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 "intl.h"
  93 #include "langhooks.h"
  94 #include "langhooks-def.h"
  95
  96 /* VMS-specific definitions */
  97 #ifdef VMS
  98 #include <descrip.h>
  99 #define O_RDONLY        0       /* Open arg for Read/Only  */
 100 #define O_WRONLY        1       /* Open arg for Write/Only */
 101 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 102 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 103 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 104 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 105 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 106 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 107 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 108 static int VMS_fstat (), VMS_stat ();
 109 static char * VMS_strncat ();
 110 static int VMS_read ();
 111 static int VMS_write ();
 112 static int VMS_open ();
 113 static FILE * VMS_fopen ();
 114 static FILE * VMS_freopen ();
 115 static void hack_vms_include_specification ();
 116 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 117 #define ino_t vms_ino_t
 118 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 119 #endif /* VMS */
 120
 121 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 122 #include "com.h"
 123 #include "bad.h"
 124 #include "bld.h"
 125 #include "equiv.h"
 126 #include "expr.h"
 127 #include "implic.h"
 128 #include "info.h"
 129 #include "malloc.h"
 130 #include "src.h"
 131 #include "st.h"
 132 #include "storag.h"
 133 #include "symbol.h"
 134 #include "target.h"
 135 #include "top.h"
 136 #include "type.h"
 137
 138 /* Externals defined here.  */
 139
 140 /* Stream for reading from the input file.  */
 141 FILE *finput;
 142
 143 /* These definitions parallel those in c-decl.c so that code from that
 144    module can be used pretty much as is.  Much of these defs aren't
 145    otherwise used, i.e. by g77 code per se, except some of them are used
 146    to build some of them that are.  The ones that are global (i.e. not
 147    "static") are those that ste.c and such might use (directly
 148    or by using com macros that reference them in their definitions).  */
 149
 150 tree string_type_node;
 151
 152 /* The rest of these are inventions for g77, though there might be
 153    similar things in the C front end.  As they are found, these
 154    inventions should be renamed to be canonical.  Note that only
 155    the ones currently required to be global are so.  */
 156
 157 static tree ffecom_tree_fun_type_void;
 158
 159 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 160 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 161 tree ffecom_integer_one_node;   /* " */
 162 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 163
 164 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 165    just use build_function_type and build_pointer_type on the
 166    appropriate _tree_type array element.  */
 167
 168 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 169 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 170 static tree ffecom_tree_subr_type;
 171 static tree ffecom_tree_ptr_to_subr_type;
 172 static tree ffecom_tree_blockdata_type;
 173
 174 static tree ffecom_tree_xargc_;
 175
 176 ffecomSymbol ffecom_symbol_null_
 177 =
 178 {
 179   NULL_TREE,
 180   NULL_TREE,
 181   NULL_TREE,
 182   NULL_TREE,
 183   false
 184 };
 185 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 186 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 187
 188 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 189 tree ffecom_f2c_integer_type_node;
 190 tree ffecom_f2c_ptr_to_integer_type_node;
 191 tree ffecom_f2c_address_type_node;
 192 tree ffecom_f2c_real_type_node;
 193 tree ffecom_f2c_ptr_to_real_type_node;
 194 tree ffecom_f2c_doublereal_type_node;
 195 tree ffecom_f2c_complex_type_node;
 196 tree ffecom_f2c_doublecomplex_type_node;
 197 tree ffecom_f2c_longint_type_node;
 198 tree ffecom_f2c_logical_type_node;
 199 tree ffecom_f2c_flag_type_node;
 200 tree ffecom_f2c_ftnlen_type_node;
 201 tree ffecom_f2c_ftnlen_zero_node;
 202 tree ffecom_f2c_ftnlen_one_node;
 203 tree ffecom_f2c_ftnlen_two_node;
 204 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 205 tree ffecom_f2c_ftnint_type_node;
 206 tree ffecom_f2c_ptr_to_ftnint_type_node;
 207
 208 /* Simple definitions and enumerations. */
 209
 210 #ifndef FFECOM_sizeMAXSTACKITEM
 211 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 212                                            larger than this # bytes
 213                                            off stack if possible. */
 214 #endif
 215
 216 /* For systems that have large enough stacks, they should define
 217    this to 0, and here, for ease of use later on, we just undefine
 218    it if it is 0.  */
 219
 220 #if FFECOM_sizeMAXSTACKITEM == 0
 221 #undef FFECOM_sizeMAXSTACKITEM
 222 #endif
 223
 224 typedef enum
 225   {
 226     FFECOM_rttypeVOID_,
 227     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 228     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 229     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 230     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 231     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 232     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 233     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 234     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 235     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 236     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 237     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 238     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 239     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 240     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 241     FFECOM_rttype_
 242   } ffecomRttype_;
 243
 244 /* Internal typedefs. */
 245
 246 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 247
 248 /* Private include files. */
 249
 250
 251 /* Internal structure definitions. */
 252
 253 struct _ffecom_concat_list_
 254   {
 255     ffebld *exprs;
 256     int count;
 257     int max;
 258     ffetargetCharacterSize minlen;
 259     ffetargetCharacterSize maxlen;
 260   };
 261
 262 /* Static functions (internal). */
 263
 264 static void ffecom_init_decl_processing PARAMS ((void));
 265 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 266 static tree ffecom_widest_expr_type_ (ffebld list);
 267 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 268                              tree dest_size, tree source_tree,
 269                              ffebld source, bool scalar_arg);
 270 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 271                                       tree args, tree callee_commons,
 272                                       bool scalar_args);
 273 static tree ffecom_build_f2c_string_ (int i, const char *s);
 274 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 275                           bool is_f2c_complex, tree type,
 276                           tree args, tree dest_tree,
 277                           ffebld dest, bool *dest_used,
 278                           tree callee_commons, bool scalar_args, tree hook);
 279 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 280                                 bool is_f2c_complex, tree type,
 281                                 ffebld left, ffebld right,
 282                                 tree dest_tree, ffebld dest,
 283                                 bool *dest_used, tree callee_commons,
 284                                 bool scalar_args, bool ref, tree hook);
 285 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 286                                  ffebld expr, bool with_null);
 287 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 288 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 289 static ffecomConcatList_
 290   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 291                               ffebld expr,
 292                               ffetargetCharacterSize max);
 293 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 294 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 295                                                 ffetargetCharacterSize max);
 296 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 297                                   ffesymbol member, tree member_type,
 298                                   ffetargetOffset offset);
 299 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 300 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 301                           bool *dest_used, bool assignp, bool widenp);
 302 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 303                                     ffebld dest, bool *dest_used);
 304 static tree ffecom_expr_power_integer_ (ffebld expr);
 305 static void ffecom_expr_transform_ (ffebld expr);
 306 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 307 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 308                                       int code);
 309 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 310 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 311 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 312 static tree ffecom_get_external_identifier_ (ffesymbol s);
 313 static tree ffecom_get_identifier_ (const char *text);
 314 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 315                                   ffeinfoBasictype bt,
 316                                   ffeinfoKindtype kt);
 317 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 318 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 319 static tree ffecom_init_zero_ (tree decl);
 320 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 321                                      tree *maybe_tree);
 322 static tree ffecom_intrinsic_len_ (ffebld expr);
 323 static void ffecom_let_char_ (tree dest_tree,
 324                               tree dest_length,
 325                               ffetargetCharacterSize dest_size,
 326                               ffebld source);
 327 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 328 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 329 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 330 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 331                                       ffebld source);
 332 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 333                                       bool stmtfunc);
 334 static void ffecom_start_progunit_ (void);
 335 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 336 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 337 static void ffecom_transform_common_ (ffesymbol s);
 338 static void ffecom_transform_equiv_ (ffestorag st);
 339 static tree ffecom_transform_namelist_ (ffesymbol s);
 340 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 341                                        tree t);
 342 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 343                                        tree *size, tree tree);
 344 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 345                                  tree dest_tree, ffebld dest,
 346                                  bool *dest_used, tree hook);
 347 static tree ffecom_type_localvar_ (ffesymbol s,
 348                                    ffeinfoBasictype bt,
 349                                    ffeinfoKindtype kt);
 350 static tree ffecom_type_namelist_ (void);
 351 static tree ffecom_type_vardesc_ (void);
 352 static tree ffecom_vardesc_ (ffebld expr);
 353 static tree ffecom_vardesc_array_ (ffesymbol s);
 354 static tree ffecom_vardesc_dims_ (ffesymbol s);
 355 static tree ffecom_convert_narrow_ (tree type, tree expr);
 356 static tree ffecom_convert_widen_ (tree type, tree expr);
 357
 358 /* These are static functions that parallel those found in the C front
 359    end and thus have the same names.  */
 360
 361 static tree bison_rule_compstmt_ (void);
 362 static void bison_rule_pushlevel_ (void);
 363 static void delete_block (tree block);
 364 static int duplicate_decls (tree newdecl, tree olddecl);
 365 static void finish_decl (tree decl, tree init, bool is_top_level);
 366 static void finish_function (int nested);
 367 static const char *lang_printable_name (tree decl, int v);
 368 static tree lookup_name_current_level (tree name);
 369 static struct binding_level *make_binding_level (void);
 370 static void pop_f_function_context (void);
 371 static void push_f_function_context (void);
 372 static void push_parm_decl (tree parm);
 373 static tree pushdecl_top_level (tree decl);
 374 static int kept_level_p (void);
 375 static tree storedecls (tree decls);
 376 static void store_parm_decls (int is_main_program);
 377 static tree start_decl (tree decl, bool is_top_level);
 378 static void start_function (tree name, tree type, int nested, int public);
 379 static void ffecom_file_ (const char *name);
 380 static void ffecom_close_include_ (FILE *f);
 381 static int ffecom_decode_include_option_ (char *spec);
 382 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 383                                    ffewhereColumn c);
 384
 385 /* Static objects accessed by functions in this module. */
 386
 387 static ffesymbol ffecom_primary_entry_ = NULL;
 388 static ffesymbol ffecom_nested_entry_ = NULL;
 389 static ffeinfoKind ffecom_primary_entry_kind_;
 390 static bool ffecom_primary_entry_is_proc_;
 391 static tree ffecom_outer_function_decl_;
 392 static tree ffecom_previous_function_decl_;
 393 static tree ffecom_which_entrypoint_decl_;
 394 static tree ffecom_float_zero_ = NULL_TREE;
 395 static tree ffecom_float_half_ = NULL_TREE;
 396 static tree ffecom_double_zero_ = NULL_TREE;
 397 static tree ffecom_double_half_ = NULL_TREE;
 398 static tree ffecom_func_result_;/* For functions. */
 399 static tree ffecom_func_length_;/* For CHARACTER fns. */
 400 static ffebld ffecom_list_blockdata_;
 401 static ffebld ffecom_list_common_;
 402 static ffebld ffecom_master_arglist_;
 403 static ffeinfoBasictype ffecom_master_bt_;
 404 static ffeinfoKindtype ffecom_master_kt_;
 405 static ffetargetCharacterSize ffecom_master_size_;
 406 static int ffecom_num_fns_ = 0;
 407 static int ffecom_num_entrypoints_ = 0;
 408 static bool ffecom_is_altreturning_ = FALSE;
 409 static tree ffecom_multi_type_node_;
 410 static tree ffecom_multi_retval_;
 411 static tree
 412   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 413 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 414 static bool ffecom_doing_entry_ = FALSE;
 415 static bool ffecom_transform_only_dummies_ = FALSE;
 416 static int ffecom_typesize_pointer_;
 417 static int ffecom_typesize_integer1_;
 418
 419 /* Holds pointer-to-function expressions.  */
 420
 421 static tree ffecom_gfrt_[FFECOM_gfrt]
 422 =
 423 {
 424 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 425 #include "com-rt.def"
 426 #undef DEFGFRT
 427 };
 428
 429 /* Holds the external names of the functions.  */
 430
 431 static const char *const ffecom_gfrt_name_[FFECOM_gfrt]
 432 =
 433 {
 434 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 435 #include "com-rt.def"
 436 #undef DEFGFRT
 437 };
 438
 439 /* Whether the function returns.  */
 440
 441 static const bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 442 =
 443 {
 444 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 445 #include "com-rt.def"
 446 #undef DEFGFRT
 447 };
 448
 449 /* Whether the function returns type complex.  */
 450
 451 static const bool ffecom_gfrt_complex_[FFECOM_gfrt]
 452 =
 453 {
 454 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 455 #include "com-rt.def"
 456 #undef DEFGFRT
 457 };
 458
 459 /* Whether the function is const
 460    (i.e., has no side effects and only depends on its arguments).  */
 461
 462 static const bool ffecom_gfrt_const_[FFECOM_gfrt]
 463 =
 464 {
 465 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 466 #include "com-rt.def"
 467 #undef DEFGFRT
 468 };
 469
 470 /* Type code for the function return value.  */
 471
 472 static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 473 =
 474 {
 475 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 476 #include "com-rt.def"
 477 #undef DEFGFRT
 478 };
 479
 480 /* String of codes for the function's arguments.  */
 481
 482 static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
 483 =
 484 {
 485 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 486 #include "com-rt.def"
 487 #undef DEFGFRT
 488 };
 489
 490 /* Internal macros. */
 491
 492 /* We let tm.h override the types used here, to handle trivial differences
 493    such as the choice of unsigned int or long unsigned int for size_t.
 494    When machines start needing nontrivial differences in the size type,
 495    it would be best to do something here to figure out automatically
 496    from other information what type to use.  */
 497
 498 #ifndef SIZE_TYPE
 499 #define SIZE_TYPE "long unsigned int"
 500 #endif
 501
 502 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 503 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 504 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 505 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 506
 507 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 508 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 509
 510 /* For each binding contour we allocate a binding_level structure
 511  * which records the names defined in that contour.
 512  * Contours include:
 513  *  0) the global one
 514  *  1) one for each function definition,
 515  *     where internal declarations of the parameters appear.
 516  *
 517  * The current meaning of a name can be found by searching the levels from
 518  * the current one out to the global one.
 519  */
 520
 521 /* Note that the information in the `names' component of the global contour
 522    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 523
 524 struct binding_level
 525   {
 526     /* A chain of _DECL nodes for all variables, constants, functions,
 527        and typedef types.  These are in the reverse of the order supplied.
 528      */
 529     tree names;
 530
 531     /* For each level (except not the global one),
 532        a chain of BLOCK nodes for all the levels
 533        that were entered and exited one level down.  */
 534     tree blocks;
 535
 536     /* The BLOCK node for this level, if one has been preallocated.
 537        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 538     tree this_block;
 539
 540     /* The binding level which this one is contained in (inherits from).  */
 541     struct binding_level *level_chain;
 542
 543     /* 0: no ffecom_prepare_* functions called at this level yet;
 544        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 545        2: ffecom_prepare_end called.  */
 546     int prep_state;
 547   };
 548
 549 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 550
 551 /* The binding level currently in effect.  */
 552
 553 static struct binding_level *current_binding_level;
 554
 555 /* A chain of binding_level structures awaiting reuse.  */
 556
 557 static struct binding_level *free_binding_level;
 558
 559 /* The outermost binding level, for names of file scope.
 560    This is created when the compiler is started and exists
 561    through the entire run.  */
 562
 563 static struct binding_level *global_binding_level;
 564
 565 /* Binding level structures are initialized by copying this one.  */
 566
 567 static const struct binding_level clear_binding_level
 568 =
 569 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 570
 571 /* Language-dependent contents of an identifier.  */
 572
 573 struct lang_identifier
 574   {
 575     struct tree_identifier ignore;
 576     tree global_value, local_value, label_value;
 577     bool invented;
 578   };
 579
 580 /* Macros for access to language-specific slots in an identifier.  */
 581 /* Each of these slots contains a DECL node or null.  */
 582
 583 /* This represents the value which the identifier has in the
 584    file-scope namespace.  */
 585 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 586   (((struct lang_identifier *)(NODE))->global_value)
 587 /* This represents the value which the identifier has in the current
 588    scope.  */
 589 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 590   (((struct lang_identifier *)(NODE))->local_value)
 591 /* This represents the value which the identifier has as a label in
 592    the current label scope.  */
 593 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 594   (((struct lang_identifier *)(NODE))->label_value)
 595 /* This is nonzero if the identifier was "made up" by g77 code.  */
 596 #define IDENTIFIER_INVENTED(NODE)       \
 597   (((struct lang_identifier *)(NODE))->invented)
 598
 599 /* In identifiers, C uses the following fields in a special way:
 600    TREE_PUBLIC        to record that there was a previous local extern decl.
 601    TREE_USED          to record that such a decl was used.
 602    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 603
 604 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 605    that have names.  Here so we can clear out their names' definitions
 606    at the end of the function.  */
 607
 608 static tree named_labels;
 609
 610 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 611
 612 static tree shadowed_labels;
 613 \f
 614 /* Return the subscript expression, modified to do range-checking.
 615
 616    `array' is the array to be checked against.
 617    `element' is the subscript expression to check.
 618    `dim' is the dimension number (starting at 0).
 619    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 620 */
 621
 622 static tree
 623 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 624                          const char *array_name)
 625 {
 626   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 627   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 628   tree cond;
 629   tree die;
 630   tree args;
 631
 632   if (element == error_mark_node)
 633     return element;
 634
 635   if (TREE_TYPE (low) != TREE_TYPE (element))
 636     {
 637       if (TYPE_PRECISION (TREE_TYPE (low))
 638           > TYPE_PRECISION (TREE_TYPE (element)))
 639         element = convert (TREE_TYPE (low), element);
 640       else
 641         {
 642           low = convert (TREE_TYPE (element), low);
 643           if (high)
 644             high = convert (TREE_TYPE (element), high);
 645         }
 646     }
 647
 648   element = ffecom_save_tree (element);
 649   if (total_dims == 0)
 650     {
 651       /* Special handling for substring range checks.  Fortran allows the
 652          end subscript < begin subscript, which means that expressions like
 653        string(1:0) are valid (and yield a null string).  In view of this,
 654        enforce two simpler conditions:
 655           1) element<=high for end-substring;
 656           2) element>=low for start-substring.
 657        Run-time character movement will enforce remaining conditions.
 658
 659        More complicated checks would be better, but present structure only
 660        provides one index element at a time, so it is not possible to
 661        enforce a check of both i and j in string(i:j).  If it were, the
 662        complete set of rules would read,
 663          if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
 664               ((low<=i<=high) && (low<=j<=high)) )
 665            ok ;
 666          else
 667            range error ;
 668       */
 669       if (dim)
 670         cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
 671       else
 672         cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
 673     }
 674   else
 675     {
 676       /* Array reference substring range checking.  */
 677
 678       cond = ffecom_2 (LE_EXPR, integer_type_node,
 679                      low,
 680                      element);
 681       if (high)
 682         {
 683           cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 684                          cond,
 685                          ffecom_2 (LE_EXPR, integer_type_node,
 686                                    element,
 687                                    high));
 688         }
 689     }
 690
 691   {
 692     int len;
 693     char *proc;
 694     char *var;
 695     tree arg3;
 696     tree arg2;
 697     tree arg1;
 698     tree arg4;
 699
 700     switch (total_dims)
 701       {
 702       case 0:
 703         var = concat (array_name, "[", (dim ? "end" : "start"),
 704                       "-substring]", NULL);
 705         len = strlen (var) + 1;
 706         arg1 = build_string (len, var);
 707         free (var);
 708         break;
 709
 710       case 1:
 711         len = strlen (array_name) + 1;
 712         arg1 = build_string (len, array_name);
 713         break;
 714
 715       default:
 716         var = xmalloc (strlen (array_name) + 40);
 717         sprintf (var, "%s[subscript-%d-of-%d]",
 718                  array_name,
 719                  dim + 1, total_dims);
 720         len = strlen (var) + 1;
 721         arg1 = build_string (len, var);
 722         free (var);
 723         break;
 724       }
 725
 726     TREE_TYPE (arg1)
 727       = build_type_variant (build_array_type (char_type_node,
 728                                               build_range_type
 729                                               (integer_type_node,
 730                                                integer_one_node,
 731                                                build_int_2 (len, 0))),
 732                             1, 0);
 733     TREE_CONSTANT (arg1) = 1;
 734     TREE_STATIC (arg1) = 1;
 735     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 736                      arg1);
 737
 738     /* s_rnge adds one to the element to print it, so bias against
 739        that -- want to print a faithful *subscript* value.  */
 740     arg2 = convert (ffecom_f2c_ftnint_type_node,
 741                     ffecom_2 (MINUS_EXPR,
 742                               TREE_TYPE (element),
 743                               element,
 744                               convert (TREE_TYPE (element),
 745                                        integer_one_node)));
 746
 747     proc = concat (input_filename, "/",
 748                    IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
 749                    NULL);
 750     len = strlen (proc) + 1;
 751     arg3 = build_string (len, proc);
 752
 753     free (proc);
 754
 755     TREE_TYPE (arg3)
 756       = build_type_variant (build_array_type (char_type_node,
 757                                               build_range_type
 758                                               (integer_type_node,
 759                                                integer_one_node,
 760                                                build_int_2 (len, 0))),
 761                             1, 0);
 762     TREE_CONSTANT (arg3) = 1;
 763     TREE_STATIC (arg3) = 1;
 764     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 765                      arg3);
 766
 767     arg4 = convert (ffecom_f2c_ftnint_type_node,
 768                     build_int_2 (lineno, 0));
 769
 770     arg1 = build_tree_list (NULL_TREE, arg1);
 771     arg2 = build_tree_list (NULL_TREE, arg2);
 772     arg3 = build_tree_list (NULL_TREE, arg3);
 773     arg4 = build_tree_list (NULL_TREE, arg4);
 774     TREE_CHAIN (arg3) = arg4;
 775     TREE_CHAIN (arg2) = arg3;
 776     TREE_CHAIN (arg1) = arg2;
 777
 778     args = arg1;
 779   }
 780   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 781                           args, NULL_TREE);
 782   TREE_SIDE_EFFECTS (die) = 1;
 783
 784   element = ffecom_3 (COND_EXPR,
 785                       TREE_TYPE (element),
 786                       cond,
 787                       element,
 788                       die);
 789
 790   return element;
 791 }
 792
 793 /* Return the computed element of an array reference.
 794
 795    `item' is NULL_TREE, or the transformed pointer to the array.
 796    `expr' is the original opARRAYREF expression, which is transformed
 797      if `item' is NULL_TREE.
 798    `want_ptr' is non-zero if a pointer to the element, instead of
 799      the element itself, is to be returned.  */
 800
 801 static tree
 802 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 803 {
 804   ffebld dims[FFECOM_dimensionsMAX];
 805   int i;
 806   int total_dims;
 807   int flatten = ffe_is_flatten_arrays ();
 808   int need_ptr;
 809   tree array;
 810   tree element;
 811   tree tree_type;
 812   tree tree_type_x;
 813   const char *array_name;
 814   ffetype type;
 815   ffebld list;
 816
 817   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 818     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 819   else
 820     array_name = "[expr?]";
 821
 822   /* Build up ARRAY_REFs in reverse order (since we're column major
 823      here in Fortran land). */
 824
 825   for (i = 0, list = ffebld_right (expr);
 826        list != NULL;
 827        ++i, list = ffebld_trail (list))
 828     {
 829       dims[i] = ffebld_head (list);
 830       type = ffeinfo_type (ffebld_basictype (dims[i]),
 831                            ffebld_kindtype (dims[i]));
 832       if (! flatten
 833           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 834           && ffetype_size (type) > ffecom_typesize_integer1_)
 835         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 836            pointers and 32-bit integers.  Do the full 64-bit pointer
 837            arithmetic, for codes using arrays for nonstandard heap-like
 838            work.  */
 839         flatten = 1;
 840     }
 841
 842   total_dims = i;
 843
 844   need_ptr = want_ptr || flatten;
 845
 846   if (! item)
 847     {
 848       if (need_ptr)
 849         item = ffecom_ptr_to_expr (ffebld_left (expr));
 850       else
 851         item = ffecom_expr (ffebld_left (expr));
 852
 853       if (item == error_mark_node)
 854         return item;
 855
 856       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 857           && ! mark_addressable (item))
 858         return error_mark_node;
 859     }
 860
 861   if (item == error_mark_node)
 862     return item;
 863
 864   if (need_ptr)
 865     {
 866       tree min;
 867
 868       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 869            i >= 0;
 870            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 871         {
 872           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 873           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 874           if (flag_bounds_check)
 875             element = ffecom_subscript_check_ (array, element, i, total_dims,
 876                                                array_name);
 877           if (element == error_mark_node)
 878             return element;
 879
 880           /* Widen integral arithmetic as desired while preserving
 881              signedness.  */
 882           tree_type = TREE_TYPE (element);
 883           tree_type_x = tree_type;
 884           if (tree_type
 885               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 886               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 887             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 888
 889           if (TREE_TYPE (min) != tree_type_x)
 890             min = convert (tree_type_x, min);
 891           if (TREE_TYPE (element) != tree_type_x)
 892             element = convert (tree_type_x, element);
 893
 894           item = ffecom_2 (PLUS_EXPR,
 895                            build_pointer_type (TREE_TYPE (array)),
 896                            item,
 897                            size_binop (MULT_EXPR,
 898                                        size_in_bytes (TREE_TYPE (array)),
 899                                        convert (sizetype,
 900                                                 fold (build (MINUS_EXPR,
 901                                                              tree_type_x,
 902                                                              element, min)))));
 903         }
 904       if (! want_ptr)
 905         {
 906           item = ffecom_1 (INDIRECT_REF,
 907                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 908                            item);
 909         }
 910     }
 911   else
 912     {
 913       for (--i;
 914            i >= 0;
 915            --i)
 916         {
 917           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 918
 919           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 920           if (flag_bounds_check)
 921             element = ffecom_subscript_check_ (array, element, i, total_dims,
 922                                                array_name);
 923           if (element == error_mark_node)
 924             return element;
 925
 926           /* Widen integral arithmetic as desired while preserving
 927              signedness.  */
 928           tree_type = TREE_TYPE (element);
 929           tree_type_x = tree_type;
 930           if (tree_type
 931               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 932               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 933             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 934
 935           element = convert (tree_type_x, element);
 936
 937           item = ffecom_2 (ARRAY_REF,
 938                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 939                            item,
 940                            element);
 941         }
 942     }
 943
 944   return item;
 945 }
 946
 947 /* This is like gcc's stabilize_reference -- in fact, most of the code
 948    comes from that -- but it handles the situation where the reference
 949    is going to have its subparts picked at, and it shouldn't change
 950    (or trigger extra invocations of functions in the subtrees) due to
 951    this.  save_expr is a bit overzealous, because we don't need the
 952    entire thing calculated and saved like a temp.  So, for DECLs, no
 953    change is needed, because these are stable aggregates, and ARRAY_REF
 954    and such might well be stable too, but for things like calculations,
 955    we do need to calculate a snapshot of a value before picking at it.  */
 956
 957 static tree
 958 ffecom_stabilize_aggregate_ (tree ref)
 959 {
 960   tree result;
 961   enum tree_code code = TREE_CODE (ref);
 962
 963   switch (code)
 964     {
 965     case VAR_DECL:
 966     case PARM_DECL:
 967     case RESULT_DECL:
 968       /* No action is needed in this case.  */
 969       return ref;
 970
 971     case NOP_EXPR:
 972     case CONVERT_EXPR:
 973     case FLOAT_EXPR:
 974     case FIX_TRUNC_EXPR:
 975     case FIX_FLOOR_EXPR:
 976     case FIX_ROUND_EXPR:
 977     case FIX_CEIL_EXPR:
 978       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
 979       break;
 980
 981     case INDIRECT_REF:
 982       result = build_nt (INDIRECT_REF,
 983                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
 984       break;
 985
 986     case COMPONENT_REF:
 987       result = build_nt (COMPONENT_REF,
 988                          stabilize_reference (TREE_OPERAND (ref, 0)),
 989                          TREE_OPERAND (ref, 1));
 990       break;
 991
 992     case BIT_FIELD_REF:
 993       result = build_nt (BIT_FIELD_REF,
 994                          stabilize_reference (TREE_OPERAND (ref, 0)),
 995                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
 996                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
 997       break;
 998
 999     case ARRAY_REF:
1000       result = build_nt (ARRAY_REF,
1001                          stabilize_reference (TREE_OPERAND (ref, 0)),
1002                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1003       break;
1004
1005     case COMPOUND_EXPR:
1006       result = build_nt (COMPOUND_EXPR,
1007                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1008                          stabilize_reference (TREE_OPERAND (ref, 1)));
1009       break;
1010
1011     case RTL_EXPR:
1012       abort ();
1013
1014
1015     default:
1016       return save_expr (ref);
1017
1018     case ERROR_MARK:
1019       return error_mark_node;
1020     }
1021
1022   TREE_TYPE (result) = TREE_TYPE (ref);
1023   TREE_READONLY (result) = TREE_READONLY (ref);
1024   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1025   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1026
1027   return result;
1028 }
1029
1030 /* A rip-off of gcc's convert.c convert_to_complex function,
1031    reworked to handle complex implemented as C structures
1032    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1033
1034 static tree
1035 ffecom_convert_to_complex_ (tree type, tree expr)
1036 {
1037   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1038   tree subtype;
1039
1040   assert (TREE_CODE (type) == RECORD_TYPE);
1041
1042   subtype = TREE_TYPE (TYPE_FIELDS (type));
1043
1044   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1045     {
1046       expr = convert (subtype, expr);
1047       return ffecom_2 (COMPLEX_EXPR, type, expr,
1048                        convert (subtype, integer_zero_node));
1049     }
1050
1051   if (form == RECORD_TYPE)
1052     {
1053       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1054       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1055         return expr;
1056       else
1057         {
1058           expr = save_expr (expr);
1059           return ffecom_2 (COMPLEX_EXPR,
1060                            type,
1061                            convert (subtype,
1062                                     ffecom_1 (REALPART_EXPR,
1063                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1064                                               expr)),
1065                            convert (subtype,
1066                                     ffecom_1 (IMAGPART_EXPR,
1067                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1068                                               expr)));
1069         }
1070     }
1071
1072   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1073     error ("pointer value used where a complex was expected");
1074   else
1075     error ("aggregate value used where a complex was expected");
1076
1077   return ffecom_2 (COMPLEX_EXPR, type,
1078                    convert (subtype, integer_zero_node),
1079                    convert (subtype, integer_zero_node));
1080 }
1081
1082 /* Like gcc's convert(), but crashes if widening might happen.  */
1083
1084 static tree
1085 ffecom_convert_narrow_ (type, expr)
1086      tree type, expr;
1087 {
1088   register tree e = expr;
1089   register enum tree_code code = TREE_CODE (type);
1090
1091   if (type == TREE_TYPE (e)
1092       || TREE_CODE (e) == ERROR_MARK)
1093     return e;
1094   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1095     return fold (build1 (NOP_EXPR, type, e));
1096   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1097       || code == ERROR_MARK)
1098     return error_mark_node;
1099   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1100     {
1101       assert ("void value not ignored as it ought to be" == NULL);
1102       return error_mark_node;
1103     }
1104   assert (code != VOID_TYPE);
1105   if ((code != RECORD_TYPE)
1106       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1107     assert ("converting COMPLEX to REAL" == NULL);
1108   assert (code != ENUMERAL_TYPE);
1109   if (code == INTEGER_TYPE)
1110     {
1111       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1112                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1113               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1114                   && (TYPE_PRECISION (type)
1115                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1116       return fold (convert_to_integer (type, e));
1117     }
1118   if (code == POINTER_TYPE)
1119     {
1120       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1121       return fold (convert_to_pointer (type, e));
1122     }
1123   if (code == REAL_TYPE)
1124     {
1125       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1126       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1127       return fold (convert_to_real (type, e));
1128     }
1129   if (code == COMPLEX_TYPE)
1130     {
1131       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1132       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1133       return fold (convert_to_complex (type, e));
1134     }
1135   if (code == RECORD_TYPE)
1136     {
1137       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1138       /* Check that at least the first field name agrees.  */
1139       assert (DECL_NAME (TYPE_FIELDS (type))
1140               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1141       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1142               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1143       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1144           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1145         return e;
1146       return fold (ffecom_convert_to_complex_ (type, e));
1147     }
1148
1149   assert ("conversion to non-scalar type requested" == NULL);
1150   return error_mark_node;
1151 }
1152
1153 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1154
1155 static tree
1156 ffecom_convert_widen_ (type, expr)
1157      tree type, expr;
1158 {
1159   register tree e = expr;
1160   register enum tree_code code = TREE_CODE (type);
1161
1162   if (type == TREE_TYPE (e)
1163       || TREE_CODE (e) == ERROR_MARK)
1164     return e;
1165   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1166     return fold (build1 (NOP_EXPR, type, e));
1167   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1168       || code == ERROR_MARK)
1169     return error_mark_node;
1170   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1171     {
1172       assert ("void value not ignored as it ought to be" == NULL);
1173       return error_mark_node;
1174     }
1175   assert (code != VOID_TYPE);
1176   if ((code != RECORD_TYPE)
1177       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1178     assert ("narrowing COMPLEX to REAL" == NULL);
1179   assert (code != ENUMERAL_TYPE);
1180   if (code == INTEGER_TYPE)
1181     {
1182       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1183                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1184               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1185                   && (TYPE_PRECISION (type)
1186                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1187       return fold (convert_to_integer (type, e));
1188     }
1189   if (code == POINTER_TYPE)
1190     {
1191       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1192       return fold (convert_to_pointer (type, e));
1193     }
1194   if (code == REAL_TYPE)
1195     {
1196       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1197       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1198       return fold (convert_to_real (type, e));
1199     }
1200   if (code == COMPLEX_TYPE)
1201     {
1202       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1203       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1204       return fold (convert_to_complex (type, e));
1205     }
1206   if (code == RECORD_TYPE)
1207     {
1208       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1209       /* Check that at least the first field name agrees.  */
1210       assert (DECL_NAME (TYPE_FIELDS (type))
1211               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1212       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1213               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1214       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1215           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1216         return e;
1217       return fold (ffecom_convert_to_complex_ (type, e));
1218     }
1219
1220   assert ("conversion to non-scalar type requested" == NULL);
1221   return error_mark_node;
1222 }
1223
1224 /* Handles making a COMPLEX type, either the standard
1225    (but buggy?) gbe way, or the safer (but less elegant?)
1226    f2c way.  */
1227
1228 static tree
1229 ffecom_make_complex_type_ (tree subtype)
1230 {
1231   tree type;
1232   tree realfield;
1233   tree imagfield;
1234
1235   if (ffe_is_emulate_complex ())
1236     {
1237       type = make_node (RECORD_TYPE);
1238       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1239       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1240       TYPE_FIELDS (type) = realfield;
1241       layout_type (type);
1242     }
1243   else
1244     {
1245       type = make_node (COMPLEX_TYPE);
1246       TREE_TYPE (type) = subtype;
1247       layout_type (type);
1248     }
1249
1250   return type;
1251 }
1252
1253 /* Chooses either the gbe or the f2c way to build a
1254    complex constant.  */
1255
1256 static tree
1257 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1258 {
1259   tree bothparts;
1260
1261   if (ffe_is_emulate_complex ())
1262     {
1263       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1264       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1265       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1266     }
1267   else
1268     {
1269       bothparts = build_complex (type, realpart, imagpart);
1270     }
1271
1272   return bothparts;
1273 }
1274
1275 static tree
1276 ffecom_arglist_expr_ (const char *c, ffebld expr)
1277 {
1278   tree list;
1279   tree *plist = &list;
1280   tree trail = NULL_TREE;       /* Append char length args here. */
1281   tree *ptrail = &trail;
1282   tree length;
1283   ffebld exprh;
1284   tree item;
1285   bool ptr = FALSE;
1286   tree wanted = NULL_TREE;
1287   static const char zed[] = "0";
1288
1289   if (c == NULL)
1290     c = &zed[0];
1291
1292   while (expr != NULL)
1293     {
1294       if (*c != '\0')
1295         {
1296           ptr = FALSE;
1297           if (*c == '&')
1298             {
1299               ptr = TRUE;
1300               ++c;
1301             }
1302           switch (*(c++))
1303             {
1304             case '\0':
1305               ptr = TRUE;
1306               wanted = NULL_TREE;
1307               break;
1308
1309             case 'a':
1310               assert (ptr);
1311               wanted = NULL_TREE;
1312               break;
1313
1314             case 'c':
1315               wanted = ffecom_f2c_complex_type_node;
1316               break;
1317
1318             case 'd':
1319               wanted = ffecom_f2c_doublereal_type_node;
1320               break;
1321
1322             case 'e':
1323               wanted = ffecom_f2c_doublecomplex_type_node;
1324               break;
1325
1326             case 'f':
1327               wanted = ffecom_f2c_real_type_node;
1328               break;
1329
1330             case 'i':
1331               wanted = ffecom_f2c_integer_type_node;
1332               break;
1333
1334             case 'j':
1335               wanted = ffecom_f2c_longint_type_node;
1336               break;
1337
1338             default:
1339               assert ("bad argstring code" == NULL);
1340               wanted = NULL_TREE;
1341               break;
1342             }
1343         }
1344
1345       exprh = ffebld_head (expr);
1346       if (exprh == NULL)
1347         wanted = NULL_TREE;
1348
1349       if ((wanted == NULL_TREE)
1350           || (ptr
1351               && (TYPE_MODE
1352                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1353                    [ffeinfo_kindtype (ffebld_info (exprh))])
1354                    == TYPE_MODE (wanted))))
1355         *plist
1356           = build_tree_list (NULL_TREE,
1357                              ffecom_arg_ptr_to_expr (exprh,
1358                                                      &length));
1359       else
1360         {
1361           item = ffecom_arg_expr (exprh, &length);
1362           item = ffecom_convert_widen_ (wanted, item);
1363           if (ptr)
1364             {
1365               item = ffecom_1 (ADDR_EXPR,
1366                                build_pointer_type (TREE_TYPE (item)),
1367                                item);
1368             }
1369           *plist
1370             = build_tree_list (NULL_TREE,
1371                                item);
1372         }
1373
1374       plist = &TREE_CHAIN (*plist);
1375       expr = ffebld_trail (expr);
1376       if (length != NULL_TREE)
1377         {
1378           *ptrail = build_tree_list (NULL_TREE, length);
1379           ptrail = &TREE_CHAIN (*ptrail);
1380         }
1381     }
1382
1383   /* We've run out of args in the call; if the implementation expects
1384      more, supply null pointers for them, which the implementation can
1385      check to see if an arg was omitted. */
1386
1387   while (*c != '\0' && *c != '0')
1388     {
1389       if (*c == '&')
1390         ++c;
1391       else
1392         assert ("missing arg to run-time routine!" == NULL);
1393
1394       switch (*(c++))
1395         {
1396         case '\0':
1397         case 'a':
1398         case 'c':
1399         case 'd':
1400         case 'e':
1401         case 'f':
1402         case 'i':
1403         case 'j':
1404           break;
1405
1406         default:
1407           assert ("bad arg string code" == NULL);
1408           break;
1409         }
1410       *plist
1411         = build_tree_list (NULL_TREE,
1412                            null_pointer_node);
1413       plist = &TREE_CHAIN (*plist);
1414     }
1415
1416   *plist = trail;
1417
1418   return list;
1419 }
1420
1421 static tree
1422 ffecom_widest_expr_type_ (ffebld list)
1423 {
1424   ffebld item;
1425   ffebld widest = NULL;
1426   ffetype type;
1427   ffetype widest_type = NULL;
1428   tree t;
1429
1430   for (; list != NULL; list = ffebld_trail (list))
1431     {
1432       item = ffebld_head (list);
1433       if (item == NULL)
1434         continue;
1435       if ((widest != NULL)
1436           && (ffeinfo_basictype (ffebld_info (item))
1437               != ffeinfo_basictype (ffebld_info (widest))))
1438         continue;
1439       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1440                            ffeinfo_kindtype (ffebld_info (item)));
1441       if ((widest == FFEINFO_kindtypeNONE)
1442           || (ffetype_size (type)
1443               > ffetype_size (widest_type)))
1444         {
1445           widest = item;
1446           widest_type = type;
1447         }
1448     }
1449
1450   assert (widest != NULL);
1451   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1452     [ffeinfo_kindtype (ffebld_info (widest))];
1453   assert (t != NULL_TREE);
1454   return t;
1455 }
1456
1457 /* Check whether a partial overlap between two expressions is possible.
1458
1459    Can *starting* to write a portion of expr1 change the value
1460    computed (perhaps already, *partially*) by expr2?
1461
1462    Currently, this is a concern only for a COMPLEX expr1.  But if it
1463    isn't in COMMON or local EQUIVALENCE, since we don't support
1464    aliasing of arguments, it isn't a concern.  */
1465
1466 static bool
1467 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1468 {
1469   ffesymbol sym;
1470   ffestorag st;
1471
1472   switch (ffebld_op (expr1))
1473     {
1474     case FFEBLD_opSYMTER:
1475       sym = ffebld_symter (expr1);
1476       break;
1477
1478     case FFEBLD_opARRAYREF:
1479       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1480         return FALSE;
1481       sym = ffebld_symter (ffebld_left (expr1));
1482       break;
1483
1484     default:
1485       return FALSE;
1486     }
1487
1488   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1489       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1490           || ! (st = ffesymbol_storage (sym))
1491           || ! ffestorag_parent (st)))
1492     return FALSE;
1493
1494   /* It's in COMMON or local EQUIVALENCE.  */
1495
1496   return TRUE;
1497 }
1498
1499 /* Check whether dest and source might overlap.  ffebld versions of these
1500    might or might not be passed, will be NULL if not.
1501
1502    The test is really whether source_tree is modifiable and, if modified,
1503    might overlap destination such that the value(s) in the destination might
1504    change before it is finally modified.  dest_* are the canonized
1505    destination itself.  */
1506
1507 static bool
1508 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1509                  tree source_tree, ffebld source UNUSED,
1510                  bool scalar_arg)
1511 {
1512   tree source_decl;
1513   tree source_offset;
1514   tree source_size;
1515   tree t;
1516
1517   if (source_tree == NULL_TREE)
1518     return FALSE;
1519
1520   switch (TREE_CODE (source_tree))
1521     {
1522     case ERROR_MARK:
1523     case IDENTIFIER_NODE:
1524     case INTEGER_CST:
1525     case REAL_CST:
1526     case COMPLEX_CST:
1527     case STRING_CST:
1528     case CONST_DECL:
1529     case VAR_DECL:
1530     case RESULT_DECL:
1531     case FIELD_DECL:
1532     case MINUS_EXPR:
1533     case MULT_EXPR:
1534     case TRUNC_DIV_EXPR:
1535     case CEIL_DIV_EXPR:
1536     case FLOOR_DIV_EXPR:
1537     case ROUND_DIV_EXPR:
1538     case TRUNC_MOD_EXPR:
1539     case CEIL_MOD_EXPR:
1540     case FLOOR_MOD_EXPR:
1541     case ROUND_MOD_EXPR:
1542     case RDIV_EXPR:
1543     case EXACT_DIV_EXPR:
1544     case FIX_TRUNC_EXPR:
1545     case FIX_CEIL_EXPR:
1546     case FIX_FLOOR_EXPR:
1547     case FIX_ROUND_EXPR:
1548     case FLOAT_EXPR:
1549     case NEGATE_EXPR:
1550     case MIN_EXPR:
1551     case MAX_EXPR:
1552     case ABS_EXPR:
1553     case FFS_EXPR:
1554     case LSHIFT_EXPR:
1555     case RSHIFT_EXPR:
1556     case LROTATE_EXPR:
1557     case RROTATE_EXPR:
1558     case BIT_IOR_EXPR:
1559     case BIT_XOR_EXPR:
1560     case BIT_AND_EXPR:
1561     case BIT_ANDTC_EXPR:
1562     case BIT_NOT_EXPR:
1563     case TRUTH_ANDIF_EXPR:
1564     case TRUTH_ORIF_EXPR:
1565     case TRUTH_AND_EXPR:
1566     case TRUTH_OR_EXPR:
1567     case TRUTH_XOR_EXPR:
1568     case TRUTH_NOT_EXPR:
1569     case LT_EXPR:
1570     case LE_EXPR:
1571     case GT_EXPR:
1572     case GE_EXPR:
1573     case EQ_EXPR:
1574     case NE_EXPR:
1575     case COMPLEX_EXPR:
1576     case CONJ_EXPR:
1577     case REALPART_EXPR:
1578     case IMAGPART_EXPR:
1579     case LABEL_EXPR:
1580     case COMPONENT_REF:
1581       return FALSE;
1582
1583     case COMPOUND_EXPR:
1584       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1585                               TREE_OPERAND (source_tree, 1), NULL,
1586                               scalar_arg);
1587
1588     case MODIFY_EXPR:
1589       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1590                               TREE_OPERAND (source_tree, 0), NULL,
1591                               scalar_arg);
1592
1593     case CONVERT_EXPR:
1594     case NOP_EXPR:
1595     case NON_LVALUE_EXPR:
1596     case PLUS_EXPR:
1597       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1598         return TRUE;
1599
1600       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1601                                  source_tree);
1602       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1603       break;
1604
1605     case COND_EXPR:
1606       return
1607         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1608                          TREE_OPERAND (source_tree, 1), NULL,
1609                          scalar_arg)
1610           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1611                               TREE_OPERAND (source_tree, 2), NULL,
1612                               scalar_arg);
1613
1614
1615     case ADDR_EXPR:
1616       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1617                                  &source_size,
1618                                  TREE_OPERAND (source_tree, 0));
1619       break;
1620
1621     case PARM_DECL:
1622       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1623         return TRUE;
1624
1625       source_decl = source_tree;
1626       source_offset = bitsize_zero_node;
1627       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1628       break;
1629
1630     case SAVE_EXPR:
1631     case REFERENCE_EXPR:
1632     case PREDECREMENT_EXPR:
1633     case PREINCREMENT_EXPR:
1634     case POSTDECREMENT_EXPR:
1635     case POSTINCREMENT_EXPR:
1636     case INDIRECT_REF:
1637     case ARRAY_REF:
1638     case CALL_EXPR:
1639     default:
1640       return TRUE;
1641     }
1642
1643   /* Come here when source_decl, source_offset, and source_size filled
1644      in appropriately.  */
1645
1646   if (source_decl == NULL_TREE)
1647     return FALSE;               /* No decl involved, so no overlap. */
1648
1649   if (source_decl != dest_decl)
1650     return FALSE;               /* Different decl, no overlap. */
1651
1652   if (TREE_CODE (dest_size) == ERROR_MARK)
1653     return TRUE;                /* Assignment into entire assumed-size
1654                                    array?  Shouldn't happen.... */
1655
1656   t = ffecom_2 (LE_EXPR, integer_type_node,
1657                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1658                           dest_offset,
1659                           convert (TREE_TYPE (dest_offset),
1660                                    dest_size)),
1661                 convert (TREE_TYPE (dest_offset),
1662                          source_offset));
1663
1664   if (integer_onep (t))
1665     return FALSE;               /* Destination precedes source. */
1666
1667   if (!scalar_arg
1668       || (source_size == NULL_TREE)
1669       || (TREE_CODE (source_size) == ERROR_MARK)
1670       || integer_zerop (source_size))
1671     return TRUE;                /* No way to tell if dest follows source. */
1672
1673   t = ffecom_2 (LE_EXPR, integer_type_node,
1674                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1675                           source_offset,
1676                           convert (TREE_TYPE (source_offset),
1677                                    source_size)),
1678                 convert (TREE_TYPE (source_offset),
1679                          dest_offset));
1680
1681   if (integer_onep (t))
1682     return FALSE;               /* Destination follows source. */
1683
1684   return TRUE;          /* Destination and source overlap. */
1685 }
1686
1687 /* Check whether dest might overlap any of a list of arguments or is
1688    in a COMMON area the callee might know about (and thus modify).  */
1689
1690 static bool
1691 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1692                           tree args, tree callee_commons,
1693                           bool scalar_args)
1694 {
1695   tree arg;
1696   tree dest_decl;
1697   tree dest_offset;
1698   tree dest_size;
1699
1700   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1701                              dest_tree);
1702
1703   if (dest_decl == NULL_TREE)
1704     return FALSE;               /* Seems unlikely! */
1705
1706   /* If the decl cannot be determined reliably, or if its in COMMON
1707      and the callee isn't known to not futz with COMMON via other
1708      means, overlap might happen.  */
1709
1710   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1711       || ((callee_commons != NULL_TREE)
1712           && TREE_PUBLIC (dest_decl)))
1713     return TRUE;
1714
1715   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1716     {
1717       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1718           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1719                               arg, NULL, scalar_args))
1720         return TRUE;
1721     }
1722
1723   return FALSE;
1724 }
1725
1726 /* Build a string for a variable name as used by NAMELIST.  This means that
1727    if we're using the f2c library, we build an uppercase string, since
1728    f2c does this.  */
1729
1730 static tree
1731 ffecom_build_f2c_string_ (int i, const char *s)
1732 {
1733   if (!ffe_is_f2c_library ())
1734     return build_string (i, s);
1735
1736   {
1737     char *tmp;
1738     const char *p;
1739     char *q;
1740     char space[34];
1741     tree t;
1742
1743     if (((size_t) i) > ARRAY_SIZE (space))
1744       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1745     else
1746       tmp = &space[0];
1747
1748     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1749       *q = TOUPPER (*p);
1750     *q = '\0';
1751
1752     t = build_string (i, tmp);
1753
1754     if (((size_t) i) > ARRAY_SIZE (space))
1755       malloc_kill_ks (malloc_pool_image (), tmp, i);
1756
1757     return t;
1758   }
1759 }
1760
1761 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1762    type to just get whatever the function returns), handling the
1763    f2c value-returning convention, if required, by prepending
1764    to the arglist a pointer to a temporary to receive the return value.  */
1765
1766 static tree
1767 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1768               tree type, tree args, tree dest_tree,
1769               ffebld dest, bool *dest_used, tree callee_commons,
1770               bool scalar_args, tree hook)
1771 {
1772   tree item;
1773   tree tempvar;
1774
1775   if (dest_used != NULL)
1776     *dest_used = FALSE;
1777
1778   if (is_f2c_complex)
1779     {
1780       if ((dest_used == NULL)
1781           || (dest == NULL)
1782           || (ffeinfo_basictype (ffebld_info (dest))
1783               != FFEINFO_basictypeCOMPLEX)
1784           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1785           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1786           || ffecom_args_overlapping_ (dest_tree, dest, args,
1787                                        callee_commons,
1788                                        scalar_args))
1789         {
1790 #ifdef HOHO
1791           tempvar = ffecom_make_tempvar (ffecom_tree_type
1792                                          [FFEINFO_basictypeCOMPLEX][kt],
1793                                          FFETARGET_charactersizeNONE,
1794                                          -1);
1795 #else
1796           tempvar = hook;
1797           assert (tempvar);
1798 #endif
1799         }
1800       else
1801         {
1802           *dest_used = TRUE;
1803           tempvar = dest_tree;
1804           type = NULL_TREE;
1805         }
1806
1807       item
1808         = build_tree_list (NULL_TREE,
1809                            ffecom_1 (ADDR_EXPR,
1810                                      build_pointer_type (TREE_TYPE (tempvar)),
1811                                      tempvar));
1812       TREE_CHAIN (item) = args;
1813
1814       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1815                         item, NULL_TREE);
1816
1817       if (tempvar != dest_tree)
1818         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1819     }
1820   else
1821     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1822                       args, NULL_TREE);
1823
1824   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1825     item = ffecom_convert_narrow_ (type, item);
1826
1827   return item;
1828 }
1829
1830 /* Given two arguments, transform them and make a call to the given
1831    function via ffecom_call_.  */
1832
1833 static tree
1834 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1835                     tree type, ffebld left, ffebld right,
1836                     tree dest_tree, ffebld dest, bool *dest_used,
1837                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1838 {
1839   tree left_tree;
1840   tree right_tree;
1841   tree left_length;
1842   tree right_length;
1843
1844   if (ref)
1845     {
1846       /* Pass arguments by reference.  */
1847       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1848       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1849     }
1850   else
1851     {
1852       /* Pass arguments by value.  */
1853       left_tree = ffecom_arg_expr (left, &left_length);
1854       right_tree = ffecom_arg_expr (right, &right_length);
1855     }
1856
1857
1858   left_tree = build_tree_list (NULL_TREE, left_tree);
1859   right_tree = build_tree_list (NULL_TREE, right_tree);
1860   TREE_CHAIN (left_tree) = right_tree;
1861
1862   if (left_length != NULL_TREE)
1863     {
1864       left_length = build_tree_list (NULL_TREE, left_length);
1865       TREE_CHAIN (right_tree) = left_length;
1866     }
1867
1868   if (right_length != NULL_TREE)
1869     {
1870       right_length = build_tree_list (NULL_TREE, right_length);
1871       if (left_length != NULL_TREE)
1872         TREE_CHAIN (left_length) = right_length;
1873       else
1874         TREE_CHAIN (right_tree) = right_length;
1875     }
1876
1877   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1878                        dest_tree, dest, dest_used, callee_commons,
1879                        scalar_args, hook);
1880 }
1881
1882 /* Return ptr/length args for char subexpression
1883
1884    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1885    subexpressions by constructing the appropriate trees for the ptr-to-
1886    character-text and length-of-character-text arguments in a calling
1887    sequence.
1888
1889    Note that if with_null is TRUE, and the expression is an opCONTER,
1890    a null byte is appended to the string.  */
1891
1892 static void
1893 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1894 {
1895   tree item;
1896   tree high;
1897   ffetargetCharacter1 val;
1898   ffetargetCharacterSize newlen;
1899
1900   switch (ffebld_op (expr))
1901     {
1902     case FFEBLD_opCONTER:
1903       val = ffebld_constant_character1 (ffebld_conter (expr));
1904       newlen = ffetarget_length_character1 (val);
1905       if (with_null)
1906         {
1907           /* Begin FFETARGET-NULL-KLUDGE.  */
1908           if (newlen != 0)
1909             ++newlen;
1910         }
1911       *length = build_int_2 (newlen, 0);
1912       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1913       high = build_int_2 (newlen, 0);
1914       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1915       item = build_string (newlen,
1916                            ffetarget_text_character1 (val));
1917       /* End FFETARGET-NULL-KLUDGE.  */
1918       TREE_TYPE (item)
1919         = build_type_variant
1920           (build_array_type
1921            (char_type_node,
1922             build_range_type
1923             (ffecom_f2c_ftnlen_type_node,
1924              ffecom_f2c_ftnlen_one_node,
1925              high)),
1926            1, 0);
1927       TREE_CONSTANT (item) = 1;
1928       TREE_STATIC (item) = 1;
1929       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1930                        item);
1931       break;
1932
1933     case FFEBLD_opSYMTER:
1934       {
1935         ffesymbol s = ffebld_symter (expr);
1936
1937         item = ffesymbol_hook (s).decl_tree;
1938         if (item == NULL_TREE)
1939           {
1940             s = ffecom_sym_transform_ (s);
1941             item = ffesymbol_hook (s).decl_tree;
1942           }
1943         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1944           {
1945             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1946               *length = ffesymbol_hook (s).length_tree;
1947             else
1948               {
1949                 *length = build_int_2 (ffesymbol_size (s), 0);
1950                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1951               }
1952           }
1953         else if (item == error_mark_node)
1954           *length = error_mark_node;
1955         else
1956           /* FFEINFO_kindFUNCTION.  */
1957           *length = NULL_TREE;
1958         if (!ffesymbol_hook (s).addr
1959             && (item != error_mark_node))
1960           item = ffecom_1 (ADDR_EXPR,
1961                            build_pointer_type (TREE_TYPE (item)),
1962                            item);
1963       }
1964       break;
1965
1966     case FFEBLD_opARRAYREF:
1967       {
1968         ffecom_char_args_ (&item, length, ffebld_left (expr));
1969
1970         if (item == error_mark_node || *length == error_mark_node)
1971           {
1972             item = *length = error_mark_node;
1973             break;
1974           }
1975
1976         item = ffecom_arrayref_ (item, expr, 1);
1977       }
1978       break;
1979
1980     case FFEBLD_opSUBSTR:
1981       {
1982         ffebld start;
1983         ffebld end;
1984         ffebld thing = ffebld_right (expr);
1985         tree start_tree;
1986         tree end_tree;
1987         const char *char_name;
1988         ffebld left_symter;
1989         tree array;
1990
1991         assert (ffebld_op (thing) == FFEBLD_opITEM);
1992         start = ffebld_head (thing);
1993         thing = ffebld_trail (thing);
1994         assert (ffebld_trail (thing) == NULL);
1995         end = ffebld_head (thing);
1996
1997         /* Determine name for pretty-printing range-check errors.  */
1998         for (left_symter = ffebld_left (expr);
1999              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2000              left_symter = ffebld_left (left_symter))
2001           ;
2002         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2003           char_name = ffesymbol_text (ffebld_symter (left_symter));
2004         else
2005           char_name = "[expr?]";
2006
2007         ffecom_char_args_ (&item, length, ffebld_left (expr));
2008
2009         if (item == error_mark_node || *length == error_mark_node)
2010           {
2011             item = *length = error_mark_node;
2012             break;
2013           }
2014
2015         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2016
2017         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2018
2019         if (start == NULL)
2020           {
2021             if (end == NULL)
2022               ;
2023             else
2024               {
2025                 end_tree = ffecom_expr (end);
2026                 if (flag_bounds_check)
2027                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2028                                                       char_name);
2029                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2030                                     end_tree);
2031
2032                 if (end_tree == error_mark_node)
2033                   {
2034                     item = *length = error_mark_node;
2035                     break;
2036                   }
2037
2038                 *length = end_tree;
2039               }
2040           }
2041         else
2042           {
2043             start_tree = ffecom_expr (start);
2044             if (flag_bounds_check)
2045               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2046                                                     char_name);
2047             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2048                                   start_tree);
2049
2050             if (start_tree == error_mark_node)
2051               {
2052                 item = *length = error_mark_node;
2053                 break;
2054               }
2055
2056             start_tree = ffecom_save_tree (start_tree);
2057
2058             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2059                              item,
2060                              ffecom_2 (MINUS_EXPR,
2061                                        TREE_TYPE (start_tree),
2062                                        start_tree,
2063                                        ffecom_f2c_ftnlen_one_node));
2064
2065             if (end == NULL)
2066               {
2067                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2068                                     ffecom_f2c_ftnlen_one_node,
2069                                     ffecom_2 (MINUS_EXPR,
2070                                               ffecom_f2c_ftnlen_type_node,
2071                                               *length,
2072                                               start_tree));
2073               }
2074             else
2075               {
2076                 end_tree = ffecom_expr (end);
2077                 if (flag_bounds_check)
2078                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2079                                                       char_name);
2080                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2081                                     end_tree);
2082
2083                 if (end_tree == error_mark_node)
2084                   {
2085                     item = *length = error_mark_node;
2086                     break;
2087                   }
2088
2089                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2090                                     ffecom_f2c_ftnlen_one_node,
2091                                     ffecom_2 (MINUS_EXPR,
2092                                               ffecom_f2c_ftnlen_type_node,
2093                                               end_tree, start_tree));
2094               }
2095           }
2096       }
2097       break;
2098
2099     case FFEBLD_opFUNCREF:
2100       {
2101         ffesymbol s = ffebld_symter (ffebld_left (expr));
2102         tree tempvar;
2103         tree args;
2104         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2105         ffecomGfrt ix;
2106
2107         if (size == FFETARGET_charactersizeNONE)
2108           /* ~~Kludge alert!  This should someday be fixed. */
2109           size = 24;
2110
2111         *length = build_int_2 (size, 0);
2112         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2113
2114         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2115             == FFEINFO_whereINTRINSIC)
2116           {
2117             if (size == 1)
2118               {
2119                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2120                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2121                                                NULL, NULL);
2122                 break;
2123               }
2124             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2125             assert (ix != FFECOM_gfrt);
2126             item = ffecom_gfrt_tree_ (ix);
2127           }
2128         else
2129           {
2130             ix = FFECOM_gfrt;
2131             item = ffesymbol_hook (s).decl_tree;
2132             if (item == NULL_TREE)
2133               {
2134                 s = ffecom_sym_transform_ (s);
2135                 item = ffesymbol_hook (s).decl_tree;
2136               }
2137             if (item == error_mark_node)
2138               {
2139                 item = *length = error_mark_node;
2140                 break;
2141               }
2142
2143             if (!ffesymbol_hook (s).addr)
2144               item = ffecom_1_fn (item);
2145           }
2146
2147 #ifdef HOHO
2148         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2149 #else
2150         tempvar = ffebld_nonter_hook (expr);
2151         assert (tempvar);
2152 #endif
2153         tempvar = ffecom_1 (ADDR_EXPR,
2154                             build_pointer_type (TREE_TYPE (tempvar)),
2155                             tempvar);
2156
2157         args = build_tree_list (NULL_TREE, tempvar);
2158
2159         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2160           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2161         else
2162           {
2163             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2164             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2165               {
2166                 TREE_CHAIN (TREE_CHAIN (args))
2167                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2168                                           ffebld_right (expr));
2169               }
2170             else
2171               {
2172                 TREE_CHAIN (TREE_CHAIN (args))
2173                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2174               }
2175           }
2176
2177         item = ffecom_3s (CALL_EXPR,
2178                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2179                           item, args, NULL_TREE);
2180         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2181                          tempvar);
2182       }
2183       break;
2184
2185     case FFEBLD_opCONVERT:
2186
2187       ffecom_char_args_ (&item, length, ffebld_left (expr));
2188
2189       if (item == error_mark_node || *length == error_mark_node)
2190         {
2191           item = *length = error_mark_node;
2192           break;
2193         }
2194
2195       if ((ffebld_size_known (ffebld_left (expr))
2196            == FFETARGET_charactersizeNONE)
2197           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2198         {                       /* Possible blank-padding needed, copy into
2199                                    temporary. */
2200           tree tempvar;
2201           tree args;
2202           tree newlen;
2203
2204 #ifdef HOHO
2205           tempvar = ffecom_make_tempvar (char_type_node,
2206                                          ffebld_size (expr), -1);
2207 #else
2208           tempvar = ffebld_nonter_hook (expr);
2209           assert (tempvar);
2210 #endif
2211           tempvar = ffecom_1 (ADDR_EXPR,
2212                               build_pointer_type (TREE_TYPE (tempvar)),
2213                               tempvar);
2214
2215           newlen = build_int_2 (ffebld_size (expr), 0);
2216           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2217
2218           args = build_tree_list (NULL_TREE, tempvar);
2219           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2220           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2221           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2222             = build_tree_list (NULL_TREE, *length);
2223
2224           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2225           TREE_SIDE_EFFECTS (item) = 1;
2226           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2227                            tempvar);
2228           *length = newlen;
2229         }
2230       else
2231         {                       /* Just truncate the length. */
2232           *length = build_int_2 (ffebld_size (expr), 0);
2233           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2234         }
2235       break;
2236
2237     default:
2238       assert ("bad op for single char arg expr" == NULL);
2239       item = NULL_TREE;
2240       break;
2241     }
2242
2243   *xitem = item;
2244 }
2245
2246 /* Check the size of the type to be sure it doesn't overflow the
2247    "portable" capacities of the compiler back end.  `dummy' types
2248    can generally overflow the normal sizes as long as the computations
2249    themselves don't overflow.  A particular target of the back end
2250    must still enforce its size requirements, though, and the back
2251    end takes care of this in stor-layout.c.  */
2252
2253 static tree
2254 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2255 {
2256   if (TREE_CODE (type) == ERROR_MARK)
2257     return type;
2258
2259   if (TYPE_SIZE (type) == NULL_TREE)
2260     return type;
2261
2262   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2263     return type;
2264
2265   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2266       || (!dummy && TREE_OVERFLOW (TYPE_SIZE (type))))
2267     {
2268       ffebad_start (FFEBAD_ARRAY_LARGE);
2269       ffebad_string (ffesymbol_text (s));
2270       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2271       ffebad_finish ();
2272
2273       return error_mark_node;
2274     }
2275
2276   return type;
2277 }
2278
2279 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2280    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2281    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2282
2283 static tree
2284 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2285 {
2286   ffetargetCharacterSize sz = ffesymbol_size (s);
2287   tree highval;
2288   tree tlen;
2289   tree type = *xtype;
2290
2291   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2292     tlen = NULL_TREE;           /* A statement function, no length passed. */
2293   else
2294     {
2295       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2296         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2297                                                ffesymbol_text (s));
2298       else
2299         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2300       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2301       DECL_ARTIFICIAL (tlen) = 1;
2302     }
2303
2304   if (sz == FFETARGET_charactersizeNONE)
2305     {
2306       assert (tlen != NULL_TREE);
2307       highval = variable_size (tlen);
2308     }
2309   else
2310     {
2311       highval = build_int_2 (sz, 0);
2312       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2313     }
2314
2315   type = build_array_type (type,
2316                            build_range_type (ffecom_f2c_ftnlen_type_node,
2317                                              ffecom_f2c_ftnlen_one_node,
2318                                              highval));
2319
2320   *xtype = type;
2321   return tlen;
2322 }
2323
2324 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2325
2326    ffecomConcatList_ catlist;
2327    ffebld expr;  // expr of CHARACTER basictype.
2328    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2329    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2330
2331    Scans expr for character subexpressions, updates and returns catlist
2332    accordingly.  */
2333
2334 static ffecomConcatList_
2335 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2336                             ffetargetCharacterSize max)
2337 {
2338   ffetargetCharacterSize sz;
2339
2340  recurse:
2341
2342   if (expr == NULL)
2343     return catlist;
2344
2345   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2346     return catlist;             /* Don't append any more items. */
2347
2348   switch (ffebld_op (expr))
2349     {
2350     case FFEBLD_opCONTER:
2351     case FFEBLD_opSYMTER:
2352     case FFEBLD_opARRAYREF:
2353     case FFEBLD_opFUNCREF:
2354     case FFEBLD_opSUBSTR:
2355     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2356                                    if they don't need to preserve it. */
2357       if (catlist.count == catlist.max)
2358         {                       /* Make a (larger) list. */
2359           ffebld *newx;
2360           int newmax;
2361
2362           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2363           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2364                                 newmax * sizeof (newx[0]));
2365           if (catlist.max != 0)
2366             {
2367               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2368               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2369                               catlist.max * sizeof (newx[0]));
2370             }
2371           catlist.max = newmax;
2372           catlist.exprs = newx;
2373         }
2374       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2375         catlist.minlen += sz;
2376       else
2377         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2378       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2379         catlist.maxlen = sz;
2380       else
2381         catlist.maxlen += sz;
2382       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2383         {                       /* This item overlaps (or is beyond) the end
2384                                    of the destination. */
2385           switch (ffebld_op (expr))
2386             {
2387             case FFEBLD_opCONTER:
2388             case FFEBLD_opSYMTER:
2389             case FFEBLD_opARRAYREF:
2390             case FFEBLD_opFUNCREF:
2391             case FFEBLD_opSUBSTR:
2392               /* ~~Do useful truncations here. */
2393               break;
2394
2395             default:
2396               assert ("op changed or inconsistent switches!" == NULL);
2397               break;
2398             }
2399         }
2400       catlist.exprs[catlist.count++] = expr;
2401       return catlist;
2402
2403     case FFEBLD_opPAREN:
2404       expr = ffebld_left (expr);
2405       goto recurse;             /* :::::::::::::::::::: */
2406
2407     case FFEBLD_opCONCATENATE:
2408       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2409       expr = ffebld_right (expr);
2410       goto recurse;             /* :::::::::::::::::::: */
2411
2412 #if 0                           /* Breaks passing small actual arg to larger
2413                                    dummy arg of sfunc */
2414     case FFEBLD_opCONVERT:
2415       expr = ffebld_left (expr);
2416       {
2417         ffetargetCharacterSize cmax;
2418
2419         cmax = catlist.len + ffebld_size_known (expr);
2420
2421         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2422           max = cmax;
2423       }
2424       goto recurse;             /* :::::::::::::::::::: */
2425 #endif
2426
2427     case FFEBLD_opANY:
2428       return catlist;
2429
2430     default:
2431       assert ("bad op in _gather_" == NULL);
2432       return catlist;
2433     }
2434 }
2435
2436 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2437
2438    ffecomConcatList_ catlist;
2439    ffecom_concat_list_kill_(catlist);
2440
2441    Anything allocated within the list info is deallocated.  */
2442
2443 static void
2444 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2445 {
2446   if (catlist.max != 0)
2447     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2448                     catlist.max * sizeof (catlist.exprs[0]));
2449 }
2450
2451 /* Make list of concatenated string exprs.
2452
2453    Returns a flattened list of concatenated subexpressions given a
2454    tree of such expressions.  */
2455
2456 static ffecomConcatList_
2457 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2458 {
2459   ffecomConcatList_ catlist;
2460
2461   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2462   return ffecom_concat_list_gather_ (catlist, expr, max);
2463 }
2464
2465 /* Provide some kind of useful info on member of aggregate area,
2466    since current g77/gcc technology does not provide debug info
2467    on these members.  */
2468
2469 static void
2470 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2471                       tree member_type UNUSED, ffetargetOffset offset)
2472 {
2473   tree value;
2474   tree decl;
2475   int len;
2476   char *buff;
2477   char space[120];
2478 #if 0
2479   tree type_id;
2480
2481   for (type_id = member_type;
2482        TREE_CODE (type_id) != IDENTIFIER_NODE;
2483        )
2484     {
2485       switch (TREE_CODE (type_id))
2486         {
2487         case INTEGER_TYPE:
2488         case REAL_TYPE:
2489           type_id = TYPE_NAME (type_id);
2490           break;
2491
2492         case ARRAY_TYPE:
2493         case COMPLEX_TYPE:
2494           type_id = TREE_TYPE (type_id);
2495           break;
2496
2497         default:
2498           assert ("no IDENTIFIER_NODE for type!" == NULL);
2499           type_id = error_mark_node;
2500           break;
2501         }
2502     }
2503 #endif
2504
2505   if (ffecom_transform_only_dummies_
2506       || !ffe_is_debug_kludge ())
2507     return;     /* Can't do this yet, maybe later. */
2508
2509   len = 60
2510     + strlen (aggr_type)
2511     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2512 #if 0
2513     + IDENTIFIER_LENGTH (type_id);
2514 #endif
2515
2516   if (((size_t) len) >= ARRAY_SIZE (space))
2517     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2518   else
2519     buff = &space[0];
2520
2521   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2522            aggr_type,
2523            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2524            (long int) offset);
2525
2526   value = build_string (len, buff);
2527   TREE_TYPE (value)
2528     = build_type_variant (build_array_type (char_type_node,
2529                                             build_range_type
2530                                             (integer_type_node,
2531                                              integer_one_node,
2532                                              build_int_2 (strlen (buff), 0))),
2533                           1, 0);
2534   decl = build_decl (VAR_DECL,
2535                      ffecom_get_identifier_ (ffesymbol_text (member)),
2536                      TREE_TYPE (value));
2537   TREE_CONSTANT (decl) = 1;
2538   TREE_STATIC (decl) = 1;
2539   DECL_INITIAL (decl) = error_mark_node;
2540   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2541   decl = start_decl (decl, FALSE);
2542   finish_decl (decl, value, FALSE);
2543
2544   if (buff != &space[0])
2545     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2546 }
2547
2548 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2549
2550    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2551    int i;  // entry# for this entrypoint (used by master fn)
2552    ffecom_do_entrypoint_(s,i);
2553
2554    Makes a public entry point that calls our private master fn (already
2555    compiled).  */
2556
2557 static void
2558 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2559 {
2560   ffebld item;
2561   tree type;                    /* Type of function. */
2562   tree multi_retval;            /* Var holding return value (union). */
2563   tree result;                  /* Var holding result. */
2564   ffeinfoBasictype bt;
2565   ffeinfoKindtype kt;
2566   ffeglobal g;
2567   ffeglobalType gt;
2568   bool charfunc;                /* All entry points return same type
2569                                    CHARACTER. */
2570   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2571   bool multi;                   /* Master fn has multiple return types. */
2572   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2573   int old_lineno = lineno;
2574   const char *old_input_filename = input_filename;
2575
2576   input_filename = ffesymbol_where_filename (fn);
2577   lineno = ffesymbol_where_filelinenum (fn);
2578
2579   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2580
2581   switch (ffecom_primary_entry_kind_)
2582     {
2583     case FFEINFO_kindFUNCTION:
2584
2585       /* Determine actual return type for function. */
2586
2587       gt = FFEGLOBAL_typeFUNC;
2588       bt = ffesymbol_basictype (fn);
2589       kt = ffesymbol_kindtype (fn);
2590       if (bt == FFEINFO_basictypeNONE)
2591         {
2592           ffeimplic_establish_symbol (fn);
2593           if (ffesymbol_funcresult (fn) != NULL)
2594             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2595           bt = ffesymbol_basictype (fn);
2596           kt = ffesymbol_kindtype (fn);
2597         }
2598
2599       if (bt == FFEINFO_basictypeCHARACTER)
2600         charfunc = TRUE, cmplxfunc = FALSE;
2601       else if ((bt == FFEINFO_basictypeCOMPLEX)
2602                && ffesymbol_is_f2c (fn))
2603         charfunc = FALSE, cmplxfunc = TRUE;
2604       else
2605         charfunc = cmplxfunc = FALSE;
2606
2607       if (charfunc)
2608         type = ffecom_tree_fun_type_void;
2609       else if (ffesymbol_is_f2c (fn))
2610         type = ffecom_tree_fun_type[bt][kt];
2611       else
2612         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2613
2614       if ((type == NULL_TREE)
2615           || (TREE_TYPE (type) == NULL_TREE))
2616         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2617
2618       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2619       break;
2620
2621     case FFEINFO_kindSUBROUTINE:
2622       gt = FFEGLOBAL_typeSUBR;
2623       bt = FFEINFO_basictypeNONE;
2624       kt = FFEINFO_kindtypeNONE;
2625       if (ffecom_is_altreturning_)
2626         {                       /* Am _I_ altreturning? */
2627           for (item = ffesymbol_dummyargs (fn);
2628                item != NULL;
2629                item = ffebld_trail (item))
2630             {
2631               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2632                 {
2633                   altreturning = TRUE;
2634                   break;
2635                 }
2636             }
2637           if (altreturning)
2638             type = ffecom_tree_subr_type;
2639           else
2640             type = ffecom_tree_fun_type_void;
2641         }
2642       else
2643         type = ffecom_tree_fun_type_void;
2644       charfunc = FALSE;
2645       cmplxfunc = FALSE;
2646       multi = FALSE;
2647       break;
2648
2649     default:
2650       assert ("say what??" == NULL);
2651       /* Fall through. */
2652     case FFEINFO_kindANY:
2653       gt = FFEGLOBAL_typeANY;
2654       bt = FFEINFO_basictypeNONE;
2655       kt = FFEINFO_kindtypeNONE;
2656       type = error_mark_node;
2657       charfunc = FALSE;
2658       cmplxfunc = FALSE;
2659       multi = FALSE;
2660       break;
2661     }
2662
2663   /* build_decl uses the current lineno and input_filename to set the decl
2664      source info.  So, I've putzed with ffestd and ffeste code to update that
2665      source info to point to the appropriate statement just before calling
2666      ffecom_do_entrypoint (which calls this fn).  */
2667
2668   start_function (ffecom_get_external_identifier_ (fn),
2669                   type,
2670                   0,            /* nested/inline */
2671                   1);           /* TREE_PUBLIC */
2672
2673   if (((g = ffesymbol_global (fn)) != NULL)
2674       && ((ffeglobal_type (g) == gt)
2675           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2676     {
2677       ffeglobal_set_hook (g, current_function_decl);
2678     }
2679
2680   /* Reset args in master arg list so they get retransitioned. */
2681
2682   for (item = ffecom_master_arglist_;
2683        item != NULL;
2684        item = ffebld_trail (item))
2685     {
2686       ffebld arg;
2687       ffesymbol s;
2688
2689       arg = ffebld_head (item);
2690       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2691         continue;               /* Alternate return or some such thing. */
2692       s = ffebld_symter (arg);
2693       ffesymbol_hook (s).decl_tree = NULL_TREE;
2694       ffesymbol_hook (s).length_tree = NULL_TREE;
2695     }
2696
2697   /* Build dummy arg list for this entry point. */
2698
2699   if (charfunc || cmplxfunc)
2700     {                           /* Prepend arg for where result goes. */
2701       tree type;
2702       tree length;
2703
2704       if (charfunc)
2705         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2706       else
2707         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2708
2709       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2710
2711       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2712
2713       if (charfunc)
2714         length = ffecom_char_enhance_arg_ (&type, fn);
2715       else
2716         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2717
2718       type = build_pointer_type (type);
2719       result = build_decl (PARM_DECL, result, type);
2720
2721       push_parm_decl (result);
2722       ffecom_func_result_ = result;
2723
2724       if (charfunc)
2725         {
2726           push_parm_decl (length);
2727           ffecom_func_length_ = length;
2728         }
2729     }
2730   else
2731     result = DECL_RESULT (current_function_decl);
2732
2733   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2734
2735   store_parm_decls (0);
2736
2737   ffecom_start_compstmt ();
2738   /* Disallow temp vars at this level.  */
2739   current_binding_level->prep_state = 2;
2740
2741   /* Make local var to hold return type for multi-type master fn. */
2742
2743   if (multi)
2744     {
2745       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2746                                                      "multi_retval");
2747       multi_retval = build_decl (VAR_DECL, multi_retval,
2748                                  ffecom_multi_type_node_);
2749       multi_retval = start_decl (multi_retval, FALSE);
2750       finish_decl (multi_retval, NULL_TREE, FALSE);
2751     }
2752   else
2753     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2754
2755   /* Here we emit the actual code for the entry point. */
2756
2757   {
2758     ffebld list;
2759     ffebld arg;
2760     ffesymbol s;
2761     tree arglist = NULL_TREE;
2762     tree *plist = &arglist;
2763     tree prepend;
2764     tree call;
2765     tree actarg;
2766     tree master_fn;
2767
2768     /* Prepare actual arg list based on master arg list. */
2769
2770     for (list = ffecom_master_arglist_;
2771          list != NULL;
2772          list = ffebld_trail (list))
2773       {
2774         arg = ffebld_head (list);
2775         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2776           continue;
2777         s = ffebld_symter (arg);
2778         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2779             || ffesymbol_hook (s).decl_tree == error_mark_node)
2780           actarg = null_pointer_node;   /* We don't have this arg. */
2781         else
2782           actarg = ffesymbol_hook (s).decl_tree;
2783         *plist = build_tree_list (NULL_TREE, actarg);
2784         plist = &TREE_CHAIN (*plist);
2785       }
2786
2787     /* This code appends the length arguments for character
2788        variables/arrays.  */
2789
2790     for (list = ffecom_master_arglist_;
2791          list != NULL;
2792          list = ffebld_trail (list))
2793       {
2794         arg = ffebld_head (list);
2795         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2796           continue;
2797         s = ffebld_symter (arg);
2798         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2799           continue;             /* Only looking for CHARACTER arguments. */
2800         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2801           continue;             /* Only looking for variables and arrays. */
2802         if (ffesymbol_hook (s).length_tree == NULL_TREE
2803             || ffesymbol_hook (s).length_tree == error_mark_node)
2804           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2805         else
2806           actarg = ffesymbol_hook (s).length_tree;
2807         *plist = build_tree_list (NULL_TREE, actarg);
2808         plist = &TREE_CHAIN (*plist);
2809       }
2810
2811     /* Prepend character-value return info to actual arg list. */
2812
2813     if (charfunc)
2814       {
2815         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2816         TREE_CHAIN (prepend)
2817           = build_tree_list (NULL_TREE, ffecom_func_length_);
2818         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2819         arglist = prepend;
2820       }
2821
2822     /* Prepend multi-type return value to actual arg list. */
2823
2824     if (multi)
2825       {
2826         prepend
2827           = build_tree_list (NULL_TREE,
2828                              ffecom_1 (ADDR_EXPR,
2829                               build_pointer_type (TREE_TYPE (multi_retval)),
2830                                        multi_retval));
2831         TREE_CHAIN (prepend) = arglist;
2832         arglist = prepend;
2833       }
2834
2835     /* Prepend my entry-point number to the actual arg list. */
2836
2837     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2838     TREE_CHAIN (prepend) = arglist;
2839     arglist = prepend;
2840
2841     /* Build the call to the master function. */
2842
2843     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2844     call = ffecom_3s (CALL_EXPR,
2845                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2846                       master_fn, arglist, NULL_TREE);
2847
2848     /* Decide whether the master function is a function or subroutine, and
2849        handle the return value for my entry point. */
2850
2851     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2852                      && !altreturning))
2853       {
2854         expand_expr_stmt (call);
2855         expand_null_return ();
2856       }
2857     else if (multi && cmplxfunc)
2858       {
2859         expand_expr_stmt (call);
2860         result
2861           = ffecom_1 (INDIRECT_REF,
2862                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2863                       result);
2864         result = ffecom_modify (NULL_TREE, result,
2865                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2866                                           multi_retval,
2867                                           ffecom_multi_fields_[bt][kt]));
2868         expand_expr_stmt (result);
2869         expand_null_return ();
2870       }
2871     else if (multi)
2872       {
2873         expand_expr_stmt (call);
2874         result
2875           = ffecom_modify (NULL_TREE, result,
2876                            convert (TREE_TYPE (result),
2877                                     ffecom_2 (COMPONENT_REF,
2878                                               ffecom_tree_type[bt][kt],
2879                                               multi_retval,
2880                                               ffecom_multi_fields_[bt][kt])));
2881         expand_return (result);
2882       }
2883     else if (cmplxfunc)
2884       {
2885         result
2886           = ffecom_1 (INDIRECT_REF,
2887                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2888                       result);
2889         result = ffecom_modify (NULL_TREE, result, call);
2890         expand_expr_stmt (result);
2891         expand_null_return ();
2892       }
2893     else
2894       {
2895         result = ffecom_modify (NULL_TREE,
2896                                 result,
2897                                 convert (TREE_TYPE (result),
2898                                          call));
2899         expand_return (result);
2900       }
2901   }
2902
2903   ffecom_end_compstmt ();
2904
2905   finish_function (0);
2906
2907   lineno = old_lineno;
2908   input_filename = old_input_filename;
2909
2910   ffecom_doing_entry_ = FALSE;
2911 }
2912
2913 /* Transform expr into gcc tree with possible destination
2914
2915    Recursive descent on expr while making corresponding tree nodes and
2916    attaching type info and such.  If destination supplied and compatible
2917    with temporary that would be made in certain cases, temporary isn't
2918    made, destination used instead, and dest_used flag set TRUE.  */
2919
2920 static tree
2921 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2922               bool *dest_used, bool assignp, bool widenp)
2923 {
2924   tree item;
2925   tree list;
2926   tree args;
2927   ffeinfoBasictype bt;
2928   ffeinfoKindtype kt;
2929   tree t;
2930   tree dt;                      /* decl_tree for an ffesymbol. */
2931   tree tree_type, tree_type_x;
2932   tree left, right;
2933   ffesymbol s;
2934   enum tree_code code;
2935
2936   assert (expr != NULL);
2937
2938   if (dest_used != NULL)
2939     *dest_used = FALSE;
2940
2941   bt = ffeinfo_basictype (ffebld_info (expr));
2942   kt = ffeinfo_kindtype (ffebld_info (expr));
2943   tree_type = ffecom_tree_type[bt][kt];
2944
2945   /* Widen integral arithmetic as desired while preserving signedness.  */
2946   tree_type_x = NULL_TREE;
2947   if (widenp && tree_type
2948       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2949       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2950     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2951
2952   switch (ffebld_op (expr))
2953     {
2954     case FFEBLD_opACCTER:
2955       {
2956         ffebitCount i;
2957         ffebit bits = ffebld_accter_bits (expr);
2958         ffetargetOffset source_offset = 0;
2959         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
2960         tree purpose;
2961
2962         assert (dest_offset == 0
2963                 || (bt == FFEINFO_basictypeCHARACTER
2964                     && kt == FFEINFO_kindtypeCHARACTER1));
2965
2966         list = item = NULL;
2967         for (;;)
2968           {
2969             ffebldConstantUnion cu;
2970             ffebitCount length;
2971             bool value;
2972             ffebldConstantArray ca = ffebld_accter (expr);
2973
2974             ffebit_test (bits, source_offset, &value, &length);
2975             if (length == 0)
2976               break;
2977
2978             if (value)
2979               {
2980                 for (i = 0; i < length; ++i)
2981                   {
2982                     cu = ffebld_constantarray_get (ca, bt, kt,
2983                                                    source_offset + i);
2984
2985                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
2986
2987                     if (i == 0
2988                         && dest_offset != 0)
2989                       purpose = build_int_2 (dest_offset, 0);
2990                     else
2991                       purpose = NULL_TREE;
2992
2993                     if (list == NULL_TREE)
2994                       list = item = build_tree_list (purpose, t);
2995                     else
2996                       {
2997                         TREE_CHAIN (item) = build_tree_list (purpose, t);
2998                         item = TREE_CHAIN (item);
2999                       }
3000                   }
3001               }
3002             source_offset += length;
3003             dest_offset += length;
3004           }
3005       }
3006
3007       item = build_int_2 ((ffebld_accter_size (expr)
3008                            + ffebld_accter_pad (expr)) - 1, 0);
3009       ffebit_kill (ffebld_accter_bits (expr));
3010       TREE_TYPE (item) = ffecom_integer_type_node;
3011       item
3012         = build_array_type
3013           (tree_type,
3014            build_range_type (ffecom_integer_type_node,
3015                              ffecom_integer_zero_node,
3016                              item));
3017       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3018       TREE_CONSTANT (list) = 1;
3019       TREE_STATIC (list) = 1;
3020       return list;
3021
3022     case FFEBLD_opARRTER:
3023       {
3024         ffetargetOffset i;
3025
3026         list = NULL_TREE;
3027         if (ffebld_arrter_pad (expr) == 0)
3028           item = NULL_TREE;
3029         else
3030           {
3031             assert (bt == FFEINFO_basictypeCHARACTER
3032                     && kt == FFEINFO_kindtypeCHARACTER1);
3033
3034             /* Becomes PURPOSE first time through loop.  */
3035             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3036           }
3037
3038         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3039           {
3040             ffebldConstantUnion cu
3041             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3042
3043             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3044
3045             if (list == NULL_TREE)
3046               /* Assume item is PURPOSE first time through loop.  */
3047               list = item = build_tree_list (item, t);
3048             else
3049               {
3050                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3051                 item = TREE_CHAIN (item);
3052               }
3053           }
3054       }
3055
3056       item = build_int_2 ((ffebld_arrter_size (expr)
3057                           + ffebld_arrter_pad (expr)) - 1, 0);
3058       TREE_TYPE (item) = ffecom_integer_type_node;
3059       item
3060         = build_array_type
3061           (tree_type,
3062            build_range_type (ffecom_integer_type_node,
3063                              ffecom_integer_zero_node,
3064                              item));
3065       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3066       TREE_CONSTANT (list) = 1;
3067       TREE_STATIC (list) = 1;
3068       return list;
3069
3070     case FFEBLD_opCONTER:
3071       assert (ffebld_conter_pad (expr) == 0);
3072       item
3073         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3074                                 bt, kt, tree_type);
3075       return item;
3076
3077     case FFEBLD_opSYMTER:
3078       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3079           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3080         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3081       s = ffebld_symter (expr);
3082       t = ffesymbol_hook (s).decl_tree;
3083
3084       if (assignp)
3085         {                       /* ASSIGN'ed-label expr. */
3086           if (ffe_is_ugly_assign ())
3087             {
3088               /* User explicitly wants ASSIGN'ed variables to be at the same
3089                  memory address as the variables when used in non-ASSIGN
3090                  contexts.  That can make old, arcane, non-standard code
3091                  work, but don't try to do it when a pointer wouldn't fit
3092                  in the normal variable (take other approach, and warn,
3093                  instead).  */
3094
3095               if (t == NULL_TREE)
3096                 {
3097                   s = ffecom_sym_transform_ (s);
3098                   t = ffesymbol_hook (s).decl_tree;
3099                   assert (t != NULL_TREE);
3100                 }
3101
3102               if (t == error_mark_node)
3103                 return t;
3104
3105               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3106                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3107                 {
3108                   if (ffesymbol_hook (s).addr)
3109                     t = ffecom_1 (INDIRECT_REF,
3110                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3111                   return t;
3112                 }
3113
3114               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3115                 {
3116                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3117                                     FFEBAD_severityWARNING);
3118                   ffebad_string (ffesymbol_text (s));
3119                   ffebad_here (0, ffesymbol_where_line (s),
3120                                ffesymbol_where_column (s));
3121                   ffebad_finish ();
3122                 }
3123             }
3124
3125           /* Don't use the normal variable's tree for ASSIGN, though mark
3126              it as in the system header (housekeeping).  Use an explicit,
3127              specially created sibling that is known to be wide enough
3128              to hold pointers to labels.  */
3129
3130           if (t != NULL_TREE
3131               && TREE_CODE (t) == VAR_DECL)
3132             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3133
3134           t = ffesymbol_hook (s).assign_tree;
3135           if (t == NULL_TREE)
3136             {
3137               s = ffecom_sym_transform_assign_ (s);
3138               t = ffesymbol_hook (s).assign_tree;
3139               assert (t != NULL_TREE);
3140             }
3141         }
3142       else
3143         {
3144           if (t == NULL_TREE)
3145             {
3146               s = ffecom_sym_transform_ (s);
3147               t = ffesymbol_hook (s).decl_tree;
3148               assert (t != NULL_TREE);
3149             }
3150           if (ffesymbol_hook (s).addr)
3151             t = ffecom_1 (INDIRECT_REF,
3152                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3153         }
3154       return t;
3155
3156     case FFEBLD_opARRAYREF:
3157       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3158
3159     case FFEBLD_opUPLUS:
3160       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3161       return ffecom_1 (NOP_EXPR, tree_type, left);
3162
3163     case FFEBLD_opPAREN:
3164       /* ~~~Make sure Fortran rules respected here */
3165       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3166       return ffecom_1 (NOP_EXPR, tree_type, left);
3167
3168     case FFEBLD_opUMINUS:
3169       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3170       if (tree_type_x)
3171         {
3172           tree_type = tree_type_x;
3173           left = convert (tree_type, left);
3174         }
3175       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3176
3177     case FFEBLD_opADD:
3178       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3179       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3180       if (tree_type_x)
3181         {
3182           tree_type = tree_type_x;
3183           left = convert (tree_type, left);
3184           right = convert (tree_type, right);
3185         }
3186       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3187
3188     case FFEBLD_opSUBTRACT:
3189       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3190       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3191       if (tree_type_x)
3192         {
3193           tree_type = tree_type_x;
3194           left = convert (tree_type, left);
3195           right = convert (tree_type, right);
3196         }
3197       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3198
3199     case FFEBLD_opMULTIPLY:
3200       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3201       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3202       if (tree_type_x)
3203         {
3204           tree_type = tree_type_x;
3205           left = convert (tree_type, left);
3206           right = convert (tree_type, right);
3207         }
3208       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3209
3210     case FFEBLD_opDIVIDE:
3211       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3212       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3213       if (tree_type_x)
3214         {
3215           tree_type = tree_type_x;
3216           left = convert (tree_type, left);
3217           right = convert (tree_type, right);
3218         }
3219       return ffecom_tree_divide_ (tree_type, left, right,
3220                                   dest_tree, dest, dest_used,
3221                                   ffebld_nonter_hook (expr));
3222
3223     case FFEBLD_opPOWER:
3224       {
3225         ffebld left = ffebld_left (expr);
3226         ffebld right = ffebld_right (expr);
3227         ffecomGfrt code;
3228         ffeinfoKindtype rtkt;
3229         ffeinfoKindtype ltkt;
3230         bool ref = TRUE;
3231
3232         switch (ffeinfo_basictype (ffebld_info (right)))
3233           {
3234
3235           case FFEINFO_basictypeINTEGER:
3236             if (1 || optimize)
3237               {
3238                 item = ffecom_expr_power_integer_ (expr);
3239                 if (item != NULL_TREE)
3240                   return item;
3241               }
3242
3243             rtkt = FFEINFO_kindtypeINTEGER1;
3244             switch (ffeinfo_basictype (ffebld_info (left)))
3245               {
3246               case FFEINFO_basictypeINTEGER:
3247                 if ((ffeinfo_kindtype (ffebld_info (left))
3248                     == FFEINFO_kindtypeINTEGER4)
3249                     || (ffeinfo_kindtype (ffebld_info (right))
3250                         == FFEINFO_kindtypeINTEGER4))
3251                   {
3252                     code = FFECOM_gfrtPOW_QQ;
3253                     ltkt = FFEINFO_kindtypeINTEGER4;
3254                     rtkt = FFEINFO_kindtypeINTEGER4;
3255                   }
3256                 else
3257                   {
3258                     code = FFECOM_gfrtPOW_II;
3259                     ltkt = FFEINFO_kindtypeINTEGER1;
3260                   }
3261                 break;
3262
3263               case FFEINFO_basictypeREAL:
3264                 if (ffeinfo_kindtype (ffebld_info (left))
3265                     == FFEINFO_kindtypeREAL1)
3266                   {
3267                     code = FFECOM_gfrtPOW_RI;
3268                     ltkt = FFEINFO_kindtypeREAL1;
3269                   }
3270                 else
3271                   {
3272                     code = FFECOM_gfrtPOW_DI;
3273                     ltkt = FFEINFO_kindtypeREAL2;
3274                   }
3275                 break;
3276
3277               case FFEINFO_basictypeCOMPLEX:
3278                 if (ffeinfo_kindtype (ffebld_info (left))
3279                     == FFEINFO_kindtypeREAL1)
3280                   {
3281                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3282                     ltkt = FFEINFO_kindtypeREAL1;
3283                   }
3284                 else
3285                   {
3286                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3287                     ltkt = FFEINFO_kindtypeREAL2;
3288                   }
3289                 break;
3290
3291               default:
3292                 assert ("bad pow_*i" == NULL);
3293                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3294                 ltkt = FFEINFO_kindtypeREAL1;
3295                 break;
3296               }
3297             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3298               left = ffeexpr_convert (left, NULL, NULL,
3299                                       ffeinfo_basictype (ffebld_info (left)),
3300                                       ltkt, 0,
3301                                       FFETARGET_charactersizeNONE,
3302                                       FFEEXPR_contextLET);
3303             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3304               right = ffeexpr_convert (right, NULL, NULL,
3305                                        FFEINFO_basictypeINTEGER,
3306                                        rtkt, 0,
3307                                        FFETARGET_charactersizeNONE,
3308                                        FFEEXPR_contextLET);
3309             break;
3310
3311           case FFEINFO_basictypeREAL:
3312             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3313               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3314                                       FFEINFO_kindtypeREALDOUBLE, 0,
3315                                       FFETARGET_charactersizeNONE,
3316                                       FFEEXPR_contextLET);
3317             if (ffeinfo_kindtype (ffebld_info (right))
3318                 == FFEINFO_kindtypeREAL1)
3319               right = ffeexpr_convert (right, NULL, NULL,
3320                                        FFEINFO_basictypeREAL,
3321                                        FFEINFO_kindtypeREALDOUBLE, 0,
3322                                        FFETARGET_charactersizeNONE,
3323                                        FFEEXPR_contextLET);
3324             /* We used to call FFECOM_gfrtPOW_DD here,
3325                which passes arguments by reference.  */
3326             code = FFECOM_gfrtL_POW;
3327             /* Pass arguments by value. */
3328             ref  = FALSE;
3329             break;
3330
3331           case FFEINFO_basictypeCOMPLEX:
3332             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3333               left = ffeexpr_convert (left, NULL, NULL,
3334                                       FFEINFO_basictypeCOMPLEX,
3335                                       FFEINFO_kindtypeREALDOUBLE, 0,
3336                                       FFETARGET_charactersizeNONE,
3337                                       FFEEXPR_contextLET);
3338             if (ffeinfo_kindtype (ffebld_info (right))
3339                 == FFEINFO_kindtypeREAL1)
3340               right = ffeexpr_convert (right, NULL, NULL,
3341                                        FFEINFO_basictypeCOMPLEX,
3342                                        FFEINFO_kindtypeREALDOUBLE, 0,
3343                                        FFETARGET_charactersizeNONE,
3344                                        FFEEXPR_contextLET);
3345             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3346             ref = TRUE;                 /* Pass arguments by reference. */
3347             break;
3348
3349           default:
3350             assert ("bad pow_x*" == NULL);
3351             code = FFECOM_gfrtPOW_II;
3352             break;
3353           }
3354         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3355                                    ffecom_gfrt_kindtype (code),
3356                                    (ffe_is_f2c_library ()
3357                                     && ffecom_gfrt_complex_[code]),
3358                                    tree_type, left, right,
3359                                    dest_tree, dest, dest_used,
3360                                    NULL_TREE, FALSE, ref,
3361                                    ffebld_nonter_hook (expr));
3362       }
3363
3364     case FFEBLD_opNOT:
3365       switch (bt)
3366         {
3367         case FFEINFO_basictypeLOGICAL:
3368           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3369           return convert (tree_type, item);
3370
3371         case FFEINFO_basictypeINTEGER:
3372           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3373                            ffecom_expr (ffebld_left (expr)));
3374
3375         default:
3376           assert ("NOT bad basictype" == NULL);
3377           /* Fall through. */
3378         case FFEINFO_basictypeANY:
3379           return error_mark_node;
3380         }
3381       break;
3382
3383     case FFEBLD_opFUNCREF:
3384       assert (ffeinfo_basictype (ffebld_info (expr))
3385               != FFEINFO_basictypeCHARACTER);
3386       /* Fall through.   */
3387     case FFEBLD_opSUBRREF:
3388       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3389           == FFEINFO_whereINTRINSIC)
3390         {                       /* Invocation of an intrinsic. */
3391           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3392                                          dest_used);
3393           return item;
3394         }
3395       s = ffebld_symter (ffebld_left (expr));
3396       dt = ffesymbol_hook (s).decl_tree;
3397       if (dt == NULL_TREE)
3398         {
3399           s = ffecom_sym_transform_ (s);
3400           dt = ffesymbol_hook (s).decl_tree;
3401         }
3402       if (dt == error_mark_node)
3403         return dt;
3404
3405       if (ffesymbol_hook (s).addr)
3406         item = dt;
3407       else
3408         item = ffecom_1_fn (dt);
3409
3410       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3411         args = ffecom_list_expr (ffebld_right (expr));
3412       else
3413         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3414
3415       if (args == error_mark_node)
3416         return error_mark_node;
3417
3418       item = ffecom_call_ (item, kt,
3419                            ffesymbol_is_f2c (s)
3420                            && (bt == FFEINFO_basictypeCOMPLEX)
3421                            && (ffesymbol_where (s)
3422                                != FFEINFO_whereCONSTANT),
3423                            tree_type,
3424                            args,
3425                            dest_tree, dest, dest_used,
3426                            error_mark_node, FALSE,
3427                            ffebld_nonter_hook (expr));
3428       TREE_SIDE_EFFECTS (item) = 1;
3429       return item;
3430
3431     case FFEBLD_opAND:
3432       switch (bt)
3433         {
3434         case FFEINFO_basictypeLOGICAL:
3435           item
3436             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3437                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3438                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3439           return convert (tree_type, item);
3440
3441         case FFEINFO_basictypeINTEGER:
3442           return ffecom_2 (BIT_AND_EXPR, tree_type,
3443                            ffecom_expr (ffebld_left (expr)),
3444                            ffecom_expr (ffebld_right (expr)));
3445
3446         default:
3447           assert ("AND bad basictype" == NULL);
3448           /* Fall through. */
3449         case FFEINFO_basictypeANY:
3450           return error_mark_node;
3451         }
3452       break;
3453
3454     case FFEBLD_opOR:
3455       switch (bt)
3456         {
3457         case FFEINFO_basictypeLOGICAL:
3458           item
3459             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3460                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3461                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3462           return convert (tree_type, item);
3463
3464         case FFEINFO_basictypeINTEGER:
3465           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3466                            ffecom_expr (ffebld_left (expr)),
3467                            ffecom_expr (ffebld_right (expr)));
3468
3469         default:
3470           assert ("OR bad basictype" == NULL);
3471           /* Fall through. */
3472         case FFEINFO_basictypeANY:
3473           return error_mark_node;
3474         }
3475       break;
3476
3477     case FFEBLD_opXOR:
3478     case FFEBLD_opNEQV:
3479       switch (bt)
3480         {
3481         case FFEINFO_basictypeLOGICAL:
3482           item
3483             = ffecom_2 (NE_EXPR, integer_type_node,
3484                         ffecom_expr (ffebld_left (expr)),
3485                         ffecom_expr (ffebld_right (expr)));
3486           return convert (tree_type, ffecom_truth_value (item));
3487
3488         case FFEINFO_basictypeINTEGER:
3489           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3490                            ffecom_expr (ffebld_left (expr)),
3491                            ffecom_expr (ffebld_right (expr)));
3492
3493         default:
3494           assert ("XOR/NEQV bad basictype" == NULL);
3495           /* Fall through. */
3496         case FFEINFO_basictypeANY:
3497           return error_mark_node;
3498         }
3499       break;
3500
3501     case FFEBLD_opEQV:
3502       switch (bt)
3503         {
3504         case FFEINFO_basictypeLOGICAL:
3505           item
3506             = ffecom_2 (EQ_EXPR, integer_type_node,
3507                         ffecom_expr (ffebld_left (expr)),
3508                         ffecom_expr (ffebld_right (expr)));
3509           return convert (tree_type, ffecom_truth_value (item));
3510
3511         case FFEINFO_basictypeINTEGER:
3512           return
3513             ffecom_1 (BIT_NOT_EXPR, tree_type,
3514                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3515                                 ffecom_expr (ffebld_left (expr)),
3516                                 ffecom_expr (ffebld_right (expr))));
3517
3518         default:
3519           assert ("EQV bad basictype" == NULL);
3520           /* Fall through. */
3521         case FFEINFO_basictypeANY:
3522           return error_mark_node;
3523         }
3524       break;
3525
3526     case FFEBLD_opCONVERT:
3527       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3528         return error_mark_node;
3529
3530       switch (bt)
3531         {
3532         case FFEINFO_basictypeLOGICAL:
3533         case FFEINFO_basictypeINTEGER:
3534         case FFEINFO_basictypeREAL:
3535           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3536
3537         case FFEINFO_basictypeCOMPLEX:
3538           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3539             {
3540             case FFEINFO_basictypeINTEGER:
3541             case FFEINFO_basictypeLOGICAL:
3542             case FFEINFO_basictypeREAL:
3543               item = ffecom_expr (ffebld_left (expr));
3544               if (item == error_mark_node)
3545                 return error_mark_node;
3546               /* convert() takes care of converting to the subtype first,
3547                  at least in gcc-2.7.2. */
3548               item = convert (tree_type, item);
3549               return item;
3550
3551             case FFEINFO_basictypeCOMPLEX:
3552               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3553
3554             default:
3555               assert ("CONVERT COMPLEX bad basictype" == NULL);
3556               /* Fall through. */
3557             case FFEINFO_basictypeANY:
3558               return error_mark_node;
3559             }
3560           break;
3561
3562         default:
3563           assert ("CONVERT bad basictype" == NULL);
3564           /* Fall through. */
3565         case FFEINFO_basictypeANY:
3566           return error_mark_node;
3567         }
3568       break;
3569
3570     case FFEBLD_opLT:
3571       code = LT_EXPR;
3572       goto relational;          /* :::::::::::::::::::: */
3573
3574     case FFEBLD_opLE:
3575       code = LE_EXPR;
3576       goto relational;          /* :::::::::::::::::::: */
3577
3578     case FFEBLD_opEQ:
3579       code = EQ_EXPR;
3580       goto relational;          /* :::::::::::::::::::: */
3581
3582     case FFEBLD_opNE:
3583       code = NE_EXPR;
3584       goto relational;          /* :::::::::::::::::::: */
3585
3586     case FFEBLD_opGT:
3587       code = GT_EXPR;
3588       goto relational;          /* :::::::::::::::::::: */
3589
3590     case FFEBLD_opGE:
3591       code = GE_EXPR;
3592
3593     relational:         /* :::::::::::::::::::: */
3594       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3595         {
3596         case FFEINFO_basictypeLOGICAL:
3597         case FFEINFO_basictypeINTEGER:
3598         case FFEINFO_basictypeREAL:
3599           item = ffecom_2 (code, integer_type_node,
3600                            ffecom_expr (ffebld_left (expr)),
3601                            ffecom_expr (ffebld_right (expr)));
3602           return convert (tree_type, item);
3603
3604         case FFEINFO_basictypeCOMPLEX:
3605           assert (code == EQ_EXPR || code == NE_EXPR);
3606           {
3607             tree real_type;
3608             tree arg1 = ffecom_expr (ffebld_left (expr));
3609             tree arg2 = ffecom_expr (ffebld_right (expr));
3610
3611             if (arg1 == error_mark_node || arg2 == error_mark_node)
3612               return error_mark_node;
3613
3614             arg1 = ffecom_save_tree (arg1);
3615             arg2 = ffecom_save_tree (arg2);
3616
3617             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3618               {
3619                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3620                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3621               }
3622             else
3623               {
3624                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3625                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3626               }
3627
3628             item
3629               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3630                           ffecom_2 (EQ_EXPR, integer_type_node,
3631                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3632                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3633                           ffecom_2 (EQ_EXPR, integer_type_node,
3634                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3635                                     ffecom_1 (IMAGPART_EXPR, real_type,
3636                                               arg2)));
3637             if (code == EQ_EXPR)
3638               item = ffecom_truth_value (item);
3639             else
3640               item = ffecom_truth_value_invert (item);
3641             return convert (tree_type, item);
3642           }
3643
3644         case FFEINFO_basictypeCHARACTER:
3645           {
3646             ffebld left = ffebld_left (expr);
3647             ffebld right = ffebld_right (expr);
3648             tree left_tree;
3649             tree right_tree;
3650             tree left_length;
3651             tree right_length;
3652
3653             /* f2c run-time functions do the implicit blank-padding for us,
3654                so we don't usually have to implement blank-padding ourselves.
3655                (The exception is when we pass an argument to a separately
3656                compiled statement function -- if we know the arg is not the
3657                same length as the dummy, we must truncate or extend it.  If
3658                we "inline" statement functions, that necessity goes away as
3659                well.)
3660
3661                Strip off the CONVERT operators that blank-pad.  (Truncation by
3662                CONVERT shouldn't happen here, but it can happen in
3663                assignments.) */
3664
3665             while (ffebld_op (left) == FFEBLD_opCONVERT)
3666               left = ffebld_left (left);
3667             while (ffebld_op (right) == FFEBLD_opCONVERT)
3668               right = ffebld_left (right);
3669
3670             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3671             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3672
3673             if (left_tree == error_mark_node || left_length == error_mark_node
3674                 || right_tree == error_mark_node
3675                 || right_length == error_mark_node)
3676               return error_mark_node;
3677
3678             if ((ffebld_size_known (left) == 1)
3679                 && (ffebld_size_known (right) == 1))
3680               {
3681                 left_tree
3682                   = ffecom_1 (INDIRECT_REF,
3683                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3684                               left_tree);
3685                 right_tree
3686                   = ffecom_1 (INDIRECT_REF,
3687                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3688                               right_tree);
3689
3690                 item
3691                   = ffecom_2 (code, integer_type_node,
3692                               ffecom_2 (ARRAY_REF,
3693                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3694                                         left_tree,
3695                                         integer_one_node),
3696                               ffecom_2 (ARRAY_REF,
3697                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3698                                         right_tree,
3699                                         integer_one_node));
3700               }
3701             else
3702               {
3703                 item = build_tree_list (NULL_TREE, left_tree);
3704                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3705                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3706                                                                left_length);
3707                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3708                   = build_tree_list (NULL_TREE, right_length);
3709                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3710                 item = ffecom_2 (code, integer_type_node,
3711                                  item,
3712                                  convert (TREE_TYPE (item),
3713                                           integer_zero_node));
3714               }
3715             item = convert (tree_type, item);
3716           }
3717
3718           return item;
3719
3720         default:
3721           assert ("relational bad basictype" == NULL);
3722           /* Fall through. */
3723         case FFEINFO_basictypeANY:
3724           return error_mark_node;
3725         }
3726       break;
3727
3728     case FFEBLD_opPERCENT_LOC:
3729       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3730       return convert (tree_type, item);
3731
3732     case FFEBLD_opITEM:
3733     case FFEBLD_opSTAR:
3734     case FFEBLD_opBOUNDS:
3735     case FFEBLD_opREPEAT:
3736     case FFEBLD_opLABTER:
3737     case FFEBLD_opLABTOK:
3738     case FFEBLD_opIMPDO:
3739     case FFEBLD_opCONCATENATE:
3740     case FFEBLD_opSUBSTR:
3741     default:
3742       assert ("bad op" == NULL);
3743       /* Fall through. */
3744     case FFEBLD_opANY:
3745       return error_mark_node;
3746     }
3747
3748 #if 1
3749   assert ("didn't think anything got here anymore!!" == NULL);
3750 #else
3751   switch (ffebld_arity (expr))
3752     {
3753     case 2:
3754       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3755       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3756       if (TREE_OPERAND (item, 0) == error_mark_node
3757           || TREE_OPERAND (item, 1) == error_mark_node)
3758         return error_mark_node;
3759       break;
3760
3761     case 1:
3762       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3763       if (TREE_OPERAND (item, 0) == error_mark_node)
3764         return error_mark_node;
3765       break;
3766
3767     default:
3768       break;
3769     }
3770
3771   return fold (item);
3772 #endif
3773 }
3774
3775 /* Returns the tree that does the intrinsic invocation.
3776
3777    Note: this function applies only to intrinsics returning
3778    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3779    subroutines.  */
3780
3781 static tree
3782 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3783                         ffebld dest, bool *dest_used)
3784 {
3785   tree expr_tree;
3786   tree saved_expr1;             /* For those who need it. */
3787   tree saved_expr2;             /* For those who need it. */
3788   ffeinfoBasictype bt;
3789   ffeinfoKindtype kt;
3790   tree tree_type;
3791   tree arg1_type;
3792   tree real_type;               /* REAL type corresponding to COMPLEX. */
3793   tree tempvar;
3794   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3795   ffebld arg1;                  /* For handy reference. */
3796   ffebld arg2;
3797   ffebld arg3;
3798   ffeintrinImp codegen_imp;
3799   ffecomGfrt gfrt;
3800
3801   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3802
3803   if (dest_used != NULL)
3804     *dest_used = FALSE;
3805
3806   bt = ffeinfo_basictype (ffebld_info (expr));
3807   kt = ffeinfo_kindtype (ffebld_info (expr));
3808   tree_type = ffecom_tree_type[bt][kt];
3809
3810   if (list != NULL)
3811     {
3812       arg1 = ffebld_head (list);
3813       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3814         return error_mark_node;
3815       if ((list = ffebld_trail (list)) != NULL)
3816         {
3817           arg2 = ffebld_head (list);
3818           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3819             return error_mark_node;
3820           if ((list = ffebld_trail (list)) != NULL)
3821             {
3822               arg3 = ffebld_head (list);
3823               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3824                 return error_mark_node;
3825             }
3826           else
3827             arg3 = NULL;
3828         }
3829       else
3830         arg2 = arg3 = NULL;
3831     }
3832   else
3833     arg1 = arg2 = arg3 = NULL;
3834
3835   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3836      args.  This is used by the MAX/MIN expansions. */
3837
3838   if (arg1 != NULL)
3839     arg1_type = ffecom_tree_type
3840       [ffeinfo_basictype (ffebld_info (arg1))]
3841       [ffeinfo_kindtype (ffebld_info (arg1))];
3842   else
3843     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3844                                    here. */
3845
3846   /* There are several ways for each of the cases in the following switch
3847      statements to exit (from simplest to use to most complicated):
3848
3849      break;  (when expr_tree == NULL)
3850
3851      A standard call is made to the specific intrinsic just as if it had been
3852      passed in as a dummy procedure and called as any old procedure.  This
3853      method can produce slower code but in some cases it's the easiest way for
3854      now.  However, if a (presumably faster) direct call is available,
3855      that is used, so this is the easiest way in many more cases now.
3856
3857      gfrt = FFECOM_gfrtWHATEVER;
3858      break;
3859
3860      gfrt contains the gfrt index of a library function to call, passing the
3861      argument(s) by value rather than by reference.  Used when a more
3862      careful choice of library function is needed than that provided
3863      by the vanilla `break;'.
3864
3865      return expr_tree;
3866
3867      The expr_tree has been completely set up and is ready to be returned
3868      as is.  No further actions are taken.  Use this when the tree is not
3869      in the simple form for one of the arity_n labels.   */
3870
3871   /* For info on how the switch statement cases were written, see the files
3872      enclosed in comments below the switch statement. */
3873
3874   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3875   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3876   if (gfrt == FFECOM_gfrt)
3877     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3878
3879   switch (codegen_imp)
3880     {
3881     case FFEINTRIN_impABS:
3882     case FFEINTRIN_impCABS:
3883     case FFEINTRIN_impCDABS:
3884     case FFEINTRIN_impDABS:
3885     case FFEINTRIN_impIABS:
3886       if (ffeinfo_basictype (ffebld_info (arg1))
3887           == FFEINFO_basictypeCOMPLEX)
3888         {
3889           if (kt == FFEINFO_kindtypeREAL1)
3890             gfrt = FFECOM_gfrtCABS;
3891           else if (kt == FFEINFO_kindtypeREAL2)
3892             gfrt = FFECOM_gfrtCDABS;
3893           break;
3894         }
3895       return ffecom_1 (ABS_EXPR, tree_type,
3896                        convert (tree_type, ffecom_expr (arg1)));
3897
3898     case FFEINTRIN_impACOS:
3899     case FFEINTRIN_impDACOS:
3900       break;
3901
3902     case FFEINTRIN_impAIMAG:
3903     case FFEINTRIN_impDIMAG:
3904     case FFEINTRIN_impIMAGPART:
3905       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3906         arg1_type = TREE_TYPE (arg1_type);
3907       else
3908         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3909
3910       return
3911         convert (tree_type,
3912                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3913                            ffecom_expr (arg1)));
3914
3915     case FFEINTRIN_impAINT:
3916     case FFEINTRIN_impDINT:
3917 #if 0
3918       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3919       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3920 #else /* in the meantime, must use floor to avoid range problems with ints */
3921       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3922       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3923       return
3924         convert (tree_type,
3925                  ffecom_3 (COND_EXPR, double_type_node,
3926                            ffecom_truth_value
3927                            (ffecom_2 (GE_EXPR, integer_type_node,
3928                                       saved_expr1,
3929                                       convert (arg1_type,
3930                                                ffecom_float_zero_))),
3931                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3932                                              build_tree_list (NULL_TREE,
3933                                                   convert (double_type_node,
3934                                                            saved_expr1)),
3935                                              NULL_TREE),
3936                            ffecom_1 (NEGATE_EXPR, double_type_node,
3937                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3938                                                  build_tree_list (NULL_TREE,
3939                                                   convert (double_type_node,
3940                                                       ffecom_1 (NEGATE_EXPR,
3941                                                                 arg1_type,
3942                                                                saved_expr1))),
3943                                                        NULL_TREE)
3944                                      ))
3945                  );
3946 #endif
3947
3948     case FFEINTRIN_impANINT:
3949     case FFEINTRIN_impDNINT:
3950 #if 0                           /* This way of doing it won't handle real
3951                                    numbers of large magnitudes. */
3952       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3953       expr_tree = convert (tree_type,
3954                            convert (integer_type_node,
3955                                     ffecom_3 (COND_EXPR, tree_type,
3956                                               ffecom_truth_value
3957                                               (ffecom_2 (GE_EXPR,
3958                                                          integer_type_node,
3959                                                          saved_expr1,
3960                                                        ffecom_float_zero_)),
3961                                               ffecom_2 (PLUS_EXPR,
3962                                                         tree_type,
3963                                                         saved_expr1,
3964                                                         ffecom_float_half_),
3965                                               ffecom_2 (MINUS_EXPR,
3966                                                         tree_type,
3967                                                         saved_expr1,
3968                                                      ffecom_float_half_))));
3969       return expr_tree;
3970 #else /* So we instead call floor. */
3971       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3972       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3973       return
3974         convert (tree_type,
3975                  ffecom_3 (COND_EXPR, double_type_node,
3976                            ffecom_truth_value
3977                            (ffecom_2 (GE_EXPR, integer_type_node,
3978                                       saved_expr1,
3979                                       convert (arg1_type,
3980                                                ffecom_float_zero_))),
3981                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3982                                              build_tree_list (NULL_TREE,
3983                                                   convert (double_type_node,
3984                                                            ffecom_2 (PLUS_EXPR,
3985                                                                      arg1_type,
3986                                                                      saved_expr1,
3987                                                                      convert (arg1_type,
3988                                                                               ffecom_float_half_)))),
3989                                              NULL_TREE),
3990                            ffecom_1 (NEGATE_EXPR, double_type_node,
3991                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3992                                                        build_tree_list (NULL_TREE,
3993                                                                         convert (double_type_node,
3994                                                                                  ffecom_2 (MINUS_EXPR,
3995                                                                                            arg1_type,
3996                                                                                            convert (arg1_type,
3997                                                                                                     ffecom_float_half_),
3998                                                                                            saved_expr1))),
3999                                                        NULL_TREE))
4000                            )
4001                  );
4002 #endif
4003
4004     case FFEINTRIN_impASIN:
4005     case FFEINTRIN_impDASIN:
4006     case FFEINTRIN_impATAN:
4007     case FFEINTRIN_impDATAN:
4008     case FFEINTRIN_impATAN2:
4009     case FFEINTRIN_impDATAN2:
4010       break;
4011
4012     case FFEINTRIN_impCHAR:
4013     case FFEINTRIN_impACHAR:
4014 #ifdef HOHO
4015       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4016 #else
4017       tempvar = ffebld_nonter_hook (expr);
4018       assert (tempvar);
4019 #endif
4020       {
4021         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4022
4023         expr_tree = ffecom_modify (tmv,
4024                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4025                                              integer_one_node),
4026                                    convert (tmv, ffecom_expr (arg1)));
4027       }
4028       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4029                             expr_tree,
4030                             tempvar);
4031       expr_tree = ffecom_1 (ADDR_EXPR,
4032                             build_pointer_type (TREE_TYPE (expr_tree)),
4033                             expr_tree);
4034       return expr_tree;
4035
4036     case FFEINTRIN_impCMPLX:
4037     case FFEINTRIN_impDCMPLX:
4038       if (arg2 == NULL)
4039         return
4040           convert (tree_type, ffecom_expr (arg1));
4041
4042       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4043       return
4044         ffecom_2 (COMPLEX_EXPR, tree_type,
4045                   convert (real_type, ffecom_expr (arg1)),
4046                   convert (real_type,
4047                            ffecom_expr (arg2)));
4048
4049     case FFEINTRIN_impCOMPLEX:
4050       return
4051         ffecom_2 (COMPLEX_EXPR, tree_type,
4052                   ffecom_expr (arg1),
4053                   ffecom_expr (arg2));
4054
4055     case FFEINTRIN_impCONJG:
4056     case FFEINTRIN_impDCONJG:
4057       {
4058         tree arg1_tree;
4059
4060         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4061         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4062         return
4063           ffecom_2 (COMPLEX_EXPR, tree_type,
4064                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4065                     ffecom_1 (NEGATE_EXPR, real_type,
4066                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4067       }
4068
4069     case FFEINTRIN_impCOS:
4070     case FFEINTRIN_impCCOS:
4071     case FFEINTRIN_impCDCOS:
4072     case FFEINTRIN_impDCOS:
4073       if (bt == FFEINFO_basictypeCOMPLEX)
4074         {
4075           if (kt == FFEINFO_kindtypeREAL1)
4076             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4077           else if (kt == FFEINFO_kindtypeREAL2)
4078             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4079         }
4080       break;
4081
4082     case FFEINTRIN_impCOSH:
4083     case FFEINTRIN_impDCOSH:
4084       break;
4085
4086     case FFEINTRIN_impDBLE:
4087     case FFEINTRIN_impDFLOAT:
4088     case FFEINTRIN_impDREAL:
4089     case FFEINTRIN_impFLOAT:
4090     case FFEINTRIN_impIDINT:
4091     case FFEINTRIN_impIFIX:
4092     case FFEINTRIN_impINT2:
4093     case FFEINTRIN_impINT8:
4094     case FFEINTRIN_impINT:
4095     case FFEINTRIN_impLONG:
4096     case FFEINTRIN_impREAL:
4097     case FFEINTRIN_impSHORT:
4098     case FFEINTRIN_impSNGL:
4099       return convert (tree_type, ffecom_expr (arg1));
4100
4101     case FFEINTRIN_impDIM:
4102     case FFEINTRIN_impDDIM:
4103     case FFEINTRIN_impIDIM:
4104       saved_expr1 = ffecom_save_tree (convert (tree_type,
4105                                                ffecom_expr (arg1)));
4106       saved_expr2 = ffecom_save_tree (convert (tree_type,
4107                                                ffecom_expr (arg2)));
4108       return
4109         ffecom_3 (COND_EXPR, tree_type,
4110                   ffecom_truth_value
4111                   (ffecom_2 (GT_EXPR, integer_type_node,
4112                              saved_expr1,
4113                              saved_expr2)),
4114                   ffecom_2 (MINUS_EXPR, tree_type,
4115                             saved_expr1,
4116                             saved_expr2),
4117                   convert (tree_type, ffecom_float_zero_));
4118
4119     case FFEINTRIN_impDPROD:
4120       return
4121         ffecom_2 (MULT_EXPR, tree_type,
4122                   convert (tree_type, ffecom_expr (arg1)),
4123                   convert (tree_type, ffecom_expr (arg2)));
4124
4125     case FFEINTRIN_impEXP:
4126     case FFEINTRIN_impCDEXP:
4127     case FFEINTRIN_impCEXP:
4128     case FFEINTRIN_impDEXP:
4129       if (bt == FFEINFO_basictypeCOMPLEX)
4130         {
4131           if (kt == FFEINFO_kindtypeREAL1)
4132             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4133           else if (kt == FFEINFO_kindtypeREAL2)
4134             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4135         }
4136       break;
4137
4138     case FFEINTRIN_impICHAR:
4139     case FFEINTRIN_impIACHAR:
4140 #if 0                           /* The simple approach. */
4141       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4142       expr_tree
4143         = ffecom_1 (INDIRECT_REF,
4144                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4145                     expr_tree);
4146       expr_tree
4147         = ffecom_2 (ARRAY_REF,
4148                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4149                     expr_tree,
4150                     integer_one_node);
4151       return convert (tree_type, expr_tree);
4152 #else /* The more interesting (and more optimal) approach. */
4153       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4154       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4155                             saved_expr1,
4156                             expr_tree,
4157                             convert (tree_type, integer_zero_node));
4158       return expr_tree;
4159 #endif
4160
4161     case FFEINTRIN_impINDEX:
4162       break;
4163
4164     case FFEINTRIN_impLEN:
4165 #if 0
4166       break;                                    /* The simple approach. */
4167 #else
4168       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4169 #endif
4170
4171     case FFEINTRIN_impLGE:
4172     case FFEINTRIN_impLGT:
4173     case FFEINTRIN_impLLE:
4174     case FFEINTRIN_impLLT:
4175       break;
4176
4177     case FFEINTRIN_impLOG:
4178     case FFEINTRIN_impALOG:
4179     case FFEINTRIN_impCDLOG:
4180     case FFEINTRIN_impCLOG:
4181     case FFEINTRIN_impDLOG:
4182       if (bt == FFEINFO_basictypeCOMPLEX)
4183         {
4184           if (kt == FFEINFO_kindtypeREAL1)
4185             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4186           else if (kt == FFEINFO_kindtypeREAL2)
4187             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4188         }
4189       break;
4190
4191     case FFEINTRIN_impLOG10:
4192     case FFEINTRIN_impALOG10:
4193     case FFEINTRIN_impDLOG10:
4194       if (gfrt != FFECOM_gfrt)
4195         break;  /* Already picked one, stick with it. */
4196
4197       if (kt == FFEINFO_kindtypeREAL1)
4198         /* We used to call FFECOM_gfrtALOG10 here.  */
4199         gfrt = FFECOM_gfrtL_LOG10;
4200       else if (kt == FFEINFO_kindtypeREAL2)
4201         /* We used to call FFECOM_gfrtDLOG10 here.  */
4202         gfrt = FFECOM_gfrtL_LOG10;
4203       break;
4204
4205     case FFEINTRIN_impMAX:
4206     case FFEINTRIN_impAMAX0:
4207     case FFEINTRIN_impAMAX1:
4208     case FFEINTRIN_impDMAX1:
4209     case FFEINTRIN_impMAX0:
4210     case FFEINTRIN_impMAX1:
4211       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4212         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4213       else
4214         arg1_type = tree_type;
4215       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4216                             convert (arg1_type, ffecom_expr (arg1)),
4217                             convert (arg1_type, ffecom_expr (arg2)));
4218       for (; list != NULL; list = ffebld_trail (list))
4219         {
4220           if ((ffebld_head (list) == NULL)
4221               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4222             continue;
4223           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4224                                 expr_tree,
4225                                 convert (arg1_type,
4226                                          ffecom_expr (ffebld_head (list))));
4227         }
4228       return convert (tree_type, expr_tree);
4229
4230     case FFEINTRIN_impMIN:
4231     case FFEINTRIN_impAMIN0:
4232     case FFEINTRIN_impAMIN1:
4233     case FFEINTRIN_impDMIN1:
4234     case FFEINTRIN_impMIN0:
4235     case FFEINTRIN_impMIN1:
4236       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4237         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4238       else
4239         arg1_type = tree_type;
4240       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4241                             convert (arg1_type, ffecom_expr (arg1)),
4242                             convert (arg1_type, ffecom_expr (arg2)));
4243       for (; list != NULL; list = ffebld_trail (list))
4244         {
4245           if ((ffebld_head (list) == NULL)
4246               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4247             continue;
4248           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4249                                 expr_tree,
4250                                 convert (arg1_type,
4251                                          ffecom_expr (ffebld_head (list))));
4252         }
4253       return convert (tree_type, expr_tree);
4254
4255     case FFEINTRIN_impMOD:
4256     case FFEINTRIN_impAMOD:
4257     case FFEINTRIN_impDMOD:
4258       if (bt != FFEINFO_basictypeREAL)
4259         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4260                          convert (tree_type, ffecom_expr (arg1)),
4261                          convert (tree_type, ffecom_expr (arg2)));
4262
4263       if (kt == FFEINFO_kindtypeREAL1)
4264         /* We used to call FFECOM_gfrtAMOD here.  */
4265         gfrt = FFECOM_gfrtL_FMOD;
4266       else if (kt == FFEINFO_kindtypeREAL2)
4267         /* We used to call FFECOM_gfrtDMOD here.  */
4268         gfrt = FFECOM_gfrtL_FMOD;
4269       break;
4270
4271     case FFEINTRIN_impNINT:
4272     case FFEINTRIN_impIDNINT:
4273 #if 0
4274       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4275       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4276 #else
4277       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4278       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4279       return
4280         convert (ffecom_integer_type_node,
4281                  ffecom_3 (COND_EXPR, arg1_type,
4282                            ffecom_truth_value
4283                            (ffecom_2 (GE_EXPR, integer_type_node,
4284                                       saved_expr1,
4285                                       convert (arg1_type,
4286                                                ffecom_float_zero_))),
4287                            ffecom_2 (PLUS_EXPR, arg1_type,
4288                                      saved_expr1,
4289                                      convert (arg1_type,
4290                                               ffecom_float_half_)),
4291                            ffecom_2 (MINUS_EXPR, arg1_type,
4292                                      saved_expr1,
4293                                      convert (arg1_type,
4294                                               ffecom_float_half_))));
4295 #endif
4296
4297     case FFEINTRIN_impSIGN:
4298     case FFEINTRIN_impDSIGN:
4299     case FFEINTRIN_impISIGN:
4300       {
4301         tree arg2_tree = ffecom_expr (arg2);
4302
4303         saved_expr1
4304           = ffecom_save_tree
4305           (ffecom_1 (ABS_EXPR, tree_type,
4306                      convert (tree_type,
4307                               ffecom_expr (arg1))));
4308         expr_tree
4309           = ffecom_3 (COND_EXPR, tree_type,
4310                       ffecom_truth_value
4311                       (ffecom_2 (GE_EXPR, integer_type_node,
4312                                  arg2_tree,
4313                                  convert (TREE_TYPE (arg2_tree),
4314                                           integer_zero_node))),
4315                       saved_expr1,
4316                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4317         /* Make sure SAVE_EXPRs get referenced early enough. */
4318         expr_tree
4319           = ffecom_2 (COMPOUND_EXPR, tree_type,
4320                       convert (void_type_node, saved_expr1),
4321                       expr_tree);
4322       }
4323       return expr_tree;
4324
4325     case FFEINTRIN_impSIN:
4326     case FFEINTRIN_impCDSIN:
4327     case FFEINTRIN_impCSIN:
4328     case FFEINTRIN_impDSIN:
4329       if (bt == FFEINFO_basictypeCOMPLEX)
4330         {
4331           if (kt == FFEINFO_kindtypeREAL1)
4332             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4333           else if (kt == FFEINFO_kindtypeREAL2)
4334             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4335         }
4336       break;
4337
4338     case FFEINTRIN_impSINH:
4339     case FFEINTRIN_impDSINH:
4340       break;
4341
4342     case FFEINTRIN_impSQRT:
4343     case FFEINTRIN_impCDSQRT:
4344     case FFEINTRIN_impCSQRT:
4345     case FFEINTRIN_impDSQRT:
4346       if (bt == FFEINFO_basictypeCOMPLEX)
4347         {
4348           if (kt == FFEINFO_kindtypeREAL1)
4349             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4350           else if (kt == FFEINFO_kindtypeREAL2)
4351             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4352         }
4353       break;
4354
4355     case FFEINTRIN_impTAN:
4356     case FFEINTRIN_impDTAN:
4357     case FFEINTRIN_impTANH:
4358     case FFEINTRIN_impDTANH:
4359       break;
4360
4361     case FFEINTRIN_impREALPART:
4362       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4363         arg1_type = TREE_TYPE (arg1_type);
4364       else
4365         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4366
4367       return
4368         convert (tree_type,
4369                  ffecom_1 (REALPART_EXPR, arg1_type,
4370                            ffecom_expr (arg1)));
4371
4372     case FFEINTRIN_impIAND:
4373     case FFEINTRIN_impAND:
4374       return ffecom_2 (BIT_AND_EXPR, tree_type,
4375                        convert (tree_type,
4376                                 ffecom_expr (arg1)),
4377                        convert (tree_type,
4378                                 ffecom_expr (arg2)));
4379
4380     case FFEINTRIN_impIOR:
4381     case FFEINTRIN_impOR:
4382       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4383                        convert (tree_type,
4384                                 ffecom_expr (arg1)),
4385                        convert (tree_type,
4386                                 ffecom_expr (arg2)));
4387
4388     case FFEINTRIN_impIEOR:
4389     case FFEINTRIN_impXOR:
4390       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4391                        convert (tree_type,
4392                                 ffecom_expr (arg1)),
4393                        convert (tree_type,
4394                                 ffecom_expr (arg2)));
4395
4396     case FFEINTRIN_impLSHIFT:
4397       return ffecom_2 (LSHIFT_EXPR, tree_type,
4398                        ffecom_expr (arg1),
4399                        convert (integer_type_node,
4400                                 ffecom_expr (arg2)));
4401
4402     case FFEINTRIN_impRSHIFT:
4403       return ffecom_2 (RSHIFT_EXPR, tree_type,
4404                        ffecom_expr (arg1),
4405                        convert (integer_type_node,
4406                                 ffecom_expr (arg2)));
4407
4408     case FFEINTRIN_impNOT:
4409       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4410
4411     case FFEINTRIN_impBIT_SIZE:
4412       return convert (tree_type, TYPE_SIZE (arg1_type));
4413
4414     case FFEINTRIN_impBTEST:
4415       {
4416         ffetargetLogical1 target_true;
4417         ffetargetLogical1 target_false;
4418         tree true_tree;
4419         tree false_tree;
4420
4421         ffetarget_logical1 (&target_true, TRUE);
4422         ffetarget_logical1 (&target_false, FALSE);
4423         if (target_true == 1)
4424           true_tree = convert (tree_type, integer_one_node);
4425         else
4426           true_tree = convert (tree_type, build_int_2 (target_true, 0));
4427         if (target_false == 0)
4428           false_tree = convert (tree_type, integer_zero_node);
4429         else
4430           false_tree = convert (tree_type, build_int_2 (target_false, 0));
4431
4432         return
4433           ffecom_3 (COND_EXPR, tree_type,
4434                     ffecom_truth_value
4435                     (ffecom_2 (EQ_EXPR, integer_type_node,
4436                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4437                                          ffecom_expr (arg1),
4438                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4439                                                    convert (arg1_type,
4440                                                           integer_one_node),
4441                                                    convert (integer_type_node,
4442                                                             ffecom_expr (arg2)))),
4443                                convert (arg1_type,
4444                                         integer_zero_node))),
4445                     false_tree,
4446                     true_tree);
4447       }
4448
4449     case FFEINTRIN_impIBCLR:
4450       return
4451         ffecom_2 (BIT_AND_EXPR, tree_type,
4452                   ffecom_expr (arg1),
4453                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4454                             ffecom_2 (LSHIFT_EXPR, tree_type,
4455                                       convert (tree_type,
4456                                                integer_one_node),
4457                                       convert (integer_type_node,
4458                                                ffecom_expr (arg2)))));
4459
4460     case FFEINTRIN_impIBITS:
4461       {
4462         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4463                                                     ffecom_expr (arg3)));
4464         tree uns_type
4465         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4466
4467         expr_tree
4468           = ffecom_2 (BIT_AND_EXPR, tree_type,
4469                       ffecom_2 (RSHIFT_EXPR, tree_type,
4470                                 ffecom_expr (arg1),
4471                                 convert (integer_type_node,
4472                                          ffecom_expr (arg2))),
4473                       convert (tree_type,
4474                                ffecom_2 (RSHIFT_EXPR, uns_type,
4475                                          ffecom_1 (BIT_NOT_EXPR,
4476                                                    uns_type,
4477                                                    convert (uns_type,
4478                                                         integer_zero_node)),
4479                                          ffecom_2 (MINUS_EXPR,
4480                                                    integer_type_node,
4481                                                    TYPE_SIZE (uns_type),
4482                                                    arg3_tree))));
4483         /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4484         expr_tree
4485           = ffecom_3 (COND_EXPR, tree_type,
4486                       ffecom_truth_value
4487                       (ffecom_2 (NE_EXPR, integer_type_node,
4488                                  arg3_tree,
4489                                  integer_zero_node)),
4490                       expr_tree,
4491                       convert (tree_type, integer_zero_node));
4492       }
4493       return expr_tree;
4494
4495     case FFEINTRIN_impIBSET:
4496       return
4497         ffecom_2 (BIT_IOR_EXPR, tree_type,
4498                   ffecom_expr (arg1),
4499                   ffecom_2 (LSHIFT_EXPR, tree_type,
4500                             convert (tree_type, integer_one_node),
4501                             convert (integer_type_node,
4502                                      ffecom_expr (arg2))));
4503
4504     case FFEINTRIN_impISHFT:
4505       {
4506         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4507         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4508                                                     ffecom_expr (arg2)));
4509         tree uns_type
4510         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4511
4512         expr_tree
4513           = ffecom_3 (COND_EXPR, tree_type,
4514                       ffecom_truth_value
4515                       (ffecom_2 (GE_EXPR, integer_type_node,
4516                                  arg2_tree,
4517                                  integer_zero_node)),
4518                       ffecom_2 (LSHIFT_EXPR, tree_type,
4519                                 arg1_tree,
4520                                 arg2_tree),
4521                       convert (tree_type,
4522                                ffecom_2 (RSHIFT_EXPR, uns_type,
4523                                          convert (uns_type, arg1_tree),
4524                                          ffecom_1 (NEGATE_EXPR,
4525                                                    integer_type_node,
4526                                                    arg2_tree))));
4527         /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
4528         expr_tree
4529           = ffecom_3 (COND_EXPR, tree_type,
4530                       ffecom_truth_value
4531                       (ffecom_2 (NE_EXPR, integer_type_node,
4532                                  ffecom_1 (ABS_EXPR,
4533                                            integer_type_node,
4534                                            arg2_tree),
4535                                  TYPE_SIZE (uns_type))),
4536                       expr_tree,
4537                       convert (tree_type, integer_zero_node));
4538         /* Make sure SAVE_EXPRs get referenced early enough. */
4539         expr_tree
4540           = ffecom_2 (COMPOUND_EXPR, tree_type,
4541                       convert (void_type_node, arg1_tree),
4542                       ffecom_2 (COMPOUND_EXPR, tree_type,
4543                                 convert (void_type_node, arg2_tree),
4544                                 expr_tree));
4545       }
4546       return expr_tree;
4547
4548     case FFEINTRIN_impISHFTC:
4549       {
4550         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4551         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4552                                                     ffecom_expr (arg2)));
4553         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4554         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4555         tree shift_neg;
4556         tree shift_pos;
4557         tree mask_arg1;
4558         tree masked_arg1;
4559         tree uns_type
4560         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4561
4562         mask_arg1
4563           = ffecom_2 (LSHIFT_EXPR, tree_type,
4564                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4565                                 convert (tree_type, integer_zero_node)),
4566                       arg3_tree);
4567         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4568         mask_arg1
4569           = ffecom_3 (COND_EXPR, tree_type,
4570                       ffecom_truth_value
4571                       (ffecom_2 (NE_EXPR, integer_type_node,
4572                                  arg3_tree,
4573                                  TYPE_SIZE (uns_type))),
4574                       mask_arg1,
4575                       convert (tree_type, integer_zero_node));
4576         mask_arg1 = ffecom_save_tree (mask_arg1);
4577         masked_arg1
4578           = ffecom_2 (BIT_AND_EXPR, tree_type,
4579                       arg1_tree,
4580                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4581                                 mask_arg1));
4582         masked_arg1 = ffecom_save_tree (masked_arg1);
4583         shift_neg
4584           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4585                       convert (tree_type,
4586                                ffecom_2 (RSHIFT_EXPR, uns_type,
4587                                          convert (uns_type, masked_arg1),
4588                                          ffecom_1 (NEGATE_EXPR,
4589                                                    integer_type_node,
4590                                                    arg2_tree))),
4591                       ffecom_2 (LSHIFT_EXPR, tree_type,
4592                                 arg1_tree,
4593                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4594                                           arg2_tree,
4595                                           arg3_tree)));
4596         shift_pos
4597           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4598                       ffecom_2 (LSHIFT_EXPR, tree_type,
4599                                 arg1_tree,
4600                                 arg2_tree),
4601                       convert (tree_type,
4602                                ffecom_2 (RSHIFT_EXPR, uns_type,
4603                                          convert (uns_type, masked_arg1),
4604                                          ffecom_2 (MINUS_EXPR,
4605                                                    integer_type_node,
4606                                                    arg3_tree,
4607                                                    arg2_tree))));
4608         expr_tree
4609           = ffecom_3 (COND_EXPR, tree_type,
4610                       ffecom_truth_value
4611                       (ffecom_2 (LT_EXPR, integer_type_node,
4612                                  arg2_tree,
4613                                  integer_zero_node)),
4614                       shift_neg,
4615                       shift_pos);
4616         expr_tree
4617           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4618                       ffecom_2 (BIT_AND_EXPR, tree_type,
4619                                 mask_arg1,
4620                                 arg1_tree),
4621                       ffecom_2 (BIT_AND_EXPR, tree_type,
4622                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4623                                           mask_arg1),
4624                                 expr_tree));
4625         expr_tree
4626           = ffecom_3 (COND_EXPR, tree_type,
4627                       ffecom_truth_value
4628                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4629                                  ffecom_2 (EQ_EXPR, integer_type_node,
4630                                            ffecom_1 (ABS_EXPR,
4631                                                      integer_type_node,
4632                                                      arg2_tree),
4633                                            arg3_tree),
4634                                  ffecom_2 (EQ_EXPR, integer_type_node,
4635                                            arg2_tree,
4636                                            integer_zero_node))),
4637                       arg1_tree,
4638                       expr_tree);
4639         /* Make sure SAVE_EXPRs get referenced early enough. */
4640         expr_tree
4641           = ffecom_2 (COMPOUND_EXPR, tree_type,
4642                       convert (void_type_node, arg1_tree),
4643                       ffecom_2 (COMPOUND_EXPR, tree_type,
4644                                 convert (void_type_node, arg2_tree),
4645                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4646                                           convert (void_type_node,
4647                                                    mask_arg1),
4648                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4649                                                     convert (void_type_node,
4650                                                              masked_arg1),
4651                                                     expr_tree))));
4652         expr_tree
4653           = ffecom_2 (COMPOUND_EXPR, tree_type,
4654                       convert (void_type_node,
4655                                arg3_tree),
4656                       expr_tree);
4657       }
4658       return expr_tree;
4659
4660     case FFEINTRIN_impLOC:
4661       {
4662         tree arg1_tree = ffecom_expr (arg1);
4663
4664         expr_tree
4665           = convert (tree_type,
4666                      ffecom_1 (ADDR_EXPR,
4667                                build_pointer_type (TREE_TYPE (arg1_tree)),
4668                                arg1_tree));
4669       }
4670       return expr_tree;
4671
4672     case FFEINTRIN_impMVBITS:
4673       {
4674         tree arg1_tree;
4675         tree arg2_tree;
4676         tree arg3_tree;
4677         ffebld arg4 = ffebld_head (ffebld_trail (list));
4678         tree arg4_tree;
4679         tree arg4_type;
4680         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4681         tree arg5_tree;
4682         tree prep_arg1;
4683         tree prep_arg4;
4684         tree arg5_plus_arg3;
4685
4686         arg2_tree = convert (integer_type_node,
4687                              ffecom_expr (arg2));
4688         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4689                                                ffecom_expr (arg3)));
4690         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4691         arg4_type = TREE_TYPE (arg4_tree);
4692
4693         arg1_tree = ffecom_save_tree (convert (arg4_type,
4694                                                ffecom_expr (arg1)));
4695
4696         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4697                                                ffecom_expr (arg5)));
4698
4699         prep_arg1
4700           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4701                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4702                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4703                                           arg1_tree,
4704                                           arg2_tree),
4705                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4706                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4707                                                     ffecom_1 (BIT_NOT_EXPR,
4708                                                               arg4_type,
4709                                                               convert
4710                                                               (arg4_type,
4711                                                         integer_zero_node)),
4712                                                     arg3_tree))),
4713                       arg5_tree);
4714         arg5_plus_arg3
4715           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4716                                         arg5_tree,
4717                                         arg3_tree));
4718         prep_arg4
4719           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4720                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4721                                 convert (arg4_type,
4722                                          integer_zero_node)),
4723                       arg5_plus_arg3);
4724         /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4725         prep_arg4
4726           = ffecom_3 (COND_EXPR, arg4_type,
4727                       ffecom_truth_value
4728                       (ffecom_2 (NE_EXPR, integer_type_node,
4729                                  arg5_plus_arg3,
4730                                  convert (TREE_TYPE (arg5_plus_arg3),
4731                                           TYPE_SIZE (arg4_type)))),
4732                       prep_arg4,
4733                       convert (arg4_type, integer_zero_node));
4734         prep_arg4
4735           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4736                       arg4_tree,
4737                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4738                                 prep_arg4,
4739                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4740                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4741                                                     ffecom_1 (BIT_NOT_EXPR,
4742                                                               arg4_type,
4743                                                               convert
4744                                                               (arg4_type,
4745                                                         integer_zero_node)),
4746                                                     arg5_tree))));
4747         prep_arg1
4748           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4749                       prep_arg1,
4750                       prep_arg4);
4751         /* Fix up (twice), because LSHIFT_EXPR above
4752            can't shift over TYPE_SIZE.  */
4753         prep_arg1
4754           = ffecom_3 (COND_EXPR, arg4_type,
4755                       ffecom_truth_value
4756                       (ffecom_2 (NE_EXPR, integer_type_node,
4757                                  arg3_tree,
4758                                  convert (TREE_TYPE (arg3_tree),
4759                                           integer_zero_node))),
4760                       prep_arg1,
4761                       arg4_tree);
4762         prep_arg1
4763           = ffecom_3 (COND_EXPR, arg4_type,
4764                       ffecom_truth_value
4765                       (ffecom_2 (NE_EXPR, integer_type_node,
4766                                  arg3_tree,
4767                                  convert (TREE_TYPE (arg3_tree),
4768                                           TYPE_SIZE (arg4_type)))),
4769                       prep_arg1,
4770                       arg1_tree);
4771         expr_tree
4772           = ffecom_2s (MODIFY_EXPR, void_type_node,
4773                        arg4_tree,
4774                        prep_arg1);
4775         /* Make sure SAVE_EXPRs get referenced early enough. */
4776         expr_tree
4777           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4778                       arg1_tree,
4779                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4780                                 arg3_tree,
4781                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4782                                           arg5_tree,
4783                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4784                                                     arg5_plus_arg3,
4785                                                     expr_tree))));
4786         expr_tree
4787           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4788                       arg4_tree,
4789                       expr_tree);
4790
4791       }
4792       return expr_tree;
4793
4794     case FFEINTRIN_impDERF:
4795     case FFEINTRIN_impERF:
4796     case FFEINTRIN_impDERFC:
4797     case FFEINTRIN_impERFC:
4798       break;
4799
4800     case FFEINTRIN_impIARGC:
4801       /* extern int xargc; i__1 = xargc - 1; */
4802       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4803                             ffecom_tree_xargc_,
4804                             convert (TREE_TYPE (ffecom_tree_xargc_),
4805                                      integer_one_node));
4806       return expr_tree;
4807
4808     case FFEINTRIN_impSIGNAL_func:
4809     case FFEINTRIN_impSIGNAL_subr:
4810       {
4811         tree arg1_tree;
4812         tree arg2_tree;
4813         tree arg3_tree;
4814
4815         arg1_tree = convert (ffecom_f2c_integer_type_node,
4816                              ffecom_expr (arg1));
4817         arg1_tree = ffecom_1 (ADDR_EXPR,
4818                               build_pointer_type (TREE_TYPE (arg1_tree)),
4819                               arg1_tree);
4820
4821         /* Pass procedure as a pointer to it, anything else by value.  */
4822         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4823           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4824         else
4825           arg2_tree = ffecom_ptr_to_expr (arg2);
4826         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4827                              arg2_tree);
4828
4829         if (arg3 != NULL)
4830           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4831         else
4832           arg3_tree = NULL_TREE;
4833
4834         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4835         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4836         TREE_CHAIN (arg1_tree) = arg2_tree;
4837
4838         expr_tree
4839           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4840                           ffecom_gfrt_kindtype (gfrt),
4841                           FALSE,
4842                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4843                            NULL_TREE :
4844                            tree_type),
4845                           arg1_tree,
4846                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4847                           ffebld_nonter_hook (expr));
4848
4849         if (arg3_tree != NULL_TREE)
4850           expr_tree
4851             = ffecom_modify (NULL_TREE, arg3_tree,
4852                              convert (TREE_TYPE (arg3_tree),
4853                                       expr_tree));
4854       }
4855       return expr_tree;
4856
4857     case FFEINTRIN_impALARM:
4858       {
4859         tree arg1_tree;
4860         tree arg2_tree;
4861         tree arg3_tree;
4862
4863         arg1_tree = convert (ffecom_f2c_integer_type_node,
4864                              ffecom_expr (arg1));
4865         arg1_tree = ffecom_1 (ADDR_EXPR,
4866                               build_pointer_type (TREE_TYPE (arg1_tree)),
4867                               arg1_tree);
4868
4869         /* Pass procedure as a pointer to it, anything else by value.  */
4870         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4871           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4872         else
4873           arg2_tree = ffecom_ptr_to_expr (arg2);
4874         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4875                              arg2_tree);
4876
4877         if (arg3 != NULL)
4878           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4879         else
4880           arg3_tree = NULL_TREE;
4881
4882         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4883         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4884         TREE_CHAIN (arg1_tree) = arg2_tree;
4885
4886         expr_tree
4887           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4888                           ffecom_gfrt_kindtype (gfrt),
4889                           FALSE,
4890                           NULL_TREE,
4891                           arg1_tree,
4892                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4893                           ffebld_nonter_hook (expr));
4894
4895         if (arg3_tree != NULL_TREE)
4896           expr_tree
4897             = ffecom_modify (NULL_TREE, arg3_tree,
4898                              convert (TREE_TYPE (arg3_tree),
4899                                       expr_tree));
4900       }
4901       return expr_tree;
4902
4903     case FFEINTRIN_impCHDIR_subr:
4904     case FFEINTRIN_impFDATE_subr:
4905     case FFEINTRIN_impFGET_subr:
4906     case FFEINTRIN_impFPUT_subr:
4907     case FFEINTRIN_impGETCWD_subr:
4908     case FFEINTRIN_impHOSTNM_subr:
4909     case FFEINTRIN_impSYSTEM_subr:
4910     case FFEINTRIN_impUNLINK_subr:
4911       {
4912         tree arg1_len = integer_zero_node;
4913         tree arg1_tree;
4914         tree arg2_tree;
4915
4916         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4917
4918         if (arg2 != NULL)
4919           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4920         else
4921           arg2_tree = NULL_TREE;
4922
4923         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4924         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4925         TREE_CHAIN (arg1_tree) = arg1_len;
4926
4927         expr_tree
4928           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4929                           ffecom_gfrt_kindtype (gfrt),
4930                           FALSE,
4931                           NULL_TREE,
4932                           arg1_tree,
4933                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4934                           ffebld_nonter_hook (expr));
4935
4936         if (arg2_tree != NULL_TREE)
4937           expr_tree
4938             = ffecom_modify (NULL_TREE, arg2_tree,
4939                              convert (TREE_TYPE (arg2_tree),
4940                                       expr_tree));
4941       }
4942       return expr_tree;
4943
4944     case FFEINTRIN_impEXIT:
4945       if (arg1 != NULL)
4946         break;
4947
4948       expr_tree = build_tree_list (NULL_TREE,
4949                                    ffecom_1 (ADDR_EXPR,
4950                                              build_pointer_type
4951                                              (ffecom_integer_type_node),
4952                                              integer_zero_node));
4953
4954       return
4955         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4956                       ffecom_gfrt_kindtype (gfrt),
4957                       FALSE,
4958                       void_type_node,
4959                       expr_tree,
4960                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4961                       ffebld_nonter_hook (expr));
4962
4963     case FFEINTRIN_impFLUSH:
4964       if (arg1 == NULL)
4965         gfrt = FFECOM_gfrtFLUSH;
4966       else
4967         gfrt = FFECOM_gfrtFLUSH1;
4968       break;
4969
4970     case FFEINTRIN_impCHMOD_subr:
4971     case FFEINTRIN_impLINK_subr:
4972     case FFEINTRIN_impRENAME_subr:
4973     case FFEINTRIN_impSYMLNK_subr:
4974       {
4975         tree arg1_len = integer_zero_node;
4976         tree arg1_tree;
4977         tree arg2_len = integer_zero_node;
4978         tree arg2_tree;
4979         tree arg3_tree;
4980
4981         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4982         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
4983         if (arg3 != NULL)
4984           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4985         else
4986           arg3_tree = NULL_TREE;
4987
4988         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4989         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4990         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4991         arg2_len = build_tree_list (NULL_TREE, arg2_len);
4992         TREE_CHAIN (arg1_tree) = arg2_tree;
4993         TREE_CHAIN (arg2_tree) = arg1_len;
4994         TREE_CHAIN (arg1_len) = arg2_len;
4995         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4996                                   ffecom_gfrt_kindtype (gfrt),
4997                                   FALSE,
4998                                   NULL_TREE,
4999                                   arg1_tree,
5000                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5001                                   ffebld_nonter_hook (expr));
5002         if (arg3_tree != NULL_TREE)
5003           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5004                                      convert (TREE_TYPE (arg3_tree),
5005                                               expr_tree));
5006       }
5007       return expr_tree;
5008
5009     case FFEINTRIN_impLSTAT_subr:
5010     case FFEINTRIN_impSTAT_subr:
5011       {
5012         tree arg1_len = integer_zero_node;
5013         tree arg1_tree;
5014         tree arg2_tree;
5015         tree arg3_tree;
5016
5017         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5018
5019         arg2_tree = ffecom_ptr_to_expr (arg2);
5020
5021         if (arg3 != NULL)
5022           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5023         else
5024           arg3_tree = NULL_TREE;
5025
5026         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5027         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5028         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5029         TREE_CHAIN (arg1_tree) = arg2_tree;
5030         TREE_CHAIN (arg2_tree) = arg1_len;
5031         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5032                                   ffecom_gfrt_kindtype (gfrt),
5033                                   FALSE,
5034                                   NULL_TREE,
5035                                   arg1_tree,
5036                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5037                                   ffebld_nonter_hook (expr));
5038         if (arg3_tree != NULL_TREE)
5039           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5040                                      convert (TREE_TYPE (arg3_tree),
5041                                               expr_tree));
5042       }
5043       return expr_tree;
5044
5045     case FFEINTRIN_impFGETC_subr:
5046     case FFEINTRIN_impFPUTC_subr:
5047       {
5048         tree arg1_tree;
5049         tree arg2_tree;
5050         tree arg2_len = integer_zero_node;
5051         tree arg3_tree;
5052
5053         arg1_tree = convert (ffecom_f2c_integer_type_node,
5054                              ffecom_expr (arg1));
5055         arg1_tree = ffecom_1 (ADDR_EXPR,
5056                               build_pointer_type (TREE_TYPE (arg1_tree)),
5057                               arg1_tree);
5058
5059         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5060         if (arg3 != NULL)
5061           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5062         else
5063           arg3_tree = NULL_TREE;
5064
5065         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5066         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5067         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5068         TREE_CHAIN (arg1_tree) = arg2_tree;
5069         TREE_CHAIN (arg2_tree) = arg2_len;
5070
5071         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5072                                   ffecom_gfrt_kindtype (gfrt),
5073                                   FALSE,
5074                                   NULL_TREE,
5075                                   arg1_tree,
5076                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5077                                   ffebld_nonter_hook (expr));
5078         if (arg3_tree != NULL_TREE)
5079           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5080                                      convert (TREE_TYPE (arg3_tree),
5081                                               expr_tree));
5082       }
5083       return expr_tree;
5084
5085     case FFEINTRIN_impFSTAT_subr:
5086       {
5087         tree arg1_tree;
5088         tree arg2_tree;
5089         tree arg3_tree;
5090
5091         arg1_tree = convert (ffecom_f2c_integer_type_node,
5092                              ffecom_expr (arg1));
5093         arg1_tree = ffecom_1 (ADDR_EXPR,
5094                               build_pointer_type (TREE_TYPE (arg1_tree)),
5095                               arg1_tree);
5096
5097         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5098                              ffecom_ptr_to_expr (arg2));
5099
5100         if (arg3 == NULL)
5101           arg3_tree = NULL_TREE;
5102         else
5103           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5104
5105         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5106         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5107         TREE_CHAIN (arg1_tree) = arg2_tree;
5108         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5109                                   ffecom_gfrt_kindtype (gfrt),
5110                                   FALSE,
5111                                   NULL_TREE,
5112                                   arg1_tree,
5113                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5114                                   ffebld_nonter_hook (expr));
5115         if (arg3_tree != NULL_TREE) {
5116           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5117                                      convert (TREE_TYPE (arg3_tree),
5118                                               expr_tree));
5119         }
5120       }
5121       return expr_tree;
5122
5123     case FFEINTRIN_impKILL_subr:
5124       {
5125         tree arg1_tree;
5126         tree arg2_tree;
5127         tree arg3_tree;
5128
5129         arg1_tree = convert (ffecom_f2c_integer_type_node,
5130                              ffecom_expr (arg1));
5131         arg1_tree = ffecom_1 (ADDR_EXPR,
5132                               build_pointer_type (TREE_TYPE (arg1_tree)),
5133                               arg1_tree);
5134
5135         arg2_tree = convert (ffecom_f2c_integer_type_node,
5136                              ffecom_expr (arg2));
5137         arg2_tree = ffecom_1 (ADDR_EXPR,
5138                               build_pointer_type (TREE_TYPE (arg2_tree)),
5139                               arg2_tree);
5140
5141         if (arg3 == NULL)
5142           arg3_tree = NULL_TREE;
5143         else
5144           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5145
5146         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5147         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5148         TREE_CHAIN (arg1_tree) = arg2_tree;
5149         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5150                                   ffecom_gfrt_kindtype (gfrt),
5151                                   FALSE,
5152                                   NULL_TREE,
5153                                   arg1_tree,
5154                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5155                                   ffebld_nonter_hook (expr));
5156         if (arg3_tree != NULL_TREE) {
5157           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5158                                      convert (TREE_TYPE (arg3_tree),
5159                                               expr_tree));
5160         }
5161       }
5162       return expr_tree;
5163
5164     case FFEINTRIN_impCTIME_subr:
5165     case FFEINTRIN_impTTYNAM_subr:
5166       {
5167         tree arg1_len = integer_zero_node;
5168         tree arg1_tree;
5169         tree arg2_tree;
5170
5171         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5172
5173         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5174                               ffecom_f2c_longint_type_node :
5175                               ffecom_f2c_integer_type_node),
5176                              ffecom_expr (arg1));
5177         arg2_tree = ffecom_1 (ADDR_EXPR,
5178                               build_pointer_type (TREE_TYPE (arg2_tree)),
5179                               arg2_tree);
5180
5181         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5182         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5183         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5184         TREE_CHAIN (arg1_len) = arg2_tree;
5185         TREE_CHAIN (arg1_tree) = arg1_len;
5186
5187         expr_tree
5188           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5189                           ffecom_gfrt_kindtype (gfrt),
5190                           FALSE,
5191                           NULL_TREE,
5192                           arg1_tree,
5193                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5194                           ffebld_nonter_hook (expr));
5195         TREE_SIDE_EFFECTS (expr_tree) = 1;
5196       }
5197       return expr_tree;
5198
5199     case FFEINTRIN_impIRAND:
5200     case FFEINTRIN_impRAND:
5201       /* Arg defaults to 0 (normal random case) */
5202       {
5203         tree arg1_tree;
5204
5205         if (arg1 == NULL)
5206           arg1_tree = ffecom_integer_zero_node;
5207         else
5208           arg1_tree = ffecom_expr (arg1);
5209         arg1_tree = convert (ffecom_f2c_integer_type_node,
5210                              arg1_tree);
5211         arg1_tree = ffecom_1 (ADDR_EXPR,
5212                               build_pointer_type (TREE_TYPE (arg1_tree)),
5213                               arg1_tree);
5214         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5215
5216         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5217                                   ffecom_gfrt_kindtype (gfrt),
5218                                   FALSE,
5219                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5220                                    ffecom_f2c_integer_type_node :
5221                                    ffecom_f2c_real_type_node),
5222                                   arg1_tree,
5223                                   dest_tree, dest, dest_used,
5224                                   NULL_TREE, TRUE,
5225                                   ffebld_nonter_hook (expr));
5226       }
5227       return expr_tree;
5228
5229     case FFEINTRIN_impFTELL_subr:
5230     case FFEINTRIN_impUMASK_subr:
5231       {
5232         tree arg1_tree;
5233         tree arg2_tree;
5234
5235         arg1_tree = convert (ffecom_f2c_integer_type_node,
5236                              ffecom_expr (arg1));
5237         arg1_tree = ffecom_1 (ADDR_EXPR,
5238                               build_pointer_type (TREE_TYPE (arg1_tree)),
5239                               arg1_tree);
5240
5241         if (arg2 == NULL)
5242           arg2_tree = NULL_TREE;
5243         else
5244           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5245
5246         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5247                                   ffecom_gfrt_kindtype (gfrt),
5248                                   FALSE,
5249                                   NULL_TREE,
5250                                   build_tree_list (NULL_TREE, arg1_tree),
5251                                   NULL_TREE, NULL, NULL, NULL_TREE,
5252                                   TRUE,
5253                                   ffebld_nonter_hook (expr));
5254         if (arg2_tree != NULL_TREE) {
5255           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5256                                      convert (TREE_TYPE (arg2_tree),
5257                                               expr_tree));
5258         }
5259       }
5260       return expr_tree;
5261
5262     case FFEINTRIN_impCPU_TIME:
5263     case FFEINTRIN_impSECOND_subr:
5264       {
5265         tree arg1_tree;
5266
5267         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5268
5269         expr_tree
5270           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5271                           ffecom_gfrt_kindtype (gfrt),
5272                           FALSE,
5273                           NULL_TREE,
5274                           NULL_TREE,
5275                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5276                           ffebld_nonter_hook (expr));
5277
5278         expr_tree
5279           = ffecom_modify (NULL_TREE, arg1_tree,
5280                            convert (TREE_TYPE (arg1_tree),
5281                                     expr_tree));
5282       }
5283       return expr_tree;
5284
5285     case FFEINTRIN_impDTIME_subr:
5286     case FFEINTRIN_impETIME_subr:
5287       {
5288         tree arg1_tree;
5289         tree result_tree;
5290
5291         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5292
5293         arg1_tree = ffecom_ptr_to_expr (arg1);
5294
5295         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5296                                   ffecom_gfrt_kindtype (gfrt),
5297                                   FALSE,
5298                                   NULL_TREE,
5299                                   build_tree_list (NULL_TREE, arg1_tree),
5300                                   NULL_TREE, NULL, NULL, NULL_TREE,
5301                                   TRUE,
5302                                   ffebld_nonter_hook (expr));
5303         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5304                                    convert (TREE_TYPE (result_tree),
5305                                             expr_tree));
5306       }
5307       return expr_tree;
5308
5309       /* Straightforward calls of libf2c routines: */
5310     case FFEINTRIN_impABORT:
5311     case FFEINTRIN_impACCESS:
5312     case FFEINTRIN_impBESJ0:
5313     case FFEINTRIN_impBESJ1:
5314     case FFEINTRIN_impBESJN:
5315     case FFEINTRIN_impBESY0:
5316     case FFEINTRIN_impBESY1:
5317     case FFEINTRIN_impBESYN:
5318     case FFEINTRIN_impCHDIR_func:
5319     case FFEINTRIN_impCHMOD_func:
5320     case FFEINTRIN_impDATE:
5321     case FFEINTRIN_impDATE_AND_TIME:
5322     case FFEINTRIN_impDBESJ0:
5323     case FFEINTRIN_impDBESJ1:
5324     case FFEINTRIN_impDBESJN:
5325     case FFEINTRIN_impDBESY0:
5326     case FFEINTRIN_impDBESY1:
5327     case FFEINTRIN_impDBESYN:
5328     case FFEINTRIN_impDTIME_func:
5329     case FFEINTRIN_impETIME_func:
5330     case FFEINTRIN_impFGETC_func:
5331     case FFEINTRIN_impFGET_func:
5332     case FFEINTRIN_impFNUM:
5333     case FFEINTRIN_impFPUTC_func:
5334     case FFEINTRIN_impFPUT_func:
5335     case FFEINTRIN_impFSEEK:
5336     case FFEINTRIN_impFSTAT_func:
5337     case FFEINTRIN_impFTELL_func:
5338     case FFEINTRIN_impGERROR:
5339     case FFEINTRIN_impGETARG:
5340     case FFEINTRIN_impGETCWD_func:
5341     case FFEINTRIN_impGETENV:
5342     case FFEINTRIN_impGETGID:
5343     case FFEINTRIN_impGETLOG:
5344     case FFEINTRIN_impGETPID:
5345     case FFEINTRIN_impGETUID:
5346     case FFEINTRIN_impGMTIME:
5347     case FFEINTRIN_impHOSTNM_func:
5348     case FFEINTRIN_impIDATE_unix:
5349     case FFEINTRIN_impIDATE_vxt:
5350     case FFEINTRIN_impIERRNO:
5351     case FFEINTRIN_impISATTY:
5352     case FFEINTRIN_impITIME:
5353     case FFEINTRIN_impKILL_func:
5354     case FFEINTRIN_impLINK_func:
5355     case FFEINTRIN_impLNBLNK:
5356     case FFEINTRIN_impLSTAT_func:
5357     case FFEINTRIN_impLTIME:
5358     case FFEINTRIN_impMCLOCK8:
5359     case FFEINTRIN_impMCLOCK:
5360     case FFEINTRIN_impPERROR:
5361     case FFEINTRIN_impRENAME_func:
5362     case FFEINTRIN_impSECNDS:
5363     case FFEINTRIN_impSECOND_func:
5364     case FFEINTRIN_impSLEEP:
5365     case FFEINTRIN_impSRAND:
5366     case FFEINTRIN_impSTAT_func:
5367     case FFEINTRIN_impSYMLNK_func:
5368     case FFEINTRIN_impSYSTEM_CLOCK:
5369     case FFEINTRIN_impSYSTEM_func:
5370     case FFEINTRIN_impTIME8:
5371     case FFEINTRIN_impTIME_unix:
5372     case FFEINTRIN_impTIME_vxt:
5373     case FFEINTRIN_impUMASK_func:
5374     case FFEINTRIN_impUNLINK_func:
5375       break;
5376
5377     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5378     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5379     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5380     case FFEINTRIN_impNONE:
5381     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5382       fprintf (stderr, "No %s implementation.\n",
5383                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5384       assert ("unimplemented intrinsic" == NULL);
5385       return error_mark_node;
5386     }
5387
5388   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5389
5390   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5391                                     ffebld_right (expr));
5392
5393   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5394                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5395                        tree_type,
5396                        expr_tree, dest_tree, dest, dest_used,
5397                        NULL_TREE, TRUE,
5398                        ffebld_nonter_hook (expr));
5399
5400   /* See bottom of this file for f2c transforms used to determine
5401      many of the above implementations.  The info seems to confuse
5402      Emacs's C mode indentation, which is why it's been moved to
5403      the bottom of this source file.  */
5404 }
5405
5406 /* For power (exponentiation) where right-hand operand is type INTEGER,
5407    generate in-line code to do it the fast way (which, if the operand
5408    is a constant, might just mean a series of multiplies).  */
5409
5410 static tree
5411 ffecom_expr_power_integer_ (ffebld expr)
5412 {
5413   tree l = ffecom_expr (ffebld_left (expr));
5414   tree r = ffecom_expr (ffebld_right (expr));
5415   tree ltype = TREE_TYPE (l);
5416   tree rtype = TREE_TYPE (r);
5417   tree result = NULL_TREE;
5418
5419   if (l == error_mark_node
5420       || r == error_mark_node)
5421     return error_mark_node;
5422
5423   if (TREE_CODE (r) == INTEGER_CST)
5424     {
5425       int sgn = tree_int_cst_sgn (r);
5426
5427       if (sgn == 0)
5428         return convert (ltype, integer_one_node);
5429
5430       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5431           && (sgn < 0))
5432         {
5433           /* Reciprocal of integer is either 0, -1, or 1, so after
5434              calculating that (which we leave to the back end to do
5435              or not do optimally), don't bother with any multiplying.  */
5436
5437           result = ffecom_tree_divide_ (ltype,
5438                                         convert (ltype, integer_one_node),
5439                                         l,
5440                                         NULL_TREE, NULL, NULL, NULL_TREE);
5441           r = ffecom_1 (NEGATE_EXPR,
5442                         rtype,
5443                         r);
5444           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5445             result = ffecom_1 (ABS_EXPR, rtype,
5446                                result);
5447         }
5448
5449       /* Generate appropriate series of multiplies, preceded
5450          by divide if the exponent is negative.  */
5451
5452       l = save_expr (l);
5453
5454       if (sgn < 0)
5455         {
5456           l = ffecom_tree_divide_ (ltype,
5457                                    convert (ltype, integer_one_node),
5458                                    l,
5459                                    NULL_TREE, NULL, NULL,
5460                                    ffebld_nonter_hook (expr));
5461           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5462           assert (TREE_CODE (r) == INTEGER_CST);
5463
5464           if (tree_int_cst_sgn (r) < 0)
5465             {                   /* The "most negative" number.  */
5466               r = ffecom_1 (NEGATE_EXPR, rtype,
5467                             ffecom_2 (RSHIFT_EXPR, rtype,
5468                                       r,
5469                                       integer_one_node));
5470               l = save_expr (l);
5471               l = ffecom_2 (MULT_EXPR, ltype,
5472                             l,
5473                             l);
5474             }
5475         }
5476
5477       for (;;)
5478         {
5479           if (TREE_INT_CST_LOW (r) & 1)
5480             {
5481               if (result == NULL_TREE)
5482                 result = l;
5483               else
5484                 result = ffecom_2 (MULT_EXPR, ltype,
5485                                    result,
5486                                    l);
5487             }
5488
5489           r = ffecom_2 (RSHIFT_EXPR, rtype,
5490                         r,
5491                         integer_one_node);
5492           if (integer_zerop (r))
5493             break;
5494           assert (TREE_CODE (r) == INTEGER_CST);
5495
5496           l = save_expr (l);
5497           l = ffecom_2 (MULT_EXPR, ltype,
5498                         l,
5499                         l);
5500         }
5501       return result;
5502     }
5503
5504   /* Though rhs isn't a constant, in-line code cannot be expanded
5505      while transforming dummies
5506      because the back end cannot be easily convinced to generate
5507      stores (MODIFY_EXPR), handle temporaries, and so on before
5508      all the appropriate rtx's have been generated for things like
5509      dummy args referenced in rhs -- which doesn't happen until
5510      store_parm_decls() is called (expand_function_start, I believe,
5511      does the actual rtx-stuffing of PARM_DECLs).
5512
5513      So, in this case, let the caller generate the call to the
5514      run-time-library function to evaluate the power for us.  */
5515
5516   if (ffecom_transform_only_dummies_)
5517     return NULL_TREE;
5518
5519   /* Right-hand operand not a constant, expand in-line code to figure
5520      out how to do the multiplies, &c.
5521
5522      The returned expression is expressed this way in GNU C, where l and
5523      r are the "inputs":
5524
5525      ({ typeof (r) rtmp = r;
5526         typeof (l) ltmp = l;
5527         typeof (l) result;
5528
5529         if (rtmp == 0)
5530           result = 1;
5531         else
5532           {
5533             if ((basetypeof (l) == basetypeof (int))
5534                 && (rtmp < 0))
5535               {
5536                 result = ((typeof (l)) 1) / ltmp;
5537                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5538                   result = -result;
5539               }
5540             else
5541               {
5542                 result = 1;
5543                 if ((basetypeof (l) != basetypeof (int))
5544                     && (rtmp < 0))
5545                   {
5546                     ltmp = ((typeof (l)) 1) / ltmp;
5547                     rtmp = -rtmp;
5548                     if (rtmp < 0)
5549                       {
5550                         rtmp = -(rtmp >> 1);
5551                         ltmp *= ltmp;
5552                       }
5553                   }
5554                 for (;;)
5555                   {
5556                     if (rtmp & 1)
5557                       result *= ltmp;
5558                     if ((rtmp >>= 1) == 0)
5559                       break;
5560                     ltmp *= ltmp;
5561                   }
5562               }
5563           }
5564         result;
5565      })
5566
5567      Note that some of the above is compile-time collapsable, such as
5568      the first part of the if statements that checks the base type of
5569      l against int.  The if statements are phrased that way to suggest
5570      an easy way to generate the if/else constructs here, knowing that
5571      the back end should (and probably does) eliminate the resulting
5572      dead code (either the int case or the non-int case), something
5573      it couldn't do without the redundant phrasing, requiring explicit
5574      dead-code elimination here, which would be kind of difficult to
5575      read.  */
5576
5577   {
5578     tree rtmp;
5579     tree ltmp;
5580     tree divide;
5581     tree basetypeof_l_is_int;
5582     tree se;
5583     tree t;
5584
5585     basetypeof_l_is_int
5586       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5587
5588     se = expand_start_stmt_expr ();
5589
5590     ffecom_start_compstmt ();
5591
5592 #ifndef HAHA
5593     rtmp = ffecom_make_tempvar ("power_r", rtype,
5594                                 FFETARGET_charactersizeNONE, -1);
5595     ltmp = ffecom_make_tempvar ("power_l", ltype,
5596                                 FFETARGET_charactersizeNONE, -1);
5597     result = ffecom_make_tempvar ("power_res", ltype,
5598                                   FFETARGET_charactersizeNONE, -1);
5599     if (TREE_CODE (ltype) == COMPLEX_TYPE
5600         || TREE_CODE (ltype) == RECORD_TYPE)
5601       divide = ffecom_make_tempvar ("power_div", ltype,
5602                                     FFETARGET_charactersizeNONE, -1);
5603     else
5604       divide = NULL_TREE;
5605 #else  /* HAHA */
5606     {
5607       tree hook;
5608
5609       hook = ffebld_nonter_hook (expr);
5610       assert (hook);
5611       assert (TREE_CODE (hook) == TREE_VEC);
5612       assert (TREE_VEC_LENGTH (hook) == 4);
5613       rtmp = TREE_VEC_ELT (hook, 0);
5614       ltmp = TREE_VEC_ELT (hook, 1);
5615       result = TREE_VEC_ELT (hook, 2);
5616       divide = TREE_VEC_ELT (hook, 3);
5617       if (TREE_CODE (ltype) == COMPLEX_TYPE
5618           || TREE_CODE (ltype) == RECORD_TYPE)
5619         assert (divide);
5620       else
5621         assert (! divide);
5622     }
5623 #endif  /* HAHA */
5624
5625     expand_expr_stmt (ffecom_modify (void_type_node,
5626                                      rtmp,
5627                                      r));
5628     expand_expr_stmt (ffecom_modify (void_type_node,
5629                                      ltmp,
5630                                      l));
5631     expand_start_cond (ffecom_truth_value
5632                        (ffecom_2 (EQ_EXPR, integer_type_node,
5633                                   rtmp,
5634                                   convert (rtype, integer_zero_node))),
5635                        0);
5636     expand_expr_stmt (ffecom_modify (void_type_node,
5637                                      result,
5638                                      convert (ltype, integer_one_node)));
5639     expand_start_else ();
5640     if (! integer_zerop (basetypeof_l_is_int))
5641       {
5642         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5643                                      rtmp,
5644                                      convert (rtype,
5645                                               integer_zero_node)),
5646                            0);
5647         expand_expr_stmt (ffecom_modify (void_type_node,
5648                                          result,
5649                                          ffecom_tree_divide_
5650                                          (ltype,
5651                                           convert (ltype, integer_one_node),
5652                                           ltmp,
5653                                           NULL_TREE, NULL, NULL,
5654                                           divide)));
5655         expand_start_cond (ffecom_truth_value
5656                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5657                                       ffecom_2 (LT_EXPR, integer_type_node,
5658                                                 ltmp,
5659                                                 convert (ltype,
5660                                                          integer_zero_node)),
5661                                       ffecom_2 (EQ_EXPR, integer_type_node,
5662                                                 ffecom_2 (BIT_AND_EXPR,
5663                                                           rtype,
5664                                                           ffecom_1 (NEGATE_EXPR,
5665                                                                     rtype,
5666                                                                     rtmp),
5667                                                           convert (rtype,
5668                                                                    integer_one_node)),
5669                                                 convert (rtype,
5670                                                          integer_zero_node)))),
5671                            0);
5672         expand_expr_stmt (ffecom_modify (void_type_node,
5673                                          result,
5674                                          ffecom_1 (NEGATE_EXPR,
5675                                                    ltype,
5676                                                    result)));
5677         expand_end_cond ();
5678         expand_start_else ();
5679       }
5680     expand_expr_stmt (ffecom_modify (void_type_node,
5681                                      result,
5682                                      convert (ltype, integer_one_node)));
5683     expand_start_cond (ffecom_truth_value
5684                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5685                                   ffecom_truth_value_invert
5686                                   (basetypeof_l_is_int),
5687                                   ffecom_2 (LT_EXPR, integer_type_node,
5688                                             rtmp,
5689                                             convert (rtype,
5690                                                      integer_zero_node)))),
5691                        0);
5692     expand_expr_stmt (ffecom_modify (void_type_node,
5693                                      ltmp,
5694                                      ffecom_tree_divide_
5695                                      (ltype,
5696                                       convert (ltype, integer_one_node),
5697                                       ltmp,
5698                                       NULL_TREE, NULL, NULL,
5699                                       divide)));
5700     expand_expr_stmt (ffecom_modify (void_type_node,
5701                                      rtmp,
5702                                      ffecom_1 (NEGATE_EXPR, rtype,
5703                                                rtmp)));
5704     expand_start_cond (ffecom_truth_value
5705                        (ffecom_2 (LT_EXPR, integer_type_node,
5706                                   rtmp,
5707                                   convert (rtype, integer_zero_node))),
5708                        0);
5709     expand_expr_stmt (ffecom_modify (void_type_node,
5710                                      rtmp,
5711                                      ffecom_1 (NEGATE_EXPR, rtype,
5712                                                ffecom_2 (RSHIFT_EXPR,
5713                                                          rtype,
5714                                                          rtmp,
5715                                                          integer_one_node))));
5716     expand_expr_stmt (ffecom_modify (void_type_node,
5717                                      ltmp,
5718                                      ffecom_2 (MULT_EXPR, ltype,
5719                                                ltmp,
5720                                                ltmp)));
5721     expand_end_cond ();
5722     expand_end_cond ();
5723     expand_start_loop (1);
5724     expand_start_cond (ffecom_truth_value
5725                        (ffecom_2 (BIT_AND_EXPR, rtype,
5726                                   rtmp,
5727                                   convert (rtype, integer_one_node))),
5728                        0);
5729     expand_expr_stmt (ffecom_modify (void_type_node,
5730                                      result,
5731                                      ffecom_2 (MULT_EXPR, ltype,
5732                                                result,
5733                                                ltmp)));
5734     expand_end_cond ();
5735     expand_exit_loop_if_false (NULL,
5736                                ffecom_truth_value
5737                                (ffecom_modify (rtype,
5738                                                rtmp,
5739                                                ffecom_2 (RSHIFT_EXPR,
5740                                                          rtype,
5741                                                          rtmp,
5742                                                          integer_one_node))));
5743     expand_expr_stmt (ffecom_modify (void_type_node,
5744                                      ltmp,
5745                                      ffecom_2 (MULT_EXPR, ltype,
5746                                                ltmp,
5747                                                ltmp)));
5748     expand_end_loop ();
5749     expand_end_cond ();
5750     if (!integer_zerop (basetypeof_l_is_int))
5751       expand_end_cond ();
5752     expand_expr_stmt (result);
5753
5754     t = ffecom_end_compstmt ();
5755
5756     result = expand_end_stmt_expr (se);
5757
5758     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5759
5760     if (TREE_CODE (t) == BLOCK)
5761       {
5762         /* Make a BIND_EXPR for the BLOCK already made.  */
5763         result = build (BIND_EXPR, TREE_TYPE (result),
5764                         NULL_TREE, result, t);
5765         /* Remove the block from the tree at this point.
5766            It gets put back at the proper place
5767            when the BIND_EXPR is expanded.  */
5768         delete_block (t);
5769       }
5770     else
5771       result = t;
5772   }
5773
5774   return result;
5775 }
5776
5777 /* ffecom_expr_transform_ -- Transform symbols in expr
5778
5779    ffebld expr;  // FFE expression.
5780    ffecom_expr_transform_ (expr);
5781
5782    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5783
5784 static void
5785 ffecom_expr_transform_ (ffebld expr)
5786 {
5787   tree t;
5788   ffesymbol s;
5789
5790  tail_recurse:
5791
5792   if (expr == NULL)
5793     return;
5794
5795   switch (ffebld_op (expr))
5796     {
5797     case FFEBLD_opSYMTER:
5798       s = ffebld_symter (expr);
5799       t = ffesymbol_hook (s).decl_tree;
5800       if ((t == NULL_TREE)
5801           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5802               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5803                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5804         {
5805           s = ffecom_sym_transform_ (s);
5806           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5807                                                    DIMENSION expr? */
5808         }
5809       break;                    /* Ok if (t == NULL) here. */
5810
5811     case FFEBLD_opITEM:
5812       ffecom_expr_transform_ (ffebld_head (expr));
5813       expr = ffebld_trail (expr);
5814       goto tail_recurse;        /* :::::::::::::::::::: */
5815
5816     default:
5817       break;
5818     }
5819
5820   switch (ffebld_arity (expr))
5821     {
5822     case 2:
5823       ffecom_expr_transform_ (ffebld_left (expr));
5824       expr = ffebld_right (expr);
5825       goto tail_recurse;        /* :::::::::::::::::::: */
5826
5827     case 1:
5828       expr = ffebld_left (expr);
5829       goto tail_recurse;        /* :::::::::::::::::::: */
5830
5831     default:
5832       break;
5833     }
5834
5835   return;
5836 }
5837
5838 /* Make a type based on info in live f2c.h file.  */
5839
5840 static void
5841 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5842 {
5843   switch (tcode)
5844     {
5845     case FFECOM_f2ccodeCHAR:
5846       *type = make_signed_type (CHAR_TYPE_SIZE);
5847       break;
5848
5849     case FFECOM_f2ccodeSHORT:
5850       *type = make_signed_type (SHORT_TYPE_SIZE);
5851       break;
5852
5853     case FFECOM_f2ccodeINT:
5854       *type = make_signed_type (INT_TYPE_SIZE);
5855       break;
5856
5857     case FFECOM_f2ccodeLONG:
5858       *type = make_signed_type (LONG_TYPE_SIZE);
5859       break;
5860
5861     case FFECOM_f2ccodeLONGLONG:
5862       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5863       break;
5864
5865     case FFECOM_f2ccodeCHARPTR:
5866       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5867                                   ? signed_char_type_node
5868                                   : unsigned_char_type_node);
5869       break;
5870
5871     case FFECOM_f2ccodeFLOAT:
5872       *type = make_node (REAL_TYPE);
5873       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5874       layout_type (*type);
5875       break;
5876
5877     case FFECOM_f2ccodeDOUBLE:
5878       *type = make_node (REAL_TYPE);
5879       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5880       layout_type (*type);
5881       break;
5882
5883     case FFECOM_f2ccodeLONGDOUBLE:
5884       *type = make_node (REAL_TYPE);
5885       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5886       layout_type (*type);
5887       break;
5888
5889     case FFECOM_f2ccodeTWOREALS:
5890       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5891       break;
5892
5893     case FFECOM_f2ccodeTWODOUBLEREALS:
5894       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5895       break;
5896
5897     default:
5898       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5899       *type = error_mark_node;
5900       return;
5901     }
5902
5903   pushdecl (build_decl (TYPE_DECL,
5904                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5905                         *type));
5906 }
5907
5908 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5909    given size.  */
5910
5911 static void
5912 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5913                           int code)
5914 {
5915   int j;
5916   tree t;
5917
5918   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5919     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5920         && compare_tree_int (TYPE_SIZE (t), size) == 0)
5921       {
5922         assert (code != -1);
5923         ffecom_f2c_typecode_[bt][j] = code;
5924         code = -1;
5925       }
5926 }
5927
5928 /* Finish up globals after doing all program units in file
5929
5930    Need to handle only uninitialized COMMON areas.  */
5931
5932 static ffeglobal
5933 ffecom_finish_global_ (ffeglobal global)
5934 {
5935   tree cbtype;
5936   tree cbt;
5937   tree size;
5938
5939   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5940       return global;
5941
5942   if (ffeglobal_common_init (global))
5943       return global;
5944
5945   cbt = ffeglobal_hook (global);
5946   if ((cbt == NULL_TREE)
5947       || !ffeglobal_common_have_size (global))
5948     return global;              /* No need to make common, never ref'd. */
5949
5950   DECL_EXTERNAL (cbt) = 0;
5951
5952   /* Give the array a size now.  */
5953
5954   size = build_int_2 ((ffeglobal_common_size (global)
5955                       + ffeglobal_common_pad (global)) - 1,
5956                       0);
5957
5958   cbtype = TREE_TYPE (cbt);
5959   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
5960                                            integer_zero_node,
5961                                            size);
5962   if (!TREE_TYPE (size))
5963     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
5964   layout_type (cbtype);
5965
5966   cbt = start_decl (cbt, FALSE);
5967   assert (cbt == ffeglobal_hook (global));
5968
5969   finish_decl (cbt, NULL_TREE, FALSE);
5970
5971   return global;
5972 }
5973
5974 /* Finish up any untransformed symbols.  */
5975
5976 static ffesymbol
5977 ffecom_finish_symbol_transform_ (ffesymbol s)
5978 {
5979   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
5980     return s;
5981
5982   /* It's easy to know to transform an untransformed symbol, to make sure
5983      we put out debugging info for it.  But COMMON variables, unlike
5984      EQUIVALENCE ones, aren't given declarations in addition to the
5985      tree expressions that specify offsets, because COMMON variables
5986      can be referenced in the outer scope where only dummy arguments
5987      (PARM_DECLs) should really be seen.  To be safe, just don't do any
5988      VAR_DECLs for COMMON variables when we transform them for real
5989      use, and therefore we do all the VAR_DECL creating here.  */
5990
5991   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
5992     {
5993       if (ffesymbol_kind (s) != FFEINFO_kindNONE
5994           || (ffesymbol_where (s) != FFEINFO_whereNONE
5995               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
5996               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
5997         /* Not transformed, and not CHARACTER*(*), and not a dummy
5998            argument, which can happen only if the entry point names
5999            it "rides in on" are all invalidated for other reasons.  */
6000         s = ffecom_sym_transform_ (s);
6001     }
6002
6003   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6004       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6005     {
6006       /* This isn't working, at least for dbxout.  The .s file looks
6007          okay to me (burley), but in gdb 4.9 at least, the variables
6008          appear to reside somewhere outside of the common area, so
6009          it doesn't make sense to mislead anyone by generating the info
6010          on those variables until this is fixed.  NOTE: Same problem
6011          with EQUIVALENCE, sadly...see similar #if later.  */
6012       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6013                              ffesymbol_storage (s));
6014     }
6015
6016   return s;
6017 }
6018
6019 /* Append underscore(s) to name before calling get_identifier.  "us"
6020    is nonzero if the name already contains an underscore and thus
6021    needs two underscores appended.  */
6022
6023 static tree
6024 ffecom_get_appended_identifier_ (char us, const char *name)
6025 {
6026   int i;
6027   char *newname;
6028   tree id;
6029
6030   newname = xmalloc ((i = strlen (name)) + 1
6031                      + ffe_is_underscoring ()
6032                      + us);
6033   memcpy (newname, name, i);
6034   newname[i] = '_';
6035   newname[i + us] = '_';
6036   newname[i + 1 + us] = '\0';
6037   id = get_identifier (newname);
6038
6039   free (newname);
6040
6041   return id;
6042 }
6043
6044 /* Decide whether to append underscore to name before calling
6045    get_identifier.  */
6046
6047 static tree
6048 ffecom_get_external_identifier_ (ffesymbol s)
6049 {
6050   char us;
6051   const char *name = ffesymbol_text (s);
6052
6053   /* If name is a built-in name, just return it as is.  */
6054
6055   if (!ffe_is_underscoring ()
6056       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6057 #if FFETARGET_isENFORCED_MAIN_NAME
6058       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6059 #else
6060       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6061 #endif
6062       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6063     return get_identifier (name);
6064
6065   us = ffe_is_second_underscore ()
6066     ? (strchr (name, '_') != NULL)
6067       : 0;
6068
6069   return ffecom_get_appended_identifier_ (us, name);
6070 }
6071
6072 /* Decide whether to append underscore to internal name before calling
6073    get_identifier.
6074
6075    This is for non-external, top-function-context names only.  Transform
6076    identifier so it doesn't conflict with the transformed result
6077    of using a _different_ external name.  E.g. if "CALL FOO" is
6078    transformed into "FOO_();", then the variable in "FOO_ = 3"
6079    must be transformed into something that does not conflict, since
6080    these two things should be independent.
6081
6082    The transformation is as follows.  If the name does not contain
6083    an underscore, there is no possible conflict, so just return.
6084    If the name does contain an underscore, then transform it just
6085    like we transform an external identifier.  */
6086
6087 static tree
6088 ffecom_get_identifier_ (const char *name)
6089 {
6090   /* If name does not contain an underscore, just return it as is.  */
6091
6092   if (!ffe_is_underscoring ()
6093       || (strchr (name, '_') == NULL))
6094     return get_identifier (name);
6095
6096   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6097                                           name);
6098 }
6099
6100 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6101
6102    tree t;
6103    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6104    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6105          ffesymbol_kindtype(s));
6106
6107    Call after setting up containing function and getting trees for all
6108    other symbols.  */
6109
6110 static tree
6111 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6112 {
6113   ffebld expr = ffesymbol_sfexpr (s);
6114   tree type;
6115   tree func;
6116   tree result;
6117   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6118   static bool recurse = FALSE;
6119   int old_lineno = lineno;
6120   const char *old_input_filename = input_filename;
6121
6122   ffecom_nested_entry_ = s;
6123
6124   /* For now, we don't have a handy pointer to where the sfunc is actually
6125      defined, though that should be easy to add to an ffesymbol. (The
6126      token/where info available might well point to the place where the type
6127      of the sfunc is declared, especially if that precedes the place where
6128      the sfunc itself is defined, which is typically the case.)  We should
6129      put out a null pointer rather than point somewhere wrong, but I want to
6130      see how it works at this point.  */
6131
6132   input_filename = ffesymbol_where_filename (s);
6133   lineno = ffesymbol_where_filelinenum (s);
6134
6135   /* Pretransform the expression so any newly discovered things belong to the
6136      outer program unit, not to the statement function. */
6137
6138   ffecom_expr_transform_ (expr);
6139
6140   /* Make sure no recursive invocation of this fn (a specific case of failing
6141      to pretransform an sfunc's expression, i.e. where its expression
6142      references another untransformed sfunc) happens. */
6143
6144   assert (!recurse);
6145   recurse = TRUE;
6146
6147   push_f_function_context ();
6148
6149   if (charfunc)
6150     type = void_type_node;
6151   else
6152     {
6153       type = ffecom_tree_type[bt][kt];
6154       if (type == NULL_TREE)
6155         type = integer_type_node;       /* _sym_exec_transition reports
6156                                            error. */
6157     }
6158
6159   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6160                   build_function_type (type, NULL_TREE),
6161                   1,            /* nested/inline */
6162                   0);           /* TREE_PUBLIC */
6163
6164   /* We don't worry about COMPLEX return values here, because this is
6165      entirely internal to our code, and gcc has the ability to return COMPLEX
6166      directly as a value.  */
6167
6168   if (charfunc)
6169     {                           /* Prepend arg for where result goes. */
6170       tree type;
6171
6172       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6173
6174       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6175
6176       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6177
6178       type = build_pointer_type (type);
6179       result = build_decl (PARM_DECL, result, type);
6180
6181       push_parm_decl (result);
6182     }
6183   else
6184     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6185
6186   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6187
6188   store_parm_decls (0);
6189
6190   ffecom_start_compstmt ();
6191
6192   if (expr != NULL)
6193     {
6194       if (charfunc)
6195         {
6196           ffetargetCharacterSize sz = ffesymbol_size (s);
6197           tree result_length;
6198
6199           result_length = build_int_2 (sz, 0);
6200           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6201
6202           ffecom_prepare_let_char_ (sz, expr);
6203
6204           ffecom_prepare_end ();
6205
6206           ffecom_let_char_ (result, result_length, sz, expr);
6207           expand_null_return ();
6208         }
6209       else
6210         {
6211           ffecom_prepare_expr (expr);
6212
6213           ffecom_prepare_end ();
6214
6215           expand_return (ffecom_modify (NULL_TREE,
6216                                         DECL_RESULT (current_function_decl),
6217                                         ffecom_expr (expr)));
6218         }
6219     }
6220
6221   ffecom_end_compstmt ();
6222
6223   func = current_function_decl;
6224   finish_function (1);
6225
6226   pop_f_function_context ();
6227
6228   recurse = FALSE;
6229
6230   lineno = old_lineno;
6231   input_filename = old_input_filename;
6232
6233   ffecom_nested_entry_ = NULL;
6234
6235   return func;
6236 }
6237
6238 static const char *
6239 ffecom_gfrt_args_ (ffecomGfrt ix)
6240 {
6241   return ffecom_gfrt_argstring_[ix];
6242 }
6243
6244 static tree
6245 ffecom_gfrt_tree_ (ffecomGfrt ix)
6246 {
6247   if (ffecom_gfrt_[ix] == NULL_TREE)
6248     ffecom_make_gfrt_ (ix);
6249
6250   return ffecom_1 (ADDR_EXPR,
6251                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6252                    ffecom_gfrt_[ix]);
6253 }
6254
6255 /* Return initialize-to-zero expression for this VAR_DECL.  */
6256
6257 /* A somewhat evil way to prevent the garbage collector
6258    from collecting 'tree' structures.  */
6259 #define NUM_TRACKED_CHUNK 63
6260 static struct tree_ggc_tracker
6261 {
6262   struct tree_ggc_tracker *next;
6263   tree trees[NUM_TRACKED_CHUNK];
6264 } *tracker_head = NULL;
6265
6266 static void
6267 mark_tracker_head (void *arg)
6268 {
6269   struct tree_ggc_tracker *head;
6270   int i;
6271
6272   for (head = * (struct tree_ggc_tracker **) arg;
6273        head != NULL;
6274        head = head->next)
6275   {
6276     ggc_mark (head);
6277     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6278       ggc_mark_tree (head->trees[i]);
6279   }
6280 }
6281
6282 void
6283 ffecom_save_tree_forever (tree t)
6284 {
6285   int i;
6286   if (tracker_head != NULL)
6287     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6288       if (tracker_head->trees[i] == NULL)
6289         {
6290           tracker_head->trees[i] = t;
6291           return;
6292         }
6293
6294   {
6295     /* Need to allocate a new block.  */
6296     struct tree_ggc_tracker *old_head = tracker_head;
6297
6298     tracker_head = ggc_alloc (sizeof (*tracker_head));
6299     tracker_head->next = old_head;
6300     tracker_head->trees[0] = t;
6301     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6302       tracker_head->trees[i] = NULL;
6303   }
6304 }
6305
6306 static tree
6307 ffecom_init_zero_ (tree decl)
6308 {
6309   tree init;
6310   int incremental = TREE_STATIC (decl);
6311   tree type = TREE_TYPE (decl);
6312
6313   if (incremental)
6314     {
6315       make_decl_rtl (decl, NULL);
6316       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6317     }
6318
6319   if ((TREE_CODE (type) != ARRAY_TYPE)
6320       && (TREE_CODE (type) != RECORD_TYPE)
6321       && (TREE_CODE (type) != UNION_TYPE)
6322       && !incremental)
6323     init = convert (type, integer_zero_node);
6324   else if (!incremental)
6325     {
6326       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6327       TREE_CONSTANT (init) = 1;
6328       TREE_STATIC (init) = 1;
6329     }
6330   else
6331     {
6332       assemble_zeros (int_size_in_bytes (type));
6333       init = error_mark_node;
6334     }
6335
6336   return init;
6337 }
6338
6339 static tree
6340 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6341                          tree *maybe_tree)
6342 {
6343   tree expr_tree;
6344   tree length_tree;
6345
6346   switch (ffebld_op (arg))
6347     {
6348     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6349       if (ffetarget_length_character1
6350           (ffebld_constant_character1
6351            (ffebld_conter (arg))) == 0)
6352         {
6353           *maybe_tree = integer_zero_node;
6354           return convert (tree_type, integer_zero_node);
6355         }
6356
6357       *maybe_tree = integer_one_node;
6358       expr_tree = build_int_2 (*ffetarget_text_character1
6359                                (ffebld_constant_character1
6360                                 (ffebld_conter (arg))),
6361                                0);
6362       TREE_TYPE (expr_tree) = tree_type;
6363       return expr_tree;
6364
6365     case FFEBLD_opSYMTER:
6366     case FFEBLD_opARRAYREF:
6367     case FFEBLD_opFUNCREF:
6368     case FFEBLD_opSUBSTR:
6369       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6370
6371       if ((expr_tree == error_mark_node)
6372           || (length_tree == error_mark_node))
6373         {
6374           *maybe_tree = error_mark_node;
6375           return error_mark_node;
6376         }
6377
6378       if (integer_zerop (length_tree))
6379         {
6380           *maybe_tree = integer_zero_node;
6381           return convert (tree_type, integer_zero_node);
6382         }
6383
6384       expr_tree
6385         = ffecom_1 (INDIRECT_REF,
6386                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6387                     expr_tree);
6388       expr_tree
6389         = ffecom_2 (ARRAY_REF,
6390                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6391                     expr_tree,
6392                     integer_one_node);
6393       expr_tree = convert (tree_type, expr_tree);
6394
6395       if (TREE_CODE (length_tree) == INTEGER_CST)
6396         *maybe_tree = integer_one_node;
6397       else                      /* Must check length at run time.  */
6398         *maybe_tree
6399           = ffecom_truth_value
6400             (ffecom_2 (GT_EXPR, integer_type_node,
6401                        length_tree,
6402                        ffecom_f2c_ftnlen_zero_node));
6403       return expr_tree;
6404
6405     case FFEBLD_opPAREN:
6406     case FFEBLD_opCONVERT:
6407       if (ffeinfo_size (ffebld_info (arg)) == 0)
6408         {
6409           *maybe_tree = integer_zero_node;
6410           return convert (tree_type, integer_zero_node);
6411         }
6412       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6413                                       maybe_tree);
6414
6415     case FFEBLD_opCONCATENATE:
6416       {
6417         tree maybe_left;
6418         tree maybe_right;
6419         tree expr_left;
6420         tree expr_right;
6421
6422         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6423                                              &maybe_left);
6424         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6425                                               &maybe_right);
6426         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6427                                 maybe_left,
6428                                 maybe_right);
6429         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6430                               maybe_left,
6431                               expr_left,
6432                               expr_right);
6433         return expr_tree;
6434       }
6435
6436     default:
6437       assert ("bad op in ICHAR" == NULL);
6438       return error_mark_node;
6439     }
6440 }
6441
6442 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6443
6444    tree length_arg;
6445    ffebld expr;
6446    length_arg = ffecom_intrinsic_len_ (expr);
6447
6448    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6449    subexpressions by constructing the appropriate tree for the
6450    length-of-character-text argument in a calling sequence.  */
6451
6452 static tree
6453 ffecom_intrinsic_len_ (ffebld expr)
6454 {
6455   ffetargetCharacter1 val;
6456   tree length;
6457
6458   switch (ffebld_op (expr))
6459     {
6460     case FFEBLD_opCONTER:
6461       val = ffebld_constant_character1 (ffebld_conter (expr));
6462       length = build_int_2 (ffetarget_length_character1 (val), 0);
6463       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6464       break;
6465
6466     case FFEBLD_opSYMTER:
6467       {
6468         ffesymbol s = ffebld_symter (expr);
6469         tree item;
6470
6471         item = ffesymbol_hook (s).decl_tree;
6472         if (item == NULL_TREE)
6473           {
6474             s = ffecom_sym_transform_ (s);
6475             item = ffesymbol_hook (s).decl_tree;
6476           }
6477         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6478           {
6479             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6480               length = ffesymbol_hook (s).length_tree;
6481             else
6482               {
6483                 length = build_int_2 (ffesymbol_size (s), 0);
6484                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6485               }
6486           }
6487         else if (item == error_mark_node)
6488           length = error_mark_node;
6489         else                    /* FFEINFO_kindFUNCTION: */
6490           length = NULL_TREE;
6491       }
6492       break;
6493
6494     case FFEBLD_opARRAYREF:
6495       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6496       break;
6497
6498     case FFEBLD_opSUBSTR:
6499       {
6500         ffebld start;
6501         ffebld end;
6502         ffebld thing = ffebld_right (expr);
6503         tree start_tree;
6504         tree end_tree;
6505
6506         assert (ffebld_op (thing) == FFEBLD_opITEM);
6507         start = ffebld_head (thing);
6508         thing = ffebld_trail (thing);
6509         assert (ffebld_trail (thing) == NULL);
6510         end = ffebld_head (thing);
6511
6512         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6513
6514         if (length == error_mark_node)
6515           break;
6516
6517         if (start == NULL)
6518           {
6519             if (end == NULL)
6520               ;
6521             else
6522               {
6523                 length = convert (ffecom_f2c_ftnlen_type_node,
6524                                   ffecom_expr (end));
6525               }
6526           }
6527         else
6528           {
6529             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6530                                   ffecom_expr (start));
6531
6532             if (start_tree == error_mark_node)
6533               {
6534                 length = error_mark_node;
6535                 break;
6536               }
6537
6538             if (end == NULL)
6539               {
6540                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6541                                    ffecom_f2c_ftnlen_one_node,
6542                                    ffecom_2 (MINUS_EXPR,
6543                                              ffecom_f2c_ftnlen_type_node,
6544                                              length,
6545                                              start_tree));
6546               }
6547             else
6548               {
6549                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6550                                     ffecom_expr (end));
6551
6552                 if (end_tree == error_mark_node)
6553                   {
6554                     length = error_mark_node;
6555                     break;
6556                   }
6557
6558                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6559                                    ffecom_f2c_ftnlen_one_node,
6560                                    ffecom_2 (MINUS_EXPR,
6561                                              ffecom_f2c_ftnlen_type_node,
6562                                              end_tree, start_tree));
6563               }
6564           }
6565       }
6566       break;
6567
6568     case FFEBLD_opCONCATENATE:
6569       length
6570         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6571                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6572                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6573       break;
6574
6575     case FFEBLD_opFUNCREF:
6576     case FFEBLD_opCONVERT:
6577       length = build_int_2 (ffebld_size (expr), 0);
6578       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6579       break;
6580
6581     default:
6582       assert ("bad op for single char arg expr" == NULL);
6583       length = ffecom_f2c_ftnlen_zero_node;
6584       break;
6585     }
6586
6587   assert (length != NULL_TREE);
6588
6589   return length;
6590 }
6591
6592 /* Handle CHARACTER assignments.
6593
6594    Generates code to do the assignment.  Used by ordinary assignment
6595    statement handler ffecom_let_stmt and by statement-function
6596    handler to generate code for a statement function.  */
6597
6598 static void
6599 ffecom_let_char_ (tree dest_tree, tree dest_length,
6600                   ffetargetCharacterSize dest_size, ffebld source)
6601 {
6602   ffecomConcatList_ catlist;
6603   tree source_length;
6604   tree source_tree;
6605   tree expr_tree;
6606
6607   if ((dest_tree == error_mark_node)
6608       || (dest_length == error_mark_node))
6609     return;
6610
6611   assert (dest_tree != NULL_TREE);
6612   assert (dest_length != NULL_TREE);
6613
6614   /* Source might be an opCONVERT, which just means it is a different size
6615      than the destination.  Since the underlying implementation here handles
6616      that (directly or via the s_copy or s_cat run-time-library functions),
6617      we don't need the "convenience" of an opCONVERT that tells us to
6618      truncate or blank-pad, particularly since the resulting implementation
6619      would probably be slower than otherwise. */
6620
6621   while (ffebld_op (source) == FFEBLD_opCONVERT)
6622     source = ffebld_left (source);
6623
6624   catlist = ffecom_concat_list_new_ (source, dest_size);
6625   switch (ffecom_concat_list_count_ (catlist))
6626     {
6627     case 0:                     /* Shouldn't happen, but in case it does... */
6628       ffecom_concat_list_kill_ (catlist);
6629       source_tree = null_pointer_node;
6630       source_length = ffecom_f2c_ftnlen_zero_node;
6631       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6632       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6633       TREE_CHAIN (TREE_CHAIN (expr_tree))
6634         = build_tree_list (NULL_TREE, dest_length);
6635       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6636         = build_tree_list (NULL_TREE, source_length);
6637
6638       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6639       TREE_SIDE_EFFECTS (expr_tree) = 1;
6640
6641       expand_expr_stmt (expr_tree);
6642
6643       return;
6644
6645     case 1:                     /* The (fairly) easy case. */
6646       ffecom_char_args_ (&source_tree, &source_length,
6647                          ffecom_concat_list_expr_ (catlist, 0));
6648       ffecom_concat_list_kill_ (catlist);
6649       assert (source_tree != NULL_TREE);
6650       assert (source_length != NULL_TREE);
6651
6652       if ((source_tree == error_mark_node)
6653           || (source_length == error_mark_node))
6654         return;
6655
6656       if (dest_size == 1)
6657         {
6658           dest_tree
6659             = ffecom_1 (INDIRECT_REF,
6660                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6661                                                       (dest_tree))),
6662                         dest_tree);
6663           dest_tree
6664             = ffecom_2 (ARRAY_REF,
6665                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6666                                                       (dest_tree))),
6667                         dest_tree,
6668                         integer_one_node);
6669           source_tree
6670             = ffecom_1 (INDIRECT_REF,
6671                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6672                                                       (source_tree))),
6673                         source_tree);
6674           source_tree
6675             = ffecom_2 (ARRAY_REF,
6676                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6677                                                       (source_tree))),
6678                         source_tree,
6679                         integer_one_node);
6680
6681           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6682
6683           expand_expr_stmt (expr_tree);
6684
6685           return;
6686         }
6687
6688       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6689       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6690       TREE_CHAIN (TREE_CHAIN (expr_tree))
6691         = build_tree_list (NULL_TREE, dest_length);
6692       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6693         = build_tree_list (NULL_TREE, source_length);
6694
6695       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6696       TREE_SIDE_EFFECTS (expr_tree) = 1;
6697
6698       expand_expr_stmt (expr_tree);
6699
6700       return;
6701
6702     default:                    /* Must actually concatenate things. */
6703       break;
6704     }
6705
6706   /* Heavy-duty concatenation. */
6707
6708   {
6709     int count = ffecom_concat_list_count_ (catlist);
6710     int i;
6711     tree lengths;
6712     tree items;
6713     tree length_array;
6714     tree item_array;
6715     tree citem;
6716     tree clength;
6717
6718 #ifdef HOHO
6719     length_array
6720       = lengths
6721       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6722                              FFETARGET_charactersizeNONE, count, TRUE);
6723     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6724                                               FFETARGET_charactersizeNONE,
6725                                               count, TRUE);
6726 #else
6727     {
6728       tree hook;
6729
6730       hook = ffebld_nonter_hook (source);
6731       assert (hook);
6732       assert (TREE_CODE (hook) == TREE_VEC);
6733       assert (TREE_VEC_LENGTH (hook) == 2);
6734       length_array = lengths = TREE_VEC_ELT (hook, 0);
6735       item_array = items = TREE_VEC_ELT (hook, 1);
6736     }
6737 #endif
6738
6739     for (i = 0; i < count; ++i)
6740       {
6741         ffecom_char_args_ (&citem, &clength,
6742                            ffecom_concat_list_expr_ (catlist, i));
6743         if ((citem == error_mark_node)
6744             || (clength == error_mark_node))
6745           {
6746             ffecom_concat_list_kill_ (catlist);
6747             return;
6748           }
6749
6750         items
6751           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6752                       ffecom_modify (void_type_node,
6753                                      ffecom_2 (ARRAY_REF,
6754                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6755                                                item_array,
6756                                                build_int_2 (i, 0)),
6757                                      citem),
6758                       items);
6759         lengths
6760           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6761                       ffecom_modify (void_type_node,
6762                                      ffecom_2 (ARRAY_REF,
6763                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6764                                                length_array,
6765                                                build_int_2 (i, 0)),
6766                                      clength),
6767                       lengths);
6768       }
6769
6770     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6771     TREE_CHAIN (expr_tree)
6772       = build_tree_list (NULL_TREE,
6773                          ffecom_1 (ADDR_EXPR,
6774                                    build_pointer_type (TREE_TYPE (items)),
6775                                    items));
6776     TREE_CHAIN (TREE_CHAIN (expr_tree))
6777       = build_tree_list (NULL_TREE,
6778                          ffecom_1 (ADDR_EXPR,
6779                                    build_pointer_type (TREE_TYPE (lengths)),
6780                                    lengths));
6781     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6782       = build_tree_list
6783         (NULL_TREE,
6784          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6785                    convert (ffecom_f2c_ftnlen_type_node,
6786                             build_int_2 (count, 0))));
6787     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6788       = build_tree_list (NULL_TREE, dest_length);
6789
6790     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6791     TREE_SIDE_EFFECTS (expr_tree) = 1;
6792
6793     expand_expr_stmt (expr_tree);
6794   }
6795
6796   ffecom_concat_list_kill_ (catlist);
6797 }
6798
6799 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6800
6801    ffecomGfrt ix;
6802    ffecom_make_gfrt_(ix);
6803
6804    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6805    for the indicated run-time routine (ix).  */
6806
6807 static void
6808 ffecom_make_gfrt_ (ffecomGfrt ix)
6809 {
6810   tree t;
6811   tree ttype;
6812
6813   switch (ffecom_gfrt_type_[ix])
6814     {
6815     case FFECOM_rttypeVOID_:
6816       ttype = void_type_node;
6817       break;
6818
6819     case FFECOM_rttypeVOIDSTAR_:
6820       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6821       break;
6822
6823     case FFECOM_rttypeFTNINT_:
6824       ttype = ffecom_f2c_ftnint_type_node;
6825       break;
6826
6827     case FFECOM_rttypeINTEGER_:
6828       ttype = ffecom_f2c_integer_type_node;
6829       break;
6830
6831     case FFECOM_rttypeLONGINT_:
6832       ttype = ffecom_f2c_longint_type_node;
6833       break;
6834
6835     case FFECOM_rttypeLOGICAL_:
6836       ttype = ffecom_f2c_logical_type_node;
6837       break;
6838
6839     case FFECOM_rttypeREAL_F2C_:
6840       ttype = double_type_node;
6841       break;
6842
6843     case FFECOM_rttypeREAL_GNU_:
6844       ttype = float_type_node;
6845       break;
6846
6847     case FFECOM_rttypeCOMPLEX_F2C_:
6848       ttype = void_type_node;
6849       break;
6850
6851     case FFECOM_rttypeCOMPLEX_GNU_:
6852       ttype = ffecom_f2c_complex_type_node;
6853       break;
6854
6855     case FFECOM_rttypeDOUBLE_:
6856       ttype = double_type_node;
6857       break;
6858
6859     case FFECOM_rttypeDOUBLEREAL_:
6860       ttype = ffecom_f2c_doublereal_type_node;
6861       break;
6862
6863     case FFECOM_rttypeDBLCMPLX_F2C_:
6864       ttype = void_type_node;
6865       break;
6866
6867     case FFECOM_rttypeDBLCMPLX_GNU_:
6868       ttype = ffecom_f2c_doublecomplex_type_node;
6869       break;
6870
6871     case FFECOM_rttypeCHARACTER_:
6872       ttype = void_type_node;
6873       break;
6874
6875     default:
6876       ttype = NULL;
6877       assert ("bad rttype" == NULL);
6878       break;
6879     }
6880
6881   ttype = build_function_type (ttype, NULL_TREE);
6882   t = build_decl (FUNCTION_DECL,
6883                   get_identifier (ffecom_gfrt_name_[ix]),
6884                   ttype);
6885   DECL_EXTERNAL (t) = 1;
6886   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6887   TREE_PUBLIC (t) = 1;
6888   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6889
6890   /* Sanity check:  A function that's const cannot be volatile.  */
6891
6892   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6893
6894   /* Sanity check: A function that's const cannot return complex.  */
6895
6896   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6897
6898   t = start_decl (t, TRUE);
6899
6900   finish_decl (t, NULL_TREE, TRUE);
6901
6902   ffecom_gfrt_[ix] = t;
6903 }
6904
6905 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6906
6907 static void
6908 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6909 {
6910   ffesymbol s = ffestorag_symbol (st);
6911
6912   if (ffesymbol_namelisted (s))
6913     ffecom_member_namelisted_ = TRUE;
6914 }
6915
6916 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
6917    the member so debugger will see it.  Otherwise nobody should be
6918    referencing the member.  */
6919
6920 static void
6921 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
6922 {
6923   ffesymbol s;
6924   tree t;
6925   tree mt;
6926   tree type;
6927
6928   if ((mst == NULL)
6929       || ((mt = ffestorag_hook (mst)) == NULL)
6930       || (mt == error_mark_node))
6931     return;
6932
6933   if ((st == NULL)
6934       || ((s = ffestorag_symbol (st)) == NULL))
6935     return;
6936
6937   type = ffecom_type_localvar_ (s,
6938                                 ffesymbol_basictype (s),
6939                                 ffesymbol_kindtype (s));
6940   if (type == error_mark_node)
6941     return;
6942
6943   t = build_decl (VAR_DECL,
6944                   ffecom_get_identifier_ (ffesymbol_text (s)),
6945                   type);
6946
6947   TREE_STATIC (t) = TREE_STATIC (mt);
6948   DECL_INITIAL (t) = NULL_TREE;
6949   TREE_ASM_WRITTEN (t) = 1;
6950   TREE_USED (t) = 1;
6951
6952   SET_DECL_RTL (t,
6953                 gen_rtx (MEM, TYPE_MODE (type),
6954                          plus_constant (XEXP (DECL_RTL (mt), 0),
6955                                         ffestorag_modulo (mst)
6956                                         + ffestorag_offset (st)
6957                                         - ffestorag_offset (mst))));
6958
6959   t = start_decl (t, FALSE);
6960
6961   finish_decl (t, NULL_TREE, FALSE);
6962 }
6963
6964 /* Prepare source expression for assignment into a destination perhaps known
6965    to be of a specific size.  */
6966
6967 static void
6968 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
6969 {
6970   ffecomConcatList_ catlist;
6971   int count;
6972   int i;
6973   tree ltmp;
6974   tree itmp;
6975   tree tempvar = NULL_TREE;
6976
6977   while (ffebld_op (source) == FFEBLD_opCONVERT)
6978     source = ffebld_left (source);
6979
6980   catlist = ffecom_concat_list_new_ (source, dest_size);
6981   count = ffecom_concat_list_count_ (catlist);
6982
6983   if (count >= 2)
6984     {
6985       ltmp
6986         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
6987                                FFETARGET_charactersizeNONE, count);
6988       itmp
6989         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
6990                                FFETARGET_charactersizeNONE, count);
6991
6992       tempvar = make_tree_vec (2);
6993       TREE_VEC_ELT (tempvar, 0) = ltmp;
6994       TREE_VEC_ELT (tempvar, 1) = itmp;
6995     }
6996
6997   for (i = 0; i < count; ++i)
6998     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
6999
7000   ffecom_concat_list_kill_ (catlist);
7001
7002   if (tempvar)
7003     {
7004       ffebld_nonter_set_hook (source, tempvar);
7005       current_binding_level->prep_state = 1;
7006     }
7007 }
7008
7009 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7010
7011    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7012    (which generates their trees) and then their trees get push_parm_decl'd.
7013
7014    The second arg is TRUE if the dummies are for a statement function, in
7015    which case lengths are not pushed for character arguments (since they are
7016    always known by both the caller and the callee, though the code allows
7017    for someday permitting CHAR*(*) stmtfunc dummies).  */
7018
7019 static void
7020 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7021 {
7022   ffebld dummy;
7023   ffebld dumlist;
7024   ffesymbol s;
7025   tree parm;
7026
7027   ffecom_transform_only_dummies_ = TRUE;
7028
7029   /* First push the parms corresponding to actual dummy "contents".  */
7030
7031   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7032     {
7033       dummy = ffebld_head (dumlist);
7034       switch (ffebld_op (dummy))
7035         {
7036         case FFEBLD_opSTAR:
7037         case FFEBLD_opANY:
7038           continue;             /* Forget alternate returns. */
7039
7040         default:
7041           break;
7042         }
7043       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7044       s = ffebld_symter (dummy);
7045       parm = ffesymbol_hook (s).decl_tree;
7046       if (parm == NULL_TREE)
7047         {
7048           s = ffecom_sym_transform_ (s);
7049           parm = ffesymbol_hook (s).decl_tree;
7050           assert (parm != NULL_TREE);
7051         }
7052       if (parm != error_mark_node)
7053         push_parm_decl (parm);
7054     }
7055
7056   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7057
7058   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7059     {
7060       dummy = ffebld_head (dumlist);
7061       switch (ffebld_op (dummy))
7062         {
7063         case FFEBLD_opSTAR:
7064         case FFEBLD_opANY:
7065           continue;             /* Forget alternate returns, they mean
7066                                    NOTHING! */
7067
7068         default:
7069           break;
7070         }
7071       s = ffebld_symter (dummy);
7072       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7073         continue;               /* Only looking for CHARACTER arguments. */
7074       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7075         continue;               /* Stmtfunc arg with known size needs no
7076                                    length param. */
7077       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7078         continue;               /* Only looking for variables and arrays. */
7079       parm = ffesymbol_hook (s).length_tree;
7080       assert (parm != NULL_TREE);
7081       if (parm != error_mark_node)
7082         push_parm_decl (parm);
7083     }
7084
7085   ffecom_transform_only_dummies_ = FALSE;
7086 }
7087
7088 /* ffecom_start_progunit_ -- Beginning of program unit
7089
7090    Does GNU back end stuff necessary to teach it about the start of its
7091    equivalent of a Fortran program unit.  */
7092
7093 static void
7094 ffecom_start_progunit_ ()
7095 {
7096   ffesymbol fn = ffecom_primary_entry_;
7097   ffebld arglist;
7098   tree id;                      /* Identifier (name) of function. */
7099   tree type;                    /* Type of function. */
7100   tree result;                  /* Result of function. */
7101   ffeinfoBasictype bt;
7102   ffeinfoKindtype kt;
7103   ffeglobal g;
7104   ffeglobalType gt;
7105   ffeglobalType egt = FFEGLOBAL_type;
7106   bool charfunc;
7107   bool cmplxfunc;
7108   bool altentries = (ffecom_num_entrypoints_ != 0);
7109   bool multi
7110   = altentries
7111   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7112   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7113   bool main_program = FALSE;
7114   int old_lineno = lineno;
7115   const char *old_input_filename = input_filename;
7116
7117   assert (fn != NULL);
7118   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7119
7120   input_filename = ffesymbol_where_filename (fn);
7121   lineno = ffesymbol_where_filelinenum (fn);
7122
7123   switch (ffecom_primary_entry_kind_)
7124     {
7125     case FFEINFO_kindPROGRAM:
7126       main_program = TRUE;
7127       gt = FFEGLOBAL_typeMAIN;
7128       bt = FFEINFO_basictypeNONE;
7129       kt = FFEINFO_kindtypeNONE;
7130       type = ffecom_tree_fun_type_void;
7131       charfunc = FALSE;
7132       cmplxfunc = FALSE;
7133       break;
7134
7135     case FFEINFO_kindBLOCKDATA:
7136       gt = FFEGLOBAL_typeBDATA;
7137       bt = FFEINFO_basictypeNONE;
7138       kt = FFEINFO_kindtypeNONE;
7139       type = ffecom_tree_fun_type_void;
7140       charfunc = FALSE;
7141       cmplxfunc = FALSE;
7142       break;
7143
7144     case FFEINFO_kindFUNCTION:
7145       gt = FFEGLOBAL_typeFUNC;
7146       egt = FFEGLOBAL_typeEXT;
7147       bt = ffesymbol_basictype (fn);
7148       kt = ffesymbol_kindtype (fn);
7149       if (bt == FFEINFO_basictypeNONE)
7150         {
7151           ffeimplic_establish_symbol (fn);
7152           if (ffesymbol_funcresult (fn) != NULL)
7153             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7154           bt = ffesymbol_basictype (fn);
7155           kt = ffesymbol_kindtype (fn);
7156         }
7157
7158       if (multi)
7159         charfunc = cmplxfunc = FALSE;
7160       else if (bt == FFEINFO_basictypeCHARACTER)
7161         charfunc = TRUE, cmplxfunc = FALSE;
7162       else if ((bt == FFEINFO_basictypeCOMPLEX)
7163                && ffesymbol_is_f2c (fn)
7164                && !altentries)
7165         charfunc = FALSE, cmplxfunc = TRUE;
7166       else
7167         charfunc = cmplxfunc = FALSE;
7168
7169       if (multi || charfunc)
7170         type = ffecom_tree_fun_type_void;
7171       else if (ffesymbol_is_f2c (fn) && !altentries)
7172         type = ffecom_tree_fun_type[bt][kt];
7173       else
7174         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7175
7176       if ((type == NULL_TREE)
7177           || (TREE_TYPE (type) == NULL_TREE))
7178         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7179       break;
7180
7181     case FFEINFO_kindSUBROUTINE:
7182       gt = FFEGLOBAL_typeSUBR;
7183       egt = FFEGLOBAL_typeEXT;
7184       bt = FFEINFO_basictypeNONE;
7185       kt = FFEINFO_kindtypeNONE;
7186       if (ffecom_is_altreturning_)
7187         type = ffecom_tree_subr_type;
7188       else
7189         type = ffecom_tree_fun_type_void;
7190       charfunc = FALSE;
7191       cmplxfunc = FALSE;
7192       break;
7193
7194     default:
7195       assert ("say what??" == NULL);
7196       /* Fall through. */
7197     case FFEINFO_kindANY:
7198       gt = FFEGLOBAL_typeANY;
7199       bt = FFEINFO_basictypeNONE;
7200       kt = FFEINFO_kindtypeNONE;
7201       type = error_mark_node;
7202       charfunc = FALSE;
7203       cmplxfunc = FALSE;
7204       break;
7205     }
7206
7207   if (altentries)
7208     {
7209       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7210                                            ffesymbol_text (fn));
7211     }
7212 #if FFETARGET_isENFORCED_MAIN
7213   else if (main_program)
7214     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7215 #endif
7216   else
7217     id = ffecom_get_external_identifier_ (fn);
7218
7219   start_function (id,
7220                   type,
7221                   0,            /* nested/inline */
7222                   !altentries); /* TREE_PUBLIC */
7223
7224   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7225
7226   if (!altentries
7227       && ((g = ffesymbol_global (fn)) != NULL)
7228       && ((ffeglobal_type (g) == gt)
7229           || (ffeglobal_type (g) == egt)))
7230     {
7231       ffeglobal_set_hook (g, current_function_decl);
7232     }
7233
7234   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7235      exec-transitioning needs current_function_decl to be filled in.  So we
7236      do these things in two phases. */
7237
7238   if (altentries)
7239     {                           /* 1st arg identifies which entrypoint. */
7240       ffecom_which_entrypoint_decl_
7241         = build_decl (PARM_DECL,
7242                       ffecom_get_invented_identifier ("__g77_%s",
7243                                                       "which_entrypoint"),
7244                       integer_type_node);
7245       push_parm_decl (ffecom_which_entrypoint_decl_);
7246     }
7247
7248   if (charfunc
7249       || cmplxfunc
7250       || multi)
7251     {                           /* Arg for result (return value). */
7252       tree type;
7253       tree length;
7254
7255       if (charfunc)
7256         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7257       else if (cmplxfunc)
7258         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7259       else
7260         type = ffecom_multi_type_node_;
7261
7262       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7263
7264       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7265
7266       if (charfunc)
7267         length = ffecom_char_enhance_arg_ (&type, fn);
7268       else
7269         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7270
7271       type = build_pointer_type (type);
7272       result = build_decl (PARM_DECL, result, type);
7273
7274       push_parm_decl (result);
7275       if (multi)
7276         ffecom_multi_retval_ = result;
7277       else
7278         ffecom_func_result_ = result;
7279
7280       if (charfunc)
7281         {
7282           push_parm_decl (length);
7283           ffecom_func_length_ = length;
7284         }
7285     }
7286
7287   if (ffecom_primary_entry_is_proc_)
7288     {
7289       if (altentries)
7290         arglist = ffecom_master_arglist_;
7291       else
7292         arglist = ffesymbol_dummyargs (fn);
7293       ffecom_push_dummy_decls_ (arglist, FALSE);
7294     }
7295
7296   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7297     store_parm_decls (main_program ? 1 : 0);
7298
7299   ffecom_start_compstmt ();
7300   /* Disallow temp vars at this level.  */
7301   current_binding_level->prep_state = 2;
7302
7303   lineno = old_lineno;
7304   input_filename = old_input_filename;
7305
7306   /* This handles any symbols still untransformed, in case -g specified.
7307      This used to be done in ffecom_finish_progunit, but it turns out to
7308      be necessary to do it here so that statement functions are
7309      expanded before code.  But don't bother for BLOCK DATA.  */
7310
7311   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7312     ffesymbol_drive (ffecom_finish_symbol_transform_);
7313 }
7314
7315 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7316
7317    ffesymbol s;
7318    ffecom_sym_transform_(s);
7319
7320    The ffesymbol_hook info for s is updated with appropriate backend info
7321    on the symbol.  */
7322
7323 static ffesymbol
7324 ffecom_sym_transform_ (ffesymbol s)
7325 {
7326   tree t;                       /* Transformed thingy. */
7327   tree tlen;                    /* Length if CHAR*(*). */
7328   bool addr;                    /* Is t the address of the thingy? */
7329   ffeinfoBasictype bt;
7330   ffeinfoKindtype kt;
7331   ffeglobal g;
7332   int old_lineno = lineno;
7333   const char *old_input_filename = input_filename;
7334
7335   /* Must ensure special ASSIGN variables are declared at top of outermost
7336      block, else they'll end up in the innermost block when their first
7337      ASSIGN is seen, which leaves them out of scope when they're the
7338      subject of a GOTO or I/O statement.
7339
7340      We make this variable even if -fugly-assign.  Just let it go unused,
7341      in case it turns out there are cases where we really want to use this
7342      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7343
7344   if (! ffecom_transform_only_dummies_
7345       && ffesymbol_assigned (s)
7346       && ! ffesymbol_hook (s).assign_tree)
7347     s = ffecom_sym_transform_assign_ (s);
7348
7349   if (ffesymbol_sfdummyparent (s) == NULL)
7350     {
7351       input_filename = ffesymbol_where_filename (s);
7352       lineno = ffesymbol_where_filelinenum (s);
7353     }
7354   else
7355     {
7356       ffesymbol sf = ffesymbol_sfdummyparent (s);
7357
7358       input_filename = ffesymbol_where_filename (sf);
7359       lineno = ffesymbol_where_filelinenum (sf);
7360     }
7361
7362   bt = ffeinfo_basictype (ffebld_info (s));
7363   kt = ffeinfo_kindtype (ffebld_info (s));
7364
7365   t = NULL_TREE;
7366   tlen = NULL_TREE;
7367   addr = FALSE;
7368
7369   switch (ffesymbol_kind (s))
7370     {
7371     case FFEINFO_kindNONE:
7372       switch (ffesymbol_where (s))
7373         {
7374         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7375           assert (ffecom_transform_only_dummies_);
7376
7377           /* Before 0.4, this could be ENTITY/DUMMY, but see
7378              ffestu_sym_end_transition -- no longer true (in particular, if
7379              it could be an ENTITY, it _will_ be made one, so that
7380              possibility won't come through here).  So we never make length
7381              arg for CHARACTER type.  */
7382
7383           t = build_decl (PARM_DECL,
7384                           ffecom_get_identifier_ (ffesymbol_text (s)),
7385                           ffecom_tree_ptr_to_subr_type);
7386           DECL_ARTIFICIAL (t) = 1;
7387           addr = TRUE;
7388           break;
7389
7390         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7391           assert (!ffecom_transform_only_dummies_);
7392
7393           if (((g = ffesymbol_global (s)) != NULL)
7394               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7395                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7396                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7397               && (ffeglobal_hook (g) != NULL_TREE)
7398               && ffe_is_globals ())
7399             {
7400               t = ffeglobal_hook (g);
7401               break;
7402             }
7403
7404           t = build_decl (FUNCTION_DECL,
7405                           ffecom_get_external_identifier_ (s),
7406                           ffecom_tree_subr_type);       /* Assume subr. */
7407           DECL_EXTERNAL (t) = 1;
7408           TREE_PUBLIC (t) = 1;
7409
7410           t = start_decl (t, FALSE);
7411           finish_decl (t, NULL_TREE, FALSE);
7412
7413           if ((g != NULL)
7414               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7415                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7416                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7417             ffeglobal_set_hook (g, t);
7418
7419           ffecom_save_tree_forever (t);
7420
7421           break;
7422
7423         default:
7424           assert ("NONE where unexpected" == NULL);
7425           /* Fall through. */
7426         case FFEINFO_whereANY:
7427           break;
7428         }
7429       break;
7430
7431     case FFEINFO_kindENTITY:
7432       switch (ffeinfo_where (ffesymbol_info (s)))
7433         {
7434
7435         case FFEINFO_whereCONSTANT:
7436           /* ~~Debugging info needed? */
7437           assert (!ffecom_transform_only_dummies_);
7438           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7439           break;
7440
7441         case FFEINFO_whereLOCAL:
7442           assert (!ffecom_transform_only_dummies_);
7443
7444           {
7445             ffestorag st = ffesymbol_storage (s);
7446             tree type;
7447
7448             if ((st != NULL)
7449                 && (ffestorag_size (st) == 0))
7450               {
7451                 t = error_mark_node;
7452                 break;
7453               }
7454
7455             type = ffecom_type_localvar_ (s, bt, kt);
7456
7457             if (type == error_mark_node)
7458               {
7459                 t = error_mark_node;
7460                 break;
7461               }
7462
7463             if ((st != NULL)
7464                 && (ffestorag_parent (st) != NULL))
7465               {                 /* Child of EQUIVALENCE parent. */
7466                 ffestorag est;
7467                 tree et;
7468                 ffetargetOffset offset;
7469
7470                 est = ffestorag_parent (st);
7471                 ffecom_transform_equiv_ (est);
7472
7473                 et = ffestorag_hook (est);
7474                 assert (et != NULL_TREE);
7475
7476                 if (! TREE_STATIC (et))
7477                   put_var_into_stack (et);
7478
7479                 offset = ffestorag_modulo (est)
7480                   + ffestorag_offset (ffesymbol_storage (s))
7481                   - ffestorag_offset (est);
7482
7483                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7484
7485                 /* (t_type *) (((char *) &et) + offset) */
7486
7487                 t = convert (string_type_node,  /* (char *) */
7488                              ffecom_1 (ADDR_EXPR,
7489                                        build_pointer_type (TREE_TYPE (et)),
7490                                        et));
7491                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7492                               t,
7493                               build_int_2 (offset, 0));
7494                 t = convert (build_pointer_type (type),
7495                              t);
7496                 TREE_CONSTANT (t) = staticp (et);
7497
7498                 addr = TRUE;
7499               }
7500             else
7501               {
7502                 tree initexpr;
7503                 bool init = ffesymbol_is_init (s);
7504
7505                 t = build_decl (VAR_DECL,
7506                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7507                                 type);
7508
7509                 if (init
7510                     || ffesymbol_namelisted (s)
7511 #ifdef FFECOM_sizeMAXSTACKITEM
7512                     || ((st != NULL)
7513                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7514 #endif
7515                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7516                         && (ffecom_primary_entry_kind_
7517                             != FFEINFO_kindBLOCKDATA)
7518                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7519                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7520                 else
7521                   TREE_STATIC (t) = 0;  /* No need to make static. */
7522
7523                 if (init || ffe_is_init_local_zero ())
7524                   DECL_INITIAL (t) = error_mark_node;
7525
7526                 /* Keep -Wunused from complaining about var if it
7527                    is used as sfunc arg or DATA implied-DO.  */
7528                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7529                   DECL_IN_SYSTEM_HEADER (t) = 1;
7530
7531                 t = start_decl (t, FALSE);
7532
7533                 if (init)
7534                   {
7535                     if (ffesymbol_init (s) != NULL)
7536                       initexpr = ffecom_expr (ffesymbol_init (s));
7537                     else
7538                       initexpr = ffecom_init_zero_ (t);
7539                   }
7540                 else if (ffe_is_init_local_zero ())
7541                   initexpr = ffecom_init_zero_ (t);
7542                 else
7543                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7544
7545                 finish_decl (t, initexpr, FALSE);
7546
7547                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7548                   {
7549                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7550                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7551                                                    ffestorag_size (st)));
7552                   }
7553               }
7554           }
7555           break;
7556
7557         case FFEINFO_whereRESULT:
7558           assert (!ffecom_transform_only_dummies_);
7559
7560           if (bt == FFEINFO_basictypeCHARACTER)
7561             {                   /* Result is already in list of dummies, use
7562                                    it (& length). */
7563               t = ffecom_func_result_;
7564               tlen = ffecom_func_length_;
7565               addr = TRUE;
7566               break;
7567             }
7568           if ((ffecom_num_entrypoints_ == 0)
7569               && (bt == FFEINFO_basictypeCOMPLEX)
7570               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7571             {                   /* Result is already in list of dummies, use
7572                                    it. */
7573               t = ffecom_func_result_;
7574               addr = TRUE;
7575               break;
7576             }
7577           if (ffecom_func_result_ != NULL_TREE)
7578             {
7579               t = ffecom_func_result_;
7580               break;
7581             }
7582           if ((ffecom_num_entrypoints_ != 0)
7583               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7584             {
7585               assert (ffecom_multi_retval_ != NULL_TREE);
7586               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7587                             ffecom_multi_retval_);
7588               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7589                             t, ffecom_multi_fields_[bt][kt]);
7590
7591               break;
7592             }
7593
7594           t = build_decl (VAR_DECL,
7595                           ffecom_get_identifier_ (ffesymbol_text (s)),
7596                           ffecom_tree_type[bt][kt]);
7597           TREE_STATIC (t) = 0;  /* Put result on stack. */
7598           t = start_decl (t, FALSE);
7599           finish_decl (t, NULL_TREE, FALSE);
7600
7601           ffecom_func_result_ = t;
7602
7603           break;
7604
7605         case FFEINFO_whereDUMMY:
7606           {
7607             tree type;
7608             ffebld dl;
7609             ffebld dim;
7610             tree low;
7611             tree high;
7612             tree old_sizes;
7613             bool adjustable = FALSE;    /* Conditionally adjustable? */
7614
7615             type = ffecom_tree_type[bt][kt];
7616             if (ffesymbol_sfdummyparent (s) != NULL)
7617               {
7618                 if (current_function_decl == ffecom_outer_function_decl_)
7619                   {                     /* Exec transition before sfunc
7620                                            context; get it later. */
7621                     break;
7622                   }
7623                 t = ffecom_get_identifier_ (ffesymbol_text
7624                                             (ffesymbol_sfdummyparent (s)));
7625               }
7626             else
7627               t = ffecom_get_identifier_ (ffesymbol_text (s));
7628
7629             assert (ffecom_transform_only_dummies_);
7630
7631             old_sizes = get_pending_sizes ();
7632             put_pending_sizes (old_sizes);
7633
7634             if (bt == FFEINFO_basictypeCHARACTER)
7635               tlen = ffecom_char_enhance_arg_ (&type, s);
7636             type = ffecom_check_size_overflow_ (s, type, TRUE);
7637
7638             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7639               {
7640                 if (type == error_mark_node)
7641                   break;
7642
7643                 dim = ffebld_head (dl);
7644                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7645                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7646                   low = ffecom_integer_one_node;
7647                 else
7648                   low = ffecom_expr (ffebld_left (dim));
7649                 assert (ffebld_right (dim) != NULL);
7650                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7651                     || ffecom_doing_entry_)
7652                   {
7653                     /* Used to just do high=low.  But for ffecom_tree_
7654                        canonize_ref_, it probably is important to correctly
7655                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7656                        C(2)=CFUNC(C), overlap can happen, while it can't
7657                        for, say, C(1)=CFUNC(C(2)).  */
7658                     /* Even more recently used to set to INT_MAX, but that
7659                        broke when some overflow checking went into the back
7660                        end.  Now we just leave the upper bound unspecified.  */
7661                     high = NULL;
7662                   }
7663                 else
7664                   high = ffecom_expr (ffebld_right (dim));
7665
7666                 /* Determine whether array is conditionally adjustable,
7667                    to decide whether back-end magic is needed.
7668
7669                    Normally the front end uses the back-end function
7670                    variable_size to wrap SAVE_EXPR's around expressions
7671                    affecting the size/shape of an array so that the
7672                    size/shape info doesn't change during execution
7673                    of the compiled code even though variables and
7674                    functions referenced in those expressions might.
7675
7676                    variable_size also makes sure those saved expressions
7677                    get evaluated immediately upon entry to the
7678                    compiled procedure -- the front end normally doesn't
7679                    have to worry about that.
7680
7681                    However, there is a problem with this that affects
7682                    g77's implementation of entry points, and that is
7683                    that it is _not_ true that each invocation of the
7684                    compiled procedure is permitted to evaluate
7685                    array size/shape info -- because it is possible
7686                    that, for some invocations, that info is invalid (in
7687                    which case it is "promised" -- i.e. a violation of
7688                    the Fortran standard -- that the compiled code
7689                    won't reference the array or its size/shape
7690                    during that particular invocation).
7691
7692                    To phrase this in C terms, consider this gcc function:
7693
7694                      void foo (int *n, float (*a)[*n])
7695                      {
7696                        // a is "pointer to array ...", fyi.
7697                      }
7698
7699                    Suppose that, for some invocations, it is permitted
7700                    for a caller of foo to do this:
7701
7702                        foo (NULL, NULL);
7703
7704                    Now the _written_ code for foo can take such a call
7705                    into account by either testing explicitly for whether
7706                    (a == NULL) || (n == NULL) -- presumably it is
7707                    not permitted to reference *a in various fashions
7708                    if (n == NULL) I suppose -- or it can avoid it by
7709                    looking at other info (other arguments, static/global
7710                    data, etc.).
7711
7712                    However, this won't work in gcc 2.5.8 because it'll
7713                    automatically emit the code to save the "*n"
7714                    expression, which'll yield a NULL dereference for
7715                    the "foo (NULL, NULL)" call, something the code
7716                    for foo cannot prevent.
7717
7718                    g77 definitely needs to avoid executing such
7719                    code anytime the pointer to the adjustable array
7720                    is NULL, because even if its bounds expressions
7721                    don't have any references to possible "absent"
7722                    variables like "*n" -- say all variable references
7723                    are to COMMON variables, i.e. global (though in C,
7724                    local static could actually make sense) -- the
7725                    expressions could yield other run-time problems
7726                    for allowably "dead" values in those variables.
7727
7728                    For example, let's consider a more complicated
7729                    version of foo:
7730
7731                      extern int i;
7732                      extern int j;
7733
7734                      void foo (float (*a)[i/j])
7735                      {
7736                        ...
7737                      }
7738
7739                    The above is (essentially) quite valid for Fortran
7740                    but, again, for a call like "foo (NULL);", it is
7741                    permitted for i and j to be undefined when the
7742                    call is made.  If j happened to be zero, for
7743                    example, emitting the code to evaluate "i/j"
7744                    could result in a run-time error.
7745
7746                    Offhand, though I don't have my F77 or F90
7747                    standards handy, it might even be valid for a
7748                    bounds expression to contain a function reference,
7749                    in which case I doubt it is permitted for an
7750                    implementation to invoke that function in the
7751                    Fortran case involved here (invocation of an
7752                    alternate ENTRY point that doesn't have the adjustable
7753                    array as one of its arguments).
7754
7755                    So, the code that the compiler would normally emit
7756                    to preevaluate the size/shape info for an
7757                    adjustable array _must not_ be executed at run time
7758                    in certain cases.  Specifically, for Fortran,
7759                    the case is when the pointer to the adjustable
7760                    array == NULL.  (For gnu-ish C, it might be nice
7761                    for the source code itself to specify an expression
7762                    that, if TRUE, inhibits execution of the code.  Or
7763                    reverse the sense for elegance.)
7764
7765                    (Note that g77 could use a different test than NULL,
7766                    actually, since it happens to always pass an
7767                    integer to the called function that specifies which
7768                    entry point is being invoked.  Hmm, this might
7769                    solve the next problem.)
7770
7771                    One way a user could, I suppose, write "foo" so
7772                    it works is to insert COND_EXPR's for the
7773                    size/shape info so the dangerous stuff isn't
7774                    actually done, as in:
7775
7776                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7777                      {
7778                        ...
7779                      }
7780
7781                    The next problem is that the front end needs to
7782                    be able to tell the back end about the array's
7783                    decl _before_ it tells it about the conditional
7784                    expression to inhibit evaluation of size/shape info,
7785                    as shown above.
7786
7787                    To solve this, the front end needs to be able
7788                    to give the back end the expression to inhibit
7789                    generation of the preevaluation code _after_
7790                    it makes the decl for the adjustable array.
7791
7792                    Until then, the above example using the COND_EXPR
7793                    doesn't pass muster with gcc because the "(a == NULL)"
7794                    part has a reference to "a", which is still
7795                    undefined at that point.
7796
7797                    g77 will therefore use a different mechanism in the
7798                    meantime.  */
7799
7800                 if (!adjustable
7801                     && ((TREE_CODE (low) != INTEGER_CST)
7802                         || (high && TREE_CODE (high) != INTEGER_CST)))
7803                   adjustable = TRUE;
7804
7805 #if 0                           /* Old approach -- see below. */
7806                 if (TREE_CODE (low) != INTEGER_CST)
7807                   low = ffecom_3 (COND_EXPR, integer_type_node,
7808                                   ffecom_adjarray_passed_ (s),
7809                                   low,
7810                                   ffecom_integer_zero_node);
7811
7812                 if (high && TREE_CODE (high) != INTEGER_CST)
7813                   high = ffecom_3 (COND_EXPR, integer_type_node,
7814                                    ffecom_adjarray_passed_ (s),
7815                                    high,
7816                                    ffecom_integer_zero_node);
7817 #endif
7818
7819                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7820                    probably.  Fixes 950302-1.f.  */
7821
7822                 if (TREE_CODE (low) != INTEGER_CST)
7823                   low = variable_size (low);
7824
7825                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7826                    does this, which is why dumb0.c would work.  */
7827
7828                 if (high && TREE_CODE (high) != INTEGER_CST)
7829                   high = variable_size (high);
7830
7831                 type
7832                   = build_array_type
7833                     (type,
7834                      build_range_type (ffecom_integer_type_node,
7835                                        low, high));
7836                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7837               }
7838
7839             if (type == error_mark_node)
7840               {
7841                 t = error_mark_node;
7842                 break;
7843               }
7844
7845             if ((ffesymbol_sfdummyparent (s) == NULL)
7846                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7847               {
7848                 type = build_pointer_type (type);
7849                 addr = TRUE;
7850               }
7851
7852             t = build_decl (PARM_DECL, t, type);
7853             DECL_ARTIFICIAL (t) = 1;
7854
7855             /* If this arg is present in every entry point's list of
7856                dummy args, then we're done.  */
7857
7858             if (ffesymbol_numentries (s)
7859                 == (ffecom_num_entrypoints_ + 1))
7860               break;
7861
7862 #if 1
7863
7864             /* If variable_size in stor-layout has been called during
7865                the above, then get_pending_sizes should have the
7866                yet-to-be-evaluated saved expressions pending.
7867                Make the whole lot of them get emitted, conditionally
7868                on whether the array decl ("t" above) is not NULL.  */
7869
7870             {
7871               tree sizes = get_pending_sizes ();
7872               tree tem;
7873
7874               for (tem = sizes;
7875                    tem != old_sizes;
7876                    tem = TREE_CHAIN (tem))
7877                 {
7878                   tree temv = TREE_VALUE (tem);
7879
7880                   if (sizes == tem)
7881                     sizes = temv;
7882                   else
7883                     sizes
7884                       = ffecom_2 (COMPOUND_EXPR,
7885                                   TREE_TYPE (sizes),
7886                                   temv,
7887                                   sizes);
7888                 }
7889
7890               if (sizes != tem)
7891                 {
7892                   sizes
7893                     = ffecom_3 (COND_EXPR,
7894                                 TREE_TYPE (sizes),
7895                                 ffecom_2 (NE_EXPR,
7896                                           integer_type_node,
7897                                           t,
7898                                           null_pointer_node),
7899                                 sizes,
7900                                 convert (TREE_TYPE (sizes),
7901                                          integer_zero_node));
7902                   sizes = ffecom_save_tree (sizes);
7903
7904                   sizes
7905                     = tree_cons (NULL_TREE, sizes, tem);
7906                 }
7907
7908               if (sizes)
7909                 put_pending_sizes (sizes);
7910             }
7911
7912 #else
7913 #if 0
7914             if (adjustable
7915                 && (ffesymbol_numentries (s)
7916                     != ffecom_num_entrypoints_ + 1))
7917               DECL_SOMETHING (t)
7918                 = ffecom_2 (NE_EXPR, integer_type_node,
7919                             t,
7920                             null_pointer_node);
7921 #else
7922 #if 0
7923             if (adjustable
7924                 && (ffesymbol_numentries (s)
7925                     != ffecom_num_entrypoints_ + 1))
7926               {
7927                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
7928                 ffebad_here (0, ffesymbol_where_line (s),
7929                              ffesymbol_where_column (s));
7930                 ffebad_string (ffesymbol_text (s));
7931                 ffebad_finish ();
7932               }
7933 #endif
7934 #endif
7935 #endif
7936           }
7937           break;
7938
7939         case FFEINFO_whereCOMMON:
7940           {
7941             ffesymbol cs;
7942             ffeglobal cg;
7943             tree ct;
7944             ffestorag st = ffesymbol_storage (s);
7945             tree type;
7946
7947             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
7948             if (st != NULL)     /* Else not laid out. */
7949               {
7950                 ffecom_transform_common_ (cs);
7951                 st = ffesymbol_storage (s);
7952               }
7953
7954             type = ffecom_type_localvar_ (s, bt, kt);
7955
7956             cg = ffesymbol_global (cs); /* The global COMMON info.  */
7957             if ((cg == NULL)
7958                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
7959               ct = NULL_TREE;
7960             else
7961               ct = ffeglobal_hook (cg); /* The common area's tree.  */
7962
7963             if ((ct == NULL_TREE)
7964                 || (st == NULL)
7965                 || (type == error_mark_node))
7966               t = error_mark_node;
7967             else
7968               {
7969                 ffetargetOffset offset;
7970                 ffestorag cst;
7971
7972                 cst = ffestorag_parent (st);
7973                 assert (cst == ffesymbol_storage (cs));
7974
7975                 offset = ffestorag_modulo (cst)
7976                   + ffestorag_offset (st)
7977                   - ffestorag_offset (cst);
7978
7979                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
7980
7981                 /* (t_type *) (((char *) &ct) + offset) */
7982
7983                 t = convert (string_type_node,  /* (char *) */
7984                              ffecom_1 (ADDR_EXPR,
7985                                        build_pointer_type (TREE_TYPE (ct)),
7986                                        ct));
7987                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7988                               t,
7989                               build_int_2 (offset, 0));
7990                 t = convert (build_pointer_type (type),
7991                              t);
7992                 TREE_CONSTANT (t) = 1;
7993
7994                 addr = TRUE;
7995               }
7996           }
7997           break;
7998
7999         case FFEINFO_whereIMMEDIATE:
8000         case FFEINFO_whereGLOBAL:
8001         case FFEINFO_whereFLEETING:
8002         case FFEINFO_whereFLEETING_CADDR:
8003         case FFEINFO_whereFLEETING_IADDR:
8004         case FFEINFO_whereINTRINSIC:
8005         case FFEINFO_whereCONSTANT_SUBOBJECT:
8006         default:
8007           assert ("ENTITY where unheard of" == NULL);
8008           /* Fall through. */
8009         case FFEINFO_whereANY:
8010           t = error_mark_node;
8011           break;
8012         }
8013       break;
8014
8015     case FFEINFO_kindFUNCTION:
8016       switch (ffeinfo_where (ffesymbol_info (s)))
8017         {
8018         case FFEINFO_whereLOCAL:        /* Me. */
8019           assert (!ffecom_transform_only_dummies_);
8020           t = current_function_decl;
8021           break;
8022
8023         case FFEINFO_whereGLOBAL:
8024           assert (!ffecom_transform_only_dummies_);
8025
8026           if (((g = ffesymbol_global (s)) != NULL)
8027               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8028                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8029               && (ffeglobal_hook (g) != NULL_TREE)
8030               && ffe_is_globals ())
8031             {
8032               t = ffeglobal_hook (g);
8033               break;
8034             }
8035
8036           if (ffesymbol_is_f2c (s)
8037               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8038             t = ffecom_tree_fun_type[bt][kt];
8039           else
8040             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8041
8042           t = build_decl (FUNCTION_DECL,
8043                           ffecom_get_external_identifier_ (s),
8044                           t);
8045           DECL_EXTERNAL (t) = 1;
8046           TREE_PUBLIC (t) = 1;
8047
8048           t = start_decl (t, FALSE);
8049           finish_decl (t, NULL_TREE, FALSE);
8050
8051           if ((g != NULL)
8052               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8053                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8054             ffeglobal_set_hook (g, t);
8055
8056           ffecom_save_tree_forever (t);
8057
8058           break;
8059
8060         case FFEINFO_whereDUMMY:
8061           assert (ffecom_transform_only_dummies_);
8062
8063           if (ffesymbol_is_f2c (s)
8064               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8065             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8066           else
8067             t = build_pointer_type
8068               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8069
8070           t = build_decl (PARM_DECL,
8071                           ffecom_get_identifier_ (ffesymbol_text (s)),
8072                           t);
8073           DECL_ARTIFICIAL (t) = 1;
8074           addr = TRUE;
8075           break;
8076
8077         case FFEINFO_whereCONSTANT:     /* Statement function. */
8078           assert (!ffecom_transform_only_dummies_);
8079           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8080           break;
8081
8082         case FFEINFO_whereINTRINSIC:
8083           assert (!ffecom_transform_only_dummies_);
8084           break;                /* Let actual references generate their
8085                                    decls. */
8086
8087         default:
8088           assert ("FUNCTION where unheard of" == NULL);
8089           /* Fall through. */
8090         case FFEINFO_whereANY:
8091           t = error_mark_node;
8092           break;
8093         }
8094       break;
8095
8096     case FFEINFO_kindSUBROUTINE:
8097       switch (ffeinfo_where (ffesymbol_info (s)))
8098         {
8099         case FFEINFO_whereLOCAL:        /* Me. */
8100           assert (!ffecom_transform_only_dummies_);
8101           t = current_function_decl;
8102           break;
8103
8104         case FFEINFO_whereGLOBAL:
8105           assert (!ffecom_transform_only_dummies_);
8106
8107           if (((g = ffesymbol_global (s)) != NULL)
8108               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8109                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8110               && (ffeglobal_hook (g) != NULL_TREE)
8111               && ffe_is_globals ())
8112             {
8113               t = ffeglobal_hook (g);
8114               break;
8115             }
8116
8117           t = build_decl (FUNCTION_DECL,
8118                           ffecom_get_external_identifier_ (s),
8119                           ffecom_tree_subr_type);
8120           DECL_EXTERNAL (t) = 1;
8121           TREE_PUBLIC (t) = 1;
8122
8123           t = start_decl (t, FALSE);
8124           finish_decl (t, NULL_TREE, FALSE);
8125
8126           if ((g != NULL)
8127               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8128                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8129             ffeglobal_set_hook (g, t);
8130
8131           ffecom_save_tree_forever (t);
8132
8133           break;
8134
8135         case FFEINFO_whereDUMMY:
8136           assert (ffecom_transform_only_dummies_);
8137
8138           t = build_decl (PARM_DECL,
8139                           ffecom_get_identifier_ (ffesymbol_text (s)),
8140                           ffecom_tree_ptr_to_subr_type);
8141           DECL_ARTIFICIAL (t) = 1;
8142           addr = TRUE;
8143           break;
8144
8145         case FFEINFO_whereINTRINSIC:
8146           assert (!ffecom_transform_only_dummies_);
8147           break;                /* Let actual references generate their
8148                                    decls. */
8149
8150         default:
8151           assert ("SUBROUTINE where unheard of" == NULL);
8152           /* Fall through. */
8153         case FFEINFO_whereANY:
8154           t = error_mark_node;
8155           break;
8156         }
8157       break;
8158
8159     case FFEINFO_kindPROGRAM:
8160       switch (ffeinfo_where (ffesymbol_info (s)))
8161         {
8162         case FFEINFO_whereLOCAL:        /* Me. */
8163           assert (!ffecom_transform_only_dummies_);
8164           t = current_function_decl;
8165           break;
8166
8167         case FFEINFO_whereCOMMON:
8168         case FFEINFO_whereDUMMY:
8169         case FFEINFO_whereGLOBAL:
8170         case FFEINFO_whereRESULT:
8171         case FFEINFO_whereFLEETING:
8172         case FFEINFO_whereFLEETING_CADDR:
8173         case FFEINFO_whereFLEETING_IADDR:
8174         case FFEINFO_whereIMMEDIATE:
8175         case FFEINFO_whereINTRINSIC:
8176         case FFEINFO_whereCONSTANT:
8177         case FFEINFO_whereCONSTANT_SUBOBJECT:
8178         default:
8179           assert ("PROGRAM where unheard of" == NULL);
8180           /* Fall through. */
8181         case FFEINFO_whereANY:
8182           t = error_mark_node;
8183           break;
8184         }
8185       break;
8186
8187     case FFEINFO_kindBLOCKDATA:
8188       switch (ffeinfo_where (ffesymbol_info (s)))
8189         {
8190         case FFEINFO_whereLOCAL:        /* Me. */
8191           assert (!ffecom_transform_only_dummies_);
8192           t = current_function_decl;
8193           break;
8194
8195         case FFEINFO_whereGLOBAL:
8196           assert (!ffecom_transform_only_dummies_);
8197
8198           t = build_decl (FUNCTION_DECL,
8199                           ffecom_get_external_identifier_ (s),
8200                           ffecom_tree_blockdata_type);
8201           DECL_EXTERNAL (t) = 1;
8202           TREE_PUBLIC (t) = 1;
8203
8204           t = start_decl (t, FALSE);
8205           finish_decl (t, NULL_TREE, FALSE);
8206
8207           ffecom_save_tree_forever (t);
8208
8209           break;
8210
8211         case FFEINFO_whereCOMMON:
8212         case FFEINFO_whereDUMMY:
8213         case FFEINFO_whereRESULT:
8214         case FFEINFO_whereFLEETING:
8215         case FFEINFO_whereFLEETING_CADDR:
8216         case FFEINFO_whereFLEETING_IADDR:
8217         case FFEINFO_whereIMMEDIATE:
8218         case FFEINFO_whereINTRINSIC:
8219         case FFEINFO_whereCONSTANT:
8220         case FFEINFO_whereCONSTANT_SUBOBJECT:
8221         default:
8222           assert ("BLOCKDATA where unheard of" == NULL);
8223           /* Fall through. */
8224         case FFEINFO_whereANY:
8225           t = error_mark_node;
8226           break;
8227         }
8228       break;
8229
8230     case FFEINFO_kindCOMMON:
8231       switch (ffeinfo_where (ffesymbol_info (s)))
8232         {
8233         case FFEINFO_whereLOCAL:
8234           assert (!ffecom_transform_only_dummies_);
8235           ffecom_transform_common_ (s);
8236           break;
8237
8238         case FFEINFO_whereNONE:
8239         case FFEINFO_whereCOMMON:
8240         case FFEINFO_whereDUMMY:
8241         case FFEINFO_whereGLOBAL:
8242         case FFEINFO_whereRESULT:
8243         case FFEINFO_whereFLEETING:
8244         case FFEINFO_whereFLEETING_CADDR:
8245         case FFEINFO_whereFLEETING_IADDR:
8246         case FFEINFO_whereIMMEDIATE:
8247         case FFEINFO_whereINTRINSIC:
8248         case FFEINFO_whereCONSTANT:
8249         case FFEINFO_whereCONSTANT_SUBOBJECT:
8250         default:
8251           assert ("COMMON where unheard of" == NULL);
8252           /* Fall through. */
8253         case FFEINFO_whereANY:
8254           t = error_mark_node;
8255           break;
8256         }
8257       break;
8258
8259     case FFEINFO_kindCONSTRUCT:
8260       switch (ffeinfo_where (ffesymbol_info (s)))
8261         {
8262         case FFEINFO_whereLOCAL:
8263           assert (!ffecom_transform_only_dummies_);
8264           break;
8265
8266         case FFEINFO_whereNONE:
8267         case FFEINFO_whereCOMMON:
8268         case FFEINFO_whereDUMMY:
8269         case FFEINFO_whereGLOBAL:
8270         case FFEINFO_whereRESULT:
8271         case FFEINFO_whereFLEETING:
8272         case FFEINFO_whereFLEETING_CADDR:
8273         case FFEINFO_whereFLEETING_IADDR:
8274         case FFEINFO_whereIMMEDIATE:
8275         case FFEINFO_whereINTRINSIC:
8276         case FFEINFO_whereCONSTANT:
8277         case FFEINFO_whereCONSTANT_SUBOBJECT:
8278         default:
8279           assert ("CONSTRUCT where unheard of" == NULL);
8280           /* Fall through. */
8281         case FFEINFO_whereANY:
8282           t = error_mark_node;
8283           break;
8284         }
8285       break;
8286
8287     case FFEINFO_kindNAMELIST:
8288       switch (ffeinfo_where (ffesymbol_info (s)))
8289         {
8290         case FFEINFO_whereLOCAL:
8291           assert (!ffecom_transform_only_dummies_);
8292           t = ffecom_transform_namelist_ (s);
8293           break;
8294
8295         case FFEINFO_whereNONE:
8296         case FFEINFO_whereCOMMON:
8297         case FFEINFO_whereDUMMY:
8298         case FFEINFO_whereGLOBAL:
8299         case FFEINFO_whereRESULT:
8300         case FFEINFO_whereFLEETING:
8301         case FFEINFO_whereFLEETING_CADDR:
8302         case FFEINFO_whereFLEETING_IADDR:
8303         case FFEINFO_whereIMMEDIATE:
8304         case FFEINFO_whereINTRINSIC:
8305         case FFEINFO_whereCONSTANT:
8306         case FFEINFO_whereCONSTANT_SUBOBJECT:
8307         default:
8308           assert ("NAMELIST where unheard of" == NULL);
8309           /* Fall through. */
8310         case FFEINFO_whereANY:
8311           t = error_mark_node;
8312           break;
8313         }
8314       break;
8315
8316     default:
8317       assert ("kind unheard of" == NULL);
8318       /* Fall through. */
8319     case FFEINFO_kindANY:
8320       t = error_mark_node;
8321       break;
8322     }
8323
8324   ffesymbol_hook (s).decl_tree = t;
8325   ffesymbol_hook (s).length_tree = tlen;
8326   ffesymbol_hook (s).addr = addr;
8327
8328   lineno = old_lineno;
8329   input_filename = old_input_filename;
8330
8331   return s;
8332 }
8333
8334 /* Transform into ASSIGNable symbol.
8335
8336    Symbol has already been transformed, but for whatever reason, the
8337    resulting decl_tree has been deemed not usable for an ASSIGN target.
8338    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8339    another local symbol of type void * and stuff that in the assign_tree
8340    argument.  The F77/F90 standards allow this implementation.  */
8341
8342 static ffesymbol
8343 ffecom_sym_transform_assign_ (ffesymbol s)
8344 {
8345   tree t;                       /* Transformed thingy. */
8346   int old_lineno = lineno;
8347   const char *old_input_filename = input_filename;
8348
8349   if (ffesymbol_sfdummyparent (s) == NULL)
8350     {
8351       input_filename = ffesymbol_where_filename (s);
8352       lineno = ffesymbol_where_filelinenum (s);
8353     }
8354   else
8355     {
8356       ffesymbol sf = ffesymbol_sfdummyparent (s);
8357
8358       input_filename = ffesymbol_where_filename (sf);
8359       lineno = ffesymbol_where_filelinenum (sf);
8360     }
8361
8362   assert (!ffecom_transform_only_dummies_);
8363
8364   t = build_decl (VAR_DECL,
8365                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8366                                                    ffesymbol_text (s)),
8367                   TREE_TYPE (null_pointer_node));
8368
8369   switch (ffesymbol_where (s))
8370     {
8371     case FFEINFO_whereLOCAL:
8372       /* Unlike for regular vars, SAVE status is easy to determine for
8373          ASSIGNed vars, since there's no initialization, there's no
8374          effective storage association (so "SAVE J" does not apply to
8375          K even given "EQUIVALENCE (J,K)"), there's no size issue
8376          to worry about, etc.  */
8377       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8378           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8379           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8380         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8381       else
8382         TREE_STATIC (t) = 0;    /* No need to make static. */
8383       break;
8384
8385     case FFEINFO_whereCOMMON:
8386       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8387       break;
8388
8389     case FFEINFO_whereDUMMY:
8390       /* Note that twinning a DUMMY means the caller won't see
8391          the ASSIGNed value.  But both F77 and F90 allow implementations
8392          to do this, i.e. disallow Fortran code that would try and
8393          take advantage of actually putting a label into a variable
8394          via a dummy argument (or any other storage association, for
8395          that matter).  */
8396       TREE_STATIC (t) = 0;
8397       break;
8398
8399     default:
8400       TREE_STATIC (t) = 0;
8401       break;
8402     }
8403
8404   t = start_decl (t, FALSE);
8405   finish_decl (t, NULL_TREE, FALSE);
8406
8407   ffesymbol_hook (s).assign_tree = t;
8408
8409   lineno = old_lineno;
8410   input_filename = old_input_filename;
8411
8412   return s;
8413 }
8414
8415 /* Implement COMMON area in back end.
8416
8417    Because COMMON-based variables can be referenced in the dimension
8418    expressions of dummy (adjustable) arrays, and because dummies
8419    (in the gcc back end) need to be put in the outer binding level
8420    of a function (which has two binding levels, the outer holding
8421    the dummies and the inner holding the other vars), special care
8422    must be taken to handle COMMON areas.
8423
8424    The current strategy is basically to always tell the back end about
8425    the COMMON area as a top-level external reference to just a block
8426    of storage of the master type of that area (e.g. integer, real,
8427    character, whatever -- not a structure).  As a distinct action,
8428    if initial values are provided, tell the back end about the area
8429    as a top-level non-external (initialized) area and remember not to
8430    allow further initialization or expansion of the area.  Meanwhile,
8431    if no initialization happens at all, tell the back end about
8432    the largest size we've seen declared so the space does get reserved.
8433    (This function doesn't handle all that stuff, but it does some
8434    of the important things.)
8435
8436    Meanwhile, for COMMON variables themselves, just keep creating
8437    references like *((float *) (&common_area + offset)) each time
8438    we reference the variable.  In other words, don't make a VAR_DECL
8439    or any kind of component reference (like we used to do before 0.4),
8440    though we might do that as well just for debugging purposes (and
8441    stuff the rtl with the appropriate offset expression).  */
8442
8443 static void
8444 ffecom_transform_common_ (ffesymbol s)
8445 {
8446   ffestorag st = ffesymbol_storage (s);
8447   ffeglobal g = ffesymbol_global (s);
8448   tree cbt;
8449   tree cbtype;
8450   tree init;
8451   tree high;
8452   bool is_init = ffestorag_is_init (st);
8453
8454   assert (st != NULL);
8455
8456   if ((g == NULL)
8457       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8458     return;
8459
8460   /* First update the size of the area in global terms.  */
8461
8462   ffeglobal_size_common (s, ffestorag_size (st));
8463
8464   if (!ffeglobal_common_init (g))
8465     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8466
8467   cbt = ffeglobal_hook (g);
8468
8469   /* If we already have declared this common block for a previous program
8470      unit, and either we already initialized it or we don't have new
8471      initialization for it, just return what we have without changing it.  */
8472
8473   if ((cbt != NULL_TREE)
8474       && (!is_init
8475           || !DECL_EXTERNAL (cbt)))
8476     {
8477       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8478       return;
8479     }
8480
8481   /* Process inits.  */
8482
8483   if (is_init)
8484     {
8485       if (ffestorag_init (st) != NULL)
8486         {
8487           ffebld sexp;
8488
8489           /* Set the padding for the expression, so ffecom_expr
8490              knows to insert that many zeros.  */
8491           switch (ffebld_op (sexp = ffestorag_init (st)))
8492             {
8493             case FFEBLD_opCONTER:
8494               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8495               break;
8496
8497             case FFEBLD_opARRTER:
8498               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8499               break;
8500
8501             case FFEBLD_opACCTER:
8502               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8503               break;
8504
8505             default:
8506               assert ("bad op for cmn init (pad)" == NULL);
8507               break;
8508             }
8509
8510           init = ffecom_expr (sexp);
8511           if (init == error_mark_node)
8512             {                   /* Hopefully the back end complained! */
8513               init = NULL_TREE;
8514               if (cbt != NULL_TREE)
8515                 return;
8516             }
8517         }
8518       else
8519         init = error_mark_node;
8520     }
8521   else
8522     init = NULL_TREE;
8523
8524   /* cbtype must be permanently allocated!  */
8525
8526   /* Allocate the MAX of the areas so far, seen filewide.  */
8527   high = build_int_2 ((ffeglobal_common_size (g)
8528                        + ffeglobal_common_pad (g)) - 1, 0);
8529   TREE_TYPE (high) = ffecom_integer_type_node;
8530
8531   if (init)
8532     cbtype = build_array_type (char_type_node,
8533                                build_range_type (integer_type_node,
8534                                                  integer_zero_node,
8535                                                  high));
8536   else
8537     cbtype = build_array_type (char_type_node, NULL_TREE);
8538
8539   if (cbt == NULL_TREE)
8540     {
8541       cbt
8542         = build_decl (VAR_DECL,
8543                       ffecom_get_external_identifier_ (s),
8544                       cbtype);
8545       TREE_STATIC (cbt) = 1;
8546       TREE_PUBLIC (cbt) = 1;
8547     }
8548   else
8549     {
8550       assert (is_init);
8551       TREE_TYPE (cbt) = cbtype;
8552     }
8553   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8554   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8555
8556   cbt = start_decl (cbt, TRUE);
8557   if (ffeglobal_hook (g) != NULL)
8558     assert (cbt == ffeglobal_hook (g));
8559
8560   assert (!init || !DECL_EXTERNAL (cbt));
8561
8562   /* Make sure that any type can live in COMMON and be referenced
8563      without getting a bus error.  We could pick the most restrictive
8564      alignment of all entities actually placed in the COMMON, but
8565      this seems easy enough.  */
8566
8567   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8568   DECL_USER_ALIGN (cbt) = 0;
8569
8570   if (is_init && (ffestorag_init (st) == NULL))
8571     init = ffecom_init_zero_ (cbt);
8572
8573   finish_decl (cbt, init, TRUE);
8574
8575   if (is_init)
8576     ffestorag_set_init (st, ffebld_new_any ());
8577
8578   if (init)
8579     {
8580       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8581       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8582       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8583                                      (ffeglobal_common_size (g)
8584                                       + ffeglobal_common_pad (g))));
8585     }
8586
8587   ffeglobal_set_hook (g, cbt);
8588
8589   ffestorag_set_hook (st, cbt);
8590
8591   ffecom_save_tree_forever (cbt);
8592 }
8593
8594 /* Make master area for local EQUIVALENCE.  */
8595
8596 static void
8597 ffecom_transform_equiv_ (ffestorag eqst)
8598 {
8599   tree eqt;
8600   tree eqtype;
8601   tree init;
8602   tree high;
8603   bool is_init = ffestorag_is_init (eqst);
8604
8605   assert (eqst != NULL);
8606
8607   eqt = ffestorag_hook (eqst);
8608
8609   if (eqt != NULL_TREE)
8610     return;
8611
8612   /* Process inits.  */
8613
8614   if (is_init)
8615     {
8616       if (ffestorag_init (eqst) != NULL)
8617         {
8618           ffebld sexp;
8619
8620           /* Set the padding for the expression, so ffecom_expr
8621              knows to insert that many zeros.  */
8622           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8623             {
8624             case FFEBLD_opCONTER:
8625               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8626               break;
8627
8628             case FFEBLD_opARRTER:
8629               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8630               break;
8631
8632             case FFEBLD_opACCTER:
8633               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8634               break;
8635
8636             default:
8637               assert ("bad op for eqv init (pad)" == NULL);
8638               break;
8639             }
8640
8641           init = ffecom_expr (sexp);
8642           if (init == error_mark_node)
8643             init = NULL_TREE;   /* Hopefully the back end complained! */
8644         }
8645       else
8646         init = error_mark_node;
8647     }
8648   else if (ffe_is_init_local_zero ())
8649     init = error_mark_node;
8650   else
8651     init = NULL_TREE;
8652
8653   ffecom_member_namelisted_ = FALSE;
8654   ffestorag_drive (ffestorag_list_equivs (eqst),
8655                    &ffecom_member_phase1_,
8656                    eqst);
8657
8658   high = build_int_2 ((ffestorag_size (eqst)
8659                        + ffestorag_modulo (eqst)) - 1, 0);
8660   TREE_TYPE (high) = ffecom_integer_type_node;
8661
8662   eqtype = build_array_type (char_type_node,
8663                              build_range_type (ffecom_integer_type_node,
8664                                                ffecom_integer_zero_node,
8665                                                high));
8666
8667   eqt = build_decl (VAR_DECL,
8668                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8669                                                     ffesymbol_text
8670                                                     (ffestorag_symbol (eqst))),
8671                     eqtype);
8672   DECL_EXTERNAL (eqt) = 0;
8673   if (is_init
8674       || ffecom_member_namelisted_
8675 #ifdef FFECOM_sizeMAXSTACKITEM
8676       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8677 #endif
8678       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8679           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8680           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8681     TREE_STATIC (eqt) = 1;
8682   else
8683     TREE_STATIC (eqt) = 0;
8684   TREE_PUBLIC (eqt) = 0;
8685   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8686   DECL_CONTEXT (eqt) = current_function_decl;
8687   if (init)
8688     DECL_INITIAL (eqt) = error_mark_node;
8689   else
8690     DECL_INITIAL (eqt) = NULL_TREE;
8691
8692   eqt = start_decl (eqt, FALSE);
8693
8694   /* Make sure that any type can live in EQUIVALENCE and be referenced
8695      without getting a bus error.  We could pick the most restrictive
8696      alignment of all entities actually placed in the EQUIVALENCE, but
8697      this seems easy enough.  */
8698
8699   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8700   DECL_USER_ALIGN (eqt) = 0;
8701
8702   if ((!is_init && ffe_is_init_local_zero ())
8703       || (is_init && (ffestorag_init (eqst) == NULL)))
8704     init = ffecom_init_zero_ (eqt);
8705
8706   finish_decl (eqt, init, FALSE);
8707
8708   if (is_init)
8709     ffestorag_set_init (eqst, ffebld_new_any ());
8710
8711   {
8712     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8713     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8714                                    (ffestorag_size (eqst)
8715                                     + ffestorag_modulo (eqst))));
8716   }
8717
8718   ffestorag_set_hook (eqst, eqt);
8719
8720   ffestorag_drive (ffestorag_list_equivs (eqst),
8721                    &ffecom_member_phase2_,
8722                    eqst);
8723 }
8724
8725 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8726
8727 static tree
8728 ffecom_transform_namelist_ (ffesymbol s)
8729 {
8730   tree nmlt;
8731   tree nmltype = ffecom_type_namelist_ ();
8732   tree nmlinits;
8733   tree nameinit;
8734   tree varsinit;
8735   tree nvarsinit;
8736   tree field;
8737   tree high;
8738   int i;
8739   static int mynumber = 0;
8740
8741   nmlt = build_decl (VAR_DECL,
8742                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8743                                                      mynumber++),
8744                      nmltype);
8745   TREE_STATIC (nmlt) = 1;
8746   DECL_INITIAL (nmlt) = error_mark_node;
8747
8748   nmlt = start_decl (nmlt, FALSE);
8749
8750   /* Process inits.  */
8751
8752   i = strlen (ffesymbol_text (s));
8753
8754   high = build_int_2 (i, 0);
8755   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8756
8757   nameinit = ffecom_build_f2c_string_ (i + 1,
8758                                        ffesymbol_text (s));
8759   TREE_TYPE (nameinit)
8760     = build_type_variant
8761     (build_array_type
8762      (char_type_node,
8763       build_range_type (ffecom_f2c_ftnlen_type_node,
8764                         ffecom_f2c_ftnlen_one_node,
8765                         high)),
8766      1, 0);
8767   TREE_CONSTANT (nameinit) = 1;
8768   TREE_STATIC (nameinit) = 1;
8769   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8770                        nameinit);
8771
8772   varsinit = ffecom_vardesc_array_ (s);
8773   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8774                        varsinit);
8775   TREE_CONSTANT (varsinit) = 1;
8776   TREE_STATIC (varsinit) = 1;
8777
8778   {
8779     ffebld b;
8780
8781     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8782       ++i;
8783   }
8784   nvarsinit = build_int_2 (i, 0);
8785   TREE_TYPE (nvarsinit) = integer_type_node;
8786   TREE_CONSTANT (nvarsinit) = 1;
8787   TREE_STATIC (nvarsinit) = 1;
8788
8789   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8790   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8791                                            varsinit);
8792   TREE_CHAIN (TREE_CHAIN (nmlinits))
8793     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8794
8795   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8796   TREE_CONSTANT (nmlinits) = 1;
8797   TREE_STATIC (nmlinits) = 1;
8798
8799   finish_decl (nmlt, nmlinits, FALSE);
8800
8801   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8802
8803   return nmlt;
8804 }
8805
8806 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8807    analyzed on the assumption it is calculating a pointer to be
8808    indirected through.  It must return the proper decl and offset,
8809    taking into account different units of measurements for offsets.  */
8810
8811 static void
8812 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8813                            tree t)
8814 {
8815   switch (TREE_CODE (t))
8816     {
8817     case NOP_EXPR:
8818     case CONVERT_EXPR:
8819     case NON_LVALUE_EXPR:
8820       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8821       break;
8822
8823     case PLUS_EXPR:
8824       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8825       if ((*decl == NULL_TREE)
8826           || (*decl == error_mark_node))
8827         break;
8828
8829       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8830         {
8831           /* An offset into COMMON.  */
8832           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8833                                  *offset, TREE_OPERAND (t, 1)));
8834           /* Convert offset (presumably in bytes) into canonical units
8835              (presumably bits).  */
8836           *offset = size_binop (MULT_EXPR,
8837                                 convert (bitsizetype, *offset),
8838                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8839           break;
8840         }
8841       /* Not a COMMON reference, so an unrecognized pattern.  */
8842       *decl = error_mark_node;
8843       break;
8844
8845     case PARM_DECL:
8846       *decl = t;
8847       *offset = bitsize_zero_node;
8848       break;
8849
8850     case ADDR_EXPR:
8851       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8852         {
8853           /* A reference to COMMON.  */
8854           *decl = TREE_OPERAND (t, 0);
8855           *offset = bitsize_zero_node;
8856           break;
8857         }
8858       /* Fall through.  */
8859     default:
8860       /* Not a COMMON reference, so an unrecognized pattern.  */
8861       *decl = error_mark_node;
8862       break;
8863     }
8864 }
8865
8866 /* Given a tree that is possibly intended for use as an lvalue, return
8867    information representing a canonical view of that tree as a decl, an
8868    offset into that decl, and a size for the lvalue.
8869
8870    If there's no applicable decl, NULL_TREE is returned for the decl,
8871    and the other fields are left undefined.
8872
8873    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8874    is returned for the decl, and the other fields are left undefined.
8875
8876    Otherwise, the decl returned currently is either a VAR_DECL or a
8877    PARM_DECL.
8878
8879    The offset returned is always valid, but of course not necessarily
8880    a constant, and not necessarily converted into the appropriate
8881    type, leaving that up to the caller (so as to avoid that overhead
8882    if the decls being looked at are different anyway).
8883
8884    If the size cannot be determined (e.g. an adjustable array),
8885    an ERROR_MARK node is returned for the size.  Otherwise, the
8886    size returned is valid, not necessarily a constant, and not
8887    necessarily converted into the appropriate type as with the
8888    offset.
8889
8890    Note that the offset and size expressions are expressed in the
8891    base storage units (usually bits) rather than in the units of
8892    the type of the decl, because two decls with different types
8893    might overlap but with apparently non-overlapping array offsets,
8894    whereas converting the array offsets to consistant offsets will
8895    reveal the overlap.  */
8896
8897 static void
8898 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
8899                            tree *size, tree t)
8900 {
8901   /* The default path is to report a nonexistant decl.  */
8902   *decl = NULL_TREE;
8903
8904   if (t == NULL_TREE)
8905     return;
8906
8907   switch (TREE_CODE (t))
8908     {
8909     case ERROR_MARK:
8910     case IDENTIFIER_NODE:
8911     case INTEGER_CST:
8912     case REAL_CST:
8913     case COMPLEX_CST:
8914     case STRING_CST:
8915     case CONST_DECL:
8916     case PLUS_EXPR:
8917     case MINUS_EXPR:
8918     case MULT_EXPR:
8919     case TRUNC_DIV_EXPR:
8920     case CEIL_DIV_EXPR:
8921     case FLOOR_DIV_EXPR:
8922     case ROUND_DIV_EXPR:
8923     case TRUNC_MOD_EXPR:
8924     case CEIL_MOD_EXPR:
8925     case FLOOR_MOD_EXPR:
8926     case ROUND_MOD_EXPR:
8927     case RDIV_EXPR:
8928     case EXACT_DIV_EXPR:
8929     case FIX_TRUNC_EXPR:
8930     case FIX_CEIL_EXPR:
8931     case FIX_FLOOR_EXPR:
8932     case FIX_ROUND_EXPR:
8933     case FLOAT_EXPR:
8934     case NEGATE_EXPR:
8935     case MIN_EXPR:
8936     case MAX_EXPR:
8937     case ABS_EXPR:
8938     case FFS_EXPR:
8939     case LSHIFT_EXPR:
8940     case RSHIFT_EXPR:
8941     case LROTATE_EXPR:
8942     case RROTATE_EXPR:
8943     case BIT_IOR_EXPR:
8944     case BIT_XOR_EXPR:
8945     case BIT_AND_EXPR:
8946     case BIT_ANDTC_EXPR:
8947     case BIT_NOT_EXPR:
8948     case TRUTH_ANDIF_EXPR:
8949     case TRUTH_ORIF_EXPR:
8950     case TRUTH_AND_EXPR:
8951     case TRUTH_OR_EXPR:
8952     case TRUTH_XOR_EXPR:
8953     case TRUTH_NOT_EXPR:
8954     case LT_EXPR:
8955     case LE_EXPR:
8956     case GT_EXPR:
8957     case GE_EXPR:
8958     case EQ_EXPR:
8959     case NE_EXPR:
8960     case COMPLEX_EXPR:
8961     case CONJ_EXPR:
8962     case REALPART_EXPR:
8963     case IMAGPART_EXPR:
8964     case LABEL_EXPR:
8965     case COMPONENT_REF:
8966     case COMPOUND_EXPR:
8967     case ADDR_EXPR:
8968       return;
8969
8970     case VAR_DECL:
8971     case PARM_DECL:
8972       *decl = t;
8973       *offset = bitsize_zero_node;
8974       *size = TYPE_SIZE (TREE_TYPE (t));
8975       return;
8976
8977     case ARRAY_REF:
8978       {
8979         tree array = TREE_OPERAND (t, 0);
8980         tree element = TREE_OPERAND (t, 1);
8981         tree init_offset;
8982
8983         if ((array == NULL_TREE)
8984             || (element == NULL_TREE))
8985           {
8986             *decl = error_mark_node;
8987             return;
8988           }
8989
8990         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
8991                                    array);
8992         if ((*decl == NULL_TREE)
8993             || (*decl == error_mark_node))
8994           return;
8995
8996         /* Calculate ((element - base) * NBBY) + init_offset.  */
8997         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
8998                                element,
8999                                TYPE_MIN_VALUE (TYPE_DOMAIN
9000                                                (TREE_TYPE (array)))));
9001
9002         *offset = size_binop (MULT_EXPR,
9003                               convert (bitsizetype, *offset),
9004                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9005
9006         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9007
9008         *size = TYPE_SIZE (TREE_TYPE (t));
9009         return;
9010       }
9011
9012     case INDIRECT_REF:
9013
9014       /* Most of this code is to handle references to COMMON.  And so
9015          far that is useful only for calling library functions, since
9016          external (user) functions might reference common areas.  But
9017          even calling an external function, it's worthwhile to decode
9018          COMMON references because if not storing into COMMON, we don't
9019          want COMMON-based arguments to gratuitously force use of a
9020          temporary.  */
9021
9022       *size = TYPE_SIZE (TREE_TYPE (t));
9023
9024       ffecom_tree_canonize_ptr_ (decl, offset,
9025                                  TREE_OPERAND (t, 0));
9026
9027       return;
9028
9029     case CONVERT_EXPR:
9030     case NOP_EXPR:
9031     case MODIFY_EXPR:
9032     case NON_LVALUE_EXPR:
9033     case RESULT_DECL:
9034     case FIELD_DECL:
9035     case COND_EXPR:             /* More cases than we can handle. */
9036     case SAVE_EXPR:
9037     case REFERENCE_EXPR:
9038     case PREDECREMENT_EXPR:
9039     case PREINCREMENT_EXPR:
9040     case POSTDECREMENT_EXPR:
9041     case POSTINCREMENT_EXPR:
9042     case CALL_EXPR:
9043     default:
9044       *decl = error_mark_node;
9045       return;
9046     }
9047 }
9048
9049 /* Do divide operation appropriate to type of operands.  */
9050
9051 static tree
9052 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9053                      tree dest_tree, ffebld dest, bool *dest_used,
9054                      tree hook)
9055 {
9056   if ((left == error_mark_node)
9057       || (right == error_mark_node))
9058     return error_mark_node;
9059
9060   switch (TREE_CODE (tree_type))
9061     {
9062     case INTEGER_TYPE:
9063       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9064                        left,
9065                        right);
9066
9067     case COMPLEX_TYPE:
9068       if (! optimize_size)
9069         return ffecom_2 (RDIV_EXPR, tree_type,
9070                          left,
9071                          right);
9072       {
9073         ffecomGfrt ix;
9074
9075         if (TREE_TYPE (tree_type)
9076             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9077           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9078         else
9079           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9080
9081         left = ffecom_1 (ADDR_EXPR,
9082                          build_pointer_type (TREE_TYPE (left)),
9083                          left);
9084         left = build_tree_list (NULL_TREE, left);
9085         right = ffecom_1 (ADDR_EXPR,
9086                           build_pointer_type (TREE_TYPE (right)),
9087                           right);
9088         right = build_tree_list (NULL_TREE, right);
9089         TREE_CHAIN (left) = right;
9090
9091         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9092                              ffecom_gfrt_kindtype (ix),
9093                              ffe_is_f2c_library (),
9094                              tree_type,
9095                              left,
9096                              dest_tree, dest, dest_used,
9097                              NULL_TREE, TRUE, hook);
9098       }
9099       break;
9100
9101     case RECORD_TYPE:
9102       {
9103         ffecomGfrt ix;
9104
9105         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9106             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9107           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9108         else
9109           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9110
9111         left = ffecom_1 (ADDR_EXPR,
9112                          build_pointer_type (TREE_TYPE (left)),
9113                          left);
9114         left = build_tree_list (NULL_TREE, left);
9115         right = ffecom_1 (ADDR_EXPR,
9116                           build_pointer_type (TREE_TYPE (right)),
9117                           right);
9118         right = build_tree_list (NULL_TREE, right);
9119         TREE_CHAIN (left) = right;
9120
9121         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9122                              ffecom_gfrt_kindtype (ix),
9123                              ffe_is_f2c_library (),
9124                              tree_type,
9125                              left,
9126                              dest_tree, dest, dest_used,
9127                              NULL_TREE, TRUE, hook);
9128       }
9129       break;
9130
9131     default:
9132       return ffecom_2 (RDIV_EXPR, tree_type,
9133                        left,
9134                        right);
9135     }
9136 }
9137
9138 /* Build type info for non-dummy variable.  */
9139
9140 static tree
9141 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9142                        ffeinfoKindtype kt)
9143 {
9144   tree type;
9145   ffebld dl;
9146   ffebld dim;
9147   tree lowt;
9148   tree hight;
9149
9150   type = ffecom_tree_type[bt][kt];
9151   if (bt == FFEINFO_basictypeCHARACTER)
9152     {
9153       hight = build_int_2 (ffesymbol_size (s), 0);
9154       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9155
9156       type
9157         = build_array_type
9158           (type,
9159            build_range_type (ffecom_f2c_ftnlen_type_node,
9160                              ffecom_f2c_ftnlen_one_node,
9161                              hight));
9162       type = ffecom_check_size_overflow_ (s, type, FALSE);
9163     }
9164
9165   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9166     {
9167       if (type == error_mark_node)
9168         break;
9169
9170       dim = ffebld_head (dl);
9171       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9172
9173       if (ffebld_left (dim) == NULL)
9174         lowt = integer_one_node;
9175       else
9176         lowt = ffecom_expr (ffebld_left (dim));
9177
9178       if (TREE_CODE (lowt) != INTEGER_CST)
9179         lowt = variable_size (lowt);
9180
9181       assert (ffebld_right (dim) != NULL);
9182       hight = ffecom_expr (ffebld_right (dim));
9183
9184       if (TREE_CODE (hight) != INTEGER_CST)
9185         hight = variable_size (hight);
9186
9187       type = build_array_type (type,
9188                                build_range_type (ffecom_integer_type_node,
9189                                                  lowt, hight));
9190       type = ffecom_check_size_overflow_ (s, type, FALSE);
9191     }
9192
9193   return type;
9194 }
9195
9196 /* Build Namelist type.  */
9197
9198 static tree
9199 ffecom_type_namelist_ ()
9200 {
9201   static tree type = NULL_TREE;
9202
9203   if (type == NULL_TREE)
9204     {
9205       static tree namefield, varsfield, nvarsfield;
9206       tree vardesctype;
9207
9208       vardesctype = ffecom_type_vardesc_ ();
9209
9210       type = make_node (RECORD_TYPE);
9211
9212       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9213
9214       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9215                                      string_type_node);
9216       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9217       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9218                                       integer_type_node);
9219
9220       TYPE_FIELDS (type) = namefield;
9221       layout_type (type);
9222
9223       ggc_add_tree_root (&type, 1);
9224     }
9225
9226   return type;
9227 }
9228
9229 /* Build Vardesc type.  */
9230
9231 static tree
9232 ffecom_type_vardesc_ ()
9233 {
9234   static tree type = NULL_TREE;
9235   static tree namefield, addrfield, dimsfield, typefield;
9236
9237   if (type == NULL_TREE)
9238     {
9239       type = make_node (RECORD_TYPE);
9240
9241       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9242                                      string_type_node);
9243       addrfield = ffecom_decl_field (type, namefield, "addr",
9244                                      string_type_node);
9245       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9246                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9247       typefield = ffecom_decl_field (type, dimsfield, "type",
9248                                      integer_type_node);
9249
9250       TYPE_FIELDS (type) = namefield;
9251       layout_type (type);
9252
9253       ggc_add_tree_root (&type, 1);
9254     }
9255
9256   return type;
9257 }
9258
9259 static tree
9260 ffecom_vardesc_ (ffebld expr)
9261 {
9262   ffesymbol s;
9263
9264   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9265   s = ffebld_symter (expr);
9266
9267   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9268     {
9269       int i;
9270       tree vardesctype = ffecom_type_vardesc_ ();
9271       tree var;
9272       tree nameinit;
9273       tree dimsinit;
9274       tree addrinit;
9275       tree typeinit;
9276       tree field;
9277       tree varinits;
9278       static int mynumber = 0;
9279
9280       var = build_decl (VAR_DECL,
9281                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9282                                                         mynumber++),
9283                         vardesctype);
9284       TREE_STATIC (var) = 1;
9285       DECL_INITIAL (var) = error_mark_node;
9286
9287       var = start_decl (var, FALSE);
9288
9289       /* Process inits.  */
9290
9291       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9292                                            + 1,
9293                                            ffesymbol_text (s));
9294       TREE_TYPE (nameinit)
9295         = build_type_variant
9296         (build_array_type
9297          (char_type_node,
9298           build_range_type (integer_type_node,
9299                             integer_one_node,
9300                             build_int_2 (i, 0))),
9301          1, 0);
9302       TREE_CONSTANT (nameinit) = 1;
9303       TREE_STATIC (nameinit) = 1;
9304       nameinit = ffecom_1 (ADDR_EXPR,
9305                            build_pointer_type (TREE_TYPE (nameinit)),
9306                            nameinit);
9307
9308       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9309
9310       dimsinit = ffecom_vardesc_dims_ (s);
9311
9312       if (typeinit == NULL_TREE)
9313         {
9314           ffeinfoBasictype bt = ffesymbol_basictype (s);
9315           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9316           int tc = ffecom_f2c_typecode (bt, kt);
9317
9318           assert (tc != -1);
9319           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9320         }
9321       else
9322         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9323
9324       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9325                                   nameinit);
9326       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9327                                                addrinit);
9328       TREE_CHAIN (TREE_CHAIN (varinits))
9329         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9330       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9331         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9332
9333       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9334       TREE_CONSTANT (varinits) = 1;
9335       TREE_STATIC (varinits) = 1;
9336
9337       finish_decl (var, varinits, FALSE);
9338
9339       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9340
9341       ffesymbol_hook (s).vardesc_tree = var;
9342     }
9343
9344   return ffesymbol_hook (s).vardesc_tree;
9345 }
9346
9347 static tree
9348 ffecom_vardesc_array_ (ffesymbol s)
9349 {
9350   ffebld b;
9351   tree list;
9352   tree item = NULL_TREE;
9353   tree var;
9354   int i;
9355   static int mynumber = 0;
9356
9357   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9358        b != NULL;
9359        b = ffebld_trail (b), ++i)
9360     {
9361       tree t;
9362
9363       t = ffecom_vardesc_ (ffebld_head (b));
9364
9365       if (list == NULL_TREE)
9366         list = item = build_tree_list (NULL_TREE, t);
9367       else
9368         {
9369           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9370           item = TREE_CHAIN (item);
9371         }
9372     }
9373
9374   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9375                            build_range_type (integer_type_node,
9376                                              integer_one_node,
9377                                              build_int_2 (i, 0)));
9378   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9379   TREE_CONSTANT (list) = 1;
9380   TREE_STATIC (list) = 1;
9381
9382   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9383   var = build_decl (VAR_DECL, var, item);
9384   TREE_STATIC (var) = 1;
9385   DECL_INITIAL (var) = error_mark_node;
9386   var = start_decl (var, FALSE);
9387   finish_decl (var, list, FALSE);
9388
9389   return var;
9390 }
9391
9392 static tree
9393 ffecom_vardesc_dims_ (ffesymbol s)
9394 {
9395   if (ffesymbol_dims (s) == NULL)
9396     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9397                     integer_zero_node);
9398
9399   {
9400     ffebld b;
9401     ffebld e;
9402     tree list;
9403     tree backlist;
9404     tree item = NULL_TREE;
9405     tree var;
9406     tree numdim;
9407     tree numelem;
9408     tree baseoff = NULL_TREE;
9409     static int mynumber = 0;
9410
9411     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9412     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9413
9414     numelem = ffecom_expr (ffesymbol_arraysize (s));
9415     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9416
9417     list = NULL_TREE;
9418     backlist = NULL_TREE;
9419     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9420          b != NULL;
9421          b = ffebld_trail (b), e = ffebld_trail (e))
9422       {
9423         tree t;
9424         tree low;
9425         tree back;
9426
9427         if (ffebld_trail (b) == NULL)
9428           t = NULL_TREE;
9429         else
9430           {
9431             t = convert (ffecom_f2c_ftnlen_type_node,
9432                          ffecom_expr (ffebld_head (e)));
9433
9434             if (list == NULL_TREE)
9435               list = item = build_tree_list (NULL_TREE, t);
9436             else
9437               {
9438                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9439                 item = TREE_CHAIN (item);
9440               }
9441           }
9442
9443         if (ffebld_left (ffebld_head (b)) == NULL)
9444           low = ffecom_integer_one_node;
9445         else
9446           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9447         low = convert (ffecom_f2c_ftnlen_type_node, low);
9448
9449         back = build_tree_list (low, t);
9450         TREE_CHAIN (back) = backlist;
9451         backlist = back;
9452       }
9453
9454     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9455       {
9456         if (TREE_VALUE (item) == NULL_TREE)
9457           baseoff = TREE_PURPOSE (item);
9458         else
9459           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9460                               TREE_PURPOSE (item),
9461                               ffecom_2 (MULT_EXPR,
9462                                         ffecom_f2c_ftnlen_type_node,
9463                                         TREE_VALUE (item),
9464                                         baseoff));
9465       }
9466
9467     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9468
9469     baseoff = build_tree_list (NULL_TREE, baseoff);
9470     TREE_CHAIN (baseoff) = list;
9471
9472     numelem = build_tree_list (NULL_TREE, numelem);
9473     TREE_CHAIN (numelem) = baseoff;
9474
9475     numdim = build_tree_list (NULL_TREE, numdim);
9476     TREE_CHAIN (numdim) = numelem;
9477
9478     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9479                              build_range_type (integer_type_node,
9480                                                integer_zero_node,
9481                                                build_int_2
9482                                                ((int) ffesymbol_rank (s)
9483                                                 + 2, 0)));
9484     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9485     TREE_CONSTANT (list) = 1;
9486     TREE_STATIC (list) = 1;
9487
9488     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9489     var = build_decl (VAR_DECL, var, item);
9490     TREE_STATIC (var) = 1;
9491     DECL_INITIAL (var) = error_mark_node;
9492     var = start_decl (var, FALSE);
9493     finish_decl (var, list, FALSE);
9494
9495     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9496
9497     return var;
9498   }
9499 }
9500
9501 /* Essentially does a "fold (build1 (code, type, node))" while checking
9502    for certain housekeeping things.
9503
9504    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9505    ffecom_1_fn instead.  */
9506
9507 tree
9508 ffecom_1 (enum tree_code code, tree type, tree node)
9509 {
9510   tree item;
9511
9512   if ((node == error_mark_node)
9513       || (type == error_mark_node))
9514     return error_mark_node;
9515
9516   if (code == ADDR_EXPR)
9517     {
9518       if (!mark_addressable (node))
9519         assert ("can't mark_addressable this node!" == NULL);
9520     }
9521
9522   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9523     {
9524       tree realtype;
9525
9526     case REALPART_EXPR:
9527       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9528       break;
9529
9530     case IMAGPART_EXPR:
9531       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9532       break;
9533
9534
9535     case NEGATE_EXPR:
9536       if (TREE_CODE (type) != RECORD_TYPE)
9537         {
9538           item = build1 (code, type, node);
9539           break;
9540         }
9541       node = ffecom_stabilize_aggregate_ (node);
9542       realtype = TREE_TYPE (TYPE_FIELDS (type));
9543       item =
9544         ffecom_2 (COMPLEX_EXPR, type,
9545                   ffecom_1 (NEGATE_EXPR, realtype,
9546                             ffecom_1 (REALPART_EXPR, realtype,
9547                                       node)),
9548                   ffecom_1 (NEGATE_EXPR, realtype,
9549                             ffecom_1 (IMAGPART_EXPR, realtype,
9550                                       node)));
9551       break;
9552
9553     default:
9554       item = build1 (code, type, node);
9555       break;
9556     }
9557
9558   if (TREE_SIDE_EFFECTS (node))
9559     TREE_SIDE_EFFECTS (item) = 1;
9560   if (code == ADDR_EXPR && staticp (node))
9561     TREE_CONSTANT (item) = 1;
9562   else if (code == INDIRECT_REF)
9563     TREE_READONLY (item) = TYPE_READONLY (type);
9564   return fold (item);
9565 }
9566
9567 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9568    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9569    does not set TREE_ADDRESSABLE (because calling an inline
9570    function does not mean the function needs to be separately
9571    compiled).  */
9572
9573 tree
9574 ffecom_1_fn (tree node)
9575 {
9576   tree item;
9577   tree type;
9578
9579   if (node == error_mark_node)
9580     return error_mark_node;
9581
9582   type = build_type_variant (TREE_TYPE (node),
9583                              TREE_READONLY (node),
9584                              TREE_THIS_VOLATILE (node));
9585   item = build1 (ADDR_EXPR,
9586                  build_pointer_type (type), node);
9587   if (TREE_SIDE_EFFECTS (node))
9588     TREE_SIDE_EFFECTS (item) = 1;
9589   if (staticp (node))
9590     TREE_CONSTANT (item) = 1;
9591   return fold (item);
9592 }
9593
9594 /* Essentially does a "fold (build (code, type, node1, node2))" while
9595    checking for certain housekeeping things.  */
9596
9597 tree
9598 ffecom_2 (enum tree_code code, tree type, tree node1,
9599           tree node2)
9600 {
9601   tree item;
9602
9603   if ((node1 == error_mark_node)
9604       || (node2 == error_mark_node)
9605       || (type == error_mark_node))
9606     return error_mark_node;
9607
9608   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9609     {
9610       tree a, b, c, d, realtype;
9611
9612     case CONJ_EXPR:
9613       assert ("no CONJ_EXPR support yet" == NULL);
9614       return error_mark_node;
9615
9616     case COMPLEX_EXPR:
9617       item = build_tree_list (TYPE_FIELDS (type), node1);
9618       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9619       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9620       break;
9621
9622     case PLUS_EXPR:
9623       if (TREE_CODE (type) != RECORD_TYPE)
9624         {
9625           item = build (code, type, node1, node2);
9626           break;
9627         }
9628       node1 = ffecom_stabilize_aggregate_ (node1);
9629       node2 = ffecom_stabilize_aggregate_ (node2);
9630       realtype = TREE_TYPE (TYPE_FIELDS (type));
9631       item =
9632         ffecom_2 (COMPLEX_EXPR, type,
9633                   ffecom_2 (PLUS_EXPR, realtype,
9634                             ffecom_1 (REALPART_EXPR, realtype,
9635                                       node1),
9636                             ffecom_1 (REALPART_EXPR, realtype,
9637                                       node2)),
9638                   ffecom_2 (PLUS_EXPR, realtype,
9639                             ffecom_1 (IMAGPART_EXPR, realtype,
9640                                       node1),
9641                             ffecom_1 (IMAGPART_EXPR, realtype,
9642                                       node2)));
9643       break;
9644
9645     case MINUS_EXPR:
9646       if (TREE_CODE (type) != RECORD_TYPE)
9647         {
9648           item = build (code, type, node1, node2);
9649           break;
9650         }
9651       node1 = ffecom_stabilize_aggregate_ (node1);
9652       node2 = ffecom_stabilize_aggregate_ (node2);
9653       realtype = TREE_TYPE (TYPE_FIELDS (type));
9654       item =
9655         ffecom_2 (COMPLEX_EXPR, type,
9656                   ffecom_2 (MINUS_EXPR, realtype,
9657                             ffecom_1 (REALPART_EXPR, realtype,
9658                                       node1),
9659                             ffecom_1 (REALPART_EXPR, realtype,
9660                                       node2)),
9661                   ffecom_2 (MINUS_EXPR, realtype,
9662                             ffecom_1 (IMAGPART_EXPR, realtype,
9663                                       node1),
9664                             ffecom_1 (IMAGPART_EXPR, realtype,
9665                                       node2)));
9666       break;
9667
9668     case MULT_EXPR:
9669       if (TREE_CODE (type) != RECORD_TYPE)
9670         {
9671           item = build (code, type, node1, node2);
9672           break;
9673         }
9674       node1 = ffecom_stabilize_aggregate_ (node1);
9675       node2 = ffecom_stabilize_aggregate_ (node2);
9676       realtype = TREE_TYPE (TYPE_FIELDS (type));
9677       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9678                                node1));
9679       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9680                                node1));
9681       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9682                                node2));
9683       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9684                                node2));
9685       item =
9686         ffecom_2 (COMPLEX_EXPR, type,
9687                   ffecom_2 (MINUS_EXPR, realtype,
9688                             ffecom_2 (MULT_EXPR, realtype,
9689                                       a,
9690                                       c),
9691                             ffecom_2 (MULT_EXPR, realtype,
9692                                       b,
9693                                       d)),
9694                   ffecom_2 (PLUS_EXPR, realtype,
9695                             ffecom_2 (MULT_EXPR, realtype,
9696                                       a,
9697                                       d),
9698                             ffecom_2 (MULT_EXPR, realtype,
9699                                       c,
9700                                       b)));
9701       break;
9702
9703     case EQ_EXPR:
9704       if ((TREE_CODE (node1) != RECORD_TYPE)
9705           && (TREE_CODE (node2) != RECORD_TYPE))
9706         {
9707           item = build (code, type, node1, node2);
9708           break;
9709         }
9710       assert (TREE_CODE (node1) == RECORD_TYPE);
9711       assert (TREE_CODE (node2) == RECORD_TYPE);
9712       node1 = ffecom_stabilize_aggregate_ (node1);
9713       node2 = ffecom_stabilize_aggregate_ (node2);
9714       realtype = TREE_TYPE (TYPE_FIELDS (type));
9715       item =
9716         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9717                   ffecom_2 (code, type,
9718                             ffecom_1 (REALPART_EXPR, realtype,
9719                                       node1),
9720                             ffecom_1 (REALPART_EXPR, realtype,
9721                                       node2)),
9722                   ffecom_2 (code, type,
9723                             ffecom_1 (IMAGPART_EXPR, realtype,
9724                                       node1),
9725                             ffecom_1 (IMAGPART_EXPR, realtype,
9726                                       node2)));
9727       break;
9728
9729     case NE_EXPR:
9730       if ((TREE_CODE (node1) != RECORD_TYPE)
9731           && (TREE_CODE (node2) != RECORD_TYPE))
9732         {
9733           item = build (code, type, node1, node2);
9734           break;
9735         }
9736       assert (TREE_CODE (node1) == RECORD_TYPE);
9737       assert (TREE_CODE (node2) == RECORD_TYPE);
9738       node1 = ffecom_stabilize_aggregate_ (node1);
9739       node2 = ffecom_stabilize_aggregate_ (node2);
9740       realtype = TREE_TYPE (TYPE_FIELDS (type));
9741       item =
9742         ffecom_2 (TRUTH_ORIF_EXPR, type,
9743                   ffecom_2 (code, type,
9744                             ffecom_1 (REALPART_EXPR, realtype,
9745                                       node1),
9746                             ffecom_1 (REALPART_EXPR, realtype,
9747                                       node2)),
9748                   ffecom_2 (code, type,
9749                             ffecom_1 (IMAGPART_EXPR, realtype,
9750                                       node1),
9751                             ffecom_1 (IMAGPART_EXPR, realtype,
9752                                       node2)));
9753       break;
9754
9755     default:
9756       item = build (code, type, node1, node2);
9757       break;
9758     }
9759
9760   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9761     TREE_SIDE_EFFECTS (item) = 1;
9762   return fold (item);
9763 }
9764
9765 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9766
9767    ffesymbol s;  // the ENTRY point itself
9768    if (ffecom_2pass_advise_entrypoint(s))
9769        // the ENTRY point has been accepted
9770
9771    Does whatever compiler needs to do when it learns about the entrypoint,
9772    like determine the return type of the master function, count the
9773    number of entrypoints, etc.  Returns FALSE if the return type is
9774    not compatible with the return type(s) of other entrypoint(s).
9775
9776    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9777    later (after _finish_progunit) be called with the same entrypoint(s)
9778    as passed to this fn for which TRUE was returned.
9779
9780    03-Jan-92  JCB  2.0
9781       Return FALSE if the return type conflicts with previous entrypoints.  */
9782
9783 bool
9784 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9785 {
9786   ffebld list;                  /* opITEM. */
9787   ffebld mlist;                 /* opITEM. */
9788   ffebld plist;                 /* opITEM. */
9789   ffebld arg;                   /* ffebld_head(opITEM). */
9790   ffebld item;                  /* opITEM. */
9791   ffesymbol s;                  /* ffebld_symter(arg). */
9792   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9793   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9794   ffetargetCharacterSize size = ffesymbol_size (entry);
9795   bool ok;
9796
9797   if (ffecom_num_entrypoints_ == 0)
9798     {                           /* First entrypoint, make list of main
9799                                    arglist's dummies. */
9800       assert (ffecom_primary_entry_ != NULL);
9801
9802       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9803       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9804       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9805
9806       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9807            list != NULL;
9808            list = ffebld_trail (list))
9809         {
9810           arg = ffebld_head (list);
9811           if (ffebld_op (arg) != FFEBLD_opSYMTER)
9812             continue;           /* Alternate return or some such thing. */
9813           item = ffebld_new_item (arg, NULL);
9814           if (plist == NULL)
9815             ffecom_master_arglist_ = item;
9816           else
9817             ffebld_set_trail (plist, item);
9818           plist = item;
9819         }
9820     }
9821
9822   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9823      apparently redundantly (it's done below to UNIONize the arglists) so
9824      that we don't complain about RETURN 1 if an offending ENTRY is the only
9825      one with an alternate return.  */
9826
9827   if (!ffecom_is_altreturning_)
9828     {
9829       for (list = ffesymbol_dummyargs (entry);
9830            list != NULL;
9831            list = ffebld_trail (list))
9832         {
9833           arg = ffebld_head (list);
9834           if (ffebld_op (arg) == FFEBLD_opSTAR)
9835             {
9836               ffecom_is_altreturning_ = TRUE;
9837               break;
9838             }
9839         }
9840     }
9841
9842   /* Now check type compatibility. */
9843
9844   switch (ffecom_master_bt_)
9845     {
9846     case FFEINFO_basictypeNONE:
9847       ok = (bt != FFEINFO_basictypeCHARACTER);
9848       break;
9849
9850     case FFEINFO_basictypeCHARACTER:
9851       ok
9852         = (bt == FFEINFO_basictypeCHARACTER)
9853         && (kt == ffecom_master_kt_)
9854         && (size == ffecom_master_size_);
9855       break;
9856
9857     case FFEINFO_basictypeANY:
9858       return FALSE;             /* Just don't bother. */
9859
9860     default:
9861       if (bt == FFEINFO_basictypeCHARACTER)
9862         {
9863           ok = FALSE;
9864           break;
9865         }
9866       ok = TRUE;
9867       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
9868         {
9869           ffecom_master_bt_ = FFEINFO_basictypeNONE;
9870           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
9871         }
9872       break;
9873     }
9874
9875   if (!ok)
9876     {
9877       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
9878       ffest_ffebad_here_current_stmt (0);
9879       ffebad_finish ();
9880       return FALSE;             /* Can't handle entrypoint. */
9881     }
9882
9883   /* Entrypoint type compatible with previous types. */
9884
9885   ++ffecom_num_entrypoints_;
9886
9887   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9888
9889   for (list = ffesymbol_dummyargs (entry);
9890        list != NULL;
9891        list = ffebld_trail (list))
9892     {
9893       arg = ffebld_head (list);
9894       if (ffebld_op (arg) != FFEBLD_opSYMTER)
9895         continue;               /* Alternate return or some such thing. */
9896       s = ffebld_symter (arg);
9897       for (plist = NULL, mlist = ffecom_master_arglist_;
9898            mlist != NULL;
9899            plist = mlist, mlist = ffebld_trail (mlist))
9900         {                       /* plist points to previous item for easy
9901                                    appending of arg. */
9902           if (ffebld_symter (ffebld_head (mlist)) == s)
9903             break;              /* Already have this arg in the master list. */
9904         }
9905       if (mlist != NULL)
9906         continue;               /* Already have this arg in the master list. */
9907
9908       /* Append this arg to the master list. */
9909
9910       item = ffebld_new_item (arg, NULL);
9911       if (plist == NULL)
9912         ffecom_master_arglist_ = item;
9913       else
9914         ffebld_set_trail (plist, item);
9915     }
9916
9917   return TRUE;
9918 }
9919
9920 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9921
9922    ffesymbol s;  // the ENTRY point itself
9923    ffecom_2pass_do_entrypoint(s);
9924
9925    Does whatever compiler needs to do to make the entrypoint actually
9926    happen.  Must be called for each entrypoint after
9927    ffecom_finish_progunit is called.  */
9928
9929 void
9930 ffecom_2pass_do_entrypoint (ffesymbol entry)
9931 {
9932   static int mfn_num = 0;
9933   static int ent_num;
9934
9935   if (mfn_num != ffecom_num_fns_)
9936     {                           /* First entrypoint for this program unit. */
9937       ent_num = 1;
9938       mfn_num = ffecom_num_fns_;
9939       ffecom_do_entry_ (ffecom_primary_entry_, 0);
9940     }
9941   else
9942     ++ent_num;
9943
9944   --ffecom_num_entrypoints_;
9945
9946   ffecom_do_entry_ (entry, ent_num);
9947 }
9948
9949 /* Essentially does a "fold (build (code, type, node1, node2))" while
9950    checking for certain housekeeping things.  Always sets
9951    TREE_SIDE_EFFECTS.  */
9952
9953 tree
9954 ffecom_2s (enum tree_code code, tree type, tree node1,
9955            tree node2)
9956 {
9957   tree item;
9958
9959   if ((node1 == error_mark_node)
9960       || (node2 == error_mark_node)
9961       || (type == error_mark_node))
9962     return error_mark_node;
9963
9964   item = build (code, type, node1, node2);
9965   TREE_SIDE_EFFECTS (item) = 1;
9966   return fold (item);
9967 }
9968
9969 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9970    checking for certain housekeeping things.  */
9971
9972 tree
9973 ffecom_3 (enum tree_code code, tree type, tree node1,
9974           tree node2, tree node3)
9975 {
9976   tree item;
9977
9978   if ((node1 == error_mark_node)
9979       || (node2 == error_mark_node)
9980       || (node3 == error_mark_node)
9981       || (type == error_mark_node))
9982     return error_mark_node;
9983
9984   item = build (code, type, node1, node2, node3);
9985   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
9986       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
9987     TREE_SIDE_EFFECTS (item) = 1;
9988   return fold (item);
9989 }
9990
9991 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9992    checking for certain housekeeping things.  Always sets
9993    TREE_SIDE_EFFECTS.  */
9994
9995 tree
9996 ffecom_3s (enum tree_code code, tree type, tree node1,
9997            tree node2, tree node3)
9998 {
9999   tree item;
10000
10001   if ((node1 == error_mark_node)
10002       || (node2 == error_mark_node)
10003       || (node3 == error_mark_node)
10004       || (type == error_mark_node))
10005     return error_mark_node;
10006
10007   item = build (code, type, node1, node2, node3);
10008   TREE_SIDE_EFFECTS (item) = 1;
10009   return fold (item);
10010 }
10011
10012 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10013
10014    See use by ffecom_list_expr.
10015
10016    If expression is NULL, returns an integer zero tree.  If it is not
10017    a CHARACTER expression, returns whatever ffecom_expr
10018    returns and sets the length return value to NULL_TREE.  Otherwise
10019    generates code to evaluate the character expression, returns the proper
10020    pointer to the result, but does NOT set the length return value to a tree
10021    that specifies the length of the result.  (In other words, the length
10022    variable is always set to NULL_TREE, because a length is never passed.)
10023
10024    21-Dec-91  JCB  1.1
10025       Don't set returned length, since nobody needs it (yet; someday if
10026       we allow CHARACTER*(*) dummies to statement functions, we'll need
10027       it).  */
10028
10029 tree
10030 ffecom_arg_expr (ffebld expr, tree *length)
10031 {
10032   tree ign;
10033
10034   *length = NULL_TREE;
10035
10036   if (expr == NULL)
10037     return integer_zero_node;
10038
10039   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10040     return ffecom_expr (expr);
10041
10042   return ffecom_arg_ptr_to_expr (expr, &ign);
10043 }
10044
10045 /* Transform expression into constant argument-pointer-to-expression tree.
10046
10047    If the expression can be transformed into a argument-pointer-to-expression
10048    tree that is constant, that is done, and the tree returned.  Else
10049    NULL_TREE is returned.
10050
10051    That way, a caller can attempt to provide compile-time initialization
10052    of a variable and, if that fails, *then* choose to start a new block
10053    and resort to using temporaries, as appropriate.  */
10054
10055 tree
10056 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10057 {
10058   if (! expr)
10059     return integer_zero_node;
10060
10061   if (ffebld_op (expr) == FFEBLD_opANY)
10062     {
10063       if (length)
10064         *length = error_mark_node;
10065       return error_mark_node;
10066     }
10067
10068   if (ffebld_arity (expr) == 0
10069       && (ffebld_op (expr) != FFEBLD_opSYMTER
10070           || ffebld_where (expr) == FFEINFO_whereCOMMON
10071           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10072           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10073     {
10074       tree t;
10075
10076       t = ffecom_arg_ptr_to_expr (expr, length);
10077       assert (TREE_CONSTANT (t));
10078       assert (! length || TREE_CONSTANT (*length));
10079       return t;
10080     }
10081
10082   if (length
10083       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10084     *length = build_int_2 (ffebld_size (expr), 0);
10085   else if (length)
10086     *length = NULL_TREE;
10087   return NULL_TREE;
10088 }
10089
10090 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10091
10092    See use by ffecom_list_ptr_to_expr.
10093
10094    If expression is NULL, returns an integer zero tree.  If it is not
10095    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10096    returns and sets the length return value to NULL_TREE.  Otherwise
10097    generates code to evaluate the character expression, returns the proper
10098    pointer to the result, AND sets the length return value to a tree that
10099    specifies the length of the result.
10100
10101    If the length argument is NULL, this is a slightly special
10102    case of building a FORMAT expression, that is, an expression that
10103    will be used at run time without regard to length.  For the current
10104    implementation, which uses the libf2c library, this means it is nice
10105    to append a null byte to the end of the expression, where feasible,
10106    to make sure any diagnostic about the FORMAT string terminates at
10107    some useful point.
10108
10109    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10110    length argument.  This might even be seen as a feature, if a null
10111    byte can always be appended.  */
10112
10113 tree
10114 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10115 {
10116   tree item;
10117   tree ign_length;
10118   ffecomConcatList_ catlist;
10119
10120   if (length != NULL)
10121     *length = NULL_TREE;
10122
10123   if (expr == NULL)
10124     return integer_zero_node;
10125
10126   switch (ffebld_op (expr))
10127     {
10128     case FFEBLD_opPERCENT_VAL:
10129       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10130         return ffecom_expr (ffebld_left (expr));
10131       {
10132         tree temp_exp;
10133         tree temp_length;
10134
10135         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10136         if (temp_exp == error_mark_node)
10137           return error_mark_node;
10138
10139         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10140                          temp_exp);
10141       }
10142
10143     case FFEBLD_opPERCENT_REF:
10144       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10145         return ffecom_ptr_to_expr (ffebld_left (expr));
10146       if (length != NULL)
10147         {
10148           ign_length = NULL_TREE;
10149           length = &ign_length;
10150         }
10151       expr = ffebld_left (expr);
10152       break;
10153
10154     case FFEBLD_opPERCENT_DESCR:
10155       switch (ffeinfo_basictype (ffebld_info (expr)))
10156         {
10157 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10158         case FFEINFO_basictypeHOLLERITH:
10159 #endif
10160         case FFEINFO_basictypeCHARACTER:
10161           break;                /* Passed by descriptor anyway. */
10162
10163         default:
10164           item = ffecom_ptr_to_expr (expr);
10165           if (item != error_mark_node)
10166             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10167           break;
10168         }
10169       break;
10170
10171     default:
10172       break;
10173     }
10174
10175 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10176   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10177       && (length != NULL))
10178     {                           /* Pass Hollerith by descriptor. */
10179       ffetargetHollerith h;
10180
10181       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10182       h = ffebld_cu_val_hollerith (ffebld_constant_union
10183                                    (ffebld_conter (expr)));
10184       *length
10185         = build_int_2 (h.length, 0);
10186       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10187     }
10188 #endif
10189
10190   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10191     return ffecom_ptr_to_expr (expr);
10192
10193   assert (ffeinfo_kindtype (ffebld_info (expr))
10194           == FFEINFO_kindtypeCHARACTER1);
10195
10196   while (ffebld_op (expr) == FFEBLD_opPAREN)
10197     expr = ffebld_left (expr);
10198
10199   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10200   switch (ffecom_concat_list_count_ (catlist))
10201     {
10202     case 0:                     /* Shouldn't happen, but in case it does... */
10203       if (length != NULL)
10204         {
10205           *length = ffecom_f2c_ftnlen_zero_node;
10206           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10207         }
10208       ffecom_concat_list_kill_ (catlist);
10209       return null_pointer_node;
10210
10211     case 1:                     /* The (fairly) easy case. */
10212       if (length == NULL)
10213         ffecom_char_args_with_null_ (&item, &ign_length,
10214                                      ffecom_concat_list_expr_ (catlist, 0));
10215       else
10216         ffecom_char_args_ (&item, length,
10217                            ffecom_concat_list_expr_ (catlist, 0));
10218       ffecom_concat_list_kill_ (catlist);
10219       assert (item != NULL_TREE);
10220       return item;
10221
10222     default:                    /* Must actually concatenate things. */
10223       break;
10224     }
10225
10226   {
10227     int count = ffecom_concat_list_count_ (catlist);
10228     int i;
10229     tree lengths;
10230     tree items;
10231     tree length_array;
10232     tree item_array;
10233     tree citem;
10234     tree clength;
10235     tree temporary;
10236     tree num;
10237     tree known_length;
10238     ffetargetCharacterSize sz;
10239
10240     sz = ffecom_concat_list_maxlen_ (catlist);
10241     /* ~~Kludge! */
10242     assert (sz != FFETARGET_charactersizeNONE);
10243
10244 #ifdef HOHO
10245     length_array
10246       = lengths
10247       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10248                              FFETARGET_charactersizeNONE, count, TRUE);
10249     item_array
10250       = items
10251       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10252                              FFETARGET_charactersizeNONE, count, TRUE);
10253     temporary = ffecom_push_tempvar (char_type_node,
10254                                      sz, -1, TRUE);
10255 #else
10256     {
10257       tree hook;
10258
10259       hook = ffebld_nonter_hook (expr);
10260       assert (hook);
10261       assert (TREE_CODE (hook) == TREE_VEC);
10262       assert (TREE_VEC_LENGTH (hook) == 3);
10263       length_array = lengths = TREE_VEC_ELT (hook, 0);
10264       item_array = items = TREE_VEC_ELT (hook, 1);
10265       temporary = TREE_VEC_ELT (hook, 2);
10266     }
10267 #endif
10268
10269     known_length = ffecom_f2c_ftnlen_zero_node;
10270
10271     for (i = 0; i < count; ++i)
10272       {
10273         if ((i == count)
10274             && (length == NULL))
10275           ffecom_char_args_with_null_ (&citem, &clength,
10276                                        ffecom_concat_list_expr_ (catlist, i));
10277         else
10278           ffecom_char_args_ (&citem, &clength,
10279                              ffecom_concat_list_expr_ (catlist, i));
10280         if ((citem == error_mark_node)
10281             || (clength == error_mark_node))
10282           {
10283             ffecom_concat_list_kill_ (catlist);
10284             *length = error_mark_node;
10285             return error_mark_node;
10286           }
10287
10288         items
10289           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10290                       ffecom_modify (void_type_node,
10291                                      ffecom_2 (ARRAY_REF,
10292                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10293                                                item_array,
10294                                                build_int_2 (i, 0)),
10295                                      citem),
10296                       items);
10297         clength = ffecom_save_tree (clength);
10298         if (length != NULL)
10299           known_length
10300             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10301                         known_length,
10302                         clength);
10303         lengths
10304           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10305                       ffecom_modify (void_type_node,
10306                                      ffecom_2 (ARRAY_REF,
10307                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10308                                                length_array,
10309                                                build_int_2 (i, 0)),
10310                                      clength),
10311                       lengths);
10312       }
10313
10314     temporary = ffecom_1 (ADDR_EXPR,
10315                           build_pointer_type (TREE_TYPE (temporary)),
10316                           temporary);
10317
10318     item = build_tree_list (NULL_TREE, temporary);
10319     TREE_CHAIN (item)
10320       = build_tree_list (NULL_TREE,
10321                          ffecom_1 (ADDR_EXPR,
10322                                    build_pointer_type (TREE_TYPE (items)),
10323                                    items));
10324     TREE_CHAIN (TREE_CHAIN (item))
10325       = build_tree_list (NULL_TREE,
10326                          ffecom_1 (ADDR_EXPR,
10327                                    build_pointer_type (TREE_TYPE (lengths)),
10328                                    lengths));
10329     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10330       = build_tree_list
10331         (NULL_TREE,
10332          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10333                    convert (ffecom_f2c_ftnlen_type_node,
10334                             build_int_2 (count, 0))));
10335     num = build_int_2 (sz, 0);
10336     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10337     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10338       = build_tree_list (NULL_TREE, num);
10339
10340     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10341     TREE_SIDE_EFFECTS (item) = 1;
10342     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10343                      item,
10344                      temporary);
10345
10346     if (length != NULL)
10347       *length = known_length;
10348   }
10349
10350   ffecom_concat_list_kill_ (catlist);
10351   assert (item != NULL_TREE);
10352   return item;
10353 }
10354
10355 /* Generate call to run-time function.
10356
10357    The first arg is the GNU Fortran Run-Time function index, the second
10358    arg is the list of arguments to pass to it.  Returned is the expression
10359    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10360    result (which may be void).  */
10361
10362 tree
10363 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10364 {
10365   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10366                        ffecom_gfrt_kindtype (ix),
10367                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10368                        NULL_TREE, args, NULL_TREE, NULL,
10369                        NULL, NULL_TREE, TRUE, hook);
10370 }
10371
10372 /* Transform constant-union to tree.  */
10373
10374 tree
10375 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10376                       ffeinfoKindtype kt, tree tree_type)
10377 {
10378   tree item;
10379
10380   switch (bt)
10381     {
10382     case FFEINFO_basictypeINTEGER:
10383       {
10384         int val;
10385
10386         switch (kt)
10387           {
10388 #if FFETARGET_okINTEGER1
10389           case FFEINFO_kindtypeINTEGER1:
10390             val = ffebld_cu_val_integer1 (*cu);
10391             break;
10392 #endif
10393
10394 #if FFETARGET_okINTEGER2
10395           case FFEINFO_kindtypeINTEGER2:
10396             val = ffebld_cu_val_integer2 (*cu);
10397             break;
10398 #endif
10399
10400 #if FFETARGET_okINTEGER3
10401           case FFEINFO_kindtypeINTEGER3:
10402             val = ffebld_cu_val_integer3 (*cu);
10403             break;
10404 #endif
10405
10406 #if FFETARGET_okINTEGER4
10407           case FFEINFO_kindtypeINTEGER4:
10408             val = ffebld_cu_val_integer4 (*cu);
10409             break;
10410 #endif
10411
10412           default:
10413             assert ("bad INTEGER constant kind type" == NULL);
10414             /* Fall through. */
10415           case FFEINFO_kindtypeANY:
10416             return error_mark_node;
10417           }
10418         item = build_int_2 (val, (val < 0) ? -1 : 0);
10419         TREE_TYPE (item) = tree_type;
10420       }
10421       break;
10422
10423     case FFEINFO_basictypeLOGICAL:
10424       {
10425         int val;
10426
10427         switch (kt)
10428           {
10429 #if FFETARGET_okLOGICAL1
10430           case FFEINFO_kindtypeLOGICAL1:
10431             val = ffebld_cu_val_logical1 (*cu);
10432             break;
10433 #endif
10434
10435 #if FFETARGET_okLOGICAL2
10436           case FFEINFO_kindtypeLOGICAL2:
10437             val = ffebld_cu_val_logical2 (*cu);
10438             break;
10439 #endif
10440
10441 #if FFETARGET_okLOGICAL3
10442           case FFEINFO_kindtypeLOGICAL3:
10443             val = ffebld_cu_val_logical3 (*cu);
10444             break;
10445 #endif
10446
10447 #if FFETARGET_okLOGICAL4
10448           case FFEINFO_kindtypeLOGICAL4:
10449             val = ffebld_cu_val_logical4 (*cu);
10450             break;
10451 #endif
10452
10453           default:
10454             assert ("bad LOGICAL constant kind type" == NULL);
10455             /* Fall through. */
10456           case FFEINFO_kindtypeANY:
10457             return error_mark_node;
10458           }
10459         item = build_int_2 (val, (val < 0) ? -1 : 0);
10460         TREE_TYPE (item) = tree_type;
10461       }
10462       break;
10463
10464     case FFEINFO_basictypeREAL:
10465       {
10466         REAL_VALUE_TYPE val;
10467
10468         switch (kt)
10469           {
10470 #if FFETARGET_okREAL1
10471           case FFEINFO_kindtypeREAL1:
10472             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10473             break;
10474 #endif
10475
10476 #if FFETARGET_okREAL2
10477           case FFEINFO_kindtypeREAL2:
10478             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10479             break;
10480 #endif
10481
10482 #if FFETARGET_okREAL3
10483           case FFEINFO_kindtypeREAL3:
10484             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10485             break;
10486 #endif
10487
10488 #if FFETARGET_okREAL4
10489           case FFEINFO_kindtypeREAL4:
10490             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10491             break;
10492 #endif
10493
10494           default:
10495             assert ("bad REAL constant kind type" == NULL);
10496             /* Fall through. */
10497           case FFEINFO_kindtypeANY:
10498             return error_mark_node;
10499           }
10500         item = build_real (tree_type, val);
10501       }
10502       break;
10503
10504     case FFEINFO_basictypeCOMPLEX:
10505       {
10506         REAL_VALUE_TYPE real;
10507         REAL_VALUE_TYPE imag;
10508         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10509
10510         switch (kt)
10511           {
10512 #if FFETARGET_okCOMPLEX1
10513           case FFEINFO_kindtypeREAL1:
10514             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10515             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10516             break;
10517 #endif
10518
10519 #if FFETARGET_okCOMPLEX2
10520           case FFEINFO_kindtypeREAL2:
10521             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10522             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10523             break;
10524 #endif
10525
10526 #if FFETARGET_okCOMPLEX3
10527           case FFEINFO_kindtypeREAL3:
10528             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10529             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10530             break;
10531 #endif
10532
10533 #if FFETARGET_okCOMPLEX4
10534           case FFEINFO_kindtypeREAL4:
10535             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10536             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10537             break;
10538 #endif
10539
10540           default:
10541             assert ("bad REAL constant kind type" == NULL);
10542             /* Fall through. */
10543           case FFEINFO_kindtypeANY:
10544             return error_mark_node;
10545           }
10546         item = ffecom_build_complex_constant_ (tree_type,
10547                                                build_real (el_type, real),
10548                                                build_real (el_type, imag));
10549       }
10550       break;
10551
10552     case FFEINFO_basictypeCHARACTER:
10553       {                         /* Happens only in DATA and similar contexts. */
10554         ffetargetCharacter1 val;
10555
10556         switch (kt)
10557           {
10558 #if FFETARGET_okCHARACTER1
10559           case FFEINFO_kindtypeLOGICAL1:
10560             val = ffebld_cu_val_character1 (*cu);
10561             break;
10562 #endif
10563
10564           default:
10565             assert ("bad CHARACTER constant kind type" == NULL);
10566             /* Fall through. */
10567           case FFEINFO_kindtypeANY:
10568             return error_mark_node;
10569           }
10570         item = build_string (ffetarget_length_character1 (val),
10571                              ffetarget_text_character1 (val));
10572         TREE_TYPE (item)
10573           = build_type_variant (build_array_type (char_type_node,
10574                                                   build_range_type
10575                                                   (integer_type_node,
10576                                                    integer_one_node,
10577                                                    build_int_2
10578                                                 (ffetarget_length_character1
10579                                                  (val), 0))),
10580                                 1, 0);
10581       }
10582       break;
10583
10584     case FFEINFO_basictypeHOLLERITH:
10585       {
10586         ffetargetHollerith h;
10587
10588         h = ffebld_cu_val_hollerith (*cu);
10589
10590         /* If not at least as wide as default INTEGER, widen it.  */
10591         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10592           item = build_string (h.length, h.text);
10593         else
10594           {
10595             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10596
10597             memcpy (str, h.text, h.length);
10598             memset (&str[h.length], ' ',
10599                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10600                     - h.length);
10601             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10602                                  str);
10603           }
10604         TREE_TYPE (item)
10605           = build_type_variant (build_array_type (char_type_node,
10606                                                   build_range_type
10607                                                   (integer_type_node,
10608                                                    integer_one_node,
10609                                                    build_int_2
10610                                                    (h.length, 0))),
10611                                 1, 0);
10612       }
10613       break;
10614
10615     case FFEINFO_basictypeTYPELESS:
10616       {
10617         ffetargetInteger1 ival;
10618         ffetargetTypeless tless;
10619         ffebad error;
10620
10621         tless = ffebld_cu_val_typeless (*cu);
10622         error = ffetarget_convert_integer1_typeless (&ival, tless);
10623         assert (error == FFEBAD);
10624
10625         item = build_int_2 ((int) ival, 0);
10626       }
10627       break;
10628
10629     default:
10630       assert ("not yet on constant type" == NULL);
10631       /* Fall through. */
10632     case FFEINFO_basictypeANY:
10633       return error_mark_node;
10634     }
10635
10636   TREE_CONSTANT (item) = 1;
10637
10638   return item;
10639 }
10640
10641 /* Transform expression into constant tree.
10642
10643    If the expression can be transformed into a tree that is constant,
10644    that is done, and the tree returned.  Else NULL_TREE is returned.
10645
10646    That way, a caller can attempt to provide compile-time initialization
10647    of a variable and, if that fails, *then* choose to start a new block
10648    and resort to using temporaries, as appropriate.  */
10649
10650 tree
10651 ffecom_const_expr (ffebld expr)
10652 {
10653   if (! expr)
10654     return integer_zero_node;
10655
10656   if (ffebld_op (expr) == FFEBLD_opANY)
10657     return error_mark_node;
10658
10659   if (ffebld_arity (expr) == 0
10660       && (ffebld_op (expr) != FFEBLD_opSYMTER
10661 #if NEWCOMMON
10662           /* ~~Enable once common/equivalence is handled properly?  */
10663           || ffebld_where (expr) == FFEINFO_whereCOMMON
10664 #endif
10665           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10666           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10667     {
10668       tree t;
10669
10670       t = ffecom_expr (expr);
10671       assert (TREE_CONSTANT (t));
10672       return t;
10673     }
10674
10675   return NULL_TREE;
10676 }
10677
10678 /* Handy way to make a field in a struct/union.  */
10679
10680 tree
10681 ffecom_decl_field (tree context, tree prevfield,
10682                    const char *name, tree type)
10683 {
10684   tree field;
10685
10686   field = build_decl (FIELD_DECL, get_identifier (name), type);
10687   DECL_CONTEXT (field) = context;
10688   DECL_ALIGN (field) = 0;
10689   DECL_USER_ALIGN (field) = 0;
10690   if (prevfield != NULL_TREE)
10691     TREE_CHAIN (prevfield) = field;
10692
10693   return field;
10694 }
10695
10696 void
10697 ffecom_close_include (FILE *f)
10698 {
10699   ffecom_close_include_ (f);
10700 }
10701
10702 int
10703 ffecom_decode_include_option (char *spec)
10704 {
10705   return ffecom_decode_include_option_ (spec);
10706 }
10707
10708 /* End a compound statement (block).  */
10709
10710 tree
10711 ffecom_end_compstmt (void)
10712 {
10713   return bison_rule_compstmt_ ();
10714 }
10715
10716 /* ffecom_end_transition -- Perform end transition on all symbols
10717
10718    ffecom_end_transition();
10719
10720    Calls ffecom_sym_end_transition for each global and local symbol.  */
10721
10722 void
10723 ffecom_end_transition ()
10724 {
10725   ffebld item;
10726
10727   if (ffe_is_ffedebug ())
10728     fprintf (dmpout, "; end_stmt_transition\n");
10729
10730   ffecom_list_blockdata_ = NULL;
10731   ffecom_list_common_ = NULL;
10732
10733   ffesymbol_drive (ffecom_sym_end_transition);
10734   if (ffe_is_ffedebug ())
10735     {
10736       ffestorag_report ();
10737     }
10738
10739   ffecom_start_progunit_ ();
10740
10741   for (item = ffecom_list_blockdata_;
10742        item != NULL;
10743        item = ffebld_trail (item))
10744     {
10745       ffebld callee;
10746       ffesymbol s;
10747       tree dt;
10748       tree t;
10749       tree var;
10750       static int number = 0;
10751
10752       callee = ffebld_head (item);
10753       s = ffebld_symter (callee);
10754       t = ffesymbol_hook (s).decl_tree;
10755       if (t == NULL_TREE)
10756         {
10757           s = ffecom_sym_transform_ (s);
10758           t = ffesymbol_hook (s).decl_tree;
10759         }
10760
10761       dt = build_pointer_type (TREE_TYPE (t));
10762
10763       var = build_decl (VAR_DECL,
10764                         ffecom_get_invented_identifier ("__g77_forceload_%d",
10765                                                         number++),
10766                         dt);
10767       DECL_EXTERNAL (var) = 0;
10768       TREE_STATIC (var) = 1;
10769       TREE_PUBLIC (var) = 0;
10770       DECL_INITIAL (var) = error_mark_node;
10771       TREE_USED (var) = 1;
10772
10773       var = start_decl (var, FALSE);
10774
10775       t = ffecom_1 (ADDR_EXPR, dt, t);
10776
10777       finish_decl (var, t, FALSE);
10778     }
10779
10780   /* This handles any COMMON areas that weren't referenced but have, for
10781      example, important initial data.  */
10782
10783   for (item = ffecom_list_common_;
10784        item != NULL;
10785        item = ffebld_trail (item))
10786     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10787
10788   ffecom_list_common_ = NULL;
10789 }
10790
10791 /* ffecom_exec_transition -- Perform exec transition on all symbols
10792
10793    ffecom_exec_transition();
10794
10795    Calls ffecom_sym_exec_transition for each global and local symbol.
10796    Make sure error updating not inhibited.  */
10797
10798 void
10799 ffecom_exec_transition ()
10800 {
10801   bool inhibited;
10802
10803   if (ffe_is_ffedebug ())
10804     fprintf (dmpout, "; exec_stmt_transition\n");
10805
10806   inhibited = ffebad_inhibit ();
10807   ffebad_set_inhibit (FALSE);
10808
10809   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10810   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
10811   if (ffe_is_ffedebug ())
10812     {
10813       ffestorag_report ();
10814     }
10815
10816   if (inhibited)
10817     ffebad_set_inhibit (TRUE);
10818 }
10819
10820 /* Handle assignment statement.
10821
10822    Convert dest and source using ffecom_expr, then join them
10823    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
10824
10825 void
10826 ffecom_expand_let_stmt (ffebld dest, ffebld source)
10827 {
10828   tree dest_tree;
10829   tree dest_length;
10830   tree source_tree;
10831   tree expr_tree;
10832
10833   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
10834     {
10835       bool dest_used;
10836       tree assign_temp;
10837
10838       /* This attempts to replicate the test below, but must not be
10839          true when the test below is false.  (Always err on the side
10840          of creating unused temporaries, to avoid ICEs.)  */
10841       if (ffebld_op (dest) != FFEBLD_opSYMTER
10842           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
10843               && (TREE_CODE (dest_tree) != VAR_DECL
10844                   || TREE_ADDRESSABLE (dest_tree))))
10845         {
10846           ffecom_prepare_expr_ (source, dest);
10847           dest_used = TRUE;
10848         }
10849       else
10850         {
10851           ffecom_prepare_expr_ (source, NULL);
10852           dest_used = FALSE;
10853         }
10854
10855       ffecom_prepare_expr_w (NULL_TREE, dest);
10856
10857       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10858          create a temporary through which the assignment is to take place,
10859          since MODIFY_EXPR doesn't handle partial overlap properly.  */
10860       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
10861           && ffecom_possible_partial_overlap_ (dest, source))
10862         {
10863           assign_temp = ffecom_make_tempvar ("complex_let",
10864                                              ffecom_tree_type
10865                                              [ffebld_basictype (dest)]
10866                                              [ffebld_kindtype (dest)],
10867                                              FFETARGET_charactersizeNONE,
10868                                              -1);
10869         }
10870       else
10871         assign_temp = NULL_TREE;
10872
10873       ffecom_prepare_end ();
10874
10875       dest_tree = ffecom_expr_w (NULL_TREE, dest);
10876       if (dest_tree == error_mark_node)
10877         return;
10878
10879       if ((TREE_CODE (dest_tree) != VAR_DECL)
10880           || TREE_ADDRESSABLE (dest_tree))
10881         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
10882                                     FALSE, FALSE);
10883       else
10884         {
10885           assert (! dest_used);
10886           dest_used = FALSE;
10887           source_tree = ffecom_expr (source);
10888         }
10889       if (source_tree == error_mark_node)
10890         return;
10891
10892       if (dest_used)
10893         expr_tree = source_tree;
10894       else if (assign_temp)
10895         {
10896 #ifdef MOVE_EXPR
10897           /* The back end understands a conceptual move (evaluate source;
10898              store into dest), so use that, in case it can determine
10899              that it is going to use, say, two registers as temporaries
10900              anyway.  So don't use the temp (and someday avoid generating
10901              it, once this code starts triggering regularly).  */
10902           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
10903                                  dest_tree,
10904                                  source_tree);
10905 #else
10906           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10907                                  assign_temp,
10908                                  source_tree);
10909           expand_expr_stmt (expr_tree);
10910           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10911                                  dest_tree,
10912                                  assign_temp);
10913 #endif
10914         }
10915       else
10916         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10917                                dest_tree,
10918                                source_tree);
10919
10920       expand_expr_stmt (expr_tree);
10921       return;
10922     }
10923
10924   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
10925   ffecom_prepare_expr_w (NULL_TREE, dest);
10926
10927   ffecom_prepare_end ();
10928
10929   ffecom_char_args_ (&dest_tree, &dest_length, dest);
10930   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
10931                     source);
10932 }
10933
10934 /* ffecom_expr -- Transform expr into gcc tree
10935
10936    tree t;
10937    ffebld expr;  // FFE expression.
10938    tree = ffecom_expr(expr);
10939
10940    Recursive descent on expr while making corresponding tree nodes and
10941    attaching type info and such.  */
10942
10943 tree
10944 ffecom_expr (ffebld expr)
10945 {
10946   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
10947 }
10948
10949 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
10950
10951 tree
10952 ffecom_expr_assign (ffebld expr)
10953 {
10954   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10955 }
10956
10957 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
10958
10959 tree
10960 ffecom_expr_assign_w (ffebld expr)
10961 {
10962   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10963 }
10964
10965 /* Transform expr for use as into read/write tree and stabilize the
10966    reference.  Not for use on CHARACTER expressions.
10967
10968    Recursive descent on expr while making corresponding tree nodes and
10969    attaching type info and such.  */
10970
10971 tree
10972 ffecom_expr_rw (tree type, ffebld expr)
10973 {
10974   assert (expr != NULL);
10975   /* Different target types not yet supported.  */
10976   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10977
10978   return stabilize_reference (ffecom_expr (expr));
10979 }
10980
10981 /* Transform expr for use as into write tree and stabilize the
10982    reference.  Not for use on CHARACTER expressions.
10983
10984    Recursive descent on expr while making corresponding tree nodes and
10985    attaching type info and such.  */
10986
10987 tree
10988 ffecom_expr_w (tree type, ffebld expr)
10989 {
10990   assert (expr != NULL);
10991   /* Different target types not yet supported.  */
10992   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
10993
10994   return stabilize_reference (ffecom_expr (expr));
10995 }
10996
10997 /* Do global stuff.  */
10998
10999 void
11000 ffecom_finish_compile ()
11001 {
11002   assert (ffecom_outer_function_decl_ == NULL_TREE);
11003   assert (current_function_decl == NULL_TREE);
11004
11005   ffeglobal_drive (ffecom_finish_global_);
11006 }
11007
11008 /* Public entry point for front end to access finish_decl.  */
11009
11010 void
11011 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11012 {
11013   assert (!is_top_level);
11014   finish_decl (decl, init, FALSE);
11015 }
11016
11017 /* Finish a program unit.  */
11018
11019 void
11020 ffecom_finish_progunit ()
11021 {
11022   ffecom_end_compstmt ();
11023
11024   ffecom_previous_function_decl_ = current_function_decl;
11025   ffecom_which_entrypoint_decl_ = NULL_TREE;
11026
11027   finish_function (0);
11028 }
11029
11030 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11031
11032 tree
11033 ffecom_get_invented_identifier (const char *pattern, ...)
11034 {
11035   tree decl;
11036   char *nam;
11037   va_list ap;
11038
11039   va_start (ap, pattern);
11040   if (vasprintf (&nam, pattern, ap) == 0)
11041     abort ();
11042   va_end (ap);
11043   decl = get_identifier (nam);
11044   free (nam);
11045   IDENTIFIER_INVENTED (decl) = 1;
11046   return decl;
11047 }
11048
11049 ffeinfoBasictype
11050 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11051 {
11052   assert (gfrt < FFECOM_gfrt);
11053
11054   switch (ffecom_gfrt_type_[gfrt])
11055     {
11056     case FFECOM_rttypeVOID_:
11057     case FFECOM_rttypeVOIDSTAR_:
11058       return FFEINFO_basictypeNONE;
11059
11060     case FFECOM_rttypeFTNINT_:
11061       return FFEINFO_basictypeINTEGER;
11062
11063     case FFECOM_rttypeINTEGER_:
11064       return FFEINFO_basictypeINTEGER;
11065
11066     case FFECOM_rttypeLONGINT_:
11067       return FFEINFO_basictypeINTEGER;
11068
11069     case FFECOM_rttypeLOGICAL_:
11070       return FFEINFO_basictypeLOGICAL;
11071
11072     case FFECOM_rttypeREAL_F2C_:
11073     case FFECOM_rttypeREAL_GNU_:
11074       return FFEINFO_basictypeREAL;
11075
11076     case FFECOM_rttypeCOMPLEX_F2C_:
11077     case FFECOM_rttypeCOMPLEX_GNU_:
11078       return FFEINFO_basictypeCOMPLEX;
11079
11080     case FFECOM_rttypeDOUBLE_:
11081     case FFECOM_rttypeDOUBLEREAL_:
11082       return FFEINFO_basictypeREAL;
11083
11084     case FFECOM_rttypeDBLCMPLX_F2C_:
11085     case FFECOM_rttypeDBLCMPLX_GNU_:
11086       return FFEINFO_basictypeCOMPLEX;
11087
11088     case FFECOM_rttypeCHARACTER_:
11089       return FFEINFO_basictypeCHARACTER;
11090
11091     default:
11092       return FFEINFO_basictypeANY;
11093     }
11094 }
11095
11096 ffeinfoKindtype
11097 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11098 {
11099   assert (gfrt < FFECOM_gfrt);
11100
11101   switch (ffecom_gfrt_type_[gfrt])
11102     {
11103     case FFECOM_rttypeVOID_:
11104     case FFECOM_rttypeVOIDSTAR_:
11105       return FFEINFO_kindtypeNONE;
11106
11107     case FFECOM_rttypeFTNINT_:
11108       return FFEINFO_kindtypeINTEGER1;
11109
11110     case FFECOM_rttypeINTEGER_:
11111       return FFEINFO_kindtypeINTEGER1;
11112
11113     case FFECOM_rttypeLONGINT_:
11114       return FFEINFO_kindtypeINTEGER4;
11115
11116     case FFECOM_rttypeLOGICAL_:
11117       return FFEINFO_kindtypeLOGICAL1;
11118
11119     case FFECOM_rttypeREAL_F2C_:
11120     case FFECOM_rttypeREAL_GNU_:
11121       return FFEINFO_kindtypeREAL1;
11122
11123     case FFECOM_rttypeCOMPLEX_F2C_:
11124     case FFECOM_rttypeCOMPLEX_GNU_:
11125       return FFEINFO_kindtypeREAL1;
11126
11127     case FFECOM_rttypeDOUBLE_:
11128     case FFECOM_rttypeDOUBLEREAL_:
11129       return FFEINFO_kindtypeREAL2;
11130
11131     case FFECOM_rttypeDBLCMPLX_F2C_:
11132     case FFECOM_rttypeDBLCMPLX_GNU_:
11133       return FFEINFO_kindtypeREAL2;
11134
11135     case FFECOM_rttypeCHARACTER_:
11136       return FFEINFO_kindtypeCHARACTER1;
11137
11138     default:
11139       return FFEINFO_kindtypeANY;
11140     }
11141 }
11142
11143 void
11144 ffecom_init_0 ()
11145 {
11146   tree endlink;
11147   int i;
11148   int j;
11149   tree t;
11150   tree field;
11151   ffetype type;
11152   ffetype base_type;
11153   tree double_ftype_double;
11154   tree float_ftype_float;
11155   tree ldouble_ftype_ldouble;
11156   tree ffecom_tree_ptr_to_fun_type_void;
11157
11158   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11159      whether the compiler environment is buggy in known ways, some of which
11160      would, if not explicitly checked here, result in subtle bugs in g77.  */
11161
11162   if (ffe_is_do_internal_checks ())
11163     {
11164       static const char names[][12]
11165         =
11166       {"bar", "bletch", "foo", "foobar"};
11167       const char *name;
11168       unsigned long ul;
11169       double fl;
11170
11171       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11172                       (int (*)(const void *, const void *)) strcmp);
11173       if (name != &names[0][2])
11174         {
11175           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11176                   == NULL);
11177           abort ();
11178         }
11179
11180       ul = strtoul ("123456789", NULL, 10);
11181       if (ul != 123456789L)
11182         {
11183           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11184  in proj.h" == NULL);
11185           abort ();
11186         }
11187
11188       fl = atof ("56.789");
11189       if ((fl < 56.788) || (fl > 56.79))
11190         {
11191           assert ("atof not type double, fix your #include <stdio.h>"
11192                   == NULL);
11193           abort ();
11194         }
11195     }
11196
11197   ffecom_outer_function_decl_ = NULL_TREE;
11198   current_function_decl = NULL_TREE;
11199   named_labels = NULL_TREE;
11200   current_binding_level = NULL_BINDING_LEVEL;
11201   free_binding_level = NULL_BINDING_LEVEL;
11202   /* Make the binding_level structure for global names.  */
11203   pushlevel (0);
11204   global_binding_level = current_binding_level;
11205   current_binding_level->prep_state = 2;
11206
11207   build_common_tree_nodes (1);
11208
11209   /* Define `int' and `char' first so that dbx will output them first.  */
11210   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11211                         integer_type_node));
11212   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11213   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11214   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11215                         char_type_node));
11216   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11217                         long_integer_type_node));
11218   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11219                         unsigned_type_node));
11220   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11221                         long_unsigned_type_node));
11222   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11223                         long_long_integer_type_node));
11224   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11225                         long_long_unsigned_type_node));
11226   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11227                         short_integer_type_node));
11228   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11229                         short_unsigned_type_node));
11230
11231   /* Set the sizetype before we make other types.  This *should* be the
11232      first type we create.  */
11233
11234   set_sizetype
11235     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11236   ffecom_typesize_pointer_
11237     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11238
11239   build_common_tree_nodes_2 (0);
11240
11241   /* Define both `signed char' and `unsigned char'.  */
11242   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11243                         signed_char_type_node));
11244
11245   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11246                         unsigned_char_type_node));
11247
11248   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11249                         float_type_node));
11250   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11251                         double_type_node));
11252   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11253                         long_double_type_node));
11254
11255   /* For now, override what build_common_tree_nodes has done.  */
11256   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11257   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11258   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11259   complex_long_double_type_node
11260     = ffecom_make_complex_type_ (long_double_type_node);
11261
11262   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11263                         complex_integer_type_node));
11264   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11265                         complex_float_type_node));
11266   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11267                         complex_double_type_node));
11268   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11269                         complex_long_double_type_node));
11270
11271   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11272                         void_type_node));
11273   /* We are not going to have real types in C with less than byte alignment,
11274      so we might as well not have any types that claim to have it.  */
11275   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11276   TYPE_USER_ALIGN (void_type_node) = 0;
11277
11278   string_type_node = build_pointer_type (char_type_node);
11279
11280   ffecom_tree_fun_type_void
11281     = build_function_type (void_type_node, NULL_TREE);
11282
11283   ffecom_tree_ptr_to_fun_type_void
11284     = build_pointer_type (ffecom_tree_fun_type_void);
11285
11286   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11287
11288   float_ftype_float
11289     = build_function_type (float_type_node,
11290                            tree_cons (NULL_TREE, float_type_node, endlink));
11291
11292   double_ftype_double
11293     = build_function_type (double_type_node,
11294                            tree_cons (NULL_TREE, double_type_node, endlink));
11295
11296   ldouble_ftype_ldouble
11297     = build_function_type (long_double_type_node,
11298                            tree_cons (NULL_TREE, long_double_type_node,
11299                                       endlink));
11300
11301   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11302     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11303       {
11304         ffecom_tree_type[i][j] = NULL_TREE;
11305         ffecom_tree_fun_type[i][j] = NULL_TREE;
11306         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11307         ffecom_f2c_typecode_[i][j] = -1;
11308       }
11309
11310   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11311      to size FLOAT_TYPE_SIZE because they have to be the same size as
11312      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11313      Compiler options and other such stuff that change the ways these
11314      types are set should not affect this particular setup.  */
11315
11316   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11317     = t = make_signed_type (FLOAT_TYPE_SIZE);
11318   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11319                         t));
11320   type = ffetype_new ();
11321   base_type = type;
11322   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11323                     type);
11324   ffetype_set_ams (type,
11325                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11326                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11327   ffetype_set_star (base_type,
11328                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11329                     type);
11330   ffetype_set_kind (base_type, 1, type);
11331   ffecom_typesize_integer1_ = ffetype_size (type);
11332   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11333
11334   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11335     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11336   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11337                         t));
11338
11339   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11340     = t = make_signed_type (CHAR_TYPE_SIZE);
11341   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11342                         t));
11343   type = ffetype_new ();
11344   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11345                     type);
11346   ffetype_set_ams (type,
11347                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11348                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11349   ffetype_set_star (base_type,
11350                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11351                     type);
11352   ffetype_set_kind (base_type, 3, type);
11353   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11354
11355   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11356     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11357   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11358                         t));
11359
11360   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11361     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11362   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11363                         t));
11364   type = ffetype_new ();
11365   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11366                     type);
11367   ffetype_set_ams (type,
11368                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11369                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11370   ffetype_set_star (base_type,
11371                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11372                     type);
11373   ffetype_set_kind (base_type, 6, type);
11374   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11375
11376   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11377     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11378   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11379                         t));
11380
11381   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11382     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11383   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11384                         t));
11385   type = ffetype_new ();
11386   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11387                     type);
11388   ffetype_set_ams (type,
11389                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11390                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11391   ffetype_set_star (base_type,
11392                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11393                     type);
11394   ffetype_set_kind (base_type, 2, type);
11395   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11396
11397   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11398     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11399   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11400                         t));
11401
11402 #if 0
11403   if (ffe_is_do_internal_checks ()
11404       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11405       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11406       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11407       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11408     {
11409       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11410                LONG_TYPE_SIZE);
11411     }
11412 #endif
11413
11414   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11415     = t = make_signed_type (FLOAT_TYPE_SIZE);
11416   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11417                         t));
11418   type = ffetype_new ();
11419   base_type = type;
11420   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11421                     type);
11422   ffetype_set_ams (type,
11423                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11424                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11425   ffetype_set_star (base_type,
11426                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11427                     type);
11428   ffetype_set_kind (base_type, 1, type);
11429   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11430
11431   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11432     = t = make_signed_type (CHAR_TYPE_SIZE);
11433   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11434                         t));
11435   type = ffetype_new ();
11436   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11437                     type);
11438   ffetype_set_ams (type,
11439                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11440                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11441   ffetype_set_star (base_type,
11442                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11443                     type);
11444   ffetype_set_kind (base_type, 3, type);
11445   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11446
11447   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11448     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11449   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11450                         t));
11451   type = ffetype_new ();
11452   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11453                     type);
11454   ffetype_set_ams (type,
11455                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11456                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11457   ffetype_set_star (base_type,
11458                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11459                     type);
11460   ffetype_set_kind (base_type, 6, type);
11461   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11462
11463   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11464     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11465   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11466                         t));
11467   type = ffetype_new ();
11468   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11469                     type);
11470   ffetype_set_ams (type,
11471                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11472                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11473   ffetype_set_star (base_type,
11474                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11475                     type);
11476   ffetype_set_kind (base_type, 2, type);
11477   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11478
11479   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11480     = t = make_node (REAL_TYPE);
11481   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11482   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11483                         t));
11484   layout_type (t);
11485   type = ffetype_new ();
11486   base_type = type;
11487   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11488                     type);
11489   ffetype_set_ams (type,
11490                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11491                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11492   ffetype_set_star (base_type,
11493                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11494                     type);
11495   ffetype_set_kind (base_type, 1, type);
11496   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11497     = FFETARGET_f2cTYREAL;
11498   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11499
11500   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11501     = t = make_node (REAL_TYPE);
11502   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11503   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11504                         t));
11505   layout_type (t);
11506   type = ffetype_new ();
11507   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11508                     type);
11509   ffetype_set_ams (type,
11510                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11511                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11512   ffetype_set_star (base_type,
11513                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11514                     type);
11515   ffetype_set_kind (base_type, 2, type);
11516   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11517     = FFETARGET_f2cTYDREAL;
11518   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11519
11520   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11521     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11522   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11523                         t));
11524   type = ffetype_new ();
11525   base_type = type;
11526   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11527                     type);
11528   ffetype_set_ams (type,
11529                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11530                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11531   ffetype_set_star (base_type,
11532                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11533                     type);
11534   ffetype_set_kind (base_type, 1, type);
11535   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11536     = FFETARGET_f2cTYCOMPLEX;
11537   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11538
11539   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11540     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11541   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11542                         t));
11543   type = ffetype_new ();
11544   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11545                     type);
11546   ffetype_set_ams (type,
11547                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11548                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11549   ffetype_set_star (base_type,
11550                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11551                     type);
11552   ffetype_set_kind (base_type, 2,
11553                     type);
11554   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11555     = FFETARGET_f2cTYDCOMPLEX;
11556   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11557
11558   /* Make function and ptr-to-function types for non-CHARACTER types. */
11559
11560   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11561     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11562       {
11563         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11564           {
11565             if (i == FFEINFO_basictypeINTEGER)
11566               {
11567                 /* Figure out the smallest INTEGER type that can hold
11568                    a pointer on this machine. */
11569                 if (GET_MODE_SIZE (TYPE_MODE (t))
11570                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11571                   {
11572                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11573                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11574                             > GET_MODE_SIZE (TYPE_MODE (t))))
11575                       ffecom_pointer_kind_ = j;
11576                   }
11577               }
11578             else if (i == FFEINFO_basictypeCOMPLEX)
11579               t = void_type_node;
11580             /* For f2c compatibility, REAL functions are really
11581                implemented as DOUBLE PRECISION.  */
11582             else if ((i == FFEINFO_basictypeREAL)
11583                      && (j == FFEINFO_kindtypeREAL1))
11584               t = ffecom_tree_type
11585                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11586
11587             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11588                                                                   NULL_TREE);
11589             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11590           }
11591       }
11592
11593   /* Set up pointer types.  */
11594
11595   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11596     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11597   else if (0 && ffe_is_do_internal_checks ())
11598     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11599   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11600                                   FFEINFO_kindtypeINTEGERDEFAULT),
11601                     7,
11602                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11603                                   ffecom_pointer_kind_));
11604
11605   if (ffe_is_ugly_assign ())
11606     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11607   else
11608     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11609   if (0 && ffe_is_do_internal_checks ())
11610     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11611
11612   ffecom_integer_type_node
11613     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11614   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11615                                       integer_zero_node);
11616   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11617                                      integer_one_node);
11618
11619   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11620      Turns out that by TYLONG, runtime/libI77/lio.h really means
11621      "whatever size an ftnint is".  For consistency and sanity,
11622      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11623      all are INTEGER, which we also make out of whatever back-end
11624      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11625      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11626      accommodate machines like the Alpha.  Note that this suggests
11627      f2c and libf2c are missing a distinction perhaps needed on
11628      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11629
11630   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11631                             FFETARGET_f2cTYLONG);
11632   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11633                             FFETARGET_f2cTYSHORT);
11634   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11635                             FFETARGET_f2cTYINT1);
11636   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11637                             FFETARGET_f2cTYQUAD);
11638   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11639                             FFETARGET_f2cTYLOGICAL);
11640   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11641                             FFETARGET_f2cTYLOGICAL2);
11642   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11643                             FFETARGET_f2cTYLOGICAL1);
11644   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11645   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11646                             FFETARGET_f2cTYQUAD);
11647
11648   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11649      loop.  CHARACTER items are built as arrays of unsigned char.  */
11650
11651   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11652     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11653   type = ffetype_new ();
11654   base_type = type;
11655   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11656                     FFEINFO_kindtypeCHARACTER1,
11657                     type);
11658   ffetype_set_ams (type,
11659                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11660                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11661   ffetype_set_kind (base_type, 1, type);
11662   assert (ffetype_size (type)
11663           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11664
11665   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11666     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11667   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11668     [FFEINFO_kindtypeCHARACTER1]
11669     = ffecom_tree_ptr_to_fun_type_void;
11670   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11671     = FFETARGET_f2cTYCHAR;
11672
11673   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11674     = 0;
11675
11676   /* Make multi-return-value type and fields. */
11677
11678   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11679
11680   field = NULL_TREE;
11681
11682   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11683     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11684       {
11685         char name[30];
11686
11687         if (ffecom_tree_type[i][j] == NULL_TREE)
11688           continue;             /* Not supported. */
11689         sprintf (&name[0], "bt_%s_kt_%s",
11690                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11691                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11692         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11693                                                  get_identifier (name),
11694                                                  ffecom_tree_type[i][j]);
11695         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11696           = ffecom_multi_type_node_;
11697         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11698         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11699         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11700         field = ffecom_multi_fields_[i][j];
11701       }
11702
11703   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11704   layout_type (ffecom_multi_type_node_);
11705
11706   /* Subroutines usually return integer because they might have alternate
11707      returns. */
11708
11709   ffecom_tree_subr_type
11710     = build_function_type (integer_type_node, NULL_TREE);
11711   ffecom_tree_ptr_to_subr_type
11712     = build_pointer_type (ffecom_tree_subr_type);
11713   ffecom_tree_blockdata_type
11714     = build_function_type (void_type_node, NULL_TREE);
11715
11716   builtin_function ("__builtin_sqrtf", float_ftype_float,
11717                     BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf");
11718   builtin_function ("__builtin_sqrt", double_ftype_double,
11719                     BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt");
11720   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11721                     BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl");
11722   builtin_function ("__builtin_sinf", float_ftype_float,
11723                     BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf");
11724   builtin_function ("__builtin_sin", double_ftype_double,
11725                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11726   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11727                     BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl");
11728   builtin_function ("__builtin_cosf", float_ftype_float,
11729                     BUILT_IN_COSF, BUILT_IN_NORMAL, "cosf");
11730   builtin_function ("__builtin_cos", double_ftype_double,
11731                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11732   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11733                     BUILT_IN_COSL, BUILT_IN_NORMAL, "cosl");
11734
11735   pedantic_lvalues = FALSE;
11736
11737   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11738                          FFECOM_f2cINTEGER,
11739                          "integer");
11740   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11741                          FFECOM_f2cADDRESS,
11742                          "address");
11743   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11744                          FFECOM_f2cREAL,
11745                          "real");
11746   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11747                          FFECOM_f2cDOUBLEREAL,
11748                          "doublereal");
11749   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11750                          FFECOM_f2cCOMPLEX,
11751                          "complex");
11752   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11753                          FFECOM_f2cDOUBLECOMPLEX,
11754                          "doublecomplex");
11755   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11756                          FFECOM_f2cLONGINT,
11757                          "longint");
11758   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11759                          FFECOM_f2cLOGICAL,
11760                          "logical");
11761   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11762                          FFECOM_f2cFLAG,
11763                          "flag");
11764   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11765                          FFECOM_f2cFTNLEN,
11766                          "ftnlen");
11767   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11768                          FFECOM_f2cFTNINT,
11769                          "ftnint");
11770
11771   ffecom_f2c_ftnlen_zero_node
11772     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11773
11774   ffecom_f2c_ftnlen_one_node
11775     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11776
11777   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11778   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11779
11780   ffecom_f2c_ptr_to_ftnlen_type_node
11781     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11782
11783   ffecom_f2c_ptr_to_ftnint_type_node
11784     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11785
11786   ffecom_f2c_ptr_to_integer_type_node
11787     = build_pointer_type (ffecom_f2c_integer_type_node);
11788
11789   ffecom_f2c_ptr_to_real_type_node
11790     = build_pointer_type (ffecom_f2c_real_type_node);
11791
11792   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11793   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11794   {
11795     REAL_VALUE_TYPE point_5;
11796
11797 #ifdef REAL_ARITHMETIC
11798     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
11799 #else
11800     point_5 = .5;
11801 #endif
11802     ffecom_float_half_ = build_real (float_type_node, point_5);
11803     ffecom_double_half_ = build_real (double_type_node, point_5);
11804   }
11805
11806   /* Do "extern int xargc;".  */
11807
11808   ffecom_tree_xargc_ = build_decl (VAR_DECL,
11809                                    get_identifier ("f__xargc"),
11810                                    integer_type_node);
11811   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
11812   TREE_STATIC (ffecom_tree_xargc_) = 1;
11813   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
11814   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
11815   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
11816
11817 #if 0   /* This is being fixed, and seems to be working now. */
11818   if ((FLOAT_TYPE_SIZE != 32)
11819       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
11820     {
11821       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11822                (int) FLOAT_TYPE_SIZE);
11823       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11824           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
11825       warning ("properly unless they all are 32 bits wide");
11826       warning ("Please keep this in mind before you report bugs.");
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           kind = _(ffeinfo_kind_message (ffesymbol_kind (s)));
13673         }
13674       else
13675         {
13676           s = ffecom_nested_entry_;
13677           kind = _("In statement function");
13678         }
13679     }
13680
13681   if ((last_g != g) || (last_s != s))
13682     {
13683       if (file)
13684         fprintf (stderr, "%s: ", file);
13685
13686       if (s == NULL)
13687         fprintf (stderr, _("Outside of any program unit:\n"));
13688       else
13689         {
13690           const char *name = ffesymbol_text (s);
13691
13692           fprintf (stderr, "%s `%s':\n", kind, name);
13693         }
13694
13695       last_g = g;
13696       last_s = s;
13697     }
13698 }
13699
13700 /* Similar to `lookup_name' but look only at current binding level.  */
13701
13702 static tree
13703 lookup_name_current_level (tree name)
13704 {
13705   register tree t;
13706
13707   if (current_binding_level == global_binding_level)
13708     return IDENTIFIER_GLOBAL_VALUE (name);
13709
13710   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
13711     return 0;
13712
13713   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
13714     if (DECL_NAME (t) == name)
13715       break;
13716
13717   return t;
13718 }
13719
13720 /* Create a new `struct binding_level'.  */
13721
13722 static struct binding_level *
13723 make_binding_level ()
13724 {
13725   /* NOSTRICT */
13726   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
13727 }
13728
13729 /* Save and restore the variables in this file and elsewhere
13730    that keep track of the progress of compilation of the current function.
13731    Used for nested functions.  */
13732
13733 struct f_function
13734 {
13735   struct f_function *next;
13736   tree named_labels;
13737   tree shadowed_labels;
13738   struct binding_level *binding_level;
13739 };
13740
13741 struct f_function *f_function_chain;
13742
13743 /* Restore the variables used during compilation of a C function.  */
13744
13745 static void
13746 pop_f_function_context ()
13747 {
13748   struct f_function *p = f_function_chain;
13749   tree link;
13750
13751   /* Bring back all the labels that were shadowed.  */
13752   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
13753     if (DECL_NAME (TREE_VALUE (link)) != 0)
13754       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
13755         = TREE_VALUE (link);
13756
13757   if (current_function_decl != error_mark_node
13758       && DECL_SAVED_INSNS (current_function_decl) == 0)
13759     {
13760       /* Stop pointing to the local nodes about to be freed.  */
13761       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13762          function definition.  */
13763       DECL_INITIAL (current_function_decl) = error_mark_node;
13764       DECL_ARGUMENTS (current_function_decl) = 0;
13765     }
13766
13767   pop_function_context ();
13768
13769   f_function_chain = p->next;
13770
13771   named_labels = p->named_labels;
13772   shadowed_labels = p->shadowed_labels;
13773   current_binding_level = p->binding_level;
13774
13775   free (p);
13776 }
13777
13778 /* Save and reinitialize the variables
13779    used during compilation of a C function.  */
13780
13781 static void
13782 push_f_function_context ()
13783 {
13784   struct f_function *p
13785   = (struct f_function *) xmalloc (sizeof (struct f_function));
13786
13787   push_function_context ();
13788
13789   p->next = f_function_chain;
13790   f_function_chain = p;
13791
13792   p->named_labels = named_labels;
13793   p->shadowed_labels = shadowed_labels;
13794   p->binding_level = current_binding_level;
13795 }
13796
13797 static void
13798 push_parm_decl (tree parm)
13799 {
13800   int old_immediate_size_expand = immediate_size_expand;
13801
13802   /* Don't try computing parm sizes now -- wait till fn is called.  */
13803
13804   immediate_size_expand = 0;
13805
13806   /* Fill in arg stuff.  */
13807
13808   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
13809   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
13810   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
13811
13812   parm = pushdecl (parm);
13813
13814   immediate_size_expand = old_immediate_size_expand;
13815
13816   finish_decl (parm, NULL_TREE, FALSE);
13817 }
13818
13819 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
13820
13821 static tree
13822 pushdecl_top_level (x)
13823      tree x;
13824 {
13825   register tree t;
13826   register struct binding_level *b = current_binding_level;
13827   register tree f = current_function_decl;
13828
13829   current_binding_level = global_binding_level;
13830   current_function_decl = NULL_TREE;
13831   t = pushdecl (x);
13832   current_binding_level = b;
13833   current_function_decl = f;
13834   return t;
13835 }
13836
13837 /* Store the list of declarations of the current level.
13838    This is done for the parameter declarations of a function being defined,
13839    after they are modified in the light of any missing parameters.  */
13840
13841 static tree
13842 storedecls (decls)
13843      tree decls;
13844 {
13845   return current_binding_level->names = decls;
13846 }
13847
13848 /* Store the parameter declarations into the current function declaration.
13849    This is called after parsing the parameter declarations, before
13850    digesting the body of the function.
13851
13852    For an old-style definition, modify the function's type
13853    to specify at least the number of arguments.  */
13854
13855 static void
13856 store_parm_decls (int is_main_program UNUSED)
13857 {
13858   register tree fndecl = current_function_decl;
13859
13860   if (fndecl == error_mark_node)
13861     return;
13862
13863   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
13864   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
13865
13866   /* Initialize the RTL code for the function.  */
13867
13868   init_function_start (fndecl, input_filename, lineno);
13869
13870   /* Set up parameters and prepare for return, for the function.  */
13871
13872   expand_function_start (fndecl, 0);
13873 }
13874
13875 static tree
13876 start_decl (tree decl, bool is_top_level)
13877 {
13878   register tree tem;
13879   bool at_top_level = (current_binding_level == global_binding_level);
13880   bool top_level = is_top_level || at_top_level;
13881
13882   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13883      level anyway.  */
13884   assert (!is_top_level || !at_top_level);
13885
13886   if (DECL_INITIAL (decl) != NULL_TREE)
13887     {
13888       assert (DECL_INITIAL (decl) == error_mark_node);
13889       assert (!DECL_EXTERNAL (decl));
13890     }
13891   else if (top_level)
13892     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
13893
13894   /* For Fortran, we by default put things in .common when possible.  */
13895   DECL_COMMON (decl) = 1;
13896
13897   /* Add this decl to the current binding level. TEM may equal DECL or it may
13898      be a previous decl of the same name.  */
13899   if (is_top_level)
13900     tem = pushdecl_top_level (decl);
13901   else
13902     tem = pushdecl (decl);
13903
13904   /* For a local variable, define the RTL now.  */
13905   if (!top_level
13906   /* But not if this is a duplicate decl and we preserved the rtl from the
13907      previous one (which may or may not happen).  */
13908       && !DECL_RTL_SET_P (tem))
13909     {
13910       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
13911         expand_decl (tem);
13912       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
13913                && DECL_INITIAL (tem) != 0)
13914         expand_decl (tem);
13915     }
13916
13917   return tem;
13918 }
13919
13920 /* Create the FUNCTION_DECL for a function definition.
13921    DECLSPECS and DECLARATOR are the parts of the declaration;
13922    they describe the function's name and the type it returns,
13923    but twisted together in a fashion that parallels the syntax of C.
13924
13925    This function creates a binding context for the function body
13926    as well as setting up the FUNCTION_DECL in current_function_decl.
13927
13928    Returns 1 on success.  If the DECLARATOR is not suitable for a function
13929    (it defines a datum instead), we return 0, which tells
13930    yyparse to report a parse error.
13931
13932    NESTED is nonzero for a function nested within another function.  */
13933
13934 static void
13935 start_function (tree name, tree type, int nested, int public)
13936 {
13937   tree decl1;
13938   tree restype;
13939   int old_immediate_size_expand = immediate_size_expand;
13940
13941   named_labels = 0;
13942   shadowed_labels = 0;
13943
13944   /* Don't expand any sizes in the return type of the function.  */
13945   immediate_size_expand = 0;
13946
13947   if (nested)
13948     {
13949       assert (!public);
13950       assert (current_function_decl != NULL_TREE);
13951       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
13952     }
13953   else
13954     {
13955       assert (current_function_decl == NULL_TREE);
13956     }
13957
13958   if (TREE_CODE (type) == ERROR_MARK)
13959     decl1 = current_function_decl = error_mark_node;
13960   else
13961     {
13962       decl1 = build_decl (FUNCTION_DECL,
13963                           name,
13964                           type);
13965       TREE_PUBLIC (decl1) = public ? 1 : 0;
13966       if (nested)
13967         DECL_INLINE (decl1) = 1;
13968       TREE_STATIC (decl1) = 1;
13969       DECL_EXTERNAL (decl1) = 0;
13970
13971       announce_function (decl1);
13972
13973       /* Make the init_value nonzero so pushdecl knows this is not tentative.
13974          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
13975       DECL_INITIAL (decl1) = error_mark_node;
13976
13977       /* Record the decl so that the function name is defined. If we already have
13978          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
13979
13980       current_function_decl = pushdecl (decl1);
13981     }
13982
13983   if (!nested)
13984     ffecom_outer_function_decl_ = current_function_decl;
13985
13986   pushlevel (0);
13987   current_binding_level->prep_state = 2;
13988
13989   if (TREE_CODE (current_function_decl) != ERROR_MARK)
13990     {
13991       make_decl_rtl (current_function_decl, NULL);
13992
13993       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
13994       DECL_RESULT (current_function_decl)
13995         = build_decl (RESULT_DECL, NULL_TREE, restype);
13996     }
13997
13998   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
13999     TREE_ADDRESSABLE (current_function_decl) = 1;
14000
14001   immediate_size_expand = old_immediate_size_expand;
14002 }
14003 \f
14004 /* Here are the public functions the GNU back end needs.  */
14005
14006 tree
14007 convert (type, expr)
14008      tree type, expr;
14009 {
14010   register tree e = expr;
14011   register enum tree_code code = TREE_CODE (type);
14012
14013   if (type == TREE_TYPE (e)
14014       || TREE_CODE (e) == ERROR_MARK)
14015     return e;
14016   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14017     return fold (build1 (NOP_EXPR, type, e));
14018   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14019       || code == ERROR_MARK)
14020     return error_mark_node;
14021   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14022     {
14023       assert ("void value not ignored as it ought to be" == NULL);
14024       return error_mark_node;
14025     }
14026   if (code == VOID_TYPE)
14027     return build1 (CONVERT_EXPR, type, e);
14028   if ((code != RECORD_TYPE)
14029       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14030     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14031                   e);
14032   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14033     return fold (convert_to_integer (type, e));
14034   if (code == POINTER_TYPE)
14035     return fold (convert_to_pointer (type, e));
14036   if (code == REAL_TYPE)
14037     return fold (convert_to_real (type, e));
14038   if (code == COMPLEX_TYPE)
14039     return fold (convert_to_complex (type, e));
14040   if (code == RECORD_TYPE)
14041     return fold (ffecom_convert_to_complex_ (type, e));
14042
14043   assert ("conversion to non-scalar type requested" == NULL);
14044   return error_mark_node;
14045 }
14046
14047 /* integrate_decl_tree calls this function, but since we don't use the
14048    DECL_LANG_SPECIFIC field, this is a no-op.  */
14049
14050 void
14051 copy_lang_decl (node)
14052      tree node UNUSED;
14053 {
14054 }
14055
14056 /* Return the list of declarations of the current level.
14057    Note that this list is in reverse order unless/until
14058    you nreverse it; and when you do nreverse it, you must
14059    store the result back using `storedecls' or you will lose.  */
14060
14061 tree
14062 getdecls ()
14063 {
14064   return current_binding_level->names;
14065 }
14066
14067 /* Nonzero if we are currently in the global binding level.  */
14068
14069 int
14070 global_bindings_p ()
14071 {
14072   return current_binding_level == global_binding_level;
14073 }
14074
14075 /* Print an error message for invalid use of an incomplete type.
14076    VALUE is the expression that was used (or 0 if that isn't known)
14077    and TYPE is the type that was invalid.  */
14078
14079 void
14080 incomplete_type_error (value, type)
14081      tree value UNUSED;
14082      tree type;
14083 {
14084   if (TREE_CODE (type) == ERROR_MARK)
14085     return;
14086
14087   assert ("incomplete type?!?" == NULL);
14088 }
14089
14090 /* Mark ARG for GC.  */
14091 static void
14092 mark_binding_level (void *arg)
14093 {
14094   struct binding_level *level = *(struct binding_level **) arg;
14095
14096   while (level)
14097     {
14098       ggc_mark_tree (level->names);
14099       ggc_mark_tree (level->blocks);
14100       ggc_mark_tree (level->this_block);
14101       level = level->level_chain;
14102     }
14103 }
14104
14105 static void
14106 ffecom_init_decl_processing ()
14107 {
14108   static tree *const tree_roots[] = {
14109     &current_function_decl,
14110     &string_type_node,
14111     &ffecom_tree_fun_type_void,
14112     &ffecom_integer_zero_node,
14113     &ffecom_integer_one_node,
14114     &ffecom_tree_subr_type,
14115     &ffecom_tree_ptr_to_subr_type,
14116     &ffecom_tree_blockdata_type,
14117     &ffecom_tree_xargc_,
14118     &ffecom_f2c_integer_type_node,
14119     &ffecom_f2c_ptr_to_integer_type_node,
14120     &ffecom_f2c_address_type_node,
14121     &ffecom_f2c_real_type_node,
14122     &ffecom_f2c_ptr_to_real_type_node,
14123     &ffecom_f2c_doublereal_type_node,
14124     &ffecom_f2c_complex_type_node,
14125     &ffecom_f2c_doublecomplex_type_node,
14126     &ffecom_f2c_longint_type_node,
14127     &ffecom_f2c_logical_type_node,
14128     &ffecom_f2c_flag_type_node,
14129     &ffecom_f2c_ftnlen_type_node,
14130     &ffecom_f2c_ftnlen_zero_node,
14131     &ffecom_f2c_ftnlen_one_node,
14132     &ffecom_f2c_ftnlen_two_node,
14133     &ffecom_f2c_ptr_to_ftnlen_type_node,
14134     &ffecom_f2c_ftnint_type_node,
14135     &ffecom_f2c_ptr_to_ftnint_type_node,
14136     &ffecom_outer_function_decl_,
14137     &ffecom_previous_function_decl_,
14138     &ffecom_which_entrypoint_decl_,
14139     &ffecom_float_zero_,
14140     &ffecom_float_half_,
14141     &ffecom_double_zero_,
14142     &ffecom_double_half_,
14143     &ffecom_func_result_,
14144     &ffecom_func_length_,
14145     &ffecom_multi_type_node_,
14146     &ffecom_multi_retval_,
14147     &named_labels,
14148     &shadowed_labels
14149   };
14150   size_t i;
14151
14152   malloc_init ();
14153
14154   /* Record our roots.  */
14155   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14156     ggc_add_tree_root (tree_roots[i], 1);
14157   ggc_add_tree_root (&ffecom_tree_type[0][0],
14158                      FFEINFO_basictype*FFEINFO_kindtype);
14159   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14160                      FFEINFO_basictype*FFEINFO_kindtype);
14161   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14162                      FFEINFO_basictype*FFEINFO_kindtype);
14163   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14164   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14165                 mark_binding_level);
14166   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14167                 mark_binding_level);
14168   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14169
14170   ffe_init_0 ();
14171 }
14172
14173 /* Delete the node BLOCK from the current binding level.
14174    This is used for the block inside a stmt expr ({...})
14175    so that the block can be reinserted where appropriate.  */
14176
14177 static void
14178 delete_block (block)
14179      tree block;
14180 {
14181   tree t;
14182   if (current_binding_level->blocks == block)
14183     current_binding_level->blocks = TREE_CHAIN (block);
14184   for (t = current_binding_level->blocks; t;)
14185     {
14186       if (TREE_CHAIN (t) == block)
14187         TREE_CHAIN (t) = TREE_CHAIN (block);
14188       else
14189         t = TREE_CHAIN (t);
14190     }
14191   TREE_CHAIN (block) = NULL;
14192   /* Clear TREE_USED which is always set by poplevel.
14193      The flag is set again if insert_block is called.  */
14194   TREE_USED (block) = 0;
14195 }
14196
14197 void
14198 insert_block (block)
14199      tree block;
14200 {
14201   TREE_USED (block) = 1;
14202   current_binding_level->blocks
14203     = chainon (current_binding_level->blocks, block);
14204 }
14205
14206 /* Each front end provides its own.  */
14207 static const char *ffe_init PARAMS ((const char *));
14208 static void ffe_finish PARAMS ((void));
14209 static void ffe_init_options PARAMS ((void));
14210 static void ffe_print_identifier PARAMS ((FILE *, tree, int));
14211
14212 #undef  LANG_HOOKS_NAME
14213 #define LANG_HOOKS_NAME                 "GNU F77"
14214 #undef  LANG_HOOKS_INIT
14215 #define LANG_HOOKS_INIT                 ffe_init
14216 #undef  LANG_HOOKS_FINISH
14217 #define LANG_HOOKS_FINISH               ffe_finish
14218 #undef  LANG_HOOKS_INIT_OPTIONS
14219 #define LANG_HOOKS_INIT_OPTIONS         ffe_init_options
14220 #undef  LANG_HOOKS_DECODE_OPTION
14221 #define LANG_HOOKS_DECODE_OPTION        ffe_decode_option
14222 #undef  LANG_HOOKS_PRINT_IDENTIFIER
14223 #define LANG_HOOKS_PRINT_IDENTIFIER     ffe_print_identifier
14224
14225 /* We do not wish to use alias-set based aliasing at all.  Used in the
14226    extreme (every object with its own set, with equivalences recorded) it
14227    might be helpful, but there are problems when it comes to inlining.  We
14228    get on ok with flag_argument_noalias, and alias-set aliasing does
14229    currently limit how stack slots can be reused, which is a lose.  */
14230 #undef LANG_HOOKS_GET_ALIAS_SET
14231 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14232
14233 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
14234
14235 static const char *
14236 ffe_init (filename)
14237      const char *filename;
14238 {
14239   /* Open input file.  */
14240   if (filename == 0 || !strcmp (filename, "-"))
14241     {
14242       finput = stdin;
14243       filename = "stdin";
14244     }
14245   else
14246     finput = fopen (filename, "r");
14247   if (finput == 0)
14248     fatal_io_error ("can't open %s", filename);
14249
14250 #ifdef IO_BUFFER_SIZE
14251   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14252 #endif
14253
14254   ffecom_init_decl_processing ();
14255   decl_printable_name = lang_printable_name;
14256   print_error_function = lang_print_error_function;
14257
14258   /* If the file is output from cpp, it should contain a first line
14259      `# 1 "real-filename"', and the current design of gcc (toplev.c
14260      in particular and the way it sets up information relied on by
14261      INCLUDE) requires that we read this now, and store the
14262      "real-filename" info in master_input_filename.  Ask the lexer
14263      to try doing this.  */
14264   ffelex_hash_kludge (finput);
14265
14266   /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14267      return the new file name.  */
14268   if (main_input_filename)
14269     filename = main_input_filename;
14270
14271   return filename;
14272 }
14273
14274 static void
14275 ffe_finish ()
14276 {
14277   ffe_terminate_0 ();
14278
14279   if (ffe_is_ffedebug ())
14280     malloc_pool_display (malloc_pool_image ());
14281
14282   fclose (finput);
14283 }
14284
14285 static void
14286 ffe_init_options ()
14287 {
14288   /* Set default options for Fortran.  */
14289   flag_move_all_movables = 1;
14290   flag_reduce_all_givs = 1;
14291   flag_argument_noalias = 2;
14292   flag_merge_constants = 2;
14293   flag_errno_math = 0;
14294   flag_complex_divide_method = 1;
14295 }
14296
14297 int
14298 mark_addressable (exp)
14299      tree exp;
14300 {
14301   register tree x = exp;
14302   while (1)
14303     switch (TREE_CODE (x))
14304       {
14305       case ADDR_EXPR:
14306       case COMPONENT_REF:
14307       case ARRAY_REF:
14308         x = TREE_OPERAND (x, 0);
14309         break;
14310
14311       case CONSTRUCTOR:
14312         TREE_ADDRESSABLE (x) = 1;
14313         return 1;
14314
14315       case VAR_DECL:
14316       case CONST_DECL:
14317       case PARM_DECL:
14318       case RESULT_DECL:
14319         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14320             && DECL_NONLOCAL (x))
14321           {
14322             if (TREE_PUBLIC (x))
14323               {
14324                 assert ("address of global register var requested" == NULL);
14325                 return 0;
14326               }
14327             assert ("address of register variable requested" == NULL);
14328           }
14329         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14330           {
14331             if (TREE_PUBLIC (x))
14332               {
14333                 assert ("address of global register var requested" == NULL);
14334                 return 0;
14335               }
14336             assert ("address of register var requested" == NULL);
14337           }
14338         put_var_into_stack (x);
14339
14340         /* drops in */
14341       case FUNCTION_DECL:
14342         TREE_ADDRESSABLE (x) = 1;
14343 #if 0                           /* poplevel deals with this now.  */
14344         if (DECL_CONTEXT (x) == 0)
14345           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14346 #endif
14347
14348       default:
14349         return 1;
14350       }
14351 }
14352
14353 /* If DECL has a cleanup, build and return that cleanup here.
14354    This is a callback called by expand_expr.  */
14355
14356 tree
14357 maybe_build_cleanup (decl)
14358      tree decl UNUSED;
14359 {
14360   /* There are no cleanups in Fortran.  */
14361   return NULL_TREE;
14362 }
14363
14364 /* Exit a binding level.
14365    Pop the level off, and restore the state of the identifier-decl mappings
14366    that were in effect when this level was entered.
14367
14368    If KEEP is nonzero, this level had explicit declarations, so
14369    and create a "block" (a BLOCK node) for the level
14370    to record its declarations and subblocks for symbol table output.
14371
14372    If FUNCTIONBODY is nonzero, this level is the body of a function,
14373    so create a block as if KEEP were set and also clear out all
14374    label names.
14375
14376    If REVERSE is nonzero, reverse the order of decls before putting
14377    them into the BLOCK.  */
14378
14379 tree
14380 poplevel (keep, reverse, functionbody)
14381      int keep;
14382      int reverse;
14383      int functionbody;
14384 {
14385   register tree link;
14386   /* The chain of decls was accumulated in reverse order.
14387      Put it into forward order, just for cleanliness.  */
14388   tree decls;
14389   tree subblocks = current_binding_level->blocks;
14390   tree block = 0;
14391   tree decl;
14392   int block_previously_created;
14393
14394   /* Get the decls in the order they were written.
14395      Usually current_binding_level->names is in reverse order.
14396      But parameter decls were previously put in forward order.  */
14397
14398   if (reverse)
14399     current_binding_level->names
14400       = decls = nreverse (current_binding_level->names);
14401   else
14402     decls = current_binding_level->names;
14403
14404   /* Output any nested inline functions within this block
14405      if they weren't already output.  */
14406
14407   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14408     if (TREE_CODE (decl) == FUNCTION_DECL
14409         && ! TREE_ASM_WRITTEN (decl)
14410         && DECL_INITIAL (decl) != 0
14411         && TREE_ADDRESSABLE (decl))
14412       {
14413         /* If this decl was copied from a file-scope decl
14414            on account of a block-scope extern decl,
14415            propagate TREE_ADDRESSABLE to the file-scope decl.
14416
14417            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14418            true, since then the decl goes through save_for_inline_copying.  */
14419         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14420             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14421           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14422         else if (DECL_SAVED_INSNS (decl) != 0)
14423           {
14424             push_function_context ();
14425             output_inline_function (decl);
14426             pop_function_context ();
14427           }
14428       }
14429
14430   /* If there were any declarations or structure tags in that level,
14431      or if this level is a function body,
14432      create a BLOCK to record them for the life of this function.  */
14433
14434   block = 0;
14435   block_previously_created = (current_binding_level->this_block != 0);
14436   if (block_previously_created)
14437     block = current_binding_level->this_block;
14438   else if (keep || functionbody)
14439     block = make_node (BLOCK);
14440   if (block != 0)
14441     {
14442       BLOCK_VARS (block) = decls;
14443       BLOCK_SUBBLOCKS (block) = subblocks;
14444     }
14445
14446   /* In each subblock, record that this is its superior.  */
14447
14448   for (link = subblocks; link; link = TREE_CHAIN (link))
14449     BLOCK_SUPERCONTEXT (link) = block;
14450
14451   /* Clear out the meanings of the local variables of this level.  */
14452
14453   for (link = decls; link; link = TREE_CHAIN (link))
14454     {
14455       if (DECL_NAME (link) != 0)
14456         {
14457           /* If the ident. was used or addressed via a local extern decl,
14458              don't forget that fact.  */
14459           if (DECL_EXTERNAL (link))
14460             {
14461               if (TREE_USED (link))
14462                 TREE_USED (DECL_NAME (link)) = 1;
14463               if (TREE_ADDRESSABLE (link))
14464                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14465             }
14466           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14467         }
14468     }
14469
14470   /* If the level being exited is the top level of a function,
14471      check over all the labels, and clear out the current
14472      (function local) meanings of their names.  */
14473
14474   if (functionbody)
14475     {
14476       /* If this is the top level block of a function,
14477          the vars are the function's parameters.
14478          Don't leave them in the BLOCK because they are
14479          found in the FUNCTION_DECL instead.  */
14480
14481       BLOCK_VARS (block) = 0;
14482     }
14483
14484   /* Pop the current level, and free the structure for reuse.  */
14485
14486   {
14487     register struct binding_level *level = current_binding_level;
14488     current_binding_level = current_binding_level->level_chain;
14489
14490     level->level_chain = free_binding_level;
14491     free_binding_level = level;
14492   }
14493
14494   /* Dispose of the block that we just made inside some higher level.  */
14495   if (functionbody
14496       && current_function_decl != error_mark_node)
14497     DECL_INITIAL (current_function_decl) = block;
14498   else if (block)
14499     {
14500       if (!block_previously_created)
14501         current_binding_level->blocks
14502           = chainon (current_binding_level->blocks, block);
14503     }
14504   /* If we did not make a block for the level just exited,
14505      any blocks made for inner levels
14506      (since they cannot be recorded as subblocks in that level)
14507      must be carried forward so they will later become subblocks
14508      of something else.  */
14509   else if (subblocks)
14510     current_binding_level->blocks
14511       = chainon (current_binding_level->blocks, subblocks);
14512
14513   if (block)
14514     TREE_USED (block) = 1;
14515   return block;
14516 }
14517
14518 static void
14519 ffe_print_identifier (file, node, indent)
14520      FILE *file;
14521      tree node;
14522      int indent;
14523 {
14524   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14525   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14526 }
14527
14528 /* Record a decl-node X as belonging to the current lexical scope.
14529    Check for errors (such as an incompatible declaration for the same
14530    name already seen in the same scope).
14531
14532    Returns either X or an old decl for the same name.
14533    If an old decl is returned, it may have been smashed
14534    to agree with what X says.  */
14535
14536 tree
14537 pushdecl (x)
14538      tree x;
14539 {
14540   register tree t;
14541   register tree name = DECL_NAME (x);
14542   register struct binding_level *b = current_binding_level;
14543
14544   if ((TREE_CODE (x) == FUNCTION_DECL)
14545       && (DECL_INITIAL (x) == 0)
14546       && DECL_EXTERNAL (x))
14547     DECL_CONTEXT (x) = NULL_TREE;
14548   else
14549     DECL_CONTEXT (x) = current_function_decl;
14550
14551   if (name)
14552     {
14553       if (IDENTIFIER_INVENTED (name))
14554         {
14555           DECL_ARTIFICIAL (x) = 1;
14556           DECL_IN_SYSTEM_HEADER (x) = 1;
14557         }
14558
14559       t = lookup_name_current_level (name);
14560
14561       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14562
14563       /* Don't push non-parms onto list for parms until we understand
14564          why we're doing this and whether it works.  */
14565
14566       assert ((b == global_binding_level)
14567               || !ffecom_transform_only_dummies_
14568               || TREE_CODE (x) == PARM_DECL);
14569
14570       if ((t != NULL_TREE) && duplicate_decls (x, t))
14571         return t;
14572
14573       /* If we are processing a typedef statement, generate a whole new
14574          ..._TYPE node (which will be just an variant of the existing
14575          ..._TYPE node with identical properties) and then install the
14576          TYPE_DECL node generated to represent the typedef name as the
14577          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14578
14579          The whole point here is to end up with a situation where each and every
14580          ..._TYPE node the compiler creates will be uniquely associated with
14581          AT MOST one node representing a typedef name. This way, even though
14582          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14583          (i.e. "typedef name") nodes very early on, later parts of the
14584          compiler can always do the reverse translation and get back the
14585          corresponding typedef name.  For example, given:
14586
14587          typedef struct S MY_TYPE; MY_TYPE object;
14588
14589          Later parts of the compiler might only know that `object' was of type
14590          `struct S' if it were not for code just below.  With this code
14591          however, later parts of the compiler see something like:
14592
14593          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14594
14595          And they can then deduce (from the node for type struct S') that the
14596          original object declaration was:
14597
14598          MY_TYPE object;
14599
14600          Being able to do this is important for proper support of protoize, and
14601          also for generating precise symbolic debugging information which
14602          takes full account of the programmer's (typedef) vocabulary.
14603
14604          Obviously, we don't want to generate a duplicate ..._TYPE node if the
14605          TYPE_DECL node that we are now processing really represents a
14606          standard built-in type.
14607
14608          Since all standard types are effectively declared at line zero in the
14609          source file, we can easily check to see if we are working on a
14610          standard type by checking the current value of lineno.  */
14611
14612       if (TREE_CODE (x) == TYPE_DECL)
14613         {
14614           if (DECL_SOURCE_LINE (x) == 0)
14615             {
14616               if (TYPE_NAME (TREE_TYPE (x)) == 0)
14617                 TYPE_NAME (TREE_TYPE (x)) = x;
14618             }
14619           else if (TREE_TYPE (x) != error_mark_node)
14620             {
14621               tree tt = TREE_TYPE (x);
14622
14623               tt = build_type_copy (tt);
14624               TYPE_NAME (tt) = x;
14625               TREE_TYPE (x) = tt;
14626             }
14627         }
14628
14629       /* This name is new in its binding level. Install the new declaration
14630          and return it.  */
14631       if (b == global_binding_level)
14632         IDENTIFIER_GLOBAL_VALUE (name) = x;
14633       else
14634         IDENTIFIER_LOCAL_VALUE (name) = x;
14635     }
14636
14637   /* Put decls on list in reverse order. We will reverse them later if
14638      necessary.  */
14639   TREE_CHAIN (x) = b->names;
14640   b->names = x;
14641
14642   return x;
14643 }
14644
14645 /* Nonzero if the current level needs to have a BLOCK made.  */
14646
14647 static int
14648 kept_level_p ()
14649 {
14650   tree decl;
14651
14652   for (decl = current_binding_level->names;
14653        decl;
14654        decl = TREE_CHAIN (decl))
14655     {
14656       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
14657           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
14658         /* Currently, there aren't supposed to be non-artificial names
14659            at other than the top block for a function -- they're
14660            believed to always be temps.  But it's wise to check anyway.  */
14661         return 1;
14662     }
14663   return 0;
14664 }
14665
14666 /* Enter a new binding level.
14667    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14668    not for that of tags.  */
14669
14670 void
14671 pushlevel (tag_transparent)
14672      int tag_transparent;
14673 {
14674   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
14675
14676   assert (! tag_transparent);
14677
14678   if (current_binding_level == global_binding_level)
14679     {
14680       named_labels = 0;
14681     }
14682
14683   /* Reuse or create a struct for this binding level.  */
14684
14685   if (free_binding_level)
14686     {
14687       newlevel = free_binding_level;
14688       free_binding_level = free_binding_level->level_chain;
14689     }
14690   else
14691     {
14692       newlevel = make_binding_level ();
14693     }
14694
14695   /* Add this level to the front of the chain (stack) of levels that
14696      are active.  */
14697
14698   *newlevel = clear_binding_level;
14699   newlevel->level_chain = current_binding_level;
14700   current_binding_level = newlevel;
14701 }
14702
14703 /* Set the BLOCK node for the innermost scope
14704    (the one we are currently in).  */
14705
14706 void
14707 set_block (block)
14708      register tree block;
14709 {
14710   current_binding_level->this_block = block;
14711   current_binding_level->names = chainon (current_binding_level->names,
14712                                           BLOCK_VARS (block));
14713   current_binding_level->blocks = chainon (current_binding_level->blocks,
14714                                            BLOCK_SUBBLOCKS (block));
14715 }
14716
14717 tree
14718 signed_or_unsigned_type (unsignedp, type)
14719      int unsignedp;
14720      tree type;
14721 {
14722   tree type2;
14723
14724   if (! INTEGRAL_TYPE_P (type))
14725     return type;
14726   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
14727     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14728   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
14729     return unsignedp ? unsigned_type_node : integer_type_node;
14730   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
14731     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14732   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
14733     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14734   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
14735     return (unsignedp ? long_long_unsigned_type_node
14736             : long_long_integer_type_node);
14737
14738   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
14739   if (type2 == NULL_TREE)
14740     return type;
14741
14742   return type2;
14743 }
14744
14745 tree
14746 signed_type (type)
14747      tree type;
14748 {
14749   tree type1 = TYPE_MAIN_VARIANT (type);
14750   ffeinfoKindtype kt;
14751   tree type2;
14752
14753   if (type1 == unsigned_char_type_node || type1 == char_type_node)
14754     return signed_char_type_node;
14755   if (type1 == unsigned_type_node)
14756     return integer_type_node;
14757   if (type1 == short_unsigned_type_node)
14758     return short_integer_type_node;
14759   if (type1 == long_unsigned_type_node)
14760     return long_integer_type_node;
14761   if (type1 == long_long_unsigned_type_node)
14762     return long_long_integer_type_node;
14763 #if 0   /* gcc/c-* files only */
14764   if (type1 == unsigned_intDI_type_node)
14765     return intDI_type_node;
14766   if (type1 == unsigned_intSI_type_node)
14767     return intSI_type_node;
14768   if (type1 == unsigned_intHI_type_node)
14769     return intHI_type_node;
14770   if (type1 == unsigned_intQI_type_node)
14771     return intQI_type_node;
14772 #endif
14773
14774   type2 = type_for_size (TYPE_PRECISION (type1), 0);
14775   if (type2 != NULL_TREE)
14776     return type2;
14777
14778   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14779     {
14780       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
14781
14782       if (type1 == type2)
14783         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14784     }
14785
14786   return type;
14787 }
14788
14789 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14790    or validate its data type for an `if' or `while' statement or ?..: exp.
14791
14792    This preparation consists of taking the ordinary
14793    representation of an expression expr and producing a valid tree
14794    boolean expression describing whether expr is nonzero.  We could
14795    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14796    but we optimize comparisons, &&, ||, and !.
14797
14798    The resulting type should always be `integer_type_node'.  */
14799
14800 tree
14801 truthvalue_conversion (expr)
14802      tree expr;
14803 {
14804   if (TREE_CODE (expr) == ERROR_MARK)
14805     return expr;
14806
14807 #if 0 /* This appears to be wrong for C++.  */
14808   /* These really should return error_mark_node after 2.4 is stable.
14809      But not all callers handle ERROR_MARK properly.  */
14810   switch (TREE_CODE (TREE_TYPE (expr)))
14811     {
14812     case RECORD_TYPE:
14813       error ("struct type value used where scalar is required");
14814       return integer_zero_node;
14815
14816     case UNION_TYPE:
14817       error ("union type value used where scalar is required");
14818       return integer_zero_node;
14819
14820     case ARRAY_TYPE:
14821       error ("array type value used where scalar is required");
14822       return integer_zero_node;
14823
14824     default:
14825       break;
14826     }
14827 #endif /* 0 */
14828
14829   switch (TREE_CODE (expr))
14830     {
14831       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14832          or comparison expressions as truth values at this level.  */
14833 #if 0
14834     case COMPONENT_REF:
14835       /* A one-bit unsigned bit-field is already acceptable.  */
14836       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
14837           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
14838         return expr;
14839       break;
14840 #endif
14841
14842     case EQ_EXPR:
14843       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14844          or comparison expressions as truth values at this level.  */
14845 #if 0
14846       if (integer_zerop (TREE_OPERAND (expr, 1)))
14847         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
14848 #endif
14849     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
14850     case TRUTH_ANDIF_EXPR:
14851     case TRUTH_ORIF_EXPR:
14852     case TRUTH_AND_EXPR:
14853     case TRUTH_OR_EXPR:
14854     case TRUTH_XOR_EXPR:
14855       TREE_TYPE (expr) = integer_type_node;
14856       return expr;
14857
14858     case ERROR_MARK:
14859       return expr;
14860
14861     case INTEGER_CST:
14862       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
14863
14864     case REAL_CST:
14865       return real_zerop (expr) ? integer_zero_node : integer_one_node;
14866
14867     case ADDR_EXPR:
14868       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
14869         return build (COMPOUND_EXPR, integer_type_node,
14870                       TREE_OPERAND (expr, 0), integer_one_node);
14871       else
14872         return integer_one_node;
14873
14874     case COMPLEX_EXPR:
14875       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
14876                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14877                        integer_type_node,
14878                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
14879                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
14880
14881     case NEGATE_EXPR:
14882     case ABS_EXPR:
14883     case FLOAT_EXPR:
14884     case FFS_EXPR:
14885       /* These don't change whether an object is non-zero or zero.  */
14886       return truthvalue_conversion (TREE_OPERAND (expr, 0));
14887
14888     case LROTATE_EXPR:
14889     case RROTATE_EXPR:
14890       /* These don't change whether an object is zero or non-zero, but
14891          we can't ignore them if their second arg has side-effects.  */
14892       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
14893         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
14894                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
14895       else
14896         return truthvalue_conversion (TREE_OPERAND (expr, 0));
14897
14898     case COND_EXPR:
14899       /* Distribute the conversion into the arms of a COND_EXPR.  */
14900       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
14901                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
14902                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
14903
14904     case CONVERT_EXPR:
14905       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14906          since that affects how `default_conversion' will behave.  */
14907       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
14908           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
14909         break;
14910       /* fall through... */
14911     case NOP_EXPR:
14912       /* If this is widening the argument, we can ignore it.  */
14913       if (TYPE_PRECISION (TREE_TYPE (expr))
14914           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
14915         return truthvalue_conversion (TREE_OPERAND (expr, 0));
14916       break;
14917
14918     case MINUS_EXPR:
14919       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14920          this case.  */
14921       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
14922           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
14923         break;
14924       /* fall through... */
14925     case BIT_XOR_EXPR:
14926       /* This and MINUS_EXPR can be changed into a comparison of the
14927          two objects.  */
14928       if (TREE_TYPE (TREE_OPERAND (expr, 0))
14929           == TREE_TYPE (TREE_OPERAND (expr, 1)))
14930         return ffecom_2 (NE_EXPR, integer_type_node,
14931                          TREE_OPERAND (expr, 0),
14932                          TREE_OPERAND (expr, 1));
14933       return ffecom_2 (NE_EXPR, integer_type_node,
14934                        TREE_OPERAND (expr, 0),
14935                        fold (build1 (NOP_EXPR,
14936                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
14937                                      TREE_OPERAND (expr, 1))));
14938
14939     case BIT_AND_EXPR:
14940       if (integer_onep (TREE_OPERAND (expr, 1)))
14941         return expr;
14942       break;
14943
14944     case MODIFY_EXPR:
14945 #if 0                           /* No such thing in Fortran. */
14946       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
14947         warning ("suggest parentheses around assignment used as truth value");
14948 #endif
14949       break;
14950
14951     default:
14952       break;
14953     }
14954
14955   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
14956     return (ffecom_2
14957             ((TREE_SIDE_EFFECTS (expr)
14958               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14959              integer_type_node,
14960              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
14961                                               TREE_TYPE (TREE_TYPE (expr)),
14962                                               expr)),
14963              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
14964                                               TREE_TYPE (TREE_TYPE (expr)),
14965                                               expr))));
14966
14967   return ffecom_2 (NE_EXPR, integer_type_node,
14968                    expr,
14969                    convert (TREE_TYPE (expr), integer_zero_node));
14970 }
14971
14972 tree
14973 type_for_mode (mode, unsignedp)
14974      enum machine_mode mode;
14975      int unsignedp;
14976 {
14977   int i;
14978   int j;
14979   tree t;
14980
14981   if (mode == TYPE_MODE (integer_type_node))
14982     return unsignedp ? unsigned_type_node : integer_type_node;
14983
14984   if (mode == TYPE_MODE (signed_char_type_node))
14985     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14986
14987   if (mode == TYPE_MODE (short_integer_type_node))
14988     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14989
14990   if (mode == TYPE_MODE (long_integer_type_node))
14991     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14992
14993   if (mode == TYPE_MODE (long_long_integer_type_node))
14994     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
14995
14996 #if HOST_BITS_PER_WIDE_INT >= 64
14997   if (mode == TYPE_MODE (intTI_type_node))
14998     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
14999 #endif
15000
15001   if (mode == TYPE_MODE (float_type_node))
15002     return float_type_node;
15003
15004   if (mode == TYPE_MODE (double_type_node))
15005     return double_type_node;
15006
15007   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15008     return build_pointer_type (char_type_node);
15009
15010   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15011     return build_pointer_type (integer_type_node);
15012
15013   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15014     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15015       {
15016         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15017             && (mode == TYPE_MODE (t)))
15018           {
15019             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15020               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15021             else
15022               return t;
15023           }
15024       }
15025
15026   return 0;
15027 }
15028
15029 tree
15030 type_for_size (bits, unsignedp)
15031      unsigned bits;
15032      int unsignedp;
15033 {
15034   ffeinfoKindtype kt;
15035   tree type_node;
15036
15037   if (bits == TYPE_PRECISION (integer_type_node))
15038     return unsignedp ? unsigned_type_node : integer_type_node;
15039
15040   if (bits == TYPE_PRECISION (signed_char_type_node))
15041     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15042
15043   if (bits == TYPE_PRECISION (short_integer_type_node))
15044     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15045
15046   if (bits == TYPE_PRECISION (long_integer_type_node))
15047     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15048
15049   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15050     return (unsignedp ? long_long_unsigned_type_node
15051             : long_long_integer_type_node);
15052
15053   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15054     {
15055       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15056
15057       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15058         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15059           : type_node;
15060     }
15061
15062   return 0;
15063 }
15064
15065 tree
15066 unsigned_type (type)
15067      tree type;
15068 {
15069   tree type1 = TYPE_MAIN_VARIANT (type);
15070   ffeinfoKindtype kt;
15071   tree type2;
15072
15073   if (type1 == signed_char_type_node || type1 == char_type_node)
15074     return unsigned_char_type_node;
15075   if (type1 == integer_type_node)
15076     return unsigned_type_node;
15077   if (type1 == short_integer_type_node)
15078     return short_unsigned_type_node;
15079   if (type1 == long_integer_type_node)
15080     return long_unsigned_type_node;
15081   if (type1 == long_long_integer_type_node)
15082     return long_long_unsigned_type_node;
15083 #if 0   /* gcc/c-* files only */
15084   if (type1 == intDI_type_node)
15085     return unsigned_intDI_type_node;
15086   if (type1 == intSI_type_node)
15087     return unsigned_intSI_type_node;
15088   if (type1 == intHI_type_node)
15089     return unsigned_intHI_type_node;
15090   if (type1 == intQI_type_node)
15091     return unsigned_intQI_type_node;
15092 #endif
15093
15094   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15095   if (type2 != NULL_TREE)
15096     return type2;
15097
15098   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15099     {
15100       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15101
15102       if (type1 == type2)
15103         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15104     }
15105
15106   return type;
15107 }
15108
15109 void
15110 lang_mark_tree (t)
15111      union tree_node *t ATTRIBUTE_UNUSED;
15112 {
15113   if (TREE_CODE (t) == IDENTIFIER_NODE)
15114     {
15115       struct lang_identifier *i = (struct lang_identifier *) t;
15116       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15117       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15118       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15119     }
15120   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15121     ggc_mark (TYPE_LANG_SPECIFIC (t));
15122 }
15123 \f
15124 /* From gcc/cccp.c, the code to handle -I.  */
15125
15126 /* Skip leading "./" from a directory name.
15127    This may yield the empty string, which represents the current directory.  */
15128
15129 static const char *
15130 skip_redundant_dir_prefix (const char *dir)
15131 {
15132   while (dir[0] == '.' && dir[1] == '/')
15133     for (dir += 2; *dir == '/'; dir++)
15134       continue;
15135   if (dir[0] == '.' && !dir[1])
15136     dir++;
15137   return dir;
15138 }
15139
15140 /* The file_name_map structure holds a mapping of file names for a
15141    particular directory.  This mapping is read from the file named
15142    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15143    map filenames on a file system with severe filename restrictions,
15144    such as DOS.  The format of the file name map file is just a series
15145    of lines with two tokens on each line.  The first token is the name
15146    to map, and the second token is the actual name to use.  */
15147
15148 struct file_name_map
15149 {
15150   struct file_name_map *map_next;
15151   char *map_from;
15152   char *map_to;
15153 };
15154
15155 #define FILE_NAME_MAP_FILE "header.gcc"
15156
15157 /* Current maximum length of directory names in the search path
15158    for include files.  (Altered as we get more of them.)  */
15159
15160 static int max_include_len = 0;
15161
15162 struct file_name_list
15163   {
15164     struct file_name_list *next;
15165     char *fname;
15166     /* Mapping of file names for this directory.  */
15167     struct file_name_map *name_map;
15168     /* Non-zero if name_map is valid.  */
15169     int got_name_map;
15170   };
15171
15172 static struct file_name_list *include = NULL;   /* First dir to search */
15173 static struct file_name_list *last_include = NULL;      /* Last in chain */
15174
15175 /* I/O buffer structure.
15176    The `fname' field is nonzero for source files and #include files
15177    and for the dummy text used for -D and -U.
15178    It is zero for rescanning results of macro expansion
15179    and for expanding macro arguments.  */
15180 #define INPUT_STACK_MAX 400
15181 static struct file_buf {
15182   const char *fname;
15183   /* Filename specified with #line command.  */
15184   const char *nominal_fname;
15185   /* Record where in the search path this file was found.
15186      For #include_next.  */
15187   struct file_name_list *dir;
15188   ffewhereLine line;
15189   ffewhereColumn column;
15190 } instack[INPUT_STACK_MAX];
15191
15192 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15193 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15194
15195 /* Current nesting level of input sources.
15196    `instack[indepth]' is the level currently being read.  */
15197 static int indepth = -1;
15198
15199 typedef struct file_buf FILE_BUF;
15200
15201 /* Nonzero means -I- has been seen,
15202    so don't look for #include "foo" the source-file directory.  */
15203 static int ignore_srcdir;
15204
15205 #ifndef INCLUDE_LEN_FUDGE
15206 #define INCLUDE_LEN_FUDGE 0
15207 #endif
15208
15209 static void append_include_chain (struct file_name_list *first,
15210                                   struct file_name_list *last);
15211 static FILE *open_include_file (char *filename,
15212                                 struct file_name_list *searchptr);
15213 static void print_containing_files (ffebadSeverity sev);
15214 static char *read_filename_string (int ch, FILE *f);
15215 static struct file_name_map *read_name_map (const char *dirname);
15216
15217 /* Append a chain of `struct file_name_list's
15218    to the end of the main include chain.
15219    FIRST is the beginning of the chain to append, and LAST is the end.  */
15220
15221 static void
15222 append_include_chain (first, last)
15223      struct file_name_list *first, *last;
15224 {
15225   struct file_name_list *dir;
15226
15227   if (!first || !last)
15228     return;
15229
15230   if (include == 0)
15231     include = first;
15232   else
15233     last_include->next = first;
15234
15235   for (dir = first; ; dir = dir->next) {
15236     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15237     if (len > max_include_len)
15238       max_include_len = len;
15239     if (dir == last)
15240       break;
15241   }
15242
15243   last->next = NULL;
15244   last_include = last;
15245 }
15246
15247 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15248    being tried from the include file search path.  This function maps
15249    filenames on file systems based on information read by
15250    read_name_map.  */
15251
15252 static FILE *
15253 open_include_file (filename, searchptr)
15254      char *filename;
15255      struct file_name_list *searchptr;
15256 {
15257   register struct file_name_map *map;
15258   register char *from;
15259   char *p, *dir;
15260
15261   if (searchptr && ! searchptr->got_name_map)
15262     {
15263       searchptr->name_map = read_name_map (searchptr->fname
15264                                            ? searchptr->fname : ".");
15265       searchptr->got_name_map = 1;
15266     }
15267
15268   /* First check the mapping for the directory we are using.  */
15269   if (searchptr && searchptr->name_map)
15270     {
15271       from = filename;
15272       if (searchptr->fname)
15273         from += strlen (searchptr->fname) + 1;
15274       for (map = searchptr->name_map; map; map = map->map_next)
15275         {
15276           if (! strcmp (map->map_from, from))
15277             {
15278               /* Found a match.  */
15279               return fopen (map->map_to, "r");
15280             }
15281         }
15282     }
15283
15284   /* Try to find a mapping file for the particular directory we are
15285      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15286      in /usr/include/header.gcc and look up types.h in
15287      /usr/include/sys/header.gcc.  */
15288   p = strrchr (filename, '/');
15289 #ifdef DIR_SEPARATOR
15290   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15291   else {
15292     char *tmp = strrchr (filename, DIR_SEPARATOR);
15293     if (tmp != NULL && tmp > p) p = tmp;
15294   }
15295 #endif
15296   if (! p)
15297     p = filename;
15298   if (searchptr
15299       && searchptr->fname
15300       && strlen (searchptr->fname) == (size_t) (p - filename)
15301       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15302     {
15303       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15304       return fopen (filename, "r");
15305     }
15306
15307   if (p == filename)
15308     {
15309       from = filename;
15310       map = read_name_map (".");
15311     }
15312   else
15313     {
15314       dir = (char *) xmalloc (p - filename + 1);
15315       memcpy (dir, filename, p - filename);
15316       dir[p - filename] = '\0';
15317       from = p + 1;
15318       map = read_name_map (dir);
15319       free (dir);
15320     }
15321   for (; map; map = map->map_next)
15322     if (! strcmp (map->map_from, from))
15323       return fopen (map->map_to, "r");
15324
15325   return fopen (filename, "r");
15326 }
15327
15328 /* Print the file names and line numbers of the #include
15329    commands which led to the current file.  */
15330
15331 static void
15332 print_containing_files (ffebadSeverity sev)
15333 {
15334   FILE_BUF *ip = NULL;
15335   int i;
15336   int first = 1;
15337   const char *str1;
15338   const char *str2;
15339
15340   /* If stack of files hasn't changed since we last printed
15341      this info, don't repeat it.  */
15342   if (last_error_tick == input_file_stack_tick)
15343     return;
15344
15345   for (i = indepth; i >= 0; i--)
15346     if (instack[i].fname != NULL) {
15347       ip = &instack[i];
15348       break;
15349     }
15350
15351   /* Give up if we don't find a source file.  */
15352   if (ip == NULL)
15353     return;
15354
15355   /* Find the other, outer source files.  */
15356   for (i--; i >= 0; i--)
15357     if (instack[i].fname != NULL)
15358       {
15359         ip = &instack[i];
15360         if (first)
15361           {
15362             first = 0;
15363             str1 = "In file included";
15364           }
15365         else
15366           {
15367             str1 = "...          ...";
15368           }
15369
15370         if (i == 1)
15371           str2 = ":";
15372         else
15373           str2 = "";
15374
15375         ffebad_start_msg ("%A from %B at %0%C", sev);
15376         ffebad_here (0, ip->line, ip->column);
15377         ffebad_string (str1);
15378         ffebad_string (ip->nominal_fname);
15379         ffebad_string (str2);
15380         ffebad_finish ();
15381       }
15382
15383   /* Record we have printed the status as of this time.  */
15384   last_error_tick = input_file_stack_tick;
15385 }
15386
15387 /* Read a space delimited string of unlimited length from a stdio
15388    file.  */
15389
15390 static char *
15391 read_filename_string (ch, f)
15392      int ch;
15393      FILE *f;
15394 {
15395   char *alloc, *set;
15396   int len;
15397
15398   len = 20;
15399   set = alloc = xmalloc (len + 1);
15400   if (! ISSPACE (ch))
15401     {
15402       *set++ = ch;
15403       while ((ch = getc (f)) != EOF && ! ISSPACE (ch))
15404         {
15405           if (set - alloc == len)
15406             {
15407               len *= 2;
15408               alloc = xrealloc (alloc, len + 1);
15409               set = alloc + len / 2;
15410             }
15411           *set++ = ch;
15412         }
15413     }
15414   *set = '\0';
15415   ungetc (ch, f);
15416   return alloc;
15417 }
15418
15419 /* Read the file name map file for DIRNAME.  */
15420
15421 static struct file_name_map *
15422 read_name_map (dirname)
15423      const char *dirname;
15424 {
15425   /* This structure holds a linked list of file name maps, one per
15426      directory.  */
15427   struct file_name_map_list
15428     {
15429       struct file_name_map_list *map_list_next;
15430       char *map_list_name;
15431       struct file_name_map *map_list_map;
15432     };
15433   static struct file_name_map_list *map_list;
15434   register struct file_name_map_list *map_list_ptr;
15435   char *name;
15436   FILE *f;
15437   size_t dirlen;
15438   int separator_needed;
15439
15440   dirname = skip_redundant_dir_prefix (dirname);
15441
15442   for (map_list_ptr = map_list; map_list_ptr;
15443        map_list_ptr = map_list_ptr->map_list_next)
15444     if (! strcmp (map_list_ptr->map_list_name, dirname))
15445       return map_list_ptr->map_list_map;
15446
15447   map_list_ptr = ((struct file_name_map_list *)
15448                   xmalloc (sizeof (struct file_name_map_list)));
15449   map_list_ptr->map_list_name = xstrdup (dirname);
15450   map_list_ptr->map_list_map = NULL;
15451
15452   dirlen = strlen (dirname);
15453   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15454   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15455   strcpy (name, dirname);
15456   name[dirlen] = '/';
15457   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15458   f = fopen (name, "r");
15459   free (name);
15460   if (!f)
15461     map_list_ptr->map_list_map = NULL;
15462   else
15463     {
15464       int ch;
15465
15466       while ((ch = getc (f)) != EOF)
15467         {
15468           char *from, *to;
15469           struct file_name_map *ptr;
15470
15471           if (ISSPACE (ch))
15472             continue;
15473           from = read_filename_string (ch, f);
15474           while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n')
15475             ;
15476           to = read_filename_string (ch, f);
15477
15478           ptr = ((struct file_name_map *)
15479                  xmalloc (sizeof (struct file_name_map)));
15480           ptr->map_from = from;
15481
15482           /* Make the real filename absolute.  */
15483           if (*to == '/')
15484             ptr->map_to = to;
15485           else
15486             {
15487               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15488               strcpy (ptr->map_to, dirname);
15489               ptr->map_to[dirlen] = '/';
15490               strcpy (ptr->map_to + dirlen + separator_needed, to);
15491               free (to);
15492             }
15493
15494           ptr->map_next = map_list_ptr->map_list_map;
15495           map_list_ptr->map_list_map = ptr;
15496
15497           while ((ch = getc (f)) != '\n')
15498             if (ch == EOF)
15499               break;
15500         }
15501       fclose (f);
15502     }
15503
15504   map_list_ptr->map_list_next = map_list;
15505   map_list = map_list_ptr;
15506
15507   return map_list_ptr->map_list_map;
15508 }
15509
15510 static void
15511 ffecom_file_ (const char *name)
15512 {
15513   FILE_BUF *fp;
15514
15515   /* Do partial setup of input buffer for the sake of generating
15516      early #line directives (when -g is in effect).  */
15517
15518   fp = &instack[++indepth];
15519   memset ((char *) fp, 0, sizeof (FILE_BUF));
15520   if (name == NULL)
15521     name = "";
15522   fp->nominal_fname = fp->fname = name;
15523 }
15524
15525 static void
15526 ffecom_close_include_ (FILE *f)
15527 {
15528   fclose (f);
15529
15530   indepth--;
15531   input_file_stack_tick++;
15532
15533   ffewhere_line_kill (instack[indepth].line);
15534   ffewhere_column_kill (instack[indepth].column);
15535 }
15536
15537 static int
15538 ffecom_decode_include_option_ (char *spec)
15539 {
15540   struct file_name_list *dirtmp;
15541
15542   if (! ignore_srcdir && !strcmp (spec, "-"))
15543     ignore_srcdir = 1;
15544   else
15545     {
15546       dirtmp = (struct file_name_list *)
15547         xmalloc (sizeof (struct file_name_list));
15548       dirtmp->next = 0;         /* New one goes on the end */
15549       dirtmp->fname = spec;
15550       dirtmp->got_name_map = 0;
15551       if (spec[0] == 0)
15552         error ("directory name must immediately follow -I");
15553       else
15554         append_include_chain (dirtmp, dirtmp);
15555     }
15556   return 1;
15557 }
15558
15559 /* Open INCLUDEd file.  */
15560
15561 static FILE *
15562 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
15563 {
15564   char *fbeg = name;
15565   size_t flen = strlen (fbeg);
15566   struct file_name_list *search_start = include; /* Chain of dirs to search */
15567   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
15568   struct file_name_list *searchptr = 0;
15569   char *fname;          /* Dynamically allocated fname buffer */
15570   FILE *f;
15571   FILE_BUF *fp;
15572
15573   if (flen == 0)
15574     return NULL;
15575
15576   dsp[0].fname = NULL;
15577
15578   /* If -I- was specified, don't search current dir, only spec'd ones. */
15579   if (!ignore_srcdir)
15580     {
15581       for (fp = &instack[indepth]; fp >= instack; fp--)
15582         {
15583           int n;
15584           char *ep;
15585           const char *nam;
15586
15587           if ((nam = fp->nominal_fname) != NULL)
15588             {
15589               /* Found a named file.  Figure out dir of the file,
15590                  and put it in front of the search list.  */
15591               dsp[0].next = search_start;
15592               search_start = dsp;
15593 #ifndef VMS
15594               ep = strrchr (nam, '/');
15595 #ifdef DIR_SEPARATOR
15596             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
15597             else {
15598               char *tmp = strrchr (nam, DIR_SEPARATOR);
15599               if (tmp != NULL && tmp > ep) ep = tmp;
15600             }
15601 #endif
15602 #else                           /* VMS */
15603               ep = strrchr (nam, ']');
15604               if (ep == NULL) ep = strrchr (nam, '>');
15605               if (ep == NULL) ep = strrchr (nam, ':');
15606               if (ep != NULL) ep++;
15607 #endif                          /* VMS */
15608               if (ep != NULL)
15609                 {
15610                   n = ep - nam;
15611                   dsp[0].fname = (char *) xmalloc (n + 1);
15612                   strncpy (dsp[0].fname, nam, n);
15613                   dsp[0].fname[n] = '\0';
15614                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
15615                     max_include_len = n + INCLUDE_LEN_FUDGE;
15616                 }
15617               else
15618                 dsp[0].fname = NULL; /* Current directory */
15619               dsp[0].got_name_map = 0;
15620               break;
15621             }
15622         }
15623     }
15624
15625   /* Allocate this permanently, because it gets stored in the definitions
15626      of macros.  */
15627   fname = xmalloc (max_include_len + flen + 4);
15628   /* + 2 above for slash and terminating null.  */
15629   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15630      for g77 yet).  */
15631
15632   /* If specified file name is absolute, just open it.  */
15633
15634   if (*fbeg == '/'
15635 #ifdef DIR_SEPARATOR
15636       || *fbeg == DIR_SEPARATOR
15637 #endif
15638       )
15639     {
15640       strncpy (fname, (char *) fbeg, flen);
15641       fname[flen] = 0;
15642       f = open_include_file (fname, NULL);
15643     }
15644   else
15645     {
15646       f = NULL;
15647
15648       /* Search directory path, trying to open the file.
15649          Copy each filename tried into FNAME.  */
15650
15651       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
15652         {
15653           if (searchptr->fname)
15654             {
15655               /* The empty string in a search path is ignored.
15656                  This makes it possible to turn off entirely
15657                  a standard piece of the list.  */
15658               if (searchptr->fname[0] == 0)
15659                 continue;
15660               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
15661               if (fname[0] && fname[strlen (fname) - 1] != '/')
15662                 strcat (fname, "/");
15663               fname[strlen (fname) + flen] = 0;
15664             }
15665           else
15666             fname[0] = 0;
15667
15668           strncat (fname, fbeg, flen);
15669 #ifdef VMS
15670           /* Change this 1/2 Unix 1/2 VMS file specification into a
15671              full VMS file specification */
15672           if (searchptr->fname && (searchptr->fname[0] != 0))
15673             {
15674               /* Fix up the filename */
15675               hack_vms_include_specification (fname);
15676             }
15677           else
15678             {
15679               /* This is a normal VMS filespec, so use it unchanged.  */
15680               strncpy (fname, (char *) fbeg, flen);
15681               fname[flen] = 0;
15682 #if 0   /* Not for g77.  */
15683               /* if it's '#include filename', add the missing .h */
15684               if (strchr (fname, '.') == NULL)
15685                 strcat (fname, ".h");
15686 #endif
15687             }
15688 #endif /* VMS */
15689           f = open_include_file (fname, searchptr);
15690 #ifdef EACCES
15691           if (f == NULL && errno == EACCES)
15692             {
15693               print_containing_files (FFEBAD_severityWARNING);
15694               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15695                                 FFEBAD_severityWARNING);
15696               ffebad_string (fname);
15697               ffebad_here (0, l, c);
15698               ffebad_finish ();
15699             }
15700 #endif
15701           if (f != NULL)
15702             break;
15703         }
15704     }
15705
15706   if (f == NULL)
15707     {
15708       /* A file that was not found.  */
15709
15710       strncpy (fname, (char *) fbeg, flen);
15711       fname[flen] = 0;
15712       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
15713       ffebad_start (FFEBAD_OPEN_INCLUDE);
15714       ffebad_here (0, l, c);
15715       ffebad_string (fname);
15716       ffebad_finish ();
15717     }
15718
15719   if (dsp[0].fname != NULL)
15720     free (dsp[0].fname);
15721
15722   if (f == NULL)
15723     return NULL;
15724
15725   if (indepth >= (INPUT_STACK_MAX - 1))
15726     {
15727       print_containing_files (FFEBAD_severityFATAL);
15728       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15729                         FFEBAD_severityFATAL);
15730       ffebad_string (fname);
15731       ffebad_here (0, l, c);
15732       ffebad_finish ();
15733       return NULL;
15734     }
15735
15736   instack[indepth].line = ffewhere_line_use (l);
15737   instack[indepth].column = ffewhere_column_use (c);
15738
15739   fp = &instack[indepth + 1];
15740   memset ((char *) fp, 0, sizeof (FILE_BUF));
15741   fp->nominal_fname = fp->fname = fname;
15742   fp->dir = searchptr;
15743
15744   indepth++;
15745   input_file_stack_tick++;
15746
15747   return f;
15748 }
15749
15750 /**INDENT* (Do not reformat this comment even with -fca option.)
15751    Data-gathering files: Given the source file listed below, compiled with
15752    f2c I obtained the output file listed after that, and from the output
15753    file I derived the above code.
15754
15755 -------- (begin input file to f2c)
15756         implicit none
15757         character*10 A1,A2
15758         complex C1,C2
15759         integer I1,I2
15760         real R1,R2
15761         double precision D1,D2
15762 C
15763         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15764 c /
15765         call fooI(I1/I2)
15766         call fooR(R1/I1)
15767         call fooD(D1/I1)
15768         call fooC(C1/I1)
15769         call fooR(R1/R2)
15770         call fooD(R1/D1)
15771         call fooD(D1/D2)
15772         call fooD(D1/R1)
15773         call fooC(C1/C2)
15774         call fooC(C1/R1)
15775         call fooZ(C1/D1)
15776 c **
15777         call fooI(I1**I2)
15778         call fooR(R1**I1)
15779         call fooD(D1**I1)
15780         call fooC(C1**I1)
15781         call fooR(R1**R2)
15782         call fooD(R1**D1)
15783         call fooD(D1**D2)
15784         call fooD(D1**R1)
15785         call fooC(C1**C2)
15786         call fooC(C1**R1)
15787         call fooZ(C1**D1)
15788 c FFEINTRIN_impABS
15789         call fooR(ABS(R1))
15790 c FFEINTRIN_impACOS
15791         call fooR(ACOS(R1))
15792 c FFEINTRIN_impAIMAG
15793         call fooR(AIMAG(C1))
15794 c FFEINTRIN_impAINT
15795         call fooR(AINT(R1))
15796 c FFEINTRIN_impALOG
15797         call fooR(ALOG(R1))
15798 c FFEINTRIN_impALOG10
15799         call fooR(ALOG10(R1))
15800 c FFEINTRIN_impAMAX0
15801         call fooR(AMAX0(I1,I2))
15802 c FFEINTRIN_impAMAX1
15803         call fooR(AMAX1(R1,R2))
15804 c FFEINTRIN_impAMIN0
15805         call fooR(AMIN0(I1,I2))
15806 c FFEINTRIN_impAMIN1
15807         call fooR(AMIN1(R1,R2))
15808 c FFEINTRIN_impAMOD
15809         call fooR(AMOD(R1,R2))
15810 c FFEINTRIN_impANINT
15811         call fooR(ANINT(R1))
15812 c FFEINTRIN_impASIN
15813         call fooR(ASIN(R1))
15814 c FFEINTRIN_impATAN
15815         call fooR(ATAN(R1))
15816 c FFEINTRIN_impATAN2
15817         call fooR(ATAN2(R1,R2))
15818 c FFEINTRIN_impCABS
15819         call fooR(CABS(C1))
15820 c FFEINTRIN_impCCOS
15821         call fooC(CCOS(C1))
15822 c FFEINTRIN_impCEXP
15823         call fooC(CEXP(C1))
15824 c FFEINTRIN_impCHAR
15825         call fooA(CHAR(I1))
15826 c FFEINTRIN_impCLOG
15827         call fooC(CLOG(C1))
15828 c FFEINTRIN_impCONJG
15829         call fooC(CONJG(C1))
15830 c FFEINTRIN_impCOS
15831         call fooR(COS(R1))
15832 c FFEINTRIN_impCOSH
15833         call fooR(COSH(R1))
15834 c FFEINTRIN_impCSIN
15835         call fooC(CSIN(C1))
15836 c FFEINTRIN_impCSQRT
15837         call fooC(CSQRT(C1))
15838 c FFEINTRIN_impDABS
15839         call fooD(DABS(D1))
15840 c FFEINTRIN_impDACOS
15841         call fooD(DACOS(D1))
15842 c FFEINTRIN_impDASIN
15843         call fooD(DASIN(D1))
15844 c FFEINTRIN_impDATAN
15845         call fooD(DATAN(D1))
15846 c FFEINTRIN_impDATAN2
15847         call fooD(DATAN2(D1,D2))
15848 c FFEINTRIN_impDCOS
15849         call fooD(DCOS(D1))
15850 c FFEINTRIN_impDCOSH
15851         call fooD(DCOSH(D1))
15852 c FFEINTRIN_impDDIM
15853         call fooD(DDIM(D1,D2))
15854 c FFEINTRIN_impDEXP
15855         call fooD(DEXP(D1))
15856 c FFEINTRIN_impDIM
15857         call fooR(DIM(R1,R2))
15858 c FFEINTRIN_impDINT
15859         call fooD(DINT(D1))
15860 c FFEINTRIN_impDLOG
15861         call fooD(DLOG(D1))
15862 c FFEINTRIN_impDLOG10
15863         call fooD(DLOG10(D1))
15864 c FFEINTRIN_impDMAX1
15865         call fooD(DMAX1(D1,D2))
15866 c FFEINTRIN_impDMIN1
15867         call fooD(DMIN1(D1,D2))
15868 c FFEINTRIN_impDMOD
15869         call fooD(DMOD(D1,D2))
15870 c FFEINTRIN_impDNINT
15871         call fooD(DNINT(D1))
15872 c FFEINTRIN_impDPROD
15873         call fooD(DPROD(R1,R2))
15874 c FFEINTRIN_impDSIGN
15875         call fooD(DSIGN(D1,D2))
15876 c FFEINTRIN_impDSIN
15877         call fooD(DSIN(D1))
15878 c FFEINTRIN_impDSINH
15879         call fooD(DSINH(D1))
15880 c FFEINTRIN_impDSQRT
15881         call fooD(DSQRT(D1))
15882 c FFEINTRIN_impDTAN
15883         call fooD(DTAN(D1))
15884 c FFEINTRIN_impDTANH
15885         call fooD(DTANH(D1))
15886 c FFEINTRIN_impEXP
15887         call fooR(EXP(R1))
15888 c FFEINTRIN_impIABS
15889         call fooI(IABS(I1))
15890 c FFEINTRIN_impICHAR
15891         call fooI(ICHAR(A1))
15892 c FFEINTRIN_impIDIM
15893         call fooI(IDIM(I1,I2))
15894 c FFEINTRIN_impIDNINT
15895         call fooI(IDNINT(D1))
15896 c FFEINTRIN_impINDEX
15897         call fooI(INDEX(A1,A2))
15898 c FFEINTRIN_impISIGN
15899         call fooI(ISIGN(I1,I2))
15900 c FFEINTRIN_impLEN
15901         call fooI(LEN(A1))
15902 c FFEINTRIN_impLGE
15903         call fooL(LGE(A1,A2))
15904 c FFEINTRIN_impLGT
15905         call fooL(LGT(A1,A2))
15906 c FFEINTRIN_impLLE
15907         call fooL(LLE(A1,A2))
15908 c FFEINTRIN_impLLT
15909         call fooL(LLT(A1,A2))
15910 c FFEINTRIN_impMAX0
15911         call fooI(MAX0(I1,I2))
15912 c FFEINTRIN_impMAX1
15913         call fooI(MAX1(R1,R2))
15914 c FFEINTRIN_impMIN0
15915         call fooI(MIN0(I1,I2))
15916 c FFEINTRIN_impMIN1
15917         call fooI(MIN1(R1,R2))
15918 c FFEINTRIN_impMOD
15919         call fooI(MOD(I1,I2))
15920 c FFEINTRIN_impNINT
15921         call fooI(NINT(R1))
15922 c FFEINTRIN_impSIGN
15923         call fooR(SIGN(R1,R2))
15924 c FFEINTRIN_impSIN
15925         call fooR(SIN(R1))
15926 c FFEINTRIN_impSINH
15927         call fooR(SINH(R1))
15928 c FFEINTRIN_impSQRT
15929         call fooR(SQRT(R1))
15930 c FFEINTRIN_impTAN
15931         call fooR(TAN(R1))
15932 c FFEINTRIN_impTANH
15933         call fooR(TANH(R1))
15934 c FFEINTRIN_imp_CMPLX_C
15935         call fooC(cmplx(C1,C2))
15936 c FFEINTRIN_imp_CMPLX_D
15937         call fooZ(cmplx(D1,D2))
15938 c FFEINTRIN_imp_CMPLX_I
15939         call fooC(cmplx(I1,I2))
15940 c FFEINTRIN_imp_CMPLX_R
15941         call fooC(cmplx(R1,R2))
15942 c FFEINTRIN_imp_DBLE_C
15943         call fooD(dble(C1))
15944 c FFEINTRIN_imp_DBLE_D
15945         call fooD(dble(D1))
15946 c FFEINTRIN_imp_DBLE_I
15947         call fooD(dble(I1))
15948 c FFEINTRIN_imp_DBLE_R
15949         call fooD(dble(R1))
15950 c FFEINTRIN_imp_INT_C
15951         call fooI(int(C1))
15952 c FFEINTRIN_imp_INT_D
15953         call fooI(int(D1))
15954 c FFEINTRIN_imp_INT_I
15955         call fooI(int(I1))
15956 c FFEINTRIN_imp_INT_R
15957         call fooI(int(R1))
15958 c FFEINTRIN_imp_REAL_C
15959         call fooR(real(C1))
15960 c FFEINTRIN_imp_REAL_D
15961         call fooR(real(D1))
15962 c FFEINTRIN_imp_REAL_I
15963         call fooR(real(I1))
15964 c FFEINTRIN_imp_REAL_R
15965         call fooR(real(R1))
15966 c
15967 c FFEINTRIN_imp_INT_D:
15968 c
15969 c FFEINTRIN_specIDINT
15970         call fooI(IDINT(D1))
15971 c
15972 c FFEINTRIN_imp_INT_R:
15973 c
15974 c FFEINTRIN_specIFIX
15975         call fooI(IFIX(R1))
15976 c FFEINTRIN_specINT
15977         call fooI(INT(R1))
15978 c
15979 c FFEINTRIN_imp_REAL_D:
15980 c
15981 c FFEINTRIN_specSNGL
15982         call fooR(SNGL(D1))
15983 c
15984 c FFEINTRIN_imp_REAL_I:
15985 c
15986 c FFEINTRIN_specFLOAT
15987         call fooR(FLOAT(I1))
15988 c FFEINTRIN_specREAL
15989         call fooR(REAL(I1))
15990 c
15991         end
15992 -------- (end input file to f2c)
15993
15994 -------- (begin output from providing above input file as input to:
15995 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
15996 --------     -e "s:^#.*$::g"')
15997
15998 //  -- translated by f2c (version 19950223).
15999    You must link the resulting object file with the libraries:
16000         -lf2c -lm   (in that order)
16001 //
16002
16003
16004 // f2c.h  --  Standard Fortran to C header file //
16005
16006 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16007
16008         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16009
16010
16011
16012
16013 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16014 // we assume short, float are OK //
16015 typedef long int // long int // integer;
16016 typedef char *address;
16017 typedef short int shortint;
16018 typedef float real;
16019 typedef double doublereal;
16020 typedef struct { real r, i; } complex;
16021 typedef struct { doublereal r, i; } doublecomplex;
16022 typedef long int // long int // logical;
16023 typedef short int shortlogical;
16024 typedef char logical1;
16025 typedef char integer1;
16026 // typedef long long longint; // // system-dependent //
16027
16028
16029
16030
16031 // Extern is for use with -E //
16032
16033
16034
16035
16036 // I/O stuff //
16037
16038
16039
16040
16041
16042
16043
16044
16045 typedef long int // int or long int // flag;
16046 typedef long int // int or long int // ftnlen;
16047 typedef long int // int or long int // ftnint;
16048
16049
16050 //external read, write//
16051 typedef struct
16052 {       flag cierr;
16053         ftnint ciunit;
16054         flag ciend;
16055         char *cifmt;
16056         ftnint cirec;
16057 } cilist;
16058
16059 //internal read, write//
16060 typedef struct
16061 {       flag icierr;
16062         char *iciunit;
16063         flag iciend;
16064         char *icifmt;
16065         ftnint icirlen;
16066         ftnint icirnum;
16067 } icilist;
16068
16069 //open//
16070 typedef struct
16071 {       flag oerr;
16072         ftnint ounit;
16073         char *ofnm;
16074         ftnlen ofnmlen;
16075         char *osta;
16076         char *oacc;
16077         char *ofm;
16078         ftnint orl;
16079         char *oblnk;
16080 } olist;
16081
16082 //close//
16083 typedef struct
16084 {       flag cerr;
16085         ftnint cunit;
16086         char *csta;
16087 } cllist;
16088
16089 //rewind, backspace, endfile//
16090 typedef struct
16091 {       flag aerr;
16092         ftnint aunit;
16093 } alist;
16094
16095 // inquire //
16096 typedef struct
16097 {       flag inerr;
16098         ftnint inunit;
16099         char *infile;
16100         ftnlen infilen;
16101         ftnint  *inex;  //parameters in standard's order//
16102         ftnint  *inopen;
16103         ftnint  *innum;
16104         ftnint  *innamed;
16105         char    *inname;
16106         ftnlen  innamlen;
16107         char    *inacc;
16108         ftnlen  inacclen;
16109         char    *inseq;
16110         ftnlen  inseqlen;
16111         char    *indir;
16112         ftnlen  indirlen;
16113         char    *infmt;
16114         ftnlen  infmtlen;
16115         char    *inform;
16116         ftnint  informlen;
16117         char    *inunf;
16118         ftnlen  inunflen;
16119         ftnint  *inrecl;
16120         ftnint  *innrec;
16121         char    *inblank;
16122         ftnlen  inblanklen;
16123 } inlist;
16124
16125
16126
16127 union Multitype {       // for multiple entry points //
16128         integer1 g;
16129         shortint h;
16130         integer i;
16131         // longint j; //
16132         real r;
16133         doublereal d;
16134         complex c;
16135         doublecomplex z;
16136         };
16137
16138 typedef union Multitype Multitype;
16139
16140 typedef long Long;      // No longer used; formerly in Namelist //
16141
16142 struct Vardesc {        // for Namelist //
16143         char *name;
16144         char *addr;
16145         ftnlen *dims;
16146         int  type;
16147         };
16148 typedef struct Vardesc Vardesc;
16149
16150 struct Namelist {
16151         char *name;
16152         Vardesc **vars;
16153         int nvars;
16154         };
16155 typedef struct Namelist Namelist;
16156
16157
16158
16159
16160
16161
16162
16163
16164 // procedure parameter types for -A and -C++ //
16165
16166
16167
16168
16169 typedef int // Unknown procedure type // (*U_fp)();
16170 typedef shortint (*J_fp)();
16171 typedef integer (*I_fp)();
16172 typedef real (*R_fp)();
16173 typedef doublereal (*D_fp)(), (*E_fp)();
16174 typedef // Complex // void  (*C_fp)();
16175 typedef // Double Complex // void  (*Z_fp)();
16176 typedef logical (*L_fp)();
16177 typedef shortlogical (*K_fp)();
16178 typedef // Character // void  (*H_fp)();
16179 typedef // Subroutine // int (*S_fp)();
16180
16181 // E_fp is for real functions when -R is not specified //
16182 typedef void  C_f;      // complex function //
16183 typedef void  H_f;      // character function //
16184 typedef void  Z_f;      // double complex function //
16185 typedef doublereal E_f; // real function with -R not specified //
16186
16187 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16188
16189
16190 // (No such symbols should be defined in a strict ANSI C compiler.
16191    We can avoid trouble with f2c-translated code by using
16192    gcc -ansi [-traditional].) //
16193
16194
16195
16196
16197
16198
16199
16200
16201
16202
16203
16204
16205
16206
16207
16208
16209
16210
16211
16212
16213
16214
16215
16216 // Main program // MAIN__()
16217 {
16218     // System generated locals //
16219     integer i__1;
16220     real r__1, r__2;
16221     doublereal d__1, d__2;
16222     complex q__1;
16223     doublecomplex z__1, z__2, z__3;
16224     logical L__1;
16225     char ch__1[1];
16226
16227     // Builtin functions //
16228     void c_div();
16229     integer pow_ii();
16230     double pow_ri(), pow_di();
16231     void pow_ci();
16232     double pow_dd();
16233     void pow_zz();
16234     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16235             asin(), atan(), atan2(), c_abs();
16236     void c_cos(), c_exp(), c_log(), r_cnjg();
16237     double cos(), cosh();
16238     void c_sin(), c_sqrt();
16239     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16240             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16241     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16242     logical l_ge(), l_gt(), l_le(), l_lt();
16243     integer i_nint();
16244     double r_sign();
16245
16246     // Local variables //
16247     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16248             fool_(), fooz_(), getem_();
16249     static char a1[10], a2[10];
16250     static complex c1, c2;
16251     static doublereal d1, d2;
16252     static integer i1, i2;
16253     static real r1, r2;
16254
16255
16256     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16257 // / //
16258     i__1 = i1 / i2;
16259     fooi_(&i__1);
16260     r__1 = r1 / i1;
16261     foor_(&r__1);
16262     d__1 = d1 / i1;
16263     food_(&d__1);
16264     d__1 = (doublereal) i1;
16265     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16266     fooc_(&q__1);
16267     r__1 = r1 / r2;
16268     foor_(&r__1);
16269     d__1 = r1 / d1;
16270     food_(&d__1);
16271     d__1 = d1 / d2;
16272     food_(&d__1);
16273     d__1 = d1 / r1;
16274     food_(&d__1);
16275     c_div(&q__1, &c1, &c2);
16276     fooc_(&q__1);
16277     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16278     fooc_(&q__1);
16279     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16280     fooz_(&z__1);
16281 // ** //
16282     i__1 = pow_ii(&i1, &i2);
16283     fooi_(&i__1);
16284     r__1 = pow_ri(&r1, &i1);
16285     foor_(&r__1);
16286     d__1 = pow_di(&d1, &i1);
16287     food_(&d__1);
16288     pow_ci(&q__1, &c1, &i1);
16289     fooc_(&q__1);
16290     d__1 = (doublereal) r1;
16291     d__2 = (doublereal) r2;
16292     r__1 = pow_dd(&d__1, &d__2);
16293     foor_(&r__1);
16294     d__2 = (doublereal) r1;
16295     d__1 = pow_dd(&d__2, &d1);
16296     food_(&d__1);
16297     d__1 = pow_dd(&d1, &d2);
16298     food_(&d__1);
16299     d__2 = (doublereal) r1;
16300     d__1 = pow_dd(&d1, &d__2);
16301     food_(&d__1);
16302     z__2.r = c1.r, z__2.i = c1.i;
16303     z__3.r = c2.r, z__3.i = c2.i;
16304     pow_zz(&z__1, &z__2, &z__3);
16305     q__1.r = z__1.r, q__1.i = z__1.i;
16306     fooc_(&q__1);
16307     z__2.r = c1.r, z__2.i = c1.i;
16308     z__3.r = r1, z__3.i = 0.;
16309     pow_zz(&z__1, &z__2, &z__3);
16310     q__1.r = z__1.r, q__1.i = z__1.i;
16311     fooc_(&q__1);
16312     z__2.r = c1.r, z__2.i = c1.i;
16313     z__3.r = d1, z__3.i = 0.;
16314     pow_zz(&z__1, &z__2, &z__3);
16315     fooz_(&z__1);
16316 // FFEINTRIN_impABS //
16317     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16318     foor_(&r__1);
16319 // FFEINTRIN_impACOS //
16320     r__1 = acos(r1);
16321     foor_(&r__1);
16322 // FFEINTRIN_impAIMAG //
16323     r__1 = r_imag(&c1);
16324     foor_(&r__1);
16325 // FFEINTRIN_impAINT //
16326     r__1 = r_int(&r1);
16327     foor_(&r__1);
16328 // FFEINTRIN_impALOG //
16329     r__1 = log(r1);
16330     foor_(&r__1);
16331 // FFEINTRIN_impALOG10 //
16332     r__1 = r_lg10(&r1);
16333     foor_(&r__1);
16334 // FFEINTRIN_impAMAX0 //
16335     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16336     foor_(&r__1);
16337 // FFEINTRIN_impAMAX1 //
16338     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16339     foor_(&r__1);
16340 // FFEINTRIN_impAMIN0 //
16341     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16342     foor_(&r__1);
16343 // FFEINTRIN_impAMIN1 //
16344     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16345     foor_(&r__1);
16346 // FFEINTRIN_impAMOD //
16347     r__1 = r_mod(&r1, &r2);
16348     foor_(&r__1);
16349 // FFEINTRIN_impANINT //
16350     r__1 = r_nint(&r1);
16351     foor_(&r__1);
16352 // FFEINTRIN_impASIN //
16353     r__1 = asin(r1);
16354     foor_(&r__1);
16355 // FFEINTRIN_impATAN //
16356     r__1 = atan(r1);
16357     foor_(&r__1);
16358 // FFEINTRIN_impATAN2 //
16359     r__1 = atan2(r1, r2);
16360     foor_(&r__1);
16361 // FFEINTRIN_impCABS //
16362     r__1 = c_abs(&c1);
16363     foor_(&r__1);
16364 // FFEINTRIN_impCCOS //
16365     c_cos(&q__1, &c1);
16366     fooc_(&q__1);
16367 // FFEINTRIN_impCEXP //
16368     c_exp(&q__1, &c1);
16369     fooc_(&q__1);
16370 // FFEINTRIN_impCHAR //
16371     *(unsigned char *)&ch__1[0] = i1;
16372     fooa_(ch__1, 1L);
16373 // FFEINTRIN_impCLOG //
16374     c_log(&q__1, &c1);
16375     fooc_(&q__1);
16376 // FFEINTRIN_impCONJG //
16377     r_cnjg(&q__1, &c1);
16378     fooc_(&q__1);
16379 // FFEINTRIN_impCOS //
16380     r__1 = cos(r1);
16381     foor_(&r__1);
16382 // FFEINTRIN_impCOSH //
16383     r__1 = cosh(r1);
16384     foor_(&r__1);
16385 // FFEINTRIN_impCSIN //
16386     c_sin(&q__1, &c1);
16387     fooc_(&q__1);
16388 // FFEINTRIN_impCSQRT //
16389     c_sqrt(&q__1, &c1);
16390     fooc_(&q__1);
16391 // FFEINTRIN_impDABS //
16392     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16393     food_(&d__1);
16394 // FFEINTRIN_impDACOS //
16395     d__1 = acos(d1);
16396     food_(&d__1);
16397 // FFEINTRIN_impDASIN //
16398     d__1 = asin(d1);
16399     food_(&d__1);
16400 // FFEINTRIN_impDATAN //
16401     d__1 = atan(d1);
16402     food_(&d__1);
16403 // FFEINTRIN_impDATAN2 //
16404     d__1 = atan2(d1, d2);
16405     food_(&d__1);
16406 // FFEINTRIN_impDCOS //
16407     d__1 = cos(d1);
16408     food_(&d__1);
16409 // FFEINTRIN_impDCOSH //
16410     d__1 = cosh(d1);
16411     food_(&d__1);
16412 // FFEINTRIN_impDDIM //
16413     d__1 = d_dim(&d1, &d2);
16414     food_(&d__1);
16415 // FFEINTRIN_impDEXP //
16416     d__1 = exp(d1);
16417     food_(&d__1);
16418 // FFEINTRIN_impDIM //
16419     r__1 = r_dim(&r1, &r2);
16420     foor_(&r__1);
16421 // FFEINTRIN_impDINT //
16422     d__1 = d_int(&d1);
16423     food_(&d__1);
16424 // FFEINTRIN_impDLOG //
16425     d__1 = log(d1);
16426     food_(&d__1);
16427 // FFEINTRIN_impDLOG10 //
16428     d__1 = d_lg10(&d1);
16429     food_(&d__1);
16430 // FFEINTRIN_impDMAX1 //
16431     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16432     food_(&d__1);
16433 // FFEINTRIN_impDMIN1 //
16434     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16435     food_(&d__1);
16436 // FFEINTRIN_impDMOD //
16437     d__1 = d_mod(&d1, &d2);
16438     food_(&d__1);
16439 // FFEINTRIN_impDNINT //
16440     d__1 = d_nint(&d1);
16441     food_(&d__1);
16442 // FFEINTRIN_impDPROD //
16443     d__1 = (doublereal) r1 * r2;
16444     food_(&d__1);
16445 // FFEINTRIN_impDSIGN //
16446     d__1 = d_sign(&d1, &d2);
16447     food_(&d__1);
16448 // FFEINTRIN_impDSIN //
16449     d__1 = sin(d1);
16450     food_(&d__1);
16451 // FFEINTRIN_impDSINH //
16452     d__1 = sinh(d1);
16453     food_(&d__1);
16454 // FFEINTRIN_impDSQRT //
16455     d__1 = sqrt(d1);
16456     food_(&d__1);
16457 // FFEINTRIN_impDTAN //
16458     d__1 = tan(d1);
16459     food_(&d__1);
16460 // FFEINTRIN_impDTANH //
16461     d__1 = tanh(d1);
16462     food_(&d__1);
16463 // FFEINTRIN_impEXP //
16464     r__1 = exp(r1);
16465     foor_(&r__1);
16466 // FFEINTRIN_impIABS //
16467     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16468     fooi_(&i__1);
16469 // FFEINTRIN_impICHAR //
16470     i__1 = *(unsigned char *)a1;
16471     fooi_(&i__1);
16472 // FFEINTRIN_impIDIM //
16473     i__1 = i_dim(&i1, &i2);
16474     fooi_(&i__1);
16475 // FFEINTRIN_impIDNINT //
16476     i__1 = i_dnnt(&d1);
16477     fooi_(&i__1);
16478 // FFEINTRIN_impINDEX //
16479     i__1 = i_indx(a1, a2, 10L, 10L);
16480     fooi_(&i__1);
16481 // FFEINTRIN_impISIGN //
16482     i__1 = i_sign(&i1, &i2);
16483     fooi_(&i__1);
16484 // FFEINTRIN_impLEN //
16485     i__1 = i_len(a1, 10L);
16486     fooi_(&i__1);
16487 // FFEINTRIN_impLGE //
16488     L__1 = l_ge(a1, a2, 10L, 10L);
16489     fool_(&L__1);
16490 // FFEINTRIN_impLGT //
16491     L__1 = l_gt(a1, a2, 10L, 10L);
16492     fool_(&L__1);
16493 // FFEINTRIN_impLLE //
16494     L__1 = l_le(a1, a2, 10L, 10L);
16495     fool_(&L__1);
16496 // FFEINTRIN_impLLT //
16497     L__1 = l_lt(a1, a2, 10L, 10L);
16498     fool_(&L__1);
16499 // FFEINTRIN_impMAX0 //
16500     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16501     fooi_(&i__1);
16502 // FFEINTRIN_impMAX1 //
16503     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16504     fooi_(&i__1);
16505 // FFEINTRIN_impMIN0 //
16506     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16507     fooi_(&i__1);
16508 // FFEINTRIN_impMIN1 //
16509     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16510     fooi_(&i__1);
16511 // FFEINTRIN_impMOD //
16512     i__1 = i1 % i2;
16513     fooi_(&i__1);
16514 // FFEINTRIN_impNINT //
16515     i__1 = i_nint(&r1);
16516     fooi_(&i__1);
16517 // FFEINTRIN_impSIGN //
16518     r__1 = r_sign(&r1, &r2);
16519     foor_(&r__1);
16520 // FFEINTRIN_impSIN //
16521     r__1 = sin(r1);
16522     foor_(&r__1);
16523 // FFEINTRIN_impSINH //
16524     r__1 = sinh(r1);
16525     foor_(&r__1);
16526 // FFEINTRIN_impSQRT //
16527     r__1 = sqrt(r1);
16528     foor_(&r__1);
16529 // FFEINTRIN_impTAN //
16530     r__1 = tan(r1);
16531     foor_(&r__1);
16532 // FFEINTRIN_impTANH //
16533     r__1 = tanh(r1);
16534     foor_(&r__1);
16535 // FFEINTRIN_imp_CMPLX_C //
16536     r__1 = c1.r;
16537     r__2 = c2.r;
16538     q__1.r = r__1, q__1.i = r__2;
16539     fooc_(&q__1);
16540 // FFEINTRIN_imp_CMPLX_D //
16541     z__1.r = d1, z__1.i = d2;
16542     fooz_(&z__1);
16543 // FFEINTRIN_imp_CMPLX_I //
16544     r__1 = (real) i1;
16545     r__2 = (real) i2;
16546     q__1.r = r__1, q__1.i = r__2;
16547     fooc_(&q__1);
16548 // FFEINTRIN_imp_CMPLX_R //
16549     q__1.r = r1, q__1.i = r2;
16550     fooc_(&q__1);
16551 // FFEINTRIN_imp_DBLE_C //
16552     d__1 = (doublereal) c1.r;
16553     food_(&d__1);
16554 // FFEINTRIN_imp_DBLE_D //
16555     d__1 = d1;
16556     food_(&d__1);
16557 // FFEINTRIN_imp_DBLE_I //
16558     d__1 = (doublereal) i1;
16559     food_(&d__1);
16560 // FFEINTRIN_imp_DBLE_R //
16561     d__1 = (doublereal) r1;
16562     food_(&d__1);
16563 // FFEINTRIN_imp_INT_C //
16564     i__1 = (integer) c1.r;
16565     fooi_(&i__1);
16566 // FFEINTRIN_imp_INT_D //
16567     i__1 = (integer) d1;
16568     fooi_(&i__1);
16569 // FFEINTRIN_imp_INT_I //
16570     i__1 = i1;
16571     fooi_(&i__1);
16572 // FFEINTRIN_imp_INT_R //
16573     i__1 = (integer) r1;
16574     fooi_(&i__1);
16575 // FFEINTRIN_imp_REAL_C //
16576     r__1 = c1.r;
16577     foor_(&r__1);
16578 // FFEINTRIN_imp_REAL_D //
16579     r__1 = (real) d1;
16580     foor_(&r__1);
16581 // FFEINTRIN_imp_REAL_I //
16582     r__1 = (real) i1;
16583     foor_(&r__1);
16584 // FFEINTRIN_imp_REAL_R //
16585     r__1 = r1;
16586     foor_(&r__1);
16587
16588 // FFEINTRIN_imp_INT_D: //
16589
16590 // FFEINTRIN_specIDINT //
16591     i__1 = (integer) d1;
16592     fooi_(&i__1);
16593
16594 // FFEINTRIN_imp_INT_R: //
16595
16596 // FFEINTRIN_specIFIX //
16597     i__1 = (integer) r1;
16598     fooi_(&i__1);
16599 // FFEINTRIN_specINT //
16600     i__1 = (integer) r1;
16601     fooi_(&i__1);
16602
16603 // FFEINTRIN_imp_REAL_D: //
16604
16605 // FFEINTRIN_specSNGL //
16606     r__1 = (real) d1;
16607     foor_(&r__1);
16608
16609 // FFEINTRIN_imp_REAL_I: //
16610
16611 // FFEINTRIN_specFLOAT //
16612     r__1 = (real) i1;
16613     foor_(&r__1);
16614 // FFEINTRIN_specREAL //
16615     r__1 = (real) i1;
16616     foor_(&r__1);
16617
16618 } // MAIN__ //
16619
16620 -------- (end output file from f2c)
16621
16622 */