gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995-1997 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU Fortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.
  21
  22    Related Modules:
  23       None
  24
  25    Description:
  26       Contains compiler-specific functions.
  27
  28    Modifications:
  29 */
  30
  31 /* Understanding this module means understanding the interface between
  32    the g77 front end and the gcc back end (or, perhaps, some other
  33    back end).  In here are the functions called by the front end proper
  34    to notify whatever back end is in place about certain things, and
  35    also the back-end-specific functions.  It's a bear to deal with, so
  36    lately I've been trying to simplify things, especially with regard
  37    to the gcc-back-end-specific stuff.
  38
  39    Building expressions generally seems quite easy, but building decls
  40    has been challenging and is undergoing revision.  gcc has several
  41    kinds of decls:
  42
  43    TYPE_DECL -- a type (int, float, struct, function, etc.)
  44    CONST_DECL -- a constant of some type other than function
  45    LABEL_DECL -- a variable or a constant?
  46    PARM_DECL -- an argument to a function (a variable that is a dummy)
  47    RESULT_DECL -- the return value of a function (a variable)
  48    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
  49    FUNCTION_DECL -- a function (either the actual function or an extern ref)
  50    FIELD_DECL -- a field in a struct or union (goes into types)
  51
  52    g77 has a set of functions that somewhat parallels the gcc front end
  53    when it comes to building decls:
  54
  55    Internal Function (one we define, not just declare as extern):
  56    int yes;
  57    yes = suspend_momentary ();
  58    if (is_nested) push_f_function_context ();
  59    start_function (get_identifier ("function_name"), function_type,
  60                    is_nested, is_public);
  61    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  62    store_parm_decls (is_main_program);
  63    ffecom_start_compstmt_ ();
  64    // for stmts and decls inside function, do appropriate things;
  65    ffecom_end_compstmt_ ();
  66    finish_function (is_nested);
  67    if (is_nested) pop_f_function_context ();
  68    if (is_nested) resume_momentary (yes);
  69
  70    Everything Else:
  71    int yes;
  72    tree d;
  73    tree init;
  74    yes = suspend_momentary ();
  75    // fill in external, public, static, &c for decl, and
  76    // set DECL_INITIAL to error_mark_node if going to initialize
  77    // set is_top_level TRUE only if not at top level and decl
  78    // must go in top level (i.e. not within current function decl context)
  79    d = start_decl (decl, is_top_level);
  80    init = ...;  // if have initializer
  81    finish_decl (d, init, is_top_level);
  82    resume_momentary (yes);
  83
  84 */
  85
  86 /* Include files. */
  87
  88 #if FFECOM_targetCURRENT == FFECOM_targetGCC
  89 #include "config.j"
  90 #include "flags.j"
  91 #include "rtl.j"
  92 #include "tree.j"
  93 #include "convert.j"
  94 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
  95
  96 #define FFECOM_GCC_INCLUDE 1    /* Enable -I. */
  97
  98 /* BEGIN stuff from gcc/cccp.c.  */
  99
 100 /* The following symbols should be autoconfigured:
 101         HAVE_FCNTL_H
 102         HAVE_STDLIB_H
 103         HAVE_SYS_TIME_H
 104         HAVE_UNISTD_H
 105         STDC_HEADERS
 106         TIME_WITH_SYS_TIME
 107    In the mean time, we'll get by with approximations based
 108    on existing GCC configuration symbols.  */
 109
 110 #ifdef POSIX
 111 # ifndef HAVE_STDLIB_H
 112 # define HAVE_STDLIB_H 1
 113 # endif
 114 # ifndef HAVE_UNISTD_H
 115 # define HAVE_UNISTD_H 1
 116 # endif
 117 # ifndef STDC_HEADERS
 118 # define STDC_HEADERS 1
 119 # endif
 120 #endif /* defined (POSIX) */
 121
 122 #if defined (POSIX) || (defined (USG) && !defined (VMS))
 123 # ifndef HAVE_FCNTL_H
 124 # define HAVE_FCNTL_H 1
 125 # endif
 126 #endif
 127
 128 #ifndef RLIMIT_STACK
 129 # include <time.h>
 130 #else
 131 # if TIME_WITH_SYS_TIME
 132 #  include <sys/time.h>
 133 #  include <time.h>
 134 # else
 135 #  if HAVE_SYS_TIME_H
 136 #   include <sys/time.h>
 137 #  else
 138 #   include <time.h>
 139 #  endif
 140 # endif
 141 # include <sys/resource.h>
 142 #endif
 143
 144 #if HAVE_FCNTL_H
 145 # include <fcntl.h>
 146 #endif
 147
 148 /* This defines "errno" properly for VMS, and gives us EACCES. */
 149 #include <errno.h>
 150
 151 #if HAVE_STDLIB_H
 152 # include <stdlib.h>
 153 #else
 154 char *getenv ();
 155 #endif
 156
 157 char *index ();
 158 char *rindex ();
 159
 160 #if HAVE_UNISTD_H
 161 # include <unistd.h>
 162 #endif
 163
 164 /* VMS-specific definitions */
 165 #ifdef VMS
 166 #include <descrip.h>
 167 #define O_RDONLY        0       /* Open arg for Read/Only  */
 168 #define O_WRONLY        1       /* Open arg for Write/Only */
 169 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 170 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 171 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 172 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 173 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 174 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 175 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 176 static int VMS_fstat (), VMS_stat ();
 177 static char * VMS_strncat ();
 178 static int VMS_read ();
 179 static int VMS_write ();
 180 static int VMS_open ();
 181 static FILE * VMS_fopen ();
 182 static FILE * VMS_freopen ();
 183 static void hack_vms_include_specification ();
 184 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 185 #define ino_t vms_ino_t
 186 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 187 #ifdef __GNUC__
 188 #define BSTRING                 /* VMS/GCC supplies the bstring routines */
 189 #endif /* __GNUC__ */
 190 #endif /* VMS */
 191
 192 #ifndef O_RDONLY
 193 #define O_RDONLY 0
 194 #endif
 195
 196 /* END stuff from gcc/cccp.c.  */
 197
 198 #include "proj.h"
 199 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 200 #include "com.h"
 201 #include "bad.h"
 202 #include "bld.h"
 203 #include "equiv.h"
 204 #include "expr.h"
 205 #include "implic.h"
 206 #include "info.h"
 207 #include "malloc.h"
 208 #include "src.h"
 209 #include "st.h"
 210 #include "storag.h"
 211 #include "symbol.h"
 212 #include "target.h"
 213 #include "top.h"
 214 #include "type.h"
 215
 216 /* Externals defined here.  */
 217
 218 #define FFECOM_FASTER_ARRAY_REFS 0      /* Generates faster code? */
 219
 220 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 221
 222 /* tree.h declares a bunch of stuff that it expects the front end to
 223    define.  Here are the definitions, which in the C front end are
 224    found in the file c-decl.c.  */
 225
 226 tree integer_zero_node;
 227 tree integer_one_node;
 228 tree null_pointer_node;
 229 tree error_mark_node;
 230 tree void_type_node;
 231 tree integer_type_node;
 232 tree unsigned_type_node;
 233 tree char_type_node;
 234 tree current_function_decl;
 235
 236 /* ~~tree.h SHOULD declare this, because toplev.c and dwarfout.c reference
 237    it.  */
 238
 239 char *language_string = "GNU F77";
 240
 241 /* These definitions parallel those in c-decl.c so that code from that
 242    module can be used pretty much as is.  Much of these defs aren't
 243    otherwise used, i.e. by g77 code per se, except some of them are used
 244    to build some of them that are.  The ones that are global (i.e. not
 245    "static") are those that ste.c and such might use (directly
 246    or by using com macros that reference them in their definitions).  */
 247
 248 static tree short_integer_type_node;
 249 tree long_integer_type_node;
 250 static tree long_long_integer_type_node;
 251
 252 static tree short_unsigned_type_node;
 253 static tree long_unsigned_type_node;
 254 static tree long_long_unsigned_type_node;
 255
 256 static tree unsigned_char_type_node;
 257 static tree signed_char_type_node;
 258
 259 static tree float_type_node;
 260 static tree double_type_node;
 261 static tree complex_float_type_node;
 262 tree complex_double_type_node;
 263 static tree long_double_type_node;
 264 static tree complex_integer_type_node;
 265 static tree complex_long_double_type_node;
 266
 267 tree string_type_node;
 268
 269 static tree double_ftype_double;
 270 static tree float_ftype_float;
 271 static tree ldouble_ftype_ldouble;
 272
 273 /* The rest of these are inventions for g77, though there might be
 274    similar things in the C front end.  As they are found, these
 275    inventions should be renamed to be canonical.  Note that only
 276    the ones currently required to be global are so.  */
 277
 278 static tree ffecom_tree_fun_type_void;
 279 static tree ffecom_tree_ptr_to_fun_type_void;
 280
 281 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 282 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 283 tree ffecom_integer_one_node;   /* " */
 284 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 285
 286 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 287    just use build_function_type and build_pointer_type on the
 288    appropriate _tree_type array element.  */
 289
 290 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 291 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 292 static tree ffecom_tree_subr_type;
 293 static tree ffecom_tree_ptr_to_subr_type;
 294 static tree ffecom_tree_blockdata_type;
 295
 296 static tree ffecom_tree_xargc_;
 297
 298 ffecomSymbol ffecom_symbol_null_
 299 =
 300 {
 301   NULL_TREE,
 302   NULL_TREE,
 303   NULL_TREE,
 304 };
 305 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 306 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 307
 308 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 309 tree ffecom_f2c_integer_type_node;
 310 tree ffecom_f2c_ptr_to_integer_type_node;
 311 tree ffecom_f2c_address_type_node;
 312 tree ffecom_f2c_real_type_node;
 313 tree ffecom_f2c_ptr_to_real_type_node;
 314 tree ffecom_f2c_doublereal_type_node;
 315 tree ffecom_f2c_complex_type_node;
 316 tree ffecom_f2c_doublecomplex_type_node;
 317 tree ffecom_f2c_longint_type_node;
 318 tree ffecom_f2c_logical_type_node;
 319 tree ffecom_f2c_flag_type_node;
 320 tree ffecom_f2c_ftnlen_type_node;
 321 tree ffecom_f2c_ftnlen_zero_node;
 322 tree ffecom_f2c_ftnlen_one_node;
 323 tree ffecom_f2c_ftnlen_two_node;
 324 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 325 tree ffecom_f2c_ftnint_type_node;
 326 tree ffecom_f2c_ptr_to_ftnint_type_node;
 327 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 328
 329 /* Simple definitions and enumerations. */
 330
 331 #ifndef FFECOM_sizeMAXSTACKITEM
 332 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 333                                            larger than this # bytes
 334                                            off stack if possible. */
 335 #endif
 336
 337 /* For systems that have large enough stacks, they should define
 338    this to 0, and here, for ease of use later on, we just undefine
 339    it if it is 0.  */
 340
 341 #if FFECOM_sizeMAXSTACKITEM == 0
 342 #undef FFECOM_sizeMAXSTACKITEM
 343 #endif
 344
 345 typedef enum
 346   {
 347     FFECOM_rttypeVOID_,
 348     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 349     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 350     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 351     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 352     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 353     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 354     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 355     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 356     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 357     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 358     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 359     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 360     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 361     FFECOM_rttype_
 362   } ffecomRttype_;
 363
 364 /* Internal typedefs. */
 365
 366 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 367 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 368 typedef struct _ffecom_temp_ *ffecomTemp_;
 369 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 370
 371 /* Private include files. */
 372
 373
 374 /* Internal structure definitions. */
 375
 376 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 377 struct _ffecom_concat_list_
 378   {
 379     ffebld *exprs;
 380     int count;
 381     int max;
 382     ffetargetCharacterSize minlen;
 383     ffetargetCharacterSize maxlen;
 384   };
 385
 386 struct _ffecom_temp_
 387   {
 388     ffecomTemp_ next;
 389     tree type;                  /* Base type (w/o size/array applied). */
 390     tree t;
 391     ffetargetCharacterSize size;
 392     int elements;
 393     bool in_use;
 394     bool auto_pop;
 395   };
 396
 397 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 398
 399 /* Static functions (internal). */
 400
 401 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 402 static tree ffecom_arglist_expr_ (char *argstring, ffebld args);
 403 static tree ffecom_widest_expr_type_ (ffebld list);
 404 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 405                              tree dest_size, tree source_tree,
 406                              ffebld source, bool scalar_arg);
 407 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 408                                       tree args, tree callee_commons,
 409                                       bool scalar_args);
 410 static tree ffecom_build_f2c_string_ (int i, char *s);
 411 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 412                           bool is_f2c_complex, tree type,
 413                           tree args, tree dest_tree,
 414                           ffebld dest, bool *dest_used,
 415                           tree callee_commons, bool scalar_args);
 416 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 417                                 bool is_f2c_complex, tree type,
 418                                 ffebld left, ffebld right,
 419                                 tree dest_tree, ffebld dest,
 420                                 bool *dest_used, tree callee_commons,
 421                                 bool scalar_args);
 422 static void ffecom_char_args_ (tree *xitem, tree *length,
 423                                ffebld expr);
 424 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 425 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 426 static ffecomConcatList_
 427   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 428                               ffebld expr,
 429                               ffetargetCharacterSize max);
 430 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 431 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 432                                                 ffetargetCharacterSize max);
 433 static void ffecom_debug_kludge_ (tree aggr, char *aggr_type, ffesymbol member,
 434                                   tree member_type, ffetargetOffset offset);
 435 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 436 static tree ffecom_expr_ (ffebld expr, tree type_tree, tree dest_tree,
 437                           ffebld dest, bool *dest_used,
 438                           bool assignp);
 439 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 440                                     ffebld dest, bool *dest_used);
 441 static tree ffecom_expr_power_integer_ (ffebld left, ffebld right);
 442 static void ffecom_expr_transform_ (ffebld expr);
 443 static void ffecom_f2c_make_type_ (tree *type, int tcode, char *name);
 444 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 445                                       int code);
 446 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 447 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 448 static tree ffecom_get_appended_identifier_ (char us, char *text);
 449 static tree ffecom_get_external_identifier_ (ffesymbol s);
 450 static tree ffecom_get_identifier_ (char *text);
 451 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 452                                   ffeinfoBasictype bt,
 453                                   ffeinfoKindtype kt);
 454 static char *ffecom_gfrt_args_ (ffecomGfrt ix);
 455 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 456 static tree ffecom_init_zero_ (tree decl);
 457 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 458                                      tree *maybe_tree);
 459 static tree ffecom_intrinsic_len_ (ffebld expr);
 460 static void ffecom_let_char_ (tree dest_tree,
 461                               tree dest_length,
 462                               ffetargetCharacterSize dest_size,
 463                               ffebld source);
 464 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 465 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 466 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
 467 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 468 #endif
 469 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 470                                       bool stmtfunc);
 471 static void ffecom_start_progunit_ (void);
 472 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 473 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 474 static void ffecom_transform_common_ (ffesymbol s);
 475 static void ffecom_transform_equiv_ (ffestorag st);
 476 static tree ffecom_transform_namelist_ (ffesymbol s);
 477 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 478                                        tree t);
 479 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 480                                        tree *size, tree tree);
 481 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 482                                  tree dest_tree, ffebld dest,
 483                                  bool *dest_used);
 484 static tree ffecom_type_localvar_ (ffesymbol s,
 485                                    ffeinfoBasictype bt,
 486                                    ffeinfoKindtype kt);
 487 static tree ffecom_type_namelist_ (void);
 488 #if 0
 489 static tree ffecom_type_permanent_copy_ (tree t);
 490 #endif
 491 static tree ffecom_type_vardesc_ (void);
 492 static tree ffecom_vardesc_ (ffebld expr);
 493 static tree ffecom_vardesc_array_ (ffesymbol s);
 494 static tree ffecom_vardesc_dims_ (ffesymbol s);
 495 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 496
 497 /* These are static functions that parallel those found in the C front
 498    end and thus have the same names.  */
 499
 500 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 501 static void bison_rule_compstmt_ (void);
 502 static void bison_rule_pushlevel_ (void);
 503 static tree builtin_function (char *name, tree type,
 504                               enum built_in_function function_code,
 505                               char *library_name);
 506 static int duplicate_decls (tree newdecl, tree olddecl);
 507 static void finish_decl (tree decl, tree init, bool is_top_level);
 508 static void finish_function (int nested);
 509 static char *lang_printable_name (tree decl, int v);
 510 static tree lookup_name_current_level (tree name);
 511 static struct binding_level *make_binding_level (void);
 512 static void pop_f_function_context (void);
 513 static void push_f_function_context (void);
 514 static void push_parm_decl (tree parm);
 515 static tree pushdecl_top_level (tree decl);
 516 static tree storedecls (tree decls);
 517 static void store_parm_decls (int is_main_program);
 518 static tree start_decl (tree decl, bool is_top_level);
 519 static void start_function (tree name, tree type, int nested, int public);
 520 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 521 #if FFECOM_GCC_INCLUDE
 522 static void ffecom_file_ (char *name);
 523 static void ffecom_initialize_char_syntax_ (void);
 524 static void ffecom_close_include_ (FILE *f);
 525 static int ffecom_decode_include_option_ (char *spec);
 526 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 527                                    ffewhereColumn c);
 528 #endif  /* FFECOM_GCC_INCLUDE */
 529
 530 /* Static objects accessed by functions in this module. */
 531
 532 static ffesymbol ffecom_primary_entry_ = NULL;
 533 static ffesymbol ffecom_nested_entry_ = NULL;
 534 static ffeinfoKind ffecom_primary_entry_kind_;
 535 static bool ffecom_primary_entry_is_proc_;
 536 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 537 static tree ffecom_outer_function_decl_;
 538 static tree ffecom_previous_function_decl_;
 539 static tree ffecom_which_entrypoint_decl_;
 540 static ffecomTemp_ ffecom_latest_temp_;
 541 static int ffecom_pending_calls_ = 0;
 542 static tree ffecom_float_zero_ = NULL_TREE;
 543 static tree ffecom_float_half_ = NULL_TREE;
 544 static tree ffecom_double_zero_ = NULL_TREE;
 545 static tree ffecom_double_half_ = NULL_TREE;
 546 static tree ffecom_func_result_;/* For functions. */
 547 static tree ffecom_func_length_;/* For CHARACTER fns. */
 548 static ffebld ffecom_list_blockdata_;
 549 static ffebld ffecom_list_common_;
 550 static ffebld ffecom_master_arglist_;
 551 static ffeinfoBasictype ffecom_master_bt_;
 552 static ffeinfoKindtype ffecom_master_kt_;
 553 static ffetargetCharacterSize ffecom_master_size_;
 554 static int ffecom_num_fns_ = 0;
 555 static int ffecom_num_entrypoints_ = 0;
 556 static bool ffecom_is_altreturning_ = FALSE;
 557 static tree ffecom_multi_type_node_;
 558 static tree ffecom_multi_retval_;
 559 static tree
 560   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 561 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 562 static bool ffecom_doing_entry_ = FALSE;
 563 static bool ffecom_transform_only_dummies_ = FALSE;
 564
 565 /* Holds pointer-to-function expressions.  */
 566
 567 static tree ffecom_gfrt_[FFECOM_gfrt]
 568 =
 569 {
 570 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE,
 571 #include "com-rt.def"
 572 #undef DEFGFRT
 573 };
 574
 575 /* Holds the external names of the functions.  */
 576
 577 static char *ffecom_gfrt_name_[FFECOM_gfrt]
 578 =
 579 {
 580 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME,
 581 #include "com-rt.def"
 582 #undef DEFGFRT
 583 };
 584
 585 /* Whether the function returns.  */
 586
 587 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 588 =
 589 {
 590 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE,
 591 #include "com-rt.def"
 592 #undef DEFGFRT
 593 };
 594
 595 /* Whether the function returns type complex.  */
 596
 597 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 598 =
 599 {
 600 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX,
 601 #include "com-rt.def"
 602 #undef DEFGFRT
 603 };
 604
 605 /* Type code for the function return value.  */
 606
 607 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 608 =
 609 {
 610 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE,
 611 #include "com-rt.def"
 612 #undef DEFGFRT
 613 };
 614
 615 /* String of codes for the function's arguments.  */
 616
 617 static char *ffecom_gfrt_argstring_[FFECOM_gfrt]
 618 =
 619 {
 620 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS,
 621 #include "com-rt.def"
 622 #undef DEFGFRT
 623 };
 624 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 625
 626 /* Internal macros. */
 627
 628 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 629
 630 /* We let tm.h override the types used here, to handle trivial differences
 631    such as the choice of unsigned int or long unsigned int for size_t.
 632    When machines start needing nontrivial differences in the size type,
 633    it would be best to do something here to figure out automatically
 634    from other information what type to use.  */
 635
 636 /* NOTE: g77 currently doesn't use these; see setting of sizetype and
 637    change that if you need to.  -- jcb 09/01/91. */
 638
 639 #ifndef SIZE_TYPE
 640 #define SIZE_TYPE "long unsigned int"
 641 #endif
 642
 643 #ifndef WCHAR_TYPE
 644 #define WCHAR_TYPE "int"
 645 #endif
 646
 647 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 648 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 649 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 650 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 651
 652 #define ffecom_start_compstmt_ bison_rule_pushlevel_
 653 #define ffecom_end_compstmt_ bison_rule_compstmt_
 654
 655 /* For each binding contour we allocate a binding_level structure
 656  * which records the names defined in that contour.
 657  * Contours include:
 658  *  0) the global one
 659  *  1) one for each function definition,
 660  *     where internal declarations of the parameters appear.
 661  *
 662  * The current meaning of a name can be found by searching the levels from
 663  * the current one out to the global one.
 664  */
 665
 666 /* Note that the information in the `names' component of the global contour
 667    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 668
 669 struct binding_level
 670   {
 671     /* A chain of _DECL nodes for all variables, constants, functions, and
 672        typedef types.  These are in the reverse of the order supplied. */
 673     tree names;
 674
 675     /* For each level (except not the global one), a chain of BLOCK nodes for
 676        all the levels that were entered and exited one level down.  */
 677     tree blocks;
 678
 679     /* The BLOCK node for this level, if one has been preallocated. If 0, the
 680        BLOCK is allocated (if needed) when the level is popped.  */
 681     tree this_block;
 682
 683     /* The binding level which this one is contained in (inherits from).  */
 684     struct binding_level *level_chain;
 685   };
 686
 687 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 688
 689 /* The binding level currently in effect.  */
 690
 691 static struct binding_level *current_binding_level;
 692
 693 /* A chain of binding_level structures awaiting reuse.  */
 694
 695 static struct binding_level *free_binding_level;
 696
 697 /* The outermost binding level, for names of file scope.
 698    This is created when the compiler is started and exists
 699    through the entire run.  */
 700
 701 static struct binding_level *global_binding_level;
 702
 703 /* Binding level structures are initialized by copying this one.  */
 704
 705 static struct binding_level clear_binding_level
 706 =
 707 {NULL, NULL, NULL, NULL_BINDING_LEVEL};
 708
 709 /* Language-dependent contents of an identifier.  */
 710
 711 struct lang_identifier
 712   {
 713     struct tree_identifier ignore;
 714     tree global_value, local_value, label_value;
 715     bool invented;
 716   };
 717
 718 /* Macros for access to language-specific slots in an identifier.  */
 719 /* Each of these slots contains a DECL node or null.  */
 720
 721 /* This represents the value which the identifier has in the
 722    file-scope namespace.  */
 723 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 724   (((struct lang_identifier *)(NODE))->global_value)
 725 /* This represents the value which the identifier has in the current
 726    scope.  */
 727 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 728   (((struct lang_identifier *)(NODE))->local_value)
 729 /* This represents the value which the identifier has as a label in
 730    the current label scope.  */
 731 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 732   (((struct lang_identifier *)(NODE))->label_value)
 733 /* This is nonzero if the identifier was "made up" by g77 code.  */
 734 #define IDENTIFIER_INVENTED(NODE)       \
 735   (((struct lang_identifier *)(NODE))->invented)
 736
 737 /* In identifiers, C uses the following fields in a special way:
 738    TREE_PUBLIC        to record that there was a previous local extern decl.
 739    TREE_USED          to record that such a decl was used.
 740    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 741
 742 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 743    that have names.  Here so we can clear out their names' definitions
 744    at the end of the function.  */
 745
 746 static tree named_labels;
 747
 748 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 749
 750 static tree shadowed_labels;
 751
 752 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 753 \f
 754
 755 /* This is like gcc's stabilize_reference -- in fact, most of the code
 756    comes from that -- but it handles the situation where the reference
 757    is going to have its subparts picked at, and it shouldn't change
 758    (or trigger extra invocations of functions in the subtrees) due to
 759    this.  save_expr is a bit overzealous, because we don't need the
 760    entire thing calculated and saved like a temp.  So, for DECLs, no
 761    change is needed, because these are stable aggregates, and ARRAY_REF
 762    and such might well be stable too, but for things like calculations,
 763    we do need to calculate a snapshot of a value before picking at it.  */
 764
 765 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 766 static tree
 767 ffecom_stabilize_aggregate_ (tree ref)
 768 {
 769   tree result;
 770   enum tree_code code = TREE_CODE (ref);
 771
 772   switch (code)
 773     {
 774     case VAR_DECL:
 775     case PARM_DECL:
 776     case RESULT_DECL:
 777       /* No action is needed in this case.  */
 778       return ref;
 779
 780     case NOP_EXPR:
 781     case CONVERT_EXPR:
 782     case FLOAT_EXPR:
 783     case FIX_TRUNC_EXPR:
 784     case FIX_FLOOR_EXPR:
 785     case FIX_ROUND_EXPR:
 786     case FIX_CEIL_EXPR:
 787       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
 788       break;
 789
 790     case INDIRECT_REF:
 791       result = build_nt (INDIRECT_REF,
 792                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
 793       break;
 794
 795     case COMPONENT_REF:
 796       result = build_nt (COMPONENT_REF,
 797                          stabilize_reference (TREE_OPERAND (ref, 0)),
 798                          TREE_OPERAND (ref, 1));
 799       break;
 800
 801     case BIT_FIELD_REF:
 802       result = build_nt (BIT_FIELD_REF,
 803                          stabilize_reference (TREE_OPERAND (ref, 0)),
 804                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
 805                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
 806       break;
 807
 808     case ARRAY_REF:
 809       result = build_nt (ARRAY_REF,
 810                          stabilize_reference (TREE_OPERAND (ref, 0)),
 811                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
 812       break;
 813
 814     case COMPOUND_EXPR:
 815       result = build_nt (COMPOUND_EXPR,
 816                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
 817                          stabilize_reference (TREE_OPERAND (ref, 1)));
 818       break;
 819
 820     case RTL_EXPR:
 821       result = build1 (INDIRECT_REF, TREE_TYPE (ref),
 822                        save_expr (build1 (ADDR_EXPR,
 823                                           build_pointer_type (TREE_TYPE (ref)),
 824                                           ref)));
 825       break;
 826
 827
 828     default:
 829       return save_expr (ref);
 830
 831     case ERROR_MARK:
 832       return error_mark_node;
 833     }
 834
 835   TREE_TYPE (result) = TREE_TYPE (ref);
 836   TREE_READONLY (result) = TREE_READONLY (ref);
 837   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
 838   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
 839   TREE_RAISES (result) = TREE_RAISES (ref);
 840
 841   return result;
 842 }
 843 #endif
 844
 845 /* A rip-off of gcc's convert.c convert_to_complex function,
 846    reworked to handle complex implemented as C structures
 847    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
 848
 849 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 850 static tree
 851 ffecom_convert_to_complex_ (tree type, tree expr)
 852 {
 853   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
 854   tree subtype;
 855
 856   assert (TREE_CODE (type) == RECORD_TYPE);
 857
 858   subtype = TREE_TYPE (TYPE_FIELDS (type));
 859
 860   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
 861     {
 862       expr = convert (subtype, expr);
 863       return ffecom_2 (COMPLEX_EXPR, type, expr,
 864                        convert (subtype, integer_zero_node));
 865     }
 866
 867   if (form == RECORD_TYPE)
 868     {
 869       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
 870       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
 871         return expr;
 872       else
 873         {
 874           expr = save_expr (expr);
 875           return ffecom_2 (COMPLEX_EXPR,
 876                            type,
 877                            convert (subtype,
 878                                     ffecom_1 (REALPART_EXPR,
 879                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
 880                                               expr)),
 881                            convert (subtype,
 882                                     ffecom_1 (IMAGPART_EXPR,
 883                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
 884                                               expr)));
 885         }
 886     }
 887
 888   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
 889     error ("pointer value used where a complex was expected");
 890   else
 891     error ("aggregate value used where a complex was expected");
 892
 893   return ffecom_2 (COMPLEX_EXPR, type,
 894                    convert (subtype, integer_zero_node),
 895                    convert (subtype, integer_zero_node));
 896 }
 897 #endif
 898
 899 /* Like gcc's convert(), but crashes if widening might happen.  */
 900
 901 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 902 static tree
 903 ffecom_convert_narrow_ (type, expr)
 904      tree type, expr;
 905 {
 906   register tree e = expr;
 907   register enum tree_code code = TREE_CODE (type);
 908
 909   if (type == TREE_TYPE (e)
 910       || TREE_CODE (e) == ERROR_MARK)
 911     return e;
 912   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
 913     return fold (build1 (NOP_EXPR, type, e));
 914   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
 915       || code == ERROR_MARK)
 916     return error_mark_node;
 917   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
 918     {
 919       assert ("void value not ignored as it ought to be" == NULL);
 920       return error_mark_node;
 921     }
 922   assert (code != VOID_TYPE);
 923   if ((code != RECORD_TYPE)
 924       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
 925     assert ("converting COMPLEX to REAL" == NULL);
 926   assert (code != ENUMERAL_TYPE);
 927   if (code == INTEGER_TYPE)
 928     {
 929       assert (TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE);
 930       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
 931       return fold (convert_to_integer (type, e));
 932     }
 933   if (code == POINTER_TYPE)
 934     {
 935       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
 936       return fold (convert_to_pointer (type, e));
 937     }
 938   if (code == REAL_TYPE)
 939     {
 940       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
 941       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
 942       return fold (convert_to_real (type, e));
 943     }
 944   if (code == COMPLEX_TYPE)
 945     {
 946       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
 947       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
 948       return fold (convert_to_complex (type, e));
 949     }
 950   if (code == RECORD_TYPE)
 951     {
 952       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
 953       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
 954               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
 955       return fold (ffecom_convert_to_complex_ (type, e));
 956     }
 957
 958   assert ("conversion to non-scalar type requested" == NULL);
 959   return error_mark_node;
 960 }
 961 #endif
 962
 963 /* Like gcc's convert(), but crashes if narrowing might happen.  */
 964
 965 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 966 static tree
 967 ffecom_convert_widen_ (type, expr)
 968      tree type, expr;
 969 {
 970   register tree e = expr;
 971   register enum tree_code code = TREE_CODE (type);
 972
 973   if (type == TREE_TYPE (e)
 974       || TREE_CODE (e) == ERROR_MARK)
 975     return e;
 976   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
 977     return fold (build1 (NOP_EXPR, type, e));
 978   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
 979       || code == ERROR_MARK)
 980     return error_mark_node;
 981   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
 982     {
 983       assert ("void value not ignored as it ought to be" == NULL);
 984       return error_mark_node;
 985     }
 986   assert (code != VOID_TYPE);
 987   if ((code != RECORD_TYPE)
 988       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
 989     assert ("narrowing COMPLEX to REAL" == NULL);
 990   assert (code != ENUMERAL_TYPE);
 991   if (code == INTEGER_TYPE)
 992     {
 993       assert (TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE);
 994       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
 995       return fold (convert_to_integer (type, e));
 996     }
 997   if (code == POINTER_TYPE)
 998     {
 999       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1000       return fold (convert_to_pointer (type, e));
1001     }
1002   if (code == REAL_TYPE)
1003     {
1004       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1005       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1006       return fold (convert_to_real (type, e));
1007     }
1008   if (code == COMPLEX_TYPE)
1009     {
1010       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1011       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1012       return fold (convert_to_complex (type, e));
1013     }
1014   if (code == RECORD_TYPE)
1015     {
1016       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1017       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1018               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1019       return fold (ffecom_convert_to_complex_ (type, e));
1020     }
1021
1022   assert ("conversion to non-scalar type requested" == NULL);
1023   return error_mark_node;
1024 }
1025 #endif
1026
1027 /* Handles making a COMPLEX type, either the standard
1028    (but buggy?) gbe way, or the safer (but less elegant?)
1029    f2c way.  */
1030
1031 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1032 static tree
1033 ffecom_make_complex_type_ (tree subtype)
1034 {
1035   tree type;
1036   tree realfield;
1037   tree imagfield;
1038
1039   if (ffe_is_emulate_complex ())
1040     {
1041       type = make_node (RECORD_TYPE);
1042       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1043       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1044       TYPE_FIELDS (type) = realfield;
1045       layout_type (type);
1046     }
1047   else
1048     {
1049       type = make_node (COMPLEX_TYPE);
1050       TREE_TYPE (type) = subtype;
1051       layout_type (type);
1052     }
1053
1054   return type;
1055 }
1056 #endif
1057
1058 /* Chooses either the gbe or the f2c way to build a
1059    complex constant.  */
1060
1061 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1062 static tree
1063 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1064 {
1065   tree bothparts;
1066
1067   if (ffe_is_emulate_complex ())
1068     {
1069       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1070       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1071       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1072     }
1073   else
1074     {
1075       bothparts = build_complex (type, realpart, imagpart);
1076     }
1077
1078   return bothparts;
1079 }
1080 #endif
1081
1082 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1083 static tree
1084 ffecom_arglist_expr_ (char *c, ffebld expr)
1085 {
1086   tree list;
1087   tree *plist = &list;
1088   tree trail = NULL_TREE;       /* Append char length args here. */
1089   tree *ptrail = &trail;
1090   tree length;
1091   ffebld exprh;
1092   tree item;
1093   bool ptr = FALSE;
1094   tree wanted = NULL_TREE;
1095
1096   while (expr != NULL)
1097     {
1098       if (*c != '\0')
1099         {
1100           ptr = FALSE;
1101           if (*c == '&')
1102             {
1103               ptr = TRUE;
1104               ++c;
1105             }
1106           switch (*(c++))
1107             {
1108             case '\0':
1109               ptr = TRUE;
1110               wanted = NULL_TREE;
1111               break;
1112
1113             case 'a':
1114               assert (ptr);
1115               wanted = NULL_TREE;
1116               break;
1117
1118             case 'c':
1119               wanted = ffecom_f2c_complex_type_node;
1120               break;
1121
1122             case 'd':
1123               wanted = ffecom_f2c_doublereal_type_node;
1124               break;
1125
1126             case 'e':
1127               wanted = ffecom_f2c_doublecomplex_type_node;
1128               break;
1129
1130             case 'f':
1131               wanted = ffecom_f2c_real_type_node;
1132               break;
1133
1134             case 'i':
1135               wanted = ffecom_f2c_integer_type_node;
1136               break;
1137
1138             case 'j':
1139               wanted = ffecom_f2c_longint_type_node;
1140               break;
1141
1142             default:
1143               assert ("bad argstring code" == NULL);
1144               wanted = NULL_TREE;
1145               break;
1146             }
1147         }
1148
1149       exprh = ffebld_head (expr);
1150       if (exprh == NULL)
1151         wanted = NULL_TREE;
1152
1153       if ((wanted == NULL_TREE)
1154           || (ptr
1155               && (TYPE_MODE
1156                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1157                    [ffeinfo_kindtype (ffebld_info (exprh))])
1158                    == TYPE_MODE (wanted))))
1159         *plist
1160           = build_tree_list (NULL_TREE,
1161                              ffecom_arg_ptr_to_expr (exprh,
1162                                                      &length));
1163       else
1164         {
1165           item = ffecom_arg_expr (exprh, &length);
1166           item = ffecom_convert_widen_ (wanted, item);
1167           if (ptr)
1168             {
1169               item = ffecom_1 (ADDR_EXPR,
1170                                build_pointer_type (TREE_TYPE (item)),
1171                                item);
1172             }
1173           *plist
1174             = build_tree_list (NULL_TREE,
1175                                item);
1176         }
1177
1178       plist = &TREE_CHAIN (*plist);
1179       expr = ffebld_trail (expr);
1180       if (length != NULL_TREE)
1181         {
1182           *ptrail = build_tree_list (NULL_TREE, length);
1183           ptrail = &TREE_CHAIN (*ptrail);
1184         }
1185     }
1186
1187   *plist = trail;
1188
1189   return list;
1190 }
1191 #endif
1192
1193 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1194 static tree
1195 ffecom_widest_expr_type_ (ffebld list)
1196 {
1197   ffebld item;
1198   ffebld widest = NULL;
1199   ffetype type;
1200   ffetype widest_type = NULL;
1201   tree t;
1202
1203   for (; list != NULL; list = ffebld_trail (list))
1204     {
1205       item = ffebld_head (list);
1206       if (item == NULL)
1207         continue;
1208       if ((widest != NULL)
1209           && (ffeinfo_basictype (ffebld_info (item))
1210               != ffeinfo_basictype (ffebld_info (widest))))
1211         continue;
1212       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1213                            ffeinfo_kindtype (ffebld_info (item)));
1214       if ((widest == FFEINFO_kindtypeNONE)
1215           || (ffetype_size (type)
1216               > ffetype_size (widest_type)))
1217         {
1218           widest = item;
1219           widest_type = type;
1220         }
1221     }
1222
1223   assert (widest != NULL);
1224   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1225     [ffeinfo_kindtype (ffebld_info (widest))];
1226   assert (t != NULL_TREE);
1227   return t;
1228 }
1229 #endif
1230
1231 /* Check whether dest and source might overlap.  ffebld versions of these
1232    might or might not be passed, will be NULL if not.
1233
1234    The test is really whether source_tree is modifiable and, if modified,
1235    might overlap destination such that the value(s) in the destination might
1236    change before it is finally modified.  dest_* are the canonized
1237    destination itself.  */
1238
1239 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1240 static bool
1241 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1242                  tree source_tree, ffebld source UNUSED,
1243                  bool scalar_arg)
1244 {
1245   tree source_decl;
1246   tree source_offset;
1247   tree source_size;
1248   tree t;
1249
1250   if (source_tree == NULL_TREE)
1251     return FALSE;
1252
1253   switch (TREE_CODE (source_tree))
1254     {
1255     case ERROR_MARK:
1256     case IDENTIFIER_NODE:
1257     case INTEGER_CST:
1258     case REAL_CST:
1259     case COMPLEX_CST:
1260     case STRING_CST:
1261     case CONST_DECL:
1262     case VAR_DECL:
1263     case RESULT_DECL:
1264     case FIELD_DECL:
1265     case MINUS_EXPR:
1266     case MULT_EXPR:
1267     case TRUNC_DIV_EXPR:
1268     case CEIL_DIV_EXPR:
1269     case FLOOR_DIV_EXPR:
1270     case ROUND_DIV_EXPR:
1271     case TRUNC_MOD_EXPR:
1272     case CEIL_MOD_EXPR:
1273     case FLOOR_MOD_EXPR:
1274     case ROUND_MOD_EXPR:
1275     case RDIV_EXPR:
1276     case EXACT_DIV_EXPR:
1277     case FIX_TRUNC_EXPR:
1278     case FIX_CEIL_EXPR:
1279     case FIX_FLOOR_EXPR:
1280     case FIX_ROUND_EXPR:
1281     case FLOAT_EXPR:
1282     case EXPON_EXPR:
1283     case NEGATE_EXPR:
1284     case MIN_EXPR:
1285     case MAX_EXPR:
1286     case ABS_EXPR:
1287     case FFS_EXPR:
1288     case LSHIFT_EXPR:
1289     case RSHIFT_EXPR:
1290     case LROTATE_EXPR:
1291     case RROTATE_EXPR:
1292     case BIT_IOR_EXPR:
1293     case BIT_XOR_EXPR:
1294     case BIT_AND_EXPR:
1295     case BIT_ANDTC_EXPR:
1296     case BIT_NOT_EXPR:
1297     case TRUTH_ANDIF_EXPR:
1298     case TRUTH_ORIF_EXPR:
1299     case TRUTH_AND_EXPR:
1300     case TRUTH_OR_EXPR:
1301     case TRUTH_XOR_EXPR:
1302     case TRUTH_NOT_EXPR:
1303     case LT_EXPR:
1304     case LE_EXPR:
1305     case GT_EXPR:
1306     case GE_EXPR:
1307     case EQ_EXPR:
1308     case NE_EXPR:
1309     case COMPLEX_EXPR:
1310     case CONJ_EXPR:
1311     case REALPART_EXPR:
1312     case IMAGPART_EXPR:
1313     case LABEL_EXPR:
1314     case COMPONENT_REF:
1315       return FALSE;
1316
1317     case COMPOUND_EXPR:
1318       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1319                               TREE_OPERAND (source_tree, 1), NULL,
1320                               scalar_arg);
1321
1322     case MODIFY_EXPR:
1323       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1324                               TREE_OPERAND (source_tree, 0), NULL,
1325                               scalar_arg);
1326
1327     case CONVERT_EXPR:
1328     case NOP_EXPR:
1329     case NON_LVALUE_EXPR:
1330     case PLUS_EXPR:
1331       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1332         return TRUE;
1333
1334       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1335                                  source_tree);
1336       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1337       break;
1338
1339     case COND_EXPR:
1340       return
1341         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1342                          TREE_OPERAND (source_tree, 1), NULL,
1343                          scalar_arg)
1344           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1345                               TREE_OPERAND (source_tree, 2), NULL,
1346                               scalar_arg);
1347
1348
1349     case ADDR_EXPR:
1350       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1351                                  &source_size,
1352                                  TREE_OPERAND (source_tree, 0));
1353       break;
1354
1355     case PARM_DECL:
1356       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1357         return TRUE;
1358
1359       source_decl = source_tree;
1360       source_offset = size_zero_node;
1361       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1362       break;
1363
1364     case SAVE_EXPR:
1365     case REFERENCE_EXPR:
1366     case PREDECREMENT_EXPR:
1367     case PREINCREMENT_EXPR:
1368     case POSTDECREMENT_EXPR:
1369     case POSTINCREMENT_EXPR:
1370     case INDIRECT_REF:
1371     case ARRAY_REF:
1372     case CALL_EXPR:
1373     default:
1374       return TRUE;
1375     }
1376
1377   /* Come here when source_decl, source_offset, and source_size filled
1378      in appropriately.  */
1379
1380   if (source_decl == NULL_TREE)
1381     return FALSE;               /* No decl involved, so no overlap. */
1382
1383   if (source_decl != dest_decl)
1384     return FALSE;               /* Different decl, no overlap. */
1385
1386   if (TREE_CODE (dest_size) == ERROR_MARK)
1387     return TRUE;                /* Assignment into entire assumed-size
1388                                    array?  Shouldn't happen.... */
1389
1390   t = ffecom_2 (LE_EXPR, integer_type_node,
1391                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1392                           dest_offset,
1393                           convert (TREE_TYPE (dest_offset),
1394                                    dest_size)),
1395                 convert (TREE_TYPE (dest_offset),
1396                          source_offset));
1397
1398   if (integer_onep (t))
1399     return FALSE;               /* Destination precedes source. */
1400
1401   if (!scalar_arg
1402       || (source_size == NULL_TREE)
1403       || (TREE_CODE (source_size) == ERROR_MARK)
1404       || integer_zerop (source_size))
1405     return TRUE;                /* No way to tell if dest follows source. */
1406
1407   t = ffecom_2 (LE_EXPR, integer_type_node,
1408                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1409                           source_offset,
1410                           convert (TREE_TYPE (source_offset),
1411                                    source_size)),
1412                 convert (TREE_TYPE (source_offset),
1413                          dest_offset));
1414
1415   if (integer_onep (t))
1416     return FALSE;               /* Destination follows source. */
1417
1418   return TRUE;          /* Destination and source overlap. */
1419 }
1420 #endif
1421
1422 /* Check whether dest might overlap any of a list of arguments or is
1423    in a COMMON area the callee might know about (and thus modify).  */
1424
1425 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1426 static bool
1427 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1428                           tree args, tree callee_commons,
1429                           bool scalar_args)
1430 {
1431   tree arg;
1432   tree dest_decl;
1433   tree dest_offset;
1434   tree dest_size;
1435
1436   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1437                              dest_tree);
1438
1439   if (dest_decl == NULL_TREE)
1440     return FALSE;               /* Seems unlikely! */
1441
1442   /* If the decl cannot be determined reliably, or if its in COMMON
1443      and the callee isn't known to not futz with COMMON via other
1444      means, overlap might happen.  */
1445
1446   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1447       || ((callee_commons != NULL_TREE)
1448           && TREE_PUBLIC (dest_decl)))
1449     return TRUE;
1450
1451   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1452     {
1453       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1454           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1455                               arg, NULL, scalar_args))
1456         return TRUE;
1457     }
1458
1459   return FALSE;
1460 }
1461 #endif
1462
1463 /* Build a string for a variable name as used by NAMELIST.  This means that
1464    if we're using the f2c library, we build an uppercase string, since
1465    f2c does this.  */
1466
1467 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1468 static tree
1469 ffecom_build_f2c_string_ (int i, char *s)
1470 {
1471   if (!ffe_is_f2c_library ())
1472     return build_string (i, s);
1473
1474   {
1475     char *tmp;
1476     char *p;
1477     char *q;
1478     char space[34];
1479     tree t;
1480
1481     if (((size_t) i) > ARRAY_SIZE (space))
1482       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1483     else
1484       tmp = &space[0];
1485
1486     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1487       *q = ffesrc_toupper (*p);
1488     *q = '\0';
1489
1490     t = build_string (i, tmp);
1491
1492     if (((size_t) i) > ARRAY_SIZE (space))
1493       malloc_kill_ks (malloc_pool_image (), tmp, i);
1494
1495     return t;
1496   }
1497 }
1498
1499 #endif
1500 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1501    type to just get whatever the function returns), handling the
1502    f2c value-returning convention, if required, by prepending
1503    to the arglist a pointer to a temporary to receive the return value.  */
1504
1505 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1506 static tree
1507 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1508               tree type, tree args, tree dest_tree,
1509               ffebld dest, bool *dest_used, tree callee_commons,
1510               bool scalar_args)
1511 {
1512   tree item;
1513   tree tempvar;
1514
1515   if (dest_used != NULL)
1516     *dest_used = FALSE;
1517
1518   if (is_f2c_complex)
1519     {
1520       if ((dest_used == NULL)
1521           || (dest == NULL)
1522           || (ffeinfo_basictype (ffebld_info (dest))
1523               != FFEINFO_basictypeCOMPLEX)
1524           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1525           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1526           || ffecom_args_overlapping_ (dest_tree, dest, args,
1527                                        callee_commons,
1528                                        scalar_args))
1529         {
1530           tempvar = ffecom_push_tempvar (ffecom_tree_type
1531                                          [FFEINFO_basictypeCOMPLEX][kt],
1532                                          FFETARGET_charactersizeNONE,
1533                                          -1, TRUE);
1534         }
1535       else
1536         {
1537           *dest_used = TRUE;
1538           tempvar = dest_tree;
1539           type = NULL_TREE;
1540         }
1541
1542       item
1543         = build_tree_list (NULL_TREE,
1544                            ffecom_1 (ADDR_EXPR,
1545                                    build_pointer_type (TREE_TYPE (tempvar)),
1546                                      tempvar));
1547       TREE_CHAIN (item) = args;
1548
1549       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1550                         item, NULL_TREE);
1551
1552       if (tempvar != dest_tree)
1553         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1554     }
1555   else
1556     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1557                       args, NULL_TREE);
1558
1559   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1560     item = ffecom_convert_narrow_ (type, item);
1561
1562   return item;
1563 }
1564 #endif
1565
1566 /* Given two arguments, transform them and make a call to the given
1567    function via ffecom_call_.  */
1568
1569 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1570 static tree
1571 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1572                     tree type, ffebld left, ffebld right,
1573                     tree dest_tree, ffebld dest, bool *dest_used,
1574                     tree callee_commons, bool scalar_args)
1575 {
1576   tree left_tree;
1577   tree right_tree;
1578   tree left_length;
1579   tree right_length;
1580
1581   ffecom_push_calltemps ();
1582   left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1583   right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1584   ffecom_pop_calltemps ();
1585
1586   left_tree = build_tree_list (NULL_TREE, left_tree);
1587   right_tree = build_tree_list (NULL_TREE, right_tree);
1588   TREE_CHAIN (left_tree) = right_tree;
1589
1590   if (left_length != NULL_TREE)
1591     {
1592       left_length = build_tree_list (NULL_TREE, left_length);
1593       TREE_CHAIN (right_tree) = left_length;
1594     }
1595
1596   if (right_length != NULL_TREE)
1597     {
1598       right_length = build_tree_list (NULL_TREE, right_length);
1599       if (left_length != NULL_TREE)
1600         TREE_CHAIN (left_length) = right_length;
1601       else
1602         TREE_CHAIN (right_tree) = right_length;
1603     }
1604
1605   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1606                        dest_tree, dest, dest_used, callee_commons,
1607                        scalar_args);
1608 }
1609 #endif
1610
1611 /* ffecom_char_args_ -- Return ptr/length args for char subexpression
1612
1613    tree ptr_arg;
1614    tree length_arg;
1615    ffebld expr;
1616    ffecom_char_args_(&ptr_arg,&length_arg,expr);
1617
1618    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1619    subexpressions by constructing the appropriate trees for the ptr-to-
1620    character-text and length-of-character-text arguments in a calling
1621    sequence.  */
1622
1623 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1624 static void
1625 ffecom_char_args_ (tree *xitem, tree *length, ffebld expr)
1626 {
1627   tree item;
1628   tree high;
1629   ffetargetCharacter1 val;
1630
1631   switch (ffebld_op (expr))
1632     {
1633     case FFEBLD_opCONTER:
1634       val = ffebld_constant_character1 (ffebld_conter (expr));
1635       *length = build_int_2 (ffetarget_length_character1 (val), 0);
1636       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1637       high = build_int_2 (ffetarget_length_character1 (val),
1638                           0);
1639       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1640       item = build_string (ffetarget_length_character1 (val),
1641                            ffetarget_text_character1 (val));
1642       TREE_TYPE (item)
1643         = build_type_variant
1644           (build_array_type
1645            (char_type_node,
1646             build_range_type
1647             (ffecom_f2c_ftnlen_type_node,
1648              ffecom_f2c_ftnlen_one_node,
1649              high)),
1650            1, 0);
1651       TREE_CONSTANT (item) = 1;
1652       TREE_STATIC (item) = 1;
1653       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1654                        item);
1655       break;
1656
1657     case FFEBLD_opSYMTER:
1658       {
1659         ffesymbol s = ffebld_symter (expr);
1660
1661         item = ffesymbol_hook (s).decl_tree;
1662         if (item == NULL_TREE)
1663           {
1664             s = ffecom_sym_transform_ (s);
1665             item = ffesymbol_hook (s).decl_tree;
1666           }
1667         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1668           {
1669             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1670               *length = ffesymbol_hook (s).length_tree;
1671             else
1672               {
1673                 *length = build_int_2 (ffesymbol_size (s), 0);
1674                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1675               }
1676           }
1677         else if (item == error_mark_node)
1678           *length = error_mark_node;
1679         else                    /* FFEINFO_kindFUNCTION: */
1680           *length = NULL_TREE;
1681         if (!ffesymbol_hook (s).addr
1682             && (item != error_mark_node))
1683           item = ffecom_1 (ADDR_EXPR,
1684                            build_pointer_type (TREE_TYPE (item)),
1685                            item);
1686       }
1687       break;
1688
1689     case FFEBLD_opARRAYREF:
1690       {
1691         ffebld dims[FFECOM_dimensionsMAX];
1692         tree array;
1693         int i;
1694
1695         ffecom_push_calltemps ();
1696         ffecom_char_args_ (&item, length, ffebld_left (expr));
1697         ffecom_pop_calltemps ();
1698
1699         if (item == error_mark_node || *length == error_mark_node)
1700           {
1701             item = *length = error_mark_node;
1702             break;
1703           }
1704
1705         /* Build up ARRAY_REFs in reverse order (since we're column major
1706            here in Fortran land). */
1707
1708         for (i = 0, expr = ffebld_right (expr);
1709              expr != NULL;
1710              expr = ffebld_trail (expr))
1711           dims[i++] = ffebld_head (expr);
1712
1713         for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
1714              i >= 0;
1715              --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
1716           {
1717             item = ffecom_2 (PLUS_EXPR, build_pointer_type (TREE_TYPE (array)),
1718                              item,
1719                              size_binop (MULT_EXPR,
1720                                          size_in_bytes (TREE_TYPE (array)),
1721                                          size_binop (MINUS_EXPR,
1722                                                      ffecom_expr (dims[i]),
1723                                     TYPE_MIN_VALUE (TYPE_DOMAIN (array)))));
1724           }
1725       }
1726       break;
1727
1728     case FFEBLD_opSUBSTR:
1729       {
1730         ffebld start;
1731         ffebld end;
1732         ffebld thing = ffebld_right (expr);
1733         tree start_tree;
1734         tree end_tree;
1735
1736         assert (ffebld_op (thing) == FFEBLD_opITEM);
1737         start = ffebld_head (thing);
1738         thing = ffebld_trail (thing);
1739         assert (ffebld_trail (thing) == NULL);
1740         end = ffebld_head (thing);
1741
1742         ffecom_push_calltemps ();
1743         ffecom_char_args_ (&item, length, ffebld_left (expr));
1744         ffecom_pop_calltemps ();
1745
1746         if (item == error_mark_node || *length == error_mark_node)
1747           {
1748             item = *length = error_mark_node;
1749             break;
1750           }
1751
1752         if (start == NULL)
1753           {
1754             if (end == NULL)
1755               ;
1756             else
1757               {
1758                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
1759                                     ffecom_expr (end));
1760
1761                 if (end_tree == error_mark_node)
1762                   {
1763                     item = *length = error_mark_node;
1764                     break;
1765                   }
1766
1767                 *length = end_tree;
1768               }
1769           }
1770         else
1771           {
1772             start_tree = convert (ffecom_f2c_ftnlen_type_node,
1773                                   ffecom_expr (start));
1774
1775             if (start_tree == error_mark_node)
1776               {
1777                 item = *length = error_mark_node;
1778                 break;
1779               }
1780
1781             start_tree = ffecom_save_tree (start_tree);
1782
1783             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
1784                              item,
1785                              ffecom_2 (MINUS_EXPR,
1786                                        TREE_TYPE (start_tree),
1787                                        start_tree,
1788                                        ffecom_f2c_ftnlen_one_node));
1789
1790             if (end == NULL)
1791               {
1792                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
1793                                     ffecom_f2c_ftnlen_one_node,
1794                                     ffecom_2 (MINUS_EXPR,
1795                                               ffecom_f2c_ftnlen_type_node,
1796                                               *length,
1797                                               start_tree));
1798               }
1799             else
1800               {
1801                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
1802                                     ffecom_expr (end));
1803
1804                 if (end_tree == error_mark_node)
1805                   {
1806                     item = *length = error_mark_node;
1807                     break;
1808                   }
1809
1810                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
1811                                     ffecom_f2c_ftnlen_one_node,
1812                                     ffecom_2 (MINUS_EXPR,
1813                                               ffecom_f2c_ftnlen_type_node,
1814                                               end_tree, start_tree));
1815               }
1816           }
1817       }
1818       break;
1819
1820     case FFEBLD_opFUNCREF:
1821       {
1822         ffesymbol s = ffebld_symter (ffebld_left (expr));
1823         tree tempvar;
1824         tree args;
1825         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
1826         ffecomGfrt ix;
1827
1828         if (size == FFETARGET_charactersizeNONE)
1829           size = 24;    /* ~~~~ Kludge alert!  This should someday be fixed. */
1830
1831         *length = build_int_2 (size, 0);
1832         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1833
1834         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
1835             == FFEINFO_whereINTRINSIC)
1836           {
1837             if (size == 1)
1838               {                 /* Invocation of an intrinsic returning CHARACTER*1. */
1839                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
1840                                                NULL, NULL);
1841                 break;
1842               }
1843             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
1844             assert (ix != FFECOM_gfrt);
1845             item = ffecom_gfrt_tree_ (ix);
1846           }
1847         else
1848           {
1849             ix = FFECOM_gfrt;
1850             item = ffesymbol_hook (s).decl_tree;
1851             if (item == NULL_TREE)
1852               {
1853                 s = ffecom_sym_transform_ (s);
1854                 item = ffesymbol_hook (s).decl_tree;
1855               }
1856             if (item == error_mark_node)
1857               {
1858                 item = *length = error_mark_node;
1859                 break;
1860               }
1861
1862             if (!ffesymbol_hook (s).addr)
1863               item = ffecom_1_fn (item);
1864           }
1865
1866         assert (ffecom_pending_calls_ != 0);
1867         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
1868         tempvar = ffecom_1 (ADDR_EXPR,
1869                             build_pointer_type (TREE_TYPE (tempvar)),
1870                             tempvar);
1871
1872         ffecom_push_calltemps ();
1873
1874         args = build_tree_list (NULL_TREE, tempvar);
1875
1876         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
1877           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
1878         else
1879           {
1880             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
1881             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
1882               {
1883                 TREE_CHAIN (TREE_CHAIN (args))
1884                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
1885                                           ffebld_right (expr));
1886               }
1887             else
1888               {
1889                 TREE_CHAIN (TREE_CHAIN (args))
1890                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
1891               }
1892           }
1893
1894         item = ffecom_3s (CALL_EXPR,
1895                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
1896                           item, args, NULL_TREE);
1897         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
1898                          tempvar);
1899
1900         ffecom_pop_calltemps ();
1901       }
1902       break;
1903
1904     case FFEBLD_opCONVERT:
1905
1906       ffecom_push_calltemps ();
1907       ffecom_char_args_ (&item, length, ffebld_left (expr));
1908       ffecom_pop_calltemps ();
1909
1910       if (item == error_mark_node || *length == error_mark_node)
1911         {
1912           item = *length = error_mark_node;
1913           break;
1914         }
1915
1916       if ((ffebld_size_known (ffebld_left (expr))
1917            == FFETARGET_charactersizeNONE)
1918           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
1919         {                       /* Possible blank-padding needed, copy into
1920                                    temporary. */
1921           tree tempvar;
1922           tree args;
1923           tree newlen;
1924
1925           assert (ffecom_pending_calls_ != 0);
1926           tempvar = ffecom_push_tempvar (char_type_node,
1927                                          ffebld_size (expr), -1, TRUE);
1928           tempvar = ffecom_1 (ADDR_EXPR,
1929                               build_pointer_type (TREE_TYPE (tempvar)),
1930                               tempvar);
1931
1932           newlen = build_int_2 (ffebld_size (expr), 0);
1933           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
1934
1935           args = build_tree_list (NULL_TREE, tempvar);
1936           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
1937           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
1938           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
1939             = build_tree_list (NULL_TREE, *length);
1940
1941           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args);
1942           TREE_SIDE_EFFECTS (item) = 1;
1943           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
1944                            tempvar);
1945           *length = newlen;
1946         }
1947       else
1948         {                       /* Just truncate the length. */
1949           *length = build_int_2 (ffebld_size (expr), 0);
1950           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1951         }
1952       break;
1953
1954     default:
1955       assert ("bad op for single char arg expr" == NULL);
1956       item = NULL_TREE;
1957       break;
1958     }
1959
1960   *xitem = item;
1961 }
1962 #endif
1963
1964 /* Check the size of the type to be sure it doesn't overflow the
1965    "portable" capacities of the compiler back end.  `dummy' types
1966    can generally overflow the normal sizes as long as the computations
1967    themselves don't overflow.  A particular target of the back end
1968    must still enforce its size requirements, though, and the back
1969    end takes care of this in stor-layout.c.  */
1970
1971 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1972 static tree
1973 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
1974 {
1975   if (TREE_CODE (type) == ERROR_MARK)
1976     return type;
1977
1978   if (TYPE_SIZE (type) == NULL_TREE)
1979     return type;
1980
1981   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
1982     return type;
1983
1984   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
1985       || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
1986       || TREE_OVERFLOW (TYPE_SIZE (type)))
1987     {
1988       ffebad_start (FFEBAD_ARRAY_LARGE);
1989       ffebad_string (ffesymbol_text (s));
1990       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
1991       ffebad_finish ();
1992
1993       return error_mark_node;
1994     }
1995
1996   return type;
1997 }
1998 #endif
1999
2000 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2001    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2002    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2003
2004 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2005 static tree
2006 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2007 {
2008   ffetargetCharacterSize sz = ffesymbol_size (s);
2009   tree highval;
2010   tree tlen;
2011   tree type = *xtype;
2012
2013   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2014     tlen = NULL_TREE;           /* A statement function, no length passed. */
2015   else
2016     {
2017       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2018         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2019                                                ffesymbol_text (s), 0);
2020       else
2021         tlen = ffecom_get_invented_identifier ("__g77_%s",
2022                                                "length", 0);
2023       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2024 #if BUILT_FOR_270
2025       DECL_ARTIFICIAL (tlen) = 1;
2026 #endif
2027     }
2028
2029   if (sz == FFETARGET_charactersizeNONE)
2030     {
2031       assert (tlen != NULL_TREE);
2032       highval = tlen;
2033     }
2034   else
2035     {
2036       highval = build_int_2 (sz, 0);
2037       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2038     }
2039
2040   type = build_array_type (type,
2041                            build_range_type (ffecom_f2c_ftnlen_type_node,
2042                                              ffecom_f2c_ftnlen_one_node,
2043                                              highval));
2044
2045   *xtype = type;
2046   return tlen;
2047 }
2048
2049 #endif
2050 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2051
2052    ffecomConcatList_ catlist;
2053    ffebld expr;  // expr of CHARACTER basictype.
2054    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2055    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2056
2057    Scans expr for character subexpressions, updates and returns catlist
2058    accordingly.  */
2059
2060 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2061 static ffecomConcatList_
2062 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2063                             ffetargetCharacterSize max)
2064 {
2065   ffetargetCharacterSize sz;
2066
2067 recurse:                        /* :::::::::::::::::::: */
2068
2069   if (expr == NULL)
2070     return catlist;
2071
2072   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2073     return catlist;             /* Don't append any more items. */
2074
2075   switch (ffebld_op (expr))
2076     {
2077     case FFEBLD_opCONTER:
2078     case FFEBLD_opSYMTER:
2079     case FFEBLD_opARRAYREF:
2080     case FFEBLD_opFUNCREF:
2081     case FFEBLD_opSUBSTR:
2082     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2083                                    if they don't need to preserve it. */
2084       if (catlist.count == catlist.max)
2085         {                       /* Make a (larger) list. */
2086           ffebld *newx;
2087           int newmax;
2088
2089           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2090           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2091                                 newmax * sizeof (newx[0]));
2092           if (catlist.max != 0)
2093             {
2094               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2095               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2096                               catlist.max * sizeof (newx[0]));
2097             }
2098           catlist.max = newmax;
2099           catlist.exprs = newx;
2100         }
2101       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2102         catlist.minlen += sz;
2103       else
2104         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2105       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2106         catlist.maxlen = sz;
2107       else
2108         catlist.maxlen += sz;
2109       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2110         {                       /* This item overlaps (or is beyond) the end
2111                                    of the destination. */
2112           switch (ffebld_op (expr))
2113             {
2114             case FFEBLD_opCONTER:
2115             case FFEBLD_opSYMTER:
2116             case FFEBLD_opARRAYREF:
2117             case FFEBLD_opFUNCREF:
2118             case FFEBLD_opSUBSTR:
2119               break;            /* ~~Do useful truncations here. */
2120
2121             default:
2122               assert ("op changed or inconsistent switches!" == NULL);
2123               break;
2124             }
2125         }
2126       catlist.exprs[catlist.count++] = expr;
2127       return catlist;
2128
2129     case FFEBLD_opPAREN:
2130       expr = ffebld_left (expr);
2131       goto recurse;             /* :::::::::::::::::::: */
2132
2133     case FFEBLD_opCONCATENATE:
2134       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2135       expr = ffebld_right (expr);
2136       goto recurse;             /* :::::::::::::::::::: */
2137
2138 #if 0                           /* Breaks passing small actual arg to larger
2139                                    dummy arg of sfunc */
2140     case FFEBLD_opCONVERT:
2141       expr = ffebld_left (expr);
2142       {
2143         ffetargetCharacterSize cmax;
2144
2145         cmax = catlist.len + ffebld_size_known (expr);
2146
2147         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2148           max = cmax;
2149       }
2150       goto recurse;             /* :::::::::::::::::::: */
2151 #endif
2152
2153     case FFEBLD_opANY:
2154       return catlist;
2155
2156     default:
2157       assert ("bad op in _gather_" == NULL);
2158       return catlist;
2159     }
2160 }
2161
2162 #endif
2163 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2164
2165    ffecomConcatList_ catlist;
2166    ffecom_concat_list_kill_(catlist);
2167
2168    Anything allocated within the list info is deallocated.  */
2169
2170 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2171 static void
2172 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2173 {
2174   if (catlist.max != 0)
2175     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2176                     catlist.max * sizeof (catlist.exprs[0]));
2177 }
2178
2179 #endif
2180 /* ffecom_concat_list_new_ -- Make list of concatenated string exprs
2181
2182    ffecomConcatList_ catlist;
2183    ffebld expr;  // Root expr of CHARACTER basictype.
2184    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2185    catlist = ffecom_concat_list_new_(expr,max);
2186
2187    Returns a flattened list of concatenated subexpressions given a
2188    tree of such expressions.  */
2189
2190 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2191 static ffecomConcatList_
2192 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2193 {
2194   ffecomConcatList_ catlist;
2195
2196   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2197   return ffecom_concat_list_gather_ (catlist, expr, max);
2198 }
2199
2200 #endif
2201
2202 /* Provide some kind of useful info on member of aggregate area,
2203    since current g77/gcc technology does not provide debug info
2204    on these members.  */
2205
2206 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2207 static void
2208 ffecom_debug_kludge_ (tree aggr, char *aggr_type, ffesymbol member,
2209                       tree member_type UNUSED, ffetargetOffset offset)
2210 {
2211   tree value;
2212   tree decl;
2213   int len;
2214   char *buff;
2215   char space[120];
2216 #if 0
2217   tree type_id;
2218
2219   for (type_id = member_type;
2220        TREE_CODE (type_id) != IDENTIFIER_NODE;
2221        )
2222     {
2223       switch (TREE_CODE (type_id))
2224         {
2225         case INTEGER_TYPE:
2226         case REAL_TYPE:
2227           type_id = TYPE_NAME (type_id);
2228           break;
2229
2230         case ARRAY_TYPE:
2231         case COMPLEX_TYPE:
2232           type_id = TREE_TYPE (type_id);
2233           break;
2234
2235         default:
2236           assert ("no IDENTIFIER_NODE for type!" == NULL);
2237           type_id = error_mark_node;
2238           break;
2239         }
2240     }
2241 #endif
2242
2243   if (ffecom_transform_only_dummies_
2244       || !ffe_is_debug_kludge ())
2245     return;     /* Can't do this yet, maybe later. */
2246
2247   len = 60
2248     + strlen (aggr_type)
2249     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2250 #if 0
2251     + IDENTIFIER_LENGTH (type_id);
2252 #endif
2253
2254   if (((size_t) len) >= ARRAY_SIZE (space))
2255     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2256   else
2257     buff = &space[0];
2258
2259   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2260            aggr_type,
2261            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2262            (long int) offset);
2263
2264   value = build_string (len, buff);
2265   TREE_TYPE (value)
2266     = build_type_variant (build_array_type (char_type_node,
2267                                             build_range_type
2268                                             (integer_type_node,
2269                                              integer_one_node,
2270                                              build_int_2 (strlen (buff), 0))),
2271                           1, 0);
2272   decl = build_decl (VAR_DECL,
2273                      ffecom_get_identifier_ (ffesymbol_text (member)),
2274                      TREE_TYPE (value));
2275   TREE_CONSTANT (decl) = 1;
2276   TREE_STATIC (decl) = 1;
2277   DECL_INITIAL (decl) = error_mark_node;
2278   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2279   decl = start_decl (decl, FALSE);
2280   finish_decl (decl, value, FALSE);
2281
2282   if (buff != &space[0])
2283     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2284 }
2285 #endif
2286
2287 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2288
2289    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2290    int i;  // entry# for this entrypoint (used by master fn)
2291    ffecom_do_entrypoint_(s,i);
2292
2293    Makes a public entry point that calls our private master fn (already
2294    compiled).  */
2295
2296 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2297 static void
2298 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2299 {
2300   ffebld item;
2301   tree type;                    /* Type of function. */
2302   tree multi_retval;            /* Var holding return value (union). */
2303   tree result;                  /* Var holding result. */
2304   ffeinfoBasictype bt;
2305   ffeinfoKindtype kt;
2306   ffeglobal g;
2307   ffeglobalType gt;
2308   bool charfunc;                /* All entry points return same type
2309                                    CHARACTER. */
2310   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2311   bool multi;                   /* Master fn has multiple return types. */
2312   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2313   int yes;
2314
2315   /* c-parse.y indeed does call suspend_momentary and not only ignores the
2316      return value, but also never calls resume_momentary, when starting an
2317      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
2318      same thing.  It shouldn't be a problem since start_function calls
2319      temporary_allocation, but it might be necessary.  If it causes a problem
2320      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
2321      comment appears twice in thist file.  */
2322
2323   suspend_momentary ();
2324
2325   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2326
2327   switch (ffecom_primary_entry_kind_)
2328     {
2329     case FFEINFO_kindFUNCTION:
2330
2331       /* Determine actual return type for function. */
2332
2333       gt = FFEGLOBAL_typeFUNC;
2334       bt = ffesymbol_basictype (fn);
2335       kt = ffesymbol_kindtype (fn);
2336       if (bt == FFEINFO_basictypeNONE)
2337         {
2338           ffeimplic_establish_symbol (fn);
2339           if (ffesymbol_funcresult (fn) != NULL)
2340             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2341           bt = ffesymbol_basictype (fn);
2342           kt = ffesymbol_kindtype (fn);
2343         }
2344
2345       if (bt == FFEINFO_basictypeCHARACTER)
2346         charfunc = TRUE, cmplxfunc = FALSE;
2347       else if ((bt == FFEINFO_basictypeCOMPLEX)
2348                && ffesymbol_is_f2c (fn))
2349         charfunc = FALSE, cmplxfunc = TRUE;
2350       else
2351         charfunc = cmplxfunc = FALSE;
2352
2353       if (charfunc)
2354         type = ffecom_tree_fun_type_void;
2355       else if (ffesymbol_is_f2c (fn))
2356         type = ffecom_tree_fun_type[bt][kt];
2357       else
2358         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2359
2360       if ((type == NULL_TREE)
2361           || (TREE_TYPE (type) == NULL_TREE))
2362         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2363
2364       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2365       break;
2366
2367     case FFEINFO_kindSUBROUTINE:
2368       gt = FFEGLOBAL_typeSUBR;
2369       bt = FFEINFO_basictypeNONE;
2370       kt = FFEINFO_kindtypeNONE;
2371       if (ffecom_is_altreturning_)
2372         {                       /* Am _I_ altreturning? */
2373           for (item = ffesymbol_dummyargs (fn);
2374                item != NULL;
2375                item = ffebld_trail (item))
2376             {
2377               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2378                 {
2379                   altreturning = TRUE;
2380                   break;
2381                 }
2382             }
2383           if (altreturning)
2384             type = ffecom_tree_subr_type;
2385           else
2386             type = ffecom_tree_fun_type_void;
2387         }
2388       else
2389         type = ffecom_tree_fun_type_void;
2390       charfunc = FALSE;
2391       cmplxfunc = FALSE;
2392       multi = FALSE;
2393       break;
2394
2395     default:
2396       assert ("say what??" == NULL);
2397       /* Fall through. */
2398     case FFEINFO_kindANY:
2399       gt = FFEGLOBAL_typeANY;
2400       bt = FFEINFO_basictypeNONE;
2401       kt = FFEINFO_kindtypeNONE;
2402       type = error_mark_node;
2403       charfunc = FALSE;
2404       cmplxfunc = FALSE;
2405       multi = FALSE;
2406       break;
2407     }
2408
2409   /* build_decl uses the current lineno and input_filename to set the decl
2410      source info.  So, I've putzed with ffestd and ffeste code to update that
2411      source info to point to the appropriate statement just before calling
2412      ffecom_do_entrypoint (which calls this fn).  */
2413
2414   start_function (ffecom_get_external_identifier_ (fn),
2415                   type,
2416                   0,            /* nested/inline */
2417                   1);           /* TREE_PUBLIC */
2418
2419   if (((g = ffesymbol_global (fn)) != NULL)
2420       && ((ffeglobal_type (g) == gt)
2421           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2422     {
2423       ffeglobal_set_hook (g, current_function_decl);
2424     }
2425
2426   /* Reset args in master arg list so they get retransitioned. */
2427
2428   for (item = ffecom_master_arglist_;
2429        item != NULL;
2430        item = ffebld_trail (item))
2431     {
2432       ffebld arg;
2433       ffesymbol s;
2434
2435       arg = ffebld_head (item);
2436       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2437         continue;               /* Alternate return or some such thing. */
2438       s = ffebld_symter (arg);
2439       ffesymbol_hook (s).decl_tree = NULL_TREE;
2440       ffesymbol_hook (s).length_tree = NULL_TREE;
2441     }
2442
2443   /* Build dummy arg list for this entry point. */
2444
2445   yes = suspend_momentary ();
2446
2447   if (charfunc || cmplxfunc)
2448     {                           /* Prepend arg for where result goes. */
2449       tree type;
2450       tree length;
2451
2452       if (charfunc)
2453         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2454       else
2455         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2456
2457       result = ffecom_get_invented_identifier ("__g77_%s",
2458                                                "result", 0);
2459
2460       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2461
2462       if (charfunc)
2463         length = ffecom_char_enhance_arg_ (&type, fn);
2464       else
2465         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2466
2467       type = build_pointer_type (type);
2468       result = build_decl (PARM_DECL, result, type);
2469
2470       push_parm_decl (result);
2471       ffecom_func_result_ = result;
2472
2473       if (charfunc)
2474         {
2475           push_parm_decl (length);
2476           ffecom_func_length_ = length;
2477         }
2478     }
2479   else
2480     result = DECL_RESULT (current_function_decl);
2481
2482   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2483
2484   resume_momentary (yes);
2485
2486   store_parm_decls (0);
2487
2488   ffecom_start_compstmt_ ();
2489
2490   /* Make local var to hold return type for multi-type master fn. */
2491
2492   if (multi)
2493     {
2494       yes = suspend_momentary ();
2495
2496       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2497                                                      "multi_retval", 0);
2498       multi_retval = build_decl (VAR_DECL, multi_retval,
2499                                  ffecom_multi_type_node_);
2500       multi_retval = start_decl (multi_retval, FALSE);
2501       finish_decl (multi_retval, NULL_TREE, FALSE);
2502
2503       resume_momentary (yes);
2504     }
2505   else
2506     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2507
2508   /* Here we emit the actual code for the entry point. */
2509
2510   {
2511     ffebld list;
2512     ffebld arg;
2513     ffesymbol s;
2514     tree arglist = NULL_TREE;
2515     tree *plist = &arglist;
2516     tree prepend;
2517     tree call;
2518     tree actarg;
2519     tree master_fn;
2520
2521     /* Prepare actual arg list based on master arg list. */
2522
2523     for (list = ffecom_master_arglist_;
2524          list != NULL;
2525          list = ffebld_trail (list))
2526       {
2527         arg = ffebld_head (list);
2528         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2529           continue;
2530         s = ffebld_symter (arg);
2531         if (ffesymbol_hook (s).decl_tree == NULL_TREE)
2532           actarg = null_pointer_node;   /* We don't have this arg. */
2533         else
2534           actarg = ffesymbol_hook (s).decl_tree;
2535         *plist = build_tree_list (NULL_TREE, actarg);
2536         plist = &TREE_CHAIN (*plist);
2537       }
2538
2539     /* This code appends the length arguments for character
2540        variables/arrays.  */
2541
2542     for (list = ffecom_master_arglist_;
2543          list != NULL;
2544          list = ffebld_trail (list))
2545       {
2546         arg = ffebld_head (list);
2547         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2548           continue;
2549         s = ffebld_symter (arg);
2550         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2551           continue;             /* Only looking for CHARACTER arguments. */
2552         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2553           continue;             /* Only looking for variables and arrays. */
2554         if (ffesymbol_hook (s).length_tree == NULL_TREE)
2555           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2556         else
2557           actarg = ffesymbol_hook (s).length_tree;
2558         *plist = build_tree_list (NULL_TREE, actarg);
2559         plist = &TREE_CHAIN (*plist);
2560       }
2561
2562     /* Prepend character-value return info to actual arg list. */
2563
2564     if (charfunc)
2565       {
2566         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2567         TREE_CHAIN (prepend)
2568           = build_tree_list (NULL_TREE, ffecom_func_length_);
2569         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2570         arglist = prepend;
2571       }
2572
2573     /* Prepend multi-type return value to actual arg list. */
2574
2575     if (multi)
2576       {
2577         prepend
2578           = build_tree_list (NULL_TREE,
2579                              ffecom_1 (ADDR_EXPR,
2580                               build_pointer_type (TREE_TYPE (multi_retval)),
2581                                        multi_retval));
2582         TREE_CHAIN (prepend) = arglist;
2583         arglist = prepend;
2584       }
2585
2586     /* Prepend my entry-point number to the actual arg list. */
2587
2588     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2589     TREE_CHAIN (prepend) = arglist;
2590     arglist = prepend;
2591
2592     /* Build the call to the master function. */
2593
2594     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2595     call = ffecom_3s (CALL_EXPR,
2596                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2597                       master_fn, arglist, NULL_TREE);
2598
2599     /* Decide whether the master function is a function or subroutine, and
2600        handle the return value for my entry point. */
2601
2602     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2603                      && !altreturning))
2604       {
2605         expand_expr_stmt (call);
2606         expand_null_return ();
2607       }
2608     else if (multi && cmplxfunc)
2609       {
2610         expand_expr_stmt (call);
2611         result
2612           = ffecom_1 (INDIRECT_REF,
2613                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2614                       result);
2615         result = ffecom_modify (NULL_TREE, result,
2616                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2617                                           multi_retval,
2618                                           ffecom_multi_fields_[bt][kt]));
2619         expand_expr_stmt (result);
2620         expand_null_return ();
2621       }
2622     else if (multi)
2623       {
2624         expand_expr_stmt (call);
2625         result
2626           = ffecom_modify (NULL_TREE, result,
2627                            convert (TREE_TYPE (result),
2628                                     ffecom_2 (COMPONENT_REF,
2629                                               ffecom_tree_type[bt][kt],
2630                                               multi_retval,
2631                                               ffecom_multi_fields_[bt][kt])));
2632         expand_return (result);
2633       }
2634     else if (cmplxfunc)
2635       {
2636         result
2637           = ffecom_1 (INDIRECT_REF,
2638                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2639                       result);
2640         result = ffecom_modify (NULL_TREE, result, call);
2641         expand_expr_stmt (result);
2642         expand_null_return ();
2643       }
2644     else
2645       {
2646         result = ffecom_modify (NULL_TREE,
2647                                 result,
2648                                 convert (TREE_TYPE (result),
2649                                          call));
2650         expand_return (result);
2651       }
2652
2653     clear_momentary ();
2654   }
2655
2656   ffecom_end_compstmt_ ();
2657
2658   finish_function (0);
2659
2660   ffecom_doing_entry_ = FALSE;
2661 }
2662
2663 #endif
2664 /* Transform expr into gcc tree with possible destination
2665
2666    Recursive descent on expr while making corresponding tree nodes and
2667    attaching type info and such.  If destination supplied and compatible
2668    with temporary that would be made in certain cases, temporary isn't
2669    made, destination used instead, and dest_used flag set TRUE.
2670
2671    If TREE_TYPE is non-null, it overrides the type that the expression
2672    would normally be computed in.  This is most useful for array indices
2673    which should be done in sizetype for efficiency.  */
2674
2675 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2676 static tree
2677 ffecom_expr_ (ffebld expr, tree tree_type_x, tree dest_tree,
2678               ffebld dest, bool *dest_used,
2679               bool assignp)
2680 {
2681   tree item;
2682   tree list;
2683   tree args;
2684   ffeinfoBasictype bt;
2685   ffeinfoKindtype kt;
2686   tree t;
2687   tree dt;                      /* decl_tree for an ffesymbol. */
2688   tree tree_type;
2689   tree left, right;
2690   ffesymbol s;
2691   enum tree_code code;
2692
2693   assert (expr != NULL);
2694
2695   if (dest_used != NULL)
2696     *dest_used = FALSE;
2697
2698   bt = ffeinfo_basictype (ffebld_info (expr));
2699   kt = ffeinfo_kindtype (ffebld_info (expr));
2700   tree_type = ffecom_tree_type[bt][kt];
2701
2702   switch (ffebld_op (expr))
2703     {
2704     case FFEBLD_opACCTER:
2705       {
2706         ffebitCount i;
2707         ffebit bits = ffebld_accter_bits (expr);
2708         ffetargetOffset source_offset = 0;
2709         size_t size;
2710         tree purpose;
2711
2712         size = ffetype_size (ffeinfo_type (bt, kt));
2713
2714         list = item = NULL;
2715         for (;;)
2716           {
2717             ffebldConstantUnion cu;
2718             ffebitCount length;
2719             bool value;
2720             ffebldConstantArray ca = ffebld_accter (expr);
2721
2722             ffebit_test (bits, source_offset, &value, &length);
2723             if (length == 0)
2724               break;
2725
2726             if (value)
2727               {
2728                 for (i = 0; i < length; ++i)
2729                   {
2730                     cu = ffebld_constantarray_get (ca, bt, kt,
2731                                                    source_offset + i);
2732
2733                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
2734
2735                     if (i == 0)
2736                       purpose = build_int_2 (source_offset, 0);
2737                     else
2738                       purpose = NULL_TREE;
2739
2740                     if (list == NULL_TREE)
2741                       list = item = build_tree_list (purpose, t);
2742                     else
2743                       {
2744                         TREE_CHAIN (item) = build_tree_list (purpose, t);
2745                         item = TREE_CHAIN (item);
2746                       }
2747                   }
2748               }
2749             source_offset += length;
2750           }
2751       }
2752
2753       item = build_int_2 (ffebld_accter_size (expr), 0);
2754       ffebit_kill (ffebld_accter_bits (expr));
2755       TREE_TYPE (item) = ffecom_integer_type_node;
2756       item
2757         = build_array_type
2758           (tree_type,
2759            build_range_type (ffecom_integer_type_node,
2760                              ffecom_integer_zero_node,
2761                              item));
2762       list = build (CONSTRUCTOR, item, NULL_TREE, list);
2763       TREE_CONSTANT (list) = 1;
2764       TREE_STATIC (list) = 1;
2765       return list;
2766
2767     case FFEBLD_opARRTER:
2768       {
2769         ffetargetOffset i;
2770
2771         list = item = NULL_TREE;
2772         for (i = 0; i < ffebld_arrter_size (expr); ++i)
2773           {
2774             ffebldConstantUnion cu
2775             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
2776
2777             t = ffecom_constantunion (&cu, bt, kt, tree_type);
2778
2779             if (list == NULL_TREE)
2780               list = item = build_tree_list (NULL_TREE, t);
2781             else
2782               {
2783                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
2784                 item = TREE_CHAIN (item);
2785               }
2786           }
2787       }
2788
2789       item = build_int_2 (ffebld_arrter_size (expr), 0);
2790       TREE_TYPE (item) = ffecom_integer_type_node;
2791       item
2792         = build_array_type
2793           (tree_type,
2794            build_range_type (ffecom_integer_type_node,
2795                              ffecom_integer_one_node,
2796                              item));
2797       list = build (CONSTRUCTOR, item, NULL_TREE, list);
2798       TREE_CONSTANT (list) = 1;
2799       TREE_STATIC (list) = 1;
2800       return list;
2801
2802     case FFEBLD_opCONTER:
2803       item
2804         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
2805                                 bt, kt, tree_type);
2806       return item;
2807
2808     case FFEBLD_opSYMTER:
2809       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
2810           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
2811         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
2812       s = ffebld_symter (expr);
2813       t = ffesymbol_hook (s).decl_tree;
2814
2815       if (assignp)
2816         {                       /* ASSIGN'ed-label expr. */
2817           if (ffe_is_ugly_assign ())
2818             {
2819               /* User explicitly wants ASSIGN'ed variables to be at the same
2820                  memory address as the variables when used in non-ASSIGN
2821                  contexts.  That can make old, arcane, non-standard code
2822                  work, but don't try to do it when a pointer wouldn't fit
2823                  in the normal variable (take other approach, and warn,
2824                  instead).  */
2825
2826               if (t == NULL_TREE)
2827                 {
2828                   s = ffecom_sym_transform_ (s);
2829                   t = ffesymbol_hook (s).decl_tree;
2830                   assert (t != NULL_TREE);
2831                 }
2832
2833               if (t == error_mark_node)
2834                 return t;
2835
2836               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
2837                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
2838                 {
2839                   if (ffesymbol_hook (s).addr)
2840                     t = ffecom_1 (INDIRECT_REF,
2841                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
2842                   return t;
2843                 }
2844
2845               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
2846                 {
2847                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
2848                                     FFEBAD_severityWARNING);
2849                   ffebad_string (ffesymbol_text (s));
2850                   ffebad_here (0, ffesymbol_where_line (s),
2851                                ffesymbol_where_column (s));
2852                   ffebad_finish ();
2853                 }
2854             }
2855
2856           /* Don't use the normal variable's tree for ASSIGN, though mark
2857              it as in the system header (housekeeping).  Use an explicit,
2858              specially created sibling that is known to be wide enough
2859              to hold pointers to labels.  */
2860
2861           if (t != NULL_TREE
2862               && TREE_CODE (t) == VAR_DECL)
2863             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
2864
2865           t = ffesymbol_hook (s).assign_tree;
2866           if (t == NULL_TREE)
2867             {
2868               s = ffecom_sym_transform_assign_ (s);
2869               t = ffesymbol_hook (s).assign_tree;
2870               assert (t != NULL_TREE);
2871             }
2872         }
2873       else
2874         {
2875           if (t == NULL_TREE)
2876             {
2877               s = ffecom_sym_transform_ (s);
2878               t = ffesymbol_hook (s).decl_tree;
2879               assert (t != NULL_TREE);
2880             }
2881           if (ffesymbol_hook (s).addr)
2882             t = ffecom_1 (INDIRECT_REF,
2883                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
2884         }
2885       return t;
2886
2887     case FFEBLD_opARRAYREF:
2888       {
2889         ffebld dims[FFECOM_dimensionsMAX];
2890 #if FFECOM_FASTER_ARRAY_REFS
2891         tree array;
2892 #endif
2893         int i;
2894
2895 #if FFECOM_FASTER_ARRAY_REFS
2896         t = ffecom_ptr_to_expr (ffebld_left (expr));
2897 #else
2898         t = ffecom_expr (ffebld_left (expr));
2899 #endif
2900         if (t == error_mark_node)
2901           return t;
2902
2903         if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING)
2904             && !mark_addressable (t))
2905           return error_mark_node;       /* Make sure non-const ref is to
2906                                            non-reg. */
2907
2908         /* Build up ARRAY_REFs in reverse order (since we're column major
2909            here in Fortran land). */
2910
2911         for (i = 0, expr = ffebld_right (expr);
2912              expr != NULL;
2913              expr = ffebld_trail (expr))
2914           dims[i++] = ffebld_head (expr);
2915
2916 #if FFECOM_FASTER_ARRAY_REFS
2917         for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t)));
2918              i >= 0;
2919              --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
2920           t = ffecom_2 (PLUS_EXPR,
2921                         build_pointer_type (TREE_TYPE (array)),
2922                         t,
2923                         size_binop (MULT_EXPR,
2924                                     size_in_bytes (TREE_TYPE (array)),
2925                                     size_binop (MINUS_EXPR,
2926                                                 ffecom_expr (dims[i]),
2927                                                 TYPE_MIN_VALUE (TYPE_DOMAIN (array)))));
2928         t = ffecom_1 (INDIRECT_REF,
2929                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))),
2930                       t);
2931 #else
2932         while (i > 0)
2933           t = ffecom_2 (ARRAY_REF,
2934                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))),
2935                         t,
2936                         ffecom_expr_ (dims[--i], sizetype, NULL, NULL,
2937                                       NULL, FALSE));
2938 #endif
2939
2940         return t;
2941       }
2942
2943     case FFEBLD_opUPLUS:
2944       left = ffecom_expr_ (ffebld_left (expr), tree_type_x, NULL, NULL,
2945                            NULL, FALSE);
2946       return ffecom_1 (NOP_EXPR, tree_type, left);
2947
2948     case FFEBLD_opPAREN:        /* ~~~Make sure Fortran rules respected here */
2949       left = ffecom_expr_ (ffebld_left (expr), tree_type_x, NULL, NULL,
2950                            NULL, FALSE);
2951       return ffecom_1 (NOP_EXPR, tree_type, left);
2952
2953     case FFEBLD_opUMINUS:
2954       left = ffecom_expr_ (ffebld_left (expr), tree_type_x, NULL, NULL,
2955                            NULL, FALSE);
2956       if (tree_type_x)
2957         {
2958           tree_type = tree_type_x;
2959           left = convert (tree_type, left);
2960         }
2961       return ffecom_1 (NEGATE_EXPR, tree_type, left);
2962
2963     case FFEBLD_opADD:
2964       left = ffecom_expr_ (ffebld_left (expr), tree_type_x, NULL, NULL,
2965                            NULL, FALSE);
2966       right = ffecom_expr_ (ffebld_right (expr), tree_type_x, NULL, NULL,
2967                             NULL, FALSE);
2968       if (tree_type_x)
2969         {
2970           tree_type = tree_type_x;
2971           left = convert (tree_type, left);
2972           right = convert (tree_type, right);
2973         }
2974       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
2975
2976     case FFEBLD_opSUBTRACT:
2977       left = ffecom_expr_ (ffebld_left (expr), tree_type_x, NULL, NULL,
2978                            NULL, FALSE);
2979       right = ffecom_expr_ (ffebld_right (expr), tree_type_x, NULL, NULL,
2980                             NULL, FALSE);
2981       if (tree_type_x)
2982         {
2983           tree_type = tree_type_x;
2984           left = convert (tree_type, left);
2985           right = convert (tree_type, right);
2986         }
2987       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
2988
2989     case FFEBLD_opMULTIPLY:
2990       left = ffecom_expr_ (ffebld_left (expr), tree_type_x, NULL, NULL,
2991                            NULL, FALSE);
2992       right = ffecom_expr_ (ffebld_right (expr), tree_type_x, NULL, NULL,
2993                             NULL, FALSE);
2994       if (tree_type_x)
2995         {
2996           tree_type = tree_type_x;
2997           left = convert (tree_type, left);
2998           right = convert (tree_type, right);
2999         }
3000       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3001
3002     case FFEBLD_opDIVIDE:
3003       left = ffecom_expr_ (ffebld_left (expr), tree_type_x, NULL, NULL,
3004                            NULL, FALSE);
3005       right = ffecom_expr_ (ffebld_right (expr), tree_type_x, NULL, NULL,
3006                             NULL, FALSE);
3007       if (tree_type_x)
3008         {
3009           tree_type = tree_type_x;
3010           left = convert (tree_type, left);
3011           right = convert (tree_type, right);
3012         }
3013       return ffecom_tree_divide_ (tree_type, left, right,
3014                                   dest_tree, dest, dest_used);
3015
3016     case FFEBLD_opPOWER:
3017       {
3018         ffebld left = ffebld_left (expr);
3019         ffebld right = ffebld_right (expr);
3020         ffecomGfrt code;
3021         ffeinfoKindtype rtkt;
3022
3023         switch (ffeinfo_basictype (ffebld_info (right)))
3024           {
3025           case FFEINFO_basictypeINTEGER:
3026             if (1 || optimize)
3027               {
3028                 item = ffecom_expr_power_integer_ (left, right);
3029                 if (item != NULL_TREE)
3030                   return item;
3031               }
3032
3033             rtkt = FFEINFO_kindtypeINTEGER1;
3034             switch (ffeinfo_basictype (ffebld_info (left)))
3035               {
3036               case FFEINFO_basictypeINTEGER:
3037                 if ((ffeinfo_kindtype (ffebld_info (left))
3038                     == FFEINFO_kindtypeINTEGER4)
3039                     || (ffeinfo_kindtype (ffebld_info (right))
3040                         == FFEINFO_kindtypeINTEGER4))
3041                   {
3042                     code = FFECOM_gfrtPOW_QQ;
3043                     rtkt = FFEINFO_kindtypeINTEGER4;
3044                   }
3045                 else
3046                   code = FFECOM_gfrtPOW_II;
3047                 break;
3048
3049               case FFEINFO_basictypeREAL:
3050                 if (ffeinfo_kindtype (ffebld_info (left))
3051                     == FFEINFO_kindtypeREAL1)
3052                   code = FFECOM_gfrtPOW_RI;
3053                 else
3054                   code = FFECOM_gfrtPOW_DI;
3055                 break;
3056
3057               case FFEINFO_basictypeCOMPLEX:
3058                 if (ffeinfo_kindtype (ffebld_info (left))
3059                     == FFEINFO_kindtypeREAL1)
3060                   code = FFECOM_gfrtPOW_CI;     /* Overlapping result okay. */
3061                 else
3062                   code = FFECOM_gfrtPOW_ZI;     /* Overlapping result okay. */
3063                 break;
3064
3065               default:
3066                 assert ("bad pow_*i" == NULL);
3067                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3068                 break;
3069               }
3070             if (ffeinfo_kindtype (ffebld_info (left)) != rtkt)
3071               left = ffeexpr_convert (left, NULL, NULL,
3072                                       FFEINFO_basictypeINTEGER,
3073                                       rtkt, 0,
3074                                       FFETARGET_charactersizeNONE,
3075                                       FFEEXPR_contextLET);
3076             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3077               right = ffeexpr_convert (right, NULL, NULL,
3078                                        FFEINFO_basictypeINTEGER,
3079                                        rtkt, 0,
3080                                        FFETARGET_charactersizeNONE,
3081                                        FFEEXPR_contextLET);
3082             break;
3083
3084           case FFEINFO_basictypeREAL:
3085             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3086               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3087                                       FFEINFO_kindtypeREALDOUBLE, 0,
3088                                       FFETARGET_charactersizeNONE,
3089                                       FFEEXPR_contextLET);
3090             if (ffeinfo_kindtype (ffebld_info (right))
3091                 == FFEINFO_kindtypeREAL1)
3092               right = ffeexpr_convert (right, NULL, NULL,
3093                                        FFEINFO_basictypeREAL,
3094                                        FFEINFO_kindtypeREALDOUBLE, 0,
3095                                        FFETARGET_charactersizeNONE,
3096                                        FFEEXPR_contextLET);
3097             code = FFECOM_gfrtPOW_DD;
3098             break;
3099
3100           case FFEINFO_basictypeCOMPLEX:
3101             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3102               left = ffeexpr_convert (left, NULL, NULL,
3103                                       FFEINFO_basictypeCOMPLEX,
3104                                       FFEINFO_kindtypeREALDOUBLE, 0,
3105                                       FFETARGET_charactersizeNONE,
3106                                       FFEEXPR_contextLET);
3107             if (ffeinfo_kindtype (ffebld_info (right))
3108                 == FFEINFO_kindtypeREAL1)
3109               right = ffeexpr_convert (right, NULL, NULL,
3110                                        FFEINFO_basictypeCOMPLEX,
3111                                        FFEINFO_kindtypeREALDOUBLE, 0,
3112                                        FFETARGET_charactersizeNONE,
3113                                        FFEEXPR_contextLET);
3114             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3115             break;
3116
3117           default:
3118             assert ("bad pow_x*" == NULL);
3119             code = FFECOM_gfrtPOW_II;
3120             break;
3121           }
3122         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3123                                    ffecom_gfrt_kindtype (code),
3124                                    (ffe_is_f2c_library ()
3125                                     && ffecom_gfrt_complex_[code]),
3126                                    tree_type, left, right,
3127                                    dest_tree, dest, dest_used,
3128                                    NULL_TREE, FALSE);
3129       }
3130
3131     case FFEBLD_opNOT:
3132       switch (bt)
3133         {
3134         case FFEINFO_basictypeLOGICAL:
3135           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3136           return convert (tree_type, item);
3137
3138         case FFEINFO_basictypeINTEGER:
3139           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3140                            ffecom_expr (ffebld_left (expr)));
3141
3142         default:
3143           assert ("NOT bad basictype" == NULL);
3144           /* Fall through. */
3145         case FFEINFO_basictypeANY:
3146           return error_mark_node;
3147         }
3148       break;
3149
3150     case FFEBLD_opFUNCREF:
3151       assert (ffeinfo_basictype (ffebld_info (expr))
3152               != FFEINFO_basictypeCHARACTER);
3153       /* Fall through.   */
3154     case FFEBLD_opSUBRREF:
3155       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3156           == FFEINFO_whereINTRINSIC)
3157         {                       /* Invocation of an intrinsic. */
3158           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3159                                          dest_used);
3160           return item;
3161         }
3162       s = ffebld_symter (ffebld_left (expr));
3163       dt = ffesymbol_hook (s).decl_tree;
3164       if (dt == NULL_TREE)
3165         {
3166           s = ffecom_sym_transform_ (s);
3167           dt = ffesymbol_hook (s).decl_tree;
3168         }
3169       if (dt == error_mark_node)
3170         return dt;
3171
3172       if (ffesymbol_hook (s).addr)
3173         item = dt;
3174       else
3175         item = ffecom_1_fn (dt);
3176
3177       ffecom_push_calltemps ();
3178       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3179         args = ffecom_list_expr (ffebld_right (expr));
3180       else
3181         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3182       ffecom_pop_calltemps ();
3183
3184       item = ffecom_call_ (item, kt,
3185                            ffesymbol_is_f2c (s)
3186                            && (bt == FFEINFO_basictypeCOMPLEX)
3187                            && (ffesymbol_where (s)
3188                                != FFEINFO_whereCONSTANT),
3189                            tree_type,
3190                            args,
3191                            dest_tree, dest, dest_used,
3192                            error_mark_node, FALSE);
3193       TREE_SIDE_EFFECTS (item) = 1;
3194       return item;
3195
3196     case FFEBLD_opAND:
3197       switch (bt)
3198         {
3199         case FFEINFO_basictypeLOGICAL:
3200           item
3201             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3202                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3203                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3204           return convert (tree_type, item);
3205
3206         case FFEINFO_basictypeINTEGER:
3207           return ffecom_2 (BIT_AND_EXPR, tree_type,
3208                            ffecom_expr (ffebld_left (expr)),
3209                            ffecom_expr (ffebld_right (expr)));
3210
3211         default:
3212           assert ("AND bad basictype" == NULL);
3213           /* Fall through. */
3214         case FFEINFO_basictypeANY:
3215           return error_mark_node;
3216         }
3217       break;
3218
3219     case FFEBLD_opOR:
3220       switch (bt)
3221         {
3222         case FFEINFO_basictypeLOGICAL:
3223           item
3224             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3225                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3226                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3227           return convert (tree_type, item);
3228
3229         case FFEINFO_basictypeINTEGER:
3230           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3231                            ffecom_expr (ffebld_left (expr)),
3232                            ffecom_expr (ffebld_right (expr)));
3233
3234         default:
3235           assert ("OR bad basictype" == NULL);
3236           /* Fall through. */
3237         case FFEINFO_basictypeANY:
3238           return error_mark_node;
3239         }
3240       break;
3241
3242     case FFEBLD_opXOR:
3243     case FFEBLD_opNEQV:
3244       switch (bt)
3245         {
3246         case FFEINFO_basictypeLOGICAL:
3247           item
3248             = ffecom_2 (NE_EXPR, integer_type_node,
3249                         ffecom_expr (ffebld_left (expr)),
3250                         ffecom_expr (ffebld_right (expr)));
3251           return convert (tree_type, ffecom_truth_value (item));
3252
3253         case FFEINFO_basictypeINTEGER:
3254           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3255                            ffecom_expr (ffebld_left (expr)),
3256                            ffecom_expr (ffebld_right (expr)));
3257
3258         default:
3259           assert ("XOR/NEQV bad basictype" == NULL);
3260           /* Fall through. */
3261         case FFEINFO_basictypeANY:
3262           return error_mark_node;
3263         }
3264       break;
3265
3266     case FFEBLD_opEQV:
3267       switch (bt)
3268         {
3269         case FFEINFO_basictypeLOGICAL:
3270           item
3271             = ffecom_2 (EQ_EXPR, integer_type_node,
3272                         ffecom_expr (ffebld_left (expr)),
3273                         ffecom_expr (ffebld_right (expr)));
3274           return convert (tree_type, ffecom_truth_value (item));
3275
3276         case FFEINFO_basictypeINTEGER:
3277           return
3278             ffecom_1 (BIT_NOT_EXPR, tree_type,
3279                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3280                                 ffecom_expr (ffebld_left (expr)),
3281                                 ffecom_expr (ffebld_right (expr))));
3282
3283         default:
3284           assert ("EQV bad basictype" == NULL);
3285           /* Fall through. */
3286         case FFEINFO_basictypeANY:
3287           return error_mark_node;
3288         }
3289       break;
3290
3291     case FFEBLD_opCONVERT:
3292       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3293         return error_mark_node;
3294
3295       switch (bt)
3296         {
3297         case FFEINFO_basictypeLOGICAL:
3298         case FFEINFO_basictypeINTEGER:
3299         case FFEINFO_basictypeREAL:
3300           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3301
3302         case FFEINFO_basictypeCOMPLEX:
3303           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3304             {
3305             case FFEINFO_basictypeINTEGER:
3306             case FFEINFO_basictypeLOGICAL:
3307             case FFEINFO_basictypeREAL:
3308               item = ffecom_expr (ffebld_left (expr));
3309               if (item == error_mark_node)
3310                 return error_mark_node;
3311               /* convert() takes care of converting to the subtype first,
3312                  at least in gcc-2.7.2. */
3313               item = convert (tree_type, item);
3314               return item;
3315
3316             case FFEINFO_basictypeCOMPLEX:
3317               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3318
3319             default:
3320               assert ("CONVERT COMPLEX bad basictype" == NULL);
3321               /* Fall through. */
3322             case FFEINFO_basictypeANY:
3323               return error_mark_node;
3324             }
3325           break;
3326
3327         default:
3328           assert ("CONVERT bad basictype" == NULL);
3329           /* Fall through. */
3330         case FFEINFO_basictypeANY:
3331           return error_mark_node;
3332         }
3333       break;
3334
3335     case FFEBLD_opLT:
3336       code = LT_EXPR;
3337       goto relational;          /* :::::::::::::::::::: */
3338
3339     case FFEBLD_opLE:
3340       code = LE_EXPR;
3341       goto relational;          /* :::::::::::::::::::: */
3342
3343     case FFEBLD_opEQ:
3344       code = EQ_EXPR;
3345       goto relational;          /* :::::::::::::::::::: */
3346
3347     case FFEBLD_opNE:
3348       code = NE_EXPR;
3349       goto relational;          /* :::::::::::::::::::: */
3350
3351     case FFEBLD_opGT:
3352       code = GT_EXPR;
3353       goto relational;          /* :::::::::::::::::::: */
3354
3355     case FFEBLD_opGE:
3356       code = GE_EXPR;
3357
3358     relational:         /* :::::::::::::::::::: */
3359       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3360         {
3361         case FFEINFO_basictypeLOGICAL:
3362         case FFEINFO_basictypeINTEGER:
3363         case FFEINFO_basictypeREAL:
3364           item = ffecom_2 (code, integer_type_node,
3365                            ffecom_expr (ffebld_left (expr)),
3366                            ffecom_expr (ffebld_right (expr)));
3367           return convert (tree_type, item);
3368
3369         case FFEINFO_basictypeCOMPLEX:
3370           assert (code == EQ_EXPR || code == NE_EXPR);
3371           {
3372             tree real_type;
3373             tree arg1 = ffecom_expr (ffebld_left (expr));
3374             tree arg2 = ffecom_expr (ffebld_right (expr));
3375
3376             if (arg1 == error_mark_node || arg2 == error_mark_node)
3377               return error_mark_node;
3378
3379             arg1 = ffecom_save_tree (arg1);
3380             arg2 = ffecom_save_tree (arg2);
3381
3382             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3383               {
3384                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3385                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3386               }
3387             else
3388               {
3389                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3390                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3391               }
3392
3393             item
3394               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3395                           ffecom_2 (EQ_EXPR, integer_type_node,
3396                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3397                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3398                           ffecom_2 (EQ_EXPR, integer_type_node,
3399                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3400                                     ffecom_1 (IMAGPART_EXPR, real_type,
3401                                               arg2)));
3402             if (code == EQ_EXPR)
3403               item = ffecom_truth_value (item);
3404             else
3405               item = ffecom_truth_value_invert (item);
3406             return convert (tree_type, item);
3407           }
3408
3409         case FFEINFO_basictypeCHARACTER:
3410           ffecom_push_calltemps ();     /* Even though we might not call. */
3411
3412           {
3413             ffebld left = ffebld_left (expr);
3414             ffebld right = ffebld_right (expr);
3415             tree left_tree;
3416             tree right_tree;
3417             tree left_length;
3418             tree right_length;
3419
3420             /* f2c run-time functions do the implicit blank-padding for us,
3421                so we don't usually have to implement blank-padding ourselves.
3422                (The exception is when we pass an argument to a separately
3423                compiled statement function -- if we know the arg is not the
3424                same length as the dummy, we must truncate or extend it.  If
3425                we "inline" statement functions, that necessity goes away as
3426                well.)
3427
3428                Strip off the CONVERT operators that blank-pad.  (Truncation by
3429                CONVERT shouldn't happen here, but it can happen in
3430                assignments.) */
3431
3432             while (ffebld_op (left) == FFEBLD_opCONVERT)
3433               left = ffebld_left (left);
3434             while (ffebld_op (right) == FFEBLD_opCONVERT)
3435               right = ffebld_left (right);
3436
3437             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3438             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3439
3440             if (left_tree == error_mark_node || left_length == error_mark_node
3441                 || right_tree == error_mark_node
3442                 || right_length == error_mark_node)
3443               {
3444                 ffecom_pop_calltemps ();
3445                 return error_mark_node;
3446               }
3447
3448             if ((ffebld_size_known (left) == 1)
3449                 && (ffebld_size_known (right) == 1))
3450               {
3451                 left_tree
3452                   = ffecom_1 (INDIRECT_REF,
3453                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3454                               left_tree);
3455                 right_tree
3456                   = ffecom_1 (INDIRECT_REF,
3457                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3458                               right_tree);
3459
3460                 item
3461                   = ffecom_2 (code, integer_type_node,
3462                               ffecom_2 (ARRAY_REF,
3463                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3464                                         left_tree,
3465                                         integer_one_node),
3466                               ffecom_2 (ARRAY_REF,
3467                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3468                                         right_tree,
3469                                         integer_one_node));
3470               }
3471             else
3472               {
3473                 item = build_tree_list (NULL_TREE, left_tree);
3474                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3475                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3476                                                                left_length);
3477                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3478                   = build_tree_list (NULL_TREE, right_length);
3479                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item);
3480                 item = ffecom_2 (code, integer_type_node,
3481                                  item,
3482                                  convert (TREE_TYPE (item),
3483                                           integer_zero_node));
3484               }
3485             item = convert (tree_type, item);
3486           }
3487
3488           ffecom_pop_calltemps ();
3489           return item;
3490
3491         default:
3492           assert ("relational bad basictype" == NULL);
3493           /* Fall through. */
3494         case FFEINFO_basictypeANY:
3495           return error_mark_node;
3496         }
3497       break;
3498
3499     case FFEBLD_opPERCENT_LOC:
3500       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3501       return convert (tree_type, item);
3502
3503     case FFEBLD_opITEM:
3504     case FFEBLD_opSTAR:
3505     case FFEBLD_opBOUNDS:
3506     case FFEBLD_opREPEAT:
3507     case FFEBLD_opLABTER:
3508     case FFEBLD_opLABTOK:
3509     case FFEBLD_opIMPDO:
3510     case FFEBLD_opCONCATENATE:
3511     case FFEBLD_opSUBSTR:
3512     default:
3513       assert ("bad op" == NULL);
3514       /* Fall through. */
3515     case FFEBLD_opANY:
3516       return error_mark_node;
3517     }
3518
3519 #if 1
3520   assert ("didn't think anything got here anymore!!" == NULL);
3521 #else
3522   switch (ffebld_arity (expr))
3523     {
3524     case 2:
3525       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3526       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3527       if (TREE_OPERAND (item, 0) == error_mark_node
3528           || TREE_OPERAND (item, 1) == error_mark_node)
3529         return error_mark_node;
3530       break;
3531
3532     case 1:
3533       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3534       if (TREE_OPERAND (item, 0) == error_mark_node)
3535         return error_mark_node;
3536       break;
3537
3538     default:
3539       break;
3540     }
3541
3542   return fold (item);
3543 #endif
3544 }
3545
3546 #endif
3547 /* Returns the tree that does the intrinsic invocation.
3548
3549    Note: this function applies only to intrinsics returning
3550    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3551    subroutines.  */
3552
3553 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3554 static tree
3555 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3556                         ffebld dest, bool *dest_used)
3557 {
3558   tree expr_tree;
3559   tree saved_expr1;             /* For those who need it. */
3560   tree saved_expr2;             /* For those who need it. */
3561   ffeinfoBasictype bt;
3562   ffeinfoKindtype kt;
3563   tree tree_type;
3564   tree arg1_type;
3565   tree real_type;               /* REAL type corresponding to COMPLEX. */
3566   tree tempvar;
3567   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3568   ffebld arg1;                  /* For handy reference. */
3569   ffebld arg2;
3570   ffebld arg3;
3571   ffeintrinImp codegen_imp;
3572   ffecomGfrt gfrt;
3573
3574   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3575
3576   if (dest_used != NULL)
3577     *dest_used = FALSE;
3578
3579   bt = ffeinfo_basictype (ffebld_info (expr));
3580   kt = ffeinfo_kindtype (ffebld_info (expr));
3581   tree_type = ffecom_tree_type[bt][kt];
3582
3583   if (list != NULL)
3584     {
3585       arg1 = ffebld_head (list);
3586       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3587         return error_mark_node;
3588       if ((list = ffebld_trail (list)) != NULL)
3589         {
3590           arg2 = ffebld_head (list);
3591           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3592             return error_mark_node;
3593           if ((list = ffebld_trail (list)) != NULL)
3594             {
3595               arg3 = ffebld_head (list);
3596               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3597                 return error_mark_node;
3598             }
3599           else
3600             arg3 = NULL;
3601         }
3602       else
3603         arg2 = arg3 = NULL;
3604     }
3605   else
3606     arg1 = arg2 = arg3 = NULL;
3607
3608   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3609      args.  This is used by the MAX/MIN expansions. */
3610
3611   if (arg1 != NULL)
3612     arg1_type = ffecom_tree_type
3613       [ffeinfo_basictype (ffebld_info (arg1))]
3614       [ffeinfo_kindtype (ffebld_info (arg1))];
3615   else
3616     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3617                                    here. */
3618
3619   /* There are several ways for each of the cases in the following switch
3620      statements to exit (from simplest to use to most complicated):
3621
3622      break;  (when expr_tree == NULL)
3623
3624      A standard call is made to the specific intrinsic just as if it had been
3625      passed in as a dummy procedure and called as any old procedure.  This
3626      method can produce slower code but in some cases it's the easiest way for
3627      now.  However, if a (presumably faster) direct call is available,
3628      that is used, so this is the easiest way in many more cases now.
3629
3630      gfrt = FFECOM_gfrtWHATEVER;
3631      break;
3632
3633      gfrt contains the gfrt index of a library function to call, passing the
3634      argument(s) by value rather than by reference.  Used when a more
3635      careful choice of library function is needed than that provided
3636      by the vanilla `break;'.
3637
3638      return expr_tree;
3639
3640      The expr_tree has been completely set up and is ready to be returned
3641      as is.  No further actions are taken.  Use this when the tree is not
3642      in the simple form for one of the arity_n labels.   */
3643
3644   /* For info on how the switch statement cases were written, see the files
3645      enclosed in comments below the switch statement. */
3646
3647   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3648   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3649   if (gfrt == FFECOM_gfrt)
3650     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3651
3652   switch (codegen_imp)
3653     {
3654     case FFEINTRIN_impABS:
3655     case FFEINTRIN_impCABS:
3656     case FFEINTRIN_impCDABS:
3657     case FFEINTRIN_impDABS:
3658     case FFEINTRIN_impIABS:
3659       if (ffeinfo_basictype (ffebld_info (arg1))
3660           == FFEINFO_basictypeCOMPLEX)
3661         {
3662           if (kt == FFEINFO_kindtypeREAL1)
3663             gfrt = FFECOM_gfrtCABS;
3664           else if (kt == FFEINFO_kindtypeREAL2)
3665             gfrt = FFECOM_gfrtCDABS;
3666           break;
3667         }
3668       return ffecom_1 (ABS_EXPR, tree_type,
3669                        convert (tree_type, ffecom_expr (arg1)));
3670
3671     case FFEINTRIN_impACOS:
3672     case FFEINTRIN_impDACOS:
3673       break;
3674
3675     case FFEINTRIN_impAIMAG:
3676     case FFEINTRIN_impDIMAG:
3677     case FFEINTRIN_impIMAGPART:
3678       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3679         arg1_type = TREE_TYPE (arg1_type);
3680       else
3681         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3682
3683       return
3684         convert (tree_type,
3685                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3686                            ffecom_expr (arg1)));
3687
3688     case FFEINTRIN_impAINT:
3689     case FFEINTRIN_impDINT:
3690 #if 0                           /* ~~ someday implement FIX_TRUNC_EXPR
3691                                    yielding same type as arg */
3692       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3693 #else /* in the meantime, must use floor to avoid range problems with ints */
3694       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3695       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3696       return
3697         convert (tree_type,
3698                  ffecom_3 (COND_EXPR, double_type_node,
3699                            ffecom_truth_value
3700                            (ffecom_2 (GE_EXPR, integer_type_node,
3701                                       saved_expr1,
3702                                       convert (arg1_type,
3703                                                ffecom_float_zero_))),
3704                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3705                                              build_tree_list (NULL_TREE,
3706                                                   convert (double_type_node,
3707                                                            saved_expr1))),
3708                            ffecom_1 (NEGATE_EXPR, double_type_node,
3709                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3710                                                  build_tree_list (NULL_TREE,
3711                                                   convert (double_type_node,
3712                                                       ffecom_1 (NEGATE_EXPR,
3713                                                                 arg1_type,
3714                                                                 saved_expr1))))
3715                                      ))
3716                  );
3717 #endif
3718
3719     case FFEINTRIN_impANINT:
3720     case FFEINTRIN_impDNINT:
3721 #if 0                           /* This way of doing it won't handle real
3722                                    numbers of large magnitudes. */
3723       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3724       expr_tree = convert (tree_type,
3725                            convert (integer_type_node,
3726                                     ffecom_3 (COND_EXPR, tree_type,
3727                                               ffecom_truth_value
3728                                               (ffecom_2 (GE_EXPR,
3729                                                          integer_type_node,
3730                                                          saved_expr1,
3731                                                        ffecom_float_zero_)),
3732                                               ffecom_2 (PLUS_EXPR,
3733                                                         tree_type,
3734                                                         saved_expr1,
3735                                                         ffecom_float_half_),
3736                                               ffecom_2 (MINUS_EXPR,
3737                                                         tree_type,
3738                                                         saved_expr1,
3739                                                      ffecom_float_half_))));
3740       return expr_tree;
3741 #else /* So we instead call floor. */
3742       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3743       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3744       return
3745         convert (tree_type,
3746                  ffecom_3 (COND_EXPR, double_type_node,
3747                            ffecom_truth_value
3748                            (ffecom_2 (GE_EXPR, integer_type_node,
3749                                       saved_expr1,
3750                                       convert (arg1_type,
3751                                                ffecom_float_zero_))),
3752                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3753                                              build_tree_list (NULL_TREE,
3754                                                   convert (double_type_node,
3755                                                            ffecom_2 (PLUS_EXPR,
3756                                                                      arg1_type,
3757                                                                      saved_expr1,
3758                                                                      convert (arg1_type,
3759                                                                               ffecom_float_half_))))),
3760                            ffecom_1 (NEGATE_EXPR, double_type_node,
3761                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3762                                                        build_tree_list (NULL_TREE,
3763                                                                         convert (double_type_node,
3764                                                                                  ffecom_2 (MINUS_EXPR,
3765                                                                                            arg1_type,
3766                                                                                            convert (arg1_type,
3767                                                                                                     ffecom_float_half_),
3768                                                                                            saved_expr1)))))
3769                            )
3770                  );
3771 #endif
3772
3773     case FFEINTRIN_impASIN:
3774     case FFEINTRIN_impDASIN:
3775     case FFEINTRIN_impATAN:
3776     case FFEINTRIN_impDATAN:
3777     case FFEINTRIN_impATAN2:
3778     case FFEINTRIN_impDATAN2:
3779       break;
3780
3781     case FFEINTRIN_impCHAR:
3782     case FFEINTRIN_impACHAR:
3783       assert (ffecom_pending_calls_ != 0);
3784       tempvar = ffecom_push_tempvar (char_type_node,
3785                                      1, -1, TRUE);
3786       {
3787         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
3788
3789         expr_tree = ffecom_modify (tmv,
3790                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
3791                                              integer_one_node),
3792                                    convert (tmv, ffecom_expr (arg1)));
3793       }
3794       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
3795                             expr_tree,
3796                             tempvar);
3797       expr_tree = ffecom_1 (ADDR_EXPR,
3798                             build_pointer_type (TREE_TYPE (expr_tree)),
3799                             expr_tree);
3800       return expr_tree;
3801
3802     case FFEINTRIN_impCMPLX:
3803     case FFEINTRIN_impDCMPLX:
3804       if (arg2 == NULL)
3805         return
3806           convert (tree_type, ffecom_expr (arg1));
3807
3808       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
3809       return
3810         ffecom_2 (COMPLEX_EXPR, tree_type,
3811                   convert (real_type, ffecom_expr (arg1)),
3812                   convert (real_type,
3813                            ffecom_expr (arg2)));
3814
3815     case FFEINTRIN_impCOMPLEX:
3816       return
3817         ffecom_2 (COMPLEX_EXPR, tree_type,
3818                   ffecom_expr (arg1),
3819                   ffecom_expr (arg2));
3820
3821     case FFEINTRIN_impCONJG:
3822     case FFEINTRIN_impDCONJG:
3823       {
3824         tree arg1_tree;
3825
3826         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
3827         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
3828         return
3829           ffecom_2 (COMPLEX_EXPR, tree_type,
3830                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
3831                     ffecom_1 (NEGATE_EXPR, real_type,
3832                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
3833       }
3834
3835     case FFEINTRIN_impCOS:
3836     case FFEINTRIN_impCCOS:
3837     case FFEINTRIN_impCDCOS:
3838     case FFEINTRIN_impDCOS:
3839       if (bt == FFEINFO_basictypeCOMPLEX)
3840         {
3841           if (kt == FFEINFO_kindtypeREAL1)
3842             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
3843           else if (kt == FFEINFO_kindtypeREAL2)
3844             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
3845         }
3846       break;
3847
3848     case FFEINTRIN_impCOSH:
3849     case FFEINTRIN_impDCOSH:
3850       break;
3851
3852     case FFEINTRIN_impDBLE:
3853     case FFEINTRIN_impDFLOAT:
3854     case FFEINTRIN_impDREAL:
3855     case FFEINTRIN_impFLOAT:
3856     case FFEINTRIN_impIDINT:
3857     case FFEINTRIN_impIFIX:
3858     case FFEINTRIN_impINT2:
3859     case FFEINTRIN_impINT8:
3860     case FFEINTRIN_impINT:
3861     case FFEINTRIN_impLONG:
3862     case FFEINTRIN_impREAL:
3863     case FFEINTRIN_impSHORT:
3864     case FFEINTRIN_impSNGL:
3865       return convert (tree_type, ffecom_expr (arg1));
3866
3867     case FFEINTRIN_impDIM:
3868     case FFEINTRIN_impDDIM:
3869     case FFEINTRIN_impIDIM:
3870       saved_expr1 = ffecom_save_tree (convert (tree_type,
3871                                                ffecom_expr (arg1)));
3872       saved_expr2 = ffecom_save_tree (convert (tree_type,
3873                                                ffecom_expr (arg2)));
3874       return
3875         ffecom_3 (COND_EXPR, tree_type,
3876                   ffecom_truth_value
3877                   (ffecom_2 (GT_EXPR, integer_type_node,
3878                              saved_expr1,
3879                              saved_expr2)),
3880                   ffecom_2 (MINUS_EXPR, tree_type,
3881                             saved_expr1,
3882                             saved_expr2),
3883                   convert (tree_type, ffecom_float_zero_));
3884
3885     case FFEINTRIN_impDPROD:
3886       return
3887         ffecom_2 (MULT_EXPR, tree_type,
3888                   convert (tree_type, ffecom_expr (arg1)),
3889                   convert (tree_type, ffecom_expr (arg2)));
3890
3891     case FFEINTRIN_impEXP:
3892     case FFEINTRIN_impCDEXP:
3893     case FFEINTRIN_impCEXP:
3894     case FFEINTRIN_impDEXP:
3895       if (bt == FFEINFO_basictypeCOMPLEX)
3896         {
3897           if (kt == FFEINFO_kindtypeREAL1)
3898             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
3899           else if (kt == FFEINFO_kindtypeREAL2)
3900             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
3901         }
3902       break;
3903
3904     case FFEINTRIN_impICHAR:
3905     case FFEINTRIN_impIACHAR:
3906 #if 0                           /* The simple approach. */
3907       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
3908       expr_tree
3909         = ffecom_1 (INDIRECT_REF,
3910                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
3911                     expr_tree);
3912       expr_tree
3913         = ffecom_2 (ARRAY_REF,
3914                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
3915                     expr_tree,
3916                     integer_one_node);
3917       return convert (tree_type, expr_tree);
3918 #else /* The more interesting (and more optimal) approach. */
3919       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
3920       expr_tree = ffecom_3 (COND_EXPR, tree_type,
3921                             saved_expr1,
3922                             expr_tree,
3923                             convert (tree_type, integer_zero_node));
3924       return expr_tree;
3925 #endif
3926
3927     case FFEINTRIN_impINDEX:
3928       break;
3929
3930     case FFEINTRIN_impLEN:
3931 #if 0
3932       break;                                    /* The simple approach. */
3933 #else
3934       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
3935 #endif
3936
3937     case FFEINTRIN_impLGE:
3938     case FFEINTRIN_impLGT:
3939     case FFEINTRIN_impLLE:
3940     case FFEINTRIN_impLLT:
3941       break;
3942
3943     case FFEINTRIN_impLOG:
3944     case FFEINTRIN_impALOG:
3945     case FFEINTRIN_impCDLOG:
3946     case FFEINTRIN_impCLOG:
3947     case FFEINTRIN_impDLOG:
3948       if (bt == FFEINFO_basictypeCOMPLEX)
3949         {
3950           if (kt == FFEINFO_kindtypeREAL1)
3951             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
3952           else if (kt == FFEINFO_kindtypeREAL2)
3953             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
3954         }
3955       break;
3956
3957     case FFEINTRIN_impLOG10:
3958     case FFEINTRIN_impALOG10:
3959     case FFEINTRIN_impDLOG10:
3960       if (gfrt != FFECOM_gfrt)
3961         break;  /* Already picked one, stick with it. */
3962
3963       if (kt == FFEINFO_kindtypeREAL1)
3964         gfrt = FFECOM_gfrtALOG10;
3965       else if (kt == FFEINFO_kindtypeREAL2)
3966         gfrt = FFECOM_gfrtDLOG10;
3967       break;
3968
3969     case FFEINTRIN_impMAX:
3970     case FFEINTRIN_impAMAX0:
3971     case FFEINTRIN_impAMAX1:
3972     case FFEINTRIN_impDMAX1:
3973     case FFEINTRIN_impMAX0:
3974     case FFEINTRIN_impMAX1:
3975       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
3976         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
3977       else
3978         arg1_type = tree_type;
3979       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
3980                             convert (arg1_type, ffecom_expr (arg1)),
3981                             convert (arg1_type, ffecom_expr (arg2)));
3982       for (; list != NULL; list = ffebld_trail (list))
3983         {
3984           if ((ffebld_head (list) == NULL)
3985               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
3986             continue;
3987           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
3988                                 expr_tree,
3989                                 convert (arg1_type,
3990                                          ffecom_expr (ffebld_head (list))));
3991         }
3992       return convert (tree_type, expr_tree);
3993
3994     case FFEINTRIN_impMIN:
3995     case FFEINTRIN_impAMIN0:
3996     case FFEINTRIN_impAMIN1:
3997     case FFEINTRIN_impDMIN1:
3998     case FFEINTRIN_impMIN0:
3999     case FFEINTRIN_impMIN1:
4000       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4001         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4002       else
4003         arg1_type = tree_type;
4004       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4005                             convert (arg1_type, ffecom_expr (arg1)),
4006                             convert (arg1_type, ffecom_expr (arg2)));
4007       for (; list != NULL; list = ffebld_trail (list))
4008         {
4009           if ((ffebld_head (list) == NULL)
4010               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4011             continue;
4012           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4013                                 expr_tree,
4014                                 convert (arg1_type,
4015                                          ffecom_expr (ffebld_head (list))));
4016         }
4017       return convert (tree_type, expr_tree);
4018
4019     case FFEINTRIN_impMOD:
4020     case FFEINTRIN_impAMOD:
4021     case FFEINTRIN_impDMOD:
4022       if (bt != FFEINFO_basictypeREAL)
4023         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4024                          convert (tree_type, ffecom_expr (arg1)),
4025                          convert (tree_type, ffecom_expr (arg2)));
4026
4027       if (kt == FFEINFO_kindtypeREAL1)
4028         gfrt = FFECOM_gfrtAMOD;
4029       else if (kt == FFEINFO_kindtypeREAL2)
4030         gfrt = FFECOM_gfrtDMOD;
4031       break;
4032
4033     case FFEINTRIN_impNINT:
4034     case FFEINTRIN_impIDNINT:
4035 #if 0                           /* ~~ ideally FIX_ROUND_EXPR would be
4036                                    implemented, but it ain't yet */
4037       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4038 #else
4039       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4040       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4041       return
4042         convert (ffecom_integer_type_node,
4043                  ffecom_3 (COND_EXPR, arg1_type,
4044                            ffecom_truth_value
4045                            (ffecom_2 (GE_EXPR, integer_type_node,
4046                                       saved_expr1,
4047                                       convert (arg1_type,
4048                                                ffecom_float_zero_))),
4049                            ffecom_2 (PLUS_EXPR, arg1_type,
4050                                      saved_expr1,
4051                                      convert (arg1_type,
4052                                               ffecom_float_half_)),
4053                            ffecom_2 (MINUS_EXPR, arg1_type,
4054                                      saved_expr1,
4055                                      convert (arg1_type,
4056                                               ffecom_float_half_))));
4057 #endif
4058
4059     case FFEINTRIN_impSIGN:
4060     case FFEINTRIN_impDSIGN:
4061     case FFEINTRIN_impISIGN:
4062       {
4063         tree arg2_tree = ffecom_expr (arg2);
4064
4065         saved_expr1
4066           = ffecom_save_tree
4067           (ffecom_1 (ABS_EXPR, tree_type,
4068                      convert (tree_type,
4069                               ffecom_expr (arg1))));
4070         expr_tree
4071           = ffecom_3 (COND_EXPR, tree_type,
4072                       ffecom_truth_value
4073                       (ffecom_2 (GE_EXPR, integer_type_node,
4074                                  arg2_tree,
4075                                  convert (TREE_TYPE (arg2_tree),
4076                                           integer_zero_node))),
4077                       saved_expr1,
4078                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4079         /* Make sure SAVE_EXPRs get referenced early enough. */
4080         expr_tree
4081           = ffecom_2 (COMPOUND_EXPR, tree_type,
4082                       convert (void_type_node, saved_expr1),
4083                       expr_tree);
4084       }
4085       return expr_tree;
4086
4087     case FFEINTRIN_impSIN:
4088     case FFEINTRIN_impCDSIN:
4089     case FFEINTRIN_impCSIN:
4090     case FFEINTRIN_impDSIN:
4091       if (bt == FFEINFO_basictypeCOMPLEX)
4092         {
4093           if (kt == FFEINFO_kindtypeREAL1)
4094             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4095           else if (kt == FFEINFO_kindtypeREAL2)
4096             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4097         }
4098       break;
4099
4100     case FFEINTRIN_impSINH:
4101     case FFEINTRIN_impDSINH:
4102       break;
4103
4104     case FFEINTRIN_impSQRT:
4105     case FFEINTRIN_impCDSQRT:
4106     case FFEINTRIN_impCSQRT:
4107     case FFEINTRIN_impDSQRT:
4108       if (bt == FFEINFO_basictypeCOMPLEX)
4109         {
4110           if (kt == FFEINFO_kindtypeREAL1)
4111             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4112           else if (kt == FFEINFO_kindtypeREAL2)
4113             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4114         }
4115       break;
4116
4117     case FFEINTRIN_impTAN:
4118     case FFEINTRIN_impDTAN:
4119     case FFEINTRIN_impTANH:
4120     case FFEINTRIN_impDTANH:
4121       break;
4122
4123     case FFEINTRIN_impREALPART:
4124       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4125         arg1_type = TREE_TYPE (arg1_type);
4126       else
4127         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4128
4129       return
4130         convert (tree_type,
4131                  ffecom_1 (REALPART_EXPR, arg1_type,
4132                            ffecom_expr (arg1)));
4133
4134     case FFEINTRIN_impIAND:
4135     case FFEINTRIN_impAND:
4136       return ffecom_2 (BIT_AND_EXPR, tree_type,
4137                        convert (tree_type,
4138                                 ffecom_expr (arg1)),
4139                        convert (tree_type,
4140                                 ffecom_expr (arg2)));
4141
4142     case FFEINTRIN_impIOR:
4143     case FFEINTRIN_impOR:
4144       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4145                        convert (tree_type,
4146                                 ffecom_expr (arg1)),
4147                        convert (tree_type,
4148                                 ffecom_expr (arg2)));
4149
4150     case FFEINTRIN_impIEOR:
4151     case FFEINTRIN_impXOR:
4152       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4153                        convert (tree_type,
4154                                 ffecom_expr (arg1)),
4155                        convert (tree_type,
4156                                 ffecom_expr (arg2)));
4157
4158     case FFEINTRIN_impLSHIFT:
4159       return ffecom_2 (LSHIFT_EXPR, tree_type,
4160                        ffecom_expr (arg1),
4161                        convert (integer_type_node,
4162                                 ffecom_expr (arg2)));
4163
4164     case FFEINTRIN_impRSHIFT:
4165       return ffecom_2 (RSHIFT_EXPR, tree_type,
4166                        ffecom_expr (arg1),
4167                        convert (integer_type_node,
4168                                 ffecom_expr (arg2)));
4169
4170     case FFEINTRIN_impNOT:
4171       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4172
4173     case FFEINTRIN_impBIT_SIZE:
4174       return convert (tree_type, TYPE_SIZE (arg1_type));
4175
4176     case FFEINTRIN_impBTEST:
4177       {
4178         ffetargetLogical1 true;
4179         ffetargetLogical1 false;
4180         tree true_tree;
4181         tree false_tree;
4182
4183         ffetarget_logical1 (&true, TRUE);
4184         ffetarget_logical1 (&false, FALSE);
4185         if (true == 1)
4186           true_tree = convert (tree_type, integer_one_node);
4187         else
4188           true_tree = convert (tree_type, build_int_2 (true, 0));
4189         if (false == 0)
4190           false_tree = convert (tree_type, integer_zero_node);
4191         else
4192           false_tree = convert (tree_type, build_int_2 (false, 0));
4193
4194         return
4195           ffecom_3 (COND_EXPR, tree_type,
4196                     ffecom_truth_value
4197                     (ffecom_2 (EQ_EXPR, integer_type_node,
4198                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4199                                          ffecom_expr (arg1),
4200                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4201                                                    convert (arg1_type,
4202                                                           integer_one_node),
4203                                                    convert (integer_type_node,
4204                                                             ffecom_expr (arg2)))),
4205                                convert (arg1_type,
4206                                         integer_zero_node))),
4207                     false_tree,
4208                     true_tree);
4209       }
4210
4211     case FFEINTRIN_impIBCLR:
4212       return
4213         ffecom_2 (BIT_AND_EXPR, tree_type,
4214                   ffecom_expr (arg1),
4215                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4216                             ffecom_2 (LSHIFT_EXPR, tree_type,
4217                                       convert (tree_type,
4218                                                integer_one_node),
4219                                       convert (integer_type_node,
4220                                                ffecom_expr (arg2)))));
4221
4222     case FFEINTRIN_impIBITS:
4223       {
4224         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4225                                                     ffecom_expr (arg3)));
4226         tree uns_type
4227         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4228
4229         expr_tree
4230           = ffecom_2 (BIT_AND_EXPR, tree_type,
4231                       ffecom_2 (RSHIFT_EXPR, tree_type,
4232                                 ffecom_expr (arg1),
4233                                 convert (integer_type_node,
4234                                          ffecom_expr (arg2))),
4235                       convert (tree_type,
4236                                ffecom_2 (RSHIFT_EXPR, uns_type,
4237                                          ffecom_1 (BIT_NOT_EXPR,
4238                                                    uns_type,
4239                                                    convert (uns_type,
4240                                                         integer_zero_node)),
4241                                          ffecom_2 (MINUS_EXPR,
4242                                                    integer_type_node,
4243                                                    TYPE_SIZE (uns_type),
4244                                                    arg3_tree))));
4245 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4246         expr_tree
4247           = ffecom_3 (COND_EXPR, tree_type,
4248                       ffecom_truth_value
4249                       (ffecom_2 (NE_EXPR, integer_type_node,
4250                                  arg3_tree,
4251                                  integer_zero_node)),
4252                       expr_tree,
4253                       convert (tree_type, integer_zero_node));
4254 #endif
4255       }
4256       return expr_tree;
4257
4258     case FFEINTRIN_impIBSET:
4259       return
4260         ffecom_2 (BIT_IOR_EXPR, tree_type,
4261                   ffecom_expr (arg1),
4262                   ffecom_2 (LSHIFT_EXPR, tree_type,
4263                             convert (tree_type, integer_one_node),
4264                             convert (integer_type_node,
4265                                      ffecom_expr (arg2))));
4266
4267     case FFEINTRIN_impISHFT:
4268       {
4269         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4270         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4271                                                     ffecom_expr (arg2)));
4272         tree uns_type
4273         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4274
4275         expr_tree
4276           = ffecom_3 (COND_EXPR, tree_type,
4277                       ffecom_truth_value
4278                       (ffecom_2 (GE_EXPR, integer_type_node,
4279                                  arg2_tree,
4280                                  integer_zero_node)),
4281                       ffecom_2 (LSHIFT_EXPR, tree_type,
4282                                 arg1_tree,
4283                                 arg2_tree),
4284                       convert (tree_type,
4285                                ffecom_2 (RSHIFT_EXPR, uns_type,
4286                                          convert (uns_type, arg1_tree),
4287                                          ffecom_1 (NEGATE_EXPR,
4288                                                    integer_type_node,
4289                                                    arg2_tree))));
4290 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4291         expr_tree
4292           = ffecom_3 (COND_EXPR, tree_type,
4293                       ffecom_truth_value
4294                       (ffecom_2 (NE_EXPR, integer_type_node,
4295                                  arg2_tree,
4296                                  TYPE_SIZE (uns_type))),
4297                       expr_tree,
4298                       convert (tree_type, integer_zero_node));
4299 #endif
4300         /* Make sure SAVE_EXPRs get referenced early enough. */
4301         expr_tree
4302           = ffecom_2 (COMPOUND_EXPR, tree_type,
4303                       convert (void_type_node, arg1_tree),
4304                       ffecom_2 (COMPOUND_EXPR, tree_type,
4305                                 convert (void_type_node, arg2_tree),
4306                                 expr_tree));
4307       }
4308       return expr_tree;
4309
4310     case FFEINTRIN_impISHFTC:
4311       {
4312         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4313         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4314                                                     ffecom_expr (arg2)));
4315         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4316         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4317         tree shift_neg;
4318         tree shift_pos;
4319         tree mask_arg1;
4320         tree masked_arg1;
4321         tree uns_type
4322         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4323
4324         mask_arg1
4325           = ffecom_2 (LSHIFT_EXPR, tree_type,
4326                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4327                                 convert (tree_type, integer_zero_node)),
4328                       arg3_tree);
4329 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4330         mask_arg1
4331           = ffecom_3 (COND_EXPR, tree_type,
4332                       ffecom_truth_value
4333                       (ffecom_2 (NE_EXPR, integer_type_node,
4334                                  arg3_tree,
4335                                  TYPE_SIZE (uns_type))),
4336                       mask_arg1,
4337                       convert (tree_type, integer_zero_node));
4338 #endif
4339         mask_arg1 = ffecom_save_tree (mask_arg1);
4340         masked_arg1
4341           = ffecom_2 (BIT_AND_EXPR, tree_type,
4342                       arg1_tree,
4343                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4344                                 mask_arg1));
4345         masked_arg1 = ffecom_save_tree (masked_arg1);
4346         shift_neg
4347           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4348                       convert (tree_type,
4349                                ffecom_2 (RSHIFT_EXPR, uns_type,
4350                                          convert (uns_type, masked_arg1),
4351                                          ffecom_1 (NEGATE_EXPR,
4352                                                    integer_type_node,
4353                                                    arg2_tree))),
4354                       ffecom_2 (LSHIFT_EXPR, tree_type,
4355                                 arg1_tree,
4356                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4357                                           arg2_tree,
4358                                           arg3_tree)));
4359         shift_pos
4360           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4361                       ffecom_2 (LSHIFT_EXPR, tree_type,
4362                                 arg1_tree,
4363                                 arg2_tree),
4364                       convert (tree_type,
4365                                ffecom_2 (RSHIFT_EXPR, uns_type,
4366                                          convert (uns_type, masked_arg1),
4367                                          ffecom_2 (MINUS_EXPR,
4368                                                    integer_type_node,
4369                                                    arg3_tree,
4370                                                    arg2_tree))));
4371         expr_tree
4372           = ffecom_3 (COND_EXPR, tree_type,
4373                       ffecom_truth_value
4374                       (ffecom_2 (LT_EXPR, integer_type_node,
4375                                  arg2_tree,
4376                                  integer_zero_node)),
4377                       shift_neg,
4378                       shift_pos);
4379         expr_tree
4380           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4381                       ffecom_2 (BIT_AND_EXPR, tree_type,
4382                                 mask_arg1,
4383                                 arg1_tree),
4384                       ffecom_2 (BIT_AND_EXPR, tree_type,
4385                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4386                                           mask_arg1),
4387                                 expr_tree));
4388         expr_tree
4389           = ffecom_3 (COND_EXPR, tree_type,
4390                       ffecom_truth_value
4391                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4392                                  ffecom_2 (EQ_EXPR, integer_type_node,
4393                                            ffecom_1 (ABS_EXPR,
4394                                                      integer_type_node,
4395                                                      arg2_tree),
4396                                            arg3_tree),
4397                                  ffecom_2 (EQ_EXPR, integer_type_node,
4398                                            arg2_tree,
4399                                            integer_zero_node))),
4400                       arg1_tree,
4401                       expr_tree);
4402         /* Make sure SAVE_EXPRs get referenced early enough. */
4403         expr_tree
4404           = ffecom_2 (COMPOUND_EXPR, tree_type,
4405                       convert (void_type_node, arg1_tree),
4406                       ffecom_2 (COMPOUND_EXPR, tree_type,
4407                                 convert (void_type_node, arg2_tree),
4408                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4409                                           convert (void_type_node,
4410                                                    mask_arg1),
4411                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4412                                                     convert (void_type_node,
4413                                                              masked_arg1),
4414                                                     expr_tree))));
4415         expr_tree
4416           = ffecom_2 (COMPOUND_EXPR, tree_type,
4417                       convert (void_type_node,
4418                                arg3_tree),
4419                       expr_tree);
4420       }
4421       return expr_tree;
4422
4423     case FFEINTRIN_impLOC:
4424       {
4425         tree arg1_tree = ffecom_expr (arg1);
4426
4427         expr_tree
4428           = convert (tree_type,
4429                      ffecom_1 (ADDR_EXPR,
4430                                build_pointer_type (TREE_TYPE (arg1_tree)),
4431                                arg1_tree));
4432       }
4433       return expr_tree;
4434
4435     case FFEINTRIN_impMVBITS:
4436       {
4437         tree arg1_tree;
4438         tree arg2_tree;
4439         tree arg3_tree;
4440         ffebld arg4 = ffebld_head (ffebld_trail (list));
4441         tree arg4_tree;
4442         tree arg4_type;
4443         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4444         tree arg5_tree;
4445         tree prep_arg1;
4446         tree prep_arg4;
4447         tree arg5_plus_arg3;
4448
4449         ffecom_push_calltemps ();
4450
4451         arg2_tree = convert (integer_type_node,
4452                              ffecom_expr (arg2));
4453         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4454                                                ffecom_expr (arg3)));
4455         arg4_tree = ffecom_expr_rw (arg4);
4456         arg4_type = TREE_TYPE (arg4_tree);
4457
4458         arg1_tree = ffecom_save_tree (convert (arg4_type,
4459                                                ffecom_expr (arg1)));
4460
4461         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4462                                                ffecom_expr (arg5)));
4463
4464         ffecom_pop_calltemps ();
4465
4466         prep_arg1
4467           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4468                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4469                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4470                                           arg1_tree,
4471                                           arg2_tree),
4472                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4473                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4474                                                     ffecom_1 (BIT_NOT_EXPR,
4475                                                               arg4_type,
4476                                                               convert
4477                                                               (arg4_type,
4478                                                         integer_zero_node)),
4479                                                     arg3_tree))),
4480                       arg5_tree);
4481         arg5_plus_arg3
4482           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4483                                         arg5_tree,
4484                                         arg3_tree));
4485         prep_arg4
4486           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4487                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4488                                 convert (arg4_type,
4489                                          integer_zero_node)),
4490                       arg5_plus_arg3);
4491 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4492         prep_arg4
4493           = ffecom_3 (COND_EXPR, arg4_type,
4494                       ffecom_truth_value
4495                       (ffecom_2 (NE_EXPR, integer_type_node,
4496                                  arg5_plus_arg3,
4497                                  convert (TREE_TYPE (arg5_plus_arg3),
4498                                           TYPE_SIZE (arg4_type)))),
4499                       prep_arg4,
4500                       convert (arg4_type, integer_zero_node));
4501 #endif
4502         prep_arg4
4503           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4504                       arg4_tree,
4505                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4506                                 prep_arg4,
4507                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4508                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4509                                                     ffecom_1 (BIT_NOT_EXPR,
4510                                                               arg4_type,
4511                                                               convert
4512                                                               (arg4_type,
4513                                                         integer_zero_node)),
4514                                                     arg5_tree))));
4515         prep_arg1
4516           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4517                       prep_arg1,
4518                       prep_arg4);
4519 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4520         prep_arg1
4521           = ffecom_3 (COND_EXPR, arg4_type,
4522                       ffecom_truth_value
4523                       (ffecom_2 (NE_EXPR, integer_type_node,
4524                                  arg3_tree,
4525                                  convert (TREE_TYPE (arg3_tree),
4526                                           integer_zero_node))),
4527                       prep_arg1,
4528                       arg4_tree);
4529         prep_arg1
4530           = ffecom_3 (COND_EXPR, arg4_type,
4531                       ffecom_truth_value
4532                       (ffecom_2 (NE_EXPR, integer_type_node,
4533                                  arg3_tree,
4534                                  convert (TREE_TYPE (arg3_tree),
4535                                           TYPE_SIZE (arg4_type)))),
4536                       prep_arg1,
4537                       arg1_tree);
4538 #endif
4539         expr_tree
4540           = ffecom_2s (MODIFY_EXPR, void_type_node,
4541                        arg4_tree,
4542                        prep_arg1);
4543         /* Make sure SAVE_EXPRs get referenced early enough. */
4544         expr_tree
4545           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4546                       arg1_tree,
4547                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4548                                 arg3_tree,
4549                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4550                                           arg5_tree,
4551                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4552                                                     arg5_plus_arg3,
4553                                                     expr_tree))));
4554         expr_tree
4555           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4556                       arg4_tree,
4557                       expr_tree);
4558
4559       }
4560       return expr_tree;
4561
4562     case FFEINTRIN_impDERF:
4563     case FFEINTRIN_impERF:
4564     case FFEINTRIN_impDERFC:
4565     case FFEINTRIN_impERFC:
4566       break;
4567
4568     case FFEINTRIN_impIARGC:
4569       /* extern int xargc; i__1 = xargc - 1; */
4570       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4571                             ffecom_tree_xargc_,
4572                             convert (TREE_TYPE (ffecom_tree_xargc_),
4573                                      integer_one_node));
4574       return expr_tree;
4575
4576     case FFEINTRIN_impSIGNAL_func:
4577     case FFEINTRIN_impSIGNAL_subr:
4578       {
4579         tree arg1_tree;
4580         tree arg2_tree;
4581         tree arg3_tree;
4582
4583         ffecom_push_calltemps ();
4584
4585         arg1_tree = convert (ffecom_f2c_integer_type_node,
4586                              ffecom_expr (arg1));
4587         arg1_tree = ffecom_1 (ADDR_EXPR,
4588                               build_pointer_type (TREE_TYPE (arg1_tree)),
4589                               arg1_tree);
4590
4591         /* Pass procedure as a pointer to it, anything else by value.  */
4592         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4593           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4594         else
4595           arg2_tree = ffecom_ptr_to_expr (arg2);
4596         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4597                              arg2_tree);
4598
4599         if (arg3 != NULL)
4600           arg3_tree = ffecom_expr_rw (arg3);
4601         else
4602           arg3_tree = NULL_TREE;
4603
4604         ffecom_pop_calltemps ();
4605
4606         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4607         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4608         TREE_CHAIN (arg1_tree) = arg2_tree;
4609
4610         expr_tree
4611           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4612                           ffecom_gfrt_kindtype (gfrt),
4613                           FALSE,
4614                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4615                            NULL_TREE :
4616                            tree_type),
4617                           arg1_tree,
4618                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
4619
4620         if (arg3_tree != NULL_TREE)
4621           expr_tree
4622             = ffecom_modify (NULL_TREE, arg3_tree,
4623                              convert (TREE_TYPE (arg3_tree),
4624                                       expr_tree));
4625       }
4626       return expr_tree;
4627
4628     case FFEINTRIN_impALARM:
4629       {
4630         tree arg1_tree;
4631         tree arg2_tree;
4632         tree arg3_tree;
4633
4634         ffecom_push_calltemps ();
4635
4636         arg1_tree = convert (ffecom_f2c_integer_type_node,
4637                              ffecom_expr (arg1));
4638         arg1_tree = ffecom_1 (ADDR_EXPR,
4639                               build_pointer_type (TREE_TYPE (arg1_tree)),
4640                               arg1_tree);
4641
4642         /* Pass procedure as a pointer to it, anything else by value.  */
4643         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4644           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4645         else
4646           arg2_tree = ffecom_ptr_to_expr (arg2);
4647         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4648                              arg2_tree);
4649
4650         if (arg3 != NULL)
4651           arg3_tree = ffecom_expr_rw (arg3);
4652         else
4653           arg3_tree = NULL_TREE;
4654
4655         ffecom_pop_calltemps ();
4656
4657         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4658         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4659         TREE_CHAIN (arg1_tree) = arg2_tree;
4660
4661         expr_tree
4662           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4663                           ffecom_gfrt_kindtype (gfrt),
4664                           FALSE,
4665                           NULL_TREE,
4666                           arg1_tree,
4667                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
4668
4669         if (arg3_tree != NULL_TREE)
4670           expr_tree
4671             = ffecom_modify (NULL_TREE, arg3_tree,
4672                              convert (TREE_TYPE (arg3_tree),
4673                                       expr_tree));
4674       }
4675       return expr_tree;
4676
4677     case FFEINTRIN_impCHDIR_subr:
4678     case FFEINTRIN_impFDATE_subr:
4679     case FFEINTRIN_impFGET_subr:
4680     case FFEINTRIN_impFPUT_subr:
4681     case FFEINTRIN_impGETCWD_subr:
4682     case FFEINTRIN_impHOSTNM_subr:
4683     case FFEINTRIN_impSYSTEM_subr:
4684     case FFEINTRIN_impUNLINK_subr:
4685       {
4686         tree arg1_len = integer_zero_node;
4687         tree arg1_tree;
4688         tree arg2_tree;
4689
4690         ffecom_push_calltemps ();
4691
4692         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4693
4694         if (arg2 != NULL)
4695           arg2_tree = ffecom_expr_rw (arg2);
4696         else
4697           arg2_tree = NULL_TREE;
4698
4699         ffecom_pop_calltemps ();
4700
4701         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4702         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4703         TREE_CHAIN (arg1_tree) = arg1_len;
4704
4705         expr_tree
4706           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4707                           ffecom_gfrt_kindtype (gfrt),
4708                           FALSE,
4709                           NULL_TREE,
4710                           arg1_tree,
4711                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
4712
4713         if (arg2_tree != NULL_TREE)
4714           expr_tree
4715             = ffecom_modify (NULL_TREE, arg2_tree,
4716                              convert (TREE_TYPE (arg2_tree),
4717                                       expr_tree));
4718       }
4719       return expr_tree;
4720
4721     case FFEINTRIN_impEXIT:
4722       if (arg1 != NULL)
4723         break;
4724
4725       expr_tree = build_tree_list (NULL_TREE,
4726                                    ffecom_1 (ADDR_EXPR,
4727                                              build_pointer_type
4728                                              (ffecom_integer_type_node),
4729                                              integer_zero_node));
4730
4731       return
4732         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4733                       ffecom_gfrt_kindtype (gfrt),
4734                       FALSE,
4735                       void_type_node,
4736                       expr_tree,
4737                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
4738
4739     case FFEINTRIN_impFLUSH:
4740       if (arg1 == NULL)
4741         gfrt = FFECOM_gfrtFLUSH;
4742       else
4743         gfrt = FFECOM_gfrtFLUSH1;
4744       break;
4745
4746     case FFEINTRIN_impCHMOD_subr:
4747     case FFEINTRIN_impLINK_subr:
4748     case FFEINTRIN_impRENAME_subr:
4749     case FFEINTRIN_impSYMLNK_subr:
4750       {
4751         tree arg1_len = integer_zero_node;
4752         tree arg1_tree;
4753         tree arg2_len = integer_zero_node;
4754         tree arg2_tree;
4755         tree arg3_tree;
4756
4757         ffecom_push_calltemps ();
4758
4759         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4760         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
4761         if (arg3 != NULL)
4762           arg3_tree = ffecom_expr_rw (arg3);
4763         else
4764           arg3_tree = NULL_TREE;
4765
4766         ffecom_pop_calltemps ();
4767
4768         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4769         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4770         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4771         arg2_len = build_tree_list (NULL_TREE, arg2_len);
4772         TREE_CHAIN (arg1_tree) = arg2_tree;
4773         TREE_CHAIN (arg2_tree) = arg1_len;
4774         TREE_CHAIN (arg1_len) = arg2_len;
4775         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4776                                   ffecom_gfrt_kindtype (gfrt),
4777                                   FALSE,
4778                                   NULL_TREE,
4779                                   arg1_tree,
4780                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
4781         if (arg3_tree != NULL_TREE)
4782           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
4783                                      convert (TREE_TYPE (arg3_tree),
4784                                               expr_tree));
4785       }
4786       return expr_tree;
4787
4788     case FFEINTRIN_impLSTAT_subr:
4789     case FFEINTRIN_impSTAT_subr:
4790       {
4791         tree arg1_len = integer_zero_node;
4792         tree arg1_tree;
4793         tree arg2_tree;
4794         tree arg3_tree;
4795
4796         ffecom_push_calltemps ();
4797
4798         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4799
4800         arg2_tree = ffecom_ptr_to_expr (arg2);
4801
4802         if (arg3 != NULL)
4803           arg3_tree = ffecom_expr_rw (arg3);
4804         else
4805           arg3_tree = NULL_TREE;
4806
4807         ffecom_pop_calltemps ();
4808
4809         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4810         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4811         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4812         TREE_CHAIN (arg1_tree) = arg2_tree;
4813         TREE_CHAIN (arg2_tree) = arg1_len;
4814         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4815                                   ffecom_gfrt_kindtype (gfrt),
4816                                   FALSE,
4817                                   NULL_TREE,
4818                                   arg1_tree,
4819                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
4820         if (arg3_tree != NULL_TREE)
4821           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
4822                                      convert (TREE_TYPE (arg3_tree),
4823                                               expr_tree));
4824       }
4825       return expr_tree;
4826
4827     case FFEINTRIN_impFGETC_subr:
4828     case FFEINTRIN_impFPUTC_subr:
4829       {
4830         tree arg1_tree;
4831         tree arg2_tree;
4832         tree arg2_len = integer_zero_node;
4833         tree arg3_tree;
4834
4835         ffecom_push_calltemps ();
4836
4837         arg1_tree = convert (ffecom_f2c_integer_type_node,
4838                              ffecom_expr (arg1));
4839         arg1_tree = ffecom_1 (ADDR_EXPR,
4840                               build_pointer_type (TREE_TYPE (arg1_tree)),
4841                               arg1_tree);
4842
4843         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
4844         arg3_tree = ffecom_expr_rw (arg3);
4845
4846         ffecom_pop_calltemps ();
4847
4848         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4849         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4850         arg2_len = build_tree_list (NULL_TREE, arg2_len);
4851         TREE_CHAIN (arg1_tree) = arg2_tree;
4852         TREE_CHAIN (arg2_tree) = arg2_len;
4853
4854         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4855                                   ffecom_gfrt_kindtype (gfrt),
4856                                   FALSE,
4857                                   NULL_TREE,
4858                                   arg1_tree,
4859                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
4860         expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
4861                                    convert (TREE_TYPE (arg3_tree),
4862                                             expr_tree));
4863       }
4864       return expr_tree;
4865
4866     case FFEINTRIN_impFSTAT_subr:
4867       {
4868         tree arg1_tree;
4869         tree arg2_tree;
4870         tree arg3_tree;
4871
4872         ffecom_push_calltemps ();
4873
4874         arg1_tree = convert (ffecom_f2c_integer_type_node,
4875                              ffecom_expr (arg1));
4876         arg1_tree = ffecom_1 (ADDR_EXPR,
4877                               build_pointer_type (TREE_TYPE (arg1_tree)),
4878                               arg1_tree);
4879
4880         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
4881                              ffecom_ptr_to_expr (arg2));
4882
4883         if (arg3 == NULL)
4884           arg3_tree = NULL_TREE;
4885         else
4886           arg3_tree = ffecom_expr_rw (arg3);
4887
4888         ffecom_pop_calltemps ();
4889
4890         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4891         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4892         TREE_CHAIN (arg1_tree) = arg2_tree;
4893         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4894                                   ffecom_gfrt_kindtype (gfrt),
4895                                   FALSE,
4896                                   NULL_TREE,
4897                                   arg1_tree,
4898                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
4899         if (arg3_tree != NULL_TREE) {
4900           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
4901                                      convert (TREE_TYPE (arg3_tree),
4902                                               expr_tree));
4903         }
4904       }
4905       return expr_tree;
4906
4907     case FFEINTRIN_impKILL_subr:
4908       {
4909         tree arg1_tree;
4910         tree arg2_tree;
4911         tree arg3_tree;
4912
4913         ffecom_push_calltemps ();
4914
4915         arg1_tree = convert (ffecom_f2c_integer_type_node,
4916                              ffecom_expr (arg1));
4917         arg1_tree = ffecom_1 (ADDR_EXPR,
4918                               build_pointer_type (TREE_TYPE (arg1_tree)),
4919                               arg1_tree);
4920
4921         arg2_tree = convert (ffecom_f2c_integer_type_node,
4922                              ffecom_expr (arg2));
4923         arg2_tree = ffecom_1 (ADDR_EXPR,
4924                               build_pointer_type (TREE_TYPE (arg2_tree)),
4925                               arg2_tree);
4926
4927         if (arg3 == NULL)
4928           arg3_tree = NULL_TREE;
4929         else
4930           arg3_tree = ffecom_expr_rw (arg3);
4931
4932         ffecom_pop_calltemps ();
4933
4934         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4935         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4936         TREE_CHAIN (arg1_tree) = arg2_tree;
4937         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4938                                   ffecom_gfrt_kindtype (gfrt),
4939                                   FALSE,
4940                                   NULL_TREE,
4941                                   arg1_tree,
4942                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
4943         if (arg3_tree != NULL_TREE) {
4944           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
4945                                      convert (TREE_TYPE (arg3_tree),
4946                                               expr_tree));
4947         }
4948       }
4949       return expr_tree;
4950
4951     case FFEINTRIN_impCTIME_subr:
4952     case FFEINTRIN_impTTYNAM_subr:
4953       {
4954         tree arg1_len = integer_zero_node;
4955         tree arg1_tree;
4956         tree arg2_tree;
4957
4958         ffecom_push_calltemps ();
4959
4960         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4961
4962         arg2_tree = convert (((gfrt == FFEINTRIN_impCTIME_subr) ?
4963                               ffecom_f2c_longint_type_node :
4964                               ffecom_f2c_integer_type_node),
4965                              ffecom_expr (arg2));
4966         arg2_tree = ffecom_1 (ADDR_EXPR,
4967                               build_pointer_type (TREE_TYPE (arg2_tree)),
4968                               arg2_tree);
4969
4970         ffecom_pop_calltemps ();
4971
4972         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4973         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4974         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4975         TREE_CHAIN (arg1_len) = arg2_tree;
4976         TREE_CHAIN (arg1_tree) = arg1_len;
4977
4978         expr_tree
4979           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4980                           ffecom_gfrt_kindtype (gfrt),
4981                           FALSE,
4982                           NULL_TREE,
4983                           arg1_tree,
4984                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
4985       }
4986       return expr_tree;
4987
4988     case FFEINTRIN_impIRAND:
4989     case FFEINTRIN_impRAND:
4990       /* Arg defaults to 0 (normal random case) */
4991       {
4992         tree arg1_tree;
4993
4994         if (arg1 == NULL)
4995           arg1_tree = ffecom_integer_zero_node;
4996         else
4997           arg1_tree = ffecom_expr (arg1);
4998         arg1_tree = convert (ffecom_f2c_integer_type_node,
4999                              arg1_tree);
5000         arg1_tree = ffecom_1 (ADDR_EXPR,
5001                               build_pointer_type (TREE_TYPE (arg1_tree)),
5002                               arg1_tree);
5003         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5004
5005         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5006                                   ffecom_gfrt_kindtype (gfrt),
5007                                   FALSE,
5008                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5009                                    ffecom_f2c_integer_type_node :
5010                                    ffecom_f2c_doublereal_type_node),
5011                                   arg1_tree,
5012                                   dest_tree, dest, dest_used,
5013                                   NULL_TREE, TRUE);
5014       }
5015       return expr_tree;
5016
5017     case FFEINTRIN_impFTELL_subr:
5018     case FFEINTRIN_impUMASK_subr:
5019       {
5020         tree arg1_tree;
5021         tree arg2_tree;
5022
5023         ffecom_push_calltemps ();
5024
5025         arg1_tree = convert (ffecom_f2c_integer_type_node,
5026                              ffecom_expr (arg1));
5027         arg1_tree = ffecom_1 (ADDR_EXPR,
5028                               build_pointer_type (TREE_TYPE (arg1_tree)),
5029                               arg1_tree);
5030
5031         if (arg2 == NULL)
5032           arg2_tree = NULL_TREE;
5033         else
5034           arg2_tree = ffecom_expr_rw (arg2);
5035
5036         ffecom_pop_calltemps ();
5037
5038         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5039                                   ffecom_gfrt_kindtype (gfrt),
5040                                   FALSE,
5041                                   NULL_TREE,
5042                                   build_tree_list (NULL_TREE, arg1_tree),
5043                                   NULL_TREE, NULL, NULL, NULL_TREE,
5044                                   TRUE);
5045         if (arg2_tree != NULL_TREE) {
5046           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5047                                      convert (TREE_TYPE (arg2_tree),
5048                                               expr_tree));
5049         }
5050       }
5051       return expr_tree;
5052
5053     case FFEINTRIN_impCPU_TIME:
5054     case FFEINTRIN_impSECOND_subr:
5055       {
5056         tree arg1_tree;
5057
5058         ffecom_push_calltemps ();
5059
5060         arg1_tree = ffecom_expr_rw (arg1);
5061
5062         ffecom_pop_calltemps ();
5063
5064         expr_tree
5065           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5066                           ffecom_gfrt_kindtype (gfrt),
5067                           FALSE,
5068                           NULL_TREE,
5069                           NULL_TREE,
5070                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE);
5071
5072         expr_tree
5073           = ffecom_modify (NULL_TREE, arg1_tree,
5074                            convert (TREE_TYPE (arg1_tree),
5075                                     expr_tree));
5076       }
5077       return expr_tree;
5078
5079     case FFEINTRIN_impDTIME_subr:
5080     case FFEINTRIN_impETIME_subr:
5081       {
5082         tree arg1_tree;
5083         tree arg2_tree;
5084
5085         ffecom_push_calltemps ();
5086
5087         arg1_tree = ffecom_expr_rw (arg1);
5088
5089         arg2_tree = ffecom_ptr_to_expr (arg2);
5090
5091         ffecom_pop_calltemps ();
5092
5093         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5094                                   ffecom_gfrt_kindtype (gfrt),
5095                                   FALSE,
5096                                   NULL_TREE,
5097                                   build_tree_list (NULL_TREE, arg2_tree),
5098                                   NULL_TREE, NULL, NULL, NULL_TREE,
5099                                   TRUE);
5100         expr_tree = ffecom_modify (NULL_TREE, arg1_tree,
5101                                    convert (TREE_TYPE (arg1_tree),
5102                                             expr_tree));
5103       }
5104       return expr_tree;
5105
5106     /* Straightforward calls of libf2c routines: */
5107     case FFEINTRIN_impABORT:
5108     case FFEINTRIN_impACCESS:
5109     case FFEINTRIN_impBESJ0:
5110     case FFEINTRIN_impBESJ1:
5111     case FFEINTRIN_impBESJN:
5112     case FFEINTRIN_impBESY0:
5113     case FFEINTRIN_impBESY1:
5114     case FFEINTRIN_impBESYN:
5115     case FFEINTRIN_impCHDIR_func:
5116     case FFEINTRIN_impCHMOD_func:
5117     case FFEINTRIN_impDATE:
5118     case FFEINTRIN_impDBESJ0:
5119     case FFEINTRIN_impDBESJ1:
5120     case FFEINTRIN_impDBESJN:
5121     case FFEINTRIN_impDBESY0:
5122     case FFEINTRIN_impDBESY1:
5123     case FFEINTRIN_impDBESYN:
5124     case FFEINTRIN_impDTIME_func:
5125     case FFEINTRIN_impETIME_func:
5126     case FFEINTRIN_impFGETC_func:
5127     case FFEINTRIN_impFGET_func:
5128     case FFEINTRIN_impFNUM:
5129     case FFEINTRIN_impFPUTC_func:
5130     case FFEINTRIN_impFPUT_func:
5131     case FFEINTRIN_impFSEEK:
5132     case FFEINTRIN_impFSTAT_func:
5133     case FFEINTRIN_impFTELL_func:
5134     case FFEINTRIN_impGERROR:
5135     case FFEINTRIN_impGETARG:
5136     case FFEINTRIN_impGETCWD_func:
5137     case FFEINTRIN_impGETENV:
5138     case FFEINTRIN_impGETGID:
5139     case FFEINTRIN_impGETLOG:
5140     case FFEINTRIN_impGETPID:
5141     case FFEINTRIN_impGETUID:
5142     case FFEINTRIN_impGMTIME:
5143     case FFEINTRIN_impHOSTNM_func:
5144     case FFEINTRIN_impIDATE_unix:
5145     case FFEINTRIN_impIDATE_vxt:
5146     case FFEINTRIN_impIERRNO:
5147     case FFEINTRIN_impISATTY:
5148     case FFEINTRIN_impITIME:
5149     case FFEINTRIN_impKILL_func:
5150     case FFEINTRIN_impLINK_func:
5151     case FFEINTRIN_impLNBLNK:
5152     case FFEINTRIN_impLSTAT_func:
5153     case FFEINTRIN_impLTIME:
5154     case FFEINTRIN_impMCLOCK8:
5155     case FFEINTRIN_impMCLOCK:
5156     case FFEINTRIN_impPERROR:
5157     case FFEINTRIN_impRENAME_func:
5158     case FFEINTRIN_impSECNDS:
5159     case FFEINTRIN_impSECOND_func:
5160     case FFEINTRIN_impSLEEP:
5161     case FFEINTRIN_impSRAND:
5162     case FFEINTRIN_impSTAT_func:
5163     case FFEINTRIN_impSYMLNK_func:
5164     case FFEINTRIN_impSYSTEM_CLOCK:
5165     case FFEINTRIN_impSYSTEM_func:
5166     case FFEINTRIN_impTIME8:
5167     case FFEINTRIN_impTIME_unix:
5168     case FFEINTRIN_impTIME_vxt:
5169     case FFEINTRIN_impUMASK_func:
5170     case FFEINTRIN_impUNLINK_func:
5171       break;
5172
5173     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5174     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5175     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5176     case FFEINTRIN_impNONE:
5177     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5178       fprintf (stderr, "No %s implementation.\n",
5179                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5180       assert ("unimplemented intrinsic" == NULL);
5181       return error_mark_node;
5182     }
5183
5184   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5185
5186   ffecom_push_calltemps ();
5187   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5188                                     ffebld_right (expr));
5189   ffecom_pop_calltemps ();
5190
5191   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5192                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5193                        tree_type,
5194                        expr_tree, dest_tree, dest, dest_used,
5195                        NULL_TREE, TRUE);
5196
5197   /**INDENT* (Do not reformat this comment even with -fca option.)
5198    Data-gathering files: Given the source file listed below, compiled with
5199    f2c I obtained the output file listed after that, and from the output
5200    file I derived the above code.
5201
5202 -------- (begin input file to f2c)
5203         implicit none
5204         character*10 A1,A2
5205         complex C1,C2
5206         integer I1,I2
5207         real R1,R2
5208         double precision D1,D2
5209 C
5210         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
5211 c /
5212         call fooI(I1/I2)
5213         call fooR(R1/I1)
5214         call fooD(D1/I1)
5215         call fooC(C1/I1)
5216         call fooR(R1/R2)
5217         call fooD(R1/D1)
5218         call fooD(D1/D2)
5219         call fooD(D1/R1)
5220         call fooC(C1/C2)
5221         call fooC(C1/R1)
5222         call fooZ(C1/D1)
5223 c **
5224         call fooI(I1**I2)
5225         call fooR(R1**I1)
5226         call fooD(D1**I1)
5227         call fooC(C1**I1)
5228         call fooR(R1**R2)
5229         call fooD(R1**D1)
5230         call fooD(D1**D2)
5231         call fooD(D1**R1)
5232         call fooC(C1**C2)
5233         call fooC(C1**R1)
5234         call fooZ(C1**D1)
5235 c FFEINTRIN_impABS
5236         call fooR(ABS(R1))
5237 c FFEINTRIN_impACOS
5238         call fooR(ACOS(R1))
5239 c FFEINTRIN_impAIMAG
5240         call fooR(AIMAG(C1))
5241 c FFEINTRIN_impAINT
5242         call fooR(AINT(R1))
5243 c FFEINTRIN_impALOG
5244         call fooR(ALOG(R1))
5245 c FFEINTRIN_impALOG10
5246         call fooR(ALOG10(R1))
5247 c FFEINTRIN_impAMAX0
5248         call fooR(AMAX0(I1,I2))
5249 c FFEINTRIN_impAMAX1
5250         call fooR(AMAX1(R1,R2))
5251 c FFEINTRIN_impAMIN0
5252         call fooR(AMIN0(I1,I2))
5253 c FFEINTRIN_impAMIN1
5254         call fooR(AMIN1(R1,R2))
5255 c FFEINTRIN_impAMOD
5256         call fooR(AMOD(R1,R2))
5257 c FFEINTRIN_impANINT
5258         call fooR(ANINT(R1))
5259 c FFEINTRIN_impASIN
5260         call fooR(ASIN(R1))
5261 c FFEINTRIN_impATAN
5262         call fooR(ATAN(R1))
5263 c FFEINTRIN_impATAN2
5264         call fooR(ATAN2(R1,R2))
5265 c FFEINTRIN_impCABS
5266         call fooR(CABS(C1))
5267 c FFEINTRIN_impCCOS
5268         call fooC(CCOS(C1))
5269 c FFEINTRIN_impCEXP
5270         call fooC(CEXP(C1))
5271 c FFEINTRIN_impCHAR
5272         call fooA(CHAR(I1))
5273 c FFEINTRIN_impCLOG
5274         call fooC(CLOG(C1))
5275 c FFEINTRIN_impCONJG
5276         call fooC(CONJG(C1))
5277 c FFEINTRIN_impCOS
5278         call fooR(COS(R1))
5279 c FFEINTRIN_impCOSH
5280         call fooR(COSH(R1))
5281 c FFEINTRIN_impCSIN
5282         call fooC(CSIN(C1))
5283 c FFEINTRIN_impCSQRT
5284         call fooC(CSQRT(C1))
5285 c FFEINTRIN_impDABS
5286         call fooD(DABS(D1))
5287 c FFEINTRIN_impDACOS
5288         call fooD(DACOS(D1))
5289 c FFEINTRIN_impDASIN
5290         call fooD(DASIN(D1))
5291 c FFEINTRIN_impDATAN
5292         call fooD(DATAN(D1))
5293 c FFEINTRIN_impDATAN2
5294         call fooD(DATAN2(D1,D2))
5295 c FFEINTRIN_impDCOS
5296         call fooD(DCOS(D1))
5297 c FFEINTRIN_impDCOSH
5298         call fooD(DCOSH(D1))
5299 c FFEINTRIN_impDDIM
5300         call fooD(DDIM(D1,D2))
5301 c FFEINTRIN_impDEXP
5302         call fooD(DEXP(D1))
5303 c FFEINTRIN_impDIM
5304         call fooR(DIM(R1,R2))
5305 c FFEINTRIN_impDINT
5306         call fooD(DINT(D1))
5307 c FFEINTRIN_impDLOG
5308         call fooD(DLOG(D1))
5309 c FFEINTRIN_impDLOG10
5310         call fooD(DLOG10(D1))
5311 c FFEINTRIN_impDMAX1
5312         call fooD(DMAX1(D1,D2))
5313 c FFEINTRIN_impDMIN1
5314         call fooD(DMIN1(D1,D2))
5315 c FFEINTRIN_impDMOD
5316         call fooD(DMOD(D1,D2))
5317 c FFEINTRIN_impDNINT
5318         call fooD(DNINT(D1))
5319 c FFEINTRIN_impDPROD
5320         call fooD(DPROD(R1,R2))
5321 c FFEINTRIN_impDSIGN
5322         call fooD(DSIGN(D1,D2))
5323 c FFEINTRIN_impDSIN
5324         call fooD(DSIN(D1))
5325 c FFEINTRIN_impDSINH
5326         call fooD(DSINH(D1))
5327 c FFEINTRIN_impDSQRT
5328         call fooD(DSQRT(D1))
5329 c FFEINTRIN_impDTAN
5330         call fooD(DTAN(D1))
5331 c FFEINTRIN_impDTANH
5332         call fooD(DTANH(D1))
5333 c FFEINTRIN_impEXP
5334         call fooR(EXP(R1))
5335 c FFEINTRIN_impIABS
5336         call fooI(IABS(I1))
5337 c FFEINTRIN_impICHAR
5338         call fooI(ICHAR(A1))
5339 c FFEINTRIN_impIDIM
5340         call fooI(IDIM(I1,I2))
5341 c FFEINTRIN_impIDNINT
5342         call fooI(IDNINT(D1))
5343 c FFEINTRIN_impINDEX
5344         call fooI(INDEX(A1,A2))
5345 c FFEINTRIN_impISIGN
5346         call fooI(ISIGN(I1,I2))
5347 c FFEINTRIN_impLEN
5348         call fooI(LEN(A1))
5349 c FFEINTRIN_impLGE
5350         call fooL(LGE(A1,A2))
5351 c FFEINTRIN_impLGT
5352         call fooL(LGT(A1,A2))
5353 c FFEINTRIN_impLLE
5354         call fooL(LLE(A1,A2))
5355 c FFEINTRIN_impLLT
5356         call fooL(LLT(A1,A2))
5357 c FFEINTRIN_impMAX0
5358         call fooI(MAX0(I1,I2))
5359 c FFEINTRIN_impMAX1
5360         call fooI(MAX1(R1,R2))
5361 c FFEINTRIN_impMIN0
5362         call fooI(MIN0(I1,I2))
5363 c FFEINTRIN_impMIN1
5364         call fooI(MIN1(R1,R2))
5365 c FFEINTRIN_impMOD
5366         call fooI(MOD(I1,I2))
5367 c FFEINTRIN_impNINT
5368         call fooI(NINT(R1))
5369 c FFEINTRIN_impSIGN
5370         call fooR(SIGN(R1,R2))
5371 c FFEINTRIN_impSIN
5372         call fooR(SIN(R1))
5373 c FFEINTRIN_impSINH
5374         call fooR(SINH(R1))
5375 c FFEINTRIN_impSQRT
5376         call fooR(SQRT(R1))
5377 c FFEINTRIN_impTAN
5378         call fooR(TAN(R1))
5379 c FFEINTRIN_impTANH
5380         call fooR(TANH(R1))
5381 c FFEINTRIN_imp_CMPLX_C
5382         call fooC(cmplx(C1,C2))
5383 c FFEINTRIN_imp_CMPLX_D
5384         call fooZ(cmplx(D1,D2))
5385 c FFEINTRIN_imp_CMPLX_I
5386         call fooC(cmplx(I1,I2))
5387 c FFEINTRIN_imp_CMPLX_R
5388         call fooC(cmplx(R1,R2))
5389 c FFEINTRIN_imp_DBLE_C
5390         call fooD(dble(C1))
5391 c FFEINTRIN_imp_DBLE_D
5392         call fooD(dble(D1))
5393 c FFEINTRIN_imp_DBLE_I
5394         call fooD(dble(I1))
5395 c FFEINTRIN_imp_DBLE_R
5396         call fooD(dble(R1))
5397 c FFEINTRIN_imp_INT_C
5398         call fooI(int(C1))
5399 c FFEINTRIN_imp_INT_D
5400         call fooI(int(D1))
5401 c FFEINTRIN_imp_INT_I
5402         call fooI(int(I1))
5403 c FFEINTRIN_imp_INT_R
5404         call fooI(int(R1))
5405 c FFEINTRIN_imp_REAL_C
5406         call fooR(real(C1))
5407 c FFEINTRIN_imp_REAL_D
5408         call fooR(real(D1))
5409 c FFEINTRIN_imp_REAL_I
5410         call fooR(real(I1))
5411 c FFEINTRIN_imp_REAL_R
5412         call fooR(real(R1))
5413 c
5414 c FFEINTRIN_imp_INT_D:
5415 c
5416 c FFEINTRIN_specIDINT
5417         call fooI(IDINT(D1))
5418 c
5419 c FFEINTRIN_imp_INT_R:
5420 c
5421 c FFEINTRIN_specIFIX
5422         call fooI(IFIX(R1))
5423 c FFEINTRIN_specINT
5424         call fooI(INT(R1))
5425 c
5426 c FFEINTRIN_imp_REAL_D:
5427 c
5428 c FFEINTRIN_specSNGL
5429         call fooR(SNGL(D1))
5430 c
5431 c FFEINTRIN_imp_REAL_I:
5432 c
5433 c FFEINTRIN_specFLOAT
5434         call fooR(FLOAT(I1))
5435 c FFEINTRIN_specREAL
5436         call fooR(REAL(I1))
5437 c
5438         end
5439 -------- (end input file to f2c)
5440
5441 -------- (begin output from providing above input file as input to:
5442 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
5443 --------     -e "s:^#.*$::g"')
5444
5445 //  -- translated by f2c (version 19950223).
5446    You must link the resulting object file with the libraries:
5447         -lf2c -lm   (in that order)
5448 //
5449
5450
5451 // f2c.h  --  Standard Fortran to C header file //
5452
5453 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
5454
5455         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
5456
5457
5458
5459
5460 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
5461 // we assume short, float are OK //
5462 typedef long int // long int // integer;
5463 typedef char *address;
5464 typedef short int shortint;
5465 typedef float real;
5466 typedef double doublereal;
5467 typedef struct { real r, i; } complex;
5468 typedef struct { doublereal r, i; } doublecomplex;
5469 typedef long int // long int // logical;
5470 typedef short int shortlogical;
5471 typedef char logical1;
5472 typedef char integer1;
5473 // typedef long long longint; // // system-dependent //
5474
5475
5476
5477
5478 // Extern is for use with -E //
5479
5480
5481
5482
5483 // I/O stuff //
5484
5485
5486
5487
5488
5489
5490
5491
5492 typedef long int // int or long int // flag;
5493 typedef long int // int or long int // ftnlen;
5494 typedef long int // int or long int // ftnint;
5495
5496
5497 //external read, write//
5498 typedef struct
5499 {       flag cierr;
5500         ftnint ciunit;
5501         flag ciend;
5502         char *cifmt;
5503         ftnint cirec;
5504 } cilist;
5505
5506 //internal read, write//
5507 typedef struct
5508 {       flag icierr;
5509         char *iciunit;
5510         flag iciend;
5511         char *icifmt;
5512         ftnint icirlen;
5513         ftnint icirnum;
5514 } icilist;
5515
5516 //open//
5517 typedef struct
5518 {       flag oerr;
5519         ftnint ounit;
5520         char *ofnm;
5521         ftnlen ofnmlen;
5522         char *osta;
5523         char *oacc;
5524         char *ofm;
5525         ftnint orl;
5526         char *oblnk;
5527 } olist;
5528
5529 //close//
5530 typedef struct
5531 {       flag cerr;
5532         ftnint cunit;
5533         char *csta;
5534 } cllist;
5535
5536 //rewind, backspace, endfile//
5537 typedef struct
5538 {       flag aerr;
5539         ftnint aunit;
5540 } alist;
5541
5542 // inquire //
5543 typedef struct
5544 {       flag inerr;
5545         ftnint inunit;
5546         char *infile;
5547         ftnlen infilen;
5548         ftnint  *inex;  //parameters in standard's order//
5549         ftnint  *inopen;
5550         ftnint  *innum;
5551         ftnint  *innamed;
5552         char    *inname;
5553         ftnlen  innamlen;
5554         char    *inacc;
5555         ftnlen  inacclen;
5556         char    *inseq;
5557         ftnlen  inseqlen;
5558         char    *indir;
5559         ftnlen  indirlen;
5560         char    *infmt;
5561         ftnlen  infmtlen;
5562         char    *inform;
5563         ftnint  informlen;
5564         char    *inunf;
5565         ftnlen  inunflen;
5566         ftnint  *inrecl;
5567         ftnint  *innrec;
5568         char    *inblank;
5569         ftnlen  inblanklen;
5570 } inlist;
5571
5572
5573
5574 union Multitype {       // for multiple entry points //
5575         integer1 g;
5576         shortint h;
5577         integer i;
5578         // longint j; //
5579         real r;
5580         doublereal d;
5581         complex c;
5582         doublecomplex z;
5583         };
5584
5585 typedef union Multitype Multitype;
5586
5587 typedef long Long;      // No longer used; formerly in Namelist //
5588
5589 struct Vardesc {        // for Namelist //
5590         char *name;
5591         char *addr;
5592         ftnlen *dims;
5593         int  type;
5594         };
5595 typedef struct Vardesc Vardesc;
5596
5597 struct Namelist {
5598         char *name;
5599         Vardesc **vars;
5600         int nvars;
5601         };
5602 typedef struct Namelist Namelist;
5603
5604
5605
5606
5607
5608
5609
5610
5611 // procedure parameter types for -A and -C++ //
5612
5613
5614
5615
5616 typedef int // Unknown procedure type // (*U_fp)();
5617 typedef shortint (*J_fp)();
5618 typedef integer (*I_fp)();
5619 typedef real (*R_fp)();
5620 typedef doublereal (*D_fp)(), (*E_fp)();
5621 typedef // Complex // void  (*C_fp)();
5622 typedef // Double Complex // void  (*Z_fp)();
5623 typedef logical (*L_fp)();
5624 typedef shortlogical (*K_fp)();
5625 typedef // Character // void  (*H_fp)();
5626 typedef // Subroutine // int (*S_fp)();
5627
5628 // E_fp is for real functions when -R is not specified //
5629 typedef void  C_f;      // complex function //
5630 typedef void  H_f;      // character function //
5631 typedef void  Z_f;      // double complex function //
5632 typedef doublereal E_f; // real function with -R not specified //
5633
5634 // undef any lower-case symbols that your C compiler predefines, e.g.: //
5635
5636
5637 // (No such symbols should be defined in a strict ANSI C compiler.
5638    We can avoid trouble with f2c-translated code by using
5639    gcc -ansi [-traditional].) //
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663 // Main program // MAIN__()
5664 {
5665     // System generated locals //
5666     integer i__1;
5667     real r__1, r__2;
5668     doublereal d__1, d__2;
5669     complex q__1;
5670     doublecomplex z__1, z__2, z__3;
5671     logical L__1;
5672     char ch__1[1];
5673
5674     // Builtin functions //
5675     void c_div();
5676     integer pow_ii();
5677     double pow_ri(), pow_di();
5678     void pow_ci();
5679     double pow_dd();
5680     void pow_zz();
5681     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
5682             asin(), atan(), atan2(), c_abs();
5683     void c_cos(), c_exp(), c_log(), r_cnjg();
5684     double cos(), cosh();
5685     void c_sin(), c_sqrt();
5686     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
5687             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
5688     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
5689     logical l_ge(), l_gt(), l_le(), l_lt();
5690     integer i_nint();
5691     double r_sign();
5692
5693     // Local variables //
5694     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
5695             fool_(), fooz_(), getem_();
5696     static char a1[10], a2[10];
5697     static complex c1, c2;
5698     static doublereal d1, d2;
5699     static integer i1, i2;
5700     static real r1, r2;
5701
5702
5703     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
5704 // / //
5705     i__1 = i1 / i2;
5706     fooi_(&i__1);
5707     r__1 = r1 / i1;
5708     foor_(&r__1);
5709     d__1 = d1 / i1;
5710     food_(&d__1);
5711     d__1 = (doublereal) i1;
5712     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
5713     fooc_(&q__1);
5714     r__1 = r1 / r2;
5715     foor_(&r__1);
5716     d__1 = r1 / d1;
5717     food_(&d__1);
5718     d__1 = d1 / d2;
5719     food_(&d__1);
5720     d__1 = d1 / r1;
5721     food_(&d__1);
5722     c_div(&q__1, &c1, &c2);
5723     fooc_(&q__1);
5724     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
5725     fooc_(&q__1);
5726     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
5727     fooz_(&z__1);
5728 // ** //
5729     i__1 = pow_ii(&i1, &i2);
5730     fooi_(&i__1);
5731     r__1 = pow_ri(&r1, &i1);
5732     foor_(&r__1);
5733     d__1 = pow_di(&d1, &i1);
5734     food_(&d__1);
5735     pow_ci(&q__1, &c1, &i1);
5736     fooc_(&q__1);
5737     d__1 = (doublereal) r1;
5738     d__2 = (doublereal) r2;
5739     r__1 = pow_dd(&d__1, &d__2);
5740     foor_(&r__1);
5741     d__2 = (doublereal) r1;
5742     d__1 = pow_dd(&d__2, &d1);
5743     food_(&d__1);
5744     d__1 = pow_dd(&d1, &d2);
5745     food_(&d__1);
5746     d__2 = (doublereal) r1;
5747     d__1 = pow_dd(&d1, &d__2);
5748     food_(&d__1);
5749     z__2.r = c1.r, z__2.i = c1.i;
5750     z__3.r = c2.r, z__3.i = c2.i;
5751     pow_zz(&z__1, &z__2, &z__3);
5752     q__1.r = z__1.r, q__1.i = z__1.i;
5753     fooc_(&q__1);
5754     z__2.r = c1.r, z__2.i = c1.i;
5755     z__3.r = r1, z__3.i = 0.;
5756     pow_zz(&z__1, &z__2, &z__3);
5757     q__1.r = z__1.r, q__1.i = z__1.i;
5758     fooc_(&q__1);
5759     z__2.r = c1.r, z__2.i = c1.i;
5760     z__3.r = d1, z__3.i = 0.;
5761     pow_zz(&z__1, &z__2, &z__3);
5762     fooz_(&z__1);
5763 // FFEINTRIN_impABS //
5764     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
5765     foor_(&r__1);
5766 // FFEINTRIN_impACOS //
5767     r__1 = acos(r1);
5768     foor_(&r__1);
5769 // FFEINTRIN_impAIMAG //
5770     r__1 = r_imag(&c1);
5771     foor_(&r__1);
5772 // FFEINTRIN_impAINT //
5773     r__1 = r_int(&r1);
5774     foor_(&r__1);
5775 // FFEINTRIN_impALOG //
5776     r__1 = log(r1);
5777     foor_(&r__1);
5778 // FFEINTRIN_impALOG10 //
5779     r__1 = r_lg10(&r1);
5780     foor_(&r__1);
5781 // FFEINTRIN_impAMAX0 //
5782     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
5783     foor_(&r__1);
5784 // FFEINTRIN_impAMAX1 //
5785     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
5786     foor_(&r__1);
5787 // FFEINTRIN_impAMIN0 //
5788     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
5789     foor_(&r__1);
5790 // FFEINTRIN_impAMIN1 //
5791     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
5792     foor_(&r__1);
5793 // FFEINTRIN_impAMOD //
5794     r__1 = r_mod(&r1, &r2);
5795     foor_(&r__1);
5796 // FFEINTRIN_impANINT //
5797     r__1 = r_nint(&r1);
5798     foor_(&r__1);
5799 // FFEINTRIN_impASIN //
5800     r__1 = asin(r1);
5801     foor_(&r__1);
5802 // FFEINTRIN_impATAN //
5803     r__1 = atan(r1);
5804     foor_(&r__1);
5805 // FFEINTRIN_impATAN2 //
5806     r__1 = atan2(r1, r2);
5807     foor_(&r__1);
5808 // FFEINTRIN_impCABS //
5809     r__1 = c_abs(&c1);
5810     foor_(&r__1);
5811 // FFEINTRIN_impCCOS //
5812     c_cos(&q__1, &c1);
5813     fooc_(&q__1);
5814 // FFEINTRIN_impCEXP //
5815     c_exp(&q__1, &c1);
5816     fooc_(&q__1);
5817 // FFEINTRIN_impCHAR //
5818     *(unsigned char *)&ch__1[0] = i1;
5819     fooa_(ch__1, 1L);
5820 // FFEINTRIN_impCLOG //
5821     c_log(&q__1, &c1);
5822     fooc_(&q__1);
5823 // FFEINTRIN_impCONJG //
5824     r_cnjg(&q__1, &c1);
5825     fooc_(&q__1);
5826 // FFEINTRIN_impCOS //
5827     r__1 = cos(r1);
5828     foor_(&r__1);
5829 // FFEINTRIN_impCOSH //
5830     r__1 = cosh(r1);
5831     foor_(&r__1);
5832 // FFEINTRIN_impCSIN //
5833     c_sin(&q__1, &c1);
5834     fooc_(&q__1);
5835 // FFEINTRIN_impCSQRT //
5836     c_sqrt(&q__1, &c1);
5837     fooc_(&q__1);
5838 // FFEINTRIN_impDABS //
5839     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
5840     food_(&d__1);
5841 // FFEINTRIN_impDACOS //
5842     d__1 = acos(d1);
5843     food_(&d__1);
5844 // FFEINTRIN_impDASIN //
5845     d__1 = asin(d1);
5846     food_(&d__1);
5847 // FFEINTRIN_impDATAN //
5848     d__1 = atan(d1);
5849     food_(&d__1);
5850 // FFEINTRIN_impDATAN2 //
5851     d__1 = atan2(d1, d2);
5852     food_(&d__1);
5853 // FFEINTRIN_impDCOS //
5854     d__1 = cos(d1);
5855     food_(&d__1);
5856 // FFEINTRIN_impDCOSH //
5857     d__1 = cosh(d1);
5858     food_(&d__1);
5859 // FFEINTRIN_impDDIM //
5860     d__1 = d_dim(&d1, &d2);
5861     food_(&d__1);
5862 // FFEINTRIN_impDEXP //
5863     d__1 = exp(d1);
5864     food_(&d__1);
5865 // FFEINTRIN_impDIM //
5866     r__1 = r_dim(&r1, &r2);
5867     foor_(&r__1);
5868 // FFEINTRIN_impDINT //
5869     d__1 = d_int(&d1);
5870     food_(&d__1);
5871 // FFEINTRIN_impDLOG //
5872     d__1 = log(d1);
5873     food_(&d__1);
5874 // FFEINTRIN_impDLOG10 //
5875     d__1 = d_lg10(&d1);
5876     food_(&d__1);
5877 // FFEINTRIN_impDMAX1 //
5878     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
5879     food_(&d__1);
5880 // FFEINTRIN_impDMIN1 //
5881     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
5882     food_(&d__1);
5883 // FFEINTRIN_impDMOD //
5884     d__1 = d_mod(&d1, &d2);
5885     food_(&d__1);
5886 // FFEINTRIN_impDNINT //
5887     d__1 = d_nint(&d1);
5888     food_(&d__1);
5889 // FFEINTRIN_impDPROD //
5890     d__1 = (doublereal) r1 * r2;
5891     food_(&d__1);
5892 // FFEINTRIN_impDSIGN //
5893     d__1 = d_sign(&d1, &d2);
5894     food_(&d__1);
5895 // FFEINTRIN_impDSIN //
5896     d__1 = sin(d1);
5897     food_(&d__1);
5898 // FFEINTRIN_impDSINH //
5899     d__1 = sinh(d1);
5900     food_(&d__1);
5901 // FFEINTRIN_impDSQRT //
5902     d__1 = sqrt(d1);
5903     food_(&d__1);
5904 // FFEINTRIN_impDTAN //
5905     d__1 = tan(d1);
5906     food_(&d__1);
5907 // FFEINTRIN_impDTANH //
5908     d__1 = tanh(d1);
5909     food_(&d__1);
5910 // FFEINTRIN_impEXP //
5911     r__1 = exp(r1);
5912     foor_(&r__1);
5913 // FFEINTRIN_impIABS //
5914     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
5915     fooi_(&i__1);
5916 // FFEINTRIN_impICHAR //
5917     i__1 = *(unsigned char *)a1;
5918     fooi_(&i__1);
5919 // FFEINTRIN_impIDIM //
5920     i__1 = i_dim(&i1, &i2);
5921     fooi_(&i__1);
5922 // FFEINTRIN_impIDNINT //
5923     i__1 = i_dnnt(&d1);
5924     fooi_(&i__1);
5925 // FFEINTRIN_impINDEX //
5926     i__1 = i_indx(a1, a2, 10L, 10L);
5927     fooi_(&i__1);
5928 // FFEINTRIN_impISIGN //
5929     i__1 = i_sign(&i1, &i2);
5930     fooi_(&i__1);
5931 // FFEINTRIN_impLEN //
5932     i__1 = i_len(a1, 10L);
5933     fooi_(&i__1);
5934 // FFEINTRIN_impLGE //
5935     L__1 = l_ge(a1, a2, 10L, 10L);
5936     fool_(&L__1);
5937 // FFEINTRIN_impLGT //
5938     L__1 = l_gt(a1, a2, 10L, 10L);
5939     fool_(&L__1);
5940 // FFEINTRIN_impLLE //
5941     L__1 = l_le(a1, a2, 10L, 10L);
5942     fool_(&L__1);
5943 // FFEINTRIN_impLLT //
5944     L__1 = l_lt(a1, a2, 10L, 10L);
5945     fool_(&L__1);
5946 // FFEINTRIN_impMAX0 //
5947     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
5948     fooi_(&i__1);
5949 // FFEINTRIN_impMAX1 //
5950     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
5951     fooi_(&i__1);
5952 // FFEINTRIN_impMIN0 //
5953     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
5954     fooi_(&i__1);
5955 // FFEINTRIN_impMIN1 //
5956     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
5957     fooi_(&i__1);
5958 // FFEINTRIN_impMOD //
5959     i__1 = i1 % i2;
5960     fooi_(&i__1);
5961 // FFEINTRIN_impNINT //
5962     i__1 = i_nint(&r1);
5963     fooi_(&i__1);
5964 // FFEINTRIN_impSIGN //
5965     r__1 = r_sign(&r1, &r2);
5966     foor_(&r__1);
5967 // FFEINTRIN_impSIN //
5968     r__1 = sin(r1);
5969     foor_(&r__1);
5970 // FFEINTRIN_impSINH //
5971     r__1 = sinh(r1);
5972     foor_(&r__1);
5973 // FFEINTRIN_impSQRT //
5974     r__1 = sqrt(r1);
5975     foor_(&r__1);
5976 // FFEINTRIN_impTAN //
5977     r__1 = tan(r1);
5978     foor_(&r__1);
5979 // FFEINTRIN_impTANH //
5980     r__1 = tanh(r1);
5981     foor_(&r__1);
5982 // FFEINTRIN_imp_CMPLX_C //
5983     r__1 = c1.r;
5984     r__2 = c2.r;
5985     q__1.r = r__1, q__1.i = r__2;
5986     fooc_(&q__1);
5987 // FFEINTRIN_imp_CMPLX_D //
5988     z__1.r = d1, z__1.i = d2;
5989     fooz_(&z__1);
5990 // FFEINTRIN_imp_CMPLX_I //
5991     r__1 = (real) i1;
5992     r__2 = (real) i2;
5993     q__1.r = r__1, q__1.i = r__2;
5994     fooc_(&q__1);
5995 // FFEINTRIN_imp_CMPLX_R //
5996     q__1.r = r1, q__1.i = r2;
5997     fooc_(&q__1);
5998 // FFEINTRIN_imp_DBLE_C //
5999     d__1 = (doublereal) c1.r;
6000     food_(&d__1);
6001 // FFEINTRIN_imp_DBLE_D //
6002     d__1 = d1;
6003     food_(&d__1);
6004 // FFEINTRIN_imp_DBLE_I //
6005     d__1 = (doublereal) i1;
6006     food_(&d__1);
6007 // FFEINTRIN_imp_DBLE_R //
6008     d__1 = (doublereal) r1;
6009     food_(&d__1);
6010 // FFEINTRIN_imp_INT_C //
6011     i__1 = (integer) c1.r;
6012     fooi_(&i__1);
6013 // FFEINTRIN_imp_INT_D //
6014     i__1 = (integer) d1;
6015     fooi_(&i__1);
6016 // FFEINTRIN_imp_INT_I //
6017     i__1 = i1;
6018     fooi_(&i__1);
6019 // FFEINTRIN_imp_INT_R //
6020     i__1 = (integer) r1;
6021     fooi_(&i__1);
6022 // FFEINTRIN_imp_REAL_C //
6023     r__1 = c1.r;
6024     foor_(&r__1);
6025 // FFEINTRIN_imp_REAL_D //
6026     r__1 = (real) d1;
6027     foor_(&r__1);
6028 // FFEINTRIN_imp_REAL_I //
6029     r__1 = (real) i1;
6030     foor_(&r__1);
6031 // FFEINTRIN_imp_REAL_R //
6032     r__1 = r1;
6033     foor_(&r__1);
6034
6035 // FFEINTRIN_imp_INT_D: //
6036
6037 // FFEINTRIN_specIDINT //
6038     i__1 = (integer) d1;
6039     fooi_(&i__1);
6040
6041 // FFEINTRIN_imp_INT_R: //
6042
6043 // FFEINTRIN_specIFIX //
6044     i__1 = (integer) r1;
6045     fooi_(&i__1);
6046 // FFEINTRIN_specINT //
6047     i__1 = (integer) r1;
6048     fooi_(&i__1);
6049
6050 // FFEINTRIN_imp_REAL_D: //
6051
6052 // FFEINTRIN_specSNGL //
6053     r__1 = (real) d1;
6054     foor_(&r__1);
6055
6056 // FFEINTRIN_imp_REAL_I: //
6057
6058 // FFEINTRIN_specFLOAT //
6059     r__1 = (real) i1;
6060     foor_(&r__1);
6061 // FFEINTRIN_specREAL //
6062     r__1 = (real) i1;
6063     foor_(&r__1);
6064
6065 } // MAIN__ //
6066
6067 -------- (end output file from f2c)
6068
6069 */
6070 }
6071
6072 #endif
6073 /* For power (exponentiation) where right-hand operand is type INTEGER,
6074    generate in-line code to do it the fast way (which, if the operand
6075    is a constant, might just mean a series of multiplies).  */
6076
6077 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6078 static tree
6079 ffecom_expr_power_integer_ (ffebld left, ffebld right)
6080 {
6081   tree l = ffecom_expr (left);
6082   tree r = ffecom_expr (right);
6083   tree ltype = TREE_TYPE (l);
6084   tree rtype = TREE_TYPE (r);
6085   tree result = NULL_TREE;
6086
6087   if (l == error_mark_node
6088       || r == error_mark_node)
6089     return error_mark_node;
6090
6091   if (TREE_CODE (r) == INTEGER_CST)
6092     {
6093       int sgn = tree_int_cst_sgn (r);
6094
6095       if (sgn == 0)
6096         return convert (ltype, integer_one_node);
6097
6098       if ((TREE_CODE (ltype) == INTEGER_TYPE)
6099           && (sgn < 0))
6100         {
6101           /* Reciprocal of integer is either 0, -1, or 1, so after
6102              calculating that (which we leave to the back end to do
6103              or not do optimally), don't bother with any multiplying.  */
6104
6105           result = ffecom_tree_divide_ (ltype,
6106                                         convert (ltype, integer_one_node),
6107                                         l,
6108                                         NULL_TREE, NULL, NULL);
6109           r = ffecom_1 (NEGATE_EXPR,
6110                         rtype,
6111                         r);
6112           if ((TREE_INT_CST_LOW (r) & 1) == 0)
6113             result = ffecom_1 (ABS_EXPR, rtype,
6114                                result);
6115         }
6116
6117       /* Generate appropriate series of multiplies, preceded
6118          by divide if the exponent is negative.  */
6119
6120       l = save_expr (l);
6121
6122       if (sgn < 0)
6123         {
6124           l = ffecom_tree_divide_ (ltype,
6125                                    convert (ltype, integer_one_node),
6126                                    l,
6127                                    NULL_TREE, NULL, NULL);
6128           r = ffecom_1 (NEGATE_EXPR, rtype, r);
6129           assert (TREE_CODE (r) == INTEGER_CST);
6130
6131           if (tree_int_cst_sgn (r) < 0)
6132             {                   /* The "most negative" number.  */
6133               r = ffecom_1 (NEGATE_EXPR, rtype,
6134                             ffecom_2 (RSHIFT_EXPR, rtype,
6135                                       r,
6136                                       integer_one_node));
6137               l = save_expr (l);
6138               l = ffecom_2 (MULT_EXPR, ltype,
6139                             l,
6140                             l);
6141             }
6142         }
6143
6144       for (;;)
6145         {
6146           if (TREE_INT_CST_LOW (r) & 1)
6147             {
6148               if (result == NULL_TREE)
6149                 result = l;
6150               else
6151                 result = ffecom_2 (MULT_EXPR, ltype,
6152                                    result,
6153                                    l);
6154             }
6155
6156           r = ffecom_2 (RSHIFT_EXPR, rtype,
6157                         r,
6158                         integer_one_node);
6159           if (integer_zerop (r))
6160             break;
6161           assert (TREE_CODE (r) == INTEGER_CST);
6162
6163           l = save_expr (l);
6164           l = ffecom_2 (MULT_EXPR, ltype,
6165                         l,
6166                         l);
6167         }
6168       return result;
6169     }
6170
6171   /* Though rhs isn't a constant, in-line code cannot be expanded
6172      while transforming dummies
6173      because the back end cannot be easily convinced to generate
6174      stores (MODIFY_EXPR), handle temporaries, and so on before
6175      all the appropriate rtx's have been generated for things like
6176      dummy args referenced in rhs -- which doesn't happen until
6177      store_parm_decls() is called (expand_function_start, I believe,
6178      does the actual rtx-stuffing of PARM_DECLs).
6179
6180      So, in this case, let the caller generate the call to the
6181      run-time-library function to evaluate the power for us.  */
6182
6183   if (ffecom_transform_only_dummies_)
6184     return NULL_TREE;
6185
6186   /* Right-hand operand not a constant, expand in-line code to figure
6187      out how to do the multiplies, &c.
6188
6189      The returned expression is expressed this way in GNU C, where l and
6190      r are the "inputs":
6191
6192      ({ typeof (r) rtmp = r;
6193         typeof (l) ltmp = l;
6194         typeof (l) result;
6195
6196         if (rtmp == 0)
6197           result = 1;
6198         else
6199           {
6200             if ((basetypeof (l) == basetypeof (int))
6201                 && (rtmp < 0))
6202               {
6203                 result = ((typeof (l)) 1) / ltmp;
6204                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
6205                   result = -result;
6206               }
6207             else
6208               {
6209                 result = 1;
6210                 if ((basetypeof (l) != basetypeof (int))
6211                     && (rtmp < 0))
6212                   {
6213                     ltmp = ((typeof (l)) 1) / ltmp;
6214                     rtmp = -rtmp;
6215                     if (rtmp < 0)
6216                       {
6217                         rtmp = -(rtmp >> 1);
6218                         ltmp *= ltmp;
6219                       }
6220                   }
6221                 for (;;)
6222                   {
6223                     if (rtmp & 1)
6224                       result *= ltmp;
6225                     if ((rtmp >>= 1) == 0)
6226                       break;
6227                     ltmp *= ltmp;
6228                   }
6229               }
6230           }
6231         result;
6232      })
6233
6234      Note that some of the above is compile-time collapsable, such as
6235      the first part of the if statements that checks the base type of
6236      l against int.  The if statements are phrased that way to suggest
6237      an easy way to generate the if/else constructs here, knowing that
6238      the back end should (and probably does) eliminate the resulting
6239      dead code (either the int case or the non-int case), something
6240      it couldn't do without the redundant phrasing, requiring explicit
6241      dead-code elimination here, which would be kind of difficult to
6242      read.  */
6243
6244   {
6245     tree rtmp;
6246     tree ltmp;
6247     tree basetypeof_l_is_int;
6248     tree se;
6249
6250     basetypeof_l_is_int
6251       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
6252
6253     se = expand_start_stmt_expr ();
6254     ffecom_push_calltemps ();
6255
6256     rtmp = ffecom_push_tempvar (rtype, FFETARGET_charactersizeNONE, -1,
6257                                 TRUE);
6258     ltmp = ffecom_push_tempvar (ltype, FFETARGET_charactersizeNONE, -1,
6259                                 TRUE);
6260     result = ffecom_push_tempvar (ltype, FFETARGET_charactersizeNONE, -1,
6261                                   TRUE);
6262
6263     expand_expr_stmt (ffecom_modify (void_type_node,
6264                                      rtmp,
6265                                      r));
6266     expand_expr_stmt (ffecom_modify (void_type_node,
6267                                      ltmp,
6268                                      l));
6269     expand_start_cond (ffecom_truth_value
6270                        (ffecom_2 (EQ_EXPR, integer_type_node,
6271                                   rtmp,
6272                                   convert (rtype, integer_zero_node))),
6273                        0);
6274     expand_expr_stmt (ffecom_modify (void_type_node,
6275                                      result,
6276                                      convert (ltype, integer_one_node)));
6277     expand_start_else ();
6278     if (!integer_zerop (basetypeof_l_is_int))
6279       {
6280         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
6281                                      rtmp,
6282                                      convert (rtype,
6283                                               integer_zero_node)),
6284                            0);
6285         expand_expr_stmt (ffecom_modify (void_type_node,
6286                                          result,
6287                                          ffecom_tree_divide_
6288                                          (ltype,
6289                                           convert (ltype, integer_one_node),
6290                                           ltmp,
6291                                           NULL_TREE, NULL, NULL)));
6292         expand_start_cond (ffecom_truth_value
6293                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
6294                                       ffecom_2 (LT_EXPR, integer_type_node,
6295                                                 ltmp,
6296                                                 convert (ltype,
6297                                                          integer_zero_node)),
6298                                       ffecom_2 (EQ_EXPR, integer_type_node,
6299                                                 ffecom_2 (BIT_AND_EXPR,
6300                                                           rtype,
6301                                                           ffecom_1 (NEGATE_EXPR,
6302                                                                     rtype,
6303                                                                     rtmp),
6304                                                           convert (rtype,
6305                                                                    integer_one_node)),
6306                                                 convert (rtype,
6307                                                          integer_zero_node)))),
6308                            0);
6309         expand_expr_stmt (ffecom_modify (void_type_node,
6310                                          result,
6311                                          ffecom_1 (NEGATE_EXPR,
6312                                                    ltype,
6313                                                    result)));
6314         expand_end_cond ();
6315         expand_start_else ();
6316       }
6317     expand_expr_stmt (ffecom_modify (void_type_node,
6318                                      result,
6319                                      convert (ltype, integer_one_node)));
6320     expand_start_cond (ffecom_truth_value
6321                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
6322                                   ffecom_truth_value_invert
6323                                   (basetypeof_l_is_int),
6324                                   ffecom_2 (LT_EXPR, integer_type_node,
6325                                             rtmp,
6326                                             convert (rtype,
6327                                                      integer_zero_node)))),
6328                        0);
6329     expand_expr_stmt (ffecom_modify (void_type_node,
6330                                      ltmp,
6331                                      ffecom_tree_divide_
6332                                      (ltype,
6333                                       convert (ltype, integer_one_node),
6334                                       ltmp,
6335                                       NULL_TREE, NULL, NULL)));
6336     expand_expr_stmt (ffecom_modify (void_type_node,
6337                                      rtmp,
6338                                      ffecom_1 (NEGATE_EXPR, rtype,
6339                                                rtmp)));
6340     expand_start_cond (ffecom_truth_value
6341                        (ffecom_2 (LT_EXPR, integer_type_node,
6342                                   rtmp,
6343                                   convert (rtype, integer_zero_node))),
6344                        0);
6345     expand_expr_stmt (ffecom_modify (void_type_node,
6346                                      rtmp,
6347                                      ffecom_1 (NEGATE_EXPR, rtype,
6348                                                ffecom_2 (RSHIFT_EXPR,
6349                                                          rtype,
6350                                                          rtmp,
6351                                                          integer_one_node))));
6352     expand_expr_stmt (ffecom_modify (void_type_node,
6353                                      ltmp,
6354                                      ffecom_2 (MULT_EXPR, ltype,
6355                                                ltmp,
6356                                                ltmp)));
6357     expand_end_cond ();
6358     expand_end_cond ();
6359     expand_start_loop (1);
6360     expand_start_cond (ffecom_truth_value
6361                        (ffecom_2 (BIT_AND_EXPR, rtype,
6362                                   rtmp,
6363                                   convert (rtype, integer_one_node))),
6364                        0);
6365     expand_expr_stmt (ffecom_modify (void_type_node,
6366                                      result,
6367                                      ffecom_2 (MULT_EXPR, ltype,
6368                                                result,
6369                                                ltmp)));
6370     expand_end_cond ();
6371     expand_exit_loop_if_false (NULL,
6372                                ffecom_truth_value
6373                                (ffecom_modify (rtype,
6374                                                rtmp,
6375                                                ffecom_2 (RSHIFT_EXPR,
6376                                                          rtype,
6377                                                          rtmp,
6378                                                          integer_one_node))));
6379     expand_expr_stmt (ffecom_modify (void_type_node,
6380                                      ltmp,
6381                                      ffecom_2 (MULT_EXPR, ltype,
6382                                                ltmp,
6383                                                ltmp)));
6384     expand_end_loop ();
6385     expand_end_cond ();
6386     if (!integer_zerop (basetypeof_l_is_int))
6387       expand_end_cond ();
6388     expand_expr_stmt (result);
6389
6390     ffecom_pop_calltemps ();
6391     result = expand_end_stmt_expr (se);
6392     TREE_SIDE_EFFECTS (result) = 1;
6393   }
6394
6395   return result;
6396 }
6397
6398 #endif
6399 /* ffecom_expr_transform_ -- Transform symbols in expr
6400
6401    ffebld expr;  // FFE expression.
6402    ffecom_expr_transform_ (expr);
6403
6404    Recursive descent on expr while transforming any untransformed SYMTERs.  */
6405
6406 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6407 static void
6408 ffecom_expr_transform_ (ffebld expr)
6409 {
6410   tree t;
6411   ffesymbol s;
6412
6413 tail_recurse:                   /* :::::::::::::::::::: */
6414
6415   if (expr == NULL)
6416     return;
6417
6418   switch (ffebld_op (expr))
6419     {
6420     case FFEBLD_opSYMTER:
6421       s = ffebld_symter (expr);
6422       t = ffesymbol_hook (s).decl_tree;
6423       if ((t == NULL_TREE)
6424           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
6425               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
6426                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
6427         {
6428           s = ffecom_sym_transform_ (s);
6429           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
6430                                                    DIMENSION expr? */
6431         }
6432       break;                    /* Ok if (t == NULL) here. */
6433
6434     case FFEBLD_opITEM:
6435       ffecom_expr_transform_ (ffebld_head (expr));
6436       expr = ffebld_trail (expr);
6437       goto tail_recurse;        /* :::::::::::::::::::: */
6438
6439     default:
6440       break;
6441     }
6442
6443   switch (ffebld_arity (expr))
6444     {
6445     case 2:
6446       ffecom_expr_transform_ (ffebld_left (expr));
6447       expr = ffebld_right (expr);
6448       goto tail_recurse;        /* :::::::::::::::::::: */
6449
6450     case 1:
6451       expr = ffebld_left (expr);
6452       goto tail_recurse;        /* :::::::::::::::::::: */
6453
6454     default:
6455       break;
6456     }
6457
6458   return;
6459 }
6460
6461 #endif
6462 /* Make a type based on info in live f2c.h file.  */
6463
6464 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6465 static void
6466 ffecom_f2c_make_type_ (tree *type, int tcode, char *name)
6467 {
6468   switch (tcode)
6469     {
6470     case FFECOM_f2ccodeCHAR:
6471       *type = make_signed_type (CHAR_TYPE_SIZE);
6472       break;
6473
6474     case FFECOM_f2ccodeSHORT:
6475       *type = make_signed_type (SHORT_TYPE_SIZE);
6476       break;
6477
6478     case FFECOM_f2ccodeINT:
6479       *type = make_signed_type (INT_TYPE_SIZE);
6480       break;
6481
6482     case FFECOM_f2ccodeLONG:
6483       *type = make_signed_type (LONG_TYPE_SIZE);
6484       break;
6485
6486     case FFECOM_f2ccodeLONGLONG:
6487       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
6488       break;
6489
6490     case FFECOM_f2ccodeCHARPTR:
6491       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
6492                                   ? signed_char_type_node
6493                                   : unsigned_char_type_node);
6494       break;
6495
6496     case FFECOM_f2ccodeFLOAT:
6497       *type = make_node (REAL_TYPE);
6498       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
6499       layout_type (*type);
6500       break;
6501
6502     case FFECOM_f2ccodeDOUBLE:
6503       *type = make_node (REAL_TYPE);
6504       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
6505       layout_type (*type);
6506       break;
6507
6508     case FFECOM_f2ccodeLONGDOUBLE:
6509       *type = make_node (REAL_TYPE);
6510       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
6511       layout_type (*type);
6512       break;
6513
6514     case FFECOM_f2ccodeTWOREALS:
6515       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
6516       break;
6517
6518     case FFECOM_f2ccodeTWODOUBLEREALS:
6519       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
6520       break;
6521
6522     default:
6523       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
6524       *type = error_mark_node;
6525       return;
6526     }
6527
6528   pushdecl (build_decl (TYPE_DECL,
6529                         ffecom_get_invented_identifier ("__g77_f2c_%s",
6530                                                         name, 0),
6531                         *type));
6532 }
6533
6534 #endif
6535 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6536 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6537    given size.  */
6538
6539 static void
6540 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
6541                           int code)
6542 {
6543   int j;
6544   tree t;
6545
6546   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
6547     if (((t = ffecom_tree_type[bt][j]) != NULL_TREE)
6548         && (TREE_INT_CST_LOW (TYPE_SIZE (t)) == size))
6549       {
6550         assert (code != -1);
6551         ffecom_f2c_typecode_[bt][j] = code;
6552         code = -1;
6553       }
6554 }
6555
6556 #endif
6557 /* Finish up globals after doing all program units in file
6558
6559    Need to handle only uninitialized COMMON areas.  */
6560
6561 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6562 static ffeglobal
6563 ffecom_finish_global_ (ffeglobal global)
6564 {
6565   tree cbtype;
6566   tree cbt;
6567   tree size;
6568
6569   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
6570       return global;
6571
6572   if (ffeglobal_common_init (global))
6573       return global;
6574
6575   cbt = ffeglobal_hook (global);
6576   if ((cbt == NULL_TREE)
6577       || !ffeglobal_common_have_size (global))
6578     return global;              /* No need to make common, never ref'd. */
6579
6580   suspend_momentary ();
6581
6582   DECL_EXTERNAL (cbt) = 0;
6583
6584   /* Give the array a size now.  */
6585
6586   size = build_int_2 (ffeglobal_common_size (global), 0);
6587
6588   cbtype = TREE_TYPE (cbt);
6589   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6590                                            integer_one_node,
6591                                            size);
6592   if (!TREE_TYPE (size))
6593     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6594   layout_type (cbtype);
6595
6596   cbt = start_decl (cbt, FALSE);
6597   assert (cbt == ffeglobal_hook (global));
6598
6599   finish_decl (cbt, NULL_TREE, FALSE);
6600
6601   return global;
6602 }
6603
6604 #endif
6605 /* Finish up any untransformed symbols.  */
6606
6607 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6608 static ffesymbol
6609 ffecom_finish_symbol_transform_ (ffesymbol s)
6610 {
6611   if (s == NULL)
6612     return s;
6613
6614   /* It's easy to know to transform an untransformed symbol, to make sure
6615      we put out debugging info for it.  But COMMON variables, unlike
6616      EQUIVALENCE ones, aren't given declarations in addition to the
6617      tree expressions that specify offsets, because COMMON variables
6618      can be referenced in the outer scope where only dummy arguments
6619      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6620      VAR_DECLs for COMMON variables when we transform them for real
6621      use, and therefore we do all the VAR_DECL creating here.  */
6622
6623   if ((ffesymbol_hook (s).decl_tree == NULL_TREE)
6624       && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
6625           || ((ffesymbol_where (s) != FFEINFO_whereNONE)
6626               && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC)))
6627       && (ffesymbol_where (s) != FFEINFO_whereDUMMY))
6628     /* Not transformed, and not CHARACTER*(*), and not a dummy
6629        argument, which can happen only if the entry point names
6630        it "rides in on" are all invalidated for other reasons.  */
6631     s = ffecom_sym_transform_ (s);
6632
6633   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6634       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6635     {
6636 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
6637       int yes = suspend_momentary ();
6638
6639       /* This isn't working, at least for dbxout.  The .s file looks
6640          okay to me (burley), but in gdb 4.9 at least, the variables
6641          appear to reside somewhere outside of the common area, so
6642          it doesn't make sense to mislead anyone by generating the info
6643          on those variables until this is fixed.  NOTE: Same problem
6644          with EQUIVALENCE, sadly...see similar #if later.  */
6645       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6646                              ffesymbol_storage (s));
6647
6648       resume_momentary (yes);
6649 #endif
6650     }
6651
6652   return s;
6653 }
6654
6655 #endif
6656 /* Append underscore(s) to name before calling get_identifier.  "us"
6657    is nonzero if the name already contains an underscore and thus
6658    needs two underscores appended.  */
6659
6660 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6661 static tree
6662 ffecom_get_appended_identifier_ (char us, char *name)
6663 {
6664   int i;
6665   char *newname;
6666   tree id;
6667
6668   newname = xmalloc ((i = strlen (name)) + 1
6669                      + ffe_is_underscoring ()
6670                      + us);
6671   memcpy (newname, name, i);
6672   newname[i] = '_';
6673   newname[i + us] = '_';
6674   newname[i + 1 + us] = '\0';
6675   id = get_identifier (newname);
6676
6677   free (newname);
6678
6679   return id;
6680 }
6681
6682 #endif
6683 /* Decide whether to append underscore to name before calling
6684    get_identifier.  */
6685
6686 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6687 static tree
6688 ffecom_get_external_identifier_ (ffesymbol s)
6689 {
6690   char us;
6691   char *name = ffesymbol_text (s);
6692
6693   /* If name is a built-in name, just return it as is.  */
6694
6695   if (!ffe_is_underscoring ()
6696       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6697 #if FFETARGET_isENFORCED_MAIN_NAME
6698       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6699 #else
6700       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6701 #endif
6702       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6703     return get_identifier (name);
6704
6705   us = ffe_is_second_underscore ()
6706     ? (strchr (name, '_') != NULL)
6707       : 0;
6708
6709   return ffecom_get_appended_identifier_ (us, name);
6710 }
6711
6712 #endif
6713 /* Decide whether to append underscore to internal name before calling
6714    get_identifier.
6715
6716    This is for non-external, top-function-context names only.  Transform
6717    identifier so it doesn't conflict with the transformed result
6718    of using a _different_ external name.  E.g. if "CALL FOO" is
6719    transformed into "FOO_();", then the variable in "FOO_ = 3"
6720    must be transformed into something that does not conflict, since
6721    these two things should be independent.
6722
6723    The transformation is as follows.  If the name does not contain
6724    an underscore, there is no possible conflict, so just return.
6725    If the name does contain an underscore, then transform it just
6726    like we transform an external identifier.  */
6727
6728 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6729 static tree
6730 ffecom_get_identifier_ (char *name)
6731 {
6732   /* If name does not contain an underscore, just return it as is.  */
6733
6734   if (!ffe_is_underscoring ()
6735       || (strchr (name, '_') == NULL))
6736     return get_identifier (name);
6737
6738   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6739                                           name);
6740 }
6741
6742 #endif
6743 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6744
6745    tree t;
6746    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6747    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6748          ffesymbol_kindtype(s));
6749
6750    Call after setting up containing function and getting trees for all
6751    other symbols.  */
6752
6753 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6754 static tree
6755 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6756 {
6757   ffebld expr = ffesymbol_sfexpr (s);
6758   tree type;
6759   tree func;
6760   tree result;
6761   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6762   static bool recurse = FALSE;
6763   int yes;
6764   int old_lineno = lineno;
6765   char *old_input_filename = input_filename;
6766
6767   ffecom_nested_entry_ = s;
6768
6769   /* For now, we don't have a handy pointer to where the sfunc is actually
6770      defined, though that should be easy to add to an ffesymbol. (The
6771      token/where info available might well point to the place where the type
6772      of the sfunc is declared, especially if that precedes the place where
6773      the sfunc itself is defined, which is typically the case.)  We should
6774      put out a null pointer rather than point somewhere wrong, but I want to
6775      see how it works at this point.  */
6776
6777   input_filename = ffesymbol_where_filename (s);
6778   lineno = ffesymbol_where_filelinenum (s);
6779
6780   /* Pretransform the expression so any newly discovered things belong to the
6781      outer program unit, not to the statement function. */
6782
6783   ffecom_expr_transform_ (expr);
6784
6785   /* Make sure no recursive invocation of this fn (a specific case of failing
6786      to pretransform an sfunc's expression, i.e. where its expression
6787      references another untransformed sfunc) happens. */
6788
6789   assert (!recurse);
6790   recurse = TRUE;
6791
6792   yes = suspend_momentary ();
6793
6794   push_f_function_context ();
6795
6796   ffecom_push_calltemps ();
6797
6798   if (charfunc)
6799     type = void_type_node;
6800   else
6801     {
6802       type = ffecom_tree_type[bt][kt];
6803       if (type == NULL_TREE)
6804         type = integer_type_node;       /* _sym_exec_transition reports
6805                                            error. */
6806     }
6807
6808   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6809                   build_function_type (type, NULL_TREE),
6810                   1,            /* nested/inline */
6811                   0);           /* TREE_PUBLIC */
6812
6813   /* We don't worry about COMPLEX return values here, because this is
6814      entirely internal to our code, and gcc has the ability to return COMPLEX
6815      directly as a value.  */
6816
6817   yes = suspend_momentary ();
6818
6819   if (charfunc)
6820     {                           /* Prepend arg for where result goes. */
6821       tree type;
6822
6823       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6824
6825       result = ffecom_get_invented_identifier ("__g77_%s",
6826                                                "result", 0);
6827
6828       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6829
6830       type = build_pointer_type (type);
6831       result = build_decl (PARM_DECL, result, type);
6832
6833       push_parm_decl (result);
6834     }
6835   else
6836     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6837
6838   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6839
6840   resume_momentary (yes);
6841
6842   store_parm_decls (0);
6843
6844   ffecom_start_compstmt_ ();
6845
6846   if (expr != NULL)
6847     {
6848       if (charfunc)
6849         {
6850           ffetargetCharacterSize sz = ffesymbol_size (s);
6851           tree result_length;
6852
6853           result_length = build_int_2 (sz, 0);
6854           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6855
6856           ffecom_let_char_ (result, result_length, sz, expr);
6857           expand_null_return ();
6858         }
6859       else
6860         expand_return (ffecom_modify (NULL_TREE,
6861                                       DECL_RESULT (current_function_decl),
6862                                       ffecom_expr (expr)));
6863
6864       clear_momentary ();
6865     }
6866
6867   ffecom_end_compstmt_ ();
6868
6869   func = current_function_decl;
6870   finish_function (1);
6871
6872   ffecom_pop_calltemps ();
6873
6874   pop_f_function_context ();
6875
6876   resume_momentary (yes);
6877
6878   recurse = FALSE;
6879
6880   lineno = old_lineno;
6881   input_filename = old_input_filename;
6882
6883   ffecom_nested_entry_ = NULL;
6884
6885   return func;
6886 }
6887
6888 #endif
6889
6890 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6891 static char *
6892 ffecom_gfrt_args_ (ffecomGfrt ix)
6893 {
6894   return ffecom_gfrt_argstring_[ix];
6895 }
6896
6897 #endif
6898 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6899 static tree
6900 ffecom_gfrt_tree_ (ffecomGfrt ix)
6901 {
6902   if (ffecom_gfrt_[ix] == NULL_TREE)
6903     ffecom_make_gfrt_ (ix);
6904
6905   return ffecom_1 (ADDR_EXPR,
6906                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6907                    ffecom_gfrt_[ix]);
6908 }
6909
6910 #endif
6911 /* Return initialize-to-zero expression for this VAR_DECL.  */
6912
6913 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6914 static tree
6915 ffecom_init_zero_ (tree decl)
6916 {
6917   tree init;
6918   int incremental = TREE_STATIC (decl);
6919   tree type = TREE_TYPE (decl);
6920
6921   if (incremental)
6922     {
6923       int momentary = suspend_momentary ();
6924       push_obstacks_nochange ();
6925       if (TREE_PERMANENT (decl))
6926         end_temporary_allocation ();
6927       make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
6928       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6929       pop_obstacks ();
6930       resume_momentary (momentary);
6931     }
6932
6933   push_momentary ();
6934
6935   if ((TREE_CODE (type) != ARRAY_TYPE)
6936       && (TREE_CODE (type) != RECORD_TYPE)
6937       && (TREE_CODE (type) != UNION_TYPE)
6938       && !incremental)
6939     init = convert (type, integer_zero_node);
6940   else if (!incremental)
6941     {
6942       int momentary = suspend_momentary ();
6943
6944       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6945       TREE_CONSTANT (init) = 1;
6946       TREE_STATIC (init) = 1;
6947
6948       resume_momentary (momentary);
6949     }
6950   else
6951     {
6952       int momentary = suspend_momentary ();
6953
6954       assemble_zeros (int_size_in_bytes (type));
6955       init = error_mark_node;
6956
6957       resume_momentary (momentary);
6958     }
6959
6960   pop_momentary_nofree ();
6961
6962   return init;
6963 }
6964
6965 #endif
6966 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6967 static tree
6968 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6969                          tree *maybe_tree)
6970 {
6971   tree expr_tree;
6972   tree length_tree;
6973
6974   switch (ffebld_op (arg))
6975     {
6976     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6977       if (ffetarget_length_character1
6978           (ffebld_constant_character1
6979            (ffebld_conter (arg))) == 0)
6980         {
6981           *maybe_tree = integer_zero_node;
6982           return convert (tree_type, integer_zero_node);
6983         }
6984
6985       *maybe_tree = integer_one_node;
6986       expr_tree = build_int_2 (*ffetarget_text_character1
6987                                (ffebld_constant_character1
6988                                 (ffebld_conter (arg))),
6989                                0);
6990       TREE_TYPE (expr_tree) = tree_type;
6991       return expr_tree;
6992
6993     case FFEBLD_opSYMTER:
6994     case FFEBLD_opARRAYREF:
6995     case FFEBLD_opFUNCREF:
6996     case FFEBLD_opSUBSTR:
6997       ffecom_push_calltemps ();
6998       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6999       ffecom_pop_calltemps ();
7000
7001       if ((expr_tree == error_mark_node)
7002           || (length_tree == error_mark_node))
7003         {
7004           *maybe_tree = error_mark_node;
7005           return error_mark_node;
7006         }
7007
7008       if (integer_zerop (length_tree))
7009         {
7010           *maybe_tree = integer_zero_node;
7011           return convert (tree_type, integer_zero_node);
7012         }
7013
7014       expr_tree
7015         = ffecom_1 (INDIRECT_REF,
7016                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
7017                     expr_tree);
7018       expr_tree
7019         = ffecom_2 (ARRAY_REF,
7020                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
7021                     expr_tree,
7022                     integer_one_node);
7023       expr_tree = convert (tree_type, expr_tree);
7024
7025       if (TREE_CODE (length_tree) == INTEGER_CST)
7026         *maybe_tree = integer_one_node;
7027       else                      /* Must check length at run time.  */
7028         *maybe_tree
7029           = ffecom_truth_value
7030             (ffecom_2 (GT_EXPR, integer_type_node,
7031                        length_tree,
7032                        ffecom_f2c_ftnlen_zero_node));
7033       return expr_tree;
7034
7035     case FFEBLD_opPAREN:
7036     case FFEBLD_opCONVERT:
7037       if (ffeinfo_size (ffebld_info (arg)) == 0)
7038         {
7039           *maybe_tree = integer_zero_node;
7040           return convert (tree_type, integer_zero_node);
7041         }
7042       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
7043                                       maybe_tree);
7044
7045     case FFEBLD_opCONCATENATE:
7046       {
7047         tree maybe_left;
7048         tree maybe_right;
7049         tree expr_left;
7050         tree expr_right;
7051
7052         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
7053                                              &maybe_left);
7054         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
7055                                               &maybe_right);
7056         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
7057                                 maybe_left,
7058                                 maybe_right);
7059         expr_tree = ffecom_3 (COND_EXPR, tree_type,
7060                               maybe_left,
7061                               expr_left,
7062                               expr_right);
7063         return expr_tree;
7064       }
7065
7066     default:
7067       assert ("bad op in ICHAR" == NULL);
7068       return error_mark_node;
7069     }
7070 }
7071
7072 #endif
7073 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
7074
7075    tree length_arg;
7076    ffebld expr;
7077    length_arg = ffecom_intrinsic_len_ (expr);
7078
7079    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
7080    subexpressions by constructing the appropriate tree for the
7081    length-of-character-text argument in a calling sequence.  */
7082
7083 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7084 static tree
7085 ffecom_intrinsic_len_ (ffebld expr)
7086 {
7087   ffetargetCharacter1 val;
7088   tree length;
7089
7090   switch (ffebld_op (expr))
7091     {
7092     case FFEBLD_opCONTER:
7093       val = ffebld_constant_character1 (ffebld_conter (expr));
7094       length = build_int_2 (ffetarget_length_character1 (val), 0);
7095       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
7096       break;
7097
7098     case FFEBLD_opSYMTER:
7099       {
7100         ffesymbol s = ffebld_symter (expr);
7101         tree item;
7102
7103         item = ffesymbol_hook (s).decl_tree;
7104         if (item == NULL_TREE)
7105           {
7106             s = ffecom_sym_transform_ (s);
7107             item = ffesymbol_hook (s).decl_tree;
7108           }
7109         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
7110           {
7111             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
7112               length = ffesymbol_hook (s).length_tree;
7113             else
7114               {
7115                 length = build_int_2 (ffesymbol_size (s), 0);
7116                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
7117               }
7118           }
7119         else if (item == error_mark_node)
7120           length = error_mark_node;
7121         else                    /* FFEINFO_kindFUNCTION: */
7122           length = NULL_TREE;
7123       }
7124       break;
7125
7126     case FFEBLD_opARRAYREF:
7127       length = ffecom_intrinsic_len_ (ffebld_left (expr));
7128       break;
7129
7130     case FFEBLD_opSUBSTR:
7131       {
7132         ffebld start;
7133         ffebld end;
7134         ffebld thing = ffebld_right (expr);
7135         tree start_tree;
7136         tree end_tree;
7137
7138         assert (ffebld_op (thing) == FFEBLD_opITEM);
7139         start = ffebld_head (thing);
7140         thing = ffebld_trail (thing);
7141         assert (ffebld_trail (thing) == NULL);
7142         end = ffebld_head (thing);
7143
7144         length = ffecom_intrinsic_len_ (ffebld_left (expr));
7145
7146         if (length == error_mark_node)
7147           break;
7148
7149         if (start == NULL)
7150           {
7151             if (end == NULL)
7152               ;
7153             else
7154               {
7155                 length = convert (ffecom_f2c_ftnlen_type_node,
7156                                   ffecom_expr (end));
7157               }
7158           }
7159         else
7160           {
7161             start_tree = convert (ffecom_f2c_ftnlen_type_node,
7162                                   ffecom_expr (start));
7163
7164             if (start_tree == error_mark_node)
7165               {
7166                 length = error_mark_node;
7167                 break;
7168               }
7169
7170             if (end == NULL)
7171               {
7172                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
7173                                    ffecom_f2c_ftnlen_one_node,
7174                                    ffecom_2 (MINUS_EXPR,
7175                                              ffecom_f2c_ftnlen_type_node,
7176                                              length,
7177                                              start_tree));
7178               }
7179             else
7180               {
7181                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
7182                                     ffecom_expr (end));
7183
7184                 if (end_tree == error_mark_node)
7185                   {
7186                     length = error_mark_node;
7187                     break;
7188                   }
7189
7190                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
7191                                    ffecom_f2c_ftnlen_one_node,
7192                                    ffecom_2 (MINUS_EXPR,
7193                                              ffecom_f2c_ftnlen_type_node,
7194                                              end_tree, start_tree));
7195               }
7196           }
7197       }
7198       break;
7199
7200     case FFEBLD_opCONCATENATE:
7201       length
7202         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
7203                     ffecom_intrinsic_len_ (ffebld_left (expr)),
7204                     ffecom_intrinsic_len_ (ffebld_right (expr)));
7205       break;
7206
7207     case FFEBLD_opFUNCREF:
7208     case FFEBLD_opCONVERT:
7209       length = build_int_2 (ffebld_size (expr), 0);
7210       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
7211       break;
7212
7213     default:
7214       assert ("bad op for single char arg expr" == NULL);
7215       length = ffecom_f2c_ftnlen_zero_node;
7216       break;
7217     }
7218
7219   assert (length != NULL_TREE);
7220
7221   return length;
7222 }
7223
7224 #endif
7225 /* ffecom_let_char_ -- Do assignment stuff for character type
7226
7227    tree dest_tree;  // destination (ADDR_EXPR)
7228    tree dest_length;  // length (INT_CST/INDIRECT_REF(PARM_DECL))
7229    ffetargetCharacterSize dest_size;  // length
7230    ffebld source;  // source expression
7231    ffecom_let_char_(dest_tree,dest_length,dest_size,source);
7232
7233    Generates code to do the assignment.  Used by ordinary assignment
7234    statement handler ffecom_let_stmt and by statement-function
7235    handler to generate code for a statement function.  */
7236
7237 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7238 static void
7239 ffecom_let_char_ (tree dest_tree, tree dest_length,
7240                   ffetargetCharacterSize dest_size, ffebld source)
7241 {
7242   ffecomConcatList_ catlist;
7243   tree source_length;
7244   tree source_tree;
7245   tree expr_tree;
7246
7247   if ((dest_tree == error_mark_node)
7248       || (dest_length == error_mark_node))
7249     return;
7250
7251   assert (dest_tree != NULL_TREE);
7252   assert (dest_length != NULL_TREE);
7253
7254   /* Source might be an opCONVERT, which just means it is a different size
7255      than the destination.  Since the underlying implementation here handles
7256      that (directly or via the s_copy or s_cat run-time-library functions),
7257      we don't need the "convenience" of an opCONVERT that tells us to
7258      truncate or blank-pad, particularly since the resulting implementation
7259      would probably be slower than otherwise. */
7260
7261   while (ffebld_op (source) == FFEBLD_opCONVERT)
7262     source = ffebld_left (source);
7263
7264   catlist = ffecom_concat_list_new_ (source, dest_size);
7265   switch (ffecom_concat_list_count_ (catlist))
7266     {
7267     case 0:                     /* Shouldn't happen, but in case it does... */
7268       ffecom_concat_list_kill_ (catlist);
7269       source_tree = null_pointer_node;
7270       source_length = ffecom_f2c_ftnlen_zero_node;
7271       expr_tree = build_tree_list (NULL_TREE, dest_tree);
7272       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
7273       TREE_CHAIN (TREE_CHAIN (expr_tree))
7274         = build_tree_list (NULL_TREE, dest_length);
7275       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
7276         = build_tree_list (NULL_TREE, source_length);
7277
7278       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree);
7279       TREE_SIDE_EFFECTS (expr_tree) = 1;
7280
7281       expand_expr_stmt (expr_tree);
7282
7283       return;
7284
7285     case 1:                     /* The (fairly) easy case. */
7286       ffecom_char_args_ (&source_tree, &source_length,
7287                          ffecom_concat_list_expr_ (catlist, 0));
7288       ffecom_concat_list_kill_ (catlist);
7289       assert (source_tree != NULL_TREE);
7290       assert (source_length != NULL_TREE);
7291
7292       if ((source_tree == error_mark_node)
7293           || (source_length == error_mark_node))
7294         return;
7295
7296       if (dest_size == 1)
7297         {
7298           dest_tree
7299             = ffecom_1 (INDIRECT_REF,
7300                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7301                                                       (dest_tree))),
7302                         dest_tree);
7303           dest_tree
7304             = ffecom_2 (ARRAY_REF,
7305                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7306                                                       (dest_tree))),
7307                         dest_tree,
7308                         integer_one_node);
7309           source_tree
7310             = ffecom_1 (INDIRECT_REF,
7311                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7312                                                       (source_tree))),
7313                         source_tree);
7314           source_tree
7315             = ffecom_2 (ARRAY_REF,
7316                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7317                                                       (source_tree))),
7318                         source_tree,
7319                         integer_one_node);
7320
7321           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
7322
7323           expand_expr_stmt (expr_tree);
7324
7325           return;
7326         }
7327
7328       expr_tree = build_tree_list (NULL_TREE, dest_tree);
7329       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
7330       TREE_CHAIN (TREE_CHAIN (expr_tree))
7331         = build_tree_list (NULL_TREE, dest_length);
7332       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
7333         = build_tree_list (NULL_TREE, source_length);
7334
7335       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree);
7336       TREE_SIDE_EFFECTS (expr_tree) = 1;
7337
7338       expand_expr_stmt (expr_tree);
7339
7340       return;
7341
7342     default:                    /* Must actually concatenate things. */
7343       break;
7344     }
7345
7346   /* Heavy-duty concatenation. */
7347
7348   {
7349     int count = ffecom_concat_list_count_ (catlist);
7350     int i;
7351     tree lengths;
7352     tree items;
7353     tree length_array;
7354     tree item_array;
7355     tree citem;
7356     tree clength;
7357
7358     length_array
7359       = lengths
7360       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
7361                              FFETARGET_charactersizeNONE, count, TRUE);
7362     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
7363                                               FFETARGET_charactersizeNONE,
7364                                               count, TRUE);
7365
7366     for (i = 0; i < count; ++i)
7367       {
7368         ffecom_char_args_ (&citem, &clength,
7369                            ffecom_concat_list_expr_ (catlist, i));
7370         if ((citem == error_mark_node)
7371             || (clength == error_mark_node))
7372           {
7373             ffecom_concat_list_kill_ (catlist);
7374             return;
7375           }
7376
7377         items
7378           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
7379                       ffecom_modify (void_type_node,
7380                                      ffecom_2 (ARRAY_REF,
7381                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
7382                                                item_array,
7383                                                build_int_2 (i, 0)),
7384                                      citem),
7385                       items);
7386         lengths
7387           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
7388                       ffecom_modify (void_type_node,
7389                                      ffecom_2 (ARRAY_REF,
7390                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
7391                                                length_array,
7392                                                build_int_2 (i, 0)),
7393                                      clength),
7394                       lengths);
7395       }
7396
7397     expr_tree = build_tree_list (NULL_TREE, dest_tree);
7398     TREE_CHAIN (expr_tree)
7399       = build_tree_list (NULL_TREE,
7400                          ffecom_1 (ADDR_EXPR,
7401                                    build_pointer_type (TREE_TYPE (items)),
7402                                    items));
7403     TREE_CHAIN (TREE_CHAIN (expr_tree))
7404       = build_tree_list (NULL_TREE,
7405                          ffecom_1 (ADDR_EXPR,
7406                                    build_pointer_type (TREE_TYPE (lengths)),
7407                                    lengths));
7408     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
7409       = build_tree_list
7410         (NULL_TREE,
7411          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
7412                    convert (ffecom_f2c_ftnlen_type_node,
7413                             build_int_2 (count, 0))));
7414     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
7415       = build_tree_list (NULL_TREE, dest_length);
7416
7417     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree);
7418     TREE_SIDE_EFFECTS (expr_tree) = 1;
7419
7420     expand_expr_stmt (expr_tree);
7421   }
7422
7423   ffecom_concat_list_kill_ (catlist);
7424 }
7425
7426 #endif
7427 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
7428
7429    ffecomGfrt ix;
7430    ffecom_make_gfrt_(ix);
7431
7432    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
7433    for the indicated run-time routine (ix).  */
7434
7435 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7436 static void
7437 ffecom_make_gfrt_ (ffecomGfrt ix)
7438 {
7439   tree t;
7440   tree ttype;
7441
7442   push_obstacks_nochange ();
7443   end_temporary_allocation ();
7444
7445   switch (ffecom_gfrt_type_[ix])
7446     {
7447     case FFECOM_rttypeVOID_:
7448       ttype = void_type_node;
7449       break;
7450
7451     case FFECOM_rttypeFTNINT_:
7452       ttype = ffecom_f2c_ftnint_type_node;
7453       break;
7454
7455     case FFECOM_rttypeINTEGER_:
7456       ttype = ffecom_f2c_integer_type_node;
7457       break;
7458
7459     case FFECOM_rttypeLONGINT_:
7460       ttype = ffecom_f2c_longint_type_node;
7461       break;
7462
7463     case FFECOM_rttypeLOGICAL_:
7464       ttype = ffecom_f2c_logical_type_node;
7465       break;
7466
7467     case FFECOM_rttypeREAL_F2C_:
7468       ttype = double_type_node;
7469       break;
7470
7471     case FFECOM_rttypeREAL_GNU_:
7472       ttype = float_type_node;
7473       break;
7474
7475     case FFECOM_rttypeCOMPLEX_F2C_:
7476       ttype = void_type_node;
7477       break;
7478
7479     case FFECOM_rttypeCOMPLEX_GNU_:
7480       ttype = ffecom_f2c_complex_type_node;
7481       break;
7482
7483     case FFECOM_rttypeDOUBLE_:
7484       ttype = double_type_node;
7485       break;
7486
7487     case FFECOM_rttypeDOUBLEREAL_:
7488       ttype = ffecom_f2c_doublereal_type_node;
7489       break;
7490
7491     case FFECOM_rttypeDBLCMPLX_F2C_:
7492       ttype = void_type_node;
7493       break;
7494
7495     case FFECOM_rttypeDBLCMPLX_GNU_:
7496       ttype = ffecom_f2c_doublecomplex_type_node;
7497       break;
7498
7499     case FFECOM_rttypeCHARACTER_:
7500       ttype = void_type_node;
7501       break;
7502
7503     default:
7504       ttype = NULL;
7505       assert ("bad rttype" == NULL);
7506       break;
7507     }
7508
7509   ttype = build_function_type (ttype, NULL_TREE);
7510   t = build_decl (FUNCTION_DECL,
7511                   get_identifier (ffecom_gfrt_name_[ix]),
7512                   ttype);
7513   DECL_EXTERNAL (t) = 1;
7514   TREE_PUBLIC (t) = 1;
7515   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
7516
7517   t = start_decl (t, TRUE);
7518
7519   finish_decl (t, NULL_TREE, TRUE);
7520
7521   resume_temporary_allocation ();
7522   pop_obstacks ();
7523
7524   ffecom_gfrt_[ix] = t;
7525 }
7526
7527 #endif
7528 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
7529
7530 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7531 static void
7532 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
7533 {
7534   ffesymbol s = ffestorag_symbol (st);
7535
7536   if (ffesymbol_namelisted (s))
7537     ffecom_member_namelisted_ = TRUE;
7538 }
7539
7540 #endif
7541 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
7542    the member so debugger will see it.  Otherwise nobody should be
7543    referencing the member.  */
7544
7545 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7546 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
7547 static void
7548 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7549 {
7550   ffesymbol s;
7551   tree t;
7552   tree mt;
7553   tree type;
7554
7555   if ((mst == NULL)
7556       || ((mt = ffestorag_hook (mst)) == NULL)
7557       || (mt == error_mark_node))
7558     return;
7559
7560   if ((st == NULL)
7561       || ((s = ffestorag_symbol (st)) == NULL))
7562     return;
7563
7564   type = ffecom_type_localvar_ (s,
7565                                 ffesymbol_basictype (s),
7566                                 ffesymbol_kindtype (s));
7567   if (type == error_mark_node)
7568     return;
7569
7570   t = build_decl (VAR_DECL,
7571                   ffecom_get_identifier_ (ffesymbol_text (s)),
7572                   type);
7573
7574   TREE_STATIC (t) = TREE_STATIC (mt);
7575   DECL_INITIAL (t) = NULL_TREE;
7576   TREE_ASM_WRITTEN (t) = 1;
7577
7578   DECL_RTL (t)
7579     = gen_rtx (MEM, TYPE_MODE (type),
7580                plus_constant (XEXP (DECL_RTL (mt), 0),
7581                               ffestorag_modulo (mst)
7582                               + ffestorag_offset (st)
7583                               - ffestorag_offset (mst)));
7584
7585   t = start_decl (t, FALSE);
7586
7587   finish_decl (t, NULL_TREE, FALSE);
7588 }
7589
7590 #endif
7591 #endif
7592 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7593
7594    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7595    (which generates their trees) and then their trees get push_parm_decl'd.
7596
7597    The second arg is TRUE if the dummies are for a statement function, in
7598    which case lengths are not pushed for character arguments (since they are
7599    always known by both the caller and the callee, though the code allows
7600    for someday permitting CHAR*(*) stmtfunc dummies).  */
7601
7602 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7603 static void
7604 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7605 {
7606   ffebld dummy;
7607   ffebld dumlist;
7608   ffesymbol s;
7609   tree parm;
7610
7611   ffecom_transform_only_dummies_ = TRUE;
7612
7613   /* First push the parms corresponding to actual dummy "contents".  */
7614
7615   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7616     {
7617       dummy = ffebld_head (dumlist);
7618       switch (ffebld_op (dummy))
7619         {
7620         case FFEBLD_opSTAR:
7621         case FFEBLD_opANY:
7622           continue;             /* Forget alternate returns. */
7623
7624         default:
7625           break;
7626         }
7627       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7628       s = ffebld_symter (dummy);
7629       parm = ffesymbol_hook (s).decl_tree;
7630       if (parm == NULL_TREE)
7631         {
7632           s = ffecom_sym_transform_ (s);
7633           parm = ffesymbol_hook (s).decl_tree;
7634           assert (parm != NULL_TREE);
7635         }
7636       if (parm != error_mark_node)
7637         push_parm_decl (parm);
7638     }
7639
7640   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7641
7642   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7643     {
7644       dummy = ffebld_head (dumlist);
7645       switch (ffebld_op (dummy))
7646         {
7647         case FFEBLD_opSTAR:
7648         case FFEBLD_opANY:
7649           continue;             /* Forget alternate returns, they mean
7650                                    NOTHING! */
7651
7652         default:
7653           break;
7654         }
7655       s = ffebld_symter (dummy);
7656       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7657         continue;               /* Only looking for CHARACTER arguments. */
7658       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7659         continue;               /* Stmtfunc arg with known size needs no
7660                                    length param. */
7661       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7662         continue;               /* Only looking for variables and arrays. */
7663       parm = ffesymbol_hook (s).length_tree;
7664       assert (parm != NULL_TREE);
7665       if (parm != error_mark_node)
7666         push_parm_decl (parm);
7667     }
7668
7669   ffecom_transform_only_dummies_ = FALSE;
7670 }
7671
7672 #endif
7673 /* ffecom_start_progunit_ -- Beginning of program unit
7674
7675    Does GNU back end stuff necessary to teach it about the start of its
7676    equivalent of a Fortran program unit.  */
7677
7678 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7679 static void
7680 ffecom_start_progunit_ ()
7681 {
7682   ffesymbol fn = ffecom_primary_entry_;
7683   ffebld arglist;
7684   tree id;                      /* Identifier (name) of function. */
7685   tree type;                    /* Type of function. */
7686   tree result;                  /* Result of function. */
7687   ffeinfoBasictype bt;
7688   ffeinfoKindtype kt;
7689   ffeglobal g;
7690   ffeglobalType gt;
7691   ffeglobalType egt = FFEGLOBAL_type;
7692   bool charfunc;
7693   bool cmplxfunc;
7694   bool altentries = (ffecom_num_entrypoints_ != 0);
7695   bool multi
7696   = altentries
7697   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7698   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7699   bool main_program = FALSE;
7700   int old_lineno = lineno;
7701   char *old_input_filename = input_filename;
7702   int yes;
7703
7704   assert (fn != NULL);
7705   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7706
7707   input_filename = ffesymbol_where_filename (fn);
7708   lineno = ffesymbol_where_filelinenum (fn);
7709
7710   /* c-parse.y indeed does call suspend_momentary and not only ignores the
7711      return value, but also never calls resume_momentary, when starting an
7712      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
7713      same thing.  It shouldn't be a problem since start_function calls
7714      temporary_allocation, but it might be necessary.  If it causes a problem
7715      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
7716      comment appears twice in thist file.  */
7717
7718   suspend_momentary ();
7719
7720   switch (ffecom_primary_entry_kind_)
7721     {
7722     case FFEINFO_kindPROGRAM:
7723       main_program = TRUE;
7724       gt = FFEGLOBAL_typeMAIN;
7725       bt = FFEINFO_basictypeNONE;
7726       kt = FFEINFO_kindtypeNONE;
7727       type = ffecom_tree_fun_type_void;
7728       charfunc = FALSE;
7729       cmplxfunc = FALSE;
7730       break;
7731
7732     case FFEINFO_kindBLOCKDATA:
7733       gt = FFEGLOBAL_typeBDATA;
7734       bt = FFEINFO_basictypeNONE;
7735       kt = FFEINFO_kindtypeNONE;
7736       type = ffecom_tree_fun_type_void;
7737       charfunc = FALSE;
7738       cmplxfunc = FALSE;
7739       break;
7740
7741     case FFEINFO_kindFUNCTION:
7742       gt = FFEGLOBAL_typeFUNC;
7743       egt = FFEGLOBAL_typeEXT;
7744       bt = ffesymbol_basictype (fn);
7745       kt = ffesymbol_kindtype (fn);
7746       if (bt == FFEINFO_basictypeNONE)
7747         {
7748           ffeimplic_establish_symbol (fn);
7749           if (ffesymbol_funcresult (fn) != NULL)
7750             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7751           bt = ffesymbol_basictype (fn);
7752           kt = ffesymbol_kindtype (fn);
7753         }
7754
7755       if (multi)
7756         charfunc = cmplxfunc = FALSE;
7757       else if (bt == FFEINFO_basictypeCHARACTER)
7758         charfunc = TRUE, cmplxfunc = FALSE;
7759       else if ((bt == FFEINFO_basictypeCOMPLEX)
7760                && ffesymbol_is_f2c (fn)
7761                && !altentries)
7762         charfunc = FALSE, cmplxfunc = TRUE;
7763       else
7764         charfunc = cmplxfunc = FALSE;
7765
7766       if (multi || charfunc)
7767         type = ffecom_tree_fun_type_void;
7768       else if (ffesymbol_is_f2c (fn) && !altentries)
7769         type = ffecom_tree_fun_type[bt][kt];
7770       else
7771         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7772
7773       if ((type == NULL_TREE)
7774           || (TREE_TYPE (type) == NULL_TREE))
7775         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7776       break;
7777
7778     case FFEINFO_kindSUBROUTINE:
7779       gt = FFEGLOBAL_typeSUBR;
7780       egt = FFEGLOBAL_typeEXT;
7781       bt = FFEINFO_basictypeNONE;
7782       kt = FFEINFO_kindtypeNONE;
7783       if (ffecom_is_altreturning_)
7784         type = ffecom_tree_subr_type;
7785       else
7786         type = ffecom_tree_fun_type_void;
7787       charfunc = FALSE;
7788       cmplxfunc = FALSE;
7789       break;
7790
7791     default:
7792       assert ("say what??" == NULL);
7793       /* Fall through. */
7794     case FFEINFO_kindANY:
7795       gt = FFEGLOBAL_typeANY;
7796       bt = FFEINFO_basictypeNONE;
7797       kt = FFEINFO_kindtypeNONE;
7798       type = error_mark_node;
7799       charfunc = FALSE;
7800       cmplxfunc = FALSE;
7801       break;
7802     }
7803
7804   if (altentries)
7805     id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7806                                          ffesymbol_text (fn),
7807                                          0);
7808 #if FFETARGET_isENFORCED_MAIN
7809   else if (main_program)
7810     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7811 #endif
7812   else
7813     id = ffecom_get_external_identifier_ (fn);
7814
7815   start_function (id,
7816                   type,
7817                   0,            /* nested/inline */
7818                   !altentries); /* TREE_PUBLIC */
7819
7820   if (!altentries
7821       && ((g = ffesymbol_global (fn)) != NULL)
7822       && ((ffeglobal_type (g) == gt)
7823           || (ffeglobal_type (g) == egt)))
7824     {
7825       ffeglobal_set_hook (g, current_function_decl);
7826     }
7827
7828   yes = suspend_momentary ();
7829
7830   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7831      exec-transitioning needs current_function_decl to be filled in.  So we
7832      do these things in two phases. */
7833
7834   if (altentries)
7835     {                           /* 1st arg identifies which entrypoint. */
7836       ffecom_which_entrypoint_decl_
7837         = build_decl (PARM_DECL,
7838                       ffecom_get_invented_identifier ("__g77_%s",
7839                                                       "which_entrypoint",
7840                                                       0),
7841                       integer_type_node);
7842       push_parm_decl (ffecom_which_entrypoint_decl_);
7843     }
7844
7845   if (charfunc
7846       || cmplxfunc
7847       || multi)
7848     {                           /* Arg for result (return value). */
7849       tree type;
7850       tree length;
7851
7852       if (charfunc)
7853         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7854       else if (cmplxfunc)
7855         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7856       else
7857         type = ffecom_multi_type_node_;
7858
7859       result = ffecom_get_invented_identifier ("__g77_%s",
7860                                                "result", 0);
7861
7862       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7863
7864       if (charfunc)
7865         length = ffecom_char_enhance_arg_ (&type, fn);
7866       else
7867         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7868
7869       type = build_pointer_type (type);
7870       result = build_decl (PARM_DECL, result, type);
7871
7872       push_parm_decl (result);
7873       if (multi)
7874         ffecom_multi_retval_ = result;
7875       else
7876         ffecom_func_result_ = result;
7877
7878       if (charfunc)
7879         {
7880           push_parm_decl (length);
7881           ffecom_func_length_ = length;
7882         }
7883     }
7884
7885   if (ffecom_primary_entry_is_proc_)
7886     {
7887       if (altentries)
7888         arglist = ffecom_master_arglist_;
7889       else
7890         arglist = ffesymbol_dummyargs (fn);
7891       ffecom_push_dummy_decls_ (arglist, FALSE);
7892     }
7893
7894   resume_momentary (yes);
7895
7896   store_parm_decls (main_program ? 1 : 0);
7897
7898   ffecom_start_compstmt_ ();
7899
7900   lineno = old_lineno;
7901   input_filename = old_input_filename;
7902
7903   /* This handles any symbols still untransformed, in case -g specified.
7904      This used to be done in ffecom_finish_progunit, but it turns out to
7905      be necessary to do it here so that statement functions are
7906      expanded before code.  But don't bother for BLOCK DATA.  */
7907
7908   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7909     ffesymbol_drive (ffecom_finish_symbol_transform_);
7910 }
7911
7912 #endif
7913 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7914
7915    ffesymbol s;
7916    ffecom_sym_transform_(s);
7917
7918    The ffesymbol_hook info for s is updated with appropriate backend info
7919    on the symbol.  */
7920
7921 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7922 static ffesymbol
7923 ffecom_sym_transform_ (ffesymbol s)
7924 {
7925   tree t;                       /* Transformed thingy. */
7926   tree tlen;                    /* Length if CHAR*(*). */
7927   bool addr;                    /* Is t the address of the thingy? */
7928   ffeinfoBasictype bt;
7929   ffeinfoKindtype kt;
7930   ffeglobal g;
7931   int yes;
7932   int old_lineno = lineno;
7933   char *old_input_filename = input_filename;
7934
7935   if (ffesymbol_sfdummyparent (s) == NULL)
7936     {
7937       input_filename = ffesymbol_where_filename (s);
7938       lineno = ffesymbol_where_filelinenum (s);
7939     }
7940   else
7941     {
7942       ffesymbol sf = ffesymbol_sfdummyparent (s);
7943
7944       input_filename = ffesymbol_where_filename (sf);
7945       lineno = ffesymbol_where_filelinenum (sf);
7946     }
7947
7948   bt = ffeinfo_basictype (ffebld_info (s));
7949   kt = ffeinfo_kindtype (ffebld_info (s));
7950
7951   t = NULL_TREE;
7952   tlen = NULL_TREE;
7953   addr = FALSE;
7954
7955   switch (ffesymbol_kind (s))
7956     {
7957     case FFEINFO_kindNONE:
7958       switch (ffesymbol_where (s))
7959         {
7960         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7961           assert (ffecom_transform_only_dummies_);
7962
7963           /* Before 0.4, this could be ENTITY/DUMMY, but see
7964              ffestu_sym_end_transition -- no longer true (in particular, if
7965              it could be an ENTITY, it _will_ be made one, so that
7966              possibility won't come through here).  So we never make length
7967              arg for CHARACTER type.  */
7968
7969           t = build_decl (PARM_DECL,
7970                           ffecom_get_identifier_ (ffesymbol_text (s)),
7971                           ffecom_tree_ptr_to_subr_type);
7972 #if BUILT_FOR_270
7973           DECL_ARTIFICIAL (t) = 1;
7974 #endif
7975           addr = TRUE;
7976           break;
7977
7978         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7979           assert (!ffecom_transform_only_dummies_);
7980
7981           if (((g = ffesymbol_global (s)) != NULL)
7982               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7983                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7984                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7985               && (ffeglobal_hook (g) != NULL_TREE)
7986               && ffe_is_globals ())
7987             {
7988               t = ffeglobal_hook (g);
7989               break;
7990             }
7991
7992           push_obstacks_nochange ();
7993           end_temporary_allocation ();
7994
7995           t = build_decl (FUNCTION_DECL,
7996                           ffecom_get_external_identifier_ (s),
7997                           ffecom_tree_subr_type);       /* Assume subr. */
7998           DECL_EXTERNAL (t) = 1;
7999           TREE_PUBLIC (t) = 1;
8000
8001           t = start_decl (t, FALSE);
8002           finish_decl (t, NULL_TREE, FALSE);
8003
8004           if ((g != NULL)
8005               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8006                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8007                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8008             ffeglobal_set_hook (g, t);
8009
8010           resume_temporary_allocation ();
8011           pop_obstacks ();
8012
8013           break;
8014
8015         default:
8016           assert ("NONE where unexpected" == NULL);
8017           /* Fall through. */
8018         case FFEINFO_whereANY:
8019           break;
8020         }
8021       break;
8022
8023     case FFEINFO_kindENTITY:
8024       switch (ffeinfo_where (ffesymbol_info (s)))
8025         {
8026
8027         case FFEINFO_whereCONSTANT:     /* ~~debugging info needed? */
8028           assert (!ffecom_transform_only_dummies_);
8029           t = error_mark_node;  /* Shouldn't ever see this in expr. */
8030           break;
8031
8032         case FFEINFO_whereLOCAL:
8033           assert (!ffecom_transform_only_dummies_);
8034
8035           {
8036             ffestorag st = ffesymbol_storage (s);
8037             tree type;
8038
8039             if ((st != NULL)
8040                 && (ffestorag_size (st) == 0))
8041               {
8042                 t = error_mark_node;
8043                 break;
8044               }
8045
8046             yes = suspend_momentary ();
8047             type = ffecom_type_localvar_ (s, bt, kt);
8048             resume_momentary (yes);
8049
8050             if (type == error_mark_node)
8051               {
8052                 t = error_mark_node;
8053                 break;
8054               }
8055
8056             if ((st != NULL)
8057                 && (ffestorag_parent (st) != NULL))
8058               {                 /* Child of EQUIVALENCE parent. */
8059                 ffestorag est;
8060                 tree et;
8061                 int yes;
8062                 ffetargetOffset offset;
8063
8064                 est = ffestorag_parent (st);
8065                 ffecom_transform_equiv_ (est);
8066
8067                 et = ffestorag_hook (est);
8068                 assert (et != NULL_TREE);
8069
8070                 if (! TREE_STATIC (et))
8071                   put_var_into_stack (et);
8072
8073                 yes = suspend_momentary ();
8074
8075                 offset = ffestorag_modulo (est)
8076                   + ffestorag_offset (ffesymbol_storage (s))
8077                   - ffestorag_offset (est);
8078
8079                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
8080
8081                 /* (t_type *) (((char *) &et) + offset) */
8082
8083                 t = convert (string_type_node,  /* (char *) */
8084                              ffecom_1 (ADDR_EXPR,
8085                                        build_pointer_type (TREE_TYPE (et)),
8086                                        et));
8087                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8088                               t,
8089                               build_int_2 (offset, 0));
8090                 t = convert (build_pointer_type (type),
8091                              t);
8092
8093                 addr = TRUE;
8094
8095                 resume_momentary (yes);
8096               }
8097             else
8098               {
8099                 tree initexpr;
8100                 bool init = ffesymbol_is_init (s);
8101
8102                 yes = suspend_momentary ();
8103
8104                 t = build_decl (VAR_DECL,
8105                                 ffecom_get_identifier_ (ffesymbol_text (s)),
8106                                 type);
8107
8108                 if (init
8109                     || ffesymbol_namelisted (s)
8110 #ifdef FFECOM_sizeMAXSTACKITEM
8111                     || ((st != NULL)
8112                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
8113 #endif
8114                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8115                         && (ffecom_primary_entry_kind_
8116                             != FFEINFO_kindBLOCKDATA)
8117                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
8118                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
8119                 else
8120                   TREE_STATIC (t) = 0;  /* No need to make static. */
8121
8122                 if (init || ffe_is_init_local_zero ())
8123                   DECL_INITIAL (t) = error_mark_node;
8124
8125                 /* Keep -Wunused from complaining about var if it
8126                    is used as sfunc arg or DATA implied-DO.  */
8127                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
8128                   DECL_IN_SYSTEM_HEADER (t) = 1;
8129
8130                 t = start_decl (t, FALSE);
8131
8132                 if (init)
8133                   {
8134                     if (ffesymbol_init (s) != NULL)
8135                       initexpr = ffecom_expr (ffesymbol_init (s));
8136                     else
8137                       initexpr = ffecom_init_zero_ (t);
8138                   }
8139                 else if (ffe_is_init_local_zero ())
8140                   initexpr = ffecom_init_zero_ (t);
8141                 else
8142                   initexpr = NULL_TREE; /* Not ref'd if !init. */
8143
8144                 finish_decl (t, initexpr, FALSE);
8145
8146                 if ((st != NULL) && (DECL_SIZE (t) != error_mark_node))
8147                   {
8148                     tree size_tree;
8149
8150                     size_tree = size_binop (CEIL_DIV_EXPR,
8151                                             DECL_SIZE (t),
8152                                             size_int (BITS_PER_UNIT));
8153                     assert (TREE_INT_CST_HIGH (size_tree) == 0);
8154                     assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (st));
8155                   }
8156
8157                 resume_momentary (yes);
8158               }
8159           }
8160           break;
8161
8162         case FFEINFO_whereRESULT:
8163           assert (!ffecom_transform_only_dummies_);
8164
8165           if (bt == FFEINFO_basictypeCHARACTER)
8166             {                   /* Result is already in list of dummies, use
8167                                    it (& length). */
8168               t = ffecom_func_result_;
8169               tlen = ffecom_func_length_;
8170               addr = TRUE;
8171               break;
8172             }
8173           if ((ffecom_num_entrypoints_ == 0)
8174               && (bt == FFEINFO_basictypeCOMPLEX)
8175               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
8176             {                   /* Result is already in list of dummies, use
8177                                    it. */
8178               t = ffecom_func_result_;
8179               addr = TRUE;
8180               break;
8181             }
8182           if (ffecom_func_result_ != NULL_TREE)
8183             {
8184               t = ffecom_func_result_;
8185               break;
8186             }
8187           if ((ffecom_num_entrypoints_ != 0)
8188               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
8189             {
8190               yes = suspend_momentary ();
8191
8192               assert (ffecom_multi_retval_ != NULL_TREE);
8193               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
8194                             ffecom_multi_retval_);
8195               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
8196                             t, ffecom_multi_fields_[bt][kt]);
8197
8198               resume_momentary (yes);
8199               break;
8200             }
8201
8202           yes = suspend_momentary ();
8203
8204           t = build_decl (VAR_DECL,
8205                           ffecom_get_identifier_ (ffesymbol_text (s)),
8206                           ffecom_tree_type[bt][kt]);
8207           TREE_STATIC (t) = 0;  /* Put result on stack. */
8208           t = start_decl (t, FALSE);
8209           finish_decl (t, NULL_TREE, FALSE);
8210
8211           ffecom_func_result_ = t;
8212
8213           resume_momentary (yes);
8214           break;
8215
8216         case FFEINFO_whereDUMMY:
8217           {
8218             tree type;
8219             ffebld dl;
8220             ffebld dim;
8221             tree low;
8222             tree high;
8223             tree old_sizes;
8224             bool adjustable = FALSE;    /* Conditionally adjustable? */
8225
8226             type = ffecom_tree_type[bt][kt];
8227             if (ffesymbol_sfdummyparent (s) != NULL)
8228               {
8229                 if (current_function_decl == ffecom_outer_function_decl_)
8230                   {                     /* Exec transition before sfunc
8231                                            context; get it later. */
8232                     break;
8233                   }
8234                 t = ffecom_get_identifier_ (ffesymbol_text
8235                                             (ffesymbol_sfdummyparent (s)));
8236               }
8237             else
8238               t = ffecom_get_identifier_ (ffesymbol_text (s));
8239
8240             assert (ffecom_transform_only_dummies_);
8241
8242             old_sizes = get_pending_sizes ();
8243             put_pending_sizes (old_sizes);
8244
8245             if (bt == FFEINFO_basictypeCHARACTER)
8246               tlen = ffecom_char_enhance_arg_ (&type, s);
8247             type = ffecom_check_size_overflow_ (s, type, TRUE);
8248
8249             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
8250               {
8251                 if (type == error_mark_node)
8252                   break;
8253
8254                 dim = ffebld_head (dl);
8255                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
8256                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
8257                   low = ffecom_integer_one_node;
8258                 else
8259                   low = ffecom_expr (ffebld_left (dim));
8260                 assert (ffebld_right (dim) != NULL);
8261                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
8262                     || ffecom_doing_entry_)
8263                   {
8264                     /* Used to just do high=low.  But for ffecom_tree_
8265                        canonize_ref_, it probably is important to correctly
8266                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
8267                        C(2)=CFUNC(C), overlap can happen, while it can't
8268                        for, say, C(1)=CFUNC(C(2)).  */
8269                     /* Even more recently used to set to INT_MAX, but that
8270                        broke when some overflow checking went into the back
8271                        end.  Now we just leave the upper bound unspecified.  */
8272                     high = NULL;
8273                   }
8274                 else
8275                   high = ffecom_expr (ffebld_right (dim));
8276
8277                 /* Determine whether array is conditionally adjustable,
8278                    to decide whether back-end magic is needed.
8279
8280                    Normally the front end uses the back-end function
8281                    variable_size to wrap SAVE_EXPR's around expressions
8282                    affecting the size/shape of an array so that the
8283                    size/shape info doesn't change during execution
8284                    of the compiled code even though variables and
8285                    functions referenced in those expressions might.
8286
8287                    variable_size also makes sure those saved expressions
8288                    get evaluated immediately upon entry to the
8289                    compiled procedure -- the front end normally doesn't
8290                    have to worry about that.
8291
8292                    However, there is a problem with this that affects
8293                    g77's implementation of entry points, and that is
8294                    that it is _not_ true that each invocation of the
8295                    compiled procedure is permitted to evaluate
8296                    array size/shape info -- because it is possible
8297                    that, for some invocations, that info is invalid (in
8298                    which case it is "promised" -- i.e. a violation of
8299                    the Fortran standard -- that the compiled code
8300                    won't reference the array or its size/shape
8301                    during that particular invocation).
8302
8303                    To phrase this in C terms, consider this gcc function:
8304
8305                      void foo (int *n, float (*a)[*n])
8306                      {
8307                        // a is "pointer to array ...", fyi.
8308                      }
8309
8310                    Suppose that, for some invocations, it is permitted
8311                    for a caller of foo to do this:
8312
8313                        foo (NULL, NULL);
8314
8315                    Now the _written_ code for foo can take such a call
8316                    into account by either testing explicitly for whether
8317                    (a == NULL) || (n == NULL) -- presumably it is
8318                    not permitted to reference *a in various fashions
8319                    if (n == NULL) I suppose -- or it can avoid it by
8320                    looking at other info (other arguments, static/global
8321                    data, etc.).
8322
8323                    However, this won't work in gcc 2.5.8 because it'll
8324                    automatically emit the code to save the "*n"
8325                    expression, which'll yield a NULL dereference for
8326                    the "foo (NULL, NULL)" call, something the code
8327                    for foo cannot prevent.
8328
8329                    g77 definitely needs to avoid executing such
8330                    code anytime the pointer to the adjustable array
8331                    is NULL, because even if its bounds expressions
8332                    don't have any references to possible "absent"
8333                    variables like "*n" -- say all variable references
8334                    are to COMMON variables, i.e. global (though in C,
8335                    local static could actually make sense) -- the
8336                    expressions could yield other run-time problems
8337                    for allowably "dead" values in those variables.
8338
8339                    For example, let's consider a more complicated
8340                    version of foo:
8341
8342                      extern int i;
8343                      extern int j;
8344
8345                      void foo (float (*a)[i/j])
8346                      {
8347                        ...
8348                      }
8349
8350                    The above is (essentially) quite valid for Fortran
8351                    but, again, for a call like "foo (NULL);", it is
8352                    permitted for i and j to be undefined when the
8353                    call is made.  If j happened to be zero, for
8354                    example, emitting the code to evaluate "i/j"
8355                    could result in a run-time error.
8356
8357                    Offhand, though I don't have my F77 or F90
8358                    standards handy, it might even be valid for a
8359                    bounds expression to contain a function reference,
8360                    in which case I doubt it is permitted for an
8361                    implementation to invoke that function in the
8362                    Fortran case involved here (invocation of an
8363                    alternate ENTRY point that doesn't have the adjustable
8364                    array as one of its arguments).
8365
8366                    So, the code that the compiler would normally emit
8367                    to preevaluate the size/shape info for an
8368                    adjustable array _must not_ be executed at run time
8369                    in certain cases.  Specifically, for Fortran,
8370                    the case is when the pointer to the adjustable
8371                    array == NULL.  (For gnu-ish C, it might be nice
8372                    for the source code itself to specify an expression
8373                    that, if TRUE, inhibits execution of the code.  Or
8374                    reverse the sense for elegance.)
8375
8376                    (Note that g77 could use a different test than NULL,
8377                    actually, since it happens to always pass an
8378                    integer to the called function that specifies which
8379                    entry point is being invoked.  Hmm, this might
8380                    solve the next problem.)
8381
8382                    One way a user could, I suppose, write "foo" so
8383                    it works is to insert COND_EXPR's for the
8384                    size/shape info so the dangerous stuff isn't
8385                    actually done, as in:
8386
8387                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
8388                      {
8389                        ...
8390                      }
8391
8392                    The next problem is that the front end needs to
8393                    be able to tell the back end about the array's
8394                    decl _before_ it tells it about the conditional
8395                    expression to inhibit evaluation of size/shape info,
8396                    as shown above.
8397
8398                    To solve this, the front end needs to be able
8399                    to give the back end the expression to inhibit
8400                    generation of the preevaluation code _after_
8401                    it makes the decl for the adjustable array.
8402
8403                    Until then, the above example using the COND_EXPR
8404                    doesn't pass muster with gcc because the "(a == NULL)"
8405                    part has a reference to "a", which is still
8406                    undefined at that point.
8407
8408                    g77 will therefore use a different mechanism in the
8409                    meantime.  */
8410
8411                 if (!adjustable
8412                     && ((TREE_CODE (low) != INTEGER_CST)
8413                         || (high && TREE_CODE (high) != INTEGER_CST)))
8414                   adjustable = TRUE;
8415
8416 #if 0                           /* Old approach -- see below. */
8417                 if (TREE_CODE (low) != INTEGER_CST)
8418                   low = ffecom_3 (COND_EXPR, integer_type_node,
8419                                   ffecom_adjarray_passed_ (s),
8420                                   low,
8421                                   ffecom_integer_zero_node);
8422
8423                 if (high && TREE_CODE (high) != INTEGER_CST)
8424                   high = ffecom_3 (COND_EXPR, integer_type_node,
8425                                    ffecom_adjarray_passed_ (s),
8426                                    high,
8427                                    ffecom_integer_zero_node);
8428 #endif
8429
8430                 /* ~~~gcc/stor-layout.c/layout_type should do this,
8431                    probably.  Fixes 950302-1.f.  */
8432
8433                 if (TREE_CODE (low) != INTEGER_CST)
8434                   low = variable_size (low);
8435
8436                 /* ~~~similarly, this fixes dumb0.f.  The C front end
8437                    does this, which is why dumb0.c would work.  */
8438
8439                 if (high && TREE_CODE (high) != INTEGER_CST)
8440                   high = variable_size (high);
8441
8442                 type
8443                   = build_array_type
8444                     (type,
8445                      build_range_type (ffecom_integer_type_node,
8446                                        low, high));
8447                 type = ffecom_check_size_overflow_ (s, type, TRUE);
8448               }
8449
8450             if (type == error_mark_node)
8451               {
8452                 t = error_mark_node;
8453                 break;
8454               }
8455
8456             if ((ffesymbol_sfdummyparent (s) == NULL)
8457                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
8458               {
8459                 type = build_pointer_type (type);
8460                 addr = TRUE;
8461               }
8462
8463             t = build_decl (PARM_DECL, t, type);
8464 #if BUILT_FOR_270
8465             DECL_ARTIFICIAL (t) = 1;
8466 #endif
8467
8468             /* If this arg is present in every entry point's list of
8469                dummy args, then we're done.  */
8470
8471             if (ffesymbol_numentries (s)
8472                 == (ffecom_num_entrypoints_ + 1))
8473               break;
8474
8475 #if 1
8476
8477             /* If variable_size in stor-layout has been called during
8478                the above, then get_pending_sizes should have the
8479                yet-to-be-evaluated saved expressions pending.
8480                Make the whole lot of them get emitted, conditionally
8481                on whether the array decl ("t" above) is not NULL.  */
8482
8483             {
8484               tree sizes = get_pending_sizes ();
8485               tree tem;
8486
8487               for (tem = sizes;
8488                    tem != old_sizes;
8489                    tem = TREE_CHAIN (tem))
8490                 {
8491                   tree temv = TREE_VALUE (tem);
8492
8493                   if (sizes == tem)
8494                     sizes = temv;
8495                   else
8496                     sizes
8497                       = ffecom_2 (COMPOUND_EXPR,
8498                                   TREE_TYPE (sizes),
8499                                   temv,
8500                                   sizes);
8501                 }
8502
8503               if (sizes != tem)
8504                 {
8505                   sizes
8506                     = ffecom_3 (COND_EXPR,
8507                                 TREE_TYPE (sizes),
8508                                 ffecom_2 (NE_EXPR,
8509                                           integer_type_node,
8510                                           t,
8511                                           null_pointer_node),
8512                                 sizes,
8513                                 convert (TREE_TYPE (sizes),
8514                                          integer_zero_node));
8515                   sizes = ffecom_save_tree (sizes);
8516
8517                   sizes
8518                     = tree_cons (NULL_TREE, sizes, tem);
8519                 }
8520
8521               if (sizes)
8522                 put_pending_sizes (sizes);
8523             }
8524
8525 #else
8526 #if 0
8527             if (adjustable
8528                 && (ffesymbol_numentries (s)
8529                     != ffecom_num_entrypoints_ + 1))
8530               DECL_SOMETHING (t)
8531                 = ffecom_2 (NE_EXPR, integer_type_node,
8532                             t,
8533                             null_pointer_node);
8534 #else
8535 #if 0
8536             if (adjustable
8537                 && (ffesymbol_numentries (s)
8538                     != ffecom_num_entrypoints_ + 1))
8539               {
8540                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8541                 ffebad_here (0, ffesymbol_where_line (s),
8542                              ffesymbol_where_column (s));
8543                 ffebad_string (ffesymbol_text (s));
8544                 ffebad_finish ();
8545               }
8546 #endif
8547 #endif
8548 #endif
8549           }
8550           break;
8551
8552         case FFEINFO_whereCOMMON:
8553           {
8554             ffesymbol cs;
8555             ffeglobal cg;
8556             tree ct;
8557             ffestorag st = ffesymbol_storage (s);
8558             tree type;
8559             int yes;
8560
8561             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
8562             if (st != NULL)     /* Else not laid out. */
8563               {
8564                 ffecom_transform_common_ (cs);
8565                 st = ffesymbol_storage (s);
8566               }
8567
8568             yes = suspend_momentary ();
8569
8570             type = ffecom_type_localvar_ (s, bt, kt);
8571
8572             cg = ffesymbol_global (cs); /* The global COMMON info.  */
8573             if ((cg == NULL)
8574                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8575               ct = NULL_TREE;
8576             else
8577               ct = ffeglobal_hook (cg); /* The common area's tree.  */
8578
8579             if ((ct == NULL_TREE)
8580                 || (st == NULL)
8581                 || (type == error_mark_node))
8582               t = error_mark_node;
8583             else
8584               {
8585                 ffetargetOffset offset;
8586                 ffestorag cst;
8587
8588                 cst = ffestorag_parent (st);
8589                 assert (cst == ffesymbol_storage (cs));
8590
8591                 offset = ffestorag_modulo (cst)
8592                   + ffestorag_offset (st)
8593                   - ffestorag_offset (cst);
8594
8595                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8596
8597                 /* (t_type *) (((char *) &ct) + offset) */
8598
8599                 t = convert (string_type_node,  /* (char *) */
8600                              ffecom_1 (ADDR_EXPR,
8601                                        build_pointer_type (TREE_TYPE (ct)),
8602                                        ct));
8603                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8604                               t,
8605                               build_int_2 (offset, 0));
8606                 t = convert (build_pointer_type (type),
8607                              t);
8608
8609                 addr = TRUE;
8610               }
8611
8612             resume_momentary (yes);
8613           }
8614           break;
8615
8616         case FFEINFO_whereIMMEDIATE:
8617         case FFEINFO_whereGLOBAL:
8618         case FFEINFO_whereFLEETING:
8619         case FFEINFO_whereFLEETING_CADDR:
8620         case FFEINFO_whereFLEETING_IADDR:
8621         case FFEINFO_whereINTRINSIC:
8622         case FFEINFO_whereCONSTANT_SUBOBJECT:
8623         default:
8624           assert ("ENTITY where unheard of" == NULL);
8625           /* Fall through. */
8626         case FFEINFO_whereANY:
8627           t = error_mark_node;
8628           break;
8629         }
8630       break;
8631
8632     case FFEINFO_kindFUNCTION:
8633       switch (ffeinfo_where (ffesymbol_info (s)))
8634         {
8635         case FFEINFO_whereLOCAL:        /* Me. */
8636           assert (!ffecom_transform_only_dummies_);
8637           t = current_function_decl;
8638           break;
8639
8640         case FFEINFO_whereGLOBAL:
8641           assert (!ffecom_transform_only_dummies_);
8642
8643           if (((g = ffesymbol_global (s)) != NULL)
8644               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8645                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8646               && (ffeglobal_hook (g) != NULL_TREE)
8647               && ffe_is_globals ())
8648             {
8649               t = ffeglobal_hook (g);
8650               break;
8651             }
8652
8653           push_obstacks_nochange ();
8654           end_temporary_allocation ();
8655
8656           if (ffesymbol_is_f2c (s)
8657               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8658             t = ffecom_tree_fun_type[bt][kt];
8659           else
8660             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8661
8662           t = build_decl (FUNCTION_DECL,
8663                           ffecom_get_external_identifier_ (s),
8664                           t);
8665           DECL_EXTERNAL (t) = 1;
8666           TREE_PUBLIC (t) = 1;
8667
8668           t = start_decl (t, FALSE);
8669           finish_decl (t, NULL_TREE, FALSE);
8670
8671           if ((g != NULL)
8672               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8673                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8674             ffeglobal_set_hook (g, t);
8675
8676           resume_temporary_allocation ();
8677           pop_obstacks ();
8678
8679           break;
8680
8681         case FFEINFO_whereDUMMY:
8682           assert (ffecom_transform_only_dummies_);
8683
8684           if (ffesymbol_is_f2c (s)
8685               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8686             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8687           else
8688             t = build_pointer_type
8689               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8690
8691           t = build_decl (PARM_DECL,
8692                           ffecom_get_identifier_ (ffesymbol_text (s)),
8693                           t);
8694 #if BUILT_FOR_270
8695           DECL_ARTIFICIAL (t) = 1;
8696 #endif
8697           addr = TRUE;
8698           break;
8699
8700         case FFEINFO_whereCONSTANT:     /* Statement function. */
8701           assert (!ffecom_transform_only_dummies_);
8702           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8703           break;
8704
8705         case FFEINFO_whereINTRINSIC:
8706           assert (!ffecom_transform_only_dummies_);
8707           break;                /* Let actual references generate their
8708                                    decls. */
8709
8710         default:
8711           assert ("FUNCTION where unheard of" == NULL);
8712           /* Fall through. */
8713         case FFEINFO_whereANY:
8714           t = error_mark_node;
8715           break;
8716         }
8717       break;
8718
8719     case FFEINFO_kindSUBROUTINE:
8720       switch (ffeinfo_where (ffesymbol_info (s)))
8721         {
8722         case FFEINFO_whereLOCAL:        /* Me. */
8723           assert (!ffecom_transform_only_dummies_);
8724           t = current_function_decl;
8725           break;
8726
8727         case FFEINFO_whereGLOBAL:
8728           assert (!ffecom_transform_only_dummies_);
8729
8730           if (((g = ffesymbol_global (s)) != NULL)
8731               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8732                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8733               && (ffeglobal_hook (g) != NULL_TREE)
8734               && ffe_is_globals ())
8735             {
8736               t = ffeglobal_hook (g);
8737               break;
8738             }
8739
8740           push_obstacks_nochange ();
8741           end_temporary_allocation ();
8742
8743           t = build_decl (FUNCTION_DECL,
8744                           ffecom_get_external_identifier_ (s),
8745                           ffecom_tree_subr_type);
8746           DECL_EXTERNAL (t) = 1;
8747           TREE_PUBLIC (t) = 1;
8748
8749           t = start_decl (t, FALSE);
8750           finish_decl (t, NULL_TREE, FALSE);
8751
8752           if ((g != NULL)
8753               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8754                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8755             ffeglobal_set_hook (g, t);
8756
8757           resume_temporary_allocation ();
8758           pop_obstacks ();
8759
8760           break;
8761
8762         case FFEINFO_whereDUMMY:
8763           assert (ffecom_transform_only_dummies_);
8764
8765           t = build_decl (PARM_DECL,
8766                           ffecom_get_identifier_ (ffesymbol_text (s)),
8767                           ffecom_tree_ptr_to_subr_type);
8768 #if BUILT_FOR_270
8769           DECL_ARTIFICIAL (t) = 1;
8770 #endif
8771           addr = TRUE;
8772           break;
8773
8774         case FFEINFO_whereINTRINSIC:
8775           assert (!ffecom_transform_only_dummies_);
8776           break;                /* Let actual references generate their
8777                                    decls. */
8778
8779         default:
8780           assert ("SUBROUTINE where unheard of" == NULL);
8781           /* Fall through. */
8782         case FFEINFO_whereANY:
8783           t = error_mark_node;
8784           break;
8785         }
8786       break;
8787
8788     case FFEINFO_kindPROGRAM:
8789       switch (ffeinfo_where (ffesymbol_info (s)))
8790         {
8791         case FFEINFO_whereLOCAL:        /* Me. */
8792           assert (!ffecom_transform_only_dummies_);
8793           t = current_function_decl;
8794           break;
8795
8796         case FFEINFO_whereCOMMON:
8797         case FFEINFO_whereDUMMY:
8798         case FFEINFO_whereGLOBAL:
8799         case FFEINFO_whereRESULT:
8800         case FFEINFO_whereFLEETING:
8801         case FFEINFO_whereFLEETING_CADDR:
8802         case FFEINFO_whereFLEETING_IADDR:
8803         case FFEINFO_whereIMMEDIATE:
8804         case FFEINFO_whereINTRINSIC:
8805         case FFEINFO_whereCONSTANT:
8806         case FFEINFO_whereCONSTANT_SUBOBJECT:
8807         default:
8808           assert ("PROGRAM where unheard of" == NULL);
8809           /* Fall through. */
8810         case FFEINFO_whereANY:
8811           t = error_mark_node;
8812           break;
8813         }
8814       break;
8815
8816     case FFEINFO_kindBLOCKDATA:
8817       switch (ffeinfo_where (ffesymbol_info (s)))
8818         {
8819         case FFEINFO_whereLOCAL:        /* Me. */
8820           assert (!ffecom_transform_only_dummies_);
8821           t = current_function_decl;
8822           break;
8823
8824         case FFEINFO_whereGLOBAL:
8825           assert (!ffecom_transform_only_dummies_);
8826
8827           push_obstacks_nochange ();
8828           end_temporary_allocation ();
8829
8830           t = build_decl (FUNCTION_DECL,
8831                           ffecom_get_external_identifier_ (s),
8832                           ffecom_tree_blockdata_type);
8833           DECL_EXTERNAL (t) = 1;
8834           TREE_PUBLIC (t) = 1;
8835
8836           t = start_decl (t, FALSE);
8837           finish_decl (t, NULL_TREE, FALSE);
8838
8839           resume_temporary_allocation ();
8840           pop_obstacks ();
8841
8842           break;
8843
8844         case FFEINFO_whereCOMMON:
8845         case FFEINFO_whereDUMMY:
8846         case FFEINFO_whereRESULT:
8847         case FFEINFO_whereFLEETING:
8848         case FFEINFO_whereFLEETING_CADDR:
8849         case FFEINFO_whereFLEETING_IADDR:
8850         case FFEINFO_whereIMMEDIATE:
8851         case FFEINFO_whereINTRINSIC:
8852         case FFEINFO_whereCONSTANT:
8853         case FFEINFO_whereCONSTANT_SUBOBJECT:
8854         default:
8855           assert ("BLOCKDATA where unheard of" == NULL);
8856           /* Fall through. */
8857         case FFEINFO_whereANY:
8858           t = error_mark_node;
8859           break;
8860         }
8861       break;
8862
8863     case FFEINFO_kindCOMMON:
8864       switch (ffeinfo_where (ffesymbol_info (s)))
8865         {
8866         case FFEINFO_whereLOCAL:
8867           assert (!ffecom_transform_only_dummies_);
8868           ffecom_transform_common_ (s);
8869           break;
8870
8871         case FFEINFO_whereNONE:
8872         case FFEINFO_whereCOMMON:
8873         case FFEINFO_whereDUMMY:
8874         case FFEINFO_whereGLOBAL:
8875         case FFEINFO_whereRESULT:
8876         case FFEINFO_whereFLEETING:
8877         case FFEINFO_whereFLEETING_CADDR:
8878         case FFEINFO_whereFLEETING_IADDR:
8879         case FFEINFO_whereIMMEDIATE:
8880         case FFEINFO_whereINTRINSIC:
8881         case FFEINFO_whereCONSTANT:
8882         case FFEINFO_whereCONSTANT_SUBOBJECT:
8883         default:
8884           assert ("COMMON where unheard of" == NULL);
8885           /* Fall through. */
8886         case FFEINFO_whereANY:
8887           t = error_mark_node;
8888           break;
8889         }
8890       break;
8891
8892     case FFEINFO_kindCONSTRUCT:
8893       switch (ffeinfo_where (ffesymbol_info (s)))
8894         {
8895         case FFEINFO_whereLOCAL:
8896           assert (!ffecom_transform_only_dummies_);
8897           break;
8898
8899         case FFEINFO_whereNONE:
8900         case FFEINFO_whereCOMMON:
8901         case FFEINFO_whereDUMMY:
8902         case FFEINFO_whereGLOBAL:
8903         case FFEINFO_whereRESULT:
8904         case FFEINFO_whereFLEETING:
8905         case FFEINFO_whereFLEETING_CADDR:
8906         case FFEINFO_whereFLEETING_IADDR:
8907         case FFEINFO_whereIMMEDIATE:
8908         case FFEINFO_whereINTRINSIC:
8909         case FFEINFO_whereCONSTANT:
8910         case FFEINFO_whereCONSTANT_SUBOBJECT:
8911         default:
8912           assert ("CONSTRUCT where unheard of" == NULL);
8913           /* Fall through. */
8914         case FFEINFO_whereANY:
8915           t = error_mark_node;
8916           break;
8917         }
8918       break;
8919
8920     case FFEINFO_kindNAMELIST:
8921       switch (ffeinfo_where (ffesymbol_info (s)))
8922         {
8923         case FFEINFO_whereLOCAL:
8924           assert (!ffecom_transform_only_dummies_);
8925           t = ffecom_transform_namelist_ (s);
8926           break;
8927
8928         case FFEINFO_whereNONE:
8929         case FFEINFO_whereCOMMON:
8930         case FFEINFO_whereDUMMY:
8931         case FFEINFO_whereGLOBAL:
8932         case FFEINFO_whereRESULT:
8933         case FFEINFO_whereFLEETING:
8934         case FFEINFO_whereFLEETING_CADDR:
8935         case FFEINFO_whereFLEETING_IADDR:
8936         case FFEINFO_whereIMMEDIATE:
8937         case FFEINFO_whereINTRINSIC:
8938         case FFEINFO_whereCONSTANT:
8939         case FFEINFO_whereCONSTANT_SUBOBJECT:
8940         default:
8941           assert ("NAMELIST where unheard of" == NULL);
8942           /* Fall through. */
8943         case FFEINFO_whereANY:
8944           t = error_mark_node;
8945           break;
8946         }
8947       break;
8948
8949     default:
8950       assert ("kind unheard of" == NULL);
8951       /* Fall through. */
8952     case FFEINFO_kindANY:
8953       t = error_mark_node;
8954       break;
8955     }
8956
8957   ffesymbol_hook (s).decl_tree = t;
8958   ffesymbol_hook (s).length_tree = tlen;
8959   ffesymbol_hook (s).addr = addr;
8960
8961   lineno = old_lineno;
8962   input_filename = old_input_filename;
8963
8964   return s;
8965 }
8966
8967 #endif
8968 /* Transform into ASSIGNable symbol.
8969
8970    Symbol has already been transformed, but for whatever reason, the
8971    resulting decl_tree has been deemed not usable for an ASSIGN target.
8972    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8973    another local symbol of type void * and stuff that in the assign_tree
8974    argument.  The F77/F90 standards allow this implementation.  */
8975
8976 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8977 static ffesymbol
8978 ffecom_sym_transform_assign_ (ffesymbol s)
8979 {
8980   tree t;                       /* Transformed thingy. */
8981   int yes;
8982   int old_lineno = lineno;
8983   char *old_input_filename = input_filename;
8984
8985   if (ffesymbol_sfdummyparent (s) == NULL)
8986     {
8987       input_filename = ffesymbol_where_filename (s);
8988       lineno = ffesymbol_where_filelinenum (s);
8989     }
8990   else
8991     {
8992       ffesymbol sf = ffesymbol_sfdummyparent (s);
8993
8994       input_filename = ffesymbol_where_filename (sf);
8995       lineno = ffesymbol_where_filelinenum (sf);
8996     }
8997
8998   assert (!ffecom_transform_only_dummies_);
8999
9000   yes = suspend_momentary ();
9001
9002   t = build_decl (VAR_DECL,
9003                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
9004                                                    ffesymbol_text (s),
9005                                                    0),
9006                   TREE_TYPE (null_pointer_node));
9007
9008   switch (ffesymbol_where (s))
9009     {
9010     case FFEINFO_whereLOCAL:
9011       /* Unlike for regular vars, SAVE status is easy to determine for
9012          ASSIGNed vars, since there's no initialization, there's no
9013          effective storage association (so "SAVE J" does not apply to
9014          K even given "EQUIVALENCE (J,K)"), there's no size issue
9015          to worry about, etc.  */
9016       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
9017           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
9018           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
9019         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
9020       else
9021         TREE_STATIC (t) = 0;    /* No need to make static. */
9022       break;
9023
9024     case FFEINFO_whereCOMMON:
9025       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
9026       break;
9027
9028     case FFEINFO_whereDUMMY:
9029       /* Note that twinning a DUMMY means the caller won't see
9030          the ASSIGNed value.  But both F77 and F90 allow implementations
9031          to do this, i.e. disallow Fortran code that would try and
9032          take advantage of actually putting a label into a variable
9033          via a dummy argument (or any other storage association, for
9034          that matter).  */
9035       TREE_STATIC (t) = 0;
9036       break;
9037
9038     default:
9039       TREE_STATIC (t) = 0;
9040       break;
9041     }
9042
9043   t = start_decl (t, FALSE);
9044   finish_decl (t, NULL_TREE, FALSE);
9045
9046   resume_momentary (yes);
9047
9048   ffesymbol_hook (s).assign_tree = t;
9049
9050   lineno = old_lineno;
9051   input_filename = old_input_filename;
9052
9053   return s;
9054 }
9055
9056 #endif
9057 /* Implement COMMON area in back end.
9058
9059    Because COMMON-based variables can be referenced in the dimension
9060    expressions of dummy (adjustable) arrays, and because dummies
9061    (in the gcc back end) need to be put in the outer binding level
9062    of a function (which has two binding levels, the outer holding
9063    the dummies and the inner holding the other vars), special care
9064    must be taken to handle COMMON areas.
9065
9066    The current strategy is basically to always tell the back end about
9067    the COMMON area as a top-level external reference to just a block
9068    of storage of the master type of that area (e.g. integer, real,
9069    character, whatever -- not a structure).  As a distinct action,
9070    if initial values are provided, tell the back end about the area
9071    as a top-level non-external (initialized) area and remember not to
9072    allow further initialization or expansion of the area.  Meanwhile,
9073    if no initialization happens at all, tell the back end about
9074    the largest size we've seen declared so the space does get reserved.
9075    (This function doesn't handle all that stuff, but it does some
9076    of the important things.)
9077
9078    Meanwhile, for COMMON variables themselves, just keep creating
9079    references like *((float *) (&common_area + offset)) each time
9080    we reference the variable.  In other words, don't make a VAR_DECL
9081    or any kind of component reference (like we used to do before 0.4),
9082    though we might do that as well just for debugging purposes (and
9083    stuff the rtl with the appropriate offset expression).  */
9084
9085 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9086 static void
9087 ffecom_transform_common_ (ffesymbol s)
9088 {
9089   ffestorag st = ffesymbol_storage (s);
9090   ffeglobal g = ffesymbol_global (s);
9091   tree cbt;
9092   tree cbtype;
9093   tree init;
9094   bool is_init = ffestorag_is_init (st);
9095
9096   assert (st != NULL);
9097
9098   if ((g == NULL)
9099       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
9100     return;
9101
9102   /* First update the size of the area in global terms.  */
9103
9104   ffeglobal_size_common (s, ffestorag_size (st));
9105
9106   if (!ffeglobal_common_init (g))
9107     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
9108
9109   cbt = ffeglobal_hook (g);
9110
9111   /* If we already have declared this common block for a previous program
9112      unit, and either we already initialized it or we don't have new
9113      initialization for it, just return what we have without changing it.  */
9114
9115   if ((cbt != NULL_TREE)
9116       && (!is_init
9117           || !DECL_EXTERNAL (cbt)))
9118     return;
9119
9120   /* Process inits.  */
9121
9122   if (is_init)
9123     {
9124       if (ffestorag_init (st) != NULL)
9125         {
9126           init = ffecom_expr (ffestorag_init (st));
9127           if (init == error_mark_node)
9128             {                   /* Hopefully the back end complained! */
9129               init = NULL_TREE;
9130               if (cbt != NULL_TREE)
9131                 return;
9132             }
9133         }
9134       else
9135         init = error_mark_node;
9136     }
9137   else
9138     init = NULL_TREE;
9139
9140   push_obstacks_nochange ();
9141   end_temporary_allocation ();
9142
9143   /* cbtype must be permanently allocated!  */
9144
9145   if (init)
9146     cbtype = build_array_type (char_type_node,
9147                                build_range_type (integer_type_node,
9148                                                  integer_one_node,
9149                                                  build_int_2
9150                                                  (ffeglobal_common_size (g),
9151                                                   0)));
9152   else
9153     cbtype = build_array_type (char_type_node, NULL_TREE);
9154
9155   if (cbt == NULL_TREE)
9156     {
9157       cbt
9158         = build_decl (VAR_DECL,
9159                       ffecom_get_external_identifier_ (s),
9160                       cbtype);
9161       TREE_STATIC (cbt) = 1;
9162       TREE_PUBLIC (cbt) = 1;
9163     }
9164   else
9165     {
9166       assert (is_init);
9167       TREE_TYPE (cbt) = cbtype;
9168     }
9169   DECL_EXTERNAL (cbt) = init ? 0 : 1;
9170   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
9171
9172   cbt = start_decl (cbt, TRUE);
9173   if (ffeglobal_hook (g) != NULL)
9174     assert (cbt == ffeglobal_hook (g));
9175
9176   assert (!init || !DECL_EXTERNAL (cbt));
9177
9178   /* Make sure that any type can live in COMMON and be referenced
9179      without getting a bus error.  We could pick the most restrictive
9180      alignment of all entities actually placed in the COMMON, but
9181      this seems easy enough.  */
9182
9183   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
9184
9185   if (is_init && (ffestorag_init (st) == NULL))
9186     init = ffecom_init_zero_ (cbt);
9187
9188   finish_decl (cbt, init, TRUE);
9189
9190   if (is_init)
9191     ffestorag_set_init (st, ffebld_new_any ());
9192
9193   if (init)
9194     {
9195       tree size_tree;
9196
9197       assert (DECL_SIZE (cbt) != NULL_TREE);
9198       assert (TREE_CODE (DECL_SIZE (cbt)) == INTEGER_CST);
9199       size_tree = size_binop (CEIL_DIV_EXPR,
9200                               DECL_SIZE (cbt),
9201                               size_int (BITS_PER_UNIT));
9202       assert (TREE_INT_CST_HIGH (size_tree) == 0);
9203       assert (TREE_INT_CST_LOW (size_tree) == ffeglobal_common_size (g));
9204     }
9205
9206   ffeglobal_set_hook (g, cbt);
9207
9208   ffestorag_set_hook (st, cbt);
9209
9210   resume_temporary_allocation ();
9211   pop_obstacks ();
9212 }
9213
9214 #endif
9215 /* Make master area for local EQUIVALENCE.  */
9216
9217 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9218 static void
9219 ffecom_transform_equiv_ (ffestorag eqst)
9220 {
9221   tree eqt;
9222   tree eqtype;
9223   tree init;
9224   tree high;
9225   bool is_init = ffestorag_is_init (eqst);
9226   int yes;
9227
9228   assert (eqst != NULL);
9229
9230   eqt = ffestorag_hook (eqst);
9231
9232   if (eqt != NULL_TREE)
9233     return;
9234
9235   /* Process inits.  */
9236
9237   if (is_init)
9238     {
9239       if (ffestorag_init (eqst) != NULL)
9240         {
9241           init = ffecom_expr (ffestorag_init (eqst));
9242           if (init == error_mark_node)
9243             init = NULL_TREE;   /* Hopefully the back end complained! */
9244         }
9245       else
9246         init = error_mark_node;
9247     }
9248   else if (ffe_is_init_local_zero ())
9249     init = error_mark_node;
9250   else
9251     init = NULL_TREE;
9252
9253   ffecom_member_namelisted_ = FALSE;
9254   ffestorag_drive (ffestorag_list_equivs (eqst),
9255                    &ffecom_member_phase1_,
9256                    eqst);
9257
9258   yes = suspend_momentary ();
9259
9260   high = build_int_2 (ffestorag_size (eqst), 0);
9261   TREE_TYPE (high) = ffecom_integer_type_node;
9262
9263   eqtype = build_array_type (char_type_node,
9264                              build_range_type (ffecom_integer_type_node,
9265                                                ffecom_integer_one_node,
9266                                                high));
9267
9268   eqt = build_decl (VAR_DECL,
9269                     ffecom_get_invented_identifier ("__g77_equiv_%s",
9270                                                     ffesymbol_text
9271                                                     (ffestorag_symbol
9272                                                      (eqst)),
9273                                                     0),
9274                     eqtype);
9275   DECL_EXTERNAL (eqt) = 0;
9276   if (is_init
9277       || ffecom_member_namelisted_
9278 #ifdef FFECOM_sizeMAXSTACKITEM
9279       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
9280 #endif
9281       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
9282           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
9283           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
9284     TREE_STATIC (eqt) = 1;
9285   else
9286     TREE_STATIC (eqt) = 0;
9287   TREE_PUBLIC (eqt) = 0;
9288   DECL_CONTEXT (eqt) = current_function_decl;
9289   if (init)
9290     DECL_INITIAL (eqt) = error_mark_node;
9291   else
9292     DECL_INITIAL (eqt) = NULL_TREE;
9293
9294   eqt = start_decl (eqt, FALSE);
9295
9296   /* Make sure this shows up as a debug symbol, which is not normally
9297      the case for invented identifiers.  */
9298
9299   DECL_IGNORED_P (eqt) = 0;
9300
9301   /* Make sure that any type can live in EQUIVALENCE and be referenced
9302      without getting a bus error.  We could pick the most restrictive
9303      alignment of all entities actually placed in the EQUIVALENCE, but
9304      this seems easy enough.  */
9305
9306   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
9307
9308   if ((!is_init && ffe_is_init_local_zero ())
9309       || (is_init && (ffestorag_init (eqst) == NULL)))
9310     init = ffecom_init_zero_ (eqt);
9311
9312   finish_decl (eqt, init, FALSE);
9313
9314   if (is_init)
9315     ffestorag_set_init (eqst, ffebld_new_any ());
9316
9317   {
9318     tree size_tree;
9319
9320     size_tree = size_binop (CEIL_DIV_EXPR,
9321                             DECL_SIZE (eqt),
9322                             size_int (BITS_PER_UNIT));
9323     assert (TREE_INT_CST_HIGH (size_tree) == 0);
9324     assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (eqst));
9325   }
9326
9327   ffestorag_set_hook (eqst, eqt);
9328
9329 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
9330   ffestorag_drive (ffestorag_list_equivs (eqst),
9331                    &ffecom_member_phase2_,
9332                    eqst);
9333 #endif
9334
9335   resume_momentary (yes);
9336 }
9337
9338 #endif
9339 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
9340
9341 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9342 static tree
9343 ffecom_transform_namelist_ (ffesymbol s)
9344 {
9345   tree nmlt;
9346   tree nmltype = ffecom_type_namelist_ ();
9347   tree nmlinits;
9348   tree nameinit;
9349   tree varsinit;
9350   tree nvarsinit;
9351   tree field;
9352   tree high;
9353   int yes;
9354   int i;
9355   static int mynumber = 0;
9356
9357   yes = suspend_momentary ();
9358
9359   nmlt = build_decl (VAR_DECL,
9360                      ffecom_get_invented_identifier ("__g77_namelist_%d",
9361                                                      NULL, mynumber++),
9362                      nmltype);
9363   TREE_STATIC (nmlt) = 1;
9364   DECL_INITIAL (nmlt) = error_mark_node;
9365
9366   nmlt = start_decl (nmlt, FALSE);
9367
9368   /* Process inits.  */
9369
9370   i = strlen (ffesymbol_text (s));
9371
9372   high = build_int_2 (i, 0);
9373   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
9374
9375   nameinit = ffecom_build_f2c_string_ (i + 1,
9376                                        ffesymbol_text (s));
9377   TREE_TYPE (nameinit)
9378     = build_type_variant
9379     (build_array_type
9380      (char_type_node,
9381       build_range_type (ffecom_f2c_ftnlen_type_node,
9382                         ffecom_f2c_ftnlen_one_node,
9383                         high)),
9384      1, 0);
9385   TREE_CONSTANT (nameinit) = 1;
9386   TREE_STATIC (nameinit) = 1;
9387   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
9388                        nameinit);
9389
9390   varsinit = ffecom_vardesc_array_ (s);
9391   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
9392                        varsinit);
9393   TREE_CONSTANT (varsinit) = 1;
9394   TREE_STATIC (varsinit) = 1;
9395
9396   {
9397     ffebld b;
9398
9399     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
9400       ++i;
9401   }
9402   nvarsinit = build_int_2 (i, 0);
9403   TREE_TYPE (nvarsinit) = integer_type_node;
9404   TREE_CONSTANT (nvarsinit) = 1;
9405   TREE_STATIC (nvarsinit) = 1;
9406
9407   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
9408   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
9409                                            varsinit);
9410   TREE_CHAIN (TREE_CHAIN (nmlinits))
9411     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
9412
9413   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
9414   TREE_CONSTANT (nmlinits) = 1;
9415   TREE_STATIC (nmlinits) = 1;
9416
9417   finish_decl (nmlt, nmlinits, FALSE);
9418
9419   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
9420
9421   resume_momentary (yes);
9422
9423   return nmlt;
9424 }
9425
9426 #endif
9427
9428 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
9429    analyzed on the assumption it is calculating a pointer to be
9430    indirected through.  It must return the proper decl and offset,
9431    taking into account different units of measurements for offsets.  */
9432
9433 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9434 static void
9435 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
9436                            tree t)
9437 {
9438   switch (TREE_CODE (t))
9439     {
9440     case NOP_EXPR:
9441     case CONVERT_EXPR:
9442     case NON_LVALUE_EXPR:
9443       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9444       break;
9445
9446     case PLUS_EXPR:
9447       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9448       if ((*decl == NULL_TREE)
9449           || (*decl == error_mark_node))
9450         break;
9451
9452       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
9453         {
9454           /* An offset into COMMON.  */
9455           *offset = size_binop (PLUS_EXPR,
9456                                 *offset,
9457                                 TREE_OPERAND (t, 1));
9458           /* Convert offset (presumably in bytes) into canonical units
9459              (presumably bits).  */
9460           *offset = size_binop (MULT_EXPR,
9461                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))),
9462                                 *offset);
9463           break;
9464         }
9465       /* Not a COMMON reference, so an unrecognized pattern.  */
9466       *decl = error_mark_node;
9467       break;
9468
9469     case PARM_DECL:
9470       *decl = t;
9471       *offset =  bitsize_int (0L, 0L);
9472       break;
9473
9474     case ADDR_EXPR:
9475       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
9476         {
9477           /* A reference to COMMON.  */
9478           *decl = TREE_OPERAND (t, 0);
9479           *offset =  bitsize_int (0L, 0L);
9480           break;
9481         }
9482       /* Fall through.  */
9483     default:
9484       /* Not a COMMON reference, so an unrecognized pattern.  */
9485       *decl = error_mark_node;
9486       break;
9487     }
9488 }
9489 #endif
9490
9491 /* Given a tree that is possibly intended for use as an lvalue, return
9492    information representing a canonical view of that tree as a decl, an
9493    offset into that decl, and a size for the lvalue.
9494
9495    If there's no applicable decl, NULL_TREE is returned for the decl,
9496    and the other fields are left undefined.
9497
9498    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9499    is returned for the decl, and the other fields are left undefined.
9500
9501    Otherwise, the decl returned currently is either a VAR_DECL or a
9502    PARM_DECL.
9503
9504    The offset returned is always valid, but of course not necessarily
9505    a constant, and not necessarily converted into the appropriate
9506    type, leaving that up to the caller (so as to avoid that overhead
9507    if the decls being looked at are different anyway).
9508
9509    If the size cannot be determined (e.g. an adjustable array),
9510    an ERROR_MARK node is returned for the size.  Otherwise, the
9511    size returned is valid, not necessarily a constant, and not
9512    necessarily converted into the appropriate type as with the
9513    offset.
9514
9515    Note that the offset and size expressions are expressed in the
9516    base storage units (usually bits) rather than in the units of
9517    the type of the decl, because two decls with different types
9518    might overlap but with apparently non-overlapping array offsets,
9519    whereas converting the array offsets to consistant offsets will
9520    reveal the overlap.  */
9521
9522 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9523 static void
9524 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9525                            tree *size, tree t)
9526 {
9527   /* The default path is to report a nonexistant decl.  */
9528   *decl = NULL_TREE;
9529
9530   if (t == NULL_TREE)
9531     return;
9532
9533   switch (TREE_CODE (t))
9534     {
9535     case ERROR_MARK:
9536     case IDENTIFIER_NODE:
9537     case INTEGER_CST:
9538     case REAL_CST:
9539     case COMPLEX_CST:
9540     case STRING_CST:
9541     case CONST_DECL:
9542     case PLUS_EXPR:
9543     case MINUS_EXPR:
9544     case MULT_EXPR:
9545     case TRUNC_DIV_EXPR:
9546     case CEIL_DIV_EXPR:
9547     case FLOOR_DIV_EXPR:
9548     case ROUND_DIV_EXPR:
9549     case TRUNC_MOD_EXPR:
9550     case CEIL_MOD_EXPR:
9551     case FLOOR_MOD_EXPR:
9552     case ROUND_MOD_EXPR:
9553     case RDIV_EXPR:
9554     case EXACT_DIV_EXPR:
9555     case FIX_TRUNC_EXPR:
9556     case FIX_CEIL_EXPR:
9557     case FIX_FLOOR_EXPR:
9558     case FIX_ROUND_EXPR:
9559     case FLOAT_EXPR:
9560     case EXPON_EXPR:
9561     case NEGATE_EXPR:
9562     case MIN_EXPR:
9563     case MAX_EXPR:
9564     case ABS_EXPR:
9565     case FFS_EXPR:
9566     case LSHIFT_EXPR:
9567     case RSHIFT_EXPR:
9568     case LROTATE_EXPR:
9569     case RROTATE_EXPR:
9570     case BIT_IOR_EXPR:
9571     case BIT_XOR_EXPR:
9572     case BIT_AND_EXPR:
9573     case BIT_ANDTC_EXPR:
9574     case BIT_NOT_EXPR:
9575     case TRUTH_ANDIF_EXPR:
9576     case TRUTH_ORIF_EXPR:
9577     case TRUTH_AND_EXPR:
9578     case TRUTH_OR_EXPR:
9579     case TRUTH_XOR_EXPR:
9580     case TRUTH_NOT_EXPR:
9581     case LT_EXPR:
9582     case LE_EXPR:
9583     case GT_EXPR:
9584     case GE_EXPR:
9585     case EQ_EXPR:
9586     case NE_EXPR:
9587     case COMPLEX_EXPR:
9588     case CONJ_EXPR:
9589     case REALPART_EXPR:
9590     case IMAGPART_EXPR:
9591     case LABEL_EXPR:
9592     case COMPONENT_REF:
9593     case COMPOUND_EXPR:
9594     case ADDR_EXPR:
9595       return;
9596
9597     case VAR_DECL:
9598     case PARM_DECL:
9599       *decl = t;
9600       *offset = bitsize_int (0L, 0L);
9601       *size = TYPE_SIZE (TREE_TYPE (t));
9602       return;
9603
9604     case ARRAY_REF:
9605       {
9606         tree array = TREE_OPERAND (t, 0);
9607         tree element = TREE_OPERAND (t, 1);
9608         tree init_offset;
9609
9610         if ((array == NULL_TREE)
9611             || (element == NULL_TREE))
9612           {
9613             *decl = error_mark_node;
9614             return;
9615           }
9616
9617         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9618                                    array);
9619         if ((*decl == NULL_TREE)
9620             || (*decl == error_mark_node))
9621           return;
9622
9623         *offset = size_binop (MULT_EXPR,
9624                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))),
9625                               size_binop (MINUS_EXPR,
9626                                           element,
9627                                           TYPE_MIN_VALUE
9628                                           (TYPE_DOMAIN
9629                                            (TREE_TYPE (array)))));
9630
9631         *offset = size_binop (PLUS_EXPR,
9632                               init_offset,
9633                               *offset);
9634
9635         *size = TYPE_SIZE (TREE_TYPE (t));
9636         return;
9637       }
9638
9639     case INDIRECT_REF:
9640
9641       /* Most of this code is to handle references to COMMON.  And so
9642          far that is useful only for calling library functions, since
9643          external (user) functions might reference common areas.  But
9644          even calling an external function, it's worthwhile to decode
9645          COMMON references because if not storing into COMMON, we don't
9646          want COMMON-based arguments to gratuitously force use of a
9647          temporary.  */
9648
9649       *size = TYPE_SIZE (TREE_TYPE (t));
9650
9651       ffecom_tree_canonize_ptr_ (decl, offset,
9652                                  TREE_OPERAND (t, 0));
9653
9654       return;
9655
9656     case CONVERT_EXPR:
9657     case NOP_EXPR:
9658     case MODIFY_EXPR:
9659     case NON_LVALUE_EXPR:
9660     case RESULT_DECL:
9661     case FIELD_DECL:
9662     case COND_EXPR:             /* More cases than we can handle. */
9663     case SAVE_EXPR:
9664     case REFERENCE_EXPR:
9665     case PREDECREMENT_EXPR:
9666     case PREINCREMENT_EXPR:
9667     case POSTDECREMENT_EXPR:
9668     case POSTINCREMENT_EXPR:
9669     case CALL_EXPR:
9670     default:
9671       *decl = error_mark_node;
9672       return;
9673     }
9674 }
9675 #endif
9676
9677 /* Do divide operation appropriate to type of operands.  */
9678
9679 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9680 static tree
9681 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9682                      tree dest_tree, ffebld dest, bool *dest_used)
9683 {
9684   if ((left == error_mark_node)
9685       || (right == error_mark_node))
9686     return error_mark_node;
9687
9688   switch (TREE_CODE (tree_type))
9689     {
9690     case INTEGER_TYPE:
9691       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9692                        left,
9693                        right);
9694
9695     case COMPLEX_TYPE:
9696       {
9697         ffecomGfrt ix;
9698
9699         if (TREE_TYPE (tree_type)
9700             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9701           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9702         else
9703           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9704
9705         left = ffecom_1 (ADDR_EXPR,
9706                          build_pointer_type (TREE_TYPE (left)),
9707                          left);
9708         left = build_tree_list (NULL_TREE, left);
9709         right = ffecom_1 (ADDR_EXPR,
9710                           build_pointer_type (TREE_TYPE (right)),
9711                           right);
9712         right = build_tree_list (NULL_TREE, right);
9713         TREE_CHAIN (left) = right;
9714
9715         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9716                              ffecom_gfrt_kindtype (ix),
9717                              ffe_is_f2c_library (),
9718                              tree_type,
9719                              left,
9720                              dest_tree, dest, dest_used,
9721                              NULL_TREE, TRUE);
9722       }
9723       break;
9724
9725     case RECORD_TYPE:
9726       {
9727         ffecomGfrt ix;
9728
9729         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9730             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9731           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9732         else
9733           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9734
9735         left = ffecom_1 (ADDR_EXPR,
9736                          build_pointer_type (TREE_TYPE (left)),
9737                          left);
9738         left = build_tree_list (NULL_TREE, left);
9739         right = ffecom_1 (ADDR_EXPR,
9740                           build_pointer_type (TREE_TYPE (right)),
9741                           right);
9742         right = build_tree_list (NULL_TREE, right);
9743         TREE_CHAIN (left) = right;
9744
9745         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9746                              ffecom_gfrt_kindtype (ix),
9747                              ffe_is_f2c_library (),
9748                              tree_type,
9749                              left,
9750                              dest_tree, dest, dest_used,
9751                              NULL_TREE, TRUE);
9752       }
9753       break;
9754
9755     default:
9756       return ffecom_2 (RDIV_EXPR, tree_type,
9757                        left,
9758                        right);
9759     }
9760 }
9761
9762 #endif
9763 /* ffecom_type_localvar_ -- Build type info for non-dummy variable
9764
9765    tree type;
9766    ffesymbol s;  // the variable's symbol
9767    ffeinfoBasictype bt;  // it's basictype
9768    ffeinfoKindtype kt; // it's kindtype
9769
9770    type = ffecom_type_localvar_(s,bt,kt);
9771
9772    Handles static arrays, CHARACTER type, etc.  */
9773
9774 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9775 static tree
9776 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9777                        ffeinfoKindtype kt)
9778 {
9779   tree type;
9780   ffebld dl;
9781   ffebld dim;
9782   tree lowt;
9783   tree hight;
9784
9785   type = ffecom_tree_type[bt][kt];
9786   if (bt == FFEINFO_basictypeCHARACTER)
9787     {
9788       hight = build_int_2 (ffesymbol_size (s), 0);
9789       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9790
9791       type
9792         = build_array_type
9793           (type,
9794            build_range_type (ffecom_f2c_ftnlen_type_node,
9795                              ffecom_f2c_ftnlen_one_node,
9796                              hight));
9797       type = ffecom_check_size_overflow_ (s, type, FALSE);
9798     }
9799
9800   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9801     {
9802       if (type == error_mark_node)
9803         break;
9804
9805       dim = ffebld_head (dl);
9806       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9807
9808       if (ffebld_left (dim) == NULL)
9809         lowt = integer_one_node;
9810       else
9811         lowt = ffecom_expr (ffebld_left (dim));
9812
9813       if (TREE_CODE (lowt) != INTEGER_CST)
9814         lowt = variable_size (lowt);
9815
9816       assert (ffebld_right (dim) != NULL);
9817       hight = ffecom_expr (ffebld_right (dim));
9818
9819       if (TREE_CODE (hight) != INTEGER_CST)
9820         hight = variable_size (hight);
9821
9822       type = build_array_type (type,
9823                                build_range_type (ffecom_integer_type_node,
9824                                                  lowt, hight));
9825       type = ffecom_check_size_overflow_ (s, type, FALSE);
9826     }
9827
9828   return type;
9829 }
9830
9831 #endif
9832 /* Build Namelist type.  */
9833
9834 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9835 static tree
9836 ffecom_type_namelist_ ()
9837 {
9838   static tree type = NULL_TREE;
9839
9840   if (type == NULL_TREE)
9841     {
9842       static tree namefield, varsfield, nvarsfield;
9843       tree vardesctype;
9844
9845       vardesctype = ffecom_type_vardesc_ ();
9846
9847       push_obstacks_nochange ();
9848       end_temporary_allocation ();
9849
9850       type = make_node (RECORD_TYPE);
9851
9852       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9853
9854       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9855                                      string_type_node);
9856       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9857       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9858                                       integer_type_node);
9859
9860       TYPE_FIELDS (type) = namefield;
9861       layout_type (type);
9862
9863       resume_temporary_allocation ();
9864       pop_obstacks ();
9865     }
9866
9867   return type;
9868 }
9869
9870 #endif
9871
9872 /* Make a copy of a type, assuming caller has switched to the permanent
9873    obstacks and that the type is for an aggregate (array) initializer.  */
9874
9875 #if FFECOM_targetCURRENT == FFECOM_targetGCC && 0       /* Not used now. */
9876 static tree
9877 ffecom_type_permanent_copy_ (tree t)
9878 {
9879   tree domain;
9880   tree max;
9881
9882   assert (TREE_TYPE (t) != NULL_TREE);
9883
9884   domain = TYPE_DOMAIN (t);
9885
9886   assert (TREE_CODE (t) == ARRAY_TYPE);
9887   assert (TREE_PERMANENT (TREE_TYPE (t)));
9888   assert (TREE_PERMANENT (TREE_TYPE (domain)));
9889   assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain)));
9890
9891   max = TYPE_MAX_VALUE (domain);
9892   if (!TREE_PERMANENT (max))
9893     {
9894       assert (TREE_CODE (max) == INTEGER_CST);
9895
9896       max = build_int_2 (TREE_INT_CST_LOW (max), TREE_INT_CST_HIGH (max));
9897       TREE_TYPE (max) = TREE_TYPE (TYPE_MIN_VALUE (domain));
9898     }
9899
9900   return build_array_type (TREE_TYPE (t),
9901                            build_range_type (TREE_TYPE (domain),
9902                                              TYPE_MIN_VALUE (domain),
9903                                              max));
9904 }
9905 #endif
9906
9907 /* Build Vardesc type.  */
9908
9909 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9910 static tree
9911 ffecom_type_vardesc_ ()
9912 {
9913   static tree type = NULL_TREE;
9914   static tree namefield, addrfield, dimsfield, typefield;
9915
9916   if (type == NULL_TREE)
9917     {
9918       push_obstacks_nochange ();
9919       end_temporary_allocation ();
9920
9921       type = make_node (RECORD_TYPE);
9922
9923       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9924                                      string_type_node);
9925       addrfield = ffecom_decl_field (type, namefield, "addr",
9926                                      string_type_node);
9927       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9928                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9929       typefield = ffecom_decl_field (type, dimsfield, "type",
9930                                      integer_type_node);
9931
9932       TYPE_FIELDS (type) = namefield;
9933       layout_type (type);
9934
9935       resume_temporary_allocation ();
9936       pop_obstacks ();
9937     }
9938
9939   return type;
9940 }
9941
9942 #endif
9943
9944 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9945 static tree
9946 ffecom_vardesc_ (ffebld expr)
9947 {
9948   ffesymbol s;
9949
9950   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9951   s = ffebld_symter (expr);
9952
9953   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9954     {
9955       int i;
9956       tree vardesctype = ffecom_type_vardesc_ ();
9957       tree var;
9958       tree nameinit;
9959       tree dimsinit;
9960       tree addrinit;
9961       tree typeinit;
9962       tree field;
9963       tree varinits;
9964       int yes;
9965       static int mynumber = 0;
9966
9967       yes = suspend_momentary ();
9968
9969       var = build_decl (VAR_DECL,
9970                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9971                                                         NULL, mynumber++),
9972                         vardesctype);
9973       TREE_STATIC (var) = 1;
9974       DECL_INITIAL (var) = error_mark_node;
9975
9976       var = start_decl (var, FALSE);
9977
9978       /* Process inits.  */
9979
9980       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9981                                            + 1,
9982                                            ffesymbol_text (s));
9983       TREE_TYPE (nameinit)
9984         = build_type_variant
9985         (build_array_type
9986          (char_type_node,
9987           build_range_type (integer_type_node,
9988                             integer_one_node,
9989                             build_int_2 (i, 0))),
9990          1, 0);
9991       TREE_CONSTANT (nameinit) = 1;
9992       TREE_STATIC (nameinit) = 1;
9993       nameinit = ffecom_1 (ADDR_EXPR,
9994                            build_pointer_type (TREE_TYPE (nameinit)),
9995                            nameinit);
9996
9997       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9998
9999       dimsinit = ffecom_vardesc_dims_ (s);
10000
10001       if (typeinit == NULL_TREE)
10002         {
10003           ffeinfoBasictype bt = ffesymbol_basictype (s);
10004           ffeinfoKindtype kt = ffesymbol_kindtype (s);
10005           int tc = ffecom_f2c_typecode (bt, kt);
10006
10007           assert (tc != -1);
10008           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
10009         }
10010       else
10011         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
10012
10013       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
10014                                   nameinit);
10015       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
10016                                                addrinit);
10017       TREE_CHAIN (TREE_CHAIN (varinits))
10018         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
10019       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
10020         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
10021
10022       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
10023       TREE_CONSTANT (varinits) = 1;
10024       TREE_STATIC (varinits) = 1;
10025
10026       finish_decl (var, varinits, FALSE);
10027
10028       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
10029
10030       resume_momentary (yes);
10031
10032       ffesymbol_hook (s).vardesc_tree = var;
10033     }
10034
10035   return ffesymbol_hook (s).vardesc_tree;
10036 }
10037
10038 #endif
10039 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10040 static tree
10041 ffecom_vardesc_array_ (ffesymbol s)
10042 {
10043   ffebld b;
10044   tree list;
10045   tree item = NULL_TREE;
10046   tree var;
10047   int i;
10048   int yes;
10049   static int mynumber = 0;
10050
10051   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
10052        b != NULL;
10053        b = ffebld_trail (b), ++i)
10054     {
10055       tree t;
10056
10057       t = ffecom_vardesc_ (ffebld_head (b));
10058
10059       if (list == NULL_TREE)
10060         list = item = build_tree_list (NULL_TREE, t);
10061       else
10062         {
10063           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
10064           item = TREE_CHAIN (item);
10065         }
10066     }
10067
10068   yes = suspend_momentary ();
10069
10070   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
10071                            build_range_type (integer_type_node,
10072                                              integer_one_node,
10073                                              build_int_2 (i, 0)));
10074   list = build (CONSTRUCTOR, item, NULL_TREE, list);
10075   TREE_CONSTANT (list) = 1;
10076   TREE_STATIC (list) = 1;
10077
10078   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL,
10079                                         mynumber++);
10080   var = build_decl (VAR_DECL, var, item);
10081   TREE_STATIC (var) = 1;
10082   DECL_INITIAL (var) = error_mark_node;
10083   var = start_decl (var, FALSE);
10084   finish_decl (var, list, FALSE);
10085
10086   resume_momentary (yes);
10087
10088   return var;
10089 }
10090
10091 #endif
10092 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10093 static tree
10094 ffecom_vardesc_dims_ (ffesymbol s)
10095 {
10096   if (ffesymbol_dims (s) == NULL)
10097     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
10098                     integer_zero_node);
10099
10100   {
10101     ffebld b;
10102     ffebld e;
10103     tree list;
10104     tree backlist;
10105     tree item = NULL_TREE;
10106     tree var;
10107     int yes;
10108     tree numdim;
10109     tree numelem;
10110     tree baseoff = NULL_TREE;
10111     static int mynumber = 0;
10112
10113     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
10114     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
10115
10116     numelem = ffecom_expr (ffesymbol_arraysize (s));
10117     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
10118
10119     list = NULL_TREE;
10120     backlist = NULL_TREE;
10121     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
10122          b != NULL;
10123          b = ffebld_trail (b), e = ffebld_trail (e))
10124       {
10125         tree t;
10126         tree low;
10127         tree back;
10128
10129         if (ffebld_trail (b) == NULL)
10130           t = NULL_TREE;
10131         else
10132           {
10133             t = convert (ffecom_f2c_ftnlen_type_node,
10134                          ffecom_expr (ffebld_head (e)));
10135
10136             if (list == NULL_TREE)
10137               list = item = build_tree_list (NULL_TREE, t);
10138             else
10139               {
10140                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
10141                 item = TREE_CHAIN (item);
10142               }
10143           }
10144
10145         if (ffebld_left (ffebld_head (b)) == NULL)
10146           low = ffecom_integer_one_node;
10147         else
10148           low = ffecom_expr (ffebld_left (ffebld_head (b)));
10149         low = convert (ffecom_f2c_ftnlen_type_node, low);
10150
10151         back = build_tree_list (low, t);
10152         TREE_CHAIN (back) = backlist;
10153         backlist = back;
10154       }
10155
10156     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
10157       {
10158         if (TREE_VALUE (item) == NULL_TREE)
10159           baseoff = TREE_PURPOSE (item);
10160         else
10161           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10162                               TREE_PURPOSE (item),
10163                               ffecom_2 (MULT_EXPR,
10164                                         ffecom_f2c_ftnlen_type_node,
10165                                         TREE_VALUE (item),
10166                                         baseoff));
10167       }
10168
10169     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
10170
10171     baseoff = build_tree_list (NULL_TREE, baseoff);
10172     TREE_CHAIN (baseoff) = list;
10173
10174     numelem = build_tree_list (NULL_TREE, numelem);
10175     TREE_CHAIN (numelem) = baseoff;
10176
10177     numdim = build_tree_list (NULL_TREE, numdim);
10178     TREE_CHAIN (numdim) = numelem;
10179
10180     yes = suspend_momentary ();
10181
10182     item = build_array_type (ffecom_f2c_ftnlen_type_node,
10183                              build_range_type (integer_type_node,
10184                                                integer_zero_node,
10185                                                build_int_2
10186                                                ((int) ffesymbol_rank (s)
10187                                                 + 2, 0)));
10188     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
10189     TREE_CONSTANT (list) = 1;
10190     TREE_STATIC (list) = 1;
10191
10192     var = ffecom_get_invented_identifier ("__g77_dims_%d", NULL,
10193                                           mynumber++);
10194     var = build_decl (VAR_DECL, var, item);
10195     TREE_STATIC (var) = 1;
10196     DECL_INITIAL (var) = error_mark_node;
10197     var = start_decl (var, FALSE);
10198     finish_decl (var, list, FALSE);
10199
10200     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
10201
10202     resume_momentary (yes);
10203
10204     return var;
10205   }
10206 }
10207
10208 #endif
10209 /* Essentially does a "fold (build1 (code, type, node))" while checking
10210    for certain housekeeping things.
10211
10212    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
10213    ffecom_1_fn instead.  */
10214
10215 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10216 tree
10217 ffecom_1 (enum tree_code code, tree type, tree node)
10218 {
10219   tree item;
10220
10221   if ((node == error_mark_node)
10222       || (type == error_mark_node))
10223     return error_mark_node;
10224
10225   if (code == ADDR_EXPR)
10226     {
10227       if (!mark_addressable (node))
10228         assert ("can't mark_addressable this node!" == NULL);
10229     }
10230
10231   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
10232     {
10233       tree realtype;
10234
10235     case REALPART_EXPR:
10236       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
10237       break;
10238
10239     case IMAGPART_EXPR:
10240       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
10241       break;
10242
10243
10244     case NEGATE_EXPR:
10245       if (TREE_CODE (type) != RECORD_TYPE)
10246         {
10247           item = build1 (code, type, node);
10248           break;
10249         }
10250       node = ffecom_stabilize_aggregate_ (node);
10251       realtype = TREE_TYPE (TYPE_FIELDS (type));
10252       item =
10253         ffecom_2 (COMPLEX_EXPR, type,
10254                   ffecom_1 (NEGATE_EXPR, realtype,
10255                             ffecom_1 (REALPART_EXPR, realtype,
10256                                       node)),
10257                   ffecom_1 (NEGATE_EXPR, realtype,
10258                             ffecom_1 (IMAGPART_EXPR, realtype,
10259                                       node)));
10260       break;
10261
10262     default:
10263       item = build1 (code, type, node);
10264       break;
10265     }
10266
10267   if (TREE_SIDE_EFFECTS (node))
10268     TREE_SIDE_EFFECTS (item) = 1;
10269   if ((code == ADDR_EXPR) && staticp (node))
10270     TREE_CONSTANT (item) = 1;
10271   return fold (item);
10272 }
10273 #endif
10274
10275 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
10276    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
10277    does not set TREE_ADDRESSABLE (because calling an inline
10278    function does not mean the function needs to be separately
10279    compiled).  */
10280
10281 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10282 tree
10283 ffecom_1_fn (tree node)
10284 {
10285   tree item;
10286   tree type;
10287
10288   if (node == error_mark_node)
10289     return error_mark_node;
10290
10291   type = build_type_variant (TREE_TYPE (node),
10292                              TREE_READONLY (node),
10293                              TREE_THIS_VOLATILE (node));
10294   item = build1 (ADDR_EXPR,
10295                  build_pointer_type (type), node);
10296   if (TREE_SIDE_EFFECTS (node))
10297     TREE_SIDE_EFFECTS (item) = 1;
10298   if (staticp (node))
10299     TREE_CONSTANT (item) = 1;
10300   return fold (item);
10301 }
10302 #endif
10303
10304 /* Essentially does a "fold (build (code, type, node1, node2))" while
10305    checking for certain housekeeping things.  */
10306
10307 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10308 tree
10309 ffecom_2 (enum tree_code code, tree type, tree node1,
10310           tree node2)
10311 {
10312   tree item;
10313
10314   if ((node1 == error_mark_node)
10315       || (node2 == error_mark_node)
10316       || (type == error_mark_node))
10317     return error_mark_node;
10318
10319   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
10320     {
10321       tree a, b, c, d, realtype;
10322
10323     case CONJ_EXPR:
10324       assert ("no CONJ_EXPR support yet" == NULL);
10325       return error_mark_node;
10326
10327     case COMPLEX_EXPR:
10328       item = build_tree_list (TYPE_FIELDS (type), node1);
10329       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
10330       item = build (CONSTRUCTOR, type, NULL_TREE, item);
10331       break;
10332
10333     case PLUS_EXPR:
10334       if (TREE_CODE (type) != RECORD_TYPE)
10335         {
10336           item = build (code, type, node1, node2);
10337           break;
10338         }
10339       node1 = ffecom_stabilize_aggregate_ (node1);
10340       node2 = ffecom_stabilize_aggregate_ (node2);
10341       realtype = TREE_TYPE (TYPE_FIELDS (type));
10342       item =
10343         ffecom_2 (COMPLEX_EXPR, type,
10344                   ffecom_2 (PLUS_EXPR, realtype,
10345                             ffecom_1 (REALPART_EXPR, realtype,
10346                                       node1),
10347                             ffecom_1 (REALPART_EXPR, realtype,
10348                                       node2)),
10349                   ffecom_2 (PLUS_EXPR, realtype,
10350                             ffecom_1 (IMAGPART_EXPR, realtype,
10351                                       node1),
10352                             ffecom_1 (IMAGPART_EXPR, realtype,
10353                                       node2)));
10354       break;
10355
10356     case MINUS_EXPR:
10357       if (TREE_CODE (type) != RECORD_TYPE)
10358         {
10359           item = build (code, type, node1, node2);
10360           break;
10361         }
10362       node1 = ffecom_stabilize_aggregate_ (node1);
10363       node2 = ffecom_stabilize_aggregate_ (node2);
10364       realtype = TREE_TYPE (TYPE_FIELDS (type));
10365       item =
10366         ffecom_2 (COMPLEX_EXPR, type,
10367                   ffecom_2 (MINUS_EXPR, realtype,
10368                             ffecom_1 (REALPART_EXPR, realtype,
10369                                       node1),
10370                             ffecom_1 (REALPART_EXPR, realtype,
10371                                       node2)),
10372                   ffecom_2 (MINUS_EXPR, realtype,
10373                             ffecom_1 (IMAGPART_EXPR, realtype,
10374                                       node1),
10375                             ffecom_1 (IMAGPART_EXPR, realtype,
10376                                       node2)));
10377       break;
10378
10379     case MULT_EXPR:
10380       if (TREE_CODE (type) != RECORD_TYPE)
10381         {
10382           item = build (code, type, node1, node2);
10383           break;
10384         }
10385       node1 = ffecom_stabilize_aggregate_ (node1);
10386       node2 = ffecom_stabilize_aggregate_ (node2);
10387       realtype = TREE_TYPE (TYPE_FIELDS (type));
10388       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
10389                                node1));
10390       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
10391                                node1));
10392       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
10393                                node2));
10394       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
10395                                node2));
10396       item =
10397         ffecom_2 (COMPLEX_EXPR, type,
10398                   ffecom_2 (MINUS_EXPR, realtype,
10399                             ffecom_2 (MULT_EXPR, realtype,
10400                                       a,
10401                                       c),
10402                             ffecom_2 (MULT_EXPR, realtype,
10403                                       b,
10404                                       d)),
10405                   ffecom_2 (PLUS_EXPR, realtype,
10406                             ffecom_2 (MULT_EXPR, realtype,
10407                                       a,
10408                                       d),
10409                             ffecom_2 (MULT_EXPR, realtype,
10410                                       c,
10411                                       b)));
10412       break;
10413
10414     case EQ_EXPR:
10415       if ((TREE_CODE (node1) != RECORD_TYPE)
10416           && (TREE_CODE (node2) != RECORD_TYPE))
10417         {
10418           item = build (code, type, node1, node2);
10419           break;
10420         }
10421       assert (TREE_CODE (node1) == RECORD_TYPE);
10422       assert (TREE_CODE (node2) == RECORD_TYPE);
10423       node1 = ffecom_stabilize_aggregate_ (node1);
10424       node2 = ffecom_stabilize_aggregate_ (node2);
10425       realtype = TREE_TYPE (TYPE_FIELDS (type));
10426       item =
10427         ffecom_2 (TRUTH_ANDIF_EXPR, type,
10428                   ffecom_2 (code, type,
10429                             ffecom_1 (REALPART_EXPR, realtype,
10430                                       node1),
10431                             ffecom_1 (REALPART_EXPR, realtype,
10432                                       node2)),
10433                   ffecom_2 (code, type,
10434                             ffecom_1 (IMAGPART_EXPR, realtype,
10435                                       node1),
10436                             ffecom_1 (IMAGPART_EXPR, realtype,
10437                                       node2)));
10438       break;
10439
10440     case NE_EXPR:
10441       if ((TREE_CODE (node1) != RECORD_TYPE)
10442           && (TREE_CODE (node2) != RECORD_TYPE))
10443         {
10444           item = build (code, type, node1, node2);
10445           break;
10446         }
10447       assert (TREE_CODE (node1) == RECORD_TYPE);
10448       assert (TREE_CODE (node2) == RECORD_TYPE);
10449       node1 = ffecom_stabilize_aggregate_ (node1);
10450       node2 = ffecom_stabilize_aggregate_ (node2);
10451       realtype = TREE_TYPE (TYPE_FIELDS (type));
10452       item =
10453         ffecom_2 (TRUTH_ORIF_EXPR, type,
10454                   ffecom_2 (code, type,
10455                             ffecom_1 (REALPART_EXPR, realtype,
10456                                       node1),
10457                             ffecom_1 (REALPART_EXPR, realtype,
10458                                       node2)),
10459                   ffecom_2 (code, type,
10460                             ffecom_1 (IMAGPART_EXPR, realtype,
10461                                       node1),
10462                             ffecom_1 (IMAGPART_EXPR, realtype,
10463                                       node2)));
10464       break;
10465
10466     default:
10467       item = build (code, type, node1, node2);
10468       break;
10469     }
10470
10471   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
10472     TREE_SIDE_EFFECTS (item) = 1;
10473   return fold (item);
10474 }
10475
10476 #endif
10477 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
10478
10479    ffesymbol s;  // the ENTRY point itself
10480    if (ffecom_2pass_advise_entrypoint(s))
10481        // the ENTRY point has been accepted
10482
10483    Does whatever compiler needs to do when it learns about the entrypoint,
10484    like determine the return type of the master function, count the
10485    number of entrypoints, etc.  Returns FALSE if the return type is
10486    not compatible with the return type(s) of other entrypoint(s).
10487
10488    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
10489    later (after _finish_progunit) be called with the same entrypoint(s)
10490    as passed to this fn for which TRUE was returned.
10491
10492    03-Jan-92  JCB  2.0
10493       Return FALSE if the return type conflicts with previous entrypoints.  */
10494
10495 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10496 bool
10497 ffecom_2pass_advise_entrypoint (ffesymbol entry)
10498 {
10499   ffebld list;                  /* opITEM. */
10500   ffebld mlist;                 /* opITEM. */
10501   ffebld plist;                 /* opITEM. */
10502   ffebld arg;                   /* ffebld_head(opITEM). */
10503   ffebld item;                  /* opITEM. */
10504   ffesymbol s;                  /* ffebld_symter(arg). */
10505   ffeinfoBasictype bt = ffesymbol_basictype (entry);
10506   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
10507   ffetargetCharacterSize size = ffesymbol_size (entry);
10508   bool ok;
10509
10510   if (ffecom_num_entrypoints_ == 0)
10511     {                           /* First entrypoint, make list of main
10512                                    arglist's dummies. */
10513       assert (ffecom_primary_entry_ != NULL);
10514
10515       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
10516       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
10517       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
10518
10519       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
10520            list != NULL;
10521            list = ffebld_trail (list))
10522         {
10523           arg = ffebld_head (list);
10524           if (ffebld_op (arg) != FFEBLD_opSYMTER)
10525             continue;           /* Alternate return or some such thing. */
10526           item = ffebld_new_item (arg, NULL);
10527           if (plist == NULL)
10528             ffecom_master_arglist_ = item;
10529           else
10530             ffebld_set_trail (plist, item);
10531           plist = item;
10532         }
10533     }
10534
10535   /* If necessary, scan entry arglist for alternate returns.  Do this scan
10536      apparently redundantly (it's done below to UNIONize the arglists) so
10537      that we don't complain about RETURN 1 if an offending ENTRY is the only
10538      one with an alternate return.  */
10539
10540   if (!ffecom_is_altreturning_)
10541     {
10542       for (list = ffesymbol_dummyargs (entry);
10543            list != NULL;
10544            list = ffebld_trail (list))
10545         {
10546           arg = ffebld_head (list);
10547           if (ffebld_op (arg) == FFEBLD_opSTAR)
10548             {
10549               ffecom_is_altreturning_ = TRUE;
10550               break;
10551             }
10552         }
10553     }
10554
10555   /* Now check type compatibility. */
10556
10557   switch (ffecom_master_bt_)
10558     {
10559     case FFEINFO_basictypeNONE:
10560       ok = (bt != FFEINFO_basictypeCHARACTER);
10561       break;
10562
10563     case FFEINFO_basictypeCHARACTER:
10564       ok
10565         = (bt == FFEINFO_basictypeCHARACTER)
10566         && (kt == ffecom_master_kt_)
10567         && (size == ffecom_master_size_);
10568       break;
10569
10570     case FFEINFO_basictypeANY:
10571       return FALSE;             /* Just don't bother. */
10572
10573     default:
10574       if (bt == FFEINFO_basictypeCHARACTER)
10575         {
10576           ok = FALSE;
10577           break;
10578         }
10579       ok = TRUE;
10580       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10581         {
10582           ffecom_master_bt_ = FFEINFO_basictypeNONE;
10583           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10584         }
10585       break;
10586     }
10587
10588   if (!ok)
10589     {
10590       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10591       ffest_ffebad_here_current_stmt (0);
10592       ffebad_finish ();
10593       return FALSE;             /* Can't handle entrypoint. */
10594     }
10595
10596   /* Entrypoint type compatible with previous types. */
10597
10598   ++ffecom_num_entrypoints_;
10599
10600   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10601
10602   for (list = ffesymbol_dummyargs (entry);
10603        list != NULL;
10604        list = ffebld_trail (list))
10605     {
10606       arg = ffebld_head (list);
10607       if (ffebld_op (arg) != FFEBLD_opSYMTER)
10608         continue;               /* Alternate return or some such thing. */
10609       s = ffebld_symter (arg);
10610       for (plist = NULL, mlist = ffecom_master_arglist_;
10611            mlist != NULL;
10612            plist = mlist, mlist = ffebld_trail (mlist))
10613         {                       /* plist points to previous item for easy
10614                                    appending of arg. */
10615           if (ffebld_symter (ffebld_head (mlist)) == s)
10616             break;              /* Already have this arg in the master list. */
10617         }
10618       if (mlist != NULL)
10619         continue;               /* Already have this arg in the master list. */
10620
10621       /* Append this arg to the master list. */
10622
10623       item = ffebld_new_item (arg, NULL);
10624       if (plist == NULL)
10625         ffecom_master_arglist_ = item;
10626       else
10627         ffebld_set_trail (plist, item);
10628     }
10629
10630   return TRUE;
10631 }
10632
10633 #endif
10634 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10635
10636    ffesymbol s;  // the ENTRY point itself
10637    ffecom_2pass_do_entrypoint(s);
10638
10639    Does whatever compiler needs to do to make the entrypoint actually
10640    happen.  Must be called for each entrypoint after
10641    ffecom_finish_progunit is called.  */
10642
10643 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10644 void
10645 ffecom_2pass_do_entrypoint (ffesymbol entry)
10646 {
10647   static int mfn_num = 0;
10648   static int ent_num;
10649
10650   if (mfn_num != ffecom_num_fns_)
10651     {                           /* First entrypoint for this program unit. */
10652       ent_num = 1;
10653       mfn_num = ffecom_num_fns_;
10654       ffecom_do_entry_ (ffecom_primary_entry_, 0);
10655     }
10656   else
10657     ++ent_num;
10658
10659   --ffecom_num_entrypoints_;
10660
10661   ffecom_do_entry_ (entry, ent_num);
10662 }
10663
10664 #endif
10665
10666 /* Essentially does a "fold (build (code, type, node1, node2))" while
10667    checking for certain housekeeping things.  Always sets
10668    TREE_SIDE_EFFECTS.  */
10669
10670 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10671 tree
10672 ffecom_2s (enum tree_code code, tree type, tree node1,
10673            tree node2)
10674 {
10675   tree item;
10676
10677   if ((node1 == error_mark_node)
10678       || (node2 == error_mark_node)
10679       || (type == error_mark_node))
10680     return error_mark_node;
10681
10682   item = build (code, type, node1, node2);
10683   TREE_SIDE_EFFECTS (item) = 1;
10684   return fold (item);
10685 }
10686
10687 #endif
10688 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10689    checking for certain housekeeping things.  */
10690
10691 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10692 tree
10693 ffecom_3 (enum tree_code code, tree type, tree node1,
10694           tree node2, tree node3)
10695 {
10696   tree item;
10697
10698   if ((node1 == error_mark_node)
10699       || (node2 == error_mark_node)
10700       || (node3 == error_mark_node)
10701       || (type == error_mark_node))
10702     return error_mark_node;
10703
10704   item = build (code, type, node1, node2, node3);
10705   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10706       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10707     TREE_SIDE_EFFECTS (item) = 1;
10708   return fold (item);
10709 }
10710
10711 #endif
10712 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10713    checking for certain housekeeping things.  Always sets
10714    TREE_SIDE_EFFECTS.  */
10715
10716 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10717 tree
10718 ffecom_3s (enum tree_code code, tree type, tree node1,
10719            tree node2, tree node3)
10720 {
10721   tree item;
10722
10723   if ((node1 == error_mark_node)
10724       || (node2 == error_mark_node)
10725       || (node3 == error_mark_node)
10726       || (type == error_mark_node))
10727     return error_mark_node;
10728
10729   item = build (code, type, node1, node2, node3);
10730   TREE_SIDE_EFFECTS (item) = 1;
10731   return fold (item);
10732 }
10733
10734 #endif
10735 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10736
10737    See use by ffecom_list_expr.
10738
10739    If expression is NULL, returns an integer zero tree.  If it is not
10740    a CHARACTER expression, returns whatever ffecom_expr
10741    returns and sets the length return value to NULL_TREE.  Otherwise
10742    generates code to evaluate the character expression, returns the proper
10743    pointer to the result, but does NOT set the length return value to a tree
10744    that specifies the length of the result.  (In other words, the length
10745    variable is always set to NULL_TREE, because a length is never passed.)
10746
10747    21-Dec-91  JCB  1.1
10748       Don't set returned length, since nobody needs it (yet; someday if
10749       we allow CHARACTER*(*) dummies to statement functions, we'll need
10750       it).  */
10751
10752 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10753 tree
10754 ffecom_arg_expr (ffebld expr, tree *length)
10755 {
10756   tree ign;
10757
10758   *length = NULL_TREE;
10759
10760   if (expr == NULL)
10761     return integer_zero_node;
10762
10763   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10764     return ffecom_expr (expr);
10765
10766   return ffecom_arg_ptr_to_expr (expr, &ign);
10767 }
10768
10769 #endif
10770 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10771
10772    See use by ffecom_list_ptr_to_expr.
10773
10774    If expression is NULL, returns an integer zero tree.  If it is not
10775    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10776    returns and sets the length return value to NULL_TREE.  Otherwise
10777    generates code to evaluate the character expression, returns the proper
10778    pointer to the result, AND sets the length return value to a tree that
10779    specifies the length of the result.  */
10780
10781 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10782 tree
10783 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10784 {
10785   tree item;
10786   tree ign_length;
10787   ffecomConcatList_ catlist;
10788
10789   *length = NULL_TREE;
10790
10791   if (expr == NULL)
10792     return integer_zero_node;
10793
10794   switch (ffebld_op (expr))
10795     {
10796     case FFEBLD_opPERCENT_VAL:
10797       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10798         return ffecom_expr (ffebld_left (expr));
10799       {
10800         tree temp_exp;
10801         tree temp_length;
10802
10803         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10804         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10805                          temp_exp);
10806       }
10807
10808     case FFEBLD_opPERCENT_REF:
10809       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10810         return ffecom_ptr_to_expr (ffebld_left (expr));
10811       ign_length = NULL_TREE;
10812       length = &ign_length;
10813       expr = ffebld_left (expr);
10814       break;
10815
10816     case FFEBLD_opPERCENT_DESCR:
10817       switch (ffeinfo_basictype (ffebld_info (expr)))
10818         {
10819 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10820         case FFEINFO_basictypeHOLLERITH:
10821 #endif
10822         case FFEINFO_basictypeCHARACTER:
10823           break;                /* Passed by descriptor anyway. */
10824
10825         default:
10826           item = ffecom_ptr_to_expr (expr);
10827           if (item != error_mark_node)
10828             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10829           break;
10830         }
10831       break;
10832
10833     default:
10834       break;
10835     }
10836
10837 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10838   if (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10839     {                           /* Pass Hollerith by descriptor. */
10840       ffetargetHollerith h;
10841
10842       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10843       h = ffebld_cu_val_hollerith (ffebld_constant_union
10844                                    (ffebld_conter (expr)));
10845       *length
10846         = build_int_2 (h.length, 0);
10847       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10848     }
10849 #endif
10850
10851   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10852     return ffecom_ptr_to_expr (expr);
10853
10854   assert (ffeinfo_kindtype (ffebld_info (expr))
10855           == FFEINFO_kindtypeCHARACTER1);
10856
10857   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10858   switch (ffecom_concat_list_count_ (catlist))
10859     {
10860     case 0:                     /* Shouldn't happen, but in case it does... */
10861       *length = ffecom_f2c_ftnlen_zero_node;
10862       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10863       ffecom_concat_list_kill_ (catlist);
10864       return null_pointer_node;
10865
10866     case 1:                     /* The (fairly) easy case. */
10867       ffecom_char_args_ (&item, length,
10868                          ffecom_concat_list_expr_ (catlist, 0));
10869       ffecom_concat_list_kill_ (catlist);
10870       assert (item != NULL_TREE);
10871       return item;
10872
10873     default:                    /* Must actually concatenate things. */
10874       break;
10875     }
10876
10877   {
10878     int count = ffecom_concat_list_count_ (catlist);
10879     int i;
10880     tree lengths;
10881     tree items;
10882     tree length_array;
10883     tree item_array;
10884     tree citem;
10885     tree clength;
10886     tree temporary;
10887     tree num;
10888     tree known_length;
10889     ffetargetCharacterSize sz;
10890
10891     length_array
10892       = lengths
10893       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10894                              FFETARGET_charactersizeNONE, count, TRUE);
10895     item_array
10896       = items
10897       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10898                              FFETARGET_charactersizeNONE, count, TRUE);
10899
10900     known_length = ffecom_f2c_ftnlen_zero_node;
10901
10902     for (i = 0; i < count; ++i)
10903       {
10904         ffecom_char_args_ (&citem, &clength,
10905                            ffecom_concat_list_expr_ (catlist, i));
10906         if ((citem == error_mark_node)
10907             || (clength == error_mark_node))
10908           {
10909             ffecom_concat_list_kill_ (catlist);
10910             *length = error_mark_node;
10911             return error_mark_node;
10912           }
10913
10914         items
10915           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10916                       ffecom_modify (void_type_node,
10917                                      ffecom_2 (ARRAY_REF,
10918                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10919                                                item_array,
10920                                                build_int_2 (i, 0)),
10921                                      citem),
10922                       items);
10923         clength = ffecom_save_tree (clength);
10924         known_length
10925           = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10926                       known_length,
10927                       clength);
10928         lengths
10929           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10930                       ffecom_modify (void_type_node,
10931                                      ffecom_2 (ARRAY_REF,
10932                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10933                                                length_array,
10934                                                build_int_2 (i, 0)),
10935                                      clength),
10936                       lengths);
10937       }
10938
10939     sz = ffecom_concat_list_maxlen_ (catlist);
10940     assert (sz != FFETARGET_charactersizeNONE);
10941
10942     temporary = ffecom_push_tempvar (char_type_node,
10943                                      sz, -1, TRUE);
10944     temporary = ffecom_1 (ADDR_EXPR,
10945                           build_pointer_type (TREE_TYPE (temporary)),
10946                           temporary);
10947
10948     item = build_tree_list (NULL_TREE, temporary);
10949     TREE_CHAIN (item)
10950       = build_tree_list (NULL_TREE,
10951                          ffecom_1 (ADDR_EXPR,
10952                                    build_pointer_type (TREE_TYPE (items)),
10953                                    items));
10954     TREE_CHAIN (TREE_CHAIN (item))
10955       = build_tree_list (NULL_TREE,
10956                          ffecom_1 (ADDR_EXPR,
10957                                    build_pointer_type (TREE_TYPE (lengths)),
10958                                    lengths));
10959     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10960       = build_tree_list
10961         (NULL_TREE,
10962          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10963                    convert (ffecom_f2c_ftnlen_type_node,
10964                             build_int_2 (count, 0))));
10965     num = build_int_2 (sz, 0);
10966     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10967     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10968       = build_tree_list (NULL_TREE, num);
10969
10970     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item);
10971     TREE_SIDE_EFFECTS (item) = 1;
10972     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10973                      item,
10974                      temporary);
10975
10976     *length = known_length;
10977   }
10978
10979   ffecom_concat_list_kill_ (catlist);
10980   assert (item != NULL_TREE);
10981   return item;
10982 }
10983
10984 #endif
10985 /* ffecom_call_gfrt -- Generate call to run-time function
10986
10987    tree expr;
10988    expr = ffecom_call_gfrt(FFECOM_gfrtSTOPNIL,NULL_TREE);
10989
10990    The first arg is the GNU Fortran Run-Time function index, the second
10991    arg is the list of arguments to pass to it.  Returned is the expression
10992    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10993    result (which may be void).  */
10994
10995 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10996 tree
10997 ffecom_call_gfrt (ffecomGfrt ix, tree args)
10998 {
10999   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
11000                        ffecom_gfrt_kindtype (ix),
11001                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
11002                        NULL_TREE, args, NULL_TREE, NULL,
11003                        NULL, NULL_TREE, TRUE);
11004 }
11005 #endif
11006
11007 /* ffecom_constantunion -- Transform constant-union to tree
11008
11009    ffebldConstantUnion cu;  // the constant to transform
11010    ffeinfoBasictype bt;  // its basic type
11011    ffeinfoKindtype kt;  // its kind type
11012    tree tree_type;  // ffecom_tree_type[bt][kt]
11013    ffecom_constantunion(&cu,bt,kt,tree_type);  */
11014
11015 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11016 tree
11017 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
11018                       ffeinfoKindtype kt, tree tree_type)
11019 {
11020   tree item;
11021
11022   switch (bt)
11023     {
11024     case FFEINFO_basictypeINTEGER:
11025       {
11026         int val;
11027
11028         switch (kt)
11029           {
11030 #if FFETARGET_okINTEGER1
11031           case FFEINFO_kindtypeINTEGER1:
11032             val = ffebld_cu_val_integer1 (*cu);
11033             break;
11034 #endif
11035
11036 #if FFETARGET_okINTEGER2
11037           case FFEINFO_kindtypeINTEGER2:
11038             val = ffebld_cu_val_integer2 (*cu);
11039             break;
11040 #endif
11041
11042 #if FFETARGET_okINTEGER3
11043           case FFEINFO_kindtypeINTEGER3:
11044             val = ffebld_cu_val_integer3 (*cu);
11045             break;
11046 #endif
11047
11048 #if FFETARGET_okINTEGER4
11049           case FFEINFO_kindtypeINTEGER4:
11050             val = ffebld_cu_val_integer4 (*cu);
11051             break;
11052 #endif
11053
11054           default:
11055             assert ("bad INTEGER constant kind type" == NULL);
11056             /* Fall through. */
11057           case FFEINFO_kindtypeANY:
11058             return error_mark_node;
11059           }
11060         item = build_int_2 (val, (val < 0) ? -1 : 0);
11061         TREE_TYPE (item) = tree_type;
11062       }
11063       break;
11064
11065     case FFEINFO_basictypeLOGICAL:
11066       {
11067         int val;
11068
11069         switch (kt)
11070           {
11071 #if FFETARGET_okLOGICAL1
11072           case FFEINFO_kindtypeLOGICAL1:
11073             val = ffebld_cu_val_logical1 (*cu);
11074             break;
11075 #endif
11076
11077 #if FFETARGET_okLOGICAL2
11078           case FFEINFO_kindtypeLOGICAL2:
11079             val = ffebld_cu_val_logical2 (*cu);
11080             break;
11081 #endif
11082
11083 #if FFETARGET_okLOGICAL3
11084           case FFEINFO_kindtypeLOGICAL3:
11085             val = ffebld_cu_val_logical3 (*cu);
11086             break;
11087 #endif
11088
11089 #if FFETARGET_okLOGICAL4
11090           case FFEINFO_kindtypeLOGICAL4:
11091             val = ffebld_cu_val_logical4 (*cu);
11092             break;
11093 #endif
11094
11095           default:
11096             assert ("bad LOGICAL constant kind type" == NULL);
11097             /* Fall through. */
11098           case FFEINFO_kindtypeANY:
11099             return error_mark_node;
11100           }
11101         item = build_int_2 (val, (val < 0) ? -1 : 0);
11102         TREE_TYPE (item) = tree_type;
11103       }
11104       break;
11105
11106     case FFEINFO_basictypeREAL:
11107       {
11108         REAL_VALUE_TYPE val;
11109
11110         switch (kt)
11111           {
11112 #if FFETARGET_okREAL1
11113           case FFEINFO_kindtypeREAL1:
11114             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
11115             break;
11116 #endif
11117
11118 #if FFETARGET_okREAL2
11119           case FFEINFO_kindtypeREAL2:
11120             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
11121             break;
11122 #endif
11123
11124 #if FFETARGET_okREAL3
11125           case FFEINFO_kindtypeREAL3:
11126             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
11127             break;
11128 #endif
11129
11130 #if FFETARGET_okREAL4
11131           case FFEINFO_kindtypeREAL4:
11132             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
11133             break;
11134 #endif
11135
11136           default:
11137             assert ("bad REAL constant kind type" == NULL);
11138             /* Fall through. */
11139           case FFEINFO_kindtypeANY:
11140             return error_mark_node;
11141           }
11142         item = build_real (tree_type, val);
11143       }
11144       break;
11145
11146     case FFEINFO_basictypeCOMPLEX:
11147       {
11148         REAL_VALUE_TYPE real;
11149         REAL_VALUE_TYPE imag;
11150         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
11151
11152         switch (kt)
11153           {
11154 #if FFETARGET_okCOMPLEX1
11155           case FFEINFO_kindtypeREAL1:
11156             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
11157             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
11158             break;
11159 #endif
11160
11161 #if FFETARGET_okCOMPLEX2
11162           case FFEINFO_kindtypeREAL2:
11163             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
11164             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
11165             break;
11166 #endif
11167
11168 #if FFETARGET_okCOMPLEX3
11169           case FFEINFO_kindtypeREAL3:
11170             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
11171             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
11172             break;
11173 #endif
11174
11175 #if FFETARGET_okCOMPLEX4
11176           case FFEINFO_kindtypeREAL4:
11177             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
11178             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
11179             break;
11180 #endif
11181
11182           default:
11183             assert ("bad REAL constant kind type" == NULL);
11184             /* Fall through. */
11185           case FFEINFO_kindtypeANY:
11186             return error_mark_node;
11187           }
11188         item = ffecom_build_complex_constant_ (tree_type,
11189                                                build_real (el_type, real),
11190                                                build_real (el_type, imag));
11191       }
11192       break;
11193
11194     case FFEINFO_basictypeCHARACTER:
11195       {                         /* Happens only in DATA and similar contexts. */
11196         ffetargetCharacter1 val;
11197
11198         switch (kt)
11199           {
11200 #if FFETARGET_okCHARACTER1
11201           case FFEINFO_kindtypeLOGICAL1:
11202             val = ffebld_cu_val_character1 (*cu);
11203             break;
11204 #endif
11205
11206           default:
11207             assert ("bad CHARACTER constant kind type" == NULL);
11208             /* Fall through. */
11209           case FFEINFO_kindtypeANY:
11210             return error_mark_node;
11211           }
11212         item = build_string (ffetarget_length_character1 (val),
11213                              ffetarget_text_character1 (val));
11214         TREE_TYPE (item)
11215           = build_type_variant (build_array_type (char_type_node,
11216                                                   build_range_type
11217                                                   (integer_type_node,
11218                                                    integer_one_node,
11219                                                    build_int_2
11220                                                 (ffetarget_length_character1
11221                                                  (val), 0))),
11222                                 1, 0);
11223       }
11224       break;
11225
11226     case FFEINFO_basictypeHOLLERITH:
11227       {
11228         ffetargetHollerith h;
11229
11230         h = ffebld_cu_val_hollerith (*cu);
11231
11232         /* If not at least as wide as default INTEGER, widen it.  */
11233         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
11234           item = build_string (h.length, h.text);
11235         else
11236           {
11237             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
11238
11239             memcpy (str, h.text, h.length);
11240             memset (&str[h.length], ' ',
11241                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
11242                     - h.length);
11243             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
11244                                  str);
11245           }
11246         TREE_TYPE (item)
11247           = build_type_variant (build_array_type (char_type_node,
11248                                                   build_range_type
11249                                                   (integer_type_node,
11250                                                    integer_one_node,
11251                                                    build_int_2
11252                                                    (h.length, 0))),
11253                                 1, 0);
11254       }
11255       break;
11256
11257     case FFEINFO_basictypeTYPELESS:
11258       {
11259         ffetargetInteger1 ival;
11260         ffetargetTypeless tless;
11261         ffebad error;
11262
11263         tless = ffebld_cu_val_typeless (*cu);
11264         error = ffetarget_convert_integer1_typeless (&ival, tless);
11265         assert (error == FFEBAD);
11266
11267         item = build_int_2 ((int) ival, 0);
11268       }
11269       break;
11270
11271     default:
11272       assert ("not yet on constant type" == NULL);
11273       /* Fall through. */
11274     case FFEINFO_basictypeANY:
11275       return error_mark_node;
11276     }
11277
11278   TREE_CONSTANT (item) = 1;
11279
11280   return item;
11281 }
11282
11283 #endif
11284
11285 /* Handy way to make a field in a struct/union.  */
11286
11287 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11288 tree
11289 ffecom_decl_field (tree context, tree prevfield,
11290                    char *name, tree type)
11291 {
11292   tree field;
11293
11294   field = build_decl (FIELD_DECL, get_identifier (name), type);
11295   DECL_CONTEXT (field) = context;
11296   DECL_FRAME_SIZE (field) = 0;
11297   if (prevfield != NULL_TREE)
11298     TREE_CHAIN (prevfield) = field;
11299
11300   return field;
11301 }
11302
11303 #endif
11304
11305 void
11306 ffecom_close_include (FILE *f)
11307 {
11308 #if FFECOM_GCC_INCLUDE
11309   ffecom_close_include_ (f);
11310 #endif
11311 }
11312
11313 int
11314 ffecom_decode_include_option (char *spec)
11315 {
11316 #if FFECOM_GCC_INCLUDE
11317   return ffecom_decode_include_option_ (spec);
11318 #else
11319   return 1;
11320 #endif
11321 }
11322
11323 /* ffecom_end_transition -- Perform end transition on all symbols
11324
11325    ffecom_end_transition();
11326
11327    Calls ffecom_sym_end_transition for each global and local symbol.  */
11328
11329 void
11330 ffecom_end_transition ()
11331 {
11332 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11333   ffebld item;
11334 #endif
11335
11336   if (ffe_is_ffedebug ())
11337     fprintf (dmpout, "; end_stmt_transition\n");
11338
11339 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11340   ffecom_list_blockdata_ = NULL;
11341   ffecom_list_common_ = NULL;
11342 #endif
11343
11344   ffesymbol_drive (ffecom_sym_end_transition);
11345   if (ffe_is_ffedebug ())
11346     {
11347       ffestorag_report ();
11348       ffesymbol_report_all ();
11349     }
11350
11351 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11352   ffecom_start_progunit_ ();
11353
11354   for (item = ffecom_list_blockdata_;
11355        item != NULL;
11356        item = ffebld_trail (item))
11357     {
11358       ffebld callee;
11359       ffesymbol s;
11360       tree dt;
11361       tree t;
11362       tree var;
11363       int yes;
11364       static int number = 0;
11365
11366       callee = ffebld_head (item);
11367       s = ffebld_symter (callee);
11368       t = ffesymbol_hook (s).decl_tree;
11369       if (t == NULL_TREE)
11370         {
11371           s = ffecom_sym_transform_ (s);
11372           t = ffesymbol_hook (s).decl_tree;
11373         }
11374
11375       yes = suspend_momentary ();
11376
11377       dt = build_pointer_type (TREE_TYPE (t));
11378
11379       var = build_decl (VAR_DECL,
11380                         ffecom_get_invented_identifier ("__g77_forceload_%d",
11381                                                         NULL, number++),
11382                         dt);
11383       DECL_EXTERNAL (var) = 0;
11384       TREE_STATIC (var) = 1;
11385       TREE_PUBLIC (var) = 0;
11386       DECL_INITIAL (var) = error_mark_node;
11387       TREE_USED (var) = 1;
11388
11389       var = start_decl (var, FALSE);
11390
11391       t = ffecom_1 (ADDR_EXPR, dt, t);
11392
11393       finish_decl (var, t, FALSE);
11394
11395       resume_momentary (yes);
11396     }
11397
11398   /* This handles any COMMON areas that weren't referenced but have, for
11399      example, important initial data.  */
11400
11401   for (item = ffecom_list_common_;
11402        item != NULL;
11403        item = ffebld_trail (item))
11404     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
11405
11406   ffecom_list_common_ = NULL;
11407 #endif
11408 }
11409
11410 /* ffecom_exec_transition -- Perform exec transition on all symbols
11411
11412    ffecom_exec_transition();
11413
11414    Calls ffecom_sym_exec_transition for each global and local symbol.
11415    Make sure error updating not inhibited.  */
11416
11417 void
11418 ffecom_exec_transition ()
11419 {
11420   bool inhibited;
11421
11422   if (ffe_is_ffedebug ())
11423     fprintf (dmpout, "; exec_stmt_transition\n");
11424
11425   inhibited = ffebad_inhibit ();
11426   ffebad_set_inhibit (FALSE);
11427
11428   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
11429   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
11430   if (ffe_is_ffedebug ())
11431     {
11432       ffestorag_report ();
11433       ffesymbol_report_all ();
11434     }
11435
11436   if (inhibited)
11437     ffebad_set_inhibit (TRUE);
11438 }
11439
11440 /* ffecom_expand_let_stmt -- Compile let (assignment) statement
11441
11442    ffebld dest;
11443    ffebld source;
11444    ffecom_expand_let_stmt(dest,source);
11445
11446    Convert dest and source using ffecom_expr, then join them
11447    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
11448
11449 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11450 void
11451 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11452 {
11453   tree dest_tree;
11454   tree dest_length;
11455   tree source_tree;
11456   tree expr_tree;
11457
11458   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11459     {
11460       bool dest_used;
11461
11462       dest_tree = ffecom_expr_rw (dest);
11463       if (dest_tree == error_mark_node)
11464         return;
11465
11466       if ((TREE_CODE (dest_tree) != VAR_DECL)
11467           || TREE_ADDRESSABLE (dest_tree))
11468         source_tree = ffecom_expr_ (source, NULL_TREE, dest_tree, dest,
11469                                     &dest_used, FALSE);
11470       else
11471         {
11472           source_tree = ffecom_expr (source);
11473           dest_used = FALSE;
11474         }
11475       if (source_tree == error_mark_node)
11476         return;
11477
11478       if (dest_used)
11479         expr_tree = source_tree;
11480       else
11481         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11482                                dest_tree,
11483                                source_tree);
11484
11485       expand_expr_stmt (expr_tree);
11486       return;
11487     }
11488
11489   ffecom_push_calltemps ();
11490   ffecom_char_args_ (&dest_tree, &dest_length, dest);
11491   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11492                     source);
11493   ffecom_pop_calltemps ();
11494 }
11495
11496 #endif
11497 /* ffecom_expr -- Transform expr into gcc tree
11498
11499    tree t;
11500    ffebld expr;  // FFE expression.
11501    tree = ffecom_expr(expr);
11502
11503    Recursive descent on expr while making corresponding tree nodes and
11504    attaching type info and such.  */
11505
11506 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11507 tree
11508 ffecom_expr (ffebld expr)
11509 {
11510   return ffecom_expr_ (expr, NULL_TREE, NULL_TREE, NULL, NULL,
11511                        FALSE);
11512 }
11513
11514 #endif
11515 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
11516
11517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11518 tree
11519 ffecom_expr_assign (ffebld expr)
11520 {
11521   return ffecom_expr_ (expr, NULL_TREE, NULL_TREE, NULL, NULL,
11522                        TRUE);
11523 }
11524
11525 #endif
11526 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
11527
11528 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11529 tree
11530 ffecom_expr_assign_w (ffebld expr)
11531 {
11532   return ffecom_expr_ (expr, NULL_TREE, NULL_TREE, NULL, NULL,
11533                        TRUE);
11534 }
11535
11536 #endif
11537 /* Transform expr for use as into read/write tree and stabilize the
11538    reference.  Not for use on CHARACTER expressions.
11539
11540    Recursive descent on expr while making corresponding tree nodes and
11541    attaching type info and such.  */
11542
11543 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11544 tree
11545 ffecom_expr_rw (ffebld expr)
11546 {
11547   assert (expr != NULL);
11548
11549   return stabilize_reference (ffecom_expr (expr));
11550 }
11551
11552 #endif
11553 /* Do global stuff.  */
11554
11555 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11556 void
11557 ffecom_finish_compile ()
11558 {
11559   assert (ffecom_outer_function_decl_ == NULL_TREE);
11560   assert (current_function_decl == NULL_TREE);
11561
11562   ffeglobal_drive (ffecom_finish_global_);
11563 }
11564
11565 #endif
11566 /* Public entry point for front end to access finish_decl.  */
11567
11568 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11569 void
11570 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11571 {
11572   assert (!is_top_level);
11573   finish_decl (decl, init, FALSE);
11574 }
11575
11576 #endif
11577 /* Finish a program unit.  */
11578
11579 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11580 void
11581 ffecom_finish_progunit ()
11582 {
11583   ffecom_end_compstmt_ ();
11584
11585   ffecom_previous_function_decl_ = current_function_decl;
11586   ffecom_which_entrypoint_decl_ = NULL_TREE;
11587
11588   finish_function (0);
11589 }
11590
11591 #endif
11592 /* Wrapper for get_identifier.  pattern is like "...%s...", text is
11593    inserted into final name in place of "%s", or if text is NULL,
11594    pattern is like "...%d..." and text form of number is inserted
11595    in place of "%d".  */
11596
11597 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11598 tree
11599 ffecom_get_invented_identifier (char *pattern, char *text, int number)
11600 {
11601   tree decl;
11602   char *nam;
11603   mallocSize lenlen;
11604   char space[66];
11605
11606   if (text == NULL)
11607     lenlen = strlen (pattern) + 20;
11608   else
11609     lenlen = strlen (pattern) + strlen (text) - 1;
11610   if (lenlen > ARRAY_SIZE (space))
11611     nam = malloc_new_ks (malloc_pool_image (), pattern, lenlen);
11612   else
11613     nam = &space[0];
11614   if (text == NULL)
11615     sprintf (&nam[0], pattern, number);
11616   else
11617     sprintf (&nam[0], pattern, text);
11618   decl = get_identifier (nam);
11619   if (lenlen > ARRAY_SIZE (space))
11620     malloc_kill_ks (malloc_pool_image (), nam, lenlen);
11621
11622   IDENTIFIER_INVENTED (decl) = 1;
11623
11624   return decl;
11625 }
11626
11627 ffeinfoBasictype
11628 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11629 {
11630   assert (gfrt < FFECOM_gfrt);
11631
11632   switch (ffecom_gfrt_type_[gfrt])
11633     {
11634     case FFECOM_rttypeVOID_:
11635       return FFEINFO_basictypeNONE;
11636
11637     case FFECOM_rttypeFTNINT_:
11638       return FFEINFO_basictypeINTEGER;
11639
11640     case FFECOM_rttypeINTEGER_:
11641       return FFEINFO_basictypeINTEGER;
11642
11643     case FFECOM_rttypeLONGINT_:
11644       return FFEINFO_basictypeINTEGER;
11645
11646     case FFECOM_rttypeLOGICAL_:
11647       return FFEINFO_basictypeLOGICAL;
11648
11649     case FFECOM_rttypeREAL_F2C_:
11650     case FFECOM_rttypeREAL_GNU_:
11651       return FFEINFO_basictypeREAL;
11652
11653     case FFECOM_rttypeCOMPLEX_F2C_:
11654     case FFECOM_rttypeCOMPLEX_GNU_:
11655       return FFEINFO_basictypeCOMPLEX;
11656
11657     case FFECOM_rttypeDOUBLE_:
11658     case FFECOM_rttypeDOUBLEREAL_:
11659       return FFEINFO_basictypeREAL;
11660
11661     case FFECOM_rttypeDBLCMPLX_F2C_:
11662     case FFECOM_rttypeDBLCMPLX_GNU_:
11663       return FFEINFO_basictypeCOMPLEX;
11664
11665     case FFECOM_rttypeCHARACTER_:
11666       return FFEINFO_basictypeCHARACTER;
11667
11668     default:
11669       return FFEINFO_basictypeANY;
11670     }
11671 }
11672
11673 ffeinfoKindtype
11674 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11675 {
11676   assert (gfrt < FFECOM_gfrt);
11677
11678   switch (ffecom_gfrt_type_[gfrt])
11679     {
11680     case FFECOM_rttypeVOID_:
11681       return FFEINFO_kindtypeNONE;
11682
11683     case FFECOM_rttypeFTNINT_:
11684       return FFEINFO_kindtypeINTEGER1;
11685
11686     case FFECOM_rttypeINTEGER_:
11687       return FFEINFO_kindtypeINTEGER1;
11688
11689     case FFECOM_rttypeLONGINT_:
11690       return FFEINFO_kindtypeINTEGER4;
11691
11692     case FFECOM_rttypeLOGICAL_:
11693       return FFEINFO_kindtypeLOGICAL1;
11694
11695     case FFECOM_rttypeREAL_F2C_:
11696     case FFECOM_rttypeREAL_GNU_:
11697       return FFEINFO_kindtypeREAL1;
11698
11699     case FFECOM_rttypeCOMPLEX_F2C_:
11700     case FFECOM_rttypeCOMPLEX_GNU_:
11701       return FFEINFO_kindtypeREAL1;
11702
11703     case FFECOM_rttypeDOUBLE_:
11704     case FFECOM_rttypeDOUBLEREAL_:
11705       return FFEINFO_kindtypeREAL2;
11706
11707     case FFECOM_rttypeDBLCMPLX_F2C_:
11708     case FFECOM_rttypeDBLCMPLX_GNU_:
11709       return FFEINFO_kindtypeREAL2;
11710
11711     case FFECOM_rttypeCHARACTER_:
11712       return FFEINFO_kindtypeCHARACTER1;
11713
11714     default:
11715       return FFEINFO_kindtypeANY;
11716     }
11717 }
11718
11719 void
11720 ffecom_init_0 ()
11721 {
11722   tree endlink;
11723   int i;
11724   int j;
11725   tree t;
11726   tree field;
11727   ffetype type;
11728   ffetype base_type;
11729
11730   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11731      whether the compiler environment is buggy in known ways, some of which
11732      would, if not explicitly checked here, result in subtle bugs in g77.  */
11733
11734   if (ffe_is_do_internal_checks ())
11735     {
11736       static char names[][12]
11737         =
11738       {"bar", "bletch", "foo", "foobar"};
11739       char *name;
11740       unsigned long ul;
11741       double fl;
11742
11743       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11744                       (int (*)()) strcmp);
11745       if (name != (char *) &names[2])
11746         {
11747           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11748                   == NULL);
11749           abort ();
11750         }
11751
11752       ul = strtoul ("123456789", NULL, 10);
11753       if (ul != 123456789L)
11754         {
11755           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11756  in proj.h" == NULL);
11757           abort ();
11758         }
11759
11760       fl = atof ("56.789");
11761       if ((fl < 56.788) || (fl > 56.79))
11762         {
11763           assert ("atof not type double, fix your #include <stdio.h>"
11764                   == NULL);
11765           abort ();
11766         }
11767     }
11768
11769 #if FFECOM_GCC_INCLUDE
11770   ffecom_initialize_char_syntax_ ();
11771 #endif
11772
11773   ffecom_outer_function_decl_ = NULL_TREE;
11774   current_function_decl = NULL_TREE;
11775   named_labels = NULL_TREE;
11776   current_binding_level = NULL_BINDING_LEVEL;
11777   free_binding_level = NULL_BINDING_LEVEL;
11778   pushlevel (0);                /* make the binding_level structure for
11779                                    global names */
11780   global_binding_level = current_binding_level;
11781
11782   /* Define `int' and `char' first so that dbx will output them first.  */
11783
11784   integer_type_node = make_signed_type (INT_TYPE_SIZE);
11785   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11786                         integer_type_node));
11787
11788   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11789   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11790                         char_type_node));
11791
11792   long_integer_type_node = make_signed_type (LONG_TYPE_SIZE);
11793   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11794                         long_integer_type_node));
11795
11796   unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE);
11797   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11798                         unsigned_type_node));
11799
11800   long_unsigned_type_node = make_unsigned_type (LONG_TYPE_SIZE);
11801   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11802                         long_unsigned_type_node));
11803
11804   long_long_integer_type_node = make_signed_type (LONG_LONG_TYPE_SIZE);
11805   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11806                         long_long_integer_type_node));
11807
11808   long_long_unsigned_type_node = make_unsigned_type (LONG_LONG_TYPE_SIZE);
11809   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11810                         long_long_unsigned_type_node));
11811
11812   set_sizetype
11813     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11814
11815   error_mark_node = make_node (ERROR_MARK);
11816   TREE_TYPE (error_mark_node) = error_mark_node;
11817
11818   short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE);
11819   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11820                         short_integer_type_node));
11821
11822   short_unsigned_type_node = make_unsigned_type (SHORT_TYPE_SIZE);
11823   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11824                         short_unsigned_type_node));
11825
11826   /* Define both `signed char' and `unsigned char'.  */
11827   signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE);
11828   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11829                         signed_char_type_node));
11830
11831   unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11832   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11833                         unsigned_char_type_node));
11834
11835   float_type_node = make_node (REAL_TYPE);
11836   TYPE_PRECISION (float_type_node) = FLOAT_TYPE_SIZE;
11837   layout_type (float_type_node);
11838   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11839                         float_type_node));
11840
11841   double_type_node = make_node (REAL_TYPE);
11842   TYPE_PRECISION (double_type_node) = DOUBLE_TYPE_SIZE;
11843   layout_type (double_type_node);
11844   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11845                         double_type_node));
11846
11847   long_double_type_node = make_node (REAL_TYPE);
11848   TYPE_PRECISION (long_double_type_node) = LONG_DOUBLE_TYPE_SIZE;
11849   layout_type (long_double_type_node);
11850   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11851                         long_double_type_node));
11852
11853   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11854   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11855                         complex_integer_type_node));
11856
11857   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11858   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11859                         complex_float_type_node));
11860
11861   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11862   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11863                         complex_double_type_node));
11864
11865   complex_long_double_type_node = ffecom_make_complex_type_ (long_double_type_node);
11866   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11867                         complex_long_double_type_node));
11868
11869   integer_zero_node = build_int_2 (0, 0);
11870   TREE_TYPE (integer_zero_node) = integer_type_node;
11871   integer_one_node = build_int_2 (1, 0);
11872   TREE_TYPE (integer_one_node) = integer_type_node;
11873
11874   size_zero_node = build_int_2 (0, 0);
11875   TREE_TYPE (size_zero_node) = sizetype;
11876   size_one_node = build_int_2 (1, 0);
11877   TREE_TYPE (size_one_node) = sizetype;
11878
11879   void_type_node = make_node (VOID_TYPE);
11880   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11881                         void_type_node));
11882   layout_type (void_type_node); /* Uses integer_zero_node */
11883   /* We are not going to have real types in C with less than byte alignment,
11884      so we might as well not have any types that claim to have it.  */
11885   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11886
11887   null_pointer_node = build_int_2 (0, 0);
11888   TREE_TYPE (null_pointer_node) = build_pointer_type (void_type_node);
11889   layout_type (TREE_TYPE (null_pointer_node));
11890
11891   string_type_node = build_pointer_type (char_type_node);
11892
11893   ffecom_tree_fun_type_void
11894     = build_function_type (void_type_node, NULL_TREE);
11895
11896   ffecom_tree_ptr_to_fun_type_void
11897     = build_pointer_type (ffecom_tree_fun_type_void);
11898
11899   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11900
11901   float_ftype_float
11902     = build_function_type (float_type_node,
11903                            tree_cons (NULL_TREE, float_type_node, endlink));
11904
11905   double_ftype_double
11906     = build_function_type (double_type_node,
11907                            tree_cons (NULL_TREE, double_type_node, endlink));
11908
11909   ldouble_ftype_ldouble
11910     = build_function_type (long_double_type_node,
11911                            tree_cons (NULL_TREE, long_double_type_node,
11912                                       endlink));
11913
11914   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11915     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11916       {
11917         ffecom_tree_type[i][j] = NULL_TREE;
11918         ffecom_tree_fun_type[i][j] = NULL_TREE;
11919         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11920         ffecom_f2c_typecode_[i][j] = -1;
11921       }
11922
11923   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11924      to size FLOAT_TYPE_SIZE because they have to be the same size as
11925      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11926      Compiler options and other such stuff that change the ways these
11927      types are set should not affect this particular setup.  */
11928
11929   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11930     = t = make_signed_type (FLOAT_TYPE_SIZE);
11931   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11932                         t));
11933   type = ffetype_new ();
11934   base_type = type;
11935   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11936                     type);
11937   ffetype_set_ams (type,
11938                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11939                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11940   ffetype_set_star (base_type,
11941                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11942                     type);
11943   ffetype_set_kind (base_type, 1, type);
11944   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11945
11946   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11947     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11948   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11949                         t));
11950
11951   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11952     = t = make_signed_type (CHAR_TYPE_SIZE);
11953   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11954                         t));
11955   type = ffetype_new ();
11956   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11957                     type);
11958   ffetype_set_ams (type,
11959                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11960                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11961   ffetype_set_star (base_type,
11962                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11963                     type);
11964   ffetype_set_kind (base_type, 3, type);
11965   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11966
11967   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11968     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11969   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11970                         t));
11971
11972   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11973     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11974   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11975                         t));
11976   type = ffetype_new ();
11977   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11978                     type);
11979   ffetype_set_ams (type,
11980                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11981                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11982   ffetype_set_star (base_type,
11983                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11984                     type);
11985   ffetype_set_kind (base_type, 6, type);
11986   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11987
11988   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11989     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11990   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11991                         t));
11992
11993   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11994     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11995   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11996                         t));
11997   type = ffetype_new ();
11998   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11999                     type);
12000   ffetype_set_ams (type,
12001                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12002                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12003   ffetype_set_star (base_type,
12004                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
12005                     type);
12006   ffetype_set_kind (base_type, 2, type);
12007   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
12008
12009   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
12010     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
12011   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
12012                         t));
12013
12014 #if 0
12015   if (ffe_is_do_internal_checks ()
12016       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
12017       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
12018       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
12019       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
12020     {
12021       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
12022                LONG_TYPE_SIZE);
12023     }
12024 #endif
12025
12026   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
12027     = t = make_signed_type (FLOAT_TYPE_SIZE);
12028   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
12029                         t));
12030   type = ffetype_new ();
12031   base_type = type;
12032   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
12033                     type);
12034   ffetype_set_ams (type,
12035                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12036                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12037   ffetype_set_star (base_type,
12038                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
12039                     type);
12040   ffetype_set_kind (base_type, 1, type);
12041   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
12042
12043   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
12044     = t = make_signed_type (CHAR_TYPE_SIZE);
12045   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
12046                         t));
12047   type = ffetype_new ();
12048   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
12049                     type);
12050   ffetype_set_ams (type,
12051                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12052                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12053   ffetype_set_star (base_type,
12054                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
12055                     type);
12056   ffetype_set_kind (base_type, 3, type);
12057   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
12058
12059   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
12060     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
12061   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
12062                         t));
12063   type = ffetype_new ();
12064   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
12065                     type);
12066   ffetype_set_ams (type,
12067                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12068                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12069   ffetype_set_star (base_type,
12070                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
12071                     type);
12072   ffetype_set_kind (base_type, 6, type);
12073   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
12074
12075   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
12076     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
12077   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
12078                         t));
12079   type = ffetype_new ();
12080   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
12081                     type);
12082   ffetype_set_ams (type,
12083                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12084                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12085   ffetype_set_star (base_type,
12086                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
12087                     type);
12088   ffetype_set_kind (base_type, 2, type);
12089   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
12090
12091   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
12092     = t = make_node (REAL_TYPE);
12093   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
12094   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
12095                         t));
12096   layout_type (t);
12097   type = ffetype_new ();
12098   base_type = type;
12099   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
12100                     type);
12101   ffetype_set_ams (type,
12102                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12103                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12104   ffetype_set_star (base_type,
12105                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
12106                     type);
12107   ffetype_set_kind (base_type, 1, type);
12108   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
12109     = FFETARGET_f2cTYREAL;
12110   assert (ffetype_size (type) == sizeof (ffetargetReal1));
12111
12112   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
12113     = t = make_node (REAL_TYPE);
12114   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
12115   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
12116                         t));
12117   layout_type (t);
12118   type = ffetype_new ();
12119   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
12120                     type);
12121   ffetype_set_ams (type,
12122                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12123                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12124   ffetype_set_star (base_type,
12125                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
12126                     type);
12127   ffetype_set_kind (base_type, 2, type);
12128   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
12129     = FFETARGET_f2cTYDREAL;
12130   assert (ffetype_size (type) == sizeof (ffetargetReal2));
12131
12132   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
12133     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
12134   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
12135                         t));
12136   type = ffetype_new ();
12137   base_type = type;
12138   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
12139                     type);
12140   ffetype_set_ams (type,
12141                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12142                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12143   ffetype_set_star (base_type,
12144                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
12145                     type);
12146   ffetype_set_kind (base_type, 1, type);
12147   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
12148     = FFETARGET_f2cTYCOMPLEX;
12149   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
12150
12151   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
12152     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
12153   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
12154                         t));
12155   type = ffetype_new ();
12156   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
12157                     type);
12158   ffetype_set_ams (type,
12159                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12160                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12161   ffetype_set_star (base_type,
12162                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
12163                     type);
12164   ffetype_set_kind (base_type, 2,
12165                     type);
12166   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
12167     = FFETARGET_f2cTYDCOMPLEX;
12168   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
12169
12170   /* Make function and ptr-to-function types for non-CHARACTER types. */
12171
12172   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
12173     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
12174       {
12175         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
12176           {
12177             if (i == FFEINFO_basictypeINTEGER)
12178               {
12179                 /* Figure out the smallest INTEGER type that can hold
12180                    a pointer on this machine. */
12181                 if (GET_MODE_SIZE (TYPE_MODE (t))
12182                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
12183                   {
12184                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
12185                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
12186                             > GET_MODE_SIZE (TYPE_MODE (t))))
12187                       ffecom_pointer_kind_ = j;
12188                   }
12189               }
12190             else if (i == FFEINFO_basictypeCOMPLEX)
12191               t = void_type_node;
12192             /* For f2c compatibility, REAL functions are really
12193                implemented as DOUBLE PRECISION.  */
12194             else if ((i == FFEINFO_basictypeREAL)
12195                      && (j == FFEINFO_kindtypeREAL1))
12196               t = ffecom_tree_type
12197                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
12198
12199             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
12200                                                                   NULL_TREE);
12201             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
12202           }
12203       }
12204
12205   /* Set up pointer types.  */
12206
12207   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
12208     fatal ("no INTEGER type can hold a pointer on this configuration");
12209   else if (0 && ffe_is_do_internal_checks ())
12210     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
12211   type = ffetype_new ();
12212   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
12213                                   FFEINFO_kindtypeINTEGERDEFAULT),
12214                     7, type);
12215
12216   if (ffe_is_ugly_assign ())
12217     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
12218   else
12219     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
12220   if (0 && ffe_is_do_internal_checks ())
12221     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
12222
12223   ffecom_integer_type_node
12224     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
12225   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
12226                                       integer_zero_node);
12227   ffecom_integer_one_node = convert (ffecom_integer_type_node,
12228                                      integer_one_node);
12229
12230   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
12231      Turns out that by TYLONG, runtime/libI77/lio.h really means
12232      "whatever size an ftnint is".  For consistency and sanity,
12233      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
12234      all are INTEGER, which we also make out of whatever back-end
12235      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
12236      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
12237      accommodate machines like the Alpha.  Note that this suggests
12238      f2c and libf2c are missing a distinction perhaps needed on
12239      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
12240
12241   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
12242                             FFETARGET_f2cTYLONG);
12243   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
12244                             FFETARGET_f2cTYSHORT);
12245   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
12246                             FFETARGET_f2cTYINT1);
12247   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
12248                             FFETARGET_f2cTYQUAD);
12249   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
12250                             FFETARGET_f2cTYLOGICAL);
12251   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
12252                             FFETARGET_f2cTYLOGICAL2);
12253   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
12254                             FFETARGET_f2cTYLOGICAL1);
12255   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
12256                             FFETARGET_f2cTYQUAD /* ~~~ */);
12257
12258   /* CHARACTER stuff is all special-cased, so it is not handled in the above
12259      loop.  CHARACTER items are built as arrays of unsigned char.  */
12260
12261   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
12262     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
12263   type = ffetype_new ();
12264   base_type = type;
12265   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
12266                     FFEINFO_kindtypeCHARACTER1,
12267                     type);
12268   ffetype_set_ams (type,
12269                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12270                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12271   ffetype_set_kind (base_type, 1, type);
12272   assert (ffetype_size (type)
12273           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
12274
12275   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
12276     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
12277   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
12278     [FFEINFO_kindtypeCHARACTER1]
12279     = ffecom_tree_ptr_to_fun_type_void;
12280   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
12281     = FFETARGET_f2cTYCHAR;
12282
12283   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
12284     = 0;
12285
12286   /* Make multi-return-value type and fields. */
12287
12288   ffecom_multi_type_node_ = make_node (UNION_TYPE);
12289
12290   field = NULL_TREE;
12291
12292   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
12293     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
12294       {
12295         char name[30];
12296
12297         if (ffecom_tree_type[i][j] == NULL_TREE)
12298           continue;             /* Not supported. */
12299         sprintf (&name[0], "bt_%s_kt_%s",
12300                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
12301                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
12302         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
12303                                                  get_identifier (name),
12304                                                  ffecom_tree_type[i][j]);
12305         DECL_CONTEXT (ffecom_multi_fields_[i][j])
12306           = ffecom_multi_type_node_;
12307         DECL_FRAME_SIZE (ffecom_multi_fields_[i][j]) = 0;
12308         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
12309         field = ffecom_multi_fields_[i][j];
12310       }
12311
12312   TYPE_FIELDS (ffecom_multi_type_node_) = field;
12313   layout_type (ffecom_multi_type_node_);
12314
12315   /* Subroutines usually return integer because they might have alternate
12316      returns. */
12317
12318   ffecom_tree_subr_type
12319     = build_function_type (integer_type_node, NULL_TREE);
12320   ffecom_tree_ptr_to_subr_type
12321     = build_pointer_type (ffecom_tree_subr_type);
12322   ffecom_tree_blockdata_type
12323     = build_function_type (void_type_node, NULL_TREE);
12324
12325   builtin_function ("__builtin_sqrtf", float_ftype_float,
12326                     BUILT_IN_FSQRT, "sqrtf");
12327   builtin_function ("__builtin_fsqrt", double_ftype_double,
12328                     BUILT_IN_FSQRT, "sqrt");
12329   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
12330                     BUILT_IN_FSQRT, "sqrtl");
12331   builtin_function ("__builtin_sinf", float_ftype_float,
12332                     BUILT_IN_SIN, "sinf");
12333   builtin_function ("__builtin_sin", double_ftype_double,
12334                     BUILT_IN_SIN, "sin");
12335   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
12336                     BUILT_IN_SIN, "sinl");
12337   builtin_function ("__builtin_cosf", float_ftype_float,
12338                     BUILT_IN_COS, "cosf");
12339   builtin_function ("__builtin_cos", double_ftype_double,
12340                     BUILT_IN_COS, "cos");
12341   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
12342                     BUILT_IN_COS, "cosl");
12343
12344 #if BUILT_FOR_270
12345   pedantic_lvalues = FALSE;
12346 #endif
12347
12348   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
12349                          FFECOM_f2cINTEGER,
12350                          "integer");
12351   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
12352                          FFECOM_f2cADDRESS,
12353                          "address");
12354   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
12355                          FFECOM_f2cREAL,
12356                          "real");
12357   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
12358                          FFECOM_f2cDOUBLEREAL,
12359                          "doublereal");
12360   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
12361                          FFECOM_f2cCOMPLEX,
12362                          "complex");
12363   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
12364                          FFECOM_f2cDOUBLECOMPLEX,
12365                          "doublecomplex");
12366   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
12367                          FFECOM_f2cLONGINT,
12368                          "longint");
12369   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
12370                          FFECOM_f2cLOGICAL,
12371                          "logical");
12372   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
12373                          FFECOM_f2cFLAG,
12374                          "flag");
12375   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
12376                          FFECOM_f2cFTNLEN,
12377                          "ftnlen");
12378   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
12379                          FFECOM_f2cFTNINT,
12380                          "ftnint");
12381
12382   ffecom_f2c_ftnlen_zero_node
12383     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
12384
12385   ffecom_f2c_ftnlen_one_node
12386     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
12387
12388   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
12389   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
12390
12391   ffecom_f2c_ptr_to_ftnlen_type_node
12392     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
12393
12394   ffecom_f2c_ptr_to_ftnint_type_node
12395     = build_pointer_type (ffecom_f2c_ftnint_type_node);
12396
12397   ffecom_f2c_ptr_to_integer_type_node
12398     = build_pointer_type (ffecom_f2c_integer_type_node);
12399
12400   ffecom_f2c_ptr_to_real_type_node
12401     = build_pointer_type (ffecom_f2c_real_type_node);
12402
12403   ffecom_float_zero_ = build_real (float_type_node, dconst0);
12404   ffecom_double_zero_ = build_real (double_type_node, dconst0);
12405   {
12406     REAL_VALUE_TYPE point_5;
12407
12408 #ifdef REAL_ARITHMETIC
12409     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12410 #else
12411     point_5 = .5;
12412 #endif
12413     ffecom_float_half_ = build_real (float_type_node, point_5);
12414     ffecom_double_half_ = build_real (double_type_node, point_5);
12415   }
12416
12417   /* Do "extern int xargc;".  */
12418
12419   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12420                                    get_identifier ("xargc"),
12421                                    integer_type_node);
12422   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12423   TREE_STATIC (ffecom_tree_xargc_) = 1;
12424   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12425   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12426   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12427
12428 #if 0   /* This is being fixed, and seems to be working now. */
12429   if ((FLOAT_TYPE_SIZE != 32)
12430       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12431     {
12432       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12433                (int) FLOAT_TYPE_SIZE);
12434       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12435           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12436       warning ("properly unless they all are 32 bits wide.");
12437       warning ("Please keep this in mind before you report bugs.  g77 should");
12438       warning ("support non-32-bit machines better as of version 0.6.");
12439     }
12440 #endif
12441
12442 #if 0   /* Code in ste.c that would crash has been commented out. */
12443   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12444       < TYPE_PRECISION (string_type_node))
12445     /* I/O will probably crash.  */
12446     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12447              TYPE_PRECISION (string_type_node),
12448              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12449 #endif
12450
12451 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12452   if (TYPE_PRECISION (ffecom_integer_type_node)
12453       < TYPE_PRECISION (string_type_node))
12454     /* ASSIGN 10 TO I will crash.  */
12455     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12456  ASSIGN statement might fail",
12457              TYPE_PRECISION (string_type_node),
12458              TYPE_PRECISION (ffecom_integer_type_node));
12459 #endif
12460 }
12461
12462 #endif
12463 /* ffecom_init_2 -- Initialize
12464
12465    ffecom_init_2();  */
12466
12467 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12468 void
12469 ffecom_init_2 ()
12470 {
12471   assert (ffecom_outer_function_decl_ == NULL_TREE);
12472   assert (current_function_decl == NULL_TREE);
12473   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12474
12475   ffecom_master_arglist_ = NULL;
12476   ++ffecom_num_fns_;
12477   ffecom_latest_temp_ = NULL;
12478   ffecom_primary_entry_ = NULL;
12479   ffecom_is_altreturning_ = FALSE;
12480   ffecom_func_result_ = NULL_TREE;
12481   ffecom_multi_retval_ = NULL_TREE;
12482 }
12483
12484 #endif
12485 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12486
12487    tree t;
12488    ffebld expr;  // FFE opITEM list.
12489    tree = ffecom_list_expr(expr);
12490
12491    List of actual args is transformed into corresponding gcc backend list.  */
12492
12493 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12494 tree
12495 ffecom_list_expr (ffebld expr)
12496 {
12497   tree list;
12498   tree *plist = &list;
12499   tree trail = NULL_TREE;       /* Append char length args here. */
12500   tree *ptrail = &trail;
12501   tree length;
12502
12503   while (expr != NULL)
12504     {
12505       *plist
12506         = build_tree_list (NULL_TREE, ffecom_arg_expr (ffebld_head (expr),
12507                                                        &length));
12508       plist = &TREE_CHAIN (*plist);
12509       expr = ffebld_trail (expr);
12510       if (length != NULL_TREE)
12511         {
12512           *ptrail = build_tree_list (NULL_TREE, length);
12513           ptrail = &TREE_CHAIN (*ptrail);
12514         }
12515     }
12516
12517   *plist = trail;
12518
12519   return list;
12520 }
12521
12522 #endif
12523 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12524
12525    tree t;
12526    ffebld expr;  // FFE opITEM list.
12527    tree = ffecom_list_ptr_to_expr(expr);
12528
12529    List of actual args is transformed into corresponding gcc backend list for
12530    use in calling an external procedure (vs. a statement function).  */
12531
12532 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12533 tree
12534 ffecom_list_ptr_to_expr (ffebld expr)
12535 {
12536   tree list;
12537   tree *plist = &list;
12538   tree trail = NULL_TREE;       /* Append char length args here. */
12539   tree *ptrail = &trail;
12540   tree length;
12541
12542   while (expr != NULL)
12543     {
12544       *plist
12545         = build_tree_list (NULL_TREE,
12546                            ffecom_arg_ptr_to_expr (ffebld_head (expr),
12547                                                    &length));
12548       plist = &TREE_CHAIN (*plist);
12549       expr = ffebld_trail (expr);
12550       if (length != NULL_TREE)
12551         {
12552           *ptrail = build_tree_list (NULL_TREE, length);
12553           ptrail = &TREE_CHAIN (*ptrail);
12554         }
12555     }
12556
12557   *plist = trail;
12558
12559   return list;
12560 }
12561
12562 #endif
12563 /* Obtain gcc's LABEL_DECL tree for label.  */
12564
12565 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12566 tree
12567 ffecom_lookup_label (ffelab label)
12568 {
12569   tree glabel;
12570
12571   if (ffelab_hook (label) == NULL_TREE)
12572     {
12573       char labelname[16];
12574
12575       switch (ffelab_type (label))
12576         {
12577         case FFELAB_typeLOOPEND:
12578         case FFELAB_typeNOTLOOP:
12579         case FFELAB_typeENDIF:
12580           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12581           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12582                                void_type_node);
12583           DECL_CONTEXT (glabel) = current_function_decl;
12584           DECL_MODE (glabel) = VOIDmode;
12585           break;
12586
12587         case FFELAB_typeFORMAT:
12588           push_obstacks_nochange ();
12589           end_temporary_allocation ();
12590
12591           glabel = build_decl (VAR_DECL,
12592                                ffecom_get_invented_identifier
12593                                ("__g77_format_%d", NULL,
12594                                 (int) ffelab_value (label)),
12595                                build_type_variant (build_array_type
12596                                                    (char_type_node,
12597                                                     NULL_TREE),
12598                                                    1, 0));
12599           TREE_CONSTANT (glabel) = 1;
12600           TREE_STATIC (glabel) = 1;
12601           DECL_CONTEXT (glabel) = 0;
12602           DECL_INITIAL (glabel) = NULL;
12603           make_decl_rtl (glabel, NULL, 0);
12604           expand_decl (glabel);
12605
12606           resume_temporary_allocation ();
12607           pop_obstacks ();
12608
12609           break;
12610
12611         case FFELAB_typeANY:
12612           glabel = error_mark_node;
12613           break;
12614
12615         default:
12616           assert ("bad label type" == NULL);
12617           glabel = NULL;
12618           break;
12619         }
12620       ffelab_set_hook (label, glabel);
12621     }
12622   else
12623     {
12624       glabel = ffelab_hook (label);
12625     }
12626
12627   return glabel;
12628 }
12629
12630 #endif
12631 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12632    a single source specification (as in the fourth argument of MVBITS).
12633    If the type is NULL_TREE, the type of lhs is used to make the type of
12634    the MODIFY_EXPR.  */
12635
12636 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12637 tree
12638 ffecom_modify (tree newtype, tree lhs,
12639                tree rhs)
12640 {
12641   if (lhs == error_mark_node || rhs == error_mark_node)
12642     return error_mark_node;
12643
12644   if (newtype == NULL_TREE)
12645     newtype = TREE_TYPE (lhs);
12646
12647   if (TREE_SIDE_EFFECTS (lhs))
12648     lhs = stabilize_reference (lhs);
12649
12650   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12651 }
12652
12653 #endif
12654
12655 /* Register source file name.  */
12656
12657 void
12658 ffecom_file (char *name)
12659 {
12660 #if FFECOM_GCC_INCLUDE
12661   ffecom_file_ (name);
12662 #endif
12663 }
12664
12665 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12666
12667    ffestorag st;
12668    ffecom_notify_init_storage(st);
12669
12670    Gets called when all possible units in an aggregate storage area (a LOCAL
12671    with equivalences or a COMMON) have been initialized.  The initialization
12672    info either is in ffestorag_init or, if that is NULL,
12673    ffestorag_accretion:
12674
12675    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12676    even for an array if the array is one element in length!
12677
12678    ffestorag_accretion will contain an opACCTER.  It is much like an
12679    opARRTER except it has an ffebit object in it instead of just a size.
12680    The back end can use the info in the ffebit object, if it wants, to
12681    reduce the amount of actual initialization, but in any case it should
12682    kill the ffebit object when done.  Also, set accretion to NULL but
12683    init to a non-NULL value.
12684
12685    After performing initialization, DO NOT set init to NULL, because that'll
12686    tell the front end it is ok for more initialization to happen.  Instead,
12687    set init to an opANY expression or some such thing that you can use to
12688    tell that you've already initialized the object.
12689
12690    27-Oct-91  JCB  1.1
12691       Support two-pass FFE.  */
12692
12693 void
12694 ffecom_notify_init_storage (ffestorag st)
12695 {
12696   ffebld init;                  /* The initialization expression. */
12697 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12698   ffetargetOffset size;         /* The size of the entity. */
12699 #endif
12700
12701   if (ffestorag_init (st) == NULL)
12702     {
12703       init = ffestorag_accretion (st);
12704       assert (init != NULL);
12705       ffestorag_set_accretion (st, NULL);
12706       ffestorag_set_accretes (st, 0);
12707
12708 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12709       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12710       size = ffebld_accter_size (init);
12711       ffebit_kill (ffebld_accter_bits (init));
12712       ffebld_set_op (init, FFEBLD_opARRTER);
12713       ffebld_set_arrter (init, ffebld_accter (init));
12714       ffebld_arrter_set_size (init, size);
12715 #endif
12716
12717 #if FFECOM_TWOPASS
12718       ffestorag_set_init (st, init);
12719 #endif
12720     }
12721 #if FFECOM_ONEPASS
12722   else
12723     init = ffestorag_init (st);
12724 #endif
12725
12726 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12727   ffestorag_set_init (st, ffebld_new_any ());
12728
12729   if (ffebld_op (init) == FFEBLD_opANY)
12730     return;                     /* Oh, we already did this! */
12731
12732 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12733   {
12734     ffesymbol s;
12735
12736     if (ffestorag_symbol (st) != NULL)
12737       s = ffestorag_symbol (st);
12738     else
12739       s = ffestorag_typesymbol (st);
12740
12741     fprintf (dmpout, "= initialize_storage \"%s\" ",
12742              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12743     ffebld_dump (init);
12744     fputc ('\n', dmpout);
12745   }
12746 #endif
12747
12748 #endif /* if FFECOM_ONEPASS */
12749 }
12750
12751 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12752
12753    ffesymbol s;
12754    ffecom_notify_init_symbol(s);
12755
12756    Gets called when all possible units in a symbol (not placed in COMMON
12757    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12758    have been initialized.  The initialization info either is in
12759    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12760
12761    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12762    even for an array if the array is one element in length!
12763
12764    ffesymbol_accretion will contain an opACCTER.  It is much like an
12765    opARRTER except it has an ffebit object in it instead of just a size.
12766    The back end can use the info in the ffebit object, if it wants, to
12767    reduce the amount of actual initialization, but in any case it should
12768    kill the ffebit object when done.  Also, set accretion to NULL but
12769    init to a non-NULL value.
12770
12771    After performing initialization, DO NOT set init to NULL, because that'll
12772    tell the front end it is ok for more initialization to happen.  Instead,
12773    set init to an opANY expression or some such thing that you can use to
12774    tell that you've already initialized the object.
12775
12776    27-Oct-91  JCB  1.1
12777       Support two-pass FFE.  */
12778
12779 void
12780 ffecom_notify_init_symbol (ffesymbol s)
12781 {
12782   ffebld init;                  /* The initialization expression. */
12783 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12784   ffetargetOffset size;         /* The size of the entity. */
12785 #endif
12786
12787   if (ffesymbol_storage (s) == NULL)
12788     return;                     /* Do nothing until COMMON/EQUIVALENCE
12789                                    possibilities checked. */
12790
12791   if ((ffesymbol_init (s) == NULL)
12792       && ((init = ffesymbol_accretion (s)) != NULL))
12793     {
12794       ffesymbol_set_accretion (s, NULL);
12795       ffesymbol_set_accretes (s, 0);
12796
12797 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12798       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12799       size = ffebld_accter_size (init);
12800       ffebit_kill (ffebld_accter_bits (init));
12801       ffebld_set_op (init, FFEBLD_opARRTER);
12802       ffebld_set_arrter (init, ffebld_accter (init));
12803       ffebld_arrter_set_size (init, size);
12804 #endif
12805
12806 #if FFECOM_TWOPASS
12807       ffesymbol_set_init (s, init);
12808 #endif
12809     }
12810 #if FFECOM_ONEPASS
12811   else
12812     init = ffesymbol_init (s);
12813 #endif
12814
12815 #if FFECOM_ONEPASS
12816   ffesymbol_set_init (s, ffebld_new_any ());
12817
12818   if (ffebld_op (init) == FFEBLD_opANY)
12819     return;                     /* Oh, we already did this! */
12820
12821 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12822   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12823   ffebld_dump (init);
12824   fputc ('\n', dmpout);
12825 #endif
12826
12827 #endif /* if FFECOM_ONEPASS */
12828 }
12829
12830 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12831
12832    ffesymbol s;
12833    ffecom_notify_primary_entry(s);
12834
12835    Gets called when implicit or explicit PROGRAM statement seen or when
12836    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12837    global symbol that serves as the entry point.  */
12838
12839 void
12840 ffecom_notify_primary_entry (ffesymbol s)
12841 {
12842   ffecom_primary_entry_ = s;
12843   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12844
12845   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12846       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12847     ffecom_primary_entry_is_proc_ = TRUE;
12848   else
12849     ffecom_primary_entry_is_proc_ = FALSE;
12850
12851   if (!ffe_is_silent ())
12852     {
12853       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12854         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12855       else
12856         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12857     }
12858
12859 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12860   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12861     {
12862       ffebld list;
12863       ffebld arg;
12864
12865       for (list = ffesymbol_dummyargs (s);
12866            list != NULL;
12867            list = ffebld_trail (list))
12868         {
12869           arg = ffebld_head (list);
12870           if (ffebld_op (arg) == FFEBLD_opSTAR)
12871             {
12872               ffecom_is_altreturning_ = TRUE;
12873               break;
12874             }
12875         }
12876     }
12877 #endif
12878 }
12879
12880 FILE *
12881 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12882 {
12883 #if FFECOM_GCC_INCLUDE
12884   return ffecom_open_include_ (name, l, c);
12885 #else
12886   return fopen (name, "r");
12887 #endif
12888 }
12889
12890 /* Clean up after making automatically popped call-arg temps.
12891
12892    Call this in pairs with push_calltemps around calls to
12893    ffecom_arg_ptr_to_expr if the latter might use temporaries.
12894    Any temporaries made within the outermost sequence of
12895    push_calltemps and pop_calltemps, that are marked as "auto-pop"
12896    meaning they won't be explicitly popped (freed), are popped
12897    at this point so they can be reused later.
12898
12899    NOTE: when called by ffecom_gen_sfuncdef_, ffecom_pending_calls_
12900    should come in == 1, and all of the in-use auto-pop temps
12901    should have DECL_CONTEXT (temp->t) == current_function_decl.
12902    Moreover, these temps should _never_ be re-used in future
12903    calls to ffecom_push_tempvar -- since current_function_decl will
12904    never be the same again.
12905
12906    SO, it could be a minor win in terms of compile time to just
12907    strip these temps off the list.  That is, if the above assumptions
12908    are correct, just remove from the list of temps any temp
12909    that is both in-use and has DECL_CONTEXT (temp->t)
12910    == current_function_decl, when called from ffecom_gen_sfuncdef_.  */
12911
12912 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12913 void
12914 ffecom_pop_calltemps ()
12915 {
12916   ffecomTemp_ temp;
12917
12918   assert (ffecom_pending_calls_ > 0);
12919
12920   if (--ffecom_pending_calls_ == 0)
12921     for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next)
12922       if (temp->auto_pop)
12923         temp->in_use = FALSE;
12924 }
12925
12926 #endif
12927 /* Mark latest temp with given tree as no longer in use.  */
12928
12929 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12930 void
12931 ffecom_pop_tempvar (tree t)
12932 {
12933   ffecomTemp_ temp;
12934
12935   for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next)
12936     if (temp->in_use && (temp->t == t))
12937       {
12938         assert (!temp->auto_pop);
12939         temp->in_use = FALSE;
12940         return;
12941       }
12942     else
12943       assert (temp->t != t);
12944
12945   assert ("couldn't ffecom_pop_tempvar!" != NULL);
12946 }
12947
12948 #endif
12949 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12950
12951    tree t;
12952    ffebld expr;  // FFE expression.
12953    tree = ffecom_ptr_to_expr(expr);
12954
12955    Like ffecom_expr, but sticks address-of in front of most things.  */
12956
12957 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12958 tree
12959 ffecom_ptr_to_expr (ffebld expr)
12960 {
12961   tree item;
12962   ffeinfoBasictype bt;
12963   ffeinfoKindtype kt;
12964   ffesymbol s;
12965
12966   assert (expr != NULL);
12967
12968   switch (ffebld_op (expr))
12969     {
12970     case FFEBLD_opSYMTER:
12971       s = ffebld_symter (expr);
12972       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12973         {
12974           ffecomGfrt ix;
12975
12976           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12977           assert (ix != FFECOM_gfrt);
12978           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12979             {
12980               ffecom_make_gfrt_ (ix);
12981               item = ffecom_gfrt_[ix];
12982             }
12983         }
12984       else
12985         {
12986           item = ffesymbol_hook (s).decl_tree;
12987           if (item == NULL_TREE)
12988             {
12989               s = ffecom_sym_transform_ (s);
12990               item = ffesymbol_hook (s).decl_tree;
12991             }
12992         }
12993       assert (item != NULL);
12994       if (item == error_mark_node)
12995         return item;
12996       if (!ffesymbol_hook (s).addr)
12997         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12998                          item);
12999       return item;
13000
13001     case FFEBLD_opARRAYREF:
13002       {
13003         ffebld dims[FFECOM_dimensionsMAX];
13004         tree array;
13005         int i;
13006
13007         item = ffecom_ptr_to_expr (ffebld_left (expr));
13008
13009         if (item == error_mark_node)
13010           return item;
13011
13012         if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING)
13013             && !mark_addressable (item))
13014           return error_mark_node;       /* Make sure non-const ref is to
13015                                            non-reg. */
13016
13017         /* Build up ARRAY_REFs in reverse order (since we're column major
13018            here in Fortran land). */
13019
13020         for (i = 0, expr = ffebld_right (expr);
13021              expr != NULL;
13022              expr = ffebld_trail (expr))
13023           dims[i++] = ffebld_head (expr);
13024
13025         for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
13026              i >= 0;
13027              --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
13028           {
13029             item
13030               = ffecom_2 (PLUS_EXPR,
13031                           build_pointer_type (TREE_TYPE (array)),
13032                           item,
13033                           size_binop (MULT_EXPR,
13034                                       size_in_bytes (TREE_TYPE (array)),
13035                                       convert (sizetype,
13036                                                fold (build (MINUS_EXPR,
13037                                                      TREE_TYPE (TYPE_MIN_VALUE (TYPE_DOMAIN (array))),
13038                                                      ffecom_expr (dims[i]),
13039                                                      TYPE_MIN_VALUE (TYPE_DOMAIN (array)))))));
13040           }
13041       }
13042       return item;
13043
13044     case FFEBLD_opCONTER:
13045
13046       bt = ffeinfo_basictype (ffebld_info (expr));
13047       kt = ffeinfo_kindtype (ffebld_info (expr));
13048
13049       item = ffecom_constantunion (&ffebld_constant_union
13050                                    (ffebld_conter (expr)), bt, kt,
13051                                    ffecom_tree_type[bt][kt]);
13052       if (item == error_mark_node)
13053         return error_mark_node;
13054       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
13055                        item);
13056       return item;
13057
13058     case FFEBLD_opANY:
13059       return error_mark_node;
13060
13061     default:
13062       assert (ffecom_pending_calls_ > 0);
13063
13064       bt = ffeinfo_basictype (ffebld_info (expr));
13065       kt = ffeinfo_kindtype (ffebld_info (expr));
13066
13067       item = ffecom_expr (expr);
13068       if (item == error_mark_node)
13069         return error_mark_node;
13070
13071       /* The back end currently optimizes a bit too zealously for us, in that
13072          we fail JCB001 if the following block of code is omitted.  It checks
13073          to see if the transformed expression is a symbol or array reference,
13074          and encloses it in a SAVE_EXPR if that is the case.  */
13075
13076       STRIP_NOPS (item);
13077       if ((TREE_CODE (item) == VAR_DECL)
13078           || (TREE_CODE (item) == PARM_DECL)
13079           || (TREE_CODE (item) == RESULT_DECL)
13080           || (TREE_CODE (item) == INDIRECT_REF)
13081           || (TREE_CODE (item) == ARRAY_REF)
13082           || (TREE_CODE (item) == COMPONENT_REF)
13083 #ifdef OFFSET_REF
13084           || (TREE_CODE (item) == OFFSET_REF)
13085 #endif
13086           || (TREE_CODE (item) == BUFFER_REF)
13087           || (TREE_CODE (item) == REALPART_EXPR)
13088           || (TREE_CODE (item) == IMAGPART_EXPR))
13089         {
13090           item = ffecom_save_tree (item);
13091         }
13092
13093       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
13094                        item);
13095       return item;
13096     }
13097
13098   assert ("fall-through error" == NULL);
13099   return error_mark_node;
13100 }
13101
13102 #endif
13103 /* Prepare to make call-arg temps.
13104
13105    Call this in pairs with pop_calltemps around calls to
13106    ffecom_arg_ptr_to_expr if the latter might use temporaries.  */
13107
13108 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13109 void
13110 ffecom_push_calltemps ()
13111 {
13112   ffecom_pending_calls_++;
13113 }
13114
13115 #endif
13116 /* Obtain a temp var with given data type.
13117
13118    Returns a VAR_DECL tree of a currently (that is, at the current
13119    statement being compiled) not in use and having the given data type,
13120    making a new one if necessary.  size is FFETARGET_charactersizeNONE
13121    for a non-CHARACTER type or >= 0 for a CHARACTER type.  elements is
13122    -1 for a scalar or > 0 for an array of type.  auto_pop is TRUE if
13123    ffecom_pop_tempvar won't be called, meaning temp will be freed
13124    when #pending calls goes to zero.  */
13125
13126 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13127 tree
13128 ffecom_push_tempvar (tree type, ffetargetCharacterSize size, int elements,
13129                      bool auto_pop)
13130 {
13131   ffecomTemp_ temp;
13132   int yes;
13133   tree t;
13134   static int mynumber;
13135
13136   assert (!auto_pop || (ffecom_pending_calls_ > 0));
13137
13138   if (type == error_mark_node)
13139     return error_mark_node;
13140
13141   for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next)
13142     {
13143       if (temp->in_use
13144           || (temp->type != type)
13145           || (temp->size != size)
13146           || (temp->elements != elements)
13147           || (DECL_CONTEXT (temp->t) != current_function_decl))
13148         continue;
13149
13150       temp->in_use = TRUE;
13151       temp->auto_pop = auto_pop;
13152       return temp->t;
13153     }
13154
13155   /* Create a new temp. */
13156
13157   yes = suspend_momentary ();
13158
13159   if (size != FFETARGET_charactersizeNONE)
13160     type = build_array_type (type,
13161                              build_range_type (ffecom_f2c_ftnlen_type_node,
13162                                                ffecom_f2c_ftnlen_one_node,
13163                                                build_int_2 (size, 0)));
13164   if (elements != -1)
13165     type = build_array_type (type,
13166                              build_range_type (integer_type_node,
13167                                                integer_zero_node,
13168                                                build_int_2 (elements - 1,
13169                                                             0)));
13170   t = build_decl (VAR_DECL,
13171                   ffecom_get_invented_identifier ("__g77_expr_%d", NULL,
13172                                                   mynumber++),
13173                   type);
13174   {     /* ~~~~ kludge alert here!!! else temp gets reused outside
13175            a compound-statement sequence.... */
13176     extern tree sequence_rtl_expr;
13177     tree back_end_bug = sequence_rtl_expr;
13178
13179     sequence_rtl_expr = NULL_TREE;
13180
13181     t = start_decl (t, FALSE);
13182     finish_decl (t, NULL_TREE, FALSE);
13183
13184     sequence_rtl_expr = back_end_bug;
13185   }
13186
13187   resume_momentary (yes);
13188
13189   temp = malloc_new_kp (ffe_pool_program_unit (), "ffecomTemp_",
13190                         sizeof (*temp));
13191
13192   temp->next = ffecom_latest_temp_;
13193   temp->type = type;
13194   temp->t = t;
13195   temp->size = size;
13196   temp->elements = elements;
13197   temp->in_use = TRUE;
13198   temp->auto_pop = auto_pop;
13199
13200   ffecom_latest_temp_ = temp;
13201
13202   return t;
13203 }
13204
13205 #endif
13206 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13207
13208    tree rtn;  // NULL_TREE means use expand_null_return()
13209    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13210    rtn = ffecom_return_expr(expr);
13211
13212    Based on the program unit type and other info (like return function
13213    type, return master function type when alternate ENTRY points,
13214    whether subroutine has any alternate RETURN points, etc), returns the
13215    appropriate expression to be returned to the caller, or NULL_TREE
13216    meaning no return value or the caller expects it to be returned somewhere
13217    else (which is handled by other parts of this module).  */
13218
13219 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13220 tree
13221 ffecom_return_expr (ffebld expr)
13222 {
13223   tree rtn;
13224
13225   switch (ffecom_primary_entry_kind_)
13226     {
13227     case FFEINFO_kindPROGRAM:
13228     case FFEINFO_kindBLOCKDATA:
13229       rtn = NULL_TREE;
13230       break;
13231
13232     case FFEINFO_kindSUBROUTINE:
13233       if (!ffecom_is_altreturning_)
13234         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13235       else if (expr == NULL)
13236         rtn = integer_zero_node;
13237       else
13238         rtn = ffecom_expr (expr);
13239       break;
13240
13241     case FFEINFO_kindFUNCTION:
13242       if ((ffecom_multi_retval_ != NULL_TREE)
13243           || (ffesymbol_basictype (ffecom_primary_entry_)
13244               == FFEINFO_basictypeCHARACTER)
13245           || ((ffesymbol_basictype (ffecom_primary_entry_)
13246                == FFEINFO_basictypeCOMPLEX)
13247               && (ffecom_num_entrypoints_ == 0)
13248               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13249         {                       /* Value is returned by direct assignment
13250                                    into (implicit) dummy. */
13251           rtn = NULL_TREE;
13252           break;
13253         }
13254       rtn = ffecom_func_result_;
13255 #if 0
13256       /* Spurious error if RETURN happens before first reference!  So elide
13257          this code.  In particular, for debugging registry, rtn should always
13258          be non-null after all, but TREE_USED won't be set until we encounter
13259          a reference in the code.  Perfectly okay (but weird) code that,
13260          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13261          this diagnostic for no reason.  Have people use -O -Wuninitialized
13262          and leave it to the back end to find obviously weird cases.  */
13263
13264       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13265          situation; if the return value has never been referenced, it won't
13266          have a tree under 2pass mode. */
13267       if ((rtn == NULL_TREE)
13268           || !TREE_USED (rtn))
13269         {
13270           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13271           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13272                        ffesymbol_where_column (ffecom_primary_entry_));
13273           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13274                                          (ffecom_primary_entry_)));
13275           ffebad_finish ();
13276         }
13277 #endif
13278       break;
13279
13280     default:
13281       assert ("bad unit kind" == NULL);
13282     case FFEINFO_kindANY:
13283       rtn = error_mark_node;
13284       break;
13285     }
13286
13287   return rtn;
13288 }
13289
13290 #endif
13291 /* Do save_expr only if tree is not error_mark_node.  */
13292
13293 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13294 tree
13295 ffecom_save_tree (tree t)
13296 {
13297   return save_expr (t);
13298 }
13299 #endif
13300
13301 /* Public entry point for front end to access start_decl.  */
13302
13303 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13304 tree
13305 ffecom_start_decl (tree decl, bool is_initialized)
13306 {
13307   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13308   return start_decl (decl, FALSE);
13309 }
13310
13311 #endif
13312 /* ffecom_sym_commit -- Symbol's state being committed to reality
13313
13314    ffesymbol s;
13315    ffecom_sym_commit(s);
13316
13317    Does whatever the backend needs when a symbol is committed after having
13318    been backtrackable for a period of time.  */
13319
13320 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13321 void
13322 ffecom_sym_commit (ffesymbol s UNUSED)
13323 {
13324   assert (!ffesymbol_retractable ());
13325 }
13326
13327 #endif
13328 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13329
13330    ffecom_sym_end_transition();
13331
13332    Does backend-specific stuff and also calls ffest_sym_end_transition
13333    to do the necessary FFE stuff.
13334
13335    Backtracking is never enabled when this fn is called, so don't worry
13336    about it.  */
13337
13338 ffesymbol
13339 ffecom_sym_end_transition (ffesymbol s)
13340 {
13341   ffestorag st;
13342
13343   assert (!ffesymbol_retractable ());
13344
13345   s = ffest_sym_end_transition (s);
13346
13347 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13348   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13349       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13350     {
13351       ffecom_list_blockdata_
13352         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13353                                               FFEINTRIN_specNONE,
13354                                               FFEINTRIN_impNONE),
13355                            ffecom_list_blockdata_);
13356     }
13357 #endif
13358
13359   /* This is where we finally notice that a symbol has partial initialization
13360      and finalize it. */
13361
13362   if (ffesymbol_accretion (s) != NULL)
13363     {
13364       assert (ffesymbol_init (s) == NULL);
13365       ffecom_notify_init_symbol (s);
13366     }
13367   else if (((st = ffesymbol_storage (s)) != NULL)
13368            && ((st = ffestorag_parent (st)) != NULL)
13369            && (ffestorag_accretion (st) != NULL))
13370     {
13371       assert (ffestorag_init (st) == NULL);
13372       ffecom_notify_init_storage (st);
13373     }
13374
13375 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13376   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13377       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13378       && (ffesymbol_storage (s) != NULL))
13379     {
13380       ffecom_list_common_
13381         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13382                                               FFEINTRIN_specNONE,
13383                                               FFEINTRIN_impNONE),
13384                            ffecom_list_common_);
13385     }
13386 #endif
13387
13388   return s;
13389 }
13390
13391 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13392
13393    ffecom_sym_exec_transition();
13394
13395    Does backend-specific stuff and also calls ffest_sym_exec_transition
13396    to do the necessary FFE stuff.
13397
13398    See the long-winded description in ffecom_sym_learned for info
13399    on handling the situation where backtracking is inhibited.  */
13400
13401 ffesymbol
13402 ffecom_sym_exec_transition (ffesymbol s)
13403 {
13404   s = ffest_sym_exec_transition (s);
13405
13406   return s;
13407 }
13408
13409 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13410
13411    ffesymbol s;
13412    s = ffecom_sym_learned(s);
13413
13414    Called when a new symbol is seen after the exec transition or when more
13415    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13416    it arrives here is that all its latest info is updated already, so its
13417    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13418    field filled in if its gone through here or exec_transition first, and
13419    so on.
13420
13421    The backend probably wants to check ffesymbol_retractable() to see if
13422    backtracking is in effect.  If so, the FFE's changes to the symbol may
13423    be retracted (undone) or committed (ratified), at which time the
13424    appropriate ffecom_sym_retract or _commit function will be called
13425    for that function.
13426
13427    If the backend has its own backtracking mechanism, great, use it so that
13428    committal is a simple operation.  Though it doesn't make much difference,
13429    I suppose: the reason for tentative symbol evolution in the FFE is to
13430    enable error detection in weird incorrect statements early and to disable
13431    incorrect error detection on a correct statement.  The backend is not
13432    likely to introduce any information that'll get involved in these
13433    considerations, so it is probably just fine that the implementation
13434    model for this fn and for _exec_transition is to not do anything
13435    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13436    and instead wait until ffecom_sym_commit is called (which it never
13437    will be as long as we're using ambiguity-detecting statement analysis in
13438    the FFE, which we are initially to shake out the code, but don't depend
13439    on this), otherwise go ahead and do whatever is needed.
13440
13441    In essence, then, when this fn and _exec_transition get called while
13442    backtracking is enabled, a general mechanism would be to flag which (or
13443    both) of these were called (and in what order? neat question as to what
13444    might happen that I'm too lame to think through right now) and then when
13445    _commit is called reproduce the original calling sequence, if any, for
13446    the two fns (at which point backtracking will, of course, be disabled).  */
13447
13448 ffesymbol
13449 ffecom_sym_learned (ffesymbol s)
13450 {
13451   ffestorag_exec_layout (s);
13452
13453   return s;
13454 }
13455
13456 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13457
13458    ffesymbol s;
13459    ffecom_sym_retract(s);
13460
13461    Does whatever the backend needs when a symbol is retracted after having
13462    been backtrackable for a period of time.  */
13463
13464 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13465 void
13466 ffecom_sym_retract (ffesymbol s UNUSED)
13467 {
13468   assert (!ffesymbol_retractable ());
13469
13470 #if 0                           /* GCC doesn't commit any backtrackable sins,
13471                                    so nothing needed here. */
13472   switch (ffesymbol_hook (s).state)
13473     {
13474     case 0:                     /* nothing happened yet. */
13475       break;
13476
13477     case 1:                     /* exec transition happened. */
13478       break;
13479
13480     case 2:                     /* learned happened. */
13481       break;
13482
13483     case 3:                     /* learned then exec. */
13484       break;
13485
13486     case 4:                     /* exec then learned. */
13487       break;
13488
13489     default:
13490       assert ("bad hook state" == NULL);
13491       break;
13492     }
13493 #endif
13494 }
13495
13496 #endif
13497 /* Create temporary gcc label.  */
13498
13499 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13500 tree
13501 ffecom_temp_label ()
13502 {
13503   tree glabel;
13504   static int mynumber = 0;
13505
13506   glabel = build_decl (LABEL_DECL,
13507                        ffecom_get_invented_identifier ("__g77_label_%d",
13508                                                        NULL,
13509                                                        mynumber++),
13510                        void_type_node);
13511   DECL_CONTEXT (glabel) = current_function_decl;
13512   DECL_MODE (glabel) = VOIDmode;
13513
13514   return glabel;
13515 }
13516
13517 #endif
13518 /* Return an expression that is usable as an arg in a conditional context
13519    (IF, DO WHILE, .NOT., and so on).
13520
13521    Use the one provided for the back end as of >2.6.0.  */
13522
13523 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13524 tree
13525 ffecom_truth_value (tree expr)
13526 {
13527   return truthvalue_conversion (expr);
13528 }
13529
13530 #endif
13531 /* Return the inversion of a truth value (the inversion of what
13532    ffecom_truth_value builds).
13533
13534    Apparently invert_truthvalue, which is properly in the back end, is
13535    enough for now, so just use it.  */
13536
13537 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13538 tree
13539 ffecom_truth_value_invert (tree expr)
13540 {
13541   return invert_truthvalue (ffecom_truth_value (expr));
13542 }
13543
13544 #endif
13545 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13546
13547    If the PARM_DECL already exists, return it, else create it.  It's an
13548    integer_type_node argument for the master function that implements a
13549    subroutine or function with more than one entrypoint and is bound at
13550    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13551    first ENTRY statement, and so on).  */
13552
13553 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13554 tree
13555 ffecom_which_entrypoint_decl ()
13556 {
13557   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13558
13559   return ffecom_which_entrypoint_decl_;
13560 }
13561
13562 #endif
13563 \f
13564 /* The following sections consists of private and public functions
13565    that have the same names and perform roughly the same functions
13566    as counterparts in the C front end.  Changes in the C front end
13567    might affect how things should be done here.  Only functions
13568    needed by the back end should be public here; the rest should
13569    be private (static in the C sense).  Functions needed by other
13570    g77 front-end modules should be accessed by them via public
13571    ffecom_* names, which should themselves call private versions
13572    in this section so the private versions are easy to recognize
13573    when upgrading to a new gcc and finding interesting changes
13574    in the front end.
13575
13576    Functions named after rule "foo:" in c-parse.y are named
13577    "bison_rule_foo_" so they are easy to find.  */
13578
13579 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13580
13581 static void
13582 bison_rule_compstmt_ ()
13583 {
13584   emit_line_note (input_filename, lineno);
13585   expand_end_bindings (getdecls (), 1, 1);
13586   poplevel (1, 1, 0);
13587   pop_momentary ();
13588 }
13589
13590 static void
13591 bison_rule_pushlevel_ ()
13592 {
13593   emit_line_note (input_filename, lineno);
13594   pushlevel (0);
13595   clear_last_expr ();
13596   push_momentary ();
13597   expand_start_bindings (0);
13598 }
13599
13600 /* Return a definition for a builtin function named NAME and whose data type
13601    is TYPE.  TYPE should be a function type with argument types.
13602    FUNCTION_CODE tells later passes how to compile calls to this function.
13603    See tree.h for its possible values.
13604
13605    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13606    the name to be called if we can't opencode the function.  */
13607
13608 static tree
13609 builtin_function (char *name, tree type,
13610                   enum built_in_function function_code, char *library_name)
13611 {
13612   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13613   DECL_EXTERNAL (decl) = 1;
13614   TREE_PUBLIC (decl) = 1;
13615   if (library_name)
13616     DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13617   make_decl_rtl (decl, NULL_PTR, 1);
13618   pushdecl (decl);
13619   if (function_code != NOT_BUILT_IN)
13620     {
13621       DECL_BUILT_IN (decl) = 1;
13622       DECL_FUNCTION_CODE (decl) = function_code;
13623     }
13624
13625   return decl;
13626 }
13627
13628 /* Handle when a new declaration NEWDECL
13629    has the same name as an old one OLDDECL
13630    in the same binding contour.
13631    Prints an error message if appropriate.
13632
13633    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13634    Otherwise, return 0.  */
13635
13636 static int
13637 duplicate_decls (tree newdecl, tree olddecl)
13638 {
13639   int types_match = 1;
13640   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13641                            && DECL_INITIAL (newdecl) != 0);
13642   tree oldtype = TREE_TYPE (olddecl);
13643   tree newtype = TREE_TYPE (newdecl);
13644
13645   if (olddecl == newdecl)
13646     return 1;
13647
13648   if (TREE_CODE (newtype) == ERROR_MARK
13649       || TREE_CODE (oldtype) == ERROR_MARK)
13650     types_match = 0;
13651
13652   /* New decl is completely inconsistent with the old one =>
13653      tell caller to replace the old one.
13654      This is always an error except in the case of shadowing a builtin.  */
13655   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13656     return 0;
13657
13658   /* For real parm decl following a forward decl,
13659      return 1 so old decl will be reused.  */
13660   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13661       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13662     return 1;
13663
13664   /* The new declaration is the same kind of object as the old one.
13665      The declarations may partially match.  Print warnings if they don't
13666      match enough.  Ultimately, copy most of the information from the new
13667      decl to the old one, and keep using the old one.  */
13668
13669   if (TREE_CODE (olddecl) == FUNCTION_DECL
13670       && DECL_BUILT_IN (olddecl))
13671     {
13672       /* A function declaration for a built-in function.  */
13673       if (!TREE_PUBLIC (newdecl))
13674         return 0;
13675       else if (!types_match)
13676         {
13677           /* Accept the return type of the new declaration if same modes.  */
13678           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13679           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13680
13681           /* Make sure we put the new type in the same obstack as the old ones.
13682              If the old types are not both in the same obstack, use the
13683              permanent one.  */
13684           if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
13685             push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
13686           else
13687             {
13688               push_obstacks_nochange ();
13689               end_temporary_allocation ();
13690             }
13691
13692           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13693             {
13694               /* Function types may be shared, so we can't just modify
13695                  the return type of olddecl's function type.  */
13696               tree newtype
13697                 = build_function_type (newreturntype,
13698                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13699
13700               types_match = 1;
13701               if (types_match)
13702                 TREE_TYPE (olddecl) = newtype;
13703             }
13704
13705           pop_obstacks ();
13706         }
13707       if (!types_match)
13708         return 0;
13709     }
13710   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13711            && DECL_SOURCE_LINE (olddecl) == 0)
13712     {
13713       /* A function declaration for a predeclared function
13714          that isn't actually built in.  */
13715       if (!TREE_PUBLIC (newdecl))
13716         return 0;
13717       else if (!types_match)
13718         {
13719           /* If the types don't match, preserve volatility indication.
13720              Later on, we will discard everything else about the
13721              default declaration.  */
13722           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13723         }
13724     }
13725
13726   /* Copy all the DECL_... slots specified in the new decl
13727      except for any that we copy here from the old type.
13728
13729      Past this point, we don't change OLDTYPE and NEWTYPE
13730      even if we change the types of NEWDECL and OLDDECL.  */
13731
13732   if (types_match)
13733     {
13734       /* Make sure we put the new type in the same obstack as the old ones.
13735          If the old types are not both in the same obstack, use the permanent
13736          one.  */
13737       if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
13738         push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
13739       else
13740         {
13741           push_obstacks_nochange ();
13742           end_temporary_allocation ();
13743         }
13744
13745       /* Merge the data types specified in the two decls.  */
13746       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13747         TREE_TYPE (newdecl)
13748           = TREE_TYPE (olddecl)
13749             = TREE_TYPE (newdecl);
13750
13751       /* Lay the type out, unless already done.  */
13752       if (oldtype != TREE_TYPE (newdecl))
13753         {
13754           if (TREE_TYPE (newdecl) != error_mark_node)
13755             layout_type (TREE_TYPE (newdecl));
13756           if (TREE_CODE (newdecl) != FUNCTION_DECL
13757               && TREE_CODE (newdecl) != TYPE_DECL
13758               && TREE_CODE (newdecl) != CONST_DECL)
13759             layout_decl (newdecl, 0);
13760         }
13761       else
13762         {
13763           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13764           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13765           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13766             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13767               DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13768         }
13769
13770       /* Keep the old rtl since we can safely use it.  */
13771       DECL_RTL (newdecl) = DECL_RTL (olddecl);
13772
13773       /* Merge the type qualifiers.  */
13774       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13775           && !TREE_THIS_VOLATILE (newdecl))
13776         TREE_THIS_VOLATILE (olddecl) = 0;
13777       if (TREE_READONLY (newdecl))
13778         TREE_READONLY (olddecl) = 1;
13779       if (TREE_THIS_VOLATILE (newdecl))
13780         {
13781           TREE_THIS_VOLATILE (olddecl) = 1;
13782           if (TREE_CODE (newdecl) == VAR_DECL)
13783             make_var_volatile (newdecl);
13784         }
13785
13786       /* Keep source location of definition rather than declaration.
13787          Likewise, keep decl at outer scope.  */
13788       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13789           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13790         {
13791           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13792           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13793
13794           if (DECL_CONTEXT (olddecl) == 0
13795               && TREE_CODE (newdecl) != FUNCTION_DECL)
13796             DECL_CONTEXT (newdecl) = 0;
13797         }
13798
13799       /* Merge the unused-warning information.  */
13800       if (DECL_IN_SYSTEM_HEADER (olddecl))
13801         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13802       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13803         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13804
13805       /* Merge the initialization information.  */
13806       if (DECL_INITIAL (newdecl) == 0)
13807         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13808
13809       /* Merge the section attribute.
13810          We want to issue an error if the sections conflict but that must be
13811          done later in decl_attributes since we are called before attributes
13812          are assigned.  */
13813       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13814         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13815
13816 #if BUILT_FOR_270
13817       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13818         {
13819           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13820           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13821         }
13822 #endif
13823
13824       pop_obstacks ();
13825     }
13826   /* If cannot merge, then use the new type and qualifiers,
13827      and don't preserve the old rtl.  */
13828   else
13829     {
13830       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13831       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13832       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13833       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13834     }
13835
13836   /* Merge the storage class information.  */
13837   /* For functions, static overrides non-static.  */
13838   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13839     {
13840       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13841       /* This is since we don't automatically
13842          copy the attributes of NEWDECL into OLDDECL.  */
13843       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13844       /* If this clears `static', clear it in the identifier too.  */
13845       if (! TREE_PUBLIC (olddecl))
13846         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13847     }
13848   if (DECL_EXTERNAL (newdecl))
13849     {
13850       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13851       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13852       /* An extern decl does not override previous storage class.  */
13853       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13854     }
13855   else
13856     {
13857       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13858       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13859     }
13860
13861   /* If either decl says `inline', this fn is inline,
13862      unless its definition was passed already.  */
13863   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13864     DECL_INLINE (olddecl) = 1;
13865   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13866
13867   /* Get rid of any built-in function if new arg types don't match it
13868      or if we have a function definition.  */
13869   if (TREE_CODE (newdecl) == FUNCTION_DECL
13870       && DECL_BUILT_IN (olddecl)
13871       && (!types_match || new_is_definition))
13872     {
13873       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13874       DECL_BUILT_IN (olddecl) = 0;
13875     }
13876
13877   /* If redeclaring a builtin function, and not a definition,
13878      it stays built in.
13879      Also preserve various other info from the definition.  */
13880   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13881     {
13882       if (DECL_BUILT_IN (olddecl))
13883         {
13884           DECL_BUILT_IN (newdecl) = 1;
13885           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13886         }
13887       else
13888         DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
13889
13890       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13891       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13892       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13893       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13894     }
13895
13896   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13897      But preserve olddecl's DECL_UID.  */
13898   {
13899     register unsigned olddecl_uid = DECL_UID (olddecl);
13900
13901     memcpy ((char *) olddecl + sizeof (struct tree_common),
13902             (char *) newdecl + sizeof (struct tree_common),
13903             sizeof (struct tree_decl) - sizeof (struct tree_common));
13904     DECL_UID (olddecl) = olddecl_uid;
13905   }
13906
13907   return 1;
13908 }
13909
13910 /* Finish processing of a declaration;
13911    install its initial value.
13912    If the length of an array type is not known before,
13913    it must be determined now, from the initial value, or it is an error.  */
13914
13915 static void
13916 finish_decl (tree decl, tree init, bool is_top_level)
13917 {
13918   register tree type = TREE_TYPE (decl);
13919   int was_incomplete = (DECL_SIZE (decl) == 0);
13920   int temporary = allocation_temporary_p ();
13921   bool at_top_level = (current_binding_level == global_binding_level);
13922   bool top_level = is_top_level || at_top_level;
13923
13924   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13925      level anyway.  */
13926   assert (!is_top_level || !at_top_level);
13927
13928   if (TREE_CODE (decl) == PARM_DECL)
13929     assert (init == NULL_TREE);
13930   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13931      overlaps DECL_ARG_TYPE.  */
13932   else if (init == NULL_TREE)
13933     assert (DECL_INITIAL (decl) == NULL_TREE);
13934   else
13935     assert (DECL_INITIAL (decl) == error_mark_node);
13936
13937   if (init != NULL_TREE)
13938     {
13939       if (TREE_CODE (decl) != TYPE_DECL)
13940         DECL_INITIAL (decl) = init;
13941       else
13942         {
13943           /* typedef foo = bar; store the type of bar as the type of foo.  */
13944           TREE_TYPE (decl) = TREE_TYPE (init);
13945           DECL_INITIAL (decl) = init = 0;
13946         }
13947     }
13948
13949   /* Pop back to the obstack that is current for this binding level. This is
13950      because MAXINDEX, rtl, etc. to be made below must go in the permanent
13951      obstack.  But don't discard the temporary data yet.  */
13952   pop_obstacks ();
13953
13954   /* Deduce size of array from initialization, if not already known */
13955
13956   if (TREE_CODE (type) == ARRAY_TYPE
13957       && TYPE_DOMAIN (type) == 0
13958       && TREE_CODE (decl) != TYPE_DECL)
13959     {
13960       assert (top_level);
13961       assert (was_incomplete);
13962
13963       layout_decl (decl, 0);
13964     }
13965
13966   if (TREE_CODE (decl) == VAR_DECL)
13967     {
13968       if (DECL_SIZE (decl) == NULL_TREE
13969           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13970         layout_decl (decl, 0);
13971
13972       if (DECL_SIZE (decl) == NULL_TREE
13973           && (TREE_STATIC (decl)
13974               ?
13975       /* A static variable with an incomplete type is an error if it is
13976          initialized. Also if it is not file scope. Otherwise, let it
13977          through, but if it is not `extern' then it may cause an error
13978          message later.  */
13979               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13980               :
13981       /* An automatic variable with an incomplete type is an error.  */
13982               !DECL_EXTERNAL (decl)))
13983         {
13984           assert ("storage size not known" == NULL);
13985           abort ();
13986         }
13987
13988       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13989           && (DECL_SIZE (decl) != 0)
13990           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13991         {
13992           assert ("storage size not constant" == NULL);
13993           abort ();
13994         }
13995     }
13996
13997   /* Output the assembler code and/or RTL code for variables and functions,
13998      unless the type is an undefined structure or union. If not, it will get
13999      done when the type is completed.  */
14000
14001   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
14002     {
14003       rest_of_decl_compilation (decl, NULL,
14004                                 DECL_CONTEXT (decl) == 0,
14005                                 0);
14006
14007       if (DECL_CONTEXT (decl) != 0)
14008         {
14009           /* Recompute the RTL of a local array now if it used to be an
14010              incomplete type.  */
14011           if (was_incomplete
14012               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
14013             {
14014               /* If we used it already as memory, it must stay in memory.  */
14015               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
14016               /* If it's still incomplete now, no init will save it.  */
14017               if (DECL_SIZE (decl) == 0)
14018                 DECL_INITIAL (decl) = 0;
14019               expand_decl (decl);
14020             }
14021           /* Compute and store the initial value.  */
14022           if (TREE_CODE (decl) != FUNCTION_DECL)
14023             expand_decl_init (decl);
14024         }
14025     }
14026   else if (TREE_CODE (decl) == TYPE_DECL)
14027     {
14028       rest_of_decl_compilation (decl, NULL_PTR,
14029                                 DECL_CONTEXT (decl) == 0,
14030                                 0);
14031     }
14032
14033   /* This test used to include TREE_PERMANENT, however, we have the same
14034      problem with initializers at the function level.  Such initializers get
14035      saved until the end of the function on the momentary_obstack.  */
14036   if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
14037       && temporary
14038   /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
14039      DECL_ARG_TYPE.  */
14040       && TREE_CODE (decl) != PARM_DECL)
14041     {
14042       /* We need to remember that this array HAD an initialization, but
14043          discard the actual temporary nodes, since we can't have a permanent
14044          node keep pointing to them.  */
14045       /* We make an exception for inline functions, since it's normal for a
14046          local extern redeclaration of an inline function to have a copy of
14047          the top-level decl's DECL_INLINE.  */
14048       if ((DECL_INITIAL (decl) != 0)
14049           && (DECL_INITIAL (decl) != error_mark_node))
14050         {
14051           /* If this is a const variable, then preserve the
14052              initializer instead of discarding it so that we can optimize
14053              references to it.  */
14054           /* This test used to include TREE_STATIC, but this won't be set
14055              for function level initializers.  */
14056           if (TREE_READONLY (decl))
14057             {
14058               preserve_initializer ();
14059               /* Hack?  Set the permanent bit for something that is
14060                  permanent, but not on the permenent obstack, so as to
14061                  convince output_constant_def to make its rtl on the
14062                  permanent obstack.  */
14063               TREE_PERMANENT (DECL_INITIAL (decl)) = 1;
14064
14065               /* The initializer and DECL must have the same (or equivalent
14066                  types), but if the initializer is a STRING_CST, its type
14067                  might not be on the right obstack, so copy the type
14068                  of DECL.  */
14069               TREE_TYPE (DECL_INITIAL (decl)) = type;
14070             }
14071           else
14072             DECL_INITIAL (decl) = error_mark_node;
14073         }
14074     }
14075
14076   /* If requested, warn about definitions of large data objects.  */
14077
14078   if (warn_larger_than
14079       && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL)
14080       && !DECL_EXTERNAL (decl))
14081     {
14082       register tree decl_size = DECL_SIZE (decl);
14083
14084       if (decl_size && TREE_CODE (decl_size) == INTEGER_CST)
14085         {
14086            unsigned units = TREE_INT_CST_LOW (decl_size) / BITS_PER_UNIT;
14087
14088           if (units > larger_than_size)
14089             warning_with_decl (decl, "size of `%s' is %u bytes", units);
14090         }
14091     }
14092
14093   /* If we have gone back from temporary to permanent allocation, actually
14094      free the temporary space that we no longer need.  */
14095   if (temporary && !allocation_temporary_p ())
14096     permanent_allocation (0);
14097
14098   /* At the end of a declaration, throw away any variable type sizes of types
14099      defined inside that declaration.  There is no use computing them in the
14100      following function definition.  */
14101   if (current_binding_level == global_binding_level)
14102     get_pending_sizes ();
14103 }
14104
14105 /* Finish up a function declaration and compile that function
14106    all the way to assembler language output.  The free the storage
14107    for the function definition.
14108
14109    This is called after parsing the body of the function definition.
14110
14111    NESTED is nonzero if the function being finished is nested in another.  */
14112
14113 static void
14114 finish_function (int nested)
14115 {
14116   register tree fndecl = current_function_decl;
14117
14118   assert (fndecl != NULL_TREE);
14119   if (nested)
14120     assert (DECL_CONTEXT (fndecl) != NULL_TREE);
14121   else
14122     assert (DECL_CONTEXT (fndecl) == NULL_TREE);
14123
14124 /*  TREE_READONLY (fndecl) = 1;
14125     This caused &foo to be of type ptr-to-const-function
14126     which then got a warning when stored in a ptr-to-function variable.  */
14127
14128   poplevel (1, 0, 1);
14129   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
14130
14131   /* Must mark the RESULT_DECL as being in this function.  */
14132
14133   DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
14134
14135   /* Obey `register' declarations if `setjmp' is called in this fn.  */
14136   /* Generate rtl for function exit.  */
14137   expand_function_end (input_filename, lineno, 0);
14138
14139   /* So we can tell if jump_optimize sets it to 1.  */
14140   can_reach_end = 0;
14141
14142   /* Run the optimizers and output the assembler code for this function.  */
14143   rest_of_compilation (fndecl);
14144
14145   /* Free all the tree nodes making up this function.  */
14146   /* Switch back to allocating nodes permanently until we start another
14147      function.  */
14148   if (!nested)
14149     permanent_allocation (1);
14150
14151   if (DECL_SAVED_INSNS (fndecl) == 0 && !nested)
14152     {
14153       /* Stop pointing to the local nodes about to be freed.  */
14154       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14155          function definition.  */
14156       /* For a nested function, this is done in pop_f_function_context.  */
14157       /* If rest_of_compilation set this to 0, leave it 0.  */
14158       if (DECL_INITIAL (fndecl) != 0)
14159         DECL_INITIAL (fndecl) = error_mark_node;
14160       DECL_ARGUMENTS (fndecl) = 0;
14161     }
14162
14163   if (!nested)
14164     {
14165       /* Let the error reporting routines know that we're outside a function.
14166          For a nested function, this value is used in pop_c_function_context
14167          and then reset via pop_function_context.  */
14168       ffecom_outer_function_decl_ = current_function_decl = NULL;
14169     }
14170 }
14171
14172 /* Plug-in replacement for identifying the name of a decl and, for a
14173    function, what we call it in diagnostics.  For now, "program unit"
14174    should suffice, since it's a bit of a hassle to figure out which
14175    of several kinds of things it is.  Note that it could conceivably
14176    be a statement function, which probably isn't really a program unit
14177    per se, but if that comes up, it should be easy to check (being a
14178    nested function and all).  */
14179
14180 static char *
14181 lang_printable_name (tree decl, int v)
14182 {
14183   /* Just to keep GCC quiet about the unused variable.
14184      In theory, differing values of V should produce different
14185      output.  */
14186   switch (v)
14187     {
14188     default:
14189       return IDENTIFIER_POINTER (DECL_NAME (decl));
14190     }
14191 }
14192
14193 /* g77's function to print out name of current function that caused
14194    an error.  */
14195
14196 #if BUILT_FOR_270
14197 void
14198 lang_print_error_function (file)
14199      char *file;
14200 {
14201   static ffesymbol last_s = NULL;
14202   ffesymbol s;
14203   char *kind;
14204
14205   if (ffecom_primary_entry_ == NULL)
14206     {
14207       s = NULL;
14208       kind = NULL;
14209     }
14210   else if (ffecom_nested_entry_ == NULL)
14211     {
14212       s = ffecom_primary_entry_;
14213       switch (ffesymbol_kind (s))
14214         {
14215         case FFEINFO_kindFUNCTION:
14216           kind = "function";
14217           break;
14218
14219         case FFEINFO_kindSUBROUTINE:
14220           kind = "subroutine";
14221           break;
14222
14223         case FFEINFO_kindPROGRAM:
14224           kind = "program";
14225           break;
14226
14227         case FFEINFO_kindBLOCKDATA:
14228           kind = "block-data";
14229           break;
14230
14231         default:
14232           kind = ffeinfo_kind_message (ffesymbol_kind (s));
14233           break;
14234         }
14235     }
14236   else
14237     {
14238       s = ffecom_nested_entry_;
14239       kind = "statement function";
14240     }
14241
14242   if (last_s != s)
14243     {
14244       if (file)
14245         fprintf (stderr, "%s: ", file);
14246
14247       if (s == NULL)
14248         fprintf (stderr, "Outside of any program unit:\n");
14249       else
14250         {
14251           char *name = ffesymbol_text (s);
14252
14253           fprintf (stderr, "In %s `%s':\n", kind, name);
14254         }
14255
14256       last_s = s;
14257     }
14258 }
14259 #endif
14260
14261 /* Similar to `lookup_name' but look only at current binding level.  */
14262
14263 static tree
14264 lookup_name_current_level (tree name)
14265 {
14266   register tree t;
14267
14268   if (current_binding_level == global_binding_level)
14269     return IDENTIFIER_GLOBAL_VALUE (name);
14270
14271   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14272     return 0;
14273
14274   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14275     if (DECL_NAME (t) == name)
14276       break;
14277
14278   return t;
14279 }
14280
14281 /* Create a new `struct binding_level'.  */
14282
14283 static struct binding_level *
14284 make_binding_level ()
14285 {
14286   /* NOSTRICT */
14287   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14288 }
14289
14290 /* Save and restore the variables in this file and elsewhere
14291    that keep track of the progress of compilation of the current function.
14292    Used for nested functions.  */
14293
14294 struct f_function
14295 {
14296   struct f_function *next;
14297   tree named_labels;
14298   tree shadowed_labels;
14299   struct binding_level *binding_level;
14300 };
14301
14302 struct f_function *f_function_chain;
14303
14304 /* Restore the variables used during compilation of a C function.  */
14305
14306 static void
14307 pop_f_function_context ()
14308 {
14309   struct f_function *p = f_function_chain;
14310   tree link;
14311
14312   /* Bring back all the labels that were shadowed.  */
14313   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14314     if (DECL_NAME (TREE_VALUE (link)) != 0)
14315       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14316         = TREE_VALUE (link);
14317
14318   if (DECL_SAVED_INSNS (current_function_decl) == 0)
14319     {
14320       /* Stop pointing to the local nodes about to be freed.  */
14321       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14322          function definition.  */
14323       DECL_INITIAL (current_function_decl) = error_mark_node;
14324       DECL_ARGUMENTS (current_function_decl) = 0;
14325     }
14326
14327   pop_function_context ();
14328
14329   f_function_chain = p->next;
14330
14331   named_labels = p->named_labels;
14332   shadowed_labels = p->shadowed_labels;
14333   current_binding_level = p->binding_level;
14334
14335   free (p);
14336 }
14337
14338 /* Save and reinitialize the variables
14339    used during compilation of a C function.  */
14340
14341 static void
14342 push_f_function_context ()
14343 {
14344   struct f_function *p
14345   = (struct f_function *) xmalloc (sizeof (struct f_function));
14346
14347   push_function_context ();
14348
14349   p->next = f_function_chain;
14350   f_function_chain = p;
14351
14352   p->named_labels = named_labels;
14353   p->shadowed_labels = shadowed_labels;
14354   p->binding_level = current_binding_level;
14355 }
14356
14357 static void
14358 push_parm_decl (tree parm)
14359 {
14360   int old_immediate_size_expand = immediate_size_expand;
14361
14362   /* Don't try computing parm sizes now -- wait till fn is called.  */
14363
14364   immediate_size_expand = 0;
14365
14366   push_obstacks_nochange ();
14367
14368   /* Fill in arg stuff.  */
14369
14370   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14371   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14372   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14373
14374   parm = pushdecl (parm);
14375
14376   immediate_size_expand = old_immediate_size_expand;
14377
14378   finish_decl (parm, NULL_TREE, FALSE);
14379 }
14380
14381 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14382
14383 static tree
14384 pushdecl_top_level (x)
14385      tree x;
14386 {
14387   register tree t;
14388   register struct binding_level *b = current_binding_level;
14389   register tree f = current_function_decl;
14390
14391   current_binding_level = global_binding_level;
14392   current_function_decl = NULL_TREE;
14393   t = pushdecl (x);
14394   current_binding_level = b;
14395   current_function_decl = f;
14396   return t;
14397 }
14398
14399 /* Store the list of declarations of the current level.
14400    This is done for the parameter declarations of a function being defined,
14401    after they are modified in the light of any missing parameters.  */
14402
14403 static tree
14404 storedecls (decls)
14405      tree decls;
14406 {
14407   return current_binding_level->names = decls;
14408 }
14409
14410 /* Store the parameter declarations into the current function declaration.
14411    This is called after parsing the parameter declarations, before
14412    digesting the body of the function.
14413
14414    For an old-style definition, modify the function's type
14415    to specify at least the number of arguments.  */
14416
14417 static void
14418 store_parm_decls (int is_main_program UNUSED)
14419 {
14420   register tree fndecl = current_function_decl;
14421
14422   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14423   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14424
14425   /* Initialize the RTL code for the function.  */
14426
14427   init_function_start (fndecl, input_filename, lineno);
14428
14429   /* Set up parameters and prepare for return, for the function.  */
14430
14431   expand_function_start (fndecl, 0);
14432 }
14433
14434 static tree
14435 start_decl (tree decl, bool is_top_level)
14436 {
14437   register tree tem;
14438   bool at_top_level = (current_binding_level == global_binding_level);
14439   bool top_level = is_top_level || at_top_level;
14440
14441   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14442      level anyway.  */
14443   assert (!is_top_level || !at_top_level);
14444
14445   /* The corresponding pop_obstacks is in finish_decl.  */
14446   push_obstacks_nochange ();
14447
14448   if (DECL_INITIAL (decl) != NULL_TREE)
14449     {
14450       assert (DECL_INITIAL (decl) == error_mark_node);
14451       assert (!DECL_EXTERNAL (decl));
14452     }
14453   else if (top_level)
14454     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14455
14456   /* For Fortran, we by default put things in .common when possible.  */
14457   DECL_COMMON (decl) = 1;
14458
14459   /* Add this decl to the current binding level. TEM may equal DECL or it may
14460      be a previous decl of the same name.  */
14461   if (is_top_level)
14462     tem = pushdecl_top_level (decl);
14463   else
14464     tem = pushdecl (decl);
14465
14466   /* For a local variable, define the RTL now.  */
14467   if (!top_level
14468   /* But not if this is a duplicate decl and we preserved the rtl from the
14469      previous one (which may or may not happen).  */
14470       && DECL_RTL (tem) == 0)
14471     {
14472       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14473         expand_decl (tem);
14474       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14475                && DECL_INITIAL (tem) != 0)
14476         expand_decl (tem);
14477     }
14478
14479   if (DECL_INITIAL (tem) != NULL_TREE)
14480     {
14481       /* When parsing and digesting the initializer, use temporary storage.
14482          Do this even if we will ignore the value.  */
14483       if (at_top_level)
14484         temporary_allocation ();
14485     }
14486
14487   return tem;
14488 }
14489
14490 /* Create the FUNCTION_DECL for a function definition.
14491    DECLSPECS and DECLARATOR are the parts of the declaration;
14492    they describe the function's name and the type it returns,
14493    but twisted together in a fashion that parallels the syntax of C.
14494
14495    This function creates a binding context for the function body
14496    as well as setting up the FUNCTION_DECL in current_function_decl.
14497
14498    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14499    (it defines a datum instead), we return 0, which tells
14500    yyparse to report a parse error.
14501
14502    NESTED is nonzero for a function nested within another function.  */
14503
14504 static void
14505 start_function (tree name, tree type, int nested, int public)
14506 {
14507   tree decl1;
14508   tree restype;
14509   int old_immediate_size_expand = immediate_size_expand;
14510
14511   named_labels = 0;
14512   shadowed_labels = 0;
14513
14514   /* Don't expand any sizes in the return type of the function.  */
14515   immediate_size_expand = 0;
14516
14517   if (nested)
14518     {
14519       assert (!public);
14520       assert (current_function_decl != NULL_TREE);
14521       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14522     }
14523   else
14524     {
14525       assert (current_function_decl == NULL_TREE);
14526     }
14527
14528   decl1 = build_decl (FUNCTION_DECL,
14529                       name,
14530                       type);
14531   TREE_PUBLIC (decl1) = public ? 1 : 0;
14532   if (nested)
14533     DECL_INLINE (decl1) = 1;
14534   TREE_STATIC (decl1) = 1;
14535   DECL_EXTERNAL (decl1) = 0;
14536
14537   announce_function (decl1);
14538
14539   /* Make the init_value nonzero so pushdecl knows this is not tentative.
14540      error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14541   DECL_INITIAL (decl1) = error_mark_node;
14542
14543   /* Record the decl so that the function name is defined. If we already have
14544      a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14545
14546   current_function_decl = pushdecl (decl1);
14547   if (!nested)
14548     ffecom_outer_function_decl_ = current_function_decl;
14549
14550   pushlevel (0);
14551
14552   make_function_rtl (current_function_decl);
14553
14554   restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14555   DECL_RESULT (current_function_decl)
14556     = build_decl (RESULT_DECL, NULL_TREE, restype);
14557
14558   if (!nested)
14559     /* Allocate further tree nodes temporarily during compilation of this
14560        function only.  */
14561     temporary_allocation ();
14562
14563   if (!nested)
14564     TREE_ADDRESSABLE (current_function_decl) = 1;
14565
14566   immediate_size_expand = old_immediate_size_expand;
14567 }
14568 \f
14569 /* Here are the public functions the GNU back end needs.  */
14570
14571 /* This is used by the `assert' macro.  It is provided in libgcc.a,
14572    which `cc' doesn't know how to link.  Note that the C++ front-end
14573    no longer actually uses the `assert' macro (instead, it calls
14574    my_friendly_assert).  But all of the back-end files still need this.  */
14575 void
14576 __eprintf (string, expression, line, filename)
14577 #ifdef __STDC__
14578      const char *string;
14579      const char *expression;
14580      unsigned line;
14581      const char *filename;
14582 #else
14583      char *string;
14584      char *expression;
14585      unsigned line;
14586      char *filename;
14587 #endif
14588 {
14589   fprintf (stderr, string, expression, line, filename);
14590   fflush (stderr);
14591   abort ();
14592 }
14593
14594 tree
14595 convert (type, expr)
14596      tree type, expr;
14597 {
14598   register tree e = expr;
14599   register enum tree_code code = TREE_CODE (type);
14600
14601   if (type == TREE_TYPE (e)
14602       || TREE_CODE (e) == ERROR_MARK)
14603     return e;
14604   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14605     return fold (build1 (NOP_EXPR, type, e));
14606   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14607       || code == ERROR_MARK)
14608     return error_mark_node;
14609   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14610     {
14611       assert ("void value not ignored as it ought to be" == NULL);
14612       return error_mark_node;
14613     }
14614   if (code == VOID_TYPE)
14615     return build1 (CONVERT_EXPR, type, e);
14616   if ((code != RECORD_TYPE)
14617       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14618     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14619                   e);
14620   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14621     return fold (convert_to_integer (type, e));
14622   if (code == POINTER_TYPE)
14623     return fold (convert_to_pointer (type, e));
14624   if (code == REAL_TYPE)
14625     return fold (convert_to_real (type, e));
14626   if (code == COMPLEX_TYPE)
14627     return fold (convert_to_complex (type, e));
14628   if (code == RECORD_TYPE)
14629     return fold (ffecom_convert_to_complex_ (type, e));
14630
14631   assert ("conversion to non-scalar type requested" == NULL);
14632   return error_mark_node;
14633 }
14634
14635 /* integrate_decl_tree calls this function, but since we don't use the
14636    DECL_LANG_SPECIFIC field, this is a no-op.  */
14637
14638 void
14639 copy_lang_decl (node)
14640      tree node UNUSED;
14641 {
14642 }
14643
14644 /* Return the list of declarations of the current level.
14645    Note that this list is in reverse order unless/until
14646    you nreverse it; and when you do nreverse it, you must
14647    store the result back using `storedecls' or you will lose.  */
14648
14649 tree
14650 getdecls ()
14651 {
14652   return current_binding_level->names;
14653 }
14654
14655 /* Nonzero if we are currently in the global binding level.  */
14656
14657 int
14658 global_bindings_p ()
14659 {
14660   return current_binding_level == global_binding_level;
14661 }
14662
14663 /* Insert BLOCK at the end of the list of subblocks of the
14664    current binding level.  This is used when a BIND_EXPR is expanded,
14665    to handle the BLOCK node inside the BIND_EXPR.  */
14666
14667 void
14668 incomplete_type_error (value, type)
14669      tree value UNUSED;
14670      tree type;
14671 {
14672   if (TREE_CODE (type) == ERROR_MARK)
14673     return;
14674
14675   assert ("incomplete type?!?" == NULL);
14676 }
14677
14678 void
14679 init_decl_processing ()
14680 {
14681   malloc_init ();
14682   ffe_init_0 ();
14683 }
14684
14685 void
14686 init_lex ()
14687 {
14688 #if BUILT_FOR_270
14689   extern void (*print_error_function) (char *);
14690 #endif
14691
14692   /* Make identifier nodes long enough for the language-specific slots.  */
14693   set_identifier_size (sizeof (struct lang_identifier));
14694   decl_printable_name = lang_printable_name;
14695 #if BUILT_FOR_270
14696   print_error_function = lang_print_error_function;
14697 #endif
14698 }
14699
14700 void
14701 insert_block (block)
14702      tree block;
14703 {
14704   TREE_USED (block) = 1;
14705   current_binding_level->blocks
14706     = chainon (current_binding_level->blocks, block);
14707 }
14708
14709 int
14710 lang_decode_option (p)
14711      char *p;
14712 {
14713   return ffe_decode_option (p);
14714 }
14715
14716 void
14717 lang_finish ()
14718 {
14719   ffe_terminate_0 ();
14720
14721   if (ffe_is_ffedebug ())
14722     malloc_pool_display (malloc_pool_image ());
14723 }
14724
14725 char *
14726 lang_identify ()
14727 {
14728   return "f77";
14729 }
14730
14731 void
14732 lang_init ()
14733 {
14734   extern FILE *finput;          /* Don't pollute com.h with this. */
14735
14736   /* If the file is output from cpp, it should contain a first line
14737      `# 1 "real-filename"', and the current design of gcc (toplev.c
14738      in particular and the way it sets up information relied on by
14739      INCLUDE) requires that we read this now, and store the
14740      "real-filename" info in master_input_filename.  Ask the lexer
14741      to try doing this.  */
14742   ffelex_hash_kludge (finput);
14743 }
14744
14745 int
14746 mark_addressable (exp)
14747      tree exp;
14748 {
14749   register tree x = exp;
14750   while (1)
14751     switch (TREE_CODE (x))
14752       {
14753       case ADDR_EXPR:
14754       case COMPONENT_REF:
14755       case ARRAY_REF:
14756         x = TREE_OPERAND (x, 0);
14757         break;
14758
14759       case CONSTRUCTOR:
14760         TREE_ADDRESSABLE (x) = 1;
14761         return 1;
14762
14763       case VAR_DECL:
14764       case CONST_DECL:
14765       case PARM_DECL:
14766       case RESULT_DECL:
14767         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14768             && DECL_NONLOCAL (x))
14769           {
14770             if (TREE_PUBLIC (x))
14771               {
14772                 assert ("address of global register var requested" == NULL);
14773                 return 0;
14774               }
14775             assert ("address of register variable requested" == NULL);
14776           }
14777         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14778           {
14779             if (TREE_PUBLIC (x))
14780               {
14781                 assert ("address of global register var requested" == NULL);
14782                 return 0;
14783               }
14784             assert ("address of register var requested" == NULL);
14785           }
14786         put_var_into_stack (x);
14787
14788         /* drops in */
14789       case FUNCTION_DECL:
14790         TREE_ADDRESSABLE (x) = 1;
14791 #if 0                           /* poplevel deals with this now.  */
14792         if (DECL_CONTEXT (x) == 0)
14793           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14794 #endif
14795
14796       default:
14797         return 1;
14798       }
14799 }
14800
14801 /* If DECL has a cleanup, build and return that cleanup here.
14802    This is a callback called by expand_expr.  */
14803
14804 tree
14805 maybe_build_cleanup (decl)
14806      tree decl UNUSED;
14807 {
14808   /* There are no cleanups in Fortran.  */
14809   return NULL_TREE;
14810 }
14811
14812 /* Exit a binding level.
14813    Pop the level off, and restore the state of the identifier-decl mappings
14814    that were in effect when this level was entered.
14815
14816    If KEEP is nonzero, this level had explicit declarations, so
14817    and create a "block" (a BLOCK node) for the level
14818    to record its declarations and subblocks for symbol table output.
14819
14820    If FUNCTIONBODY is nonzero, this level is the body of a function,
14821    so create a block as if KEEP were set and also clear out all
14822    label names.
14823
14824    If REVERSE is nonzero, reverse the order of decls before putting
14825    them into the BLOCK.  */
14826
14827 tree
14828 poplevel (keep, reverse, functionbody)
14829      int keep;
14830      int reverse;
14831      int functionbody;
14832 {
14833   register tree link;
14834   /* The chain of decls was accumulated in reverse order. Put it into forward
14835      order, just for cleanliness.  */
14836   tree decls;
14837   tree subblocks = current_binding_level->blocks;
14838   tree block = 0;
14839   tree decl;
14840   int block_previously_created;
14841
14842   /* Get the decls in the order they were written. Usually
14843      current_binding_level->names is in reverse order. But parameter decls
14844      were previously put in forward order.  */
14845
14846   if (reverse)
14847     current_binding_level->names
14848       = decls = nreverse (current_binding_level->names);
14849   else
14850     decls = current_binding_level->names;
14851
14852   /* Output any nested inline functions within this block if they weren't
14853      already output.  */
14854
14855   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14856     if (TREE_CODE (decl) == FUNCTION_DECL
14857         && !TREE_ASM_WRITTEN (decl)
14858         && DECL_INITIAL (decl) != 0
14859         && TREE_ADDRESSABLE (decl))
14860       {
14861         /* If this decl was copied from a file-scope decl on account of a
14862            block-scope extern decl, propagate TREE_ADDRESSABLE to the
14863            file-scope decl.  */
14864         if (DECL_ABSTRACT_ORIGIN (decl) != 0)
14865           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14866         else
14867           {
14868             push_function_context ();
14869             output_inline_function (decl);
14870             pop_function_context ();
14871           }
14872       }
14873
14874   /* If there were any declarations or structure tags in that level, or if
14875      this level is a function body, create a BLOCK to record them for the
14876      life of this function.  */
14877
14878   block = 0;
14879   block_previously_created = (current_binding_level->this_block != 0);
14880   if (block_previously_created)
14881     block = current_binding_level->this_block;
14882   else if (keep || functionbody)
14883     block = make_node (BLOCK);
14884   if (block != 0)
14885     {
14886       BLOCK_VARS (block) = decls;
14887       BLOCK_SUBBLOCKS (block) = subblocks;
14888       remember_end_note (block);
14889     }
14890
14891   /* In each subblock, record that this is its superior.  */
14892
14893   for (link = subblocks; link; link = TREE_CHAIN (link))
14894     BLOCK_SUPERCONTEXT (link) = block;
14895
14896   /* Clear out the meanings of the local variables of this level.  */
14897
14898   for (link = decls; link; link = TREE_CHAIN (link))
14899     {
14900       if (DECL_NAME (link) != 0)
14901         {
14902           /* If the ident. was used or addressed via a local extern decl,
14903              don't forget that fact.  */
14904           if (DECL_EXTERNAL (link))
14905             {
14906               if (TREE_USED (link))
14907                 TREE_USED (DECL_NAME (link)) = 1;
14908               if (TREE_ADDRESSABLE (link))
14909                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14910             }
14911           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14912         }
14913     }
14914
14915   /* If the level being exited is the top level of a function, check over all
14916      the labels, and clear out the current (function local) meanings of their
14917      names.  */
14918
14919   if (functionbody)
14920     {
14921       /* If this is the top level block of a function, the vars are the
14922          function's parameters. Don't leave them in the BLOCK because they
14923          are found in the FUNCTION_DECL instead.  */
14924
14925       BLOCK_VARS (block) = 0;
14926     }
14927
14928   /* Pop the current level, and free the structure for reuse.  */
14929
14930   {
14931     register struct binding_level *level = current_binding_level;
14932     current_binding_level = current_binding_level->level_chain;
14933
14934     level->level_chain = free_binding_level;
14935     free_binding_level = level;
14936   }
14937
14938   /* Dispose of the block that we just made inside some higher level.  */
14939   if (functionbody)
14940     DECL_INITIAL (current_function_decl) = block;
14941   else if (block)
14942     {
14943       if (!block_previously_created)
14944         current_binding_level->blocks
14945           = chainon (current_binding_level->blocks, block);
14946     }
14947   /* If we did not make a block for the level just exited, any blocks made
14948      for inner levels (since they cannot be recorded as subblocks in that
14949      level) must be carried forward so they will later become subblocks of
14950      something else.  */
14951   else if (subblocks)
14952     current_binding_level->blocks
14953       = chainon (current_binding_level->blocks, subblocks);
14954
14955   /* Set the TYPE_CONTEXTs for all of the tagged types belonging to this
14956      binding contour so that they point to the appropriate construct, i.e.
14957      either to the current FUNCTION_DECL node, or else to the BLOCK node we
14958      just constructed.
14959
14960      Note that for tagged types whose scope is just the formal parameter list
14961      for some function type specification, we can't properly set their
14962      TYPE_CONTEXTs here, because we don't have a pointer to the appropriate
14963      FUNCTION_TYPE node readily available to us.  For those cases, the
14964      TYPE_CONTEXTs of the relevant tagged type nodes get set in
14965      `grokdeclarator' as soon as we have created the FUNCTION_TYPE node which
14966      will represent the "scope" for these "parameter list local" tagged
14967      types. */
14968
14969   if (block)
14970     TREE_USED (block) = 1;
14971   return block;
14972 }
14973
14974 void
14975 print_lang_decl (file, node, indent)
14976      FILE *file UNUSED;
14977      tree node UNUSED;
14978      int indent UNUSED;
14979 {
14980 }
14981
14982 void
14983 print_lang_identifier (file, node, indent)
14984      FILE *file;
14985      tree node;
14986      int indent;
14987 {
14988   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14989   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14990 }
14991
14992 void
14993 print_lang_statistics ()
14994 {
14995 }
14996
14997 void
14998 print_lang_type (file, node, indent)
14999      FILE *file UNUSED;
15000      tree node UNUSED;
15001      int indent UNUSED;
15002 {
15003 }
15004
15005 /* Record a decl-node X as belonging to the current lexical scope.
15006    Check for errors (such as an incompatible declaration for the same
15007    name already seen in the same scope).
15008
15009    Returns either X or an old decl for the same name.
15010    If an old decl is returned, it may have been smashed
15011    to agree with what X says.  */
15012
15013 tree
15014 pushdecl (x)
15015      tree x;
15016 {
15017   register tree t;
15018   register tree name = DECL_NAME (x);
15019   register struct binding_level *b = current_binding_level;
15020
15021   if ((TREE_CODE (x) == FUNCTION_DECL)
15022       && (DECL_INITIAL (x) == 0)
15023       && DECL_EXTERNAL (x))
15024     DECL_CONTEXT (x) = NULL_TREE;
15025   else
15026     DECL_CONTEXT (x) = current_function_decl;
15027
15028   if (name)
15029     {
15030       if (IDENTIFIER_INVENTED (name))
15031         {
15032 #if BUILT_FOR_270
15033           DECL_ARTIFICIAL (x) = 1;
15034 #endif
15035           DECL_IN_SYSTEM_HEADER (x) = 1;
15036           DECL_IGNORED_P (x) = 1;
15037           TREE_USED (x) = 1;
15038           if (TREE_CODE (x) == TYPE_DECL)
15039             TYPE_DECL_SUPPRESS_DEBUG (x) = 1;
15040         }
15041
15042       t = lookup_name_current_level (name);
15043
15044       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
15045
15046       /* Don't push non-parms onto list for parms until we understand
15047          why we're doing this and whether it works.  */
15048
15049       assert ((b == global_binding_level)
15050               || !ffecom_transform_only_dummies_
15051               || TREE_CODE (x) == PARM_DECL);
15052
15053       if ((t != NULL_TREE) && duplicate_decls (x, t))
15054         return t;
15055
15056       /* If we are processing a typedef statement, generate a whole new
15057          ..._TYPE node (which will be just an variant of the existing
15058          ..._TYPE node with identical properties) and then install the
15059          TYPE_DECL node generated to represent the typedef name as the
15060          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15061
15062          The whole point here is to end up with a situation where each and every
15063          ..._TYPE node the compiler creates will be uniquely associated with
15064          AT MOST one node representing a typedef name. This way, even though
15065          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15066          (i.e. "typedef name") nodes very early on, later parts of the
15067          compiler can always do the reverse translation and get back the
15068          corresponding typedef name.  For example, given:
15069
15070          typedef struct S MY_TYPE; MY_TYPE object;
15071
15072          Later parts of the compiler might only know that `object' was of type
15073          `struct S' if if were not for code just below.  With this code
15074          however, later parts of the compiler see something like:
15075
15076          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15077
15078          And they can then deduce (from the node for type struct S') that the
15079          original object declaration was:
15080
15081          MY_TYPE object;
15082
15083          Being able to do this is important for proper support of protoize, and
15084          also for generating precise symbolic debugging information which
15085          takes full account of the programmer's (typedef) vocabulary.
15086
15087          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15088          TYPE_DECL node that we are now processing really represents a
15089          standard built-in type.
15090
15091          Since all standard types are effectively declared at line zero in the
15092          source file, we can easily check to see if we are working on a
15093          standard type by checking the current value of lineno.  */
15094
15095       if (TREE_CODE (x) == TYPE_DECL)
15096         {
15097           if (DECL_SOURCE_LINE (x) == 0)
15098             {
15099               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15100                 TYPE_NAME (TREE_TYPE (x)) = x;
15101             }
15102           else if (TREE_TYPE (x) != error_mark_node)
15103             {
15104               tree tt = TREE_TYPE (x);
15105
15106               tt = build_type_copy (tt);
15107               TYPE_NAME (tt) = x;
15108               TREE_TYPE (x) = tt;
15109             }
15110         }
15111
15112       /* This name is new in its binding level. Install the new declaration
15113          and return it.  */
15114       if (b == global_binding_level)
15115         IDENTIFIER_GLOBAL_VALUE (name) = x;
15116       else
15117         IDENTIFIER_LOCAL_VALUE (name) = x;
15118     }
15119
15120   /* Put decls on list in reverse order. We will reverse them later if
15121      necessary.  */
15122   TREE_CHAIN (x) = b->names;
15123   b->names = x;
15124
15125   return x;
15126 }
15127
15128 /* Enter a new binding level.
15129    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15130    not for that of tags.  */
15131
15132 void
15133 pushlevel (tag_transparent)
15134      int tag_transparent;
15135 {
15136   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15137
15138   assert (!tag_transparent);
15139
15140   /* Reuse or create a struct for this binding level.  */
15141
15142   if (free_binding_level)
15143     {
15144       newlevel = free_binding_level;
15145       free_binding_level = free_binding_level->level_chain;
15146     }
15147   else
15148     {
15149       newlevel = make_binding_level ();
15150     }
15151
15152   /* Add this level to the front of the chain (stack) of levels that are
15153      active.  */
15154
15155   *newlevel = clear_binding_level;
15156   newlevel->level_chain = current_binding_level;
15157   current_binding_level = newlevel;
15158 }
15159
15160 /* Set the BLOCK node for the innermost scope
15161    (the one we are currently in).  */
15162
15163 void
15164 set_block (block)
15165      register tree block;
15166 {
15167   current_binding_level->this_block = block;
15168 }
15169
15170 /* ~~tree.h SHOULD declare this, because toplev.c references it.  */
15171
15172 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15173
15174 void
15175 set_yydebug (value)
15176      int value;
15177 {
15178   if (value)
15179     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15180 }
15181
15182 tree
15183 signed_or_unsigned_type (unsignedp, type)
15184      int unsignedp;
15185      tree type;
15186 {
15187   tree type2;
15188
15189   if (! INTEGRAL_TYPE_P (type))
15190     return type;
15191   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15192     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15193   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15194     return unsignedp ? unsigned_type_node : integer_type_node;
15195   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15196     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15197   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15198     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15199   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15200     return (unsignedp ? long_long_unsigned_type_node
15201             : long_long_integer_type_node);
15202
15203   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15204   if (type2 == NULL_TREE)
15205     return type;
15206
15207   return type2;
15208 }
15209
15210 tree
15211 signed_type (type)
15212      tree type;
15213 {
15214   tree type1 = TYPE_MAIN_VARIANT (type);
15215   ffeinfoKindtype kt;
15216   tree type2;
15217
15218   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15219     return signed_char_type_node;
15220   if (type1 == unsigned_type_node)
15221     return integer_type_node;
15222   if (type1 == short_unsigned_type_node)
15223     return short_integer_type_node;
15224   if (type1 == long_unsigned_type_node)
15225     return long_integer_type_node;
15226   if (type1 == long_long_unsigned_type_node)
15227     return long_long_integer_type_node;
15228 #if 0   /* gcc/c-* files only */
15229   if (type1 == unsigned_intDI_type_node)
15230     return intDI_type_node;
15231   if (type1 == unsigned_intSI_type_node)
15232     return intSI_type_node;
15233   if (type1 == unsigned_intHI_type_node)
15234     return intHI_type_node;
15235   if (type1 == unsigned_intQI_type_node)
15236     return intQI_type_node;
15237 #endif
15238
15239   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15240   if (type2 != NULL_TREE)
15241     return type2;
15242
15243   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15244     {
15245       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15246
15247       if (type1 == type2)
15248         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15249     }
15250
15251   return type;
15252 }
15253
15254 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15255    or validate its data type for an `if' or `while' statement or ?..: exp.
15256
15257    This preparation consists of taking the ordinary
15258    representation of an expression expr and producing a valid tree
15259    boolean expression describing whether expr is nonzero.  We could
15260    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15261    but we optimize comparisons, &&, ||, and !.
15262
15263    The resulting type should always be `integer_type_node'.  */
15264
15265 tree
15266 truthvalue_conversion (expr)
15267      tree expr;
15268 {
15269   if (TREE_CODE (expr) == ERROR_MARK)
15270     return expr;
15271
15272 #if 0 /* This appears to be wrong for C++.  */
15273   /* These really should return error_mark_node after 2.4 is stable.
15274      But not all callers handle ERROR_MARK properly.  */
15275   switch (TREE_CODE (TREE_TYPE (expr)))
15276     {
15277     case RECORD_TYPE:
15278       error ("struct type value used where scalar is required");
15279       return integer_zero_node;
15280
15281     case UNION_TYPE:
15282       error ("union type value used where scalar is required");
15283       return integer_zero_node;
15284
15285     case ARRAY_TYPE:
15286       error ("array type value used where scalar is required");
15287       return integer_zero_node;
15288
15289     default:
15290       break;
15291     }
15292 #endif /* 0 */
15293
15294   switch (TREE_CODE (expr))
15295     {
15296       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15297          or comparison expressions as truth values at this level.  */
15298 #if 0
15299     case COMPONENT_REF:
15300       /* A one-bit unsigned bit-field is already acceptable.  */
15301       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15302           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15303         return expr;
15304       break;
15305 #endif
15306
15307     case EQ_EXPR:
15308       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15309          or comparison expressions as truth values at this level.  */
15310 #if 0
15311       if (integer_zerop (TREE_OPERAND (expr, 1)))
15312         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15313 #endif
15314     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15315     case TRUTH_ANDIF_EXPR:
15316     case TRUTH_ORIF_EXPR:
15317     case TRUTH_AND_EXPR:
15318     case TRUTH_OR_EXPR:
15319     case TRUTH_XOR_EXPR:
15320       TREE_TYPE (expr) = integer_type_node;
15321       return expr;
15322
15323     case ERROR_MARK:
15324       return expr;
15325
15326     case INTEGER_CST:
15327       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15328
15329     case REAL_CST:
15330       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15331
15332     case ADDR_EXPR:
15333       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15334         return build (COMPOUND_EXPR, integer_type_node,
15335                       TREE_OPERAND (expr, 0), integer_one_node);
15336       else
15337         return integer_one_node;
15338
15339     case COMPLEX_EXPR:
15340       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15341                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15342                        integer_type_node,
15343                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15344                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15345
15346     case NEGATE_EXPR:
15347     case ABS_EXPR:
15348     case FLOAT_EXPR:
15349     case FFS_EXPR:
15350       /* These don't change whether an object is non-zero or zero.  */
15351       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15352
15353     case LROTATE_EXPR:
15354     case RROTATE_EXPR:
15355       /* These don't change whether an object is zero or non-zero, but
15356          we can't ignore them if their second arg has side-effects.  */
15357       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15358         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15359                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15360       else
15361         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15362
15363     case COND_EXPR:
15364       /* Distribute the conversion into the arms of a COND_EXPR.  */
15365       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15366                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15367                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15368
15369     case CONVERT_EXPR:
15370       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15371          since that affects how `default_conversion' will behave.  */
15372       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15373           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15374         break;
15375       /* fall through... */
15376     case NOP_EXPR:
15377       /* If this is widening the argument, we can ignore it.  */
15378       if (TYPE_PRECISION (TREE_TYPE (expr))
15379           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15380         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15381       break;
15382
15383     case MINUS_EXPR:
15384       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15385          this case.  */
15386       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15387           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15388         break;
15389       /* fall through... */
15390     case BIT_XOR_EXPR:
15391       /* This and MINUS_EXPR can be changed into a comparison of the
15392          two objects.  */
15393       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15394           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15395         return ffecom_2 (NE_EXPR, integer_type_node,
15396                          TREE_OPERAND (expr, 0),
15397                          TREE_OPERAND (expr, 1));
15398       return ffecom_2 (NE_EXPR, integer_type_node,
15399                        TREE_OPERAND (expr, 0),
15400                        fold (build1 (NOP_EXPR,
15401                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15402                                      TREE_OPERAND (expr, 1))));
15403
15404     case BIT_AND_EXPR:
15405       if (integer_onep (TREE_OPERAND (expr, 1)))
15406         return expr;
15407       break;
15408
15409     case MODIFY_EXPR:
15410 #if 0                           /* No such thing in Fortran. */
15411       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15412         warning ("suggest parentheses around assignment used as truth value");
15413 #endif
15414       break;
15415
15416     default:
15417       break;
15418     }
15419
15420   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15421     return (ffecom_2
15422             ((TREE_SIDE_EFFECTS (expr)
15423               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15424              integer_type_node,
15425              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15426                                               TREE_TYPE (TREE_TYPE (expr)),
15427                                               expr)),
15428              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15429                                               TREE_TYPE (TREE_TYPE (expr)),
15430                                               expr))));
15431
15432   return ffecom_2 (NE_EXPR, integer_type_node,
15433                    expr,
15434                    convert (TREE_TYPE (expr), integer_zero_node));
15435 }
15436
15437 tree
15438 type_for_mode (mode, unsignedp)
15439      enum machine_mode mode;
15440      int unsignedp;
15441 {
15442   int i;
15443   int j;
15444   tree t;
15445
15446   if (mode == TYPE_MODE (integer_type_node))
15447     return unsignedp ? unsigned_type_node : integer_type_node;
15448
15449   if (mode == TYPE_MODE (signed_char_type_node))
15450     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15451
15452   if (mode == TYPE_MODE (short_integer_type_node))
15453     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15454
15455   if (mode == TYPE_MODE (long_integer_type_node))
15456     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15457
15458   if (mode == TYPE_MODE (long_long_integer_type_node))
15459     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15460
15461   if (mode == TYPE_MODE (float_type_node))
15462     return float_type_node;
15463
15464   if (mode == TYPE_MODE (double_type_node))
15465     return double_type_node;
15466
15467   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15468     return build_pointer_type (char_type_node);
15469
15470   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15471     return build_pointer_type (integer_type_node);
15472
15473   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15474     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15475       {
15476         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15477             && (mode == TYPE_MODE (t)))
15478           if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15479             return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15480           else
15481             return t;
15482       }
15483
15484   return 0;
15485 }
15486
15487 tree
15488 type_for_size (bits, unsignedp)
15489      unsigned bits;
15490      int unsignedp;
15491 {
15492   ffeinfoKindtype kt;
15493   tree type_node;
15494
15495   if (bits == TYPE_PRECISION (integer_type_node))
15496     return unsignedp ? unsigned_type_node : integer_type_node;
15497
15498   if (bits == TYPE_PRECISION (signed_char_type_node))
15499     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15500
15501   if (bits == TYPE_PRECISION (short_integer_type_node))
15502     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15503
15504   if (bits == TYPE_PRECISION (long_integer_type_node))
15505     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15506
15507   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15508     return (unsignedp ? long_long_unsigned_type_node
15509             : long_long_integer_type_node);
15510
15511   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15512     {
15513       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15514
15515       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15516         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15517           : type_node;
15518     }
15519
15520   return 0;
15521 }
15522
15523 tree
15524 unsigned_type (type)
15525      tree type;
15526 {
15527   tree type1 = TYPE_MAIN_VARIANT (type);
15528   ffeinfoKindtype kt;
15529   tree type2;
15530
15531   if (type1 == signed_char_type_node || type1 == char_type_node)
15532     return unsigned_char_type_node;
15533   if (type1 == integer_type_node)
15534     return unsigned_type_node;
15535   if (type1 == short_integer_type_node)
15536     return short_unsigned_type_node;
15537   if (type1 == long_integer_type_node)
15538     return long_unsigned_type_node;
15539   if (type1 == long_long_integer_type_node)
15540     return long_long_unsigned_type_node;
15541 #if 0   /* gcc/c-* files only */
15542   if (type1 == intDI_type_node)
15543     return unsigned_intDI_type_node;
15544   if (type1 == intSI_type_node)
15545     return unsigned_intSI_type_node;
15546   if (type1 == intHI_type_node)
15547     return unsigned_intHI_type_node;
15548   if (type1 == intQI_type_node)
15549     return unsigned_intQI_type_node;
15550 #endif
15551
15552   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15553   if (type2 != NULL_TREE)
15554     return type2;
15555
15556   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15557     {
15558       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15559
15560       if (type1 == type2)
15561         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15562     }
15563
15564   return type;
15565 }
15566
15567 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15568 \f
15569 #if FFECOM_GCC_INCLUDE
15570
15571 /* From gcc/cccp.c, the code to handle -I.  */
15572
15573 /* Skip leading "./" from a directory name.
15574    This may yield the empty string, which represents the current directory.  */
15575
15576 static char *
15577 skip_redundant_dir_prefix (char *dir)
15578 {
15579   while (dir[0] == '.' && dir[1] == '/')
15580     for (dir += 2; *dir == '/'; dir++)
15581       continue;
15582   if (dir[0] == '.' && !dir[1])
15583     dir++;
15584   return dir;
15585 }
15586
15587 /* The file_name_map structure holds a mapping of file names for a
15588    particular directory.  This mapping is read from the file named
15589    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15590    map filenames on a file system with severe filename restrictions,
15591    such as DOS.  The format of the file name map file is just a series
15592    of lines with two tokens on each line.  The first token is the name
15593    to map, and the second token is the actual name to use.  */
15594
15595 struct file_name_map
15596 {
15597   struct file_name_map *map_next;
15598   char *map_from;
15599   char *map_to;
15600 };
15601
15602 #define FILE_NAME_MAP_FILE "header.gcc"
15603
15604 /* Current maximum length of directory names in the search path
15605    for include files.  (Altered as we get more of them.)  */
15606
15607 static int max_include_len = 0;
15608
15609 struct file_name_list
15610   {
15611     struct file_name_list *next;
15612     char *fname;
15613     /* Mapping of file names for this directory.  */
15614     struct file_name_map *name_map;
15615     /* Non-zero if name_map is valid.  */
15616     int got_name_map;
15617   };
15618
15619 static struct file_name_list *include = NULL;   /* First dir to search */
15620 static struct file_name_list *last_include = NULL;      /* Last in chain */
15621
15622 /* I/O buffer structure.
15623    The `fname' field is nonzero for source files and #include files
15624    and for the dummy text used for -D and -U.
15625    It is zero for rescanning results of macro expansion
15626    and for expanding macro arguments.  */
15627 #define INPUT_STACK_MAX 400
15628 static struct file_buf {
15629   char *fname;
15630   /* Filename specified with #line command.  */
15631   char *nominal_fname;
15632   /* Record where in the search path this file was found.
15633      For #include_next.  */
15634   struct file_name_list *dir;
15635   ffewhereLine line;
15636   ffewhereColumn column;
15637 } instack[INPUT_STACK_MAX];
15638
15639 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15640 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15641
15642 /* Current nesting level of input sources.
15643    `instack[indepth]' is the level currently being read.  */
15644 static int indepth = -1;
15645
15646 typedef struct file_buf FILE_BUF;
15647
15648 typedef unsigned char U_CHAR;
15649
15650 /* table to tell if char can be part of a C identifier. */
15651 U_CHAR is_idchar[256];
15652 /* table to tell if char can be first char of a c identifier. */
15653 U_CHAR is_idstart[256];
15654 /* table to tell if c is horizontal space.  */
15655 U_CHAR is_hor_space[256];
15656 /* table to tell if c is horizontal or vertical space.  */
15657 static U_CHAR is_space[256];
15658
15659 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15660 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15661
15662 /* Nonzero means -I- has been seen,
15663    so don't look for #include "foo" the source-file directory.  */
15664 static int ignore_srcdir;
15665
15666 #ifndef INCLUDE_LEN_FUDGE
15667 #define INCLUDE_LEN_FUDGE 0
15668 #endif
15669
15670 static void append_include_chain (struct file_name_list *first,
15671                                   struct file_name_list *last);
15672 static FILE *open_include_file (char *filename,
15673                                 struct file_name_list *searchptr);
15674 static void print_containing_files (ffebadSeverity sev);
15675 static char *skip_redundant_dir_prefix (char *);
15676 static char *read_filename_string (int ch, FILE *f);
15677 static struct file_name_map *read_name_map (char *dirname);
15678 static char *savestring (char *input);
15679
15680 /* Append a chain of `struct file_name_list's
15681    to the end of the main include chain.
15682    FIRST is the beginning of the chain to append, and LAST is the end.  */
15683
15684 static void
15685 append_include_chain (first, last)
15686      struct file_name_list *first, *last;
15687 {
15688   struct file_name_list *dir;
15689
15690   if (!first || !last)
15691     return;
15692
15693   if (include == 0)
15694     include = first;
15695   else
15696     last_include->next = first;
15697
15698   for (dir = first; ; dir = dir->next) {
15699     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15700     if (len > max_include_len)
15701       max_include_len = len;
15702     if (dir == last)
15703       break;
15704   }
15705
15706   last->next = NULL;
15707   last_include = last;
15708 }
15709
15710 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15711    being tried from the include file search path.  This function maps
15712    filenames on file systems based on information read by
15713    read_name_map.  */
15714
15715 static FILE *
15716 open_include_file (filename, searchptr)
15717      char *filename;
15718      struct file_name_list *searchptr;
15719 {
15720   register struct file_name_map *map;
15721   register char *from;
15722   char *p, *dir;
15723
15724   if (searchptr && ! searchptr->got_name_map)
15725     {
15726       searchptr->name_map = read_name_map (searchptr->fname
15727                                            ? searchptr->fname : ".");
15728       searchptr->got_name_map = 1;
15729     }
15730
15731   /* First check the mapping for the directory we are using.  */
15732   if (searchptr && searchptr->name_map)
15733     {
15734       from = filename;
15735       if (searchptr->fname)
15736         from += strlen (searchptr->fname) + 1;
15737       for (map = searchptr->name_map; map; map = map->map_next)
15738         {
15739           if (! strcmp (map->map_from, from))
15740             {
15741               /* Found a match.  */
15742               return fopen (map->map_to, "r");
15743             }
15744         }
15745     }
15746
15747   /* Try to find a mapping file for the particular directory we are
15748      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15749      in /usr/include/header.gcc and look up types.h in
15750      /usr/include/sys/header.gcc.  */
15751   p = rindex (filename, '/');
15752 #ifdef DIR_SEPARATOR
15753   if (! p) p = rindex (filename, DIR_SEPARATOR);
15754   else {
15755     char *tmp = rindex (filename, DIR_SEPARATOR);
15756     if (tmp != NULL && tmp > p) p = tmp;
15757   }
15758 #endif
15759   if (! p)
15760     p = filename;
15761   if (searchptr
15762       && searchptr->fname
15763       && strlen (searchptr->fname) == (size_t) (p - filename)
15764       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15765     {
15766       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15767       return fopen (filename, "r");
15768     }
15769
15770   if (p == filename)
15771     {
15772       from = filename;
15773       map = read_name_map (".");
15774     }
15775   else
15776     {
15777       dir = (char *) xmalloc (p - filename + 1);
15778       memcpy (dir, filename, p - filename);
15779       dir[p - filename] = '\0';
15780       from = p + 1;
15781       map = read_name_map (dir);
15782       free (dir);
15783     }
15784   for (; map; map = map->map_next)
15785     if (! strcmp (map->map_from, from))
15786       return fopen (map->map_to, "r");
15787
15788   return fopen (filename, "r");
15789 }
15790
15791 /* Print the file names and line numbers of the #include
15792    commands which led to the current file.  */
15793
15794 static void
15795 print_containing_files (ffebadSeverity sev)
15796 {
15797   FILE_BUF *ip = NULL;
15798   int i;
15799   int first = 1;
15800   char *str1;
15801   char *str2;
15802
15803   /* If stack of files hasn't changed since we last printed
15804      this info, don't repeat it.  */
15805   if (last_error_tick == input_file_stack_tick)
15806     return;
15807
15808   for (i = indepth; i >= 0; i--)
15809     if (instack[i].fname != NULL) {
15810       ip = &instack[i];
15811       break;
15812     }
15813
15814   /* Give up if we don't find a source file.  */
15815   if (ip == NULL)
15816     return;
15817
15818   /* Find the other, outer source files.  */
15819   for (i--; i >= 0; i--)
15820     if (instack[i].fname != NULL)
15821       {
15822         ip = &instack[i];
15823         if (first)
15824           {
15825             first = 0;
15826             str1 = "In file included";
15827           }
15828         else
15829           {
15830             str1 = "...          ...";
15831           }
15832
15833         if (i == 1)
15834           str2 = ":";
15835         else
15836           str2 = "";
15837
15838         ffebad_start_msg ("%A from %B at %0%C", sev);
15839         ffebad_here (0, ip->line, ip->column);
15840         ffebad_string (str1);
15841         ffebad_string (ip->nominal_fname);
15842         ffebad_string (str2);
15843         ffebad_finish ();
15844       }
15845
15846   /* Record we have printed the status as of this time.  */
15847   last_error_tick = input_file_stack_tick;
15848 }
15849
15850 /* Read a space delimited string of unlimited length from a stdio
15851    file.  */
15852
15853 static char *
15854 read_filename_string (ch, f)
15855      int ch;
15856      FILE *f;
15857 {
15858   char *alloc, *set;
15859   int len;
15860
15861   len = 20;
15862   set = alloc = xmalloc (len + 1);
15863   if (! is_space[ch])
15864     {
15865       *set++ = ch;
15866       while ((ch = getc (f)) != EOF && ! is_space[ch])
15867         {
15868           if (set - alloc == len)
15869             {
15870               len *= 2;
15871               alloc = xrealloc (alloc, len + 1);
15872               set = alloc + len / 2;
15873             }
15874           *set++ = ch;
15875         }
15876     }
15877   *set = '\0';
15878   ungetc (ch, f);
15879   return alloc;
15880 }
15881
15882 /* Read the file name map file for DIRNAME.  */
15883
15884 static struct file_name_map *
15885 read_name_map (dirname)
15886      char *dirname;
15887 {
15888   /* This structure holds a linked list of file name maps, one per
15889      directory.  */
15890   struct file_name_map_list
15891     {
15892       struct file_name_map_list *map_list_next;
15893       char *map_list_name;
15894       struct file_name_map *map_list_map;
15895     };
15896   static struct file_name_map_list *map_list;
15897   register struct file_name_map_list *map_list_ptr;
15898   char *name;
15899   FILE *f;
15900   size_t dirlen;
15901   int separator_needed;
15902
15903   dirname = skip_redundant_dir_prefix (dirname);
15904
15905   for (map_list_ptr = map_list; map_list_ptr;
15906        map_list_ptr = map_list_ptr->map_list_next)
15907     if (! strcmp (map_list_ptr->map_list_name, dirname))
15908       return map_list_ptr->map_list_map;
15909
15910   map_list_ptr = ((struct file_name_map_list *)
15911                   xmalloc (sizeof (struct file_name_map_list)));
15912   map_list_ptr->map_list_name = savestring (dirname);
15913   map_list_ptr->map_list_map = NULL;
15914
15915   dirlen = strlen (dirname);
15916   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15917   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15918   strcpy (name, dirname);
15919   name[dirlen] = '/';
15920   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15921   f = fopen (name, "r");
15922   free (name);
15923   if (!f)
15924     map_list_ptr->map_list_map = NULL;
15925   else
15926     {
15927       int ch;
15928
15929       while ((ch = getc (f)) != EOF)
15930         {
15931           char *from, *to;
15932           struct file_name_map *ptr;
15933
15934           if (is_space[ch])
15935             continue;
15936           from = read_filename_string (ch, f);
15937           while ((ch = getc (f)) != EOF && is_hor_space[ch])
15938             ;
15939           to = read_filename_string (ch, f);
15940
15941           ptr = ((struct file_name_map *)
15942                  xmalloc (sizeof (struct file_name_map)));
15943           ptr->map_from = from;
15944
15945           /* Make the real filename absolute.  */
15946           if (*to == '/')
15947             ptr->map_to = to;
15948           else
15949             {
15950               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15951               strcpy (ptr->map_to, dirname);
15952               ptr->map_to[dirlen] = '/';
15953               strcpy (ptr->map_to + dirlen + separator_needed, to);
15954               free (to);
15955             }
15956
15957           ptr->map_next = map_list_ptr->map_list_map;
15958           map_list_ptr->map_list_map = ptr;
15959
15960           while ((ch = getc (f)) != '\n')
15961             if (ch == EOF)
15962               break;
15963         }
15964       fclose (f);
15965     }
15966
15967   map_list_ptr->map_list_next = map_list;
15968   map_list = map_list_ptr;
15969
15970   return map_list_ptr->map_list_map;
15971 }
15972
15973 static char *
15974 savestring (input)
15975      char *input;
15976 {
15977   unsigned size = strlen (input);
15978   char *output = xmalloc (size + 1);
15979   strcpy (output, input);
15980   return output;
15981 }
15982
15983 static void
15984 ffecom_file_ (char *name)
15985 {
15986   FILE_BUF *fp;
15987
15988   /* Do partial setup of input buffer for the sake of generating
15989      early #line directives (when -g is in effect).  */
15990
15991   fp = &instack[++indepth];
15992   memset ((char *) fp, 0, sizeof (FILE_BUF));
15993   if (name == NULL)
15994     name = "";
15995   fp->nominal_fname = fp->fname = name;
15996 }
15997
15998 /* Initialize syntactic classifications of characters.  */
15999
16000 static void
16001 ffecom_initialize_char_syntax_ ()
16002 {
16003   register int i;
16004
16005   /*
16006    * Set up is_idchar and is_idstart tables.  These should be
16007    * faster than saying (is_alpha (c) || c == '_'), etc.
16008    * Set up these things before calling any routines tthat
16009    * refer to them.
16010    */
16011   for (i = 'a'; i <= 'z'; i++) {
16012     is_idchar[i - 'a' + 'A'] = 1;
16013     is_idchar[i] = 1;
16014     is_idstart[i - 'a' + 'A'] = 1;
16015     is_idstart[i] = 1;
16016   }
16017   for (i = '0'; i <= '9'; i++)
16018     is_idchar[i] = 1;
16019   is_idchar['_'] = 1;
16020   is_idstart['_'] = 1;
16021
16022   /* horizontal space table */
16023   is_hor_space[' '] = 1;
16024   is_hor_space['\t'] = 1;
16025   is_hor_space['\v'] = 1;
16026   is_hor_space['\f'] = 1;
16027   is_hor_space['\r'] = 1;
16028
16029   is_space[' '] = 1;
16030   is_space['\t'] = 1;
16031   is_space['\v'] = 1;
16032   is_space['\f'] = 1;
16033   is_space['\n'] = 1;
16034   is_space['\r'] = 1;
16035 }
16036
16037 static void
16038 ffecom_close_include_ (FILE *f)
16039 {
16040   fclose (f);
16041
16042   indepth--;
16043   input_file_stack_tick++;
16044
16045   ffewhere_line_kill (instack[indepth].line);
16046   ffewhere_column_kill (instack[indepth].column);
16047 }
16048
16049 static int
16050 ffecom_decode_include_option_ (char *spec)
16051 {
16052   struct file_name_list *dirtmp;
16053
16054   if (! ignore_srcdir && !strcmp (spec, "-"))
16055     ignore_srcdir = 1;
16056   else
16057     {
16058       dirtmp = (struct file_name_list *)
16059         xmalloc (sizeof (struct file_name_list));
16060       dirtmp->next = 0;         /* New one goes on the end */
16061       if (spec[0] != 0)
16062         dirtmp->fname = spec;
16063       else
16064         fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16065       dirtmp->got_name_map = 0;
16066       append_include_chain (dirtmp, dirtmp);
16067     }
16068   return 1;
16069 }
16070
16071 /* Open INCLUDEd file.  */
16072
16073 static FILE *
16074 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16075 {
16076   char *fbeg = name;
16077   size_t flen = strlen (fbeg);
16078   struct file_name_list *search_start = include; /* Chain of dirs to search */
16079   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16080   struct file_name_list *searchptr = 0;
16081   char *fname;          /* Dynamically allocated fname buffer */
16082   FILE *f;
16083   FILE_BUF *fp;
16084
16085   if (flen == 0)
16086     return NULL;
16087
16088   dsp[0].fname = NULL;
16089
16090   /* If -I- was specified, don't search current dir, only spec'd ones. */
16091   if (!ignore_srcdir)
16092     {
16093       for (fp = &instack[indepth]; fp >= instack; fp--)
16094         {
16095           int n;
16096           char *ep;
16097           char *nam;
16098
16099           if ((nam = fp->nominal_fname) != NULL)
16100             {
16101               /* Found a named file.  Figure out dir of the file,
16102                  and put it in front of the search list.  */
16103               dsp[0].next = search_start;
16104               search_start = dsp;
16105 #ifndef VMS
16106               ep = rindex (nam, '/');
16107 #ifdef DIR_SEPARATOR
16108             if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR);
16109             else {
16110               char *tmp = rindex (nam, DIR_SEPARATOR);
16111               if (tmp != NULL && tmp > ep) ep = tmp;
16112             }
16113 #endif
16114 #else                           /* VMS */
16115               ep = rindex (nam, ']');
16116               if (ep == NULL) ep = rindex (nam, '>');
16117               if (ep == NULL) ep = rindex (nam, ':');
16118               if (ep != NULL) ep++;
16119 #endif                          /* VMS */
16120               if (ep != NULL)
16121                 {
16122                   n = ep - nam;
16123                   dsp[0].fname = (char *) xmalloc (n + 1);
16124                   strncpy (dsp[0].fname, nam, n);
16125                   dsp[0].fname[n] = '\0';
16126                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16127                     max_include_len = n + INCLUDE_LEN_FUDGE;
16128                 }
16129               else
16130                 dsp[0].fname = NULL; /* Current directory */
16131               dsp[0].got_name_map = 0;
16132               break;
16133             }
16134         }
16135     }
16136
16137   /* Allocate this permanently, because it gets stored in the definitions
16138      of macros.  */
16139   fname = xmalloc (max_include_len + flen + 4);
16140   /* + 2 above for slash and terminating null.  */
16141   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16142      for g77 yet).  */
16143
16144   /* If specified file name is absolute, just open it.  */
16145
16146   if (*fbeg == '/'
16147 #ifdef DIR_SEPARATOR
16148       || *fbeg == DIR_SEPARATOR
16149 #endif
16150       )
16151     {
16152       strncpy (fname, (char *) fbeg, flen);
16153       fname[flen] = 0;
16154       f = open_include_file (fname, NULL_PTR);
16155     }
16156   else
16157     {
16158       f = NULL;
16159
16160       /* Search directory path, trying to open the file.
16161          Copy each filename tried into FNAME.  */
16162
16163       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16164         {
16165           if (searchptr->fname)
16166             {
16167               /* The empty string in a search path is ignored.
16168                  This makes it possible to turn off entirely
16169                  a standard piece of the list.  */
16170               if (searchptr->fname[0] == 0)
16171                 continue;
16172               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16173               if (fname[0] && fname[strlen (fname) - 1] != '/')
16174                 strcat (fname, "/");
16175               fname[strlen (fname) + flen] = 0;
16176             }
16177           else
16178             fname[0] = 0;
16179
16180           strncat (fname, fbeg, flen);
16181 #ifdef VMS
16182           /* Change this 1/2 Unix 1/2 VMS file specification into a
16183              full VMS file specification */
16184           if (searchptr->fname && (searchptr->fname[0] != 0))
16185             {
16186               /* Fix up the filename */
16187               hack_vms_include_specification (fname);
16188             }
16189           else
16190             {
16191               /* This is a normal VMS filespec, so use it unchanged.  */
16192               strncpy (fname, (char *) fbeg, flen);
16193               fname[flen] = 0;
16194 #if 0   /* Not for g77.  */
16195               /* if it's '#include filename', add the missing .h */
16196               if (index (fname, '.') == NULL)
16197                 strcat (fname, ".h");
16198 #endif
16199             }
16200 #endif /* VMS */
16201           f = open_include_file (fname, searchptr);
16202 #ifdef EACCES
16203           if (f == NULL && errno == EACCES)
16204             {
16205               print_containing_files (FFEBAD_severityWARNING);
16206               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16207                                 FFEBAD_severityWARNING);
16208               ffebad_string (fname);
16209               ffebad_here (0, l, c);
16210               ffebad_finish ();
16211             }
16212 #endif
16213           if (f != NULL)
16214             break;
16215         }
16216     }
16217
16218   if (f == NULL)
16219     {
16220       /* A file that was not found.  */
16221
16222       strncpy (fname, (char *) fbeg, flen);
16223       fname[flen] = 0;
16224       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16225       ffebad_start (FFEBAD_OPEN_INCLUDE);
16226       ffebad_here (0, l, c);
16227       ffebad_string (fname);
16228       ffebad_finish ();
16229     }
16230
16231   if (dsp[0].fname != NULL)
16232     free (dsp[0].fname);
16233
16234   if (f == NULL)
16235     return NULL;
16236
16237   if (indepth >= (INPUT_STACK_MAX - 1))
16238     {
16239       print_containing_files (FFEBAD_severityFATAL);
16240       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16241                         FFEBAD_severityFATAL);
16242       ffebad_string (fname);
16243       ffebad_here (0, l, c);
16244       ffebad_finish ();
16245       return NULL;
16246     }
16247
16248   instack[indepth].line = ffewhere_line_use (l);
16249   instack[indepth].column = ffewhere_column_use (c);
16250
16251   fp = &instack[indepth + 1];
16252   memset ((char *) fp, 0, sizeof (FILE_BUF));
16253   fp->nominal_fname = fp->fname = fname;
16254   fp->dir = searchptr;
16255
16256   indepth++;
16257   input_file_stack_tick++;
16258
16259   return f;
16260 }
16261 #endif  /* FFECOM_GCC_INCLUDE */