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.  g77 should");
11827       warning ("support non-32-bit machines better as of version 0.6");
11828     }
11829 #endif
11830
11831 #if 0   /* Code in ste.c that would crash has been commented out. */
11832   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
11833       < TYPE_PRECISION (string_type_node))
11834     /* I/O will probably crash.  */
11835     warning ("configuration: char * holds %d bits, but ftnlen only %d",
11836              TYPE_PRECISION (string_type_node),
11837              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
11838 #endif
11839
11840 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
11841   if (TYPE_PRECISION (ffecom_integer_type_node)
11842       < TYPE_PRECISION (string_type_node))
11843     /* ASSIGN 10 TO I will crash.  */
11844     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11845  ASSIGN statement might fail",
11846              TYPE_PRECISION (string_type_node),
11847              TYPE_PRECISION (ffecom_integer_type_node));
11848 #endif
11849 }
11850
11851 /* ffecom_init_2 -- Initialize
11852
11853    ffecom_init_2();  */
11854
11855 void
11856 ffecom_init_2 ()
11857 {
11858   assert (ffecom_outer_function_decl_ == NULL_TREE);
11859   assert (current_function_decl == NULL_TREE);
11860   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
11861
11862   ffecom_master_arglist_ = NULL;
11863   ++ffecom_num_fns_;
11864   ffecom_primary_entry_ = NULL;
11865   ffecom_is_altreturning_ = FALSE;
11866   ffecom_func_result_ = NULL_TREE;
11867   ffecom_multi_retval_ = NULL_TREE;
11868 }
11869
11870 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11871
11872    tree t;
11873    ffebld expr;  // FFE opITEM list.
11874    tree = ffecom_list_expr(expr);
11875
11876    List of actual args is transformed into corresponding gcc backend list.  */
11877
11878 tree
11879 ffecom_list_expr (ffebld expr)
11880 {
11881   tree list;
11882   tree *plist = &list;
11883   tree trail = NULL_TREE;       /* Append char length args here. */
11884   tree *ptrail = &trail;
11885   tree length;
11886
11887   while (expr != NULL)
11888     {
11889       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
11890
11891       if (texpr == error_mark_node)
11892         return error_mark_node;
11893
11894       *plist = build_tree_list (NULL_TREE, texpr);
11895       plist = &TREE_CHAIN (*plist);
11896       expr = ffebld_trail (expr);
11897       if (length != NULL_TREE)
11898         {
11899           *ptrail = build_tree_list (NULL_TREE, length);
11900           ptrail = &TREE_CHAIN (*ptrail);
11901         }
11902     }
11903
11904   *plist = trail;
11905
11906   return list;
11907 }
11908
11909 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11910
11911    tree t;
11912    ffebld expr;  // FFE opITEM list.
11913    tree = ffecom_list_ptr_to_expr(expr);
11914
11915    List of actual args is transformed into corresponding gcc backend list for
11916    use in calling an external procedure (vs. a statement function).  */
11917
11918 tree
11919 ffecom_list_ptr_to_expr (ffebld expr)
11920 {
11921   tree list;
11922   tree *plist = &list;
11923   tree trail = NULL_TREE;       /* Append char length args here. */
11924   tree *ptrail = &trail;
11925   tree length;
11926
11927   while (expr != NULL)
11928     {
11929       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
11930
11931       if (texpr == error_mark_node)
11932         return error_mark_node;
11933
11934       *plist = build_tree_list (NULL_TREE, texpr);
11935       plist = &TREE_CHAIN (*plist);
11936       expr = ffebld_trail (expr);
11937       if (length != NULL_TREE)
11938         {
11939           *ptrail = build_tree_list (NULL_TREE, length);
11940           ptrail = &TREE_CHAIN (*ptrail);
11941         }
11942     }
11943
11944   *plist = trail;
11945
11946   return list;
11947 }
11948
11949 /* Obtain gcc's LABEL_DECL tree for label.  */
11950
11951 tree
11952 ffecom_lookup_label (ffelab label)
11953 {
11954   tree glabel;
11955
11956   if (ffelab_hook (label) == NULL_TREE)
11957     {
11958       char labelname[16];
11959
11960       switch (ffelab_type (label))
11961         {
11962         case FFELAB_typeLOOPEND:
11963         case FFELAB_typeNOTLOOP:
11964         case FFELAB_typeENDIF:
11965           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
11966           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
11967                                void_type_node);
11968           DECL_CONTEXT (glabel) = current_function_decl;
11969           DECL_MODE (glabel) = VOIDmode;
11970           break;
11971
11972         case FFELAB_typeFORMAT:
11973           glabel = build_decl (VAR_DECL,
11974                                ffecom_get_invented_identifier
11975                                ("__g77_format_%d", (int) ffelab_value (label)),
11976                                build_type_variant (build_array_type
11977                                                    (char_type_node,
11978                                                     NULL_TREE),
11979                                                    1, 0));
11980           TREE_CONSTANT (glabel) = 1;
11981           TREE_STATIC (glabel) = 1;
11982           DECL_CONTEXT (glabel) = current_function_decl;
11983           DECL_INITIAL (glabel) = NULL;
11984           make_decl_rtl (glabel, NULL);
11985           expand_decl (glabel);
11986
11987           ffecom_save_tree_forever (glabel);
11988
11989           break;
11990
11991         case FFELAB_typeANY:
11992           glabel = error_mark_node;
11993           break;
11994
11995         default:
11996           assert ("bad label type" == NULL);
11997           glabel = NULL;
11998           break;
11999         }
12000       ffelab_set_hook (label, glabel);
12001     }
12002   else
12003     {
12004       glabel = ffelab_hook (label);
12005     }
12006
12007   return glabel;
12008 }
12009
12010 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12011    a single source specification (as in the fourth argument of MVBITS).
12012    If the type is NULL_TREE, the type of lhs is used to make the type of
12013    the MODIFY_EXPR.  */
12014
12015 tree
12016 ffecom_modify (tree newtype, tree lhs,
12017                tree rhs)
12018 {
12019   if (lhs == error_mark_node || rhs == error_mark_node)
12020     return error_mark_node;
12021
12022   if (newtype == NULL_TREE)
12023     newtype = TREE_TYPE (lhs);
12024
12025   if (TREE_SIDE_EFFECTS (lhs))
12026     lhs = stabilize_reference (lhs);
12027
12028   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12029 }
12030
12031 /* Register source file name.  */
12032
12033 void
12034 ffecom_file (const char *name)
12035 {
12036   ffecom_file_ (name);
12037 }
12038
12039 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12040
12041    ffestorag st;
12042    ffecom_notify_init_storage(st);
12043
12044    Gets called when all possible units in an aggregate storage area (a LOCAL
12045    with equivalences or a COMMON) have been initialized.  The initialization
12046    info either is in ffestorag_init or, if that is NULL,
12047    ffestorag_accretion:
12048
12049    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12050    even for an array if the array is one element in length!
12051
12052    ffestorag_accretion will contain an opACCTER.  It is much like an
12053    opARRTER except it has an ffebit object in it instead of just a size.
12054    The back end can use the info in the ffebit object, if it wants, to
12055    reduce the amount of actual initialization, but in any case it should
12056    kill the ffebit object when done.  Also, set accretion to NULL but
12057    init to a non-NULL value.
12058
12059    After performing initialization, DO NOT set init to NULL, because that'll
12060    tell the front end it is ok for more initialization to happen.  Instead,
12061    set init to an opANY expression or some such thing that you can use to
12062    tell that you've already initialized the object.
12063
12064    27-Oct-91  JCB  1.1
12065       Support two-pass FFE.  */
12066
12067 void
12068 ffecom_notify_init_storage (ffestorag st)
12069 {
12070   ffebld init;                  /* The initialization expression. */
12071
12072   if (ffestorag_init (st) == NULL)
12073     {
12074       init = ffestorag_accretion (st);
12075       assert (init != NULL);
12076       ffestorag_set_accretion (st, NULL);
12077       ffestorag_set_accretes (st, 0);
12078       ffestorag_set_init (st, init);
12079     }
12080 }
12081
12082 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12083
12084    ffesymbol s;
12085    ffecom_notify_init_symbol(s);
12086
12087    Gets called when all possible units in a symbol (not placed in COMMON
12088    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12089    have been initialized.  The initialization info either is in
12090    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12091
12092    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12093    even for an array if the array is one element in length!
12094
12095    ffesymbol_accretion will contain an opACCTER.  It is much like an
12096    opARRTER except it has an ffebit object in it instead of just a size.
12097    The back end can use the info in the ffebit object, if it wants, to
12098    reduce the amount of actual initialization, but in any case it should
12099    kill the ffebit object when done.  Also, set accretion to NULL but
12100    init to a non-NULL value.
12101
12102    After performing initialization, DO NOT set init to NULL, because that'll
12103    tell the front end it is ok for more initialization to happen.  Instead,
12104    set init to an opANY expression or some such thing that you can use to
12105    tell that you've already initialized the object.
12106
12107    27-Oct-91  JCB  1.1
12108       Support two-pass FFE.  */
12109
12110 void
12111 ffecom_notify_init_symbol (ffesymbol s)
12112 {
12113   ffebld init;                  /* The initialization expression. */
12114
12115   if (ffesymbol_storage (s) == NULL)
12116     return;                     /* Do nothing until COMMON/EQUIVALENCE
12117                                    possibilities checked. */
12118
12119   if ((ffesymbol_init (s) == NULL)
12120       && ((init = ffesymbol_accretion (s)) != NULL))
12121     {
12122       ffesymbol_set_accretion (s, NULL);
12123       ffesymbol_set_accretes (s, 0);
12124       ffesymbol_set_init (s, init);
12125     }
12126 }
12127
12128 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12129
12130    ffesymbol s;
12131    ffecom_notify_primary_entry(s);
12132
12133    Gets called when implicit or explicit PROGRAM statement seen or when
12134    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12135    global symbol that serves as the entry point.  */
12136
12137 void
12138 ffecom_notify_primary_entry (ffesymbol s)
12139 {
12140   ffecom_primary_entry_ = s;
12141   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12142
12143   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12144       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12145     ffecom_primary_entry_is_proc_ = TRUE;
12146   else
12147     ffecom_primary_entry_is_proc_ = FALSE;
12148
12149   if (!ffe_is_silent ())
12150     {
12151       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12152         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12153       else
12154         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12155     }
12156
12157   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12158     {
12159       ffebld list;
12160       ffebld arg;
12161
12162       for (list = ffesymbol_dummyargs (s);
12163            list != NULL;
12164            list = ffebld_trail (list))
12165         {
12166           arg = ffebld_head (list);
12167           if (ffebld_op (arg) == FFEBLD_opSTAR)
12168             {
12169               ffecom_is_altreturning_ = TRUE;
12170               break;
12171             }
12172         }
12173     }
12174 }
12175
12176 FILE *
12177 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12178 {
12179   return ffecom_open_include_ (name, l, c);
12180 }
12181
12182 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12183
12184    tree t;
12185    ffebld expr;  // FFE expression.
12186    tree = ffecom_ptr_to_expr(expr);
12187
12188    Like ffecom_expr, but sticks address-of in front of most things.  */
12189
12190 tree
12191 ffecom_ptr_to_expr (ffebld expr)
12192 {
12193   tree item;
12194   ffeinfoBasictype bt;
12195   ffeinfoKindtype kt;
12196   ffesymbol s;
12197
12198   assert (expr != NULL);
12199
12200   switch (ffebld_op (expr))
12201     {
12202     case FFEBLD_opSYMTER:
12203       s = ffebld_symter (expr);
12204       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12205         {
12206           ffecomGfrt ix;
12207
12208           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12209           assert (ix != FFECOM_gfrt);
12210           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12211             {
12212               ffecom_make_gfrt_ (ix);
12213               item = ffecom_gfrt_[ix];
12214             }
12215         }
12216       else
12217         {
12218           item = ffesymbol_hook (s).decl_tree;
12219           if (item == NULL_TREE)
12220             {
12221               s = ffecom_sym_transform_ (s);
12222               item = ffesymbol_hook (s).decl_tree;
12223             }
12224         }
12225       assert (item != NULL);
12226       if (item == error_mark_node)
12227         return item;
12228       if (!ffesymbol_hook (s).addr)
12229         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12230                          item);
12231       return item;
12232
12233     case FFEBLD_opARRAYREF:
12234       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12235
12236     case FFEBLD_opCONTER:
12237
12238       bt = ffeinfo_basictype (ffebld_info (expr));
12239       kt = ffeinfo_kindtype (ffebld_info (expr));
12240
12241       item = ffecom_constantunion (&ffebld_constant_union
12242                                    (ffebld_conter (expr)), bt, kt,
12243                                    ffecom_tree_type[bt][kt]);
12244       if (item == error_mark_node)
12245         return error_mark_node;
12246       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12247                        item);
12248       return item;
12249
12250     case FFEBLD_opANY:
12251       return error_mark_node;
12252
12253     default:
12254       bt = ffeinfo_basictype (ffebld_info (expr));
12255       kt = ffeinfo_kindtype (ffebld_info (expr));
12256
12257       item = ffecom_expr (expr);
12258       if (item == error_mark_node)
12259         return error_mark_node;
12260
12261       /* The back end currently optimizes a bit too zealously for us, in that
12262          we fail JCB001 if the following block of code is omitted.  It checks
12263          to see if the transformed expression is a symbol or array reference,
12264          and encloses it in a SAVE_EXPR if that is the case.  */
12265
12266       STRIP_NOPS (item);
12267       if ((TREE_CODE (item) == VAR_DECL)
12268           || (TREE_CODE (item) == PARM_DECL)
12269           || (TREE_CODE (item) == RESULT_DECL)
12270           || (TREE_CODE (item) == INDIRECT_REF)
12271           || (TREE_CODE (item) == ARRAY_REF)
12272           || (TREE_CODE (item) == COMPONENT_REF)
12273 #ifdef OFFSET_REF
12274           || (TREE_CODE (item) == OFFSET_REF)
12275 #endif
12276           || (TREE_CODE (item) == BUFFER_REF)
12277           || (TREE_CODE (item) == REALPART_EXPR)
12278           || (TREE_CODE (item) == IMAGPART_EXPR))
12279         {
12280           item = ffecom_save_tree (item);
12281         }
12282
12283       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12284                        item);
12285       return item;
12286     }
12287
12288   assert ("fall-through error" == NULL);
12289   return error_mark_node;
12290 }
12291
12292 /* Obtain a temp var with given data type.
12293
12294    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12295    or >= 0 for a CHARACTER type.
12296
12297    elements is -1 for a scalar or > 0 for an array of type.  */
12298
12299 tree
12300 ffecom_make_tempvar (const char *commentary, tree type,
12301                      ffetargetCharacterSize size, int elements)
12302 {
12303   tree t;
12304   static int mynumber;
12305
12306   assert (current_binding_level->prep_state < 2);
12307
12308   if (type == error_mark_node)
12309     return error_mark_node;
12310
12311   if (size != FFETARGET_charactersizeNONE)
12312     type = build_array_type (type,
12313                              build_range_type (ffecom_f2c_ftnlen_type_node,
12314                                                ffecom_f2c_ftnlen_one_node,
12315                                                build_int_2 (size, 0)));
12316   if (elements != -1)
12317     type = build_array_type (type,
12318                              build_range_type (integer_type_node,
12319                                                integer_zero_node,
12320                                                build_int_2 (elements - 1,
12321                                                             0)));
12322   t = build_decl (VAR_DECL,
12323                   ffecom_get_invented_identifier ("__g77_%s_%d",
12324                                                   commentary,
12325                                                   mynumber++),
12326                   type);
12327
12328   t = start_decl (t, FALSE);
12329   finish_decl (t, NULL_TREE, FALSE);
12330
12331   return t;
12332 }
12333
12334 /* Prepare argument pointer to expression.
12335
12336    Like ffecom_prepare_expr, except for expressions to be evaluated
12337    via ffecom_arg_ptr_to_expr.  */
12338
12339 void
12340 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12341 {
12342   /* ~~For now, it seems to be the same thing.  */
12343   ffecom_prepare_expr (expr);
12344   return;
12345 }
12346
12347 /* End of preparations.  */
12348
12349 bool
12350 ffecom_prepare_end (void)
12351 {
12352   int prep_state = current_binding_level->prep_state;
12353
12354   assert (prep_state < 2);
12355   current_binding_level->prep_state = 2;
12356
12357   return (prep_state == 1) ? TRUE : FALSE;
12358 }
12359
12360 /* Prepare expression.
12361
12362    This is called before any code is generated for the current block.
12363    It scans the expression, declares any temporaries that might be needed
12364    during evaluation of the expression, and stores those temporaries in
12365    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12366    specifies the destination that ffecom_expr_ will see, in case that
12367    helps avoid generating unused temporaries.
12368
12369    ~~Improve to avoid allocating unused temporaries by taking `dest'
12370    into account vis-a-vis aliasing requirements of complex/character
12371    functions.  */
12372
12373 void
12374 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12375 {
12376   ffeinfoBasictype bt;
12377   ffeinfoKindtype kt;
12378   ffetargetCharacterSize sz;
12379   tree tempvar = NULL_TREE;
12380
12381   assert (current_binding_level->prep_state < 2);
12382
12383   if (! expr)
12384     return;
12385
12386   bt = ffeinfo_basictype (ffebld_info (expr));
12387   kt = ffeinfo_kindtype (ffebld_info (expr));
12388   sz = ffeinfo_size (ffebld_info (expr));
12389
12390   /* Generate whatever temporaries are needed to represent the result
12391      of the expression.  */
12392
12393   if (bt == FFEINFO_basictypeCHARACTER)
12394     {
12395       while (ffebld_op (expr) == FFEBLD_opPAREN)
12396         expr = ffebld_left (expr);
12397     }
12398
12399   switch (ffebld_op (expr))
12400     {
12401     default:
12402       /* Don't make temps for SYMTER, CONTER, etc.  */
12403       if (ffebld_arity (expr) == 0)
12404         break;
12405
12406       switch (bt)
12407         {
12408         case FFEINFO_basictypeCOMPLEX:
12409           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12410             {
12411               ffesymbol s;
12412
12413               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12414                 break;
12415
12416               s = ffebld_symter (ffebld_left (expr));
12417               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12418                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12419                       && ! ffesymbol_is_f2c (s))
12420                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12421                       && ! ffe_is_f2c_library ()))
12422                 break;
12423             }
12424           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12425             {
12426               /* Requires special treatment.  There's no POW_CC function
12427                  in libg2c, so POW_ZZ is used, which means we always
12428                  need a double-complex temp, not a single-complex.  */
12429               kt = FFEINFO_kindtypeREAL2;
12430             }
12431           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12432             /* The other ops don't need temps for complex operands.  */
12433             break;
12434
12435           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12436              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12437           tempvar = ffecom_make_tempvar ("complex",
12438                                          ffecom_tree_type
12439                                          [FFEINFO_basictypeCOMPLEX][kt],
12440                                          FFETARGET_charactersizeNONE,
12441                                          -1);
12442           break;
12443
12444         case FFEINFO_basictypeCHARACTER:
12445           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12446             break;
12447
12448           if (sz == FFETARGET_charactersizeNONE)
12449             /* ~~Kludge alert!  This should someday be fixed. */
12450             sz = 24;
12451
12452           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12453           break;
12454
12455         default:
12456           break;
12457         }
12458       break;
12459
12460 #ifdef HAHA
12461     case FFEBLD_opPOWER:
12462       {
12463         tree rtype, ltype;
12464         tree rtmp, ltmp, result;
12465
12466         ltype = ffecom_type_expr (ffebld_left (expr));
12467         rtype = ffecom_type_expr (ffebld_right (expr));
12468
12469         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12470         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12471         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12472
12473         tempvar = make_tree_vec (3);
12474         TREE_VEC_ELT (tempvar, 0) = rtmp;
12475         TREE_VEC_ELT (tempvar, 1) = ltmp;
12476         TREE_VEC_ELT (tempvar, 2) = result;
12477       }
12478       break;
12479 #endif  /* HAHA */
12480
12481     case FFEBLD_opCONCATENATE:
12482       {
12483         /* This gets special handling, because only one set of temps
12484            is needed for a tree of these -- the tree is treated as
12485            a flattened list of concatenations when generating code.  */
12486
12487         ffecomConcatList_ catlist;
12488         tree ltmp, itmp, result;
12489         int count;
12490         int i;
12491
12492         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12493         count = ffecom_concat_list_count_ (catlist);
12494
12495         if (count >= 2)
12496           {
12497             ltmp
12498               = ffecom_make_tempvar ("concat_len",
12499                                      ffecom_f2c_ftnlen_type_node,
12500                                      FFETARGET_charactersizeNONE, count);
12501             itmp
12502               = ffecom_make_tempvar ("concat_item",
12503                                      ffecom_f2c_address_type_node,
12504                                      FFETARGET_charactersizeNONE, count);
12505             result
12506               = ffecom_make_tempvar ("concat_res",
12507                                      char_type_node,
12508                                      ffecom_concat_list_maxlen_ (catlist),
12509                                      -1);
12510
12511             tempvar = make_tree_vec (3);
12512             TREE_VEC_ELT (tempvar, 0) = ltmp;
12513             TREE_VEC_ELT (tempvar, 1) = itmp;
12514             TREE_VEC_ELT (tempvar, 2) = result;
12515           }
12516
12517         for (i = 0; i < count; ++i)
12518           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12519                                                                     i));
12520
12521         ffecom_concat_list_kill_ (catlist);
12522
12523         if (tempvar)
12524           {
12525             ffebld_nonter_set_hook (expr, tempvar);
12526             current_binding_level->prep_state = 1;
12527           }
12528       }
12529       return;
12530
12531     case FFEBLD_opCONVERT:
12532       if (bt == FFEINFO_basictypeCHARACTER
12533           && ((ffebld_size_known (ffebld_left (expr))
12534                == FFETARGET_charactersizeNONE)
12535               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12536         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12537       break;
12538     }
12539
12540   if (tempvar)
12541     {
12542       ffebld_nonter_set_hook (expr, tempvar);
12543       current_binding_level->prep_state = 1;
12544     }
12545
12546   /* Prepare subexpressions for this expr.  */
12547
12548   switch (ffebld_op (expr))
12549     {
12550     case FFEBLD_opPERCENT_LOC:
12551       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12552       break;
12553
12554     case FFEBLD_opPERCENT_VAL:
12555     case FFEBLD_opPERCENT_REF:
12556       ffecom_prepare_expr (ffebld_left (expr));
12557       break;
12558
12559     case FFEBLD_opPERCENT_DESCR:
12560       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12561       break;
12562
12563     case FFEBLD_opITEM:
12564       {
12565         ffebld item;
12566
12567         for (item = expr;
12568              item != NULL;
12569              item = ffebld_trail (item))
12570           if (ffebld_head (item) != NULL)
12571             ffecom_prepare_expr (ffebld_head (item));
12572       }
12573       break;
12574
12575     default:
12576       /* Need to handle character conversion specially.  */
12577       switch (ffebld_arity (expr))
12578         {
12579         case 2:
12580           ffecom_prepare_expr (ffebld_left (expr));
12581           ffecom_prepare_expr (ffebld_right (expr));
12582           break;
12583
12584         case 1:
12585           ffecom_prepare_expr (ffebld_left (expr));
12586           break;
12587
12588         default:
12589           break;
12590         }
12591     }
12592
12593   return;
12594 }
12595
12596 /* Prepare expression for reading and writing.
12597
12598    Like ffecom_prepare_expr, except for expressions to be evaluated
12599    via ffecom_expr_rw.  */
12600
12601 void
12602 ffecom_prepare_expr_rw (tree type, ffebld expr)
12603 {
12604   /* This is all we support for now.  */
12605   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12606
12607   /* ~~For now, it seems to be the same thing.  */
12608   ffecom_prepare_expr (expr);
12609   return;
12610 }
12611
12612 /* Prepare expression for writing.
12613
12614    Like ffecom_prepare_expr, except for expressions to be evaluated
12615    via ffecom_expr_w.  */
12616
12617 void
12618 ffecom_prepare_expr_w (tree type, ffebld expr)
12619 {
12620   /* This is all we support for now.  */
12621   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12622
12623   /* ~~For now, it seems to be the same thing.  */
12624   ffecom_prepare_expr (expr);
12625   return;
12626 }
12627
12628 /* Prepare expression for returning.
12629
12630    Like ffecom_prepare_expr, except for expressions to be evaluated
12631    via ffecom_return_expr.  */
12632
12633 void
12634 ffecom_prepare_return_expr (ffebld expr)
12635 {
12636   assert (current_binding_level->prep_state < 2);
12637
12638   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12639       && ffecom_is_altreturning_
12640       && expr != NULL)
12641     ffecom_prepare_expr (expr);
12642 }
12643
12644 /* Prepare pointer to expression.
12645
12646    Like ffecom_prepare_expr, except for expressions to be evaluated
12647    via ffecom_ptr_to_expr.  */
12648
12649 void
12650 ffecom_prepare_ptr_to_expr (ffebld expr)
12651 {
12652   /* ~~For now, it seems to be the same thing.  */
12653   ffecom_prepare_expr (expr);
12654   return;
12655 }
12656
12657 /* Transform expression into constant pointer-to-expression tree.
12658
12659    If the expression can be transformed into a pointer-to-expression tree
12660    that is constant, that is done, and the tree returned.  Else NULL_TREE
12661    is returned.
12662
12663    That way, a caller can attempt to provide compile-time initialization
12664    of a variable and, if that fails, *then* choose to start a new block
12665    and resort to using temporaries, as appropriate.  */
12666
12667 tree
12668 ffecom_ptr_to_const_expr (ffebld expr)
12669 {
12670   if (! expr)
12671     return integer_zero_node;
12672
12673   if (ffebld_op (expr) == FFEBLD_opANY)
12674     return error_mark_node;
12675
12676   if (ffebld_arity (expr) == 0
12677       && (ffebld_op (expr) != FFEBLD_opSYMTER
12678           || ffebld_where (expr) == FFEINFO_whereCOMMON
12679           || ffebld_where (expr) == FFEINFO_whereGLOBAL
12680           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12681     {
12682       tree t;
12683
12684       t = ffecom_ptr_to_expr (expr);
12685       assert (TREE_CONSTANT (t));
12686       return t;
12687     }
12688
12689   return NULL_TREE;
12690 }
12691
12692 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12693
12694    tree rtn;  // NULL_TREE means use expand_null_return()
12695    ffebld expr;  // NULL if no alt return expr to RETURN stmt
12696    rtn = ffecom_return_expr(expr);
12697
12698    Based on the program unit type and other info (like return function
12699    type, return master function type when alternate ENTRY points,
12700    whether subroutine has any alternate RETURN points, etc), returns the
12701    appropriate expression to be returned to the caller, or NULL_TREE
12702    meaning no return value or the caller expects it to be returned somewhere
12703    else (which is handled by other parts of this module).  */
12704
12705 tree
12706 ffecom_return_expr (ffebld expr)
12707 {
12708   tree rtn;
12709
12710   switch (ffecom_primary_entry_kind_)
12711     {
12712     case FFEINFO_kindPROGRAM:
12713     case FFEINFO_kindBLOCKDATA:
12714       rtn = NULL_TREE;
12715       break;
12716
12717     case FFEINFO_kindSUBROUTINE:
12718       if (!ffecom_is_altreturning_)
12719         rtn = NULL_TREE;        /* No alt returns, never an expr. */
12720       else if (expr == NULL)
12721         rtn = integer_zero_node;
12722       else
12723         rtn = ffecom_expr (expr);
12724       break;
12725
12726     case FFEINFO_kindFUNCTION:
12727       if ((ffecom_multi_retval_ != NULL_TREE)
12728           || (ffesymbol_basictype (ffecom_primary_entry_)
12729               == FFEINFO_basictypeCHARACTER)
12730           || ((ffesymbol_basictype (ffecom_primary_entry_)
12731                == FFEINFO_basictypeCOMPLEX)
12732               && (ffecom_num_entrypoints_ == 0)
12733               && ffesymbol_is_f2c (ffecom_primary_entry_)))
12734         {                       /* Value is returned by direct assignment
12735                                    into (implicit) dummy. */
12736           rtn = NULL_TREE;
12737           break;
12738         }
12739       rtn = ffecom_func_result_;
12740 #if 0
12741       /* Spurious error if RETURN happens before first reference!  So elide
12742          this code.  In particular, for debugging registry, rtn should always
12743          be non-null after all, but TREE_USED won't be set until we encounter
12744          a reference in the code.  Perfectly okay (but weird) code that,
12745          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12746          this diagnostic for no reason.  Have people use -O -Wuninitialized
12747          and leave it to the back end to find obviously weird cases.  */
12748
12749       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12750          situation; if the return value has never been referenced, it won't
12751          have a tree under 2pass mode. */
12752       if ((rtn == NULL_TREE)
12753           || !TREE_USED (rtn))
12754         {
12755           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
12756           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
12757                        ffesymbol_where_column (ffecom_primary_entry_));
12758           ffebad_string (ffesymbol_text (ffesymbol_funcresult
12759                                          (ffecom_primary_entry_)));
12760           ffebad_finish ();
12761         }
12762 #endif
12763       break;
12764
12765     default:
12766       assert ("bad unit kind" == NULL);
12767     case FFEINFO_kindANY:
12768       rtn = error_mark_node;
12769       break;
12770     }
12771
12772   return rtn;
12773 }
12774
12775 /* Do save_expr only if tree is not error_mark_node.  */
12776
12777 tree
12778 ffecom_save_tree (tree t)
12779 {
12780   return save_expr (t);
12781 }
12782
12783 /* Start a compound statement (block).  */
12784
12785 void
12786 ffecom_start_compstmt (void)
12787 {
12788   bison_rule_pushlevel_ ();
12789 }
12790
12791 /* Public entry point for front end to access start_decl.  */
12792
12793 tree
12794 ffecom_start_decl (tree decl, bool is_initialized)
12795 {
12796   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
12797   return start_decl (decl, FALSE);
12798 }
12799
12800 /* ffecom_sym_commit -- Symbol's state being committed to reality
12801
12802    ffesymbol s;
12803    ffecom_sym_commit(s);
12804
12805    Does whatever the backend needs when a symbol is committed after having
12806    been backtrackable for a period of time.  */
12807
12808 void
12809 ffecom_sym_commit (ffesymbol s UNUSED)
12810 {
12811   assert (!ffesymbol_retractable ());
12812 }
12813
12814 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12815
12816    ffecom_sym_end_transition();
12817
12818    Does backend-specific stuff and also calls ffest_sym_end_transition
12819    to do the necessary FFE stuff.
12820
12821    Backtracking is never enabled when this fn is called, so don't worry
12822    about it.  */
12823
12824 ffesymbol
12825 ffecom_sym_end_transition (ffesymbol s)
12826 {
12827   ffestorag st;
12828
12829   assert (!ffesymbol_retractable ());
12830
12831   s = ffest_sym_end_transition (s);
12832
12833   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
12834       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
12835     {
12836       ffecom_list_blockdata_
12837         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12838                                               FFEINTRIN_specNONE,
12839                                               FFEINTRIN_impNONE),
12840                            ffecom_list_blockdata_);
12841     }
12842
12843   /* This is where we finally notice that a symbol has partial initialization
12844      and finalize it. */
12845
12846   if (ffesymbol_accretion (s) != NULL)
12847     {
12848       assert (ffesymbol_init (s) == NULL);
12849       ffecom_notify_init_symbol (s);
12850     }
12851   else if (((st = ffesymbol_storage (s)) != NULL)
12852            && ((st = ffestorag_parent (st)) != NULL)
12853            && (ffestorag_accretion (st) != NULL))
12854     {
12855       assert (ffestorag_init (st) == NULL);
12856       ffecom_notify_init_storage (st);
12857     }
12858
12859   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
12860       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
12861       && (ffesymbol_storage (s) != NULL))
12862     {
12863       ffecom_list_common_
12864         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12865                                               FFEINTRIN_specNONE,
12866                                               FFEINTRIN_impNONE),
12867                            ffecom_list_common_);
12868     }
12869
12870   return s;
12871 }
12872
12873 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12874
12875    ffecom_sym_exec_transition();
12876
12877    Does backend-specific stuff and also calls ffest_sym_exec_transition
12878    to do the necessary FFE stuff.
12879
12880    See the long-winded description in ffecom_sym_learned for info
12881    on handling the situation where backtracking is inhibited.  */
12882
12883 ffesymbol
12884 ffecom_sym_exec_transition (ffesymbol s)
12885 {
12886   s = ffest_sym_exec_transition (s);
12887
12888   return s;
12889 }
12890
12891 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12892
12893    ffesymbol s;
12894    s = ffecom_sym_learned(s);
12895
12896    Called when a new symbol is seen after the exec transition or when more
12897    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
12898    it arrives here is that all its latest info is updated already, so its
12899    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12900    field filled in if its gone through here or exec_transition first, and
12901    so on.
12902
12903    The backend probably wants to check ffesymbol_retractable() to see if
12904    backtracking is in effect.  If so, the FFE's changes to the symbol may
12905    be retracted (undone) or committed (ratified), at which time the
12906    appropriate ffecom_sym_retract or _commit function will be called
12907    for that function.
12908
12909    If the backend has its own backtracking mechanism, great, use it so that
12910    committal is a simple operation.  Though it doesn't make much difference,
12911    I suppose: the reason for tentative symbol evolution in the FFE is to
12912    enable error detection in weird incorrect statements early and to disable
12913    incorrect error detection on a correct statement.  The backend is not
12914    likely to introduce any information that'll get involved in these
12915    considerations, so it is probably just fine that the implementation
12916    model for this fn and for _exec_transition is to not do anything
12917    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12918    and instead wait until ffecom_sym_commit is called (which it never
12919    will be as long as we're using ambiguity-detecting statement analysis in
12920    the FFE, which we are initially to shake out the code, but don't depend
12921    on this), otherwise go ahead and do whatever is needed.
12922
12923    In essence, then, when this fn and _exec_transition get called while
12924    backtracking is enabled, a general mechanism would be to flag which (or
12925    both) of these were called (and in what order? neat question as to what
12926    might happen that I'm too lame to think through right now) and then when
12927    _commit is called reproduce the original calling sequence, if any, for
12928    the two fns (at which point backtracking will, of course, be disabled).  */
12929
12930 ffesymbol
12931 ffecom_sym_learned (ffesymbol s)
12932 {
12933   ffestorag_exec_layout (s);
12934
12935   return s;
12936 }
12937
12938 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12939
12940    ffesymbol s;
12941    ffecom_sym_retract(s);
12942
12943    Does whatever the backend needs when a symbol is retracted after having
12944    been backtrackable for a period of time.  */
12945
12946 void
12947 ffecom_sym_retract (ffesymbol s UNUSED)
12948 {
12949   assert (!ffesymbol_retractable ());
12950
12951 #if 0                           /* GCC doesn't commit any backtrackable sins,
12952                                    so nothing needed here. */
12953   switch (ffesymbol_hook (s).state)
12954     {
12955     case 0:                     /* nothing happened yet. */
12956       break;
12957
12958     case 1:                     /* exec transition happened. */
12959       break;
12960
12961     case 2:                     /* learned happened. */
12962       break;
12963
12964     case 3:                     /* learned then exec. */
12965       break;
12966
12967     case 4:                     /* exec then learned. */
12968       break;
12969
12970     default:
12971       assert ("bad hook state" == NULL);
12972       break;
12973     }
12974 #endif
12975 }
12976
12977 /* Create temporary gcc label.  */
12978
12979 tree
12980 ffecom_temp_label ()
12981 {
12982   tree glabel;
12983   static int mynumber = 0;
12984
12985   glabel = build_decl (LABEL_DECL,
12986                        ffecom_get_invented_identifier ("__g77_label_%d",
12987                                                        mynumber++),
12988                        void_type_node);
12989   DECL_CONTEXT (glabel) = current_function_decl;
12990   DECL_MODE (glabel) = VOIDmode;
12991
12992   return glabel;
12993 }
12994
12995 /* Return an expression that is usable as an arg in a conditional context
12996    (IF, DO WHILE, .NOT., and so on).
12997
12998    Use the one provided for the back end as of >2.6.0.  */
12999
13000 tree
13001 ffecom_truth_value (tree expr)
13002 {
13003   return truthvalue_conversion (expr);
13004 }
13005
13006 /* Return the inversion of a truth value (the inversion of what
13007    ffecom_truth_value builds).
13008
13009    Apparently invert_truthvalue, which is properly in the back end, is
13010    enough for now, so just use it.  */
13011
13012 tree
13013 ffecom_truth_value_invert (tree expr)
13014 {
13015   return invert_truthvalue (ffecom_truth_value (expr));
13016 }
13017
13018 /* Return the tree that is the type of the expression, as would be
13019    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13020    transforming the expression, generating temporaries, etc.  */
13021
13022 tree
13023 ffecom_type_expr (ffebld expr)
13024 {
13025   ffeinfoBasictype bt;
13026   ffeinfoKindtype kt;
13027   tree tree_type;
13028
13029   assert (expr != NULL);
13030
13031   bt = ffeinfo_basictype (ffebld_info (expr));
13032   kt = ffeinfo_kindtype (ffebld_info (expr));
13033   tree_type = ffecom_tree_type[bt][kt];
13034
13035   switch (ffebld_op (expr))
13036     {
13037     case FFEBLD_opCONTER:
13038     case FFEBLD_opSYMTER:
13039     case FFEBLD_opARRAYREF:
13040     case FFEBLD_opUPLUS:
13041     case FFEBLD_opPAREN:
13042     case FFEBLD_opUMINUS:
13043     case FFEBLD_opADD:
13044     case FFEBLD_opSUBTRACT:
13045     case FFEBLD_opMULTIPLY:
13046     case FFEBLD_opDIVIDE:
13047     case FFEBLD_opPOWER:
13048     case FFEBLD_opNOT:
13049     case FFEBLD_opFUNCREF:
13050     case FFEBLD_opSUBRREF:
13051     case FFEBLD_opAND:
13052     case FFEBLD_opOR:
13053     case FFEBLD_opXOR:
13054     case FFEBLD_opNEQV:
13055     case FFEBLD_opEQV:
13056     case FFEBLD_opCONVERT:
13057     case FFEBLD_opLT:
13058     case FFEBLD_opLE:
13059     case FFEBLD_opEQ:
13060     case FFEBLD_opNE:
13061     case FFEBLD_opGT:
13062     case FFEBLD_opGE:
13063     case FFEBLD_opPERCENT_LOC:
13064       return tree_type;
13065
13066     case FFEBLD_opACCTER:
13067     case FFEBLD_opARRTER:
13068     case FFEBLD_opITEM:
13069     case FFEBLD_opSTAR:
13070     case FFEBLD_opBOUNDS:
13071     case FFEBLD_opREPEAT:
13072     case FFEBLD_opLABTER:
13073     case FFEBLD_opLABTOK:
13074     case FFEBLD_opIMPDO:
13075     case FFEBLD_opCONCATENATE:
13076     case FFEBLD_opSUBSTR:
13077     default:
13078       assert ("bad op for ffecom_type_expr" == NULL);
13079       /* Fall through. */
13080     case FFEBLD_opANY:
13081       return error_mark_node;
13082     }
13083 }
13084
13085 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13086
13087    If the PARM_DECL already exists, return it, else create it.  It's an
13088    integer_type_node argument for the master function that implements a
13089    subroutine or function with more than one entrypoint and is bound at
13090    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13091    first ENTRY statement, and so on).  */
13092
13093 tree
13094 ffecom_which_entrypoint_decl ()
13095 {
13096   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13097
13098   return ffecom_which_entrypoint_decl_;
13099 }
13100 \f
13101 /* The following sections consists of private and public functions
13102    that have the same names and perform roughly the same functions
13103    as counterparts in the C front end.  Changes in the C front end
13104    might affect how things should be done here.  Only functions
13105    needed by the back end should be public here; the rest should
13106    be private (static in the C sense).  Functions needed by other
13107    g77 front-end modules should be accessed by them via public
13108    ffecom_* names, which should themselves call private versions
13109    in this section so the private versions are easy to recognize
13110    when upgrading to a new gcc and finding interesting changes
13111    in the front end.
13112
13113    Functions named after rule "foo:" in c-parse.y are named
13114    "bison_rule_foo_" so they are easy to find.  */
13115
13116 static void
13117 bison_rule_pushlevel_ ()
13118 {
13119   emit_line_note (input_filename, lineno);
13120   pushlevel (0);
13121   clear_last_expr ();
13122   expand_start_bindings (0);
13123 }
13124
13125 static tree
13126 bison_rule_compstmt_ ()
13127 {
13128   tree t;
13129   int keep = kept_level_p ();
13130
13131   /* Make the temps go away.  */
13132   if (! keep)
13133     current_binding_level->names = NULL_TREE;
13134
13135   emit_line_note (input_filename, lineno);
13136   expand_end_bindings (getdecls (), keep, 0);
13137   t = poplevel (keep, 1, 0);
13138
13139   return t;
13140 }
13141
13142 /* Return a definition for a builtin function named NAME and whose data type
13143    is TYPE.  TYPE should be a function type with argument types.
13144    FUNCTION_CODE tells later passes how to compile calls to this function.
13145    See tree.h for its possible values.
13146
13147    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13148    the name to be called if we can't opencode the function.  */
13149
13150 tree
13151 builtin_function (const char *name, tree type, int function_code,
13152                   enum built_in_class class,
13153                   const char *library_name)
13154 {
13155   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13156   DECL_EXTERNAL (decl) = 1;
13157   TREE_PUBLIC (decl) = 1;
13158   if (library_name)
13159     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13160   make_decl_rtl (decl, NULL);
13161   pushdecl (decl);
13162   DECL_BUILT_IN_CLASS (decl) = class;
13163   DECL_FUNCTION_CODE (decl) = function_code;
13164
13165   return decl;
13166 }
13167
13168 /* Handle when a new declaration NEWDECL
13169    has the same name as an old one OLDDECL
13170    in the same binding contour.
13171    Prints an error message if appropriate.
13172
13173    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13174    Otherwise, return 0.  */
13175
13176 static int
13177 duplicate_decls (tree newdecl, tree olddecl)
13178 {
13179   int types_match = 1;
13180   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13181                            && DECL_INITIAL (newdecl) != 0);
13182   tree oldtype = TREE_TYPE (olddecl);
13183   tree newtype = TREE_TYPE (newdecl);
13184
13185   if (olddecl == newdecl)
13186     return 1;
13187
13188   if (TREE_CODE (newtype) == ERROR_MARK
13189       || TREE_CODE (oldtype) == ERROR_MARK)
13190     types_match = 0;
13191
13192   /* New decl is completely inconsistent with the old one =>
13193      tell caller to replace the old one.
13194      This is always an error except in the case of shadowing a builtin.  */
13195   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13196     return 0;
13197
13198   /* For real parm decl following a forward decl,
13199      return 1 so old decl will be reused.  */
13200   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13201       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13202     return 1;
13203
13204   /* The new declaration is the same kind of object as the old one.
13205      The declarations may partially match.  Print warnings if they don't
13206      match enough.  Ultimately, copy most of the information from the new
13207      decl to the old one, and keep using the old one.  */
13208
13209   if (TREE_CODE (olddecl) == FUNCTION_DECL
13210       && DECL_BUILT_IN (olddecl))
13211     {
13212       /* A function declaration for a built-in function.  */
13213       if (!TREE_PUBLIC (newdecl))
13214         return 0;
13215       else if (!types_match)
13216         {
13217           /* Accept the return type of the new declaration if same modes.  */
13218           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13219           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13220
13221           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13222             {
13223               /* Function types may be shared, so we can't just modify
13224                  the return type of olddecl's function type.  */
13225               tree newtype
13226                 = build_function_type (newreturntype,
13227                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13228
13229               types_match = 1;
13230               if (types_match)
13231                 TREE_TYPE (olddecl) = newtype;
13232             }
13233         }
13234       if (!types_match)
13235         return 0;
13236     }
13237   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13238            && DECL_SOURCE_LINE (olddecl) == 0)
13239     {
13240       /* A function declaration for a predeclared function
13241          that isn't actually built in.  */
13242       if (!TREE_PUBLIC (newdecl))
13243         return 0;
13244       else if (!types_match)
13245         {
13246           /* If the types don't match, preserve volatility indication.
13247              Later on, we will discard everything else about the
13248              default declaration.  */
13249           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13250         }
13251     }
13252
13253   /* Copy all the DECL_... slots specified in the new decl
13254      except for any that we copy here from the old type.
13255
13256      Past this point, we don't change OLDTYPE and NEWTYPE
13257      even if we change the types of NEWDECL and OLDDECL.  */
13258
13259   if (types_match)
13260     {
13261       /* Merge the data types specified in the two decls.  */
13262       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13263         TREE_TYPE (newdecl)
13264           = TREE_TYPE (olddecl)
13265             = TREE_TYPE (newdecl);
13266
13267       /* Lay the type out, unless already done.  */
13268       if (oldtype != TREE_TYPE (newdecl))
13269         {
13270           if (TREE_TYPE (newdecl) != error_mark_node)
13271             layout_type (TREE_TYPE (newdecl));
13272           if (TREE_CODE (newdecl) != FUNCTION_DECL
13273               && TREE_CODE (newdecl) != TYPE_DECL
13274               && TREE_CODE (newdecl) != CONST_DECL)
13275             layout_decl (newdecl, 0);
13276         }
13277       else
13278         {
13279           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13280           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13281           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13282           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13283             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13284               {
13285                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13286                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13287               }
13288         }
13289
13290       /* Keep the old rtl since we can safely use it.  */
13291       COPY_DECL_RTL (olddecl, newdecl);
13292
13293       /* Merge the type qualifiers.  */
13294       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13295           && !TREE_THIS_VOLATILE (newdecl))
13296         TREE_THIS_VOLATILE (olddecl) = 0;
13297       if (TREE_READONLY (newdecl))
13298         TREE_READONLY (olddecl) = 1;
13299       if (TREE_THIS_VOLATILE (newdecl))
13300         {
13301           TREE_THIS_VOLATILE (olddecl) = 1;
13302           if (TREE_CODE (newdecl) == VAR_DECL)
13303             make_var_volatile (newdecl);
13304         }
13305
13306       /* Keep source location of definition rather than declaration.
13307          Likewise, keep decl at outer scope.  */
13308       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13309           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13310         {
13311           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13312           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13313
13314           if (DECL_CONTEXT (olddecl) == 0
13315               && TREE_CODE (newdecl) != FUNCTION_DECL)
13316             DECL_CONTEXT (newdecl) = 0;
13317         }
13318
13319       /* Merge the unused-warning information.  */
13320       if (DECL_IN_SYSTEM_HEADER (olddecl))
13321         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13322       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13323         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13324
13325       /* Merge the initialization information.  */
13326       if (DECL_INITIAL (newdecl) == 0)
13327         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13328
13329       /* Merge the section attribute.
13330          We want to issue an error if the sections conflict but that must be
13331          done later in decl_attributes since we are called before attributes
13332          are assigned.  */
13333       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13334         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13335
13336       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13337         {
13338           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13339           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13340         }
13341     }
13342   /* If cannot merge, then use the new type and qualifiers,
13343      and don't preserve the old rtl.  */
13344   else
13345     {
13346       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13347       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13348       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13349       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13350     }
13351
13352   /* Merge the storage class information.  */
13353   /* For functions, static overrides non-static.  */
13354   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13355     {
13356       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13357       /* This is since we don't automatically
13358          copy the attributes of NEWDECL into OLDDECL.  */
13359       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13360       /* If this clears `static', clear it in the identifier too.  */
13361       if (! TREE_PUBLIC (olddecl))
13362         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13363     }
13364   if (DECL_EXTERNAL (newdecl))
13365     {
13366       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13367       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13368       /* An extern decl does not override previous storage class.  */
13369       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13370     }
13371   else
13372     {
13373       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13374       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13375     }
13376
13377   /* If either decl says `inline', this fn is inline,
13378      unless its definition was passed already.  */
13379   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13380     DECL_INLINE (olddecl) = 1;
13381   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13382
13383   /* Get rid of any built-in function if new arg types don't match it
13384      or if we have a function definition.  */
13385   if (TREE_CODE (newdecl) == FUNCTION_DECL
13386       && DECL_BUILT_IN (olddecl)
13387       && (!types_match || new_is_definition))
13388     {
13389       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13390       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13391     }
13392
13393   /* If redeclaring a builtin function, and not a definition,
13394      it stays built in.
13395      Also preserve various other info from the definition.  */
13396   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13397     {
13398       if (DECL_BUILT_IN (olddecl))
13399         {
13400           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13401           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13402         }
13403
13404       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13405       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13406       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13407       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13408     }
13409
13410   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13411      But preserve olddecl's DECL_UID.  */
13412   {
13413     register unsigned olddecl_uid = DECL_UID (olddecl);
13414
13415     memcpy ((char *) olddecl + sizeof (struct tree_common),
13416             (char *) newdecl + sizeof (struct tree_common),
13417             sizeof (struct tree_decl) - sizeof (struct tree_common));
13418     DECL_UID (olddecl) = olddecl_uid;
13419   }
13420
13421   return 1;
13422 }
13423
13424 /* Finish processing of a declaration;
13425    install its initial value.
13426    If the length of an array type is not known before,
13427    it must be determined now, from the initial value, or it is an error.  */
13428
13429 static void
13430 finish_decl (tree decl, tree init, bool is_top_level)
13431 {
13432   register tree type = TREE_TYPE (decl);
13433   int was_incomplete = (DECL_SIZE (decl) == 0);
13434   bool at_top_level = (current_binding_level == global_binding_level);
13435   bool top_level = is_top_level || at_top_level;
13436
13437   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13438      level anyway.  */
13439   assert (!is_top_level || !at_top_level);
13440
13441   if (TREE_CODE (decl) == PARM_DECL)
13442     assert (init == NULL_TREE);
13443   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13444      overlaps DECL_ARG_TYPE.  */
13445   else if (init == NULL_TREE)
13446     assert (DECL_INITIAL (decl) == NULL_TREE);
13447   else
13448     assert (DECL_INITIAL (decl) == error_mark_node);
13449
13450   if (init != NULL_TREE)
13451     {
13452       if (TREE_CODE (decl) != TYPE_DECL)
13453         DECL_INITIAL (decl) = init;
13454       else
13455         {
13456           /* typedef foo = bar; store the type of bar as the type of foo.  */
13457           TREE_TYPE (decl) = TREE_TYPE (init);
13458           DECL_INITIAL (decl) = init = 0;
13459         }
13460     }
13461
13462   /* Deduce size of array from initialization, if not already known */
13463
13464   if (TREE_CODE (type) == ARRAY_TYPE
13465       && TYPE_DOMAIN (type) == 0
13466       && TREE_CODE (decl) != TYPE_DECL)
13467     {
13468       assert (top_level);
13469       assert (was_incomplete);
13470
13471       layout_decl (decl, 0);
13472     }
13473
13474   if (TREE_CODE (decl) == VAR_DECL)
13475     {
13476       if (DECL_SIZE (decl) == NULL_TREE
13477           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13478         layout_decl (decl, 0);
13479
13480       if (DECL_SIZE (decl) == NULL_TREE
13481           && (TREE_STATIC (decl)
13482               ?
13483       /* A static variable with an incomplete type is an error if it is
13484          initialized. Also if it is not file scope. Otherwise, let it
13485          through, but if it is not `extern' then it may cause an error
13486          message later.  */
13487               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13488               :
13489       /* An automatic variable with an incomplete type is an error.  */
13490               !DECL_EXTERNAL (decl)))
13491         {
13492           assert ("storage size not known" == NULL);
13493           abort ();
13494         }
13495
13496       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13497           && (DECL_SIZE (decl) != 0)
13498           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13499         {
13500           assert ("storage size not constant" == NULL);
13501           abort ();
13502         }
13503     }
13504
13505   /* Output the assembler code and/or RTL code for variables and functions,
13506      unless the type is an undefined structure or union. If not, it will get
13507      done when the type is completed.  */
13508
13509   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13510     {
13511       rest_of_decl_compilation (decl, NULL,
13512                                 DECL_CONTEXT (decl) == 0,
13513                                 0);
13514
13515       if (DECL_CONTEXT (decl) != 0)
13516         {
13517           /* Recompute the RTL of a local array now if it used to be an
13518              incomplete type.  */
13519           if (was_incomplete
13520               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13521             {
13522               /* If we used it already as memory, it must stay in memory.  */
13523               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13524               /* If it's still incomplete now, no init will save it.  */
13525               if (DECL_SIZE (decl) == 0)
13526                 DECL_INITIAL (decl) = 0;
13527               expand_decl (decl);
13528             }
13529           /* Compute and store the initial value.  */
13530           if (TREE_CODE (decl) != FUNCTION_DECL)
13531             expand_decl_init (decl);
13532         }
13533     }
13534   else if (TREE_CODE (decl) == TYPE_DECL)
13535     {
13536       rest_of_decl_compilation (decl, NULL,
13537                                 DECL_CONTEXT (decl) == 0,
13538                                 0);
13539     }
13540
13541   /* At the end of a declaration, throw away any variable type sizes of types
13542      defined inside that declaration.  There is no use computing them in the
13543      following function definition.  */
13544   if (current_binding_level == global_binding_level)
13545     get_pending_sizes ();
13546 }
13547
13548 /* Finish up a function declaration and compile that function
13549    all the way to assembler language output.  The free the storage
13550    for the function definition.
13551
13552    This is called after parsing the body of the function definition.
13553
13554    NESTED is nonzero if the function being finished is nested in another.  */
13555
13556 static void
13557 finish_function (int nested)
13558 {
13559   register tree fndecl = current_function_decl;
13560
13561   assert (fndecl != NULL_TREE);
13562   if (TREE_CODE (fndecl) != ERROR_MARK)
13563     {
13564       if (nested)
13565         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13566       else
13567         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13568     }
13569
13570 /*  TREE_READONLY (fndecl) = 1;
13571     This caused &foo to be of type ptr-to-const-function
13572     which then got a warning when stored in a ptr-to-function variable.  */
13573
13574   poplevel (1, 0, 1);
13575
13576   if (TREE_CODE (fndecl) != ERROR_MARK)
13577     {
13578       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13579
13580       /* Must mark the RESULT_DECL as being in this function.  */
13581
13582       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13583
13584       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13585       /* Generate rtl for function exit.  */
13586       expand_function_end (input_filename, lineno, 0);
13587
13588       /* If this is a nested function, protect the local variables in the stack
13589          above us from being collected while we're compiling this function.  */
13590       if (nested)
13591         ggc_push_context ();
13592
13593       /* Run the optimizers and output the assembler code for this function.  */
13594       rest_of_compilation (fndecl);
13595
13596       /* Undo the GC context switch.  */
13597       if (nested)
13598         ggc_pop_context ();
13599     }
13600
13601   if (TREE_CODE (fndecl) != ERROR_MARK
13602       && !nested
13603       && DECL_SAVED_INSNS (fndecl) == 0)
13604     {
13605       /* Stop pointing to the local nodes about to be freed.  */
13606       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13607          function definition.  */
13608       /* For a nested function, this is done in pop_f_function_context.  */
13609       /* If rest_of_compilation set this to 0, leave it 0.  */
13610       if (DECL_INITIAL (fndecl) != 0)
13611         DECL_INITIAL (fndecl) = error_mark_node;
13612       DECL_ARGUMENTS (fndecl) = 0;
13613     }
13614
13615   if (!nested)
13616     {
13617       /* Let the error reporting routines know that we're outside a function.
13618          For a nested function, this value is used in pop_c_function_context
13619          and then reset via pop_function_context.  */
13620       ffecom_outer_function_decl_ = current_function_decl = NULL;
13621     }
13622 }
13623
13624 /* Plug-in replacement for identifying the name of a decl and, for a
13625    function, what we call it in diagnostics.  For now, "program unit"
13626    should suffice, since it's a bit of a hassle to figure out which
13627    of several kinds of things it is.  Note that it could conceivably
13628    be a statement function, which probably isn't really a program unit
13629    per se, but if that comes up, it should be easy to check (being a
13630    nested function and all).  */
13631
13632 static const char *
13633 lang_printable_name (tree decl, int v)
13634 {
13635   /* Just to keep GCC quiet about the unused variable.
13636      In theory, differing values of V should produce different
13637      output.  */
13638   switch (v)
13639     {
13640     default:
13641       if (TREE_CODE (decl) == ERROR_MARK)
13642         return "erroneous code";
13643       return IDENTIFIER_POINTER (DECL_NAME (decl));
13644     }
13645 }
13646
13647 /* g77's function to print out name of current function that caused
13648    an error.  */
13649
13650 static void
13651 lang_print_error_function (diagnostic_context *context __attribute__((unused)),
13652                            const char *file)
13653 {
13654   static ffeglobal last_g = NULL;
13655   static ffesymbol last_s = NULL;
13656   ffeglobal g;
13657   ffesymbol s;
13658   const char *kind;
13659
13660   if ((ffecom_primary_entry_ == NULL)
13661       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
13662     {
13663       g = NULL;
13664       s = NULL;
13665       kind = NULL;
13666     }
13667   else
13668     {
13669       g = ffesymbol_global (ffecom_primary_entry_);
13670       if (ffecom_nested_entry_ == NULL)
13671         {
13672           s = ffecom_primary_entry_;
13673           kind = _(ffeinfo_kind_message (ffesymbol_kind (s)));
13674         }
13675       else
13676         {
13677           s = ffecom_nested_entry_;
13678           kind = _("In statement function");
13679         }
13680     }
13681
13682   if ((last_g != g) || (last_s != s))
13683     {
13684       if (file)
13685         fprintf (stderr, "%s: ", file);
13686
13687       if (s == NULL)
13688         fprintf (stderr, _("Outside of any program unit:\n"));
13689       else
13690         {
13691           const char *name = ffesymbol_text (s);
13692
13693           fprintf (stderr, "%s `%s':\n", kind, name);
13694         }
13695
13696       last_g = g;
13697       last_s = s;
13698     }
13699 }
13700
13701 /* Similar to `lookup_name' but look only at current binding level.  */
13702
13703 static tree
13704 lookup_name_current_level (tree name)
13705 {
13706   register tree t;
13707
13708   if (current_binding_level == global_binding_level)
13709     return IDENTIFIER_GLOBAL_VALUE (name);
13710
13711   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
13712     return 0;
13713
13714   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
13715     if (DECL_NAME (t) == name)
13716       break;
13717
13718   return t;
13719 }
13720
13721 /* Create a new `struct binding_level'.  */
13722
13723 static struct binding_level *
13724 make_binding_level ()
13725 {
13726   /* NOSTRICT */
13727   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
13728 }
13729
13730 /* Save and restore the variables in this file and elsewhere
13731    that keep track of the progress of compilation of the current function.
13732    Used for nested functions.  */
13733
13734 struct f_function
13735 {
13736   struct f_function *next;
13737   tree named_labels;
13738   tree shadowed_labels;
13739   struct binding_level *binding_level;
13740 };
13741
13742 struct f_function *f_function_chain;
13743
13744 /* Restore the variables used during compilation of a C function.  */
13745
13746 static void
13747 pop_f_function_context ()
13748 {
13749   struct f_function *p = f_function_chain;
13750   tree link;
13751
13752   /* Bring back all the labels that were shadowed.  */
13753   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
13754     if (DECL_NAME (TREE_VALUE (link)) != 0)
13755       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
13756         = TREE_VALUE (link);
13757
13758   if (current_function_decl != error_mark_node
13759       && DECL_SAVED_INSNS (current_function_decl) == 0)
13760     {
13761       /* Stop pointing to the local nodes about to be freed.  */
13762       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13763          function definition.  */
13764       DECL_INITIAL (current_function_decl) = error_mark_node;
13765       DECL_ARGUMENTS (current_function_decl) = 0;
13766     }
13767
13768   pop_function_context ();
13769
13770   f_function_chain = p->next;
13771
13772   named_labels = p->named_labels;
13773   shadowed_labels = p->shadowed_labels;
13774   current_binding_level = p->binding_level;
13775
13776   free (p);
13777 }
13778
13779 /* Save and reinitialize the variables
13780    used during compilation of a C function.  */
13781
13782 static void
13783 push_f_function_context ()
13784 {
13785   struct f_function *p
13786   = (struct f_function *) xmalloc (sizeof (struct f_function));
13787
13788   push_function_context ();
13789
13790   p->next = f_function_chain;
13791   f_function_chain = p;
13792
13793   p->named_labels = named_labels;
13794   p->shadowed_labels = shadowed_labels;
13795   p->binding_level = current_binding_level;
13796 }
13797
13798 static void
13799 push_parm_decl (tree parm)
13800 {
13801   int old_immediate_size_expand = immediate_size_expand;
13802
13803   /* Don't try computing parm sizes now -- wait till fn is called.  */
13804
13805   immediate_size_expand = 0;
13806
13807   /* Fill in arg stuff.  */
13808
13809   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
13810   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
13811   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
13812
13813   parm = pushdecl (parm);
13814
13815   immediate_size_expand = old_immediate_size_expand;
13816
13817   finish_decl (parm, NULL_TREE, FALSE);
13818 }
13819
13820 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
13821
13822 static tree
13823 pushdecl_top_level (x)
13824      tree x;
13825 {
13826   register tree t;
13827   register struct binding_level *b = current_binding_level;
13828   register tree f = current_function_decl;
13829
13830   current_binding_level = global_binding_level;
13831   current_function_decl = NULL_TREE;
13832   t = pushdecl (x);
13833   current_binding_level = b;
13834   current_function_decl = f;
13835   return t;
13836 }
13837
13838 /* Store the list of declarations of the current level.
13839    This is done for the parameter declarations of a function being defined,
13840    after they are modified in the light of any missing parameters.  */
13841
13842 static tree
13843 storedecls (decls)
13844      tree decls;
13845 {
13846   return current_binding_level->names = decls;
13847 }
13848
13849 /* Store the parameter declarations into the current function declaration.
13850    This is called after parsing the parameter declarations, before
13851    digesting the body of the function.
13852
13853    For an old-style definition, modify the function's type
13854    to specify at least the number of arguments.  */
13855
13856 static void
13857 store_parm_decls (int is_main_program UNUSED)
13858 {
13859   register tree fndecl = current_function_decl;
13860
13861   if (fndecl == error_mark_node)
13862     return;
13863
13864   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
13865   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
13866
13867   /* Initialize the RTL code for the function.  */
13868
13869   init_function_start (fndecl, input_filename, lineno);
13870
13871   /* Set up parameters and prepare for return, for the function.  */
13872
13873   expand_function_start (fndecl, 0);
13874 }
13875
13876 static tree
13877 start_decl (tree decl, bool is_top_level)
13878 {
13879   register tree tem;
13880   bool at_top_level = (current_binding_level == global_binding_level);
13881   bool top_level = is_top_level || at_top_level;
13882
13883   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13884      level anyway.  */
13885   assert (!is_top_level || !at_top_level);
13886
13887   if (DECL_INITIAL (decl) != NULL_TREE)
13888     {
13889       assert (DECL_INITIAL (decl) == error_mark_node);
13890       assert (!DECL_EXTERNAL (decl));
13891     }
13892   else if (top_level)
13893     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
13894
13895   /* For Fortran, we by default put things in .common when possible.  */
13896   DECL_COMMON (decl) = 1;
13897
13898   /* Add this decl to the current binding level. TEM may equal DECL or it may
13899      be a previous decl of the same name.  */
13900   if (is_top_level)
13901     tem = pushdecl_top_level (decl);
13902   else
13903     tem = pushdecl (decl);
13904
13905   /* For a local variable, define the RTL now.  */
13906   if (!top_level
13907   /* But not if this is a duplicate decl and we preserved the rtl from the
13908      previous one (which may or may not happen).  */
13909       && !DECL_RTL_SET_P (tem))
13910     {
13911       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
13912         expand_decl (tem);
13913       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
13914                && DECL_INITIAL (tem) != 0)
13915         expand_decl (tem);
13916     }
13917
13918   return tem;
13919 }
13920
13921 /* Create the FUNCTION_DECL for a function definition.
13922    DECLSPECS and DECLARATOR are the parts of the declaration;
13923    they describe the function's name and the type it returns,
13924    but twisted together in a fashion that parallels the syntax of C.
13925
13926    This function creates a binding context for the function body
13927    as well as setting up the FUNCTION_DECL in current_function_decl.
13928
13929    Returns 1 on success.  If the DECLARATOR is not suitable for a function
13930    (it defines a datum instead), we return 0, which tells
13931    yyparse to report a parse error.
13932
13933    NESTED is nonzero for a function nested within another function.  */
13934
13935 static void
13936 start_function (tree name, tree type, int nested, int public)
13937 {
13938   tree decl1;
13939   tree restype;
13940   int old_immediate_size_expand = immediate_size_expand;
13941
13942   named_labels = 0;
13943   shadowed_labels = 0;
13944
13945   /* Don't expand any sizes in the return type of the function.  */
13946   immediate_size_expand = 0;
13947
13948   if (nested)
13949     {
13950       assert (!public);
13951       assert (current_function_decl != NULL_TREE);
13952       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
13953     }
13954   else
13955     {
13956       assert (current_function_decl == NULL_TREE);
13957     }
13958
13959   if (TREE_CODE (type) == ERROR_MARK)
13960     decl1 = current_function_decl = error_mark_node;
13961   else
13962     {
13963       decl1 = build_decl (FUNCTION_DECL,
13964                           name,
13965                           type);
13966       TREE_PUBLIC (decl1) = public ? 1 : 0;
13967       if (nested)
13968         DECL_INLINE (decl1) = 1;
13969       TREE_STATIC (decl1) = 1;
13970       DECL_EXTERNAL (decl1) = 0;
13971
13972       announce_function (decl1);
13973
13974       /* Make the init_value nonzero so pushdecl knows this is not tentative.
13975          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
13976       DECL_INITIAL (decl1) = error_mark_node;
13977
13978       /* Record the decl so that the function name is defined. If we already have
13979          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
13980
13981       current_function_decl = pushdecl (decl1);
13982     }
13983
13984   if (!nested)
13985     ffecom_outer_function_decl_ = current_function_decl;
13986
13987   pushlevel (0);
13988   current_binding_level->prep_state = 2;
13989
13990   if (TREE_CODE (current_function_decl) != ERROR_MARK)
13991     {
13992       make_decl_rtl (current_function_decl, NULL);
13993
13994       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
13995       DECL_RESULT (current_function_decl)
13996         = build_decl (RESULT_DECL, NULL_TREE, restype);
13997     }
13998
13999   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14000     TREE_ADDRESSABLE (current_function_decl) = 1;
14001
14002   immediate_size_expand = old_immediate_size_expand;
14003 }
14004 \f
14005 /* Here are the public functions the GNU back end needs.  */
14006
14007 tree
14008 convert (type, expr)
14009      tree type, expr;
14010 {
14011   register tree e = expr;
14012   register enum tree_code code = TREE_CODE (type);
14013
14014   if (type == TREE_TYPE (e)
14015       || TREE_CODE (e) == ERROR_MARK)
14016     return e;
14017   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14018     return fold (build1 (NOP_EXPR, type, e));
14019   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14020       || code == ERROR_MARK)
14021     return error_mark_node;
14022   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14023     {
14024       assert ("void value not ignored as it ought to be" == NULL);
14025       return error_mark_node;
14026     }
14027   if (code == VOID_TYPE)
14028     return build1 (CONVERT_EXPR, type, e);
14029   if ((code != RECORD_TYPE)
14030       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14031     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14032                   e);
14033   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14034     return fold (convert_to_integer (type, e));
14035   if (code == POINTER_TYPE)
14036     return fold (convert_to_pointer (type, e));
14037   if (code == REAL_TYPE)
14038     return fold (convert_to_real (type, e));
14039   if (code == COMPLEX_TYPE)
14040     return fold (convert_to_complex (type, e));
14041   if (code == RECORD_TYPE)
14042     return fold (ffecom_convert_to_complex_ (type, e));
14043
14044   assert ("conversion to non-scalar type requested" == NULL);
14045   return error_mark_node;
14046 }
14047
14048 /* integrate_decl_tree calls this function, but since we don't use the
14049    DECL_LANG_SPECIFIC field, this is a no-op.  */
14050
14051 void
14052 copy_lang_decl (node)
14053      tree node UNUSED;
14054 {
14055 }
14056
14057 /* Return the list of declarations of the current level.
14058    Note that this list is in reverse order unless/until
14059    you nreverse it; and when you do nreverse it, you must
14060    store the result back using `storedecls' or you will lose.  */
14061
14062 tree
14063 getdecls ()
14064 {
14065   return current_binding_level->names;
14066 }
14067
14068 /* Nonzero if we are currently in the global binding level.  */
14069
14070 int
14071 global_bindings_p ()
14072 {
14073   return current_binding_level == global_binding_level;
14074 }
14075
14076 /* Print an error message for invalid use of an incomplete type.
14077    VALUE is the expression that was used (or 0 if that isn't known)
14078    and TYPE is the type that was invalid.  */
14079
14080 void
14081 incomplete_type_error (value, type)
14082      tree value UNUSED;
14083      tree type;
14084 {
14085   if (TREE_CODE (type) == ERROR_MARK)
14086     return;
14087
14088   assert ("incomplete type?!?" == NULL);
14089 }
14090
14091 /* Mark ARG for GC.  */
14092 static void
14093 mark_binding_level (void *arg)
14094 {
14095   struct binding_level *level = *(struct binding_level **) arg;
14096
14097   while (level)
14098     {
14099       ggc_mark_tree (level->names);
14100       ggc_mark_tree (level->blocks);
14101       ggc_mark_tree (level->this_block);
14102       level = level->level_chain;
14103     }
14104 }
14105
14106 static void
14107 ffecom_init_decl_processing ()
14108 {
14109   static tree *const tree_roots[] = {
14110     &current_function_decl,
14111     &string_type_node,
14112     &ffecom_tree_fun_type_void,
14113     &ffecom_integer_zero_node,
14114     &ffecom_integer_one_node,
14115     &ffecom_tree_subr_type,
14116     &ffecom_tree_ptr_to_subr_type,
14117     &ffecom_tree_blockdata_type,
14118     &ffecom_tree_xargc_,
14119     &ffecom_f2c_integer_type_node,
14120     &ffecom_f2c_ptr_to_integer_type_node,
14121     &ffecom_f2c_address_type_node,
14122     &ffecom_f2c_real_type_node,
14123     &ffecom_f2c_ptr_to_real_type_node,
14124     &ffecom_f2c_doublereal_type_node,
14125     &ffecom_f2c_complex_type_node,
14126     &ffecom_f2c_doublecomplex_type_node,
14127     &ffecom_f2c_longint_type_node,
14128     &ffecom_f2c_logical_type_node,
14129     &ffecom_f2c_flag_type_node,
14130     &ffecom_f2c_ftnlen_type_node,
14131     &ffecom_f2c_ftnlen_zero_node,
14132     &ffecom_f2c_ftnlen_one_node,
14133     &ffecom_f2c_ftnlen_two_node,
14134     &ffecom_f2c_ptr_to_ftnlen_type_node,
14135     &ffecom_f2c_ftnint_type_node,
14136     &ffecom_f2c_ptr_to_ftnint_type_node,
14137     &ffecom_outer_function_decl_,
14138     &ffecom_previous_function_decl_,
14139     &ffecom_which_entrypoint_decl_,
14140     &ffecom_float_zero_,
14141     &ffecom_float_half_,
14142     &ffecom_double_zero_,
14143     &ffecom_double_half_,
14144     &ffecom_func_result_,
14145     &ffecom_func_length_,
14146     &ffecom_multi_type_node_,
14147     &ffecom_multi_retval_,
14148     &named_labels,
14149     &shadowed_labels
14150   };
14151   size_t i;
14152
14153   malloc_init ();
14154
14155   /* Record our roots.  */
14156   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14157     ggc_add_tree_root (tree_roots[i], 1);
14158   ggc_add_tree_root (&ffecom_tree_type[0][0],
14159                      FFEINFO_basictype*FFEINFO_kindtype);
14160   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14161                      FFEINFO_basictype*FFEINFO_kindtype);
14162   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14163                      FFEINFO_basictype*FFEINFO_kindtype);
14164   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14165   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14166                 mark_binding_level);
14167   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14168                 mark_binding_level);
14169   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14170
14171   ffe_init_0 ();
14172 }
14173
14174 /* Delete the node BLOCK from the current binding level.
14175    This is used for the block inside a stmt expr ({...})
14176    so that the block can be reinserted where appropriate.  */
14177
14178 static void
14179 delete_block (block)
14180      tree block;
14181 {
14182   tree t;
14183   if (current_binding_level->blocks == block)
14184     current_binding_level->blocks = TREE_CHAIN (block);
14185   for (t = current_binding_level->blocks; t;)
14186     {
14187       if (TREE_CHAIN (t) == block)
14188         TREE_CHAIN (t) = TREE_CHAIN (block);
14189       else
14190         t = TREE_CHAIN (t);
14191     }
14192   TREE_CHAIN (block) = NULL;
14193   /* Clear TREE_USED which is always set by poplevel.
14194      The flag is set again if insert_block is called.  */
14195   TREE_USED (block) = 0;
14196 }
14197
14198 void
14199 insert_block (block)
14200      tree block;
14201 {
14202   TREE_USED (block) = 1;
14203   current_binding_level->blocks
14204     = chainon (current_binding_level->blocks, block);
14205 }
14206
14207 /* Each front end provides its own.  */
14208 static const char *ffe_init PARAMS ((const char *));
14209 static void ffe_finish PARAMS ((void));
14210 static void ffe_init_options PARAMS ((void));
14211 static void ffe_print_identifier PARAMS ((FILE *, tree, int));
14212
14213 #undef  LANG_HOOKS_NAME
14214 #define LANG_HOOKS_NAME                 "GNU F77"
14215 #undef  LANG_HOOKS_INIT
14216 #define LANG_HOOKS_INIT                 ffe_init
14217 #undef  LANG_HOOKS_FINISH
14218 #define LANG_HOOKS_FINISH               ffe_finish
14219 #undef  LANG_HOOKS_INIT_OPTIONS
14220 #define LANG_HOOKS_INIT_OPTIONS         ffe_init_options
14221 #undef  LANG_HOOKS_DECODE_OPTION
14222 #define LANG_HOOKS_DECODE_OPTION        ffe_decode_option
14223 #undef  LANG_HOOKS_PRINT_IDENTIFIER
14224 #define LANG_HOOKS_PRINT_IDENTIFIER     ffe_print_identifier
14225
14226 /* We do not wish to use alias-set based aliasing at all.  Used in the
14227    extreme (every object with its own set, with equivalences recorded) it
14228    might be helpful, but there are problems when it comes to inlining.  We
14229    get on ok with flag_argument_noalias, and alias-set aliasing does
14230    currently limit how stack slots can be reused, which is a lose.  */
14231 #undef LANG_HOOKS_GET_ALIAS_SET
14232 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14233
14234 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
14235
14236 static const char *
14237 ffe_init (filename)
14238      const char *filename;
14239 {
14240   /* Open input file.  */
14241   if (filename == 0 || !strcmp (filename, "-"))
14242     {
14243       finput = stdin;
14244       filename = "stdin";
14245     }
14246   else
14247     finput = fopen (filename, "r");
14248   if (finput == 0)
14249     fatal_io_error ("can't open %s", filename);
14250
14251 #ifdef IO_BUFFER_SIZE
14252   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14253 #endif
14254
14255   ffecom_init_decl_processing ();
14256   decl_printable_name = lang_printable_name;
14257   print_error_function = lang_print_error_function;
14258
14259   /* If the file is output from cpp, it should contain a first line
14260      `# 1 "real-filename"', and the current design of gcc (toplev.c
14261      in particular and the way it sets up information relied on by
14262      INCLUDE) requires that we read this now, and store the
14263      "real-filename" info in master_input_filename.  Ask the lexer
14264      to try doing this.  */
14265   ffelex_hash_kludge (finput);
14266
14267   /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14268      return the new file name.  */
14269   if (main_input_filename)
14270     filename = main_input_filename;
14271
14272   return filename;
14273 }
14274
14275 static void
14276 ffe_finish ()
14277 {
14278   ffe_terminate_0 ();
14279
14280   if (ffe_is_ffedebug ())
14281     malloc_pool_display (malloc_pool_image ());
14282
14283   fclose (finput);
14284 }
14285
14286 static void
14287 ffe_init_options ()
14288 {
14289   /* Set default options for Fortran.  */
14290   flag_move_all_movables = 1;
14291   flag_reduce_all_givs = 1;
14292   flag_argument_noalias = 2;
14293   flag_merge_constants = 2;
14294   flag_errno_math = 0;
14295   flag_complex_divide_method = 1;
14296 }
14297
14298 int
14299 mark_addressable (exp)
14300      tree exp;
14301 {
14302   register tree x = exp;
14303   while (1)
14304     switch (TREE_CODE (x))
14305       {
14306       case ADDR_EXPR:
14307       case COMPONENT_REF:
14308       case ARRAY_REF:
14309         x = TREE_OPERAND (x, 0);
14310         break;
14311
14312       case CONSTRUCTOR:
14313         TREE_ADDRESSABLE (x) = 1;
14314         return 1;
14315
14316       case VAR_DECL:
14317       case CONST_DECL:
14318       case PARM_DECL:
14319       case RESULT_DECL:
14320         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14321             && DECL_NONLOCAL (x))
14322           {
14323             if (TREE_PUBLIC (x))
14324               {
14325                 assert ("address of global register var requested" == NULL);
14326                 return 0;
14327               }
14328             assert ("address of register variable requested" == NULL);
14329           }
14330         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14331           {
14332             if (TREE_PUBLIC (x))
14333               {
14334                 assert ("address of global register var requested" == NULL);
14335                 return 0;
14336               }
14337             assert ("address of register var requested" == NULL);
14338           }
14339         put_var_into_stack (x);
14340
14341         /* drops in */
14342       case FUNCTION_DECL:
14343         TREE_ADDRESSABLE (x) = 1;
14344 #if 0                           /* poplevel deals with this now.  */
14345         if (DECL_CONTEXT (x) == 0)
14346           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14347 #endif
14348
14349       default:
14350         return 1;
14351       }
14352 }
14353
14354 /* If DECL has a cleanup, build and return that cleanup here.
14355    This is a callback called by expand_expr.  */
14356
14357 tree
14358 maybe_build_cleanup (decl)
14359      tree decl UNUSED;
14360 {
14361   /* There are no cleanups in Fortran.  */
14362   return NULL_TREE;
14363 }
14364
14365 /* Exit a binding level.
14366    Pop the level off, and restore the state of the identifier-decl mappings
14367    that were in effect when this level was entered.
14368
14369    If KEEP is nonzero, this level had explicit declarations, so
14370    and create a "block" (a BLOCK node) for the level
14371    to record its declarations and subblocks for symbol table output.
14372
14373    If FUNCTIONBODY is nonzero, this level is the body of a function,
14374    so create a block as if KEEP were set and also clear out all
14375    label names.
14376
14377    If REVERSE is nonzero, reverse the order of decls before putting
14378    them into the BLOCK.  */
14379
14380 tree
14381 poplevel (keep, reverse, functionbody)
14382      int keep;
14383      int reverse;
14384      int functionbody;
14385 {
14386   register tree link;
14387   /* The chain of decls was accumulated in reverse order.
14388      Put it into forward order, just for cleanliness.  */
14389   tree decls;
14390   tree subblocks = current_binding_level->blocks;
14391   tree block = 0;
14392   tree decl;
14393   int block_previously_created;
14394
14395   /* Get the decls in the order they were written.
14396      Usually current_binding_level->names is in reverse order.
14397      But parameter decls were previously put in forward order.  */
14398
14399   if (reverse)
14400     current_binding_level->names
14401       = decls = nreverse (current_binding_level->names);
14402   else
14403     decls = current_binding_level->names;
14404
14405   /* Output any nested inline functions within this block
14406      if they weren't already output.  */
14407
14408   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14409     if (TREE_CODE (decl) == FUNCTION_DECL
14410         && ! TREE_ASM_WRITTEN (decl)
14411         && DECL_INITIAL (decl) != 0
14412         && TREE_ADDRESSABLE (decl))
14413       {
14414         /* If this decl was copied from a file-scope decl
14415            on account of a block-scope extern decl,
14416            propagate TREE_ADDRESSABLE to the file-scope decl.
14417
14418            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14419            true, since then the decl goes through save_for_inline_copying.  */
14420         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14421             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14422           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14423         else if (DECL_SAVED_INSNS (decl) != 0)
14424           {
14425             push_function_context ();
14426             output_inline_function (decl);
14427             pop_function_context ();
14428           }
14429       }
14430
14431   /* If there were any declarations or structure tags in that level,
14432      or if this level is a function body,
14433      create a BLOCK to record them for the life of this function.  */
14434
14435   block = 0;
14436   block_previously_created = (current_binding_level->this_block != 0);
14437   if (block_previously_created)
14438     block = current_binding_level->this_block;
14439   else if (keep || functionbody)
14440     block = make_node (BLOCK);
14441   if (block != 0)
14442     {
14443       BLOCK_VARS (block) = decls;
14444       BLOCK_SUBBLOCKS (block) = subblocks;
14445     }
14446
14447   /* In each subblock, record that this is its superior.  */
14448
14449   for (link = subblocks; link; link = TREE_CHAIN (link))
14450     BLOCK_SUPERCONTEXT (link) = block;
14451
14452   /* Clear out the meanings of the local variables of this level.  */
14453
14454   for (link = decls; link; link = TREE_CHAIN (link))
14455     {
14456       if (DECL_NAME (link) != 0)
14457         {
14458           /* If the ident. was used or addressed via a local extern decl,
14459              don't forget that fact.  */
14460           if (DECL_EXTERNAL (link))
14461             {
14462               if (TREE_USED (link))
14463                 TREE_USED (DECL_NAME (link)) = 1;
14464               if (TREE_ADDRESSABLE (link))
14465                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14466             }
14467           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14468         }
14469     }
14470
14471   /* If the level being exited is the top level of a function,
14472      check over all the labels, and clear out the current
14473      (function local) meanings of their names.  */
14474
14475   if (functionbody)
14476     {
14477       /* If this is the top level block of a function,
14478          the vars are the function's parameters.
14479          Don't leave them in the BLOCK because they are
14480          found in the FUNCTION_DECL instead.  */
14481
14482       BLOCK_VARS (block) = 0;
14483     }
14484
14485   /* Pop the current level, and free the structure for reuse.  */
14486
14487   {
14488     register struct binding_level *level = current_binding_level;
14489     current_binding_level = current_binding_level->level_chain;
14490
14491     level->level_chain = free_binding_level;
14492     free_binding_level = level;
14493   }
14494
14495   /* Dispose of the block that we just made inside some higher level.  */
14496   if (functionbody
14497       && current_function_decl != error_mark_node)
14498     DECL_INITIAL (current_function_decl) = block;
14499   else if (block)
14500     {
14501       if (!block_previously_created)
14502         current_binding_level->blocks
14503           = chainon (current_binding_level->blocks, block);
14504     }
14505   /* If we did not make a block for the level just exited,
14506      any blocks made for inner levels
14507      (since they cannot be recorded as subblocks in that level)
14508      must be carried forward so they will later become subblocks
14509      of something else.  */
14510   else if (subblocks)
14511     current_binding_level->blocks
14512       = chainon (current_binding_level->blocks, subblocks);
14513
14514   if (block)
14515     TREE_USED (block) = 1;
14516   return block;
14517 }
14518
14519 static void
14520 ffe_print_identifier (file, node, indent)
14521      FILE *file;
14522      tree node;
14523      int indent;
14524 {
14525   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14526   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14527 }
14528
14529 /* Record a decl-node X as belonging to the current lexical scope.
14530    Check for errors (such as an incompatible declaration for the same
14531    name already seen in the same scope).
14532
14533    Returns either X or an old decl for the same name.
14534    If an old decl is returned, it may have been smashed
14535    to agree with what X says.  */
14536
14537 tree
14538 pushdecl (x)
14539      tree x;
14540 {
14541   register tree t;
14542   register tree name = DECL_NAME (x);
14543   register struct binding_level *b = current_binding_level;
14544
14545   if ((TREE_CODE (x) == FUNCTION_DECL)
14546       && (DECL_INITIAL (x) == 0)
14547       && DECL_EXTERNAL (x))
14548     DECL_CONTEXT (x) = NULL_TREE;
14549   else
14550     DECL_CONTEXT (x) = current_function_decl;
14551
14552   if (name)
14553     {
14554       if (IDENTIFIER_INVENTED (name))
14555         {
14556           DECL_ARTIFICIAL (x) = 1;
14557           DECL_IN_SYSTEM_HEADER (x) = 1;
14558         }
14559
14560       t = lookup_name_current_level (name);
14561
14562       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14563
14564       /* Don't push non-parms onto list for parms until we understand
14565          why we're doing this and whether it works.  */
14566
14567       assert ((b == global_binding_level)
14568               || !ffecom_transform_only_dummies_
14569               || TREE_CODE (x) == PARM_DECL);
14570
14571       if ((t != NULL_TREE) && duplicate_decls (x, t))
14572         return t;
14573
14574       /* If we are processing a typedef statement, generate a whole new
14575          ..._TYPE node (which will be just an variant of the existing
14576          ..._TYPE node with identical properties) and then install the
14577          TYPE_DECL node generated to represent the typedef name as the
14578          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14579
14580          The whole point here is to end up with a situation where each and every
14581          ..._TYPE node the compiler creates will be uniquely associated with
14582          AT MOST one node representing a typedef name. This way, even though
14583          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14584          (i.e. "typedef name") nodes very early on, later parts of the
14585          compiler can always do the reverse translation and get back the
14586          corresponding typedef name.  For example, given:
14587
14588          typedef struct S MY_TYPE; MY_TYPE object;
14589
14590          Later parts of the compiler might only know that `object' was of type
14591          `struct S' if it were not for code just below.  With this code
14592          however, later parts of the compiler see something like:
14593
14594          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14595
14596          And they can then deduce (from the node for type struct S') that the
14597          original object declaration was:
14598
14599          MY_TYPE object;
14600
14601          Being able to do this is important for proper support of protoize, and
14602          also for generating precise symbolic debugging information which
14603          takes full account of the programmer's (typedef) vocabulary.
14604
14605          Obviously, we don't want to generate a duplicate ..._TYPE node if the
14606          TYPE_DECL node that we are now processing really represents a
14607          standard built-in type.
14608
14609          Since all standard types are effectively declared at line zero in the
14610          source file, we can easily check to see if we are working on a
14611          standard type by checking the current value of lineno.  */
14612
14613       if (TREE_CODE (x) == TYPE_DECL)
14614         {
14615           if (DECL_SOURCE_LINE (x) == 0)
14616             {
14617               if (TYPE_NAME (TREE_TYPE (x)) == 0)
14618                 TYPE_NAME (TREE_TYPE (x)) = x;
14619             }
14620           else if (TREE_TYPE (x) != error_mark_node)
14621             {
14622               tree tt = TREE_TYPE (x);
14623
14624               tt = build_type_copy (tt);
14625               TYPE_NAME (tt) = x;
14626               TREE_TYPE (x) = tt;
14627             }
14628         }
14629
14630       /* This name is new in its binding level. Install the new declaration
14631          and return it.  */
14632       if (b == global_binding_level)
14633         IDENTIFIER_GLOBAL_VALUE (name) = x;
14634       else
14635         IDENTIFIER_LOCAL_VALUE (name) = x;
14636     }
14637
14638   /* Put decls on list in reverse order. We will reverse them later if
14639      necessary.  */
14640   TREE_CHAIN (x) = b->names;
14641   b->names = x;
14642
14643   return x;
14644 }
14645
14646 /* Nonzero if the current level needs to have a BLOCK made.  */
14647
14648 static int
14649 kept_level_p ()
14650 {
14651   tree decl;
14652
14653   for (decl = current_binding_level->names;
14654        decl;
14655        decl = TREE_CHAIN (decl))
14656     {
14657       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
14658           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
14659         /* Currently, there aren't supposed to be non-artificial names
14660            at other than the top block for a function -- they're
14661            believed to always be temps.  But it's wise to check anyway.  */
14662         return 1;
14663     }
14664   return 0;
14665 }
14666
14667 /* Enter a new binding level.
14668    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14669    not for that of tags.  */
14670
14671 void
14672 pushlevel (tag_transparent)
14673      int tag_transparent;
14674 {
14675   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
14676
14677   assert (! tag_transparent);
14678
14679   if (current_binding_level == global_binding_level)
14680     {
14681       named_labels = 0;
14682     }
14683
14684   /* Reuse or create a struct for this binding level.  */
14685
14686   if (free_binding_level)
14687     {
14688       newlevel = free_binding_level;
14689       free_binding_level = free_binding_level->level_chain;
14690     }
14691   else
14692     {
14693       newlevel = make_binding_level ();
14694     }
14695
14696   /* Add this level to the front of the chain (stack) of levels that
14697      are active.  */
14698
14699   *newlevel = clear_binding_level;
14700   newlevel->level_chain = current_binding_level;
14701   current_binding_level = newlevel;
14702 }
14703
14704 /* Set the BLOCK node for the innermost scope
14705    (the one we are currently in).  */
14706
14707 void
14708 set_block (block)
14709      register tree block;
14710 {
14711   current_binding_level->this_block = block;
14712   current_binding_level->names = chainon (current_binding_level->names,
14713                                           BLOCK_VARS (block));
14714   current_binding_level->blocks = chainon (current_binding_level->blocks,
14715                                            BLOCK_SUBBLOCKS (block));
14716 }
14717
14718 tree
14719 signed_or_unsigned_type (unsignedp, type)
14720      int unsignedp;
14721      tree type;
14722 {
14723   tree type2;
14724
14725   if (! INTEGRAL_TYPE_P (type))
14726     return type;
14727   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
14728     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14729   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
14730     return unsignedp ? unsigned_type_node : integer_type_node;
14731   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
14732     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14733   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
14734     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14735   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
14736     return (unsignedp ? long_long_unsigned_type_node
14737             : long_long_integer_type_node);
14738
14739   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
14740   if (type2 == NULL_TREE)
14741     return type;
14742
14743   return type2;
14744 }
14745
14746 tree
14747 signed_type (type)
14748      tree type;
14749 {
14750   tree type1 = TYPE_MAIN_VARIANT (type);
14751   ffeinfoKindtype kt;
14752   tree type2;
14753
14754   if (type1 == unsigned_char_type_node || type1 == char_type_node)
14755     return signed_char_type_node;
14756   if (type1 == unsigned_type_node)
14757     return integer_type_node;
14758   if (type1 == short_unsigned_type_node)
14759     return short_integer_type_node;
14760   if (type1 == long_unsigned_type_node)
14761     return long_integer_type_node;
14762   if (type1 == long_long_unsigned_type_node)
14763     return long_long_integer_type_node;
14764 #if 0   /* gcc/c-* files only */
14765   if (type1 == unsigned_intDI_type_node)
14766     return intDI_type_node;
14767   if (type1 == unsigned_intSI_type_node)
14768     return intSI_type_node;
14769   if (type1 == unsigned_intHI_type_node)
14770     return intHI_type_node;
14771   if (type1 == unsigned_intQI_type_node)
14772     return intQI_type_node;
14773 #endif
14774
14775   type2 = type_for_size (TYPE_PRECISION (type1), 0);
14776   if (type2 != NULL_TREE)
14777     return type2;
14778
14779   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14780     {
14781       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
14782
14783       if (type1 == type2)
14784         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14785     }
14786
14787   return type;
14788 }
14789
14790 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14791    or validate its data type for an `if' or `while' statement or ?..: exp.
14792
14793    This preparation consists of taking the ordinary
14794    representation of an expression expr and producing a valid tree
14795    boolean expression describing whether expr is nonzero.  We could
14796    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14797    but we optimize comparisons, &&, ||, and !.
14798
14799    The resulting type should always be `integer_type_node'.  */
14800
14801 tree
14802 truthvalue_conversion (expr)
14803      tree expr;
14804 {
14805   if (TREE_CODE (expr) == ERROR_MARK)
14806     return expr;
14807
14808 #if 0 /* This appears to be wrong for C++.  */
14809   /* These really should return error_mark_node after 2.4 is stable.
14810      But not all callers handle ERROR_MARK properly.  */
14811   switch (TREE_CODE (TREE_TYPE (expr)))
14812     {
14813     case RECORD_TYPE:
14814       error ("struct type value used where scalar is required");
14815       return integer_zero_node;
14816
14817     case UNION_TYPE:
14818       error ("union type value used where scalar is required");
14819       return integer_zero_node;
14820
14821     case ARRAY_TYPE:
14822       error ("array type value used where scalar is required");
14823       return integer_zero_node;
14824
14825     default:
14826       break;
14827     }
14828 #endif /* 0 */
14829
14830   switch (TREE_CODE (expr))
14831     {
14832       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14833          or comparison expressions as truth values at this level.  */
14834 #if 0
14835     case COMPONENT_REF:
14836       /* A one-bit unsigned bit-field is already acceptable.  */
14837       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
14838           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
14839         return expr;
14840       break;
14841 #endif
14842
14843     case EQ_EXPR:
14844       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14845          or comparison expressions as truth values at this level.  */
14846 #if 0
14847       if (integer_zerop (TREE_OPERAND (expr, 1)))
14848         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
14849 #endif
14850     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
14851     case TRUTH_ANDIF_EXPR:
14852     case TRUTH_ORIF_EXPR:
14853     case TRUTH_AND_EXPR:
14854     case TRUTH_OR_EXPR:
14855     case TRUTH_XOR_EXPR:
14856       TREE_TYPE (expr) = integer_type_node;
14857       return expr;
14858
14859     case ERROR_MARK:
14860       return expr;
14861
14862     case INTEGER_CST:
14863       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
14864
14865     case REAL_CST:
14866       return real_zerop (expr) ? integer_zero_node : integer_one_node;
14867
14868     case ADDR_EXPR:
14869       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
14870         return build (COMPOUND_EXPR, integer_type_node,
14871                       TREE_OPERAND (expr, 0), integer_one_node);
14872       else
14873         return integer_one_node;
14874
14875     case COMPLEX_EXPR:
14876       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
14877                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14878                        integer_type_node,
14879                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
14880                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
14881
14882     case NEGATE_EXPR:
14883     case ABS_EXPR:
14884     case FLOAT_EXPR:
14885     case FFS_EXPR:
14886       /* These don't change whether an object is non-zero or zero.  */
14887       return truthvalue_conversion (TREE_OPERAND (expr, 0));
14888
14889     case LROTATE_EXPR:
14890     case RROTATE_EXPR:
14891       /* These don't change whether an object is zero or non-zero, but
14892          we can't ignore them if their second arg has side-effects.  */
14893       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
14894         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
14895                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
14896       else
14897         return truthvalue_conversion (TREE_OPERAND (expr, 0));
14898
14899     case COND_EXPR:
14900       /* Distribute the conversion into the arms of a COND_EXPR.  */
14901       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
14902                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
14903                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
14904
14905     case CONVERT_EXPR:
14906       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14907          since that affects how `default_conversion' will behave.  */
14908       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
14909           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
14910         break;
14911       /* fall through... */
14912     case NOP_EXPR:
14913       /* If this is widening the argument, we can ignore it.  */
14914       if (TYPE_PRECISION (TREE_TYPE (expr))
14915           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
14916         return truthvalue_conversion (TREE_OPERAND (expr, 0));
14917       break;
14918
14919     case MINUS_EXPR:
14920       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14921          this case.  */
14922       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
14923           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
14924         break;
14925       /* fall through... */
14926     case BIT_XOR_EXPR:
14927       /* This and MINUS_EXPR can be changed into a comparison of the
14928          two objects.  */
14929       if (TREE_TYPE (TREE_OPERAND (expr, 0))
14930           == TREE_TYPE (TREE_OPERAND (expr, 1)))
14931         return ffecom_2 (NE_EXPR, integer_type_node,
14932                          TREE_OPERAND (expr, 0),
14933                          TREE_OPERAND (expr, 1));
14934       return ffecom_2 (NE_EXPR, integer_type_node,
14935                        TREE_OPERAND (expr, 0),
14936                        fold (build1 (NOP_EXPR,
14937                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
14938                                      TREE_OPERAND (expr, 1))));
14939
14940     case BIT_AND_EXPR:
14941       if (integer_onep (TREE_OPERAND (expr, 1)))
14942         return expr;
14943       break;
14944
14945     case MODIFY_EXPR:
14946 #if 0                           /* No such thing in Fortran. */
14947       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
14948         warning ("suggest parentheses around assignment used as truth value");
14949 #endif
14950       break;
14951
14952     default:
14953       break;
14954     }
14955
14956   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
14957     return (ffecom_2
14958             ((TREE_SIDE_EFFECTS (expr)
14959               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14960              integer_type_node,
14961              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
14962                                               TREE_TYPE (TREE_TYPE (expr)),
14963                                               expr)),
14964              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
14965                                               TREE_TYPE (TREE_TYPE (expr)),
14966                                               expr))));
14967
14968   return ffecom_2 (NE_EXPR, integer_type_node,
14969                    expr,
14970                    convert (TREE_TYPE (expr), integer_zero_node));
14971 }
14972
14973 tree
14974 type_for_mode (mode, unsignedp)
14975      enum machine_mode mode;
14976      int unsignedp;
14977 {
14978   int i;
14979   int j;
14980   tree t;
14981
14982   if (mode == TYPE_MODE (integer_type_node))
14983     return unsignedp ? unsigned_type_node : integer_type_node;
14984
14985   if (mode == TYPE_MODE (signed_char_type_node))
14986     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14987
14988   if (mode == TYPE_MODE (short_integer_type_node))
14989     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14990
14991   if (mode == TYPE_MODE (long_integer_type_node))
14992     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14993
14994   if (mode == TYPE_MODE (long_long_integer_type_node))
14995     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
14996
14997 #if HOST_BITS_PER_WIDE_INT >= 64
14998   if (mode == TYPE_MODE (intTI_type_node))
14999     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15000 #endif
15001
15002   if (mode == TYPE_MODE (float_type_node))
15003     return float_type_node;
15004
15005   if (mode == TYPE_MODE (double_type_node))
15006     return double_type_node;
15007
15008   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15009     return build_pointer_type (char_type_node);
15010
15011   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15012     return build_pointer_type (integer_type_node);
15013
15014   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15015     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15016       {
15017         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15018             && (mode == TYPE_MODE (t)))
15019           {
15020             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15021               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15022             else
15023               return t;
15024           }
15025       }
15026
15027   return 0;
15028 }
15029
15030 tree
15031 type_for_size (bits, unsignedp)
15032      unsigned bits;
15033      int unsignedp;
15034 {
15035   ffeinfoKindtype kt;
15036   tree type_node;
15037
15038   if (bits == TYPE_PRECISION (integer_type_node))
15039     return unsignedp ? unsigned_type_node : integer_type_node;
15040
15041   if (bits == TYPE_PRECISION (signed_char_type_node))
15042     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15043
15044   if (bits == TYPE_PRECISION (short_integer_type_node))
15045     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15046
15047   if (bits == TYPE_PRECISION (long_integer_type_node))
15048     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15049
15050   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15051     return (unsignedp ? long_long_unsigned_type_node
15052             : long_long_integer_type_node);
15053
15054   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15055     {
15056       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15057
15058       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15059         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15060           : type_node;
15061     }
15062
15063   return 0;
15064 }
15065
15066 tree
15067 unsigned_type (type)
15068      tree type;
15069 {
15070   tree type1 = TYPE_MAIN_VARIANT (type);
15071   ffeinfoKindtype kt;
15072   tree type2;
15073
15074   if (type1 == signed_char_type_node || type1 == char_type_node)
15075     return unsigned_char_type_node;
15076   if (type1 == integer_type_node)
15077     return unsigned_type_node;
15078   if (type1 == short_integer_type_node)
15079     return short_unsigned_type_node;
15080   if (type1 == long_integer_type_node)
15081     return long_unsigned_type_node;
15082   if (type1 == long_long_integer_type_node)
15083     return long_long_unsigned_type_node;
15084 #if 0   /* gcc/c-* files only */
15085   if (type1 == intDI_type_node)
15086     return unsigned_intDI_type_node;
15087   if (type1 == intSI_type_node)
15088     return unsigned_intSI_type_node;
15089   if (type1 == intHI_type_node)
15090     return unsigned_intHI_type_node;
15091   if (type1 == intQI_type_node)
15092     return unsigned_intQI_type_node;
15093 #endif
15094
15095   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15096   if (type2 != NULL_TREE)
15097     return type2;
15098
15099   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15100     {
15101       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15102
15103       if (type1 == type2)
15104         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15105     }
15106
15107   return type;
15108 }
15109
15110 void
15111 lang_mark_tree (t)
15112      union tree_node *t ATTRIBUTE_UNUSED;
15113 {
15114   if (TREE_CODE (t) == IDENTIFIER_NODE)
15115     {
15116       struct lang_identifier *i = (struct lang_identifier *) t;
15117       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15118       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15119       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15120     }
15121   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15122     ggc_mark (TYPE_LANG_SPECIFIC (t));
15123 }
15124 \f
15125 /* From gcc/cccp.c, the code to handle -I.  */
15126
15127 /* Skip leading "./" from a directory name.
15128    This may yield the empty string, which represents the current directory.  */
15129
15130 static const char *
15131 skip_redundant_dir_prefix (const char *dir)
15132 {
15133   while (dir[0] == '.' && dir[1] == '/')
15134     for (dir += 2; *dir == '/'; dir++)
15135       continue;
15136   if (dir[0] == '.' && !dir[1])
15137     dir++;
15138   return dir;
15139 }
15140
15141 /* The file_name_map structure holds a mapping of file names for a
15142    particular directory.  This mapping is read from the file named
15143    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15144    map filenames on a file system with severe filename restrictions,
15145    such as DOS.  The format of the file name map file is just a series
15146    of lines with two tokens on each line.  The first token is the name
15147    to map, and the second token is the actual name to use.  */
15148
15149 struct file_name_map
15150 {
15151   struct file_name_map *map_next;
15152   char *map_from;
15153   char *map_to;
15154 };
15155
15156 #define FILE_NAME_MAP_FILE "header.gcc"
15157
15158 /* Current maximum length of directory names in the search path
15159    for include files.  (Altered as we get more of them.)  */
15160
15161 static int max_include_len = 0;
15162
15163 struct file_name_list
15164   {
15165     struct file_name_list *next;
15166     char *fname;
15167     /* Mapping of file names for this directory.  */
15168     struct file_name_map *name_map;
15169     /* Non-zero if name_map is valid.  */
15170     int got_name_map;
15171   };
15172
15173 static struct file_name_list *include = NULL;   /* First dir to search */
15174 static struct file_name_list *last_include = NULL;      /* Last in chain */
15175
15176 /* I/O buffer structure.
15177    The `fname' field is nonzero for source files and #include files
15178    and for the dummy text used for -D and -U.
15179    It is zero for rescanning results of macro expansion
15180    and for expanding macro arguments.  */
15181 #define INPUT_STACK_MAX 400
15182 static struct file_buf {
15183   const char *fname;
15184   /* Filename specified with #line command.  */
15185   const char *nominal_fname;
15186   /* Record where in the search path this file was found.
15187      For #include_next.  */
15188   struct file_name_list *dir;
15189   ffewhereLine line;
15190   ffewhereColumn column;
15191 } instack[INPUT_STACK_MAX];
15192
15193 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15194 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15195
15196 /* Current nesting level of input sources.
15197    `instack[indepth]' is the level currently being read.  */
15198 static int indepth = -1;
15199
15200 typedef struct file_buf FILE_BUF;
15201
15202 /* Nonzero means -I- has been seen,
15203    so don't look for #include "foo" the source-file directory.  */
15204 static int ignore_srcdir;
15205
15206 #ifndef INCLUDE_LEN_FUDGE
15207 #define INCLUDE_LEN_FUDGE 0
15208 #endif
15209
15210 static void append_include_chain (struct file_name_list *first,
15211                                   struct file_name_list *last);
15212 static FILE *open_include_file (char *filename,
15213                                 struct file_name_list *searchptr);
15214 static void print_containing_files (ffebadSeverity sev);
15215 static char *read_filename_string (int ch, FILE *f);
15216 static struct file_name_map *read_name_map (const char *dirname);
15217
15218 /* Append a chain of `struct file_name_list's
15219    to the end of the main include chain.
15220    FIRST is the beginning of the chain to append, and LAST is the end.  */
15221
15222 static void
15223 append_include_chain (first, last)
15224      struct file_name_list *first, *last;
15225 {
15226   struct file_name_list *dir;
15227
15228   if (!first || !last)
15229     return;
15230
15231   if (include == 0)
15232     include = first;
15233   else
15234     last_include->next = first;
15235
15236   for (dir = first; ; dir = dir->next) {
15237     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15238     if (len > max_include_len)
15239       max_include_len = len;
15240     if (dir == last)
15241       break;
15242   }
15243
15244   last->next = NULL;
15245   last_include = last;
15246 }
15247
15248 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15249    being tried from the include file search path.  This function maps
15250    filenames on file systems based on information read by
15251    read_name_map.  */
15252
15253 static FILE *
15254 open_include_file (filename, searchptr)
15255      char *filename;
15256      struct file_name_list *searchptr;
15257 {
15258   register struct file_name_map *map;
15259   register char *from;
15260   char *p, *dir;
15261
15262   if (searchptr && ! searchptr->got_name_map)
15263     {
15264       searchptr->name_map = read_name_map (searchptr->fname
15265                                            ? searchptr->fname : ".");
15266       searchptr->got_name_map = 1;
15267     }
15268
15269   /* First check the mapping for the directory we are using.  */
15270   if (searchptr && searchptr->name_map)
15271     {
15272       from = filename;
15273       if (searchptr->fname)
15274         from += strlen (searchptr->fname) + 1;
15275       for (map = searchptr->name_map; map; map = map->map_next)
15276         {
15277           if (! strcmp (map->map_from, from))
15278             {
15279               /* Found a match.  */
15280               return fopen (map->map_to, "r");
15281             }
15282         }
15283     }
15284
15285   /* Try to find a mapping file for the particular directory we are
15286      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15287      in /usr/include/header.gcc and look up types.h in
15288      /usr/include/sys/header.gcc.  */
15289   p = strrchr (filename, '/');
15290 #ifdef DIR_SEPARATOR
15291   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15292   else {
15293     char *tmp = strrchr (filename, DIR_SEPARATOR);
15294     if (tmp != NULL && tmp > p) p = tmp;
15295   }
15296 #endif
15297   if (! p)
15298     p = filename;
15299   if (searchptr
15300       && searchptr->fname
15301       && strlen (searchptr->fname) == (size_t) (p - filename)
15302       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15303     {
15304       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15305       return fopen (filename, "r");
15306     }
15307
15308   if (p == filename)
15309     {
15310       from = filename;
15311       map = read_name_map (".");
15312     }
15313   else
15314     {
15315       dir = (char *) xmalloc (p - filename + 1);
15316       memcpy (dir, filename, p - filename);
15317       dir[p - filename] = '\0';
15318       from = p + 1;
15319       map = read_name_map (dir);
15320       free (dir);
15321     }
15322   for (; map; map = map->map_next)
15323     if (! strcmp (map->map_from, from))
15324       return fopen (map->map_to, "r");
15325
15326   return fopen (filename, "r");
15327 }
15328
15329 /* Print the file names and line numbers of the #include
15330    commands which led to the current file.  */
15331
15332 static void
15333 print_containing_files (ffebadSeverity sev)
15334 {
15335   FILE_BUF *ip = NULL;
15336   int i;
15337   int first = 1;
15338   const char *str1;
15339   const char *str2;
15340
15341   /* If stack of files hasn't changed since we last printed
15342      this info, don't repeat it.  */
15343   if (last_error_tick == input_file_stack_tick)
15344     return;
15345
15346   for (i = indepth; i >= 0; i--)
15347     if (instack[i].fname != NULL) {
15348       ip = &instack[i];
15349       break;
15350     }
15351
15352   /* Give up if we don't find a source file.  */
15353   if (ip == NULL)
15354     return;
15355
15356   /* Find the other, outer source files.  */
15357   for (i--; i >= 0; i--)
15358     if (instack[i].fname != NULL)
15359       {
15360         ip = &instack[i];
15361         if (first)
15362           {
15363             first = 0;
15364             str1 = "In file included";
15365           }
15366         else
15367           {
15368             str1 = "...          ...";
15369           }
15370
15371         if (i == 1)
15372           str2 = ":";
15373         else
15374           str2 = "";
15375
15376         ffebad_start_msg ("%A from %B at %0%C", sev);
15377         ffebad_here (0, ip->line, ip->column);
15378         ffebad_string (str1);
15379         ffebad_string (ip->nominal_fname);
15380         ffebad_string (str2);
15381         ffebad_finish ();
15382       }
15383
15384   /* Record we have printed the status as of this time.  */
15385   last_error_tick = input_file_stack_tick;
15386 }
15387
15388 /* Read a space delimited string of unlimited length from a stdio
15389    file.  */
15390
15391 static char *
15392 read_filename_string (ch, f)
15393      int ch;
15394      FILE *f;
15395 {
15396   char *alloc, *set;
15397   int len;
15398
15399   len = 20;
15400   set = alloc = xmalloc (len + 1);
15401   if (! ISSPACE (ch))
15402     {
15403       *set++ = ch;
15404       while ((ch = getc (f)) != EOF && ! ISSPACE (ch))
15405         {
15406           if (set - alloc == len)
15407             {
15408               len *= 2;
15409               alloc = xrealloc (alloc, len + 1);
15410               set = alloc + len / 2;
15411             }
15412           *set++ = ch;
15413         }
15414     }
15415   *set = '\0';
15416   ungetc (ch, f);
15417   return alloc;
15418 }
15419
15420 /* Read the file name map file for DIRNAME.  */
15421
15422 static struct file_name_map *
15423 read_name_map (dirname)
15424      const char *dirname;
15425 {
15426   /* This structure holds a linked list of file name maps, one per
15427      directory.  */
15428   struct file_name_map_list
15429     {
15430       struct file_name_map_list *map_list_next;
15431       char *map_list_name;
15432       struct file_name_map *map_list_map;
15433     };
15434   static struct file_name_map_list *map_list;
15435   register struct file_name_map_list *map_list_ptr;
15436   char *name;
15437   FILE *f;
15438   size_t dirlen;
15439   int separator_needed;
15440
15441   dirname = skip_redundant_dir_prefix (dirname);
15442
15443   for (map_list_ptr = map_list; map_list_ptr;
15444        map_list_ptr = map_list_ptr->map_list_next)
15445     if (! strcmp (map_list_ptr->map_list_name, dirname))
15446       return map_list_ptr->map_list_map;
15447
15448   map_list_ptr = ((struct file_name_map_list *)
15449                   xmalloc (sizeof (struct file_name_map_list)));
15450   map_list_ptr->map_list_name = xstrdup (dirname);
15451   map_list_ptr->map_list_map = NULL;
15452
15453   dirlen = strlen (dirname);
15454   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15455   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15456   strcpy (name, dirname);
15457   name[dirlen] = '/';
15458   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15459   f = fopen (name, "r");
15460   free (name);
15461   if (!f)
15462     map_list_ptr->map_list_map = NULL;
15463   else
15464     {
15465       int ch;
15466
15467       while ((ch = getc (f)) != EOF)
15468         {
15469           char *from, *to;
15470           struct file_name_map *ptr;
15471
15472           if (ISSPACE (ch))
15473             continue;
15474           from = read_filename_string (ch, f);
15475           while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n')
15476             ;
15477           to = read_filename_string (ch, f);
15478
15479           ptr = ((struct file_name_map *)
15480                  xmalloc (sizeof (struct file_name_map)));
15481           ptr->map_from = from;
15482
15483           /* Make the real filename absolute.  */
15484           if (*to == '/')
15485             ptr->map_to = to;
15486           else
15487             {
15488               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15489               strcpy (ptr->map_to, dirname);
15490               ptr->map_to[dirlen] = '/';
15491               strcpy (ptr->map_to + dirlen + separator_needed, to);
15492               free (to);
15493             }
15494
15495           ptr->map_next = map_list_ptr->map_list_map;
15496           map_list_ptr->map_list_map = ptr;
15497
15498           while ((ch = getc (f)) != '\n')
15499             if (ch == EOF)
15500               break;
15501         }
15502       fclose (f);
15503     }
15504
15505   map_list_ptr->map_list_next = map_list;
15506   map_list = map_list_ptr;
15507
15508   return map_list_ptr->map_list_map;
15509 }
15510
15511 static void
15512 ffecom_file_ (const char *name)
15513 {
15514   FILE_BUF *fp;
15515
15516   /* Do partial setup of input buffer for the sake of generating
15517      early #line directives (when -g is in effect).  */
15518
15519   fp = &instack[++indepth];
15520   memset ((char *) fp, 0, sizeof (FILE_BUF));
15521   if (name == NULL)
15522     name = "";
15523   fp->nominal_fname = fp->fname = name;
15524 }
15525
15526 static void
15527 ffecom_close_include_ (FILE *f)
15528 {
15529   fclose (f);
15530
15531   indepth--;
15532   input_file_stack_tick++;
15533
15534   ffewhere_line_kill (instack[indepth].line);
15535   ffewhere_column_kill (instack[indepth].column);
15536 }
15537
15538 static int
15539 ffecom_decode_include_option_ (char *spec)
15540 {
15541   struct file_name_list *dirtmp;
15542
15543   if (! ignore_srcdir && !strcmp (spec, "-"))
15544     ignore_srcdir = 1;
15545   else
15546     {
15547       dirtmp = (struct file_name_list *)
15548         xmalloc (sizeof (struct file_name_list));
15549       dirtmp->next = 0;         /* New one goes on the end */
15550       dirtmp->fname = spec;
15551       dirtmp->got_name_map = 0;
15552       if (spec[0] == 0)
15553         error ("directory name must immediately follow -I");
15554       else
15555         append_include_chain (dirtmp, dirtmp);
15556     }
15557   return 1;
15558 }
15559
15560 /* Open INCLUDEd file.  */
15561
15562 static FILE *
15563 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
15564 {
15565   char *fbeg = name;
15566   size_t flen = strlen (fbeg);
15567   struct file_name_list *search_start = include; /* Chain of dirs to search */
15568   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
15569   struct file_name_list *searchptr = 0;
15570   char *fname;          /* Dynamically allocated fname buffer */
15571   FILE *f;
15572   FILE_BUF *fp;
15573
15574   if (flen == 0)
15575     return NULL;
15576
15577   dsp[0].fname = NULL;
15578
15579   /* If -I- was specified, don't search current dir, only spec'd ones. */
15580   if (!ignore_srcdir)
15581     {
15582       for (fp = &instack[indepth]; fp >= instack; fp--)
15583         {
15584           int n;
15585           char *ep;
15586           const char *nam;
15587
15588           if ((nam = fp->nominal_fname) != NULL)
15589             {
15590               /* Found a named file.  Figure out dir of the file,
15591                  and put it in front of the search list.  */
15592               dsp[0].next = search_start;
15593               search_start = dsp;
15594 #ifndef VMS
15595               ep = strrchr (nam, '/');
15596 #ifdef DIR_SEPARATOR
15597             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
15598             else {
15599               char *tmp = strrchr (nam, DIR_SEPARATOR);
15600               if (tmp != NULL && tmp > ep) ep = tmp;
15601             }
15602 #endif
15603 #else                           /* VMS */
15604               ep = strrchr (nam, ']');
15605               if (ep == NULL) ep = strrchr (nam, '>');
15606               if (ep == NULL) ep = strrchr (nam, ':');
15607               if (ep != NULL) ep++;
15608 #endif                          /* VMS */
15609               if (ep != NULL)
15610                 {
15611                   n = ep - nam;
15612                   dsp[0].fname = (char *) xmalloc (n + 1);
15613                   strncpy (dsp[0].fname, nam, n);
15614                   dsp[0].fname[n] = '\0';
15615                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
15616                     max_include_len = n + INCLUDE_LEN_FUDGE;
15617                 }
15618               else
15619                 dsp[0].fname = NULL; /* Current directory */
15620               dsp[0].got_name_map = 0;
15621               break;
15622             }
15623         }
15624     }
15625
15626   /* Allocate this permanently, because it gets stored in the definitions
15627      of macros.  */
15628   fname = xmalloc (max_include_len + flen + 4);
15629   /* + 2 above for slash and terminating null.  */
15630   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15631      for g77 yet).  */
15632
15633   /* If specified file name is absolute, just open it.  */
15634
15635   if (*fbeg == '/'
15636 #ifdef DIR_SEPARATOR
15637       || *fbeg == DIR_SEPARATOR
15638 #endif
15639       )
15640     {
15641       strncpy (fname, (char *) fbeg, flen);
15642       fname[flen] = 0;
15643       f = open_include_file (fname, NULL);
15644     }
15645   else
15646     {
15647       f = NULL;
15648
15649       /* Search directory path, trying to open the file.
15650          Copy each filename tried into FNAME.  */
15651
15652       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
15653         {
15654           if (searchptr->fname)
15655             {
15656               /* The empty string in a search path is ignored.
15657                  This makes it possible to turn off entirely
15658                  a standard piece of the list.  */
15659               if (searchptr->fname[0] == 0)
15660                 continue;
15661               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
15662               if (fname[0] && fname[strlen (fname) - 1] != '/')
15663                 strcat (fname, "/");
15664               fname[strlen (fname) + flen] = 0;
15665             }
15666           else
15667             fname[0] = 0;
15668
15669           strncat (fname, fbeg, flen);
15670 #ifdef VMS
15671           /* Change this 1/2 Unix 1/2 VMS file specification into a
15672              full VMS file specification */
15673           if (searchptr->fname && (searchptr->fname[0] != 0))
15674             {
15675               /* Fix up the filename */
15676               hack_vms_include_specification (fname);
15677             }
15678           else
15679             {
15680               /* This is a normal VMS filespec, so use it unchanged.  */
15681               strncpy (fname, (char *) fbeg, flen);
15682               fname[flen] = 0;
15683 #if 0   /* Not for g77.  */
15684               /* if it's '#include filename', add the missing .h */
15685               if (strchr (fname, '.') == NULL)
15686                 strcat (fname, ".h");
15687 #endif
15688             }
15689 #endif /* VMS */
15690           f = open_include_file (fname, searchptr);
15691 #ifdef EACCES
15692           if (f == NULL && errno == EACCES)
15693             {
15694               print_containing_files (FFEBAD_severityWARNING);
15695               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15696                                 FFEBAD_severityWARNING);
15697               ffebad_string (fname);
15698               ffebad_here (0, l, c);
15699               ffebad_finish ();
15700             }
15701 #endif
15702           if (f != NULL)
15703             break;
15704         }
15705     }
15706
15707   if (f == NULL)
15708     {
15709       /* A file that was not found.  */
15710
15711       strncpy (fname, (char *) fbeg, flen);
15712       fname[flen] = 0;
15713       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
15714       ffebad_start (FFEBAD_OPEN_INCLUDE);
15715       ffebad_here (0, l, c);
15716       ffebad_string (fname);
15717       ffebad_finish ();
15718     }
15719
15720   if (dsp[0].fname != NULL)
15721     free (dsp[0].fname);
15722
15723   if (f == NULL)
15724     return NULL;
15725
15726   if (indepth >= (INPUT_STACK_MAX - 1))
15727     {
15728       print_containing_files (FFEBAD_severityFATAL);
15729       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15730                         FFEBAD_severityFATAL);
15731       ffebad_string (fname);
15732       ffebad_here (0, l, c);
15733       ffebad_finish ();
15734       return NULL;
15735     }
15736
15737   instack[indepth].line = ffewhere_line_use (l);
15738   instack[indepth].column = ffewhere_column_use (c);
15739
15740   fp = &instack[indepth + 1];
15741   memset ((char *) fp, 0, sizeof (FILE_BUF));
15742   fp->nominal_fname = fp->fname = fname;
15743   fp->dir = searchptr;
15744
15745   indepth++;
15746   input_file_stack_tick++;
15747
15748   return f;
15749 }
15750
15751 /**INDENT* (Do not reformat this comment even with -fca option.)
15752    Data-gathering files: Given the source file listed below, compiled with
15753    f2c I obtained the output file listed after that, and from the output
15754    file I derived the above code.
15755
15756 -------- (begin input file to f2c)
15757         implicit none
15758         character*10 A1,A2
15759         complex C1,C2
15760         integer I1,I2
15761         real R1,R2
15762         double precision D1,D2
15763 C
15764         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15765 c /
15766         call fooI(I1/I2)
15767         call fooR(R1/I1)
15768         call fooD(D1/I1)
15769         call fooC(C1/I1)
15770         call fooR(R1/R2)
15771         call fooD(R1/D1)
15772         call fooD(D1/D2)
15773         call fooD(D1/R1)
15774         call fooC(C1/C2)
15775         call fooC(C1/R1)
15776         call fooZ(C1/D1)
15777 c **
15778         call fooI(I1**I2)
15779         call fooR(R1**I1)
15780         call fooD(D1**I1)
15781         call fooC(C1**I1)
15782         call fooR(R1**R2)
15783         call fooD(R1**D1)
15784         call fooD(D1**D2)
15785         call fooD(D1**R1)
15786         call fooC(C1**C2)
15787         call fooC(C1**R1)
15788         call fooZ(C1**D1)
15789 c FFEINTRIN_impABS
15790         call fooR(ABS(R1))
15791 c FFEINTRIN_impACOS
15792         call fooR(ACOS(R1))
15793 c FFEINTRIN_impAIMAG
15794         call fooR(AIMAG(C1))
15795 c FFEINTRIN_impAINT
15796         call fooR(AINT(R1))
15797 c FFEINTRIN_impALOG
15798         call fooR(ALOG(R1))
15799 c FFEINTRIN_impALOG10
15800         call fooR(ALOG10(R1))
15801 c FFEINTRIN_impAMAX0
15802         call fooR(AMAX0(I1,I2))
15803 c FFEINTRIN_impAMAX1
15804         call fooR(AMAX1(R1,R2))
15805 c FFEINTRIN_impAMIN0
15806         call fooR(AMIN0(I1,I2))
15807 c FFEINTRIN_impAMIN1
15808         call fooR(AMIN1(R1,R2))
15809 c FFEINTRIN_impAMOD
15810         call fooR(AMOD(R1,R2))
15811 c FFEINTRIN_impANINT
15812         call fooR(ANINT(R1))
15813 c FFEINTRIN_impASIN
15814         call fooR(ASIN(R1))
15815 c FFEINTRIN_impATAN
15816         call fooR(ATAN(R1))
15817 c FFEINTRIN_impATAN2
15818         call fooR(ATAN2(R1,R2))
15819 c FFEINTRIN_impCABS
15820         call fooR(CABS(C1))
15821 c FFEINTRIN_impCCOS
15822         call fooC(CCOS(C1))
15823 c FFEINTRIN_impCEXP
15824         call fooC(CEXP(C1))
15825 c FFEINTRIN_impCHAR
15826         call fooA(CHAR(I1))
15827 c FFEINTRIN_impCLOG
15828         call fooC(CLOG(C1))
15829 c FFEINTRIN_impCONJG
15830         call fooC(CONJG(C1))
15831 c FFEINTRIN_impCOS
15832         call fooR(COS(R1))
15833 c FFEINTRIN_impCOSH
15834         call fooR(COSH(R1))
15835 c FFEINTRIN_impCSIN
15836         call fooC(CSIN(C1))
15837 c FFEINTRIN_impCSQRT
15838         call fooC(CSQRT(C1))
15839 c FFEINTRIN_impDABS
15840         call fooD(DABS(D1))
15841 c FFEINTRIN_impDACOS
15842         call fooD(DACOS(D1))
15843 c FFEINTRIN_impDASIN
15844         call fooD(DASIN(D1))
15845 c FFEINTRIN_impDATAN
15846         call fooD(DATAN(D1))
15847 c FFEINTRIN_impDATAN2
15848         call fooD(DATAN2(D1,D2))
15849 c FFEINTRIN_impDCOS
15850         call fooD(DCOS(D1))
15851 c FFEINTRIN_impDCOSH
15852         call fooD(DCOSH(D1))
15853 c FFEINTRIN_impDDIM
15854         call fooD(DDIM(D1,D2))
15855 c FFEINTRIN_impDEXP
15856         call fooD(DEXP(D1))
15857 c FFEINTRIN_impDIM
15858         call fooR(DIM(R1,R2))
15859 c FFEINTRIN_impDINT
15860         call fooD(DINT(D1))
15861 c FFEINTRIN_impDLOG
15862         call fooD(DLOG(D1))
15863 c FFEINTRIN_impDLOG10
15864         call fooD(DLOG10(D1))
15865 c FFEINTRIN_impDMAX1
15866         call fooD(DMAX1(D1,D2))
15867 c FFEINTRIN_impDMIN1
15868         call fooD(DMIN1(D1,D2))
15869 c FFEINTRIN_impDMOD
15870         call fooD(DMOD(D1,D2))
15871 c FFEINTRIN_impDNINT
15872         call fooD(DNINT(D1))
15873 c FFEINTRIN_impDPROD
15874         call fooD(DPROD(R1,R2))
15875 c FFEINTRIN_impDSIGN
15876         call fooD(DSIGN(D1,D2))
15877 c FFEINTRIN_impDSIN
15878         call fooD(DSIN(D1))
15879 c FFEINTRIN_impDSINH
15880         call fooD(DSINH(D1))
15881 c FFEINTRIN_impDSQRT
15882         call fooD(DSQRT(D1))
15883 c FFEINTRIN_impDTAN
15884         call fooD(DTAN(D1))
15885 c FFEINTRIN_impDTANH
15886         call fooD(DTANH(D1))
15887 c FFEINTRIN_impEXP
15888         call fooR(EXP(R1))
15889 c FFEINTRIN_impIABS
15890         call fooI(IABS(I1))
15891 c FFEINTRIN_impICHAR
15892         call fooI(ICHAR(A1))
15893 c FFEINTRIN_impIDIM
15894         call fooI(IDIM(I1,I2))
15895 c FFEINTRIN_impIDNINT
15896         call fooI(IDNINT(D1))
15897 c FFEINTRIN_impINDEX
15898         call fooI(INDEX(A1,A2))
15899 c FFEINTRIN_impISIGN
15900         call fooI(ISIGN(I1,I2))
15901 c FFEINTRIN_impLEN
15902         call fooI(LEN(A1))
15903 c FFEINTRIN_impLGE
15904         call fooL(LGE(A1,A2))
15905 c FFEINTRIN_impLGT
15906         call fooL(LGT(A1,A2))
15907 c FFEINTRIN_impLLE
15908         call fooL(LLE(A1,A2))
15909 c FFEINTRIN_impLLT
15910         call fooL(LLT(A1,A2))
15911 c FFEINTRIN_impMAX0
15912         call fooI(MAX0(I1,I2))
15913 c FFEINTRIN_impMAX1
15914         call fooI(MAX1(R1,R2))
15915 c FFEINTRIN_impMIN0
15916         call fooI(MIN0(I1,I2))
15917 c FFEINTRIN_impMIN1
15918         call fooI(MIN1(R1,R2))
15919 c FFEINTRIN_impMOD
15920         call fooI(MOD(I1,I2))
15921 c FFEINTRIN_impNINT
15922         call fooI(NINT(R1))
15923 c FFEINTRIN_impSIGN
15924         call fooR(SIGN(R1,R2))
15925 c FFEINTRIN_impSIN
15926         call fooR(SIN(R1))
15927 c FFEINTRIN_impSINH
15928         call fooR(SINH(R1))
15929 c FFEINTRIN_impSQRT
15930         call fooR(SQRT(R1))
15931 c FFEINTRIN_impTAN
15932         call fooR(TAN(R1))
15933 c FFEINTRIN_impTANH
15934         call fooR(TANH(R1))
15935 c FFEINTRIN_imp_CMPLX_C
15936         call fooC(cmplx(C1,C2))
15937 c FFEINTRIN_imp_CMPLX_D
15938         call fooZ(cmplx(D1,D2))
15939 c FFEINTRIN_imp_CMPLX_I
15940         call fooC(cmplx(I1,I2))
15941 c FFEINTRIN_imp_CMPLX_R
15942         call fooC(cmplx(R1,R2))
15943 c FFEINTRIN_imp_DBLE_C
15944         call fooD(dble(C1))
15945 c FFEINTRIN_imp_DBLE_D
15946         call fooD(dble(D1))
15947 c FFEINTRIN_imp_DBLE_I
15948         call fooD(dble(I1))
15949 c FFEINTRIN_imp_DBLE_R
15950         call fooD(dble(R1))
15951 c FFEINTRIN_imp_INT_C
15952         call fooI(int(C1))
15953 c FFEINTRIN_imp_INT_D
15954         call fooI(int(D1))
15955 c FFEINTRIN_imp_INT_I
15956         call fooI(int(I1))
15957 c FFEINTRIN_imp_INT_R
15958         call fooI(int(R1))
15959 c FFEINTRIN_imp_REAL_C
15960         call fooR(real(C1))
15961 c FFEINTRIN_imp_REAL_D
15962         call fooR(real(D1))
15963 c FFEINTRIN_imp_REAL_I
15964         call fooR(real(I1))
15965 c FFEINTRIN_imp_REAL_R
15966         call fooR(real(R1))
15967 c
15968 c FFEINTRIN_imp_INT_D:
15969 c
15970 c FFEINTRIN_specIDINT
15971         call fooI(IDINT(D1))
15972 c
15973 c FFEINTRIN_imp_INT_R:
15974 c
15975 c FFEINTRIN_specIFIX
15976         call fooI(IFIX(R1))
15977 c FFEINTRIN_specINT
15978         call fooI(INT(R1))
15979 c
15980 c FFEINTRIN_imp_REAL_D:
15981 c
15982 c FFEINTRIN_specSNGL
15983         call fooR(SNGL(D1))
15984 c
15985 c FFEINTRIN_imp_REAL_I:
15986 c
15987 c FFEINTRIN_specFLOAT
15988         call fooR(FLOAT(I1))
15989 c FFEINTRIN_specREAL
15990         call fooR(REAL(I1))
15991 c
15992         end
15993 -------- (end input file to f2c)
15994
15995 -------- (begin output from providing above input file as input to:
15996 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
15997 --------     -e "s:^#.*$::g"')
15998
15999 //  -- translated by f2c (version 19950223).
16000    You must link the resulting object file with the libraries:
16001         -lf2c -lm   (in that order)
16002 //
16003
16004
16005 // f2c.h  --  Standard Fortran to C header file //
16006
16007 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16008
16009         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16010
16011
16012
16013
16014 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16015 // we assume short, float are OK //
16016 typedef long int // long int // integer;
16017 typedef char *address;
16018 typedef short int shortint;
16019 typedef float real;
16020 typedef double doublereal;
16021 typedef struct { real r, i; } complex;
16022 typedef struct { doublereal r, i; } doublecomplex;
16023 typedef long int // long int // logical;
16024 typedef short int shortlogical;
16025 typedef char logical1;
16026 typedef char integer1;
16027 // typedef long long longint; // // system-dependent //
16028
16029
16030
16031
16032 // Extern is for use with -E //
16033
16034
16035
16036
16037 // I/O stuff //
16038
16039
16040
16041
16042
16043
16044
16045
16046 typedef long int // int or long int // flag;
16047 typedef long int // int or long int // ftnlen;
16048 typedef long int // int or long int // ftnint;
16049
16050
16051 //external read, write//
16052 typedef struct
16053 {       flag cierr;
16054         ftnint ciunit;
16055         flag ciend;
16056         char *cifmt;
16057         ftnint cirec;
16058 } cilist;
16059
16060 //internal read, write//
16061 typedef struct
16062 {       flag icierr;
16063         char *iciunit;
16064         flag iciend;
16065         char *icifmt;
16066         ftnint icirlen;
16067         ftnint icirnum;
16068 } icilist;
16069
16070 //open//
16071 typedef struct
16072 {       flag oerr;
16073         ftnint ounit;
16074         char *ofnm;
16075         ftnlen ofnmlen;
16076         char *osta;
16077         char *oacc;
16078         char *ofm;
16079         ftnint orl;
16080         char *oblnk;
16081 } olist;
16082
16083 //close//
16084 typedef struct
16085 {       flag cerr;
16086         ftnint cunit;
16087         char *csta;
16088 } cllist;
16089
16090 //rewind, backspace, endfile//
16091 typedef struct
16092 {       flag aerr;
16093         ftnint aunit;
16094 } alist;
16095
16096 // inquire //
16097 typedef struct
16098 {       flag inerr;
16099         ftnint inunit;
16100         char *infile;
16101         ftnlen infilen;
16102         ftnint  *inex;  //parameters in standard's order//
16103         ftnint  *inopen;
16104         ftnint  *innum;
16105         ftnint  *innamed;
16106         char    *inname;
16107         ftnlen  innamlen;
16108         char    *inacc;
16109         ftnlen  inacclen;
16110         char    *inseq;
16111         ftnlen  inseqlen;
16112         char    *indir;
16113         ftnlen  indirlen;
16114         char    *infmt;
16115         ftnlen  infmtlen;
16116         char    *inform;
16117         ftnint  informlen;
16118         char    *inunf;
16119         ftnlen  inunflen;
16120         ftnint  *inrecl;
16121         ftnint  *innrec;
16122         char    *inblank;
16123         ftnlen  inblanklen;
16124 } inlist;
16125
16126
16127
16128 union Multitype {       // for multiple entry points //
16129         integer1 g;
16130         shortint h;
16131         integer i;
16132         // longint j; //
16133         real r;
16134         doublereal d;
16135         complex c;
16136         doublecomplex z;
16137         };
16138
16139 typedef union Multitype Multitype;
16140
16141 typedef long Long;      // No longer used; formerly in Namelist //
16142
16143 struct Vardesc {        // for Namelist //
16144         char *name;
16145         char *addr;
16146         ftnlen *dims;
16147         int  type;
16148         };
16149 typedef struct Vardesc Vardesc;
16150
16151 struct Namelist {
16152         char *name;
16153         Vardesc **vars;
16154         int nvars;
16155         };
16156 typedef struct Namelist Namelist;
16157
16158
16159
16160
16161
16162
16163
16164
16165 // procedure parameter types for -A and -C++ //
16166
16167
16168
16169
16170 typedef int // Unknown procedure type // (*U_fp)();
16171 typedef shortint (*J_fp)();
16172 typedef integer (*I_fp)();
16173 typedef real (*R_fp)();
16174 typedef doublereal (*D_fp)(), (*E_fp)();
16175 typedef // Complex // void  (*C_fp)();
16176 typedef // Double Complex // void  (*Z_fp)();
16177 typedef logical (*L_fp)();
16178 typedef shortlogical (*K_fp)();
16179 typedef // Character // void  (*H_fp)();
16180 typedef // Subroutine // int (*S_fp)();
16181
16182 // E_fp is for real functions when -R is not specified //
16183 typedef void  C_f;      // complex function //
16184 typedef void  H_f;      // character function //
16185 typedef void  Z_f;      // double complex function //
16186 typedef doublereal E_f; // real function with -R not specified //
16187
16188 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16189
16190
16191 // (No such symbols should be defined in a strict ANSI C compiler.
16192    We can avoid trouble with f2c-translated code by using
16193    gcc -ansi [-traditional].) //
16194
16195
16196
16197
16198
16199
16200
16201
16202
16203
16204
16205
16206
16207
16208
16209
16210
16211
16212
16213
16214
16215
16216
16217 // Main program // MAIN__()
16218 {
16219     // System generated locals //
16220     integer i__1;
16221     real r__1, r__2;
16222     doublereal d__1, d__2;
16223     complex q__1;
16224     doublecomplex z__1, z__2, z__3;
16225     logical L__1;
16226     char ch__1[1];
16227
16228     // Builtin functions //
16229     void c_div();
16230     integer pow_ii();
16231     double pow_ri(), pow_di();
16232     void pow_ci();
16233     double pow_dd();
16234     void pow_zz();
16235     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16236             asin(), atan(), atan2(), c_abs();
16237     void c_cos(), c_exp(), c_log(), r_cnjg();
16238     double cos(), cosh();
16239     void c_sin(), c_sqrt();
16240     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16241             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16242     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16243     logical l_ge(), l_gt(), l_le(), l_lt();
16244     integer i_nint();
16245     double r_sign();
16246
16247     // Local variables //
16248     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16249             fool_(), fooz_(), getem_();
16250     static char a1[10], a2[10];
16251     static complex c1, c2;
16252     static doublereal d1, d2;
16253     static integer i1, i2;
16254     static real r1, r2;
16255
16256
16257     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16258 // / //
16259     i__1 = i1 / i2;
16260     fooi_(&i__1);
16261     r__1 = r1 / i1;
16262     foor_(&r__1);
16263     d__1 = d1 / i1;
16264     food_(&d__1);
16265     d__1 = (doublereal) i1;
16266     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16267     fooc_(&q__1);
16268     r__1 = r1 / r2;
16269     foor_(&r__1);
16270     d__1 = r1 / d1;
16271     food_(&d__1);
16272     d__1 = d1 / d2;
16273     food_(&d__1);
16274     d__1 = d1 / r1;
16275     food_(&d__1);
16276     c_div(&q__1, &c1, &c2);
16277     fooc_(&q__1);
16278     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16279     fooc_(&q__1);
16280     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16281     fooz_(&z__1);
16282 // ** //
16283     i__1 = pow_ii(&i1, &i2);
16284     fooi_(&i__1);
16285     r__1 = pow_ri(&r1, &i1);
16286     foor_(&r__1);
16287     d__1 = pow_di(&d1, &i1);
16288     food_(&d__1);
16289     pow_ci(&q__1, &c1, &i1);
16290     fooc_(&q__1);
16291     d__1 = (doublereal) r1;
16292     d__2 = (doublereal) r2;
16293     r__1 = pow_dd(&d__1, &d__2);
16294     foor_(&r__1);
16295     d__2 = (doublereal) r1;
16296     d__1 = pow_dd(&d__2, &d1);
16297     food_(&d__1);
16298     d__1 = pow_dd(&d1, &d2);
16299     food_(&d__1);
16300     d__2 = (doublereal) r1;
16301     d__1 = pow_dd(&d1, &d__2);
16302     food_(&d__1);
16303     z__2.r = c1.r, z__2.i = c1.i;
16304     z__3.r = c2.r, z__3.i = c2.i;
16305     pow_zz(&z__1, &z__2, &z__3);
16306     q__1.r = z__1.r, q__1.i = z__1.i;
16307     fooc_(&q__1);
16308     z__2.r = c1.r, z__2.i = c1.i;
16309     z__3.r = r1, z__3.i = 0.;
16310     pow_zz(&z__1, &z__2, &z__3);
16311     q__1.r = z__1.r, q__1.i = z__1.i;
16312     fooc_(&q__1);
16313     z__2.r = c1.r, z__2.i = c1.i;
16314     z__3.r = d1, z__3.i = 0.;
16315     pow_zz(&z__1, &z__2, &z__3);
16316     fooz_(&z__1);
16317 // FFEINTRIN_impABS //
16318     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16319     foor_(&r__1);
16320 // FFEINTRIN_impACOS //
16321     r__1 = acos(r1);
16322     foor_(&r__1);
16323 // FFEINTRIN_impAIMAG //
16324     r__1 = r_imag(&c1);
16325     foor_(&r__1);
16326 // FFEINTRIN_impAINT //
16327     r__1 = r_int(&r1);
16328     foor_(&r__1);
16329 // FFEINTRIN_impALOG //
16330     r__1 = log(r1);
16331     foor_(&r__1);
16332 // FFEINTRIN_impALOG10 //
16333     r__1 = r_lg10(&r1);
16334     foor_(&r__1);
16335 // FFEINTRIN_impAMAX0 //
16336     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16337     foor_(&r__1);
16338 // FFEINTRIN_impAMAX1 //
16339     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16340     foor_(&r__1);
16341 // FFEINTRIN_impAMIN0 //
16342     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16343     foor_(&r__1);
16344 // FFEINTRIN_impAMIN1 //
16345     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16346     foor_(&r__1);
16347 // FFEINTRIN_impAMOD //
16348     r__1 = r_mod(&r1, &r2);
16349     foor_(&r__1);
16350 // FFEINTRIN_impANINT //
16351     r__1 = r_nint(&r1);
16352     foor_(&r__1);
16353 // FFEINTRIN_impASIN //
16354     r__1 = asin(r1);
16355     foor_(&r__1);
16356 // FFEINTRIN_impATAN //
16357     r__1 = atan(r1);
16358     foor_(&r__1);
16359 // FFEINTRIN_impATAN2 //
16360     r__1 = atan2(r1, r2);
16361     foor_(&r__1);
16362 // FFEINTRIN_impCABS //
16363     r__1 = c_abs(&c1);
16364     foor_(&r__1);
16365 // FFEINTRIN_impCCOS //
16366     c_cos(&q__1, &c1);
16367     fooc_(&q__1);
16368 // FFEINTRIN_impCEXP //
16369     c_exp(&q__1, &c1);
16370     fooc_(&q__1);
16371 // FFEINTRIN_impCHAR //
16372     *(unsigned char *)&ch__1[0] = i1;
16373     fooa_(ch__1, 1L);
16374 // FFEINTRIN_impCLOG //
16375     c_log(&q__1, &c1);
16376     fooc_(&q__1);
16377 // FFEINTRIN_impCONJG //
16378     r_cnjg(&q__1, &c1);
16379     fooc_(&q__1);
16380 // FFEINTRIN_impCOS //
16381     r__1 = cos(r1);
16382     foor_(&r__1);
16383 // FFEINTRIN_impCOSH //
16384     r__1 = cosh(r1);
16385     foor_(&r__1);
16386 // FFEINTRIN_impCSIN //
16387     c_sin(&q__1, &c1);
16388     fooc_(&q__1);
16389 // FFEINTRIN_impCSQRT //
16390     c_sqrt(&q__1, &c1);
16391     fooc_(&q__1);
16392 // FFEINTRIN_impDABS //
16393     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16394     food_(&d__1);
16395 // FFEINTRIN_impDACOS //
16396     d__1 = acos(d1);
16397     food_(&d__1);
16398 // FFEINTRIN_impDASIN //
16399     d__1 = asin(d1);
16400     food_(&d__1);
16401 // FFEINTRIN_impDATAN //
16402     d__1 = atan(d1);
16403     food_(&d__1);
16404 // FFEINTRIN_impDATAN2 //
16405     d__1 = atan2(d1, d2);
16406     food_(&d__1);
16407 // FFEINTRIN_impDCOS //
16408     d__1 = cos(d1);
16409     food_(&d__1);
16410 // FFEINTRIN_impDCOSH //
16411     d__1 = cosh(d1);
16412     food_(&d__1);
16413 // FFEINTRIN_impDDIM //
16414     d__1 = d_dim(&d1, &d2);
16415     food_(&d__1);
16416 // FFEINTRIN_impDEXP //
16417     d__1 = exp(d1);
16418     food_(&d__1);
16419 // FFEINTRIN_impDIM //
16420     r__1 = r_dim(&r1, &r2);
16421     foor_(&r__1);
16422 // FFEINTRIN_impDINT //
16423     d__1 = d_int(&d1);
16424     food_(&d__1);
16425 // FFEINTRIN_impDLOG //
16426     d__1 = log(d1);
16427     food_(&d__1);
16428 // FFEINTRIN_impDLOG10 //
16429     d__1 = d_lg10(&d1);
16430     food_(&d__1);
16431 // FFEINTRIN_impDMAX1 //
16432     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16433     food_(&d__1);
16434 // FFEINTRIN_impDMIN1 //
16435     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16436     food_(&d__1);
16437 // FFEINTRIN_impDMOD //
16438     d__1 = d_mod(&d1, &d2);
16439     food_(&d__1);
16440 // FFEINTRIN_impDNINT //
16441     d__1 = d_nint(&d1);
16442     food_(&d__1);
16443 // FFEINTRIN_impDPROD //
16444     d__1 = (doublereal) r1 * r2;
16445     food_(&d__1);
16446 // FFEINTRIN_impDSIGN //
16447     d__1 = d_sign(&d1, &d2);
16448     food_(&d__1);
16449 // FFEINTRIN_impDSIN //
16450     d__1 = sin(d1);
16451     food_(&d__1);
16452 // FFEINTRIN_impDSINH //
16453     d__1 = sinh(d1);
16454     food_(&d__1);
16455 // FFEINTRIN_impDSQRT //
16456     d__1 = sqrt(d1);
16457     food_(&d__1);
16458 // FFEINTRIN_impDTAN //
16459     d__1 = tan(d1);
16460     food_(&d__1);
16461 // FFEINTRIN_impDTANH //
16462     d__1 = tanh(d1);
16463     food_(&d__1);
16464 // FFEINTRIN_impEXP //
16465     r__1 = exp(r1);
16466     foor_(&r__1);
16467 // FFEINTRIN_impIABS //
16468     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16469     fooi_(&i__1);
16470 // FFEINTRIN_impICHAR //
16471     i__1 = *(unsigned char *)a1;
16472     fooi_(&i__1);
16473 // FFEINTRIN_impIDIM //
16474     i__1 = i_dim(&i1, &i2);
16475     fooi_(&i__1);
16476 // FFEINTRIN_impIDNINT //
16477     i__1 = i_dnnt(&d1);
16478     fooi_(&i__1);
16479 // FFEINTRIN_impINDEX //
16480     i__1 = i_indx(a1, a2, 10L, 10L);
16481     fooi_(&i__1);
16482 // FFEINTRIN_impISIGN //
16483     i__1 = i_sign(&i1, &i2);
16484     fooi_(&i__1);
16485 // FFEINTRIN_impLEN //
16486     i__1 = i_len(a1, 10L);
16487     fooi_(&i__1);
16488 // FFEINTRIN_impLGE //
16489     L__1 = l_ge(a1, a2, 10L, 10L);
16490     fool_(&L__1);
16491 // FFEINTRIN_impLGT //
16492     L__1 = l_gt(a1, a2, 10L, 10L);
16493     fool_(&L__1);
16494 // FFEINTRIN_impLLE //
16495     L__1 = l_le(a1, a2, 10L, 10L);
16496     fool_(&L__1);
16497 // FFEINTRIN_impLLT //
16498     L__1 = l_lt(a1, a2, 10L, 10L);
16499     fool_(&L__1);
16500 // FFEINTRIN_impMAX0 //
16501     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16502     fooi_(&i__1);
16503 // FFEINTRIN_impMAX1 //
16504     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16505     fooi_(&i__1);
16506 // FFEINTRIN_impMIN0 //
16507     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16508     fooi_(&i__1);
16509 // FFEINTRIN_impMIN1 //
16510     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16511     fooi_(&i__1);
16512 // FFEINTRIN_impMOD //
16513     i__1 = i1 % i2;
16514     fooi_(&i__1);
16515 // FFEINTRIN_impNINT //
16516     i__1 = i_nint(&r1);
16517     fooi_(&i__1);
16518 // FFEINTRIN_impSIGN //
16519     r__1 = r_sign(&r1, &r2);
16520     foor_(&r__1);
16521 // FFEINTRIN_impSIN //
16522     r__1 = sin(r1);
16523     foor_(&r__1);
16524 // FFEINTRIN_impSINH //
16525     r__1 = sinh(r1);
16526     foor_(&r__1);
16527 // FFEINTRIN_impSQRT //
16528     r__1 = sqrt(r1);
16529     foor_(&r__1);
16530 // FFEINTRIN_impTAN //
16531     r__1 = tan(r1);
16532     foor_(&r__1);
16533 // FFEINTRIN_impTANH //
16534     r__1 = tanh(r1);
16535     foor_(&r__1);
16536 // FFEINTRIN_imp_CMPLX_C //
16537     r__1 = c1.r;
16538     r__2 = c2.r;
16539     q__1.r = r__1, q__1.i = r__2;
16540     fooc_(&q__1);
16541 // FFEINTRIN_imp_CMPLX_D //
16542     z__1.r = d1, z__1.i = d2;
16543     fooz_(&z__1);
16544 // FFEINTRIN_imp_CMPLX_I //
16545     r__1 = (real) i1;
16546     r__2 = (real) i2;
16547     q__1.r = r__1, q__1.i = r__2;
16548     fooc_(&q__1);
16549 // FFEINTRIN_imp_CMPLX_R //
16550     q__1.r = r1, q__1.i = r2;
16551     fooc_(&q__1);
16552 // FFEINTRIN_imp_DBLE_C //
16553     d__1 = (doublereal) c1.r;
16554     food_(&d__1);
16555 // FFEINTRIN_imp_DBLE_D //
16556     d__1 = d1;
16557     food_(&d__1);
16558 // FFEINTRIN_imp_DBLE_I //
16559     d__1 = (doublereal) i1;
16560     food_(&d__1);
16561 // FFEINTRIN_imp_DBLE_R //
16562     d__1 = (doublereal) r1;
16563     food_(&d__1);
16564 // FFEINTRIN_imp_INT_C //
16565     i__1 = (integer) c1.r;
16566     fooi_(&i__1);
16567 // FFEINTRIN_imp_INT_D //
16568     i__1 = (integer) d1;
16569     fooi_(&i__1);
16570 // FFEINTRIN_imp_INT_I //
16571     i__1 = i1;
16572     fooi_(&i__1);
16573 // FFEINTRIN_imp_INT_R //
16574     i__1 = (integer) r1;
16575     fooi_(&i__1);
16576 // FFEINTRIN_imp_REAL_C //
16577     r__1 = c1.r;
16578     foor_(&r__1);
16579 // FFEINTRIN_imp_REAL_D //
16580     r__1 = (real) d1;
16581     foor_(&r__1);
16582 // FFEINTRIN_imp_REAL_I //
16583     r__1 = (real) i1;
16584     foor_(&r__1);
16585 // FFEINTRIN_imp_REAL_R //
16586     r__1 = r1;
16587     foor_(&r__1);
16588
16589 // FFEINTRIN_imp_INT_D: //
16590
16591 // FFEINTRIN_specIDINT //
16592     i__1 = (integer) d1;
16593     fooi_(&i__1);
16594
16595 // FFEINTRIN_imp_INT_R: //
16596
16597 // FFEINTRIN_specIFIX //
16598     i__1 = (integer) r1;
16599     fooi_(&i__1);
16600 // FFEINTRIN_specINT //
16601     i__1 = (integer) r1;
16602     fooi_(&i__1);
16603
16604 // FFEINTRIN_imp_REAL_D: //
16605
16606 // FFEINTRIN_specSNGL //
16607     r__1 = (real) d1;
16608     foor_(&r__1);
16609
16610 // FFEINTRIN_imp_REAL_I: //
16611
16612 // FFEINTRIN_specFLOAT //
16613     r__1 = (real) i1;
16614     foor_(&r__1);
16615 // FFEINTRIN_specREAL //
16616     r__1 = (real) i1;
16617     foor_(&r__1);
16618
16619 } // MAIN__ //
16620
16621 -------- (end output file from f2c)
16622
16623 */