gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995-1998 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley.
   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 #include "proj.h"
  89 #if FFECOM_targetCURRENT == FFECOM_targetGCC
  90 #include "flags.j"
  91 #include "rtl.j"
  92 #include "toplev.j"
  93 #include "tree.j"
  94 #include "output.j"  /* Must follow tree.j so TREE_CODE is defined! */
  95 #include "convert.j"
  96 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
  97
  98 #define FFECOM_GCC_INCLUDE 1    /* Enable -I. */
  99
 100 /* BEGIN stuff from gcc/cccp.c.  */
 101
 102 /* The following symbols should be autoconfigured:
 103         HAVE_FCNTL_H
 104         HAVE_STDLIB_H
 105         HAVE_SYS_TIME_H
 106         HAVE_UNISTD_H
 107         STDC_HEADERS
 108         TIME_WITH_SYS_TIME
 109    In the mean time, we'll get by with approximations based
 110    on existing GCC configuration symbols.  */
 111
 112 #ifdef POSIX
 113 # ifndef HAVE_STDLIB_H
 114 # define HAVE_STDLIB_H 1
 115 # endif
 116 # ifndef HAVE_UNISTD_H
 117 # define HAVE_UNISTD_H 1
 118 # endif
 119 # ifndef STDC_HEADERS
 120 # define STDC_HEADERS 1
 121 # endif
 122 #endif /* defined (POSIX) */
 123
 124 #if defined (POSIX) || (defined (USG) && !defined (VMS))
 125 # ifndef HAVE_FCNTL_H
 126 # define HAVE_FCNTL_H 1
 127 # endif
 128 #endif
 129
 130 #ifndef RLIMIT_STACK
 131 # include <time.h>
 132 #else
 133 # if TIME_WITH_SYS_TIME
 134 #  include <sys/time.h>
 135 #  include <time.h>
 136 # else
 137 #  if HAVE_SYS_TIME_H
 138 #   include <sys/time.h>
 139 #  else
 140 #   include <time.h>
 141 #  endif
 142 # endif
 143 # include <sys/resource.h>
 144 #endif
 145
 146 #if HAVE_FCNTL_H
 147 # include <fcntl.h>
 148 #endif
 149
 150 /* This defines "errno" properly for VMS, and gives us EACCES. */
 151 #include <errno.h>
 152
 153 #if HAVE_STDLIB_H
 154 # include <stdlib.h>
 155 #else
 156 char *getenv ();
 157 #endif
 158
 159 #if HAVE_UNISTD_H
 160 # include <unistd.h>
 161 #endif
 162
 163 /* VMS-specific definitions */
 164 #ifdef VMS
 165 #include <descrip.h>
 166 #define O_RDONLY        0       /* Open arg for Read/Only  */
 167 #define O_WRONLY        1       /* Open arg for Write/Only */
 168 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 169 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 170 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 171 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 172 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 173 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 174 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 175 static int VMS_fstat (), VMS_stat ();
 176 static char * VMS_strncat ();
 177 static int VMS_read ();
 178 static int VMS_write ();
 179 static int VMS_open ();
 180 static FILE * VMS_fopen ();
 181 static FILE * VMS_freopen ();
 182 static void hack_vms_include_specification ();
 183 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 184 #define ino_t vms_ino_t
 185 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 186 #ifdef __GNUC__
 187 #define BSTRING                 /* VMS/GCC supplies the bstring routines */
 188 #endif /* __GNUC__ */
 189 #endif /* VMS */
 190
 191 #ifndef O_RDONLY
 192 #define O_RDONLY 0
 193 #endif
 194
 195 /* END stuff from gcc/cccp.c.  */
 196
 197 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 198 #include "com.h"
 199 #include "bad.h"
 200 #include "bld.h"
 201 #include "equiv.h"
 202 #include "expr.h"
 203 #include "implic.h"
 204 #include "info.h"
 205 #include "malloc.h"
 206 #include "src.h"
 207 #include "st.h"
 208 #include "storag.h"
 209 #include "symbol.h"
 210 #include "target.h"
 211 #include "top.h"
 212 #include "type.h"
 213
 214 /* Externals defined here.  */
 215
 216 #define FFECOM_FASTER_ARRAY_REFS 0      /* Generates faster code? */
 217
 218 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 219
 220 /* tree.h declares a bunch of stuff that it expects the front end to
 221    define.  Here are the definitions, which in the C front end are
 222    found in the file c-decl.c.  */
 223
 224 tree integer_zero_node;
 225 tree integer_one_node;
 226 tree null_pointer_node;
 227 tree error_mark_node;
 228 tree void_type_node;
 229 tree integer_type_node;
 230 tree unsigned_type_node;
 231 tree char_type_node;
 232 tree current_function_decl;
 233
 234 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
 235    reference it.  */
 236
 237 char *language_string = "GNU F77";
 238
 239 /* Stream for reading from the input file.  */
 240 FILE *finput;
 241
 242 /* These definitions parallel those in c-decl.c so that code from that
 243    module can be used pretty much as is.  Much of these defs aren't
 244    otherwise used, i.e. by g77 code per se, except some of them are used
 245    to build some of them that are.  The ones that are global (i.e. not
 246    "static") are those that ste.c and such might use (directly
 247    or by using com macros that reference them in their definitions).  */
 248
 249 static tree short_integer_type_node;
 250 tree long_integer_type_node;
 251 static tree long_long_integer_type_node;
 252
 253 static tree short_unsigned_type_node;
 254 static tree long_unsigned_type_node;
 255 static tree long_long_unsigned_type_node;
 256
 257 static tree unsigned_char_type_node;
 258 static tree signed_char_type_node;
 259
 260 static tree float_type_node;
 261 static tree double_type_node;
 262 static tree complex_float_type_node;
 263 tree complex_double_type_node;
 264 static tree long_double_type_node;
 265 static tree complex_integer_type_node;
 266 static tree complex_long_double_type_node;
 267
 268 tree string_type_node;
 269
 270 static tree double_ftype_double;
 271 static tree float_ftype_float;
 272 static tree ldouble_ftype_ldouble;
 273
 274 /* The rest of these are inventions for g77, though there might be
 275    similar things in the C front end.  As they are found, these
 276    inventions should be renamed to be canonical.  Note that only
 277    the ones currently required to be global are so.  */
 278
 279 static tree ffecom_tree_fun_type_void;
 280 static tree ffecom_tree_ptr_to_fun_type_void;
 281
 282 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 283 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 284 tree ffecom_integer_one_node;   /* " */
 285 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 286
 287 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 288    just use build_function_type and build_pointer_type on the
 289    appropriate _tree_type array element.  */
 290
 291 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 292 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 293 static tree ffecom_tree_subr_type;
 294 static tree ffecom_tree_ptr_to_subr_type;
 295 static tree ffecom_tree_blockdata_type;
 296
 297 static tree ffecom_tree_xargc_;
 298
 299 ffecomSymbol ffecom_symbol_null_
 300 =
 301 {
 302   NULL_TREE,
 303   NULL_TREE,
 304   NULL_TREE,
 305   NULL_TREE,
 306   false
 307 };
 308 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 309 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 310
 311 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 312 tree ffecom_f2c_integer_type_node;
 313 tree ffecom_f2c_ptr_to_integer_type_node;
 314 tree ffecom_f2c_address_type_node;
 315 tree ffecom_f2c_real_type_node;
 316 tree ffecom_f2c_ptr_to_real_type_node;
 317 tree ffecom_f2c_doublereal_type_node;
 318 tree ffecom_f2c_complex_type_node;
 319 tree ffecom_f2c_doublecomplex_type_node;
 320 tree ffecom_f2c_longint_type_node;
 321 tree ffecom_f2c_logical_type_node;
 322 tree ffecom_f2c_flag_type_node;
 323 tree ffecom_f2c_ftnlen_type_node;
 324 tree ffecom_f2c_ftnlen_zero_node;
 325 tree ffecom_f2c_ftnlen_one_node;
 326 tree ffecom_f2c_ftnlen_two_node;
 327 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 328 tree ffecom_f2c_ftnint_type_node;
 329 tree ffecom_f2c_ptr_to_ftnint_type_node;
 330 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 331
 332 /* Simple definitions and enumerations. */
 333
 334 #ifndef FFECOM_sizeMAXSTACKITEM
 335 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 336                                            larger than this # bytes
 337                                            off stack if possible. */
 338 #endif
 339
 340 /* For systems that have large enough stacks, they should define
 341    this to 0, and here, for ease of use later on, we just undefine
 342    it if it is 0.  */
 343
 344 #if FFECOM_sizeMAXSTACKITEM == 0
 345 #undef FFECOM_sizeMAXSTACKITEM
 346 #endif
 347
 348 typedef enum
 349   {
 350     FFECOM_rttypeVOID_,
 351     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 352     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 353     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 354     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 355     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 356     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 357     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 358     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 359     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 360     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 361     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 362     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 363     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 364     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 365     FFECOM_rttype_
 366   } ffecomRttype_;
 367
 368 /* Internal typedefs. */
 369
 370 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 371 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 372 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 373
 374 /* Private include files. */
 375
 376
 377 /* Internal structure definitions. */
 378
 379 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 380 struct _ffecom_concat_list_
 381   {
 382     ffebld *exprs;
 383     int count;
 384     int max;
 385     ffetargetCharacterSize minlen;
 386     ffetargetCharacterSize maxlen;
 387   };
 388 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 389
 390 /* Static functions (internal). */
 391
 392 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 393 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 394 static tree ffecom_widest_expr_type_ (ffebld list);
 395 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 396                              tree dest_size, tree source_tree,
 397                              ffebld source, bool scalar_arg);
 398 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 399                                       tree args, tree callee_commons,
 400                                       bool scalar_args);
 401 static tree ffecom_build_f2c_string_ (int i, const char *s);
 402 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 403                           bool is_f2c_complex, tree type,
 404                           tree args, tree dest_tree,
 405                           ffebld dest, bool *dest_used,
 406                           tree callee_commons, bool scalar_args, tree hook);
 407 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 408                                 bool is_f2c_complex, tree type,
 409                                 ffebld left, ffebld right,
 410                                 tree dest_tree, ffebld dest,
 411                                 bool *dest_used, tree callee_commons,
 412                                 bool scalar_args, tree hook);
 413 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 414                                  ffebld expr, bool with_null);
 415 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 416 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 417 static ffecomConcatList_
 418   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 419                               ffebld expr,
 420                               ffetargetCharacterSize max);
 421 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 422 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 423                                                 ffetargetCharacterSize max);
 424 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 425                                   ffesymbol member, tree member_type,
 426                                   ffetargetOffset offset);
 427 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 428 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 429                           bool *dest_used, bool assignp, bool widenp);
 430 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 431                                     ffebld dest, bool *dest_used);
 432 static tree ffecom_expr_power_integer_ (ffebld expr);
 433 static void ffecom_expr_transform_ (ffebld expr);
 434 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 435 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 436                                       int code);
 437 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 438 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 439 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 440 static tree ffecom_get_external_identifier_ (ffesymbol s);
 441 static tree ffecom_get_identifier_ (const char *text);
 442 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 443                                   ffeinfoBasictype bt,
 444                                   ffeinfoKindtype kt);
 445 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 446 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 447 static tree ffecom_init_zero_ (tree decl);
 448 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 449                                      tree *maybe_tree);
 450 static tree ffecom_intrinsic_len_ (ffebld expr);
 451 static void ffecom_let_char_ (tree dest_tree,
 452                               tree dest_length,
 453                               ffetargetCharacterSize dest_size,
 454                               ffebld source);
 455 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 456 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 457 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
 458 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 459 #endif
 460 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 461                                       ffebld source);
 462 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 463                                       bool stmtfunc);
 464 static void ffecom_start_progunit_ (void);
 465 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 466 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 467 static void ffecom_transform_common_ (ffesymbol s);
 468 static void ffecom_transform_equiv_ (ffestorag st);
 469 static tree ffecom_transform_namelist_ (ffesymbol s);
 470 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 471                                        tree t);
 472 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 473                                        tree *size, tree tree);
 474 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 475                                  tree dest_tree, ffebld dest,
 476                                  bool *dest_used, tree hook);
 477 static tree ffecom_type_localvar_ (ffesymbol s,
 478                                    ffeinfoBasictype bt,
 479                                    ffeinfoKindtype kt);
 480 static tree ffecom_type_namelist_ (void);
 481 #if 0
 482 static tree ffecom_type_permanent_copy_ (tree t);
 483 #endif
 484 static tree ffecom_type_vardesc_ (void);
 485 static tree ffecom_vardesc_ (ffebld expr);
 486 static tree ffecom_vardesc_array_ (ffesymbol s);
 487 static tree ffecom_vardesc_dims_ (ffesymbol s);
 488 static tree ffecom_convert_narrow_ (tree type, tree expr);
 489 static tree ffecom_convert_widen_ (tree type, tree expr);
 490 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 491
 492 /* These are static functions that parallel those found in the C front
 493    end and thus have the same names.  */
 494
 495 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 496 static tree bison_rule_compstmt_ (void);
 497 static void bison_rule_pushlevel_ (void);
 498 static tree builtin_function (const char *name, tree type,
 499                               enum built_in_function function_code,
 500                               const char *library_name);
 501 static void delete_block (tree block);
 502 static int duplicate_decls (tree newdecl, tree olddecl);
 503 static void finish_decl (tree decl, tree init, bool is_top_level);
 504 static void finish_function (int nested);
 505 static char *lang_printable_name (tree decl, int v);
 506 static tree lookup_name_current_level (tree name);
 507 static struct binding_level *make_binding_level (void);
 508 static void pop_f_function_context (void);
 509 static void push_f_function_context (void);
 510 static void push_parm_decl (tree parm);
 511 static tree pushdecl_top_level (tree decl);
 512 static int kept_level_p (void);
 513 static tree storedecls (tree decls);
 514 static void store_parm_decls (int is_main_program);
 515 static tree start_decl (tree decl, bool is_top_level);
 516 static void start_function (tree name, tree type, int nested, int public);
 517 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 518 #if FFECOM_GCC_INCLUDE
 519 static void ffecom_file_ (char *name);
 520 static void ffecom_initialize_char_syntax_ (void);
 521 static void ffecom_close_include_ (FILE *f);
 522 static int ffecom_decode_include_option_ (char *spec);
 523 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 524                                    ffewhereColumn c);
 525 #endif  /* FFECOM_GCC_INCLUDE */
 526
 527 /* Static objects accessed by functions in this module. */
 528
 529 static ffesymbol ffecom_primary_entry_ = NULL;
 530 static ffesymbol ffecom_nested_entry_ = NULL;
 531 static ffeinfoKind ffecom_primary_entry_kind_;
 532 static bool ffecom_primary_entry_is_proc_;
 533 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 534 static tree ffecom_outer_function_decl_;
 535 static tree ffecom_previous_function_decl_;
 536 static tree ffecom_which_entrypoint_decl_;
 537 static tree ffecom_float_zero_ = NULL_TREE;
 538 static tree ffecom_float_half_ = NULL_TREE;
 539 static tree ffecom_double_zero_ = NULL_TREE;
 540 static tree ffecom_double_half_ = NULL_TREE;
 541 static tree ffecom_func_result_;/* For functions. */
 542 static tree ffecom_func_length_;/* For CHARACTER fns. */
 543 static ffebld ffecom_list_blockdata_;
 544 static ffebld ffecom_list_common_;
 545 static ffebld ffecom_master_arglist_;
 546 static ffeinfoBasictype ffecom_master_bt_;
 547 static ffeinfoKindtype ffecom_master_kt_;
 548 static ffetargetCharacterSize ffecom_master_size_;
 549 static int ffecom_num_fns_ = 0;
 550 static int ffecom_num_entrypoints_ = 0;
 551 static bool ffecom_is_altreturning_ = FALSE;
 552 static tree ffecom_multi_type_node_;
 553 static tree ffecom_multi_retval_;
 554 static tree
 555   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 556 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 557 static bool ffecom_doing_entry_ = FALSE;
 558 static bool ffecom_transform_only_dummies_ = FALSE;
 559
 560 /* Holds pointer-to-function expressions.  */
 561
 562 static tree ffecom_gfrt_[FFECOM_gfrt]
 563 =
 564 {
 565 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE,
 566 #include "com-rt.def"
 567 #undef DEFGFRT
 568 };
 569
 570 /* Holds the external names of the functions.  */
 571
 572 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
 573 =
 574 {
 575 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME,
 576 #include "com-rt.def"
 577 #undef DEFGFRT
 578 };
 579
 580 /* Whether the function returns.  */
 581
 582 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 583 =
 584 {
 585 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE,
 586 #include "com-rt.def"
 587 #undef DEFGFRT
 588 };
 589
 590 /* Whether the function returns type complex.  */
 591
 592 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 593 =
 594 {
 595 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX,
 596 #include "com-rt.def"
 597 #undef DEFGFRT
 598 };
 599
 600 /* Type code for the function return value.  */
 601
 602 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 603 =
 604 {
 605 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE,
 606 #include "com-rt.def"
 607 #undef DEFGFRT
 608 };
 609
 610 /* String of codes for the function's arguments.  */
 611
 612 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
 613 =
 614 {
 615 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS,
 616 #include "com-rt.def"
 617 #undef DEFGFRT
 618 };
 619 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 620
 621 /* Internal macros. */
 622
 623 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 624
 625 /* We let tm.h override the types used here, to handle trivial differences
 626    such as the choice of unsigned int or long unsigned int for size_t.
 627    When machines start needing nontrivial differences in the size type,
 628    it would be best to do something here to figure out automatically
 629    from other information what type to use.  */
 630
 631 /* NOTE: g77 currently doesn't use these; see setting of sizetype and
 632    change that if you need to.  -- jcb 09/01/91. */
 633
 634 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 635 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 636 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 637 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 638
 639 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 640 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 641
 642 /* For each binding contour we allocate a binding_level structure
 643  * which records the names defined in that contour.
 644  * Contours include:
 645  *  0) the global one
 646  *  1) one for each function definition,
 647  *     where internal declarations of the parameters appear.
 648  *
 649  * The current meaning of a name can be found by searching the levels from
 650  * the current one out to the global one.
 651  */
 652
 653 /* Note that the information in the `names' component of the global contour
 654    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 655
 656 struct binding_level
 657   {
 658     /* A chain of _DECL nodes for all variables, constants, functions,
 659        and typedef types.  These are in the reverse of the order supplied.
 660      */
 661     tree names;
 662
 663     /* For each level (except not the global one),
 664        a chain of BLOCK nodes for all the levels
 665        that were entered and exited one level down.  */
 666     tree blocks;
 667
 668     /* The BLOCK node for this level, if one has been preallocated.
 669        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 670     tree this_block;
 671
 672     /* The binding level which this one is contained in (inherits from).  */
 673     struct binding_level *level_chain;
 674
 675     /* 0: no ffecom_prepare_* functions called at this level yet;
 676        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 677        2: ffecom_prepare_end called.  */
 678     int prep_state;
 679   };
 680
 681 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 682
 683 /* The binding level currently in effect.  */
 684
 685 static struct binding_level *current_binding_level;
 686
 687 /* A chain of binding_level structures awaiting reuse.  */
 688
 689 static struct binding_level *free_binding_level;
 690
 691 /* The outermost binding level, for names of file scope.
 692    This is created when the compiler is started and exists
 693    through the entire run.  */
 694
 695 static struct binding_level *global_binding_level;
 696
 697 /* Binding level structures are initialized by copying this one.  */
 698
 699 static struct binding_level clear_binding_level
 700 =
 701 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 702
 703 /* Language-dependent contents of an identifier.  */
 704
 705 struct lang_identifier
 706   {
 707     struct tree_identifier ignore;
 708     tree global_value, local_value, label_value;
 709     bool invented;
 710   };
 711
 712 /* Macros for access to language-specific slots in an identifier.  */
 713 /* Each of these slots contains a DECL node or null.  */
 714
 715 /* This represents the value which the identifier has in the
 716    file-scope namespace.  */
 717 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 718   (((struct lang_identifier *)(NODE))->global_value)
 719 /* This represents the value which the identifier has in the current
 720    scope.  */
 721 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 722   (((struct lang_identifier *)(NODE))->local_value)
 723 /* This represents the value which the identifier has as a label in
 724    the current label scope.  */
 725 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 726   (((struct lang_identifier *)(NODE))->label_value)
 727 /* This is nonzero if the identifier was "made up" by g77 code.  */
 728 #define IDENTIFIER_INVENTED(NODE)       \
 729   (((struct lang_identifier *)(NODE))->invented)
 730
 731 /* In identifiers, C uses the following fields in a special way:
 732    TREE_PUBLIC        to record that there was a previous local extern decl.
 733    TREE_USED          to record that such a decl was used.
 734    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 735
 736 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 737    that have names.  Here so we can clear out their names' definitions
 738    at the end of the function.  */
 739
 740 static tree named_labels;
 741
 742 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 743
 744 static tree shadowed_labels;
 745
 746 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 747 \f
 748 /* Return the subscript expression, modified to do range-checking.
 749
 750    `array' is the array to be checked against.
 751    `element' is the subscript expression to check.
 752    `dim' is the dimension number (starting at 0).
 753    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 754 */
 755
 756 static tree
 757 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 758                          char *array_name)
 759 {
 760   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 761   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 762   tree cond;
 763   tree die;
 764   tree args;
 765
 766   if (element == error_mark_node)
 767     return element;
 768
 769   element = ffecom_save_tree (element);
 770   cond = ffecom_2 (LE_EXPR, integer_type_node,
 771                    low,
 772                    element);
 773   if (high)
 774     {
 775       cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 776                        cond,
 777                        ffecom_2 (LE_EXPR, integer_type_node,
 778                                  element,
 779                                  high));
 780     }
 781
 782   {
 783     int len;
 784     char *proc;
 785     char *var;
 786     tree arg3;
 787     tree arg2;
 788     tree arg1;
 789     tree arg4;
 790
 791     switch (total_dims)
 792       {
 793       case 0:
 794         var = xmalloc (strlen (array_name) + 20);
 795         sprintf (&var[0], "%s[%s-substring]",
 796                  array_name,
 797                  dim ? "end" : "start");
 798         len = strlen (var) + 1;
 799         break;
 800
 801       case 1:
 802         len = strlen (array_name) + 1;
 803         var = array_name;
 804         break;
 805
 806       default:
 807         var = xmalloc (strlen (array_name) + 40);
 808         sprintf (&var[0], "%s[subscript-%d-of-%d]",
 809                  array_name,
 810                  dim + 1, total_dims);
 811         len = strlen (var) + 1;
 812         break;
 813       }
 814
 815     arg1 = build_string (len, var);
 816
 817     if (total_dims != 1)
 818       free (var);
 819
 820     TREE_TYPE (arg1)
 821       = build_type_variant (build_array_type (char_type_node,
 822                                               build_range_type
 823                                               (integer_type_node,
 824                                                integer_one_node,
 825                                                build_int_2 (len, 0))),
 826                             1, 0);
 827     TREE_CONSTANT (arg1) = 1;
 828     TREE_STATIC (arg1) = 1;
 829     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 830                      arg1);
 831
 832     /* s_rnge adds one to the element to print it, so bias against
 833        that -- want to print a faithful *subscript* value.  */
 834     arg2 = convert (ffecom_f2c_ftnint_type_node,
 835                     ffecom_2 (MINUS_EXPR,
 836                               TREE_TYPE (element),
 837                               element,
 838                               convert (TREE_TYPE (element),
 839                                        integer_one_node)));
 840
 841     proc = xmalloc ((len = strlen (input_filename)
 842                      + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl))
 843                      + 2));
 844
 845     sprintf (&proc[0], "%s/%s",
 846              input_filename,
 847              IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 848     arg3 = build_string (len, proc);
 849
 850     free (proc);
 851
 852     TREE_TYPE (arg3)
 853       = build_type_variant (build_array_type (char_type_node,
 854                                               build_range_type
 855                                               (integer_type_node,
 856                                                integer_one_node,
 857                                                build_int_2 (len, 0))),
 858                             1, 0);
 859     TREE_CONSTANT (arg3) = 1;
 860     TREE_STATIC (arg3) = 1;
 861     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 862                      arg3);
 863
 864     arg4 = convert (ffecom_f2c_ftnint_type_node,
 865                     build_int_2 (lineno, 0));
 866
 867     arg1 = build_tree_list (NULL_TREE, arg1);
 868     arg2 = build_tree_list (NULL_TREE, arg2);
 869     arg3 = build_tree_list (NULL_TREE, arg3);
 870     arg4 = build_tree_list (NULL_TREE, arg4);
 871     TREE_CHAIN (arg3) = arg4;
 872     TREE_CHAIN (arg2) = arg3;
 873     TREE_CHAIN (arg1) = arg2;
 874
 875     args = arg1;
 876   }
 877   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 878                           args, NULL_TREE);
 879   TREE_SIDE_EFFECTS (die) = 1;
 880
 881   element = ffecom_3 (COND_EXPR,
 882                       TREE_TYPE (element),
 883                       cond,
 884                       element,
 885                       die);
 886
 887   return element;
 888 }
 889
 890 /* Return the computed element of an array reference.
 891
 892    `item' is the array or a pointer to the array.  It must be a pointer
 893      to the array if ffe_is_flat_arrays ().
 894    `expr' is the original opARRAYREF expression.
 895    `want_ptr' is non-zero if `item' is a pointer to the element, instead of
 896      the element itself, is to be returned.  */
 897
 898 static tree
 899 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 900 {
 901   ffebld dims[FFECOM_dimensionsMAX];
 902   int i;
 903   int total_dims;
 904   int flatten = 0 /* ~~~ ffe_is_flat_arrays () */;
 905   int need_ptr = want_ptr || flatten;
 906   tree array;
 907   tree element;
 908   char *array_name;
 909
 910   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 911     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 912   else
 913     array_name = "[expr?]";
 914
 915   /* Build up ARRAY_REFs in reverse order (since we're column major
 916      here in Fortran land). */
 917
 918   for (i = 0, expr = ffebld_right (expr);
 919        expr != NULL;
 920        expr = ffebld_trail (expr))
 921     dims[i++] = ffebld_head (expr);
 922
 923   total_dims = i;
 924
 925   if (need_ptr)
 926     {
 927       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 928            i >= 0;
 929            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 930         {
 931           element = ffecom_expr (dims[i]);
 932           if (ffe_is_subscript_check ())
 933             element = ffecom_subscript_check_ (array, element, i, total_dims,
 934                                                array_name);
 935           item = ffecom_2 (PLUS_EXPR,
 936                            build_pointer_type (TREE_TYPE (array)),
 937                            item,
 938                            size_binop (MULT_EXPR,
 939                                        size_in_bytes (TREE_TYPE (array)),
 940                                        convert (sizetype,
 941                                                 fold (build (MINUS_EXPR,
 942                                                              TREE_TYPE (TYPE_MIN_VALUE (TYPE_DOMAIN (array))),
 943                                                              element,
 944                                                              TYPE_MIN_VALUE (TYPE_DOMAIN (array)))))));
 945         }
 946       if (! want_ptr)
 947         {
 948           item = ffecom_1 (INDIRECT_REF,
 949                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 950                            item);
 951         }
 952     }
 953   else
 954     {
 955       for (--i;
 956            i >= 0;
 957            --i)
 958         {
 959           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 960
 961           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 962           if (ffe_is_subscript_check ())
 963             element = ffecom_subscript_check_ (array, element, i, total_dims,
 964                                                array_name);
 965           item = ffecom_2 (ARRAY_REF,
 966                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 967                            item,
 968                            element);
 969         }
 970     }
 971
 972   return item;
 973 }
 974
 975 /* This is like gcc's stabilize_reference -- in fact, most of the code
 976    comes from that -- but it handles the situation where the reference
 977    is going to have its subparts picked at, and it shouldn't change
 978    (or trigger extra invocations of functions in the subtrees) due to
 979    this.  save_expr is a bit overzealous, because we don't need the
 980    entire thing calculated and saved like a temp.  So, for DECLs, no
 981    change is needed, because these are stable aggregates, and ARRAY_REF
 982    and such might well be stable too, but for things like calculations,
 983    we do need to calculate a snapshot of a value before picking at it.  */
 984
 985 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 986 static tree
 987 ffecom_stabilize_aggregate_ (tree ref)
 988 {
 989   tree result;
 990   enum tree_code code = TREE_CODE (ref);
 991
 992   switch (code)
 993     {
 994     case VAR_DECL:
 995     case PARM_DECL:
 996     case RESULT_DECL:
 997       /* No action is needed in this case.  */
 998       return ref;
 999
1000     case NOP_EXPR:
1001     case CONVERT_EXPR:
1002     case FLOAT_EXPR:
1003     case FIX_TRUNC_EXPR:
1004     case FIX_FLOOR_EXPR:
1005     case FIX_ROUND_EXPR:
1006     case FIX_CEIL_EXPR:
1007       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1008       break;
1009
1010     case INDIRECT_REF:
1011       result = build_nt (INDIRECT_REF,
1012                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1013       break;
1014
1015     case COMPONENT_REF:
1016       result = build_nt (COMPONENT_REF,
1017                          stabilize_reference (TREE_OPERAND (ref, 0)),
1018                          TREE_OPERAND (ref, 1));
1019       break;
1020
1021     case BIT_FIELD_REF:
1022       result = build_nt (BIT_FIELD_REF,
1023                          stabilize_reference (TREE_OPERAND (ref, 0)),
1024                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1025                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1026       break;
1027
1028     case ARRAY_REF:
1029       result = build_nt (ARRAY_REF,
1030                          stabilize_reference (TREE_OPERAND (ref, 0)),
1031                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1032       break;
1033
1034     case COMPOUND_EXPR:
1035       result = build_nt (COMPOUND_EXPR,
1036                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1037                          stabilize_reference (TREE_OPERAND (ref, 1)));
1038       break;
1039
1040     case RTL_EXPR:
1041       result = build1 (INDIRECT_REF, TREE_TYPE (ref),
1042                        save_expr (build1 (ADDR_EXPR,
1043                                           build_pointer_type (TREE_TYPE (ref)),
1044                                           ref)));
1045       break;
1046
1047
1048     default:
1049       return save_expr (ref);
1050
1051     case ERROR_MARK:
1052       return error_mark_node;
1053     }
1054
1055   TREE_TYPE (result) = TREE_TYPE (ref);
1056   TREE_READONLY (result) = TREE_READONLY (ref);
1057   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1058   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1059   TREE_RAISES (result) = TREE_RAISES (ref);
1060
1061   return result;
1062 }
1063 #endif
1064
1065 /* A rip-off of gcc's convert.c convert_to_complex function,
1066    reworked to handle complex implemented as C structures
1067    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1068
1069 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1070 static tree
1071 ffecom_convert_to_complex_ (tree type, tree expr)
1072 {
1073   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1074   tree subtype;
1075
1076   assert (TREE_CODE (type) == RECORD_TYPE);
1077
1078   subtype = TREE_TYPE (TYPE_FIELDS (type));
1079
1080   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1081     {
1082       expr = convert (subtype, expr);
1083       return ffecom_2 (COMPLEX_EXPR, type, expr,
1084                        convert (subtype, integer_zero_node));
1085     }
1086
1087   if (form == RECORD_TYPE)
1088     {
1089       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1090       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1091         return expr;
1092       else
1093         {
1094           expr = save_expr (expr);
1095           return ffecom_2 (COMPLEX_EXPR,
1096                            type,
1097                            convert (subtype,
1098                                     ffecom_1 (REALPART_EXPR,
1099                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1100                                               expr)),
1101                            convert (subtype,
1102                                     ffecom_1 (IMAGPART_EXPR,
1103                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1104                                               expr)));
1105         }
1106     }
1107
1108   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1109     error ("pointer value used where a complex was expected");
1110   else
1111     error ("aggregate value used where a complex was expected");
1112
1113   return ffecom_2 (COMPLEX_EXPR, type,
1114                    convert (subtype, integer_zero_node),
1115                    convert (subtype, integer_zero_node));
1116 }
1117 #endif
1118
1119 /* Like gcc's convert(), but crashes if widening might happen.  */
1120
1121 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1122 static tree
1123 ffecom_convert_narrow_ (type, expr)
1124      tree type, expr;
1125 {
1126   register tree e = expr;
1127   register enum tree_code code = TREE_CODE (type);
1128
1129   if (type == TREE_TYPE (e)
1130       || TREE_CODE (e) == ERROR_MARK)
1131     return e;
1132   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1133     return fold (build1 (NOP_EXPR, type, e));
1134   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1135       || code == ERROR_MARK)
1136     return error_mark_node;
1137   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1138     {
1139       assert ("void value not ignored as it ought to be" == NULL);
1140       return error_mark_node;
1141     }
1142   assert (code != VOID_TYPE);
1143   if ((code != RECORD_TYPE)
1144       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1145     assert ("converting COMPLEX to REAL" == NULL);
1146   assert (code != ENUMERAL_TYPE);
1147   if (code == INTEGER_TYPE)
1148     {
1149       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1150                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1151               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1152                   && (TYPE_PRECISION (type)
1153                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1154       return fold (convert_to_integer (type, e));
1155     }
1156   if (code == POINTER_TYPE)
1157     {
1158       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1159       return fold (convert_to_pointer (type, e));
1160     }
1161   if (code == REAL_TYPE)
1162     {
1163       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1164       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1165       return fold (convert_to_real (type, e));
1166     }
1167   if (code == COMPLEX_TYPE)
1168     {
1169       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1170       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1171       return fold (convert_to_complex (type, e));
1172     }
1173   if (code == RECORD_TYPE)
1174     {
1175       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1176       /* Check that at least the first field name agrees.  */
1177       assert (DECL_NAME (TYPE_FIELDS (type))
1178               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1179       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1180               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1181       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1182           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1183         return e;
1184       return fold (ffecom_convert_to_complex_ (type, e));
1185     }
1186
1187   assert ("conversion to non-scalar type requested" == NULL);
1188   return error_mark_node;
1189 }
1190 #endif
1191
1192 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1193
1194 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1195 static tree
1196 ffecom_convert_widen_ (type, expr)
1197      tree type, expr;
1198 {
1199   register tree e = expr;
1200   register enum tree_code code = TREE_CODE (type);
1201
1202   if (type == TREE_TYPE (e)
1203       || TREE_CODE (e) == ERROR_MARK)
1204     return e;
1205   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1206     return fold (build1 (NOP_EXPR, type, e));
1207   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1208       || code == ERROR_MARK)
1209     return error_mark_node;
1210   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1211     {
1212       assert ("void value not ignored as it ought to be" == NULL);
1213       return error_mark_node;
1214     }
1215   assert (code != VOID_TYPE);
1216   if ((code != RECORD_TYPE)
1217       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1218     assert ("narrowing COMPLEX to REAL" == NULL);
1219   assert (code != ENUMERAL_TYPE);
1220   if (code == INTEGER_TYPE)
1221     {
1222       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1223                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1224               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1225                   && (TYPE_PRECISION (type)
1226                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1227       return fold (convert_to_integer (type, e));
1228     }
1229   if (code == POINTER_TYPE)
1230     {
1231       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1232       return fold (convert_to_pointer (type, e));
1233     }
1234   if (code == REAL_TYPE)
1235     {
1236       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1237       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1238       return fold (convert_to_real (type, e));
1239     }
1240   if (code == COMPLEX_TYPE)
1241     {
1242       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1243       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1244       return fold (convert_to_complex (type, e));
1245     }
1246   if (code == RECORD_TYPE)
1247     {
1248       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1249       /* Check that at least the first field name agrees.  */
1250       assert (DECL_NAME (TYPE_FIELDS (type))
1251               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1252       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1253               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1254       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1255           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1256         return e;
1257       return fold (ffecom_convert_to_complex_ (type, e));
1258     }
1259
1260   assert ("conversion to non-scalar type requested" == NULL);
1261   return error_mark_node;
1262 }
1263 #endif
1264
1265 /* Handles making a COMPLEX type, either the standard
1266    (but buggy?) gbe way, or the safer (but less elegant?)
1267    f2c way.  */
1268
1269 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1270 static tree
1271 ffecom_make_complex_type_ (tree subtype)
1272 {
1273   tree type;
1274   tree realfield;
1275   tree imagfield;
1276
1277   if (ffe_is_emulate_complex ())
1278     {
1279       type = make_node (RECORD_TYPE);
1280       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1281       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1282       TYPE_FIELDS (type) = realfield;
1283       layout_type (type);
1284     }
1285   else
1286     {
1287       type = make_node (COMPLEX_TYPE);
1288       TREE_TYPE (type) = subtype;
1289       layout_type (type);
1290     }
1291
1292   return type;
1293 }
1294 #endif
1295
1296 /* Chooses either the gbe or the f2c way to build a
1297    complex constant.  */
1298
1299 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1300 static tree
1301 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1302 {
1303   tree bothparts;
1304
1305   if (ffe_is_emulate_complex ())
1306     {
1307       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1308       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1309       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1310     }
1311   else
1312     {
1313       bothparts = build_complex (type, realpart, imagpart);
1314     }
1315
1316   return bothparts;
1317 }
1318 #endif
1319
1320 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1321 static tree
1322 ffecom_arglist_expr_ (const char *c, ffebld expr)
1323 {
1324   tree list;
1325   tree *plist = &list;
1326   tree trail = NULL_TREE;       /* Append char length args here. */
1327   tree *ptrail = &trail;
1328   tree length;
1329   ffebld exprh;
1330   tree item;
1331   bool ptr = FALSE;
1332   tree wanted = NULL_TREE;
1333   static char zed[] = "0";
1334
1335   if (c == NULL)
1336     c = &zed[0];
1337
1338   while (expr != NULL)
1339     {
1340       if (*c != '\0')
1341         {
1342           ptr = FALSE;
1343           if (*c == '&')
1344             {
1345               ptr = TRUE;
1346               ++c;
1347             }
1348           switch (*(c++))
1349             {
1350             case '\0':
1351               ptr = TRUE;
1352               wanted = NULL_TREE;
1353               break;
1354
1355             case 'a':
1356               assert (ptr);
1357               wanted = NULL_TREE;
1358               break;
1359
1360             case 'c':
1361               wanted = ffecom_f2c_complex_type_node;
1362               break;
1363
1364             case 'd':
1365               wanted = ffecom_f2c_doublereal_type_node;
1366               break;
1367
1368             case 'e':
1369               wanted = ffecom_f2c_doublecomplex_type_node;
1370               break;
1371
1372             case 'f':
1373               wanted = ffecom_f2c_real_type_node;
1374               break;
1375
1376             case 'i':
1377               wanted = ffecom_f2c_integer_type_node;
1378               break;
1379
1380             case 'j':
1381               wanted = ffecom_f2c_longint_type_node;
1382               break;
1383
1384             default:
1385               assert ("bad argstring code" == NULL);
1386               wanted = NULL_TREE;
1387               break;
1388             }
1389         }
1390
1391       exprh = ffebld_head (expr);
1392       if (exprh == NULL)
1393         wanted = NULL_TREE;
1394
1395       if ((wanted == NULL_TREE)
1396           || (ptr
1397               && (TYPE_MODE
1398                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1399                    [ffeinfo_kindtype (ffebld_info (exprh))])
1400                    == TYPE_MODE (wanted))))
1401         *plist
1402           = build_tree_list (NULL_TREE,
1403                              ffecom_arg_ptr_to_expr (exprh,
1404                                                      &length));
1405       else
1406         {
1407           item = ffecom_arg_expr (exprh, &length);
1408           item = ffecom_convert_widen_ (wanted, item);
1409           if (ptr)
1410             {
1411               item = ffecom_1 (ADDR_EXPR,
1412                                build_pointer_type (TREE_TYPE (item)),
1413                                item);
1414             }
1415           *plist
1416             = build_tree_list (NULL_TREE,
1417                                item);
1418         }
1419
1420       plist = &TREE_CHAIN (*plist);
1421       expr = ffebld_trail (expr);
1422       if (length != NULL_TREE)
1423         {
1424           *ptrail = build_tree_list (NULL_TREE, length);
1425           ptrail = &TREE_CHAIN (*ptrail);
1426         }
1427     }
1428
1429   /* We've run out of args in the call; if the implementation expects
1430      more, supply null pointers for them, which the implementation can
1431      check to see if an arg was omitted. */
1432
1433   while (*c != '\0' && *c != '0')
1434     {
1435       if (*c == '&')
1436         ++c;
1437       else
1438         assert ("missing arg to run-time routine!" == NULL);
1439
1440       switch (*(c++))
1441         {
1442         case '\0':
1443         case 'a':
1444         case 'c':
1445         case 'd':
1446         case 'e':
1447         case 'f':
1448         case 'i':
1449         case 'j':
1450           break;
1451
1452         default:
1453           assert ("bad arg string code" == NULL);
1454           break;
1455         }
1456       *plist
1457         = build_tree_list (NULL_TREE,
1458                            null_pointer_node);
1459       plist = &TREE_CHAIN (*plist);
1460     }
1461
1462   *plist = trail;
1463
1464   return list;
1465 }
1466 #endif
1467
1468 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1469 static tree
1470 ffecom_widest_expr_type_ (ffebld list)
1471 {
1472   ffebld item;
1473   ffebld widest = NULL;
1474   ffetype type;
1475   ffetype widest_type = NULL;
1476   tree t;
1477
1478   for (; list != NULL; list = ffebld_trail (list))
1479     {
1480       item = ffebld_head (list);
1481       if (item == NULL)
1482         continue;
1483       if ((widest != NULL)
1484           && (ffeinfo_basictype (ffebld_info (item))
1485               != ffeinfo_basictype (ffebld_info (widest))))
1486         continue;
1487       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1488                            ffeinfo_kindtype (ffebld_info (item)));
1489       if ((widest == FFEINFO_kindtypeNONE)
1490           || (ffetype_size (type)
1491               > ffetype_size (widest_type)))
1492         {
1493           widest = item;
1494           widest_type = type;
1495         }
1496     }
1497
1498   assert (widest != NULL);
1499   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1500     [ffeinfo_kindtype (ffebld_info (widest))];
1501   assert (t != NULL_TREE);
1502   return t;
1503 }
1504 #endif
1505
1506 /* Check whether dest and source might overlap.  ffebld versions of these
1507    might or might not be passed, will be NULL if not.
1508
1509    The test is really whether source_tree is modifiable and, if modified,
1510    might overlap destination such that the value(s) in the destination might
1511    change before it is finally modified.  dest_* are the canonized
1512    destination itself.  */
1513
1514 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1515 static bool
1516 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1517                  tree source_tree, ffebld source UNUSED,
1518                  bool scalar_arg)
1519 {
1520   tree source_decl;
1521   tree source_offset;
1522   tree source_size;
1523   tree t;
1524
1525   if (source_tree == NULL_TREE)
1526     return FALSE;
1527
1528   switch (TREE_CODE (source_tree))
1529     {
1530     case ERROR_MARK:
1531     case IDENTIFIER_NODE:
1532     case INTEGER_CST:
1533     case REAL_CST:
1534     case COMPLEX_CST:
1535     case STRING_CST:
1536     case CONST_DECL:
1537     case VAR_DECL:
1538     case RESULT_DECL:
1539     case FIELD_DECL:
1540     case MINUS_EXPR:
1541     case MULT_EXPR:
1542     case TRUNC_DIV_EXPR:
1543     case CEIL_DIV_EXPR:
1544     case FLOOR_DIV_EXPR:
1545     case ROUND_DIV_EXPR:
1546     case TRUNC_MOD_EXPR:
1547     case CEIL_MOD_EXPR:
1548     case FLOOR_MOD_EXPR:
1549     case ROUND_MOD_EXPR:
1550     case RDIV_EXPR:
1551     case EXACT_DIV_EXPR:
1552     case FIX_TRUNC_EXPR:
1553     case FIX_CEIL_EXPR:
1554     case FIX_FLOOR_EXPR:
1555     case FIX_ROUND_EXPR:
1556     case FLOAT_EXPR:
1557     case EXPON_EXPR:
1558     case NEGATE_EXPR:
1559     case MIN_EXPR:
1560     case MAX_EXPR:
1561     case ABS_EXPR:
1562     case FFS_EXPR:
1563     case LSHIFT_EXPR:
1564     case RSHIFT_EXPR:
1565     case LROTATE_EXPR:
1566     case RROTATE_EXPR:
1567     case BIT_IOR_EXPR:
1568     case BIT_XOR_EXPR:
1569     case BIT_AND_EXPR:
1570     case BIT_ANDTC_EXPR:
1571     case BIT_NOT_EXPR:
1572     case TRUTH_ANDIF_EXPR:
1573     case TRUTH_ORIF_EXPR:
1574     case TRUTH_AND_EXPR:
1575     case TRUTH_OR_EXPR:
1576     case TRUTH_XOR_EXPR:
1577     case TRUTH_NOT_EXPR:
1578     case LT_EXPR:
1579     case LE_EXPR:
1580     case GT_EXPR:
1581     case GE_EXPR:
1582     case EQ_EXPR:
1583     case NE_EXPR:
1584     case COMPLEX_EXPR:
1585     case CONJ_EXPR:
1586     case REALPART_EXPR:
1587     case IMAGPART_EXPR:
1588     case LABEL_EXPR:
1589     case COMPONENT_REF:
1590       return FALSE;
1591
1592     case COMPOUND_EXPR:
1593       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1594                               TREE_OPERAND (source_tree, 1), NULL,
1595                               scalar_arg);
1596
1597     case MODIFY_EXPR:
1598       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1599                               TREE_OPERAND (source_tree, 0), NULL,
1600                               scalar_arg);
1601
1602     case CONVERT_EXPR:
1603     case NOP_EXPR:
1604     case NON_LVALUE_EXPR:
1605     case PLUS_EXPR:
1606       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1607         return TRUE;
1608
1609       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1610                                  source_tree);
1611       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1612       break;
1613
1614     case COND_EXPR:
1615       return
1616         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1617                          TREE_OPERAND (source_tree, 1), NULL,
1618                          scalar_arg)
1619           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1620                               TREE_OPERAND (source_tree, 2), NULL,
1621                               scalar_arg);
1622
1623
1624     case ADDR_EXPR:
1625       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1626                                  &source_size,
1627                                  TREE_OPERAND (source_tree, 0));
1628       break;
1629
1630     case PARM_DECL:
1631       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1632         return TRUE;
1633
1634       source_decl = source_tree;
1635       source_offset = size_zero_node;
1636       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1637       break;
1638
1639     case SAVE_EXPR:
1640     case REFERENCE_EXPR:
1641     case PREDECREMENT_EXPR:
1642     case PREINCREMENT_EXPR:
1643     case POSTDECREMENT_EXPR:
1644     case POSTINCREMENT_EXPR:
1645     case INDIRECT_REF:
1646     case ARRAY_REF:
1647     case CALL_EXPR:
1648     default:
1649       return TRUE;
1650     }
1651
1652   /* Come here when source_decl, source_offset, and source_size filled
1653      in appropriately.  */
1654
1655   if (source_decl == NULL_TREE)
1656     return FALSE;               /* No decl involved, so no overlap. */
1657
1658   if (source_decl != dest_decl)
1659     return FALSE;               /* Different decl, no overlap. */
1660
1661   if (TREE_CODE (dest_size) == ERROR_MARK)
1662     return TRUE;                /* Assignment into entire assumed-size
1663                                    array?  Shouldn't happen.... */
1664
1665   t = ffecom_2 (LE_EXPR, integer_type_node,
1666                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1667                           dest_offset,
1668                           convert (TREE_TYPE (dest_offset),
1669                                    dest_size)),
1670                 convert (TREE_TYPE (dest_offset),
1671                          source_offset));
1672
1673   if (integer_onep (t))
1674     return FALSE;               /* Destination precedes source. */
1675
1676   if (!scalar_arg
1677       || (source_size == NULL_TREE)
1678       || (TREE_CODE (source_size) == ERROR_MARK)
1679       || integer_zerop (source_size))
1680     return TRUE;                /* No way to tell if dest follows source. */
1681
1682   t = ffecom_2 (LE_EXPR, integer_type_node,
1683                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1684                           source_offset,
1685                           convert (TREE_TYPE (source_offset),
1686                                    source_size)),
1687                 convert (TREE_TYPE (source_offset),
1688                          dest_offset));
1689
1690   if (integer_onep (t))
1691     return FALSE;               /* Destination follows source. */
1692
1693   return TRUE;          /* Destination and source overlap. */
1694 }
1695 #endif
1696
1697 /* Check whether dest might overlap any of a list of arguments or is
1698    in a COMMON area the callee might know about (and thus modify).  */
1699
1700 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1701 static bool
1702 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1703                           tree args, tree callee_commons,
1704                           bool scalar_args)
1705 {
1706   tree arg;
1707   tree dest_decl;
1708   tree dest_offset;
1709   tree dest_size;
1710
1711   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1712                              dest_tree);
1713
1714   if (dest_decl == NULL_TREE)
1715     return FALSE;               /* Seems unlikely! */
1716
1717   /* If the decl cannot be determined reliably, or if its in COMMON
1718      and the callee isn't known to not futz with COMMON via other
1719      means, overlap might happen.  */
1720
1721   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1722       || ((callee_commons != NULL_TREE)
1723           && TREE_PUBLIC (dest_decl)))
1724     return TRUE;
1725
1726   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1727     {
1728       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1729           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1730                               arg, NULL, scalar_args))
1731         return TRUE;
1732     }
1733
1734   return FALSE;
1735 }
1736 #endif
1737
1738 /* Build a string for a variable name as used by NAMELIST.  This means that
1739    if we're using the f2c library, we build an uppercase string, since
1740    f2c does this.  */
1741
1742 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1743 static tree
1744 ffecom_build_f2c_string_ (int i, const char *s)
1745 {
1746   if (!ffe_is_f2c_library ())
1747     return build_string (i, s);
1748
1749   {
1750     char *tmp;
1751     const char *p;
1752     char *q;
1753     char space[34];
1754     tree t;
1755
1756     if (((size_t) i) > ARRAY_SIZE (space))
1757       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1758     else
1759       tmp = &space[0];
1760
1761     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1762       *q = ffesrc_toupper (*p);
1763     *q = '\0';
1764
1765     t = build_string (i, tmp);
1766
1767     if (((size_t) i) > ARRAY_SIZE (space))
1768       malloc_kill_ks (malloc_pool_image (), tmp, i);
1769
1770     return t;
1771   }
1772 }
1773
1774 #endif
1775 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1776    type to just get whatever the function returns), handling the
1777    f2c value-returning convention, if required, by prepending
1778    to the arglist a pointer to a temporary to receive the return value.  */
1779
1780 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1781 static tree
1782 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1783               tree type, tree args, tree dest_tree,
1784               ffebld dest, bool *dest_used, tree callee_commons,
1785               bool scalar_args, tree hook)
1786 {
1787   tree item;
1788   tree tempvar;
1789
1790   if (dest_used != NULL)
1791     *dest_used = FALSE;
1792
1793   if (is_f2c_complex)
1794     {
1795       if ((dest_used == NULL)
1796           || (dest == NULL)
1797           || (ffeinfo_basictype (ffebld_info (dest))
1798               != FFEINFO_basictypeCOMPLEX)
1799           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1800           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1801           || ffecom_args_overlapping_ (dest_tree, dest, args,
1802                                        callee_commons,
1803                                        scalar_args))
1804         {
1805 #ifdef HOHO
1806           tempvar = ffecom_make_tempvar (ffecom_tree_type
1807                                          [FFEINFO_basictypeCOMPLEX][kt],
1808                                          FFETARGET_charactersizeNONE,
1809                                          -1);
1810 #else
1811           tempvar = hook;
1812           assert (tempvar);
1813 #endif
1814         }
1815       else
1816         {
1817           *dest_used = TRUE;
1818           tempvar = dest_tree;
1819           type = NULL_TREE;
1820         }
1821
1822       item
1823         = build_tree_list (NULL_TREE,
1824                            ffecom_1 (ADDR_EXPR,
1825                                      build_pointer_type (TREE_TYPE (tempvar)),
1826                                      tempvar));
1827       TREE_CHAIN (item) = args;
1828
1829       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1830                         item, NULL_TREE);
1831
1832       if (tempvar != dest_tree)
1833         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1834     }
1835   else
1836     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1837                       args, NULL_TREE);
1838
1839   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1840     item = ffecom_convert_narrow_ (type, item);
1841
1842   return item;
1843 }
1844 #endif
1845
1846 /* Given two arguments, transform them and make a call to the given
1847    function via ffecom_call_.  */
1848
1849 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1850 static tree
1851 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1852                     tree type, ffebld left, ffebld right,
1853                     tree dest_tree, ffebld dest, bool *dest_used,
1854                     tree callee_commons, bool scalar_args, tree hook)
1855 {
1856   tree left_tree;
1857   tree right_tree;
1858   tree left_length;
1859   tree right_length;
1860
1861   left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1862   right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1863
1864   left_tree = build_tree_list (NULL_TREE, left_tree);
1865   right_tree = build_tree_list (NULL_TREE, right_tree);
1866   TREE_CHAIN (left_tree) = right_tree;
1867
1868   if (left_length != NULL_TREE)
1869     {
1870       left_length = build_tree_list (NULL_TREE, left_length);
1871       TREE_CHAIN (right_tree) = left_length;
1872     }
1873
1874   if (right_length != NULL_TREE)
1875     {
1876       right_length = build_tree_list (NULL_TREE, right_length);
1877       if (left_length != NULL_TREE)
1878         TREE_CHAIN (left_length) = right_length;
1879       else
1880         TREE_CHAIN (right_tree) = right_length;
1881     }
1882
1883   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1884                        dest_tree, dest, dest_used, callee_commons,
1885                        scalar_args, hook);
1886 }
1887 #endif
1888
1889 /* Return ptr/length args for char subexpression
1890
1891    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1892    subexpressions by constructing the appropriate trees for the ptr-to-
1893    character-text and length-of-character-text arguments in a calling
1894    sequence.
1895
1896    Note that if with_null is TRUE, and the expression is an opCONTER,
1897    a null byte is appended to the string.  */
1898
1899 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1900 static void
1901 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1902 {
1903   tree item;
1904   tree high;
1905   ffetargetCharacter1 val;
1906   ffetargetCharacterSize newlen;
1907
1908   switch (ffebld_op (expr))
1909     {
1910     case FFEBLD_opCONTER:
1911       val = ffebld_constant_character1 (ffebld_conter (expr));
1912       newlen = ffetarget_length_character1 (val);
1913       if (with_null)
1914         {
1915           /* Begin FFETARGET-NULL-KLUDGE.  */
1916           if (newlen != 0)
1917             ++newlen;
1918         }
1919       *length = build_int_2 (newlen, 0);
1920       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1921       high = build_int_2 (newlen, 0);
1922       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1923       item = build_string (newlen,
1924                            ffetarget_text_character1 (val));
1925       /* End FFETARGET-NULL-KLUDGE.  */
1926       TREE_TYPE (item)
1927         = build_type_variant
1928           (build_array_type
1929            (char_type_node,
1930             build_range_type
1931             (ffecom_f2c_ftnlen_type_node,
1932              ffecom_f2c_ftnlen_one_node,
1933              high)),
1934            1, 0);
1935       TREE_CONSTANT (item) = 1;
1936       TREE_STATIC (item) = 1;
1937       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1938                        item);
1939       break;
1940
1941     case FFEBLD_opSYMTER:
1942       {
1943         ffesymbol s = ffebld_symter (expr);
1944
1945         item = ffesymbol_hook (s).decl_tree;
1946         if (item == NULL_TREE)
1947           {
1948             s = ffecom_sym_transform_ (s);
1949             item = ffesymbol_hook (s).decl_tree;
1950           }
1951         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1952           {
1953             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1954               *length = ffesymbol_hook (s).length_tree;
1955             else
1956               {
1957                 *length = build_int_2 (ffesymbol_size (s), 0);
1958                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1959               }
1960           }
1961         else if (item == error_mark_node)
1962           *length = error_mark_node;
1963         else
1964           /* FFEINFO_kindFUNCTION.  */
1965           *length = NULL_TREE;
1966         if (!ffesymbol_hook (s).addr
1967             && (item != error_mark_node))
1968           item = ffecom_1 (ADDR_EXPR,
1969                            build_pointer_type (TREE_TYPE (item)),
1970                            item);
1971       }
1972       break;
1973
1974     case FFEBLD_opARRAYREF:
1975       {
1976         ffecom_char_args_ (&item, length, ffebld_left (expr));
1977
1978         if (item == error_mark_node || *length == error_mark_node)
1979           {
1980             item = *length = error_mark_node;
1981             break;
1982           }
1983
1984         item = ffecom_arrayref_ (item, expr, 1);
1985       }
1986       break;
1987
1988     case FFEBLD_opSUBSTR:
1989       {
1990         ffebld start;
1991         ffebld end;
1992         ffebld thing = ffebld_right (expr);
1993         tree start_tree;
1994         tree end_tree;
1995         char *char_name;
1996         ffebld left_symter;
1997         tree array;
1998
1999         assert (ffebld_op (thing) == FFEBLD_opITEM);
2000         start = ffebld_head (thing);
2001         thing = ffebld_trail (thing);
2002         assert (ffebld_trail (thing) == NULL);
2003         end = ffebld_head (thing);
2004
2005         /* Determine name for pretty-printing range-check errors.  */
2006         for (left_symter = ffebld_left (expr);
2007              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2008              left_symter = ffebld_left (left_symter))
2009           ;
2010         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2011           char_name = ffesymbol_text (ffebld_symter (left_symter));
2012         else
2013           char_name = "[expr?]";
2014
2015         ffecom_char_args_ (&item, length, ffebld_left (expr));
2016
2017         if (item == error_mark_node || *length == error_mark_node)
2018           {
2019             item = *length = error_mark_node;
2020             break;
2021           }
2022
2023         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2024
2025         if (start == NULL)
2026           {
2027             if (end == NULL)
2028               ;
2029             else
2030               {
2031                 end_tree = ffecom_expr (end);
2032                 if (ffe_is_subscript_check ())
2033                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2034                                                       char_name);
2035                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2036                                     end_tree);
2037
2038                 if (end_tree == error_mark_node)
2039                   {
2040                     item = *length = error_mark_node;
2041                     break;
2042                   }
2043
2044                 *length = end_tree;
2045               }
2046           }
2047         else
2048           {
2049             start_tree = ffecom_expr (start);
2050             if (ffe_is_subscript_check ())
2051               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2052                                                     char_name);
2053             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2054                                   start_tree);
2055
2056             if (start_tree == error_mark_node)
2057               {
2058                 item = *length = error_mark_node;
2059                 break;
2060               }
2061
2062             start_tree = ffecom_save_tree (start_tree);
2063
2064             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2065                              item,
2066                              ffecom_2 (MINUS_EXPR,
2067                                        TREE_TYPE (start_tree),
2068                                        start_tree,
2069                                        ffecom_f2c_ftnlen_one_node));
2070
2071             if (end == NULL)
2072               {
2073                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2074                                     ffecom_f2c_ftnlen_one_node,
2075                                     ffecom_2 (MINUS_EXPR,
2076                                               ffecom_f2c_ftnlen_type_node,
2077                                               *length,
2078                                               start_tree));
2079               }
2080             else
2081               {
2082                 end_tree = ffecom_expr (end);
2083                 if (ffe_is_subscript_check ())
2084                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2085                                                       char_name);
2086                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2087                                     end_tree);
2088
2089                 if (end_tree == error_mark_node)
2090                   {
2091                     item = *length = error_mark_node;
2092                     break;
2093                   }
2094
2095                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2096                                     ffecom_f2c_ftnlen_one_node,
2097                                     ffecom_2 (MINUS_EXPR,
2098                                               ffecom_f2c_ftnlen_type_node,
2099                                               end_tree, start_tree));
2100               }
2101           }
2102       }
2103       break;
2104
2105     case FFEBLD_opFUNCREF:
2106       {
2107         ffesymbol s = ffebld_symter (ffebld_left (expr));
2108         tree tempvar;
2109         tree args;
2110         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2111         ffecomGfrt ix;
2112
2113         if (size == FFETARGET_charactersizeNONE)
2114           /* ~~Kludge alert!  This should someday be fixed. */
2115           size = 24;
2116
2117         *length = build_int_2 (size, 0);
2118         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2119
2120         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2121             == FFEINFO_whereINTRINSIC)
2122           {
2123             if (size == 1)
2124               {
2125                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2126                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2127                                                NULL, NULL);
2128                 break;
2129               }
2130             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2131             assert (ix != FFECOM_gfrt);
2132             item = ffecom_gfrt_tree_ (ix);
2133           }
2134         else
2135           {
2136             ix = FFECOM_gfrt;
2137             item = ffesymbol_hook (s).decl_tree;
2138             if (item == NULL_TREE)
2139               {
2140                 s = ffecom_sym_transform_ (s);
2141                 item = ffesymbol_hook (s).decl_tree;
2142               }
2143             if (item == error_mark_node)
2144               {
2145                 item = *length = error_mark_node;
2146                 break;
2147               }
2148
2149             if (!ffesymbol_hook (s).addr)
2150               item = ffecom_1_fn (item);
2151           }
2152
2153 #ifdef HOHO
2154         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2155 #else
2156         tempvar = ffebld_nonter_hook (expr);
2157         assert (tempvar);
2158 #endif
2159         tempvar = ffecom_1 (ADDR_EXPR,
2160                             build_pointer_type (TREE_TYPE (tempvar)),
2161                             tempvar);
2162
2163         args = build_tree_list (NULL_TREE, tempvar);
2164
2165         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2166           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2167         else
2168           {
2169             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2170             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2171               {
2172                 TREE_CHAIN (TREE_CHAIN (args))
2173                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2174                                           ffebld_right (expr));
2175               }
2176             else
2177               {
2178                 TREE_CHAIN (TREE_CHAIN (args))
2179                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2180               }
2181           }
2182
2183         item = ffecom_3s (CALL_EXPR,
2184                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2185                           item, args, NULL_TREE);
2186         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2187                          tempvar);
2188       }
2189       break;
2190
2191     case FFEBLD_opCONVERT:
2192
2193       ffecom_char_args_ (&item, length, ffebld_left (expr));
2194
2195       if (item == error_mark_node || *length == error_mark_node)
2196         {
2197           item = *length = error_mark_node;
2198           break;
2199         }
2200
2201       if ((ffebld_size_known (ffebld_left (expr))
2202            == FFETARGET_charactersizeNONE)
2203           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2204         {                       /* Possible blank-padding needed, copy into
2205                                    temporary. */
2206           tree tempvar;
2207           tree args;
2208           tree newlen;
2209
2210 #ifdef HOHO
2211           tempvar = ffecom_make_tempvar (char_type_node,
2212                                          ffebld_size (expr), -1);
2213 #else
2214           tempvar = ffebld_nonter_hook (expr);
2215           assert (tempvar);
2216 #endif
2217           tempvar = ffecom_1 (ADDR_EXPR,
2218                               build_pointer_type (TREE_TYPE (tempvar)),
2219                               tempvar);
2220
2221           newlen = build_int_2 (ffebld_size (expr), 0);
2222           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2223
2224           args = build_tree_list (NULL_TREE, tempvar);
2225           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2226           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2227           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2228             = build_tree_list (NULL_TREE, *length);
2229
2230           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2231           TREE_SIDE_EFFECTS (item) = 1;
2232           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2233                            tempvar);
2234           *length = newlen;
2235         }
2236       else
2237         {                       /* Just truncate the length. */
2238           *length = build_int_2 (ffebld_size (expr), 0);
2239           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2240         }
2241       break;
2242
2243     default:
2244       assert ("bad op for single char arg expr" == NULL);
2245       item = NULL_TREE;
2246       break;
2247     }
2248
2249   *xitem = item;
2250 }
2251 #endif
2252
2253 /* Check the size of the type to be sure it doesn't overflow the
2254    "portable" capacities of the compiler back end.  `dummy' types
2255    can generally overflow the normal sizes as long as the computations
2256    themselves don't overflow.  A particular target of the back end
2257    must still enforce its size requirements, though, and the back
2258    end takes care of this in stor-layout.c.  */
2259
2260 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2261 static tree
2262 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2263 {
2264   if (TREE_CODE (type) == ERROR_MARK)
2265     return type;
2266
2267   if (TYPE_SIZE (type) == NULL_TREE)
2268     return type;
2269
2270   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2271     return type;
2272
2273   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2274       || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2275                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2276     {
2277       ffebad_start (FFEBAD_ARRAY_LARGE);
2278       ffebad_string (ffesymbol_text (s));
2279       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2280       ffebad_finish ();
2281
2282       return error_mark_node;
2283     }
2284
2285   return type;
2286 }
2287 #endif
2288
2289 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2290    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2291    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2292
2293 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2294 static tree
2295 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2296 {
2297   ffetargetCharacterSize sz = ffesymbol_size (s);
2298   tree highval;
2299   tree tlen;
2300   tree type = *xtype;
2301
2302   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2303     tlen = NULL_TREE;           /* A statement function, no length passed. */
2304   else
2305     {
2306       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2307         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2308                                                ffesymbol_text (s), -1);
2309       else
2310         tlen = ffecom_get_invented_identifier ("__g77_%s",
2311                                                "length", -1);
2312       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2313 #if BUILT_FOR_270
2314       DECL_ARTIFICIAL (tlen) = 1;
2315 #endif
2316     }
2317
2318   if (sz == FFETARGET_charactersizeNONE)
2319     {
2320       assert (tlen != NULL_TREE);
2321       highval = variable_size (tlen);
2322     }
2323   else
2324     {
2325       highval = build_int_2 (sz, 0);
2326       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2327     }
2328
2329   type = build_array_type (type,
2330                            build_range_type (ffecom_f2c_ftnlen_type_node,
2331                                              ffecom_f2c_ftnlen_one_node,
2332                                              highval));
2333
2334   *xtype = type;
2335   return tlen;
2336 }
2337
2338 #endif
2339 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2340
2341    ffecomConcatList_ catlist;
2342    ffebld expr;  // expr of CHARACTER basictype.
2343    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2344    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2345
2346    Scans expr for character subexpressions, updates and returns catlist
2347    accordingly.  */
2348
2349 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2350 static ffecomConcatList_
2351 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2352                             ffetargetCharacterSize max)
2353 {
2354   ffetargetCharacterSize sz;
2355
2356 recurse:                        /* :::::::::::::::::::: */
2357
2358   if (expr == NULL)
2359     return catlist;
2360
2361   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2362     return catlist;             /* Don't append any more items. */
2363
2364   switch (ffebld_op (expr))
2365     {
2366     case FFEBLD_opCONTER:
2367     case FFEBLD_opSYMTER:
2368     case FFEBLD_opARRAYREF:
2369     case FFEBLD_opFUNCREF:
2370     case FFEBLD_opSUBSTR:
2371     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2372                                    if they don't need to preserve it. */
2373       if (catlist.count == catlist.max)
2374         {                       /* Make a (larger) list. */
2375           ffebld *newx;
2376           int newmax;
2377
2378           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2379           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2380                                 newmax * sizeof (newx[0]));
2381           if (catlist.max != 0)
2382             {
2383               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2384               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2385                               catlist.max * sizeof (newx[0]));
2386             }
2387           catlist.max = newmax;
2388           catlist.exprs = newx;
2389         }
2390       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2391         catlist.minlen += sz;
2392       else
2393         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2394       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2395         catlist.maxlen = sz;
2396       else
2397         catlist.maxlen += sz;
2398       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2399         {                       /* This item overlaps (or is beyond) the end
2400                                    of the destination. */
2401           switch (ffebld_op (expr))
2402             {
2403             case FFEBLD_opCONTER:
2404             case FFEBLD_opSYMTER:
2405             case FFEBLD_opARRAYREF:
2406             case FFEBLD_opFUNCREF:
2407             case FFEBLD_opSUBSTR:
2408               /* ~~Do useful truncations here. */
2409               break;
2410
2411             default:
2412               assert ("op changed or inconsistent switches!" == NULL);
2413               break;
2414             }
2415         }
2416       catlist.exprs[catlist.count++] = expr;
2417       return catlist;
2418
2419     case FFEBLD_opPAREN:
2420       expr = ffebld_left (expr);
2421       goto recurse;             /* :::::::::::::::::::: */
2422
2423     case FFEBLD_opCONCATENATE:
2424       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2425       expr = ffebld_right (expr);
2426       goto recurse;             /* :::::::::::::::::::: */
2427
2428 #if 0                           /* Breaks passing small actual arg to larger
2429                                    dummy arg of sfunc */
2430     case FFEBLD_opCONVERT:
2431       expr = ffebld_left (expr);
2432       {
2433         ffetargetCharacterSize cmax;
2434
2435         cmax = catlist.len + ffebld_size_known (expr);
2436
2437         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2438           max = cmax;
2439       }
2440       goto recurse;             /* :::::::::::::::::::: */
2441 #endif
2442
2443     case FFEBLD_opANY:
2444       return catlist;
2445
2446     default:
2447       assert ("bad op in _gather_" == NULL);
2448       return catlist;
2449     }
2450 }
2451
2452 #endif
2453 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2454
2455    ffecomConcatList_ catlist;
2456    ffecom_concat_list_kill_(catlist);
2457
2458    Anything allocated within the list info is deallocated.  */
2459
2460 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2461 static void
2462 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2463 {
2464   if (catlist.max != 0)
2465     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2466                     catlist.max * sizeof (catlist.exprs[0]));
2467 }
2468
2469 #endif
2470 /* Make list of concatenated string exprs.
2471
2472    Returns a flattened list of concatenated subexpressions given a
2473    tree of such expressions.  */
2474
2475 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2476 static ffecomConcatList_
2477 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2478 {
2479   ffecomConcatList_ catlist;
2480
2481   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2482   return ffecom_concat_list_gather_ (catlist, expr, max);
2483 }
2484
2485 #endif
2486
2487 /* Provide some kind of useful info on member of aggregate area,
2488    since current g77/gcc technology does not provide debug info
2489    on these members.  */
2490
2491 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2492 static void
2493 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2494                       tree member_type UNUSED, ffetargetOffset offset)
2495 {
2496   tree value;
2497   tree decl;
2498   int len;
2499   char *buff;
2500   char space[120];
2501 #if 0
2502   tree type_id;
2503
2504   for (type_id = member_type;
2505        TREE_CODE (type_id) != IDENTIFIER_NODE;
2506        )
2507     {
2508       switch (TREE_CODE (type_id))
2509         {
2510         case INTEGER_TYPE:
2511         case REAL_TYPE:
2512           type_id = TYPE_NAME (type_id);
2513           break;
2514
2515         case ARRAY_TYPE:
2516         case COMPLEX_TYPE:
2517           type_id = TREE_TYPE (type_id);
2518           break;
2519
2520         default:
2521           assert ("no IDENTIFIER_NODE for type!" == NULL);
2522           type_id = error_mark_node;
2523           break;
2524         }
2525     }
2526 #endif
2527
2528   if (ffecom_transform_only_dummies_
2529       || !ffe_is_debug_kludge ())
2530     return;     /* Can't do this yet, maybe later. */
2531
2532   len = 60
2533     + strlen (aggr_type)
2534     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2535 #if 0
2536     + IDENTIFIER_LENGTH (type_id);
2537 #endif
2538
2539   if (((size_t) len) >= ARRAY_SIZE (space))
2540     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2541   else
2542     buff = &space[0];
2543
2544   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2545            aggr_type,
2546            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2547            (long int) offset);
2548
2549   value = build_string (len, buff);
2550   TREE_TYPE (value)
2551     = build_type_variant (build_array_type (char_type_node,
2552                                             build_range_type
2553                                             (integer_type_node,
2554                                              integer_one_node,
2555                                              build_int_2 (strlen (buff), 0))),
2556                           1, 0);
2557   decl = build_decl (VAR_DECL,
2558                      ffecom_get_identifier_ (ffesymbol_text (member)),
2559                      TREE_TYPE (value));
2560   TREE_CONSTANT (decl) = 1;
2561   TREE_STATIC (decl) = 1;
2562   DECL_INITIAL (decl) = error_mark_node;
2563   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2564   decl = start_decl (decl, FALSE);
2565   finish_decl (decl, value, FALSE);
2566
2567   if (buff != &space[0])
2568     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2569 }
2570 #endif
2571
2572 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2573
2574    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2575    int i;  // entry# for this entrypoint (used by master fn)
2576    ffecom_do_entrypoint_(s,i);
2577
2578    Makes a public entry point that calls our private master fn (already
2579    compiled).  */
2580
2581 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2582 static void
2583 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2584 {
2585   ffebld item;
2586   tree type;                    /* Type of function. */
2587   tree multi_retval;            /* Var holding return value (union). */
2588   tree result;                  /* Var holding result. */
2589   ffeinfoBasictype bt;
2590   ffeinfoKindtype kt;
2591   ffeglobal g;
2592   ffeglobalType gt;
2593   bool charfunc;                /* All entry points return same type
2594                                    CHARACTER. */
2595   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2596   bool multi;                   /* Master fn has multiple return types. */
2597   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2598   int yes;
2599   int old_lineno = lineno;
2600   char *old_input_filename = input_filename;
2601
2602   input_filename = ffesymbol_where_filename (fn);
2603   lineno = ffesymbol_where_filelinenum (fn);
2604
2605   /* c-parse.y indeed does call suspend_momentary and not only ignores the
2606      return value, but also never calls resume_momentary, when starting an
2607      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
2608      same thing.  It shouldn't be a problem since start_function calls
2609      temporary_allocation, but it might be necessary.  If it causes a problem
2610      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
2611      comment appears twice in thist file.  */
2612
2613   suspend_momentary ();
2614
2615   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2616
2617   switch (ffecom_primary_entry_kind_)
2618     {
2619     case FFEINFO_kindFUNCTION:
2620
2621       /* Determine actual return type for function. */
2622
2623       gt = FFEGLOBAL_typeFUNC;
2624       bt = ffesymbol_basictype (fn);
2625       kt = ffesymbol_kindtype (fn);
2626       if (bt == FFEINFO_basictypeNONE)
2627         {
2628           ffeimplic_establish_symbol (fn);
2629           if (ffesymbol_funcresult (fn) != NULL)
2630             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2631           bt = ffesymbol_basictype (fn);
2632           kt = ffesymbol_kindtype (fn);
2633         }
2634
2635       if (bt == FFEINFO_basictypeCHARACTER)
2636         charfunc = TRUE, cmplxfunc = FALSE;
2637       else if ((bt == FFEINFO_basictypeCOMPLEX)
2638                && ffesymbol_is_f2c (fn))
2639         charfunc = FALSE, cmplxfunc = TRUE;
2640       else
2641         charfunc = cmplxfunc = FALSE;
2642
2643       if (charfunc)
2644         type = ffecom_tree_fun_type_void;
2645       else if (ffesymbol_is_f2c (fn))
2646         type = ffecom_tree_fun_type[bt][kt];
2647       else
2648         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2649
2650       if ((type == NULL_TREE)
2651           || (TREE_TYPE (type) == NULL_TREE))
2652         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2653
2654       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2655       break;
2656
2657     case FFEINFO_kindSUBROUTINE:
2658       gt = FFEGLOBAL_typeSUBR;
2659       bt = FFEINFO_basictypeNONE;
2660       kt = FFEINFO_kindtypeNONE;
2661       if (ffecom_is_altreturning_)
2662         {                       /* Am _I_ altreturning? */
2663           for (item = ffesymbol_dummyargs (fn);
2664                item != NULL;
2665                item = ffebld_trail (item))
2666             {
2667               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2668                 {
2669                   altreturning = TRUE;
2670                   break;
2671                 }
2672             }
2673           if (altreturning)
2674             type = ffecom_tree_subr_type;
2675           else
2676             type = ffecom_tree_fun_type_void;
2677         }
2678       else
2679         type = ffecom_tree_fun_type_void;
2680       charfunc = FALSE;
2681       cmplxfunc = FALSE;
2682       multi = FALSE;
2683       break;
2684
2685     default:
2686       assert ("say what??" == NULL);
2687       /* Fall through. */
2688     case FFEINFO_kindANY:
2689       gt = FFEGLOBAL_typeANY;
2690       bt = FFEINFO_basictypeNONE;
2691       kt = FFEINFO_kindtypeNONE;
2692       type = error_mark_node;
2693       charfunc = FALSE;
2694       cmplxfunc = FALSE;
2695       multi = FALSE;
2696       break;
2697     }
2698
2699   /* build_decl uses the current lineno and input_filename to set the decl
2700      source info.  So, I've putzed with ffestd and ffeste code to update that
2701      source info to point to the appropriate statement just before calling
2702      ffecom_do_entrypoint (which calls this fn).  */
2703
2704   start_function (ffecom_get_external_identifier_ (fn),
2705                   type,
2706                   0,            /* nested/inline */
2707                   1);           /* TREE_PUBLIC */
2708
2709   if (((g = ffesymbol_global (fn)) != NULL)
2710       && ((ffeglobal_type (g) == gt)
2711           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2712     {
2713       ffeglobal_set_hook (g, current_function_decl);
2714     }
2715
2716   /* Reset args in master arg list so they get retransitioned. */
2717
2718   for (item = ffecom_master_arglist_;
2719        item != NULL;
2720        item = ffebld_trail (item))
2721     {
2722       ffebld arg;
2723       ffesymbol s;
2724
2725       arg = ffebld_head (item);
2726       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2727         continue;               /* Alternate return or some such thing. */
2728       s = ffebld_symter (arg);
2729       ffesymbol_hook (s).decl_tree = NULL_TREE;
2730       ffesymbol_hook (s).length_tree = NULL_TREE;
2731     }
2732
2733   /* Build dummy arg list for this entry point. */
2734
2735   yes = suspend_momentary ();
2736
2737   if (charfunc || cmplxfunc)
2738     {                           /* Prepend arg for where result goes. */
2739       tree type;
2740       tree length;
2741
2742       if (charfunc)
2743         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2744       else
2745         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2746
2747       result = ffecom_get_invented_identifier ("__g77_%s",
2748                                                "result", -1);
2749
2750       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2751
2752       if (charfunc)
2753         length = ffecom_char_enhance_arg_ (&type, fn);
2754       else
2755         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2756
2757       type = build_pointer_type (type);
2758       result = build_decl (PARM_DECL, result, type);
2759
2760       push_parm_decl (result);
2761       ffecom_func_result_ = result;
2762
2763       if (charfunc)
2764         {
2765           push_parm_decl (length);
2766           ffecom_func_length_ = length;
2767         }
2768     }
2769   else
2770     result = DECL_RESULT (current_function_decl);
2771
2772   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2773
2774   resume_momentary (yes);
2775
2776   store_parm_decls (0);
2777
2778   ffecom_start_compstmt ();
2779   /* Disallow temp vars at this level.  */
2780   current_binding_level->prep_state = 2;
2781
2782   /* Make local var to hold return type for multi-type master fn. */
2783
2784   if (multi)
2785     {
2786       yes = suspend_momentary ();
2787
2788       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2789                                                      "multi_retval", -1);
2790       multi_retval = build_decl (VAR_DECL, multi_retval,
2791                                  ffecom_multi_type_node_);
2792       multi_retval = start_decl (multi_retval, FALSE);
2793       finish_decl (multi_retval, NULL_TREE, FALSE);
2794
2795       resume_momentary (yes);
2796     }
2797   else
2798     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2799
2800   /* Here we emit the actual code for the entry point. */
2801
2802   {
2803     ffebld list;
2804     ffebld arg;
2805     ffesymbol s;
2806     tree arglist = NULL_TREE;
2807     tree *plist = &arglist;
2808     tree prepend;
2809     tree call;
2810     tree actarg;
2811     tree master_fn;
2812
2813     /* Prepare actual arg list based on master arg list. */
2814
2815     for (list = ffecom_master_arglist_;
2816          list != NULL;
2817          list = ffebld_trail (list))
2818       {
2819         arg = ffebld_head (list);
2820         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2821           continue;
2822         s = ffebld_symter (arg);
2823         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2824             || ffesymbol_hook (s).decl_tree == error_mark_node)
2825           actarg = null_pointer_node;   /* We don't have this arg. */
2826         else
2827           actarg = ffesymbol_hook (s).decl_tree;
2828         *plist = build_tree_list (NULL_TREE, actarg);
2829         plist = &TREE_CHAIN (*plist);
2830       }
2831
2832     /* This code appends the length arguments for character
2833        variables/arrays.  */
2834
2835     for (list = ffecom_master_arglist_;
2836          list != NULL;
2837          list = ffebld_trail (list))
2838       {
2839         arg = ffebld_head (list);
2840         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2841           continue;
2842         s = ffebld_symter (arg);
2843         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2844           continue;             /* Only looking for CHARACTER arguments. */
2845         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2846           continue;             /* Only looking for variables and arrays. */
2847         if (ffesymbol_hook (s).length_tree == NULL_TREE
2848             || ffesymbol_hook (s).length_tree == error_mark_node)
2849           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2850         else
2851           actarg = ffesymbol_hook (s).length_tree;
2852         *plist = build_tree_list (NULL_TREE, actarg);
2853         plist = &TREE_CHAIN (*plist);
2854       }
2855
2856     /* Prepend character-value return info to actual arg list. */
2857
2858     if (charfunc)
2859       {
2860         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2861         TREE_CHAIN (prepend)
2862           = build_tree_list (NULL_TREE, ffecom_func_length_);
2863         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2864         arglist = prepend;
2865       }
2866
2867     /* Prepend multi-type return value to actual arg list. */
2868
2869     if (multi)
2870       {
2871         prepend
2872           = build_tree_list (NULL_TREE,
2873                              ffecom_1 (ADDR_EXPR,
2874                               build_pointer_type (TREE_TYPE (multi_retval)),
2875                                        multi_retval));
2876         TREE_CHAIN (prepend) = arglist;
2877         arglist = prepend;
2878       }
2879
2880     /* Prepend my entry-point number to the actual arg list. */
2881
2882     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2883     TREE_CHAIN (prepend) = arglist;
2884     arglist = prepend;
2885
2886     /* Build the call to the master function. */
2887
2888     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2889     call = ffecom_3s (CALL_EXPR,
2890                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2891                       master_fn, arglist, NULL_TREE);
2892
2893     /* Decide whether the master function is a function or subroutine, and
2894        handle the return value for my entry point. */
2895
2896     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2897                      && !altreturning))
2898       {
2899         expand_expr_stmt (call);
2900         expand_null_return ();
2901       }
2902     else if (multi && cmplxfunc)
2903       {
2904         expand_expr_stmt (call);
2905         result
2906           = ffecom_1 (INDIRECT_REF,
2907                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2908                       result);
2909         result = ffecom_modify (NULL_TREE, result,
2910                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2911                                           multi_retval,
2912                                           ffecom_multi_fields_[bt][kt]));
2913         expand_expr_stmt (result);
2914         expand_null_return ();
2915       }
2916     else if (multi)
2917       {
2918         expand_expr_stmt (call);
2919         result
2920           = ffecom_modify (NULL_TREE, result,
2921                            convert (TREE_TYPE (result),
2922                                     ffecom_2 (COMPONENT_REF,
2923                                               ffecom_tree_type[bt][kt],
2924                                               multi_retval,
2925                                               ffecom_multi_fields_[bt][kt])));
2926         expand_return (result);
2927       }
2928     else if (cmplxfunc)
2929       {
2930         result
2931           = ffecom_1 (INDIRECT_REF,
2932                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2933                       result);
2934         result = ffecom_modify (NULL_TREE, result, call);
2935         expand_expr_stmt (result);
2936         expand_null_return ();
2937       }
2938     else
2939       {
2940         result = ffecom_modify (NULL_TREE,
2941                                 result,
2942                                 convert (TREE_TYPE (result),
2943                                          call));
2944         expand_return (result);
2945       }
2946
2947     clear_momentary ();
2948   }
2949
2950   ffecom_end_compstmt ();
2951
2952   finish_function (0);
2953
2954   lineno = old_lineno;
2955   input_filename = old_input_filename;
2956
2957   ffecom_doing_entry_ = FALSE;
2958 }
2959
2960 #endif
2961 /* Transform expr into gcc tree with possible destination
2962
2963    Recursive descent on expr while making corresponding tree nodes and
2964    attaching type info and such.  If destination supplied and compatible
2965    with temporary that would be made in certain cases, temporary isn't
2966    made, destination used instead, and dest_used flag set TRUE.  */
2967
2968 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2969 static tree
2970 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2971               bool *dest_used, bool assignp, bool widenp)
2972 {
2973   tree item;
2974   tree list;
2975   tree args;
2976   ffeinfoBasictype bt;
2977   ffeinfoKindtype kt;
2978   tree t;
2979   tree dt;                      /* decl_tree for an ffesymbol. */
2980   tree tree_type, tree_type_x;
2981   tree left, right;
2982   ffesymbol s;
2983   enum tree_code code;
2984
2985   assert (expr != NULL);
2986
2987   if (dest_used != NULL)
2988     *dest_used = FALSE;
2989
2990   bt = ffeinfo_basictype (ffebld_info (expr));
2991   kt = ffeinfo_kindtype (ffebld_info (expr));
2992   tree_type = ffecom_tree_type[bt][kt];
2993
2994   /* Widen integral arithmetic as desired while preserving signedness.  */
2995   tree_type_x = NULL_TREE;
2996   if (widenp && tree_type
2997       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2998       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2999     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
3000
3001   switch (ffebld_op (expr))
3002     {
3003     case FFEBLD_opACCTER:
3004       {
3005         ffebitCount i;
3006         ffebit bits = ffebld_accter_bits (expr);
3007         ffetargetOffset source_offset = 0;
3008         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3009         tree purpose;
3010
3011         assert (dest_offset == 0
3012                 || (bt == FFEINFO_basictypeCHARACTER
3013                     && kt == FFEINFO_kindtypeCHARACTER1));
3014
3015         list = item = NULL;
3016         for (;;)
3017           {
3018             ffebldConstantUnion cu;
3019             ffebitCount length;
3020             bool value;
3021             ffebldConstantArray ca = ffebld_accter (expr);
3022
3023             ffebit_test (bits, source_offset, &value, &length);
3024             if (length == 0)
3025               break;
3026
3027             if (value)
3028               {
3029                 for (i = 0; i < length; ++i)
3030                   {
3031                     cu = ffebld_constantarray_get (ca, bt, kt,
3032                                                    source_offset + i);
3033
3034                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3035
3036                     if (i == 0
3037                         && dest_offset != 0)
3038                       purpose = build_int_2 (dest_offset, 0);
3039                     else
3040                       purpose = NULL_TREE;
3041
3042                     if (list == NULL_TREE)
3043                       list = item = build_tree_list (purpose, t);
3044                     else
3045                       {
3046                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3047                         item = TREE_CHAIN (item);
3048                       }
3049                   }
3050               }
3051             source_offset += length;
3052             dest_offset += length;
3053           }
3054       }
3055
3056       item = build_int_2 ((ffebld_accter_size (expr)
3057                            + ffebld_accter_pad (expr)) - 1, 0);
3058       ffebit_kill (ffebld_accter_bits (expr));
3059       TREE_TYPE (item) = ffecom_integer_type_node;
3060       item
3061         = build_array_type
3062           (tree_type,
3063            build_range_type (ffecom_integer_type_node,
3064                              ffecom_integer_zero_node,
3065                              item));
3066       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3067       TREE_CONSTANT (list) = 1;
3068       TREE_STATIC (list) = 1;
3069       return list;
3070
3071     case FFEBLD_opARRTER:
3072       {
3073         ffetargetOffset i;
3074
3075         list = NULL_TREE;
3076         if (ffebld_arrter_pad (expr) == 0)
3077           item = NULL_TREE;
3078         else
3079           {
3080             assert (bt == FFEINFO_basictypeCHARACTER
3081                     && kt == FFEINFO_kindtypeCHARACTER1);
3082
3083             /* Becomes PURPOSE first time through loop.  */
3084             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3085           }
3086
3087         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3088           {
3089             ffebldConstantUnion cu
3090             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3091
3092             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3093
3094             if (list == NULL_TREE)
3095               /* Assume item is PURPOSE first time through loop.  */
3096               list = item = build_tree_list (item, t);
3097             else
3098               {
3099                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3100                 item = TREE_CHAIN (item);
3101               }
3102           }
3103       }
3104
3105       item = build_int_2 ((ffebld_arrter_size (expr)
3106                           + ffebld_arrter_pad (expr)) - 1, 0);
3107       TREE_TYPE (item) = ffecom_integer_type_node;
3108       item
3109         = build_array_type
3110           (tree_type,
3111            build_range_type (ffecom_integer_type_node,
3112                              ffecom_integer_zero_node,
3113                              item));
3114       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3115       TREE_CONSTANT (list) = 1;
3116       TREE_STATIC (list) = 1;
3117       return list;
3118
3119     case FFEBLD_opCONTER:
3120       assert (ffebld_conter_pad (expr) == 0);
3121       item
3122         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3123                                 bt, kt, tree_type);
3124       return item;
3125
3126     case FFEBLD_opSYMTER:
3127       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3128           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3129         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3130       s = ffebld_symter (expr);
3131       t = ffesymbol_hook (s).decl_tree;
3132
3133       if (assignp)
3134         {                       /* ASSIGN'ed-label expr. */
3135           if (ffe_is_ugly_assign ())
3136             {
3137               /* User explicitly wants ASSIGN'ed variables to be at the same
3138                  memory address as the variables when used in non-ASSIGN
3139                  contexts.  That can make old, arcane, non-standard code
3140                  work, but don't try to do it when a pointer wouldn't fit
3141                  in the normal variable (take other approach, and warn,
3142                  instead).  */
3143
3144               if (t == NULL_TREE)
3145                 {
3146                   s = ffecom_sym_transform_ (s);
3147                   t = ffesymbol_hook (s).decl_tree;
3148                   assert (t != NULL_TREE);
3149                 }
3150
3151               if (t == error_mark_node)
3152                 return t;
3153
3154               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3155                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3156                 {
3157                   if (ffesymbol_hook (s).addr)
3158                     t = ffecom_1 (INDIRECT_REF,
3159                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3160                   return t;
3161                 }
3162
3163               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3164                 {
3165                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3166                                     FFEBAD_severityWARNING);
3167                   ffebad_string (ffesymbol_text (s));
3168                   ffebad_here (0, ffesymbol_where_line (s),
3169                                ffesymbol_where_column (s));
3170                   ffebad_finish ();
3171                 }
3172             }
3173
3174           /* Don't use the normal variable's tree for ASSIGN, though mark
3175              it as in the system header (housekeeping).  Use an explicit,
3176              specially created sibling that is known to be wide enough
3177              to hold pointers to labels.  */
3178
3179           if (t != NULL_TREE
3180               && TREE_CODE (t) == VAR_DECL)
3181             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3182
3183           t = ffesymbol_hook (s).assign_tree;
3184           if (t == NULL_TREE)
3185             {
3186               s = ffecom_sym_transform_assign_ (s);
3187               t = ffesymbol_hook (s).assign_tree;
3188               assert (t != NULL_TREE);
3189             }
3190         }
3191       else
3192         {
3193           if (t == NULL_TREE)
3194             {
3195               s = ffecom_sym_transform_ (s);
3196               t = ffesymbol_hook (s).decl_tree;
3197               assert (t != NULL_TREE);
3198             }
3199           if (ffesymbol_hook (s).addr)
3200             t = ffecom_1 (INDIRECT_REF,
3201                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3202         }
3203       return t;
3204
3205     case FFEBLD_opARRAYREF:
3206       {
3207         if (0 /* ~~~~~ ffe_is_flat_arrays () */)
3208           t = ffecom_ptr_to_expr (ffebld_left (expr));
3209         else
3210           t = ffecom_expr (ffebld_left (expr));
3211
3212         if (t == error_mark_node)
3213           return t;
3214
3215         if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING)
3216             && !mark_addressable (t))
3217           return error_mark_node;       /* Make sure non-const ref is to
3218                                            non-reg. */
3219
3220         t = ffecom_arrayref_ (t, expr, 0);
3221
3222         return t;
3223       }
3224
3225     case FFEBLD_opUPLUS:
3226       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3227       return ffecom_1 (NOP_EXPR, tree_type, left);
3228
3229     case FFEBLD_opPAREN:
3230       /* ~~~Make sure Fortran rules respected here */
3231       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3232       return ffecom_1 (NOP_EXPR, tree_type, left);
3233
3234     case FFEBLD_opUMINUS:
3235       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3236       if (tree_type_x)
3237         {
3238           tree_type = tree_type_x;
3239           left = convert (tree_type, left);
3240         }
3241       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3242
3243     case FFEBLD_opADD:
3244       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3245       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3246       if (tree_type_x)
3247         {
3248           tree_type = tree_type_x;
3249           left = convert (tree_type, left);
3250           right = convert (tree_type, right);
3251         }
3252       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3253
3254     case FFEBLD_opSUBTRACT:
3255       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3256       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3257       if (tree_type_x)
3258         {
3259           tree_type = tree_type_x;
3260           left = convert (tree_type, left);
3261           right = convert (tree_type, right);
3262         }
3263       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3264
3265     case FFEBLD_opMULTIPLY:
3266       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3267       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3268       if (tree_type_x)
3269         {
3270           tree_type = tree_type_x;
3271           left = convert (tree_type, left);
3272           right = convert (tree_type, right);
3273         }
3274       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3275
3276     case FFEBLD_opDIVIDE:
3277       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3278       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3279       if (tree_type_x)
3280         {
3281           tree_type = tree_type_x;
3282           left = convert (tree_type, left);
3283           right = convert (tree_type, right);
3284         }
3285       return ffecom_tree_divide_ (tree_type, left, right,
3286                                   dest_tree, dest, dest_used,
3287                                   ffebld_nonter_hook (expr));
3288
3289     case FFEBLD_opPOWER:
3290       {
3291         ffebld left = ffebld_left (expr);
3292         ffebld right = ffebld_right (expr);
3293         ffecomGfrt code;
3294         ffeinfoKindtype rtkt;
3295         ffeinfoKindtype ltkt;
3296
3297         switch (ffeinfo_basictype (ffebld_info (right)))
3298           {
3299           case FFEINFO_basictypeINTEGER:
3300             if (1 || optimize)
3301               {
3302                 item = ffecom_expr_power_integer_ (expr);
3303                 if (item != NULL_TREE)
3304                   return item;
3305               }
3306
3307             rtkt = FFEINFO_kindtypeINTEGER1;
3308             switch (ffeinfo_basictype (ffebld_info (left)))
3309               {
3310               case FFEINFO_basictypeINTEGER:
3311                 if ((ffeinfo_kindtype (ffebld_info (left))
3312                     == FFEINFO_kindtypeINTEGER4)
3313                     || (ffeinfo_kindtype (ffebld_info (right))
3314                         == FFEINFO_kindtypeINTEGER4))
3315                   {
3316                     code = FFECOM_gfrtPOW_QQ;
3317                     ltkt = FFEINFO_kindtypeINTEGER4;
3318                     rtkt = FFEINFO_kindtypeINTEGER4;
3319                   }
3320                 else
3321                   {
3322                     code = FFECOM_gfrtPOW_II;
3323                     ltkt = FFEINFO_kindtypeINTEGER1;
3324                   }
3325                 break;
3326
3327               case FFEINFO_basictypeREAL:
3328                 if (ffeinfo_kindtype (ffebld_info (left))
3329                     == FFEINFO_kindtypeREAL1)
3330                   {
3331                     code = FFECOM_gfrtPOW_RI;
3332                     ltkt = FFEINFO_kindtypeREAL1;
3333                   }
3334                 else
3335                   {
3336                     code = FFECOM_gfrtPOW_DI;
3337                     ltkt = FFEINFO_kindtypeREAL2;
3338                   }
3339                 break;
3340
3341               case FFEINFO_basictypeCOMPLEX:
3342                 if (ffeinfo_kindtype (ffebld_info (left))
3343                     == FFEINFO_kindtypeREAL1)
3344                   {
3345                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3346                     ltkt = FFEINFO_kindtypeREAL1;
3347                   }
3348                 else
3349                   {
3350                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3351                     ltkt = FFEINFO_kindtypeREAL2;
3352                   }
3353                 break;
3354
3355               default:
3356                 assert ("bad pow_*i" == NULL);
3357                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3358                 ltkt = FFEINFO_kindtypeREAL1;
3359                 break;
3360               }
3361             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3362               left = ffeexpr_convert (left, NULL, NULL,
3363                                       ffeinfo_basictype (ffebld_info (left)),
3364                                       ltkt, 0,
3365                                       FFETARGET_charactersizeNONE,
3366                                       FFEEXPR_contextLET);
3367             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3368               right = ffeexpr_convert (right, NULL, NULL,
3369                                        FFEINFO_basictypeINTEGER,
3370                                        rtkt, 0,
3371                                        FFETARGET_charactersizeNONE,
3372                                        FFEEXPR_contextLET);
3373             break;
3374
3375           case FFEINFO_basictypeREAL:
3376             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3377               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3378                                       FFEINFO_kindtypeREALDOUBLE, 0,
3379                                       FFETARGET_charactersizeNONE,
3380                                       FFEEXPR_contextLET);
3381             if (ffeinfo_kindtype (ffebld_info (right))
3382                 == FFEINFO_kindtypeREAL1)
3383               right = ffeexpr_convert (right, NULL, NULL,
3384                                        FFEINFO_basictypeREAL,
3385                                        FFEINFO_kindtypeREALDOUBLE, 0,
3386                                        FFETARGET_charactersizeNONE,
3387                                        FFEEXPR_contextLET);
3388             code = FFECOM_gfrtPOW_DD;
3389             break;
3390
3391           case FFEINFO_basictypeCOMPLEX:
3392             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3393               left = ffeexpr_convert (left, NULL, NULL,
3394                                       FFEINFO_basictypeCOMPLEX,
3395                                       FFEINFO_kindtypeREALDOUBLE, 0,
3396                                       FFETARGET_charactersizeNONE,
3397                                       FFEEXPR_contextLET);
3398             if (ffeinfo_kindtype (ffebld_info (right))
3399                 == FFEINFO_kindtypeREAL1)
3400               right = ffeexpr_convert (right, NULL, NULL,
3401                                        FFEINFO_basictypeCOMPLEX,
3402                                        FFEINFO_kindtypeREALDOUBLE, 0,
3403                                        FFETARGET_charactersizeNONE,
3404                                        FFEEXPR_contextLET);
3405             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3406             break;
3407
3408           default:
3409             assert ("bad pow_x*" == NULL);
3410             code = FFECOM_gfrtPOW_II;
3411             break;
3412           }
3413         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3414                                    ffecom_gfrt_kindtype (code),
3415                                    (ffe_is_f2c_library ()
3416                                     && ffecom_gfrt_complex_[code]),
3417                                    tree_type, left, right,
3418                                    dest_tree, dest, dest_used,
3419                                    NULL_TREE, FALSE,
3420                                    ffebld_nonter_hook (expr));
3421       }
3422
3423     case FFEBLD_opNOT:
3424       switch (bt)
3425         {
3426         case FFEINFO_basictypeLOGICAL:
3427           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3428           return convert (tree_type, item);
3429
3430         case FFEINFO_basictypeINTEGER:
3431           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3432                            ffecom_expr (ffebld_left (expr)));
3433
3434         default:
3435           assert ("NOT bad basictype" == NULL);
3436           /* Fall through. */
3437         case FFEINFO_basictypeANY:
3438           return error_mark_node;
3439         }
3440       break;
3441
3442     case FFEBLD_opFUNCREF:
3443       assert (ffeinfo_basictype (ffebld_info (expr))
3444               != FFEINFO_basictypeCHARACTER);
3445       /* Fall through.   */
3446     case FFEBLD_opSUBRREF:
3447       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3448           == FFEINFO_whereINTRINSIC)
3449         {                       /* Invocation of an intrinsic. */
3450           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3451                                          dest_used);
3452           return item;
3453         }
3454       s = ffebld_symter (ffebld_left (expr));
3455       dt = ffesymbol_hook (s).decl_tree;
3456       if (dt == NULL_TREE)
3457         {
3458           s = ffecom_sym_transform_ (s);
3459           dt = ffesymbol_hook (s).decl_tree;
3460         }
3461       if (dt == error_mark_node)
3462         return dt;
3463
3464       if (ffesymbol_hook (s).addr)
3465         item = dt;
3466       else
3467         item = ffecom_1_fn (dt);
3468
3469       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3470         args = ffecom_list_expr (ffebld_right (expr));
3471       else
3472         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3473
3474       if (args == error_mark_node)
3475         return error_mark_node;
3476
3477       item = ffecom_call_ (item, kt,
3478                            ffesymbol_is_f2c (s)
3479                            && (bt == FFEINFO_basictypeCOMPLEX)
3480                            && (ffesymbol_where (s)
3481                                != FFEINFO_whereCONSTANT),
3482                            tree_type,
3483                            args,
3484                            dest_tree, dest, dest_used,
3485                            error_mark_node, FALSE,
3486                            ffebld_nonter_hook (expr));
3487       TREE_SIDE_EFFECTS (item) = 1;
3488       return item;
3489
3490     case FFEBLD_opAND:
3491       switch (bt)
3492         {
3493         case FFEINFO_basictypeLOGICAL:
3494           item
3495             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3496                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3497                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3498           return convert (tree_type, item);
3499
3500         case FFEINFO_basictypeINTEGER:
3501           return ffecom_2 (BIT_AND_EXPR, tree_type,
3502                            ffecom_expr (ffebld_left (expr)),
3503                            ffecom_expr (ffebld_right (expr)));
3504
3505         default:
3506           assert ("AND bad basictype" == NULL);
3507           /* Fall through. */
3508         case FFEINFO_basictypeANY:
3509           return error_mark_node;
3510         }
3511       break;
3512
3513     case FFEBLD_opOR:
3514       switch (bt)
3515         {
3516         case FFEINFO_basictypeLOGICAL:
3517           item
3518             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3519                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3520                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3521           return convert (tree_type, item);
3522
3523         case FFEINFO_basictypeINTEGER:
3524           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3525                            ffecom_expr (ffebld_left (expr)),
3526                            ffecom_expr (ffebld_right (expr)));
3527
3528         default:
3529           assert ("OR bad basictype" == NULL);
3530           /* Fall through. */
3531         case FFEINFO_basictypeANY:
3532           return error_mark_node;
3533         }
3534       break;
3535
3536     case FFEBLD_opXOR:
3537     case FFEBLD_opNEQV:
3538       switch (bt)
3539         {
3540         case FFEINFO_basictypeLOGICAL:
3541           item
3542             = ffecom_2 (NE_EXPR, integer_type_node,
3543                         ffecom_expr (ffebld_left (expr)),
3544                         ffecom_expr (ffebld_right (expr)));
3545           return convert (tree_type, ffecom_truth_value (item));
3546
3547         case FFEINFO_basictypeINTEGER:
3548           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3549                            ffecom_expr (ffebld_left (expr)),
3550                            ffecom_expr (ffebld_right (expr)));
3551
3552         default:
3553           assert ("XOR/NEQV bad basictype" == NULL);
3554           /* Fall through. */
3555         case FFEINFO_basictypeANY:
3556           return error_mark_node;
3557         }
3558       break;
3559
3560     case FFEBLD_opEQV:
3561       switch (bt)
3562         {
3563         case FFEINFO_basictypeLOGICAL:
3564           item
3565             = ffecom_2 (EQ_EXPR, integer_type_node,
3566                         ffecom_expr (ffebld_left (expr)),
3567                         ffecom_expr (ffebld_right (expr)));
3568           return convert (tree_type, ffecom_truth_value (item));
3569
3570         case FFEINFO_basictypeINTEGER:
3571           return
3572             ffecom_1 (BIT_NOT_EXPR, tree_type,
3573                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3574                                 ffecom_expr (ffebld_left (expr)),
3575                                 ffecom_expr (ffebld_right (expr))));
3576
3577         default:
3578           assert ("EQV bad basictype" == NULL);
3579           /* Fall through. */
3580         case FFEINFO_basictypeANY:
3581           return error_mark_node;
3582         }
3583       break;
3584
3585     case FFEBLD_opCONVERT:
3586       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3587         return error_mark_node;
3588
3589       switch (bt)
3590         {
3591         case FFEINFO_basictypeLOGICAL:
3592         case FFEINFO_basictypeINTEGER:
3593         case FFEINFO_basictypeREAL:
3594           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3595
3596         case FFEINFO_basictypeCOMPLEX:
3597           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3598             {
3599             case FFEINFO_basictypeINTEGER:
3600             case FFEINFO_basictypeLOGICAL:
3601             case FFEINFO_basictypeREAL:
3602               item = ffecom_expr (ffebld_left (expr));
3603               if (item == error_mark_node)
3604                 return error_mark_node;
3605               /* convert() takes care of converting to the subtype first,
3606                  at least in gcc-2.7.2. */
3607               item = convert (tree_type, item);
3608               return item;
3609
3610             case FFEINFO_basictypeCOMPLEX:
3611               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3612
3613             default:
3614               assert ("CONVERT COMPLEX bad basictype" == NULL);
3615               /* Fall through. */
3616             case FFEINFO_basictypeANY:
3617               return error_mark_node;
3618             }
3619           break;
3620
3621         default:
3622           assert ("CONVERT bad basictype" == NULL);
3623           /* Fall through. */
3624         case FFEINFO_basictypeANY:
3625           return error_mark_node;
3626         }
3627       break;
3628
3629     case FFEBLD_opLT:
3630       code = LT_EXPR;
3631       goto relational;          /* :::::::::::::::::::: */
3632
3633     case FFEBLD_opLE:
3634       code = LE_EXPR;
3635       goto relational;          /* :::::::::::::::::::: */
3636
3637     case FFEBLD_opEQ:
3638       code = EQ_EXPR;
3639       goto relational;          /* :::::::::::::::::::: */
3640
3641     case FFEBLD_opNE:
3642       code = NE_EXPR;
3643       goto relational;          /* :::::::::::::::::::: */
3644
3645     case FFEBLD_opGT:
3646       code = GT_EXPR;
3647       goto relational;          /* :::::::::::::::::::: */
3648
3649     case FFEBLD_opGE:
3650       code = GE_EXPR;
3651
3652     relational:         /* :::::::::::::::::::: */
3653       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3654         {
3655         case FFEINFO_basictypeLOGICAL:
3656         case FFEINFO_basictypeINTEGER:
3657         case FFEINFO_basictypeREAL:
3658           item = ffecom_2 (code, integer_type_node,
3659                            ffecom_expr (ffebld_left (expr)),
3660                            ffecom_expr (ffebld_right (expr)));
3661           return convert (tree_type, item);
3662
3663         case FFEINFO_basictypeCOMPLEX:
3664           assert (code == EQ_EXPR || code == NE_EXPR);
3665           {
3666             tree real_type;
3667             tree arg1 = ffecom_expr (ffebld_left (expr));
3668             tree arg2 = ffecom_expr (ffebld_right (expr));
3669
3670             if (arg1 == error_mark_node || arg2 == error_mark_node)
3671               return error_mark_node;
3672
3673             arg1 = ffecom_save_tree (arg1);
3674             arg2 = ffecom_save_tree (arg2);
3675
3676             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3677               {
3678                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3679                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3680               }
3681             else
3682               {
3683                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3684                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3685               }
3686
3687             item
3688               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3689                           ffecom_2 (EQ_EXPR, integer_type_node,
3690                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3691                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3692                           ffecom_2 (EQ_EXPR, integer_type_node,
3693                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3694                                     ffecom_1 (IMAGPART_EXPR, real_type,
3695                                               arg2)));
3696             if (code == EQ_EXPR)
3697               item = ffecom_truth_value (item);
3698             else
3699               item = ffecom_truth_value_invert (item);
3700             return convert (tree_type, item);
3701           }
3702
3703         case FFEINFO_basictypeCHARACTER:
3704           {
3705             ffebld left = ffebld_left (expr);
3706             ffebld right = ffebld_right (expr);
3707             tree left_tree;
3708             tree right_tree;
3709             tree left_length;
3710             tree right_length;
3711
3712             /* f2c run-time functions do the implicit blank-padding for us,
3713                so we don't usually have to implement blank-padding ourselves.
3714                (The exception is when we pass an argument to a separately
3715                compiled statement function -- if we know the arg is not the
3716                same length as the dummy, we must truncate or extend it.  If
3717                we "inline" statement functions, that necessity goes away as
3718                well.)
3719
3720                Strip off the CONVERT operators that blank-pad.  (Truncation by
3721                CONVERT shouldn't happen here, but it can happen in
3722                assignments.) */
3723
3724             while (ffebld_op (left) == FFEBLD_opCONVERT)
3725               left = ffebld_left (left);
3726             while (ffebld_op (right) == FFEBLD_opCONVERT)
3727               right = ffebld_left (right);
3728
3729             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3730             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3731
3732             if (left_tree == error_mark_node || left_length == error_mark_node
3733                 || right_tree == error_mark_node
3734                 || right_length == error_mark_node)
3735               return error_mark_node;
3736
3737             if ((ffebld_size_known (left) == 1)
3738                 && (ffebld_size_known (right) == 1))
3739               {
3740                 left_tree
3741                   = ffecom_1 (INDIRECT_REF,
3742                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3743                               left_tree);
3744                 right_tree
3745                   = ffecom_1 (INDIRECT_REF,
3746                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3747                               right_tree);
3748
3749                 item
3750                   = ffecom_2 (code, integer_type_node,
3751                               ffecom_2 (ARRAY_REF,
3752                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3753                                         left_tree,
3754                                         integer_one_node),
3755                               ffecom_2 (ARRAY_REF,
3756                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3757                                         right_tree,
3758                                         integer_one_node));
3759               }
3760             else
3761               {
3762                 item = build_tree_list (NULL_TREE, left_tree);
3763                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3764                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3765                                                                left_length);
3766                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3767                   = build_tree_list (NULL_TREE, right_length);
3768                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3769                 item = ffecom_2 (code, integer_type_node,
3770                                  item,
3771                                  convert (TREE_TYPE (item),
3772                                           integer_zero_node));
3773               }
3774             item = convert (tree_type, item);
3775           }
3776
3777           return item;
3778
3779         default:
3780           assert ("relational bad basictype" == NULL);
3781           /* Fall through. */
3782         case FFEINFO_basictypeANY:
3783           return error_mark_node;
3784         }
3785       break;
3786
3787     case FFEBLD_opPERCENT_LOC:
3788       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3789       return convert (tree_type, item);
3790
3791     case FFEBLD_opITEM:
3792     case FFEBLD_opSTAR:
3793     case FFEBLD_opBOUNDS:
3794     case FFEBLD_opREPEAT:
3795     case FFEBLD_opLABTER:
3796     case FFEBLD_opLABTOK:
3797     case FFEBLD_opIMPDO:
3798     case FFEBLD_opCONCATENATE:
3799     case FFEBLD_opSUBSTR:
3800     default:
3801       assert ("bad op" == NULL);
3802       /* Fall through. */
3803     case FFEBLD_opANY:
3804       return error_mark_node;
3805     }
3806
3807 #if 1
3808   assert ("didn't think anything got here anymore!!" == NULL);
3809 #else
3810   switch (ffebld_arity (expr))
3811     {
3812     case 2:
3813       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3814       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3815       if (TREE_OPERAND (item, 0) == error_mark_node
3816           || TREE_OPERAND (item, 1) == error_mark_node)
3817         return error_mark_node;
3818       break;
3819
3820     case 1:
3821       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3822       if (TREE_OPERAND (item, 0) == error_mark_node)
3823         return error_mark_node;
3824       break;
3825
3826     default:
3827       break;
3828     }
3829
3830   return fold (item);
3831 #endif
3832 }
3833
3834 #endif
3835 /* Returns the tree that does the intrinsic invocation.
3836
3837    Note: this function applies only to intrinsics returning
3838    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3839    subroutines.  */
3840
3841 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3842 static tree
3843 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3844                         ffebld dest, bool *dest_used)
3845 {
3846   tree expr_tree;
3847   tree saved_expr1;             /* For those who need it. */
3848   tree saved_expr2;             /* For those who need it. */
3849   ffeinfoBasictype bt;
3850   ffeinfoKindtype kt;
3851   tree tree_type;
3852   tree arg1_type;
3853   tree real_type;               /* REAL type corresponding to COMPLEX. */
3854   tree tempvar;
3855   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3856   ffebld arg1;                  /* For handy reference. */
3857   ffebld arg2;
3858   ffebld arg3;
3859   ffeintrinImp codegen_imp;
3860   ffecomGfrt gfrt;
3861
3862   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3863
3864   if (dest_used != NULL)
3865     *dest_used = FALSE;
3866
3867   bt = ffeinfo_basictype (ffebld_info (expr));
3868   kt = ffeinfo_kindtype (ffebld_info (expr));
3869   tree_type = ffecom_tree_type[bt][kt];
3870
3871   if (list != NULL)
3872     {
3873       arg1 = ffebld_head (list);
3874       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3875         return error_mark_node;
3876       if ((list = ffebld_trail (list)) != NULL)
3877         {
3878           arg2 = ffebld_head (list);
3879           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3880             return error_mark_node;
3881           if ((list = ffebld_trail (list)) != NULL)
3882             {
3883               arg3 = ffebld_head (list);
3884               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3885                 return error_mark_node;
3886             }
3887           else
3888             arg3 = NULL;
3889         }
3890       else
3891         arg2 = arg3 = NULL;
3892     }
3893   else
3894     arg1 = arg2 = arg3 = NULL;
3895
3896   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3897      args.  This is used by the MAX/MIN expansions. */
3898
3899   if (arg1 != NULL)
3900     arg1_type = ffecom_tree_type
3901       [ffeinfo_basictype (ffebld_info (arg1))]
3902       [ffeinfo_kindtype (ffebld_info (arg1))];
3903   else
3904     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3905                                    here. */
3906
3907   /* There are several ways for each of the cases in the following switch
3908      statements to exit (from simplest to use to most complicated):
3909
3910      break;  (when expr_tree == NULL)
3911
3912      A standard call is made to the specific intrinsic just as if it had been
3913      passed in as a dummy procedure and called as any old procedure.  This
3914      method can produce slower code but in some cases it's the easiest way for
3915      now.  However, if a (presumably faster) direct call is available,
3916      that is used, so this is the easiest way in many more cases now.
3917
3918      gfrt = FFECOM_gfrtWHATEVER;
3919      break;
3920
3921      gfrt contains the gfrt index of a library function to call, passing the
3922      argument(s) by value rather than by reference.  Used when a more
3923      careful choice of library function is needed than that provided
3924      by the vanilla `break;'.
3925
3926      return expr_tree;
3927
3928      The expr_tree has been completely set up and is ready to be returned
3929      as is.  No further actions are taken.  Use this when the tree is not
3930      in the simple form for one of the arity_n labels.   */
3931
3932   /* For info on how the switch statement cases were written, see the files
3933      enclosed in comments below the switch statement. */
3934
3935   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3936   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3937   if (gfrt == FFECOM_gfrt)
3938     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3939
3940   switch (codegen_imp)
3941     {
3942     case FFEINTRIN_impABS:
3943     case FFEINTRIN_impCABS:
3944     case FFEINTRIN_impCDABS:
3945     case FFEINTRIN_impDABS:
3946     case FFEINTRIN_impIABS:
3947       if (ffeinfo_basictype (ffebld_info (arg1))
3948           == FFEINFO_basictypeCOMPLEX)
3949         {
3950           if (kt == FFEINFO_kindtypeREAL1)
3951             gfrt = FFECOM_gfrtCABS;
3952           else if (kt == FFEINFO_kindtypeREAL2)
3953             gfrt = FFECOM_gfrtCDABS;
3954           break;
3955         }
3956       return ffecom_1 (ABS_EXPR, tree_type,
3957                        convert (tree_type, ffecom_expr (arg1)));
3958
3959     case FFEINTRIN_impACOS:
3960     case FFEINTRIN_impDACOS:
3961       break;
3962
3963     case FFEINTRIN_impAIMAG:
3964     case FFEINTRIN_impDIMAG:
3965     case FFEINTRIN_impIMAGPART:
3966       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3967         arg1_type = TREE_TYPE (arg1_type);
3968       else
3969         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3970
3971       return
3972         convert (tree_type,
3973                  ffecom_1 (IMAGPART_EXPR, arg1_type,
3974                            ffecom_expr (arg1)));
3975
3976     case FFEINTRIN_impAINT:
3977     case FFEINTRIN_impDINT:
3978 #if 0
3979       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3980       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3981 #else /* in the meantime, must use floor to avoid range problems with ints */
3982       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3983       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3984       return
3985         convert (tree_type,
3986                  ffecom_3 (COND_EXPR, double_type_node,
3987                            ffecom_truth_value
3988                            (ffecom_2 (GE_EXPR, integer_type_node,
3989                                       saved_expr1,
3990                                       convert (arg1_type,
3991                                                ffecom_float_zero_))),
3992                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3993                                              build_tree_list (NULL_TREE,
3994                                                   convert (double_type_node,
3995                                                            saved_expr1)),
3996                                              NULL_TREE),
3997                            ffecom_1 (NEGATE_EXPR, double_type_node,
3998                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3999                                                  build_tree_list (NULL_TREE,
4000                                                   convert (double_type_node,
4001                                                       ffecom_1 (NEGATE_EXPR,
4002                                                                 arg1_type,
4003                                                                saved_expr1))),
4004                                                        NULL_TREE)
4005                                      ))
4006                  );
4007 #endif
4008
4009     case FFEINTRIN_impANINT:
4010     case FFEINTRIN_impDNINT:
4011 #if 0                           /* This way of doing it won't handle real
4012                                    numbers of large magnitudes. */
4013       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4014       expr_tree = convert (tree_type,
4015                            convert (integer_type_node,
4016                                     ffecom_3 (COND_EXPR, tree_type,
4017                                               ffecom_truth_value
4018                                               (ffecom_2 (GE_EXPR,
4019                                                          integer_type_node,
4020                                                          saved_expr1,
4021                                                        ffecom_float_zero_)),
4022                                               ffecom_2 (PLUS_EXPR,
4023                                                         tree_type,
4024                                                         saved_expr1,
4025                                                         ffecom_float_half_),
4026                                               ffecom_2 (MINUS_EXPR,
4027                                                         tree_type,
4028                                                         saved_expr1,
4029                                                      ffecom_float_half_))));
4030       return expr_tree;
4031 #else /* So we instead call floor. */
4032       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4033       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4034       return
4035         convert (tree_type,
4036                  ffecom_3 (COND_EXPR, double_type_node,
4037                            ffecom_truth_value
4038                            (ffecom_2 (GE_EXPR, integer_type_node,
4039                                       saved_expr1,
4040                                       convert (arg1_type,
4041                                                ffecom_float_zero_))),
4042                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4043                                              build_tree_list (NULL_TREE,
4044                                                   convert (double_type_node,
4045                                                            ffecom_2 (PLUS_EXPR,
4046                                                                      arg1_type,
4047                                                                      saved_expr1,
4048                                                                      convert (arg1_type,
4049                                                                               ffecom_float_half_)))),
4050                                              NULL_TREE),
4051                            ffecom_1 (NEGATE_EXPR, double_type_node,
4052                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4053                                                        build_tree_list (NULL_TREE,
4054                                                                         convert (double_type_node,
4055                                                                                  ffecom_2 (MINUS_EXPR,
4056                                                                                            arg1_type,
4057                                                                                            convert (arg1_type,
4058                                                                                                     ffecom_float_half_),
4059                                                                                            saved_expr1))),
4060                                                        NULL_TREE))
4061                            )
4062                  );
4063 #endif
4064
4065     case FFEINTRIN_impASIN:
4066     case FFEINTRIN_impDASIN:
4067     case FFEINTRIN_impATAN:
4068     case FFEINTRIN_impDATAN:
4069     case FFEINTRIN_impATAN2:
4070     case FFEINTRIN_impDATAN2:
4071       break;
4072
4073     case FFEINTRIN_impCHAR:
4074     case FFEINTRIN_impACHAR:
4075 #ifdef HOHO
4076       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4077 #else
4078       tempvar = ffebld_nonter_hook (expr);
4079       assert (tempvar);
4080 #endif
4081       {
4082         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4083
4084         expr_tree = ffecom_modify (tmv,
4085                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4086                                              integer_one_node),
4087                                    convert (tmv, ffecom_expr (arg1)));
4088       }
4089       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4090                             expr_tree,
4091                             tempvar);
4092       expr_tree = ffecom_1 (ADDR_EXPR,
4093                             build_pointer_type (TREE_TYPE (expr_tree)),
4094                             expr_tree);
4095       return expr_tree;
4096
4097     case FFEINTRIN_impCMPLX:
4098     case FFEINTRIN_impDCMPLX:
4099       if (arg2 == NULL)
4100         return
4101           convert (tree_type, ffecom_expr (arg1));
4102
4103       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4104       return
4105         ffecom_2 (COMPLEX_EXPR, tree_type,
4106                   convert (real_type, ffecom_expr (arg1)),
4107                   convert (real_type,
4108                            ffecom_expr (arg2)));
4109
4110     case FFEINTRIN_impCOMPLEX:
4111       return
4112         ffecom_2 (COMPLEX_EXPR, tree_type,
4113                   ffecom_expr (arg1),
4114                   ffecom_expr (arg2));
4115
4116     case FFEINTRIN_impCONJG:
4117     case FFEINTRIN_impDCONJG:
4118       {
4119         tree arg1_tree;
4120
4121         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4122         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4123         return
4124           ffecom_2 (COMPLEX_EXPR, tree_type,
4125                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4126                     ffecom_1 (NEGATE_EXPR, real_type,
4127                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4128       }
4129
4130     case FFEINTRIN_impCOS:
4131     case FFEINTRIN_impCCOS:
4132     case FFEINTRIN_impCDCOS:
4133     case FFEINTRIN_impDCOS:
4134       if (bt == FFEINFO_basictypeCOMPLEX)
4135         {
4136           if (kt == FFEINFO_kindtypeREAL1)
4137             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4138           else if (kt == FFEINFO_kindtypeREAL2)
4139             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4140         }
4141       break;
4142
4143     case FFEINTRIN_impCOSH:
4144     case FFEINTRIN_impDCOSH:
4145       break;
4146
4147     case FFEINTRIN_impDBLE:
4148     case FFEINTRIN_impDFLOAT:
4149     case FFEINTRIN_impDREAL:
4150     case FFEINTRIN_impFLOAT:
4151     case FFEINTRIN_impIDINT:
4152     case FFEINTRIN_impIFIX:
4153     case FFEINTRIN_impINT2:
4154     case FFEINTRIN_impINT8:
4155     case FFEINTRIN_impINT:
4156     case FFEINTRIN_impLONG:
4157     case FFEINTRIN_impREAL:
4158     case FFEINTRIN_impSHORT:
4159     case FFEINTRIN_impSNGL:
4160       return convert (tree_type, ffecom_expr (arg1));
4161
4162     case FFEINTRIN_impDIM:
4163     case FFEINTRIN_impDDIM:
4164     case FFEINTRIN_impIDIM:
4165       saved_expr1 = ffecom_save_tree (convert (tree_type,
4166                                                ffecom_expr (arg1)));
4167       saved_expr2 = ffecom_save_tree (convert (tree_type,
4168                                                ffecom_expr (arg2)));
4169       return
4170         ffecom_3 (COND_EXPR, tree_type,
4171                   ffecom_truth_value
4172                   (ffecom_2 (GT_EXPR, integer_type_node,
4173                              saved_expr1,
4174                              saved_expr2)),
4175                   ffecom_2 (MINUS_EXPR, tree_type,
4176                             saved_expr1,
4177                             saved_expr2),
4178                   convert (tree_type, ffecom_float_zero_));
4179
4180     case FFEINTRIN_impDPROD:
4181       return
4182         ffecom_2 (MULT_EXPR, tree_type,
4183                   convert (tree_type, ffecom_expr (arg1)),
4184                   convert (tree_type, ffecom_expr (arg2)));
4185
4186     case FFEINTRIN_impEXP:
4187     case FFEINTRIN_impCDEXP:
4188     case FFEINTRIN_impCEXP:
4189     case FFEINTRIN_impDEXP:
4190       if (bt == FFEINFO_basictypeCOMPLEX)
4191         {
4192           if (kt == FFEINFO_kindtypeREAL1)
4193             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4194           else if (kt == FFEINFO_kindtypeREAL2)
4195             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4196         }
4197       break;
4198
4199     case FFEINTRIN_impICHAR:
4200     case FFEINTRIN_impIACHAR:
4201 #if 0                           /* The simple approach. */
4202       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4203       expr_tree
4204         = ffecom_1 (INDIRECT_REF,
4205                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4206                     expr_tree);
4207       expr_tree
4208         = ffecom_2 (ARRAY_REF,
4209                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4210                     expr_tree,
4211                     integer_one_node);
4212       return convert (tree_type, expr_tree);
4213 #else /* The more interesting (and more optimal) approach. */
4214       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4215       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4216                             saved_expr1,
4217                             expr_tree,
4218                             convert (tree_type, integer_zero_node));
4219       return expr_tree;
4220 #endif
4221
4222     case FFEINTRIN_impINDEX:
4223       break;
4224
4225     case FFEINTRIN_impLEN:
4226 #if 0
4227       break;                                    /* The simple approach. */
4228 #else
4229       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4230 #endif
4231
4232     case FFEINTRIN_impLGE:
4233     case FFEINTRIN_impLGT:
4234     case FFEINTRIN_impLLE:
4235     case FFEINTRIN_impLLT:
4236       break;
4237
4238     case FFEINTRIN_impLOG:
4239     case FFEINTRIN_impALOG:
4240     case FFEINTRIN_impCDLOG:
4241     case FFEINTRIN_impCLOG:
4242     case FFEINTRIN_impDLOG:
4243       if (bt == FFEINFO_basictypeCOMPLEX)
4244         {
4245           if (kt == FFEINFO_kindtypeREAL1)
4246             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4247           else if (kt == FFEINFO_kindtypeREAL2)
4248             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4249         }
4250       break;
4251
4252     case FFEINTRIN_impLOG10:
4253     case FFEINTRIN_impALOG10:
4254     case FFEINTRIN_impDLOG10:
4255       if (gfrt != FFECOM_gfrt)
4256         break;  /* Already picked one, stick with it. */
4257
4258       if (kt == FFEINFO_kindtypeREAL1)
4259         gfrt = FFECOM_gfrtALOG10;
4260       else if (kt == FFEINFO_kindtypeREAL2)
4261         gfrt = FFECOM_gfrtDLOG10;
4262       break;
4263
4264     case FFEINTRIN_impMAX:
4265     case FFEINTRIN_impAMAX0:
4266     case FFEINTRIN_impAMAX1:
4267     case FFEINTRIN_impDMAX1:
4268     case FFEINTRIN_impMAX0:
4269     case FFEINTRIN_impMAX1:
4270       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4271         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4272       else
4273         arg1_type = tree_type;
4274       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4275                             convert (arg1_type, ffecom_expr (arg1)),
4276                             convert (arg1_type, ffecom_expr (arg2)));
4277       for (; list != NULL; list = ffebld_trail (list))
4278         {
4279           if ((ffebld_head (list) == NULL)
4280               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4281             continue;
4282           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4283                                 expr_tree,
4284                                 convert (arg1_type,
4285                                          ffecom_expr (ffebld_head (list))));
4286         }
4287       return convert (tree_type, expr_tree);
4288
4289     case FFEINTRIN_impMIN:
4290     case FFEINTRIN_impAMIN0:
4291     case FFEINTRIN_impAMIN1:
4292     case FFEINTRIN_impDMIN1:
4293     case FFEINTRIN_impMIN0:
4294     case FFEINTRIN_impMIN1:
4295       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4296         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4297       else
4298         arg1_type = tree_type;
4299       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4300                             convert (arg1_type, ffecom_expr (arg1)),
4301                             convert (arg1_type, ffecom_expr (arg2)));
4302       for (; list != NULL; list = ffebld_trail (list))
4303         {
4304           if ((ffebld_head (list) == NULL)
4305               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4306             continue;
4307           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4308                                 expr_tree,
4309                                 convert (arg1_type,
4310                                          ffecom_expr (ffebld_head (list))));
4311         }
4312       return convert (tree_type, expr_tree);
4313
4314     case FFEINTRIN_impMOD:
4315     case FFEINTRIN_impAMOD:
4316     case FFEINTRIN_impDMOD:
4317       if (bt != FFEINFO_basictypeREAL)
4318         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4319                          convert (tree_type, ffecom_expr (arg1)),
4320                          convert (tree_type, ffecom_expr (arg2)));
4321
4322       if (kt == FFEINFO_kindtypeREAL1)
4323         gfrt = FFECOM_gfrtAMOD;
4324       else if (kt == FFEINFO_kindtypeREAL2)
4325         gfrt = FFECOM_gfrtDMOD;
4326       break;
4327
4328     case FFEINTRIN_impNINT:
4329     case FFEINTRIN_impIDNINT:
4330 #if 0
4331       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4332       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4333 #else
4334       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4335       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4336       return
4337         convert (ffecom_integer_type_node,
4338                  ffecom_3 (COND_EXPR, arg1_type,
4339                            ffecom_truth_value
4340                            (ffecom_2 (GE_EXPR, integer_type_node,
4341                                       saved_expr1,
4342                                       convert (arg1_type,
4343                                                ffecom_float_zero_))),
4344                            ffecom_2 (PLUS_EXPR, arg1_type,
4345                                      saved_expr1,
4346                                      convert (arg1_type,
4347                                               ffecom_float_half_)),
4348                            ffecom_2 (MINUS_EXPR, arg1_type,
4349                                      saved_expr1,
4350                                      convert (arg1_type,
4351                                               ffecom_float_half_))));
4352 #endif
4353
4354     case FFEINTRIN_impSIGN:
4355     case FFEINTRIN_impDSIGN:
4356     case FFEINTRIN_impISIGN:
4357       {
4358         tree arg2_tree = ffecom_expr (arg2);
4359
4360         saved_expr1
4361           = ffecom_save_tree
4362           (ffecom_1 (ABS_EXPR, tree_type,
4363                      convert (tree_type,
4364                               ffecom_expr (arg1))));
4365         expr_tree
4366           = ffecom_3 (COND_EXPR, tree_type,
4367                       ffecom_truth_value
4368                       (ffecom_2 (GE_EXPR, integer_type_node,
4369                                  arg2_tree,
4370                                  convert (TREE_TYPE (arg2_tree),
4371                                           integer_zero_node))),
4372                       saved_expr1,
4373                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4374         /* Make sure SAVE_EXPRs get referenced early enough. */
4375         expr_tree
4376           = ffecom_2 (COMPOUND_EXPR, tree_type,
4377                       convert (void_type_node, saved_expr1),
4378                       expr_tree);
4379       }
4380       return expr_tree;
4381
4382     case FFEINTRIN_impSIN:
4383     case FFEINTRIN_impCDSIN:
4384     case FFEINTRIN_impCSIN:
4385     case FFEINTRIN_impDSIN:
4386       if (bt == FFEINFO_basictypeCOMPLEX)
4387         {
4388           if (kt == FFEINFO_kindtypeREAL1)
4389             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4390           else if (kt == FFEINFO_kindtypeREAL2)
4391             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4392         }
4393       break;
4394
4395     case FFEINTRIN_impSINH:
4396     case FFEINTRIN_impDSINH:
4397       break;
4398
4399     case FFEINTRIN_impSQRT:
4400     case FFEINTRIN_impCDSQRT:
4401     case FFEINTRIN_impCSQRT:
4402     case FFEINTRIN_impDSQRT:
4403       if (bt == FFEINFO_basictypeCOMPLEX)
4404         {
4405           if (kt == FFEINFO_kindtypeREAL1)
4406             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4407           else if (kt == FFEINFO_kindtypeREAL2)
4408             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4409         }
4410       break;
4411
4412     case FFEINTRIN_impTAN:
4413     case FFEINTRIN_impDTAN:
4414     case FFEINTRIN_impTANH:
4415     case FFEINTRIN_impDTANH:
4416       break;
4417
4418     case FFEINTRIN_impREALPART:
4419       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4420         arg1_type = TREE_TYPE (arg1_type);
4421       else
4422         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4423
4424       return
4425         convert (tree_type,
4426                  ffecom_1 (REALPART_EXPR, arg1_type,
4427                            ffecom_expr (arg1)));
4428
4429     case FFEINTRIN_impIAND:
4430     case FFEINTRIN_impAND:
4431       return ffecom_2 (BIT_AND_EXPR, tree_type,
4432                        convert (tree_type,
4433                                 ffecom_expr (arg1)),
4434                        convert (tree_type,
4435                                 ffecom_expr (arg2)));
4436
4437     case FFEINTRIN_impIOR:
4438     case FFEINTRIN_impOR:
4439       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4440                        convert (tree_type,
4441                                 ffecom_expr (arg1)),
4442                        convert (tree_type,
4443                                 ffecom_expr (arg2)));
4444
4445     case FFEINTRIN_impIEOR:
4446     case FFEINTRIN_impXOR:
4447       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4448                        convert (tree_type,
4449                                 ffecom_expr (arg1)),
4450                        convert (tree_type,
4451                                 ffecom_expr (arg2)));
4452
4453     case FFEINTRIN_impLSHIFT:
4454       return ffecom_2 (LSHIFT_EXPR, tree_type,
4455                        ffecom_expr (arg1),
4456                        convert (integer_type_node,
4457                                 ffecom_expr (arg2)));
4458
4459     case FFEINTRIN_impRSHIFT:
4460       return ffecom_2 (RSHIFT_EXPR, tree_type,
4461                        ffecom_expr (arg1),
4462                        convert (integer_type_node,
4463                                 ffecom_expr (arg2)));
4464
4465     case FFEINTRIN_impNOT:
4466       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4467
4468     case FFEINTRIN_impBIT_SIZE:
4469       return convert (tree_type, TYPE_SIZE (arg1_type));
4470
4471     case FFEINTRIN_impBTEST:
4472       {
4473         ffetargetLogical1 true;
4474         ffetargetLogical1 false;
4475         tree true_tree;
4476         tree false_tree;
4477
4478         ffetarget_logical1 (&true, TRUE);
4479         ffetarget_logical1 (&false, FALSE);
4480         if (true == 1)
4481           true_tree = convert (tree_type, integer_one_node);
4482         else
4483           true_tree = convert (tree_type, build_int_2 (true, 0));
4484         if (false == 0)
4485           false_tree = convert (tree_type, integer_zero_node);
4486         else
4487           false_tree = convert (tree_type, build_int_2 (false, 0));
4488
4489         return
4490           ffecom_3 (COND_EXPR, tree_type,
4491                     ffecom_truth_value
4492                     (ffecom_2 (EQ_EXPR, integer_type_node,
4493                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4494                                          ffecom_expr (arg1),
4495                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4496                                                    convert (arg1_type,
4497                                                           integer_one_node),
4498                                                    convert (integer_type_node,
4499                                                             ffecom_expr (arg2)))),
4500                                convert (arg1_type,
4501                                         integer_zero_node))),
4502                     false_tree,
4503                     true_tree);
4504       }
4505
4506     case FFEINTRIN_impIBCLR:
4507       return
4508         ffecom_2 (BIT_AND_EXPR, tree_type,
4509                   ffecom_expr (arg1),
4510                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4511                             ffecom_2 (LSHIFT_EXPR, tree_type,
4512                                       convert (tree_type,
4513                                                integer_one_node),
4514                                       convert (integer_type_node,
4515                                                ffecom_expr (arg2)))));
4516
4517     case FFEINTRIN_impIBITS:
4518       {
4519         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4520                                                     ffecom_expr (arg3)));
4521         tree uns_type
4522         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4523
4524         expr_tree
4525           = ffecom_2 (BIT_AND_EXPR, tree_type,
4526                       ffecom_2 (RSHIFT_EXPR, tree_type,
4527                                 ffecom_expr (arg1),
4528                                 convert (integer_type_node,
4529                                          ffecom_expr (arg2))),
4530                       convert (tree_type,
4531                                ffecom_2 (RSHIFT_EXPR, uns_type,
4532                                          ffecom_1 (BIT_NOT_EXPR,
4533                                                    uns_type,
4534                                                    convert (uns_type,
4535                                                         integer_zero_node)),
4536                                          ffecom_2 (MINUS_EXPR,
4537                                                    integer_type_node,
4538                                                    TYPE_SIZE (uns_type),
4539                                                    arg3_tree))));
4540 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4541         expr_tree
4542           = ffecom_3 (COND_EXPR, tree_type,
4543                       ffecom_truth_value
4544                       (ffecom_2 (NE_EXPR, integer_type_node,
4545                                  arg3_tree,
4546                                  integer_zero_node)),
4547                       expr_tree,
4548                       convert (tree_type, integer_zero_node));
4549 #endif
4550       }
4551       return expr_tree;
4552
4553     case FFEINTRIN_impIBSET:
4554       return
4555         ffecom_2 (BIT_IOR_EXPR, tree_type,
4556                   ffecom_expr (arg1),
4557                   ffecom_2 (LSHIFT_EXPR, tree_type,
4558                             convert (tree_type, integer_one_node),
4559                             convert (integer_type_node,
4560                                      ffecom_expr (arg2))));
4561
4562     case FFEINTRIN_impISHFT:
4563       {
4564         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4565         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4566                                                     ffecom_expr (arg2)));
4567         tree uns_type
4568         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4569
4570         expr_tree
4571           = ffecom_3 (COND_EXPR, tree_type,
4572                       ffecom_truth_value
4573                       (ffecom_2 (GE_EXPR, integer_type_node,
4574                                  arg2_tree,
4575                                  integer_zero_node)),
4576                       ffecom_2 (LSHIFT_EXPR, tree_type,
4577                                 arg1_tree,
4578                                 arg2_tree),
4579                       convert (tree_type,
4580                                ffecom_2 (RSHIFT_EXPR, uns_type,
4581                                          convert (uns_type, arg1_tree),
4582                                          ffecom_1 (NEGATE_EXPR,
4583                                                    integer_type_node,
4584                                                    arg2_tree))));
4585 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4586         expr_tree
4587           = ffecom_3 (COND_EXPR, tree_type,
4588                       ffecom_truth_value
4589                       (ffecom_2 (NE_EXPR, integer_type_node,
4590                                  arg2_tree,
4591                                  TYPE_SIZE (uns_type))),
4592                       expr_tree,
4593                       convert (tree_type, integer_zero_node));
4594 #endif
4595         /* Make sure SAVE_EXPRs get referenced early enough. */
4596         expr_tree
4597           = ffecom_2 (COMPOUND_EXPR, tree_type,
4598                       convert (void_type_node, arg1_tree),
4599                       ffecom_2 (COMPOUND_EXPR, tree_type,
4600                                 convert (void_type_node, arg2_tree),
4601                                 expr_tree));
4602       }
4603       return expr_tree;
4604
4605     case FFEINTRIN_impISHFTC:
4606       {
4607         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4608         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4609                                                     ffecom_expr (arg2)));
4610         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4611         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4612         tree shift_neg;
4613         tree shift_pos;
4614         tree mask_arg1;
4615         tree masked_arg1;
4616         tree uns_type
4617         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4618
4619         mask_arg1
4620           = ffecom_2 (LSHIFT_EXPR, tree_type,
4621                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4622                                 convert (tree_type, integer_zero_node)),
4623                       arg3_tree);
4624 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4625         mask_arg1
4626           = ffecom_3 (COND_EXPR, tree_type,
4627                       ffecom_truth_value
4628                       (ffecom_2 (NE_EXPR, integer_type_node,
4629                                  arg3_tree,
4630                                  TYPE_SIZE (uns_type))),
4631                       mask_arg1,
4632                       convert (tree_type, integer_zero_node));
4633 #endif
4634         mask_arg1 = ffecom_save_tree (mask_arg1);
4635         masked_arg1
4636           = ffecom_2 (BIT_AND_EXPR, tree_type,
4637                       arg1_tree,
4638                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4639                                 mask_arg1));
4640         masked_arg1 = ffecom_save_tree (masked_arg1);
4641         shift_neg
4642           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4643                       convert (tree_type,
4644                                ffecom_2 (RSHIFT_EXPR, uns_type,
4645                                          convert (uns_type, masked_arg1),
4646                                          ffecom_1 (NEGATE_EXPR,
4647                                                    integer_type_node,
4648                                                    arg2_tree))),
4649                       ffecom_2 (LSHIFT_EXPR, tree_type,
4650                                 arg1_tree,
4651                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4652                                           arg2_tree,
4653                                           arg3_tree)));
4654         shift_pos
4655           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4656                       ffecom_2 (LSHIFT_EXPR, tree_type,
4657                                 arg1_tree,
4658                                 arg2_tree),
4659                       convert (tree_type,
4660                                ffecom_2 (RSHIFT_EXPR, uns_type,
4661                                          convert (uns_type, masked_arg1),
4662                                          ffecom_2 (MINUS_EXPR,
4663                                                    integer_type_node,
4664                                                    arg3_tree,
4665                                                    arg2_tree))));
4666         expr_tree
4667           = ffecom_3 (COND_EXPR, tree_type,
4668                       ffecom_truth_value
4669                       (ffecom_2 (LT_EXPR, integer_type_node,
4670                                  arg2_tree,
4671                                  integer_zero_node)),
4672                       shift_neg,
4673                       shift_pos);
4674         expr_tree
4675           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4676                       ffecom_2 (BIT_AND_EXPR, tree_type,
4677                                 mask_arg1,
4678                                 arg1_tree),
4679                       ffecom_2 (BIT_AND_EXPR, tree_type,
4680                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4681                                           mask_arg1),
4682                                 expr_tree));
4683         expr_tree
4684           = ffecom_3 (COND_EXPR, tree_type,
4685                       ffecom_truth_value
4686                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4687                                  ffecom_2 (EQ_EXPR, integer_type_node,
4688                                            ffecom_1 (ABS_EXPR,
4689                                                      integer_type_node,
4690                                                      arg2_tree),
4691                                            arg3_tree),
4692                                  ffecom_2 (EQ_EXPR, integer_type_node,
4693                                            arg2_tree,
4694                                            integer_zero_node))),
4695                       arg1_tree,
4696                       expr_tree);
4697         /* Make sure SAVE_EXPRs get referenced early enough. */
4698         expr_tree
4699           = ffecom_2 (COMPOUND_EXPR, tree_type,
4700                       convert (void_type_node, arg1_tree),
4701                       ffecom_2 (COMPOUND_EXPR, tree_type,
4702                                 convert (void_type_node, arg2_tree),
4703                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4704                                           convert (void_type_node,
4705                                                    mask_arg1),
4706                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4707                                                     convert (void_type_node,
4708                                                              masked_arg1),
4709                                                     expr_tree))));
4710         expr_tree
4711           = ffecom_2 (COMPOUND_EXPR, tree_type,
4712                       convert (void_type_node,
4713                                arg3_tree),
4714                       expr_tree);
4715       }
4716       return expr_tree;
4717
4718     case FFEINTRIN_impLOC:
4719       {
4720         tree arg1_tree = ffecom_expr (arg1);
4721
4722         expr_tree
4723           = convert (tree_type,
4724                      ffecom_1 (ADDR_EXPR,
4725                                build_pointer_type (TREE_TYPE (arg1_tree)),
4726                                arg1_tree));
4727       }
4728       return expr_tree;
4729
4730     case FFEINTRIN_impMVBITS:
4731       {
4732         tree arg1_tree;
4733         tree arg2_tree;
4734         tree arg3_tree;
4735         ffebld arg4 = ffebld_head (ffebld_trail (list));
4736         tree arg4_tree;
4737         tree arg4_type;
4738         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4739         tree arg5_tree;
4740         tree prep_arg1;
4741         tree prep_arg4;
4742         tree arg5_plus_arg3;
4743
4744         arg2_tree = convert (integer_type_node,
4745                              ffecom_expr (arg2));
4746         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4747                                                ffecom_expr (arg3)));
4748         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4749         arg4_type = TREE_TYPE (arg4_tree);
4750
4751         arg1_tree = ffecom_save_tree (convert (arg4_type,
4752                                                ffecom_expr (arg1)));
4753
4754         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4755                                                ffecom_expr (arg5)));
4756
4757         prep_arg1
4758           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4759                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4760                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4761                                           arg1_tree,
4762                                           arg2_tree),
4763                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4764                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4765                                                     ffecom_1 (BIT_NOT_EXPR,
4766                                                               arg4_type,
4767                                                               convert
4768                                                               (arg4_type,
4769                                                         integer_zero_node)),
4770                                                     arg3_tree))),
4771                       arg5_tree);
4772         arg5_plus_arg3
4773           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4774                                         arg5_tree,
4775                                         arg3_tree));
4776         prep_arg4
4777           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4778                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4779                                 convert (arg4_type,
4780                                          integer_zero_node)),
4781                       arg5_plus_arg3);
4782 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4783         prep_arg4
4784           = ffecom_3 (COND_EXPR, arg4_type,
4785                       ffecom_truth_value
4786                       (ffecom_2 (NE_EXPR, integer_type_node,
4787                                  arg5_plus_arg3,
4788                                  convert (TREE_TYPE (arg5_plus_arg3),
4789                                           TYPE_SIZE (arg4_type)))),
4790                       prep_arg4,
4791                       convert (arg4_type, integer_zero_node));
4792 #endif
4793         prep_arg4
4794           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4795                       arg4_tree,
4796                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4797                                 prep_arg4,
4798                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4799                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4800                                                     ffecom_1 (BIT_NOT_EXPR,
4801                                                               arg4_type,
4802                                                               convert
4803                                                               (arg4_type,
4804                                                         integer_zero_node)),
4805                                                     arg5_tree))));
4806         prep_arg1
4807           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4808                       prep_arg1,
4809                       prep_arg4);
4810 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4811         prep_arg1
4812           = ffecom_3 (COND_EXPR, arg4_type,
4813                       ffecom_truth_value
4814                       (ffecom_2 (NE_EXPR, integer_type_node,
4815                                  arg3_tree,
4816                                  convert (TREE_TYPE (arg3_tree),
4817                                           integer_zero_node))),
4818                       prep_arg1,
4819                       arg4_tree);
4820         prep_arg1
4821           = ffecom_3 (COND_EXPR, arg4_type,
4822                       ffecom_truth_value
4823                       (ffecom_2 (NE_EXPR, integer_type_node,
4824                                  arg3_tree,
4825                                  convert (TREE_TYPE (arg3_tree),
4826                                           TYPE_SIZE (arg4_type)))),
4827                       prep_arg1,
4828                       arg1_tree);
4829 #endif
4830         expr_tree
4831           = ffecom_2s (MODIFY_EXPR, void_type_node,
4832                        arg4_tree,
4833                        prep_arg1);
4834         /* Make sure SAVE_EXPRs get referenced early enough. */
4835         expr_tree
4836           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4837                       arg1_tree,
4838                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4839                                 arg3_tree,
4840                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4841                                           arg5_tree,
4842                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4843                                                     arg5_plus_arg3,
4844                                                     expr_tree))));
4845         expr_tree
4846           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4847                       arg4_tree,
4848                       expr_tree);
4849
4850       }
4851       return expr_tree;
4852
4853     case FFEINTRIN_impDERF:
4854     case FFEINTRIN_impERF:
4855     case FFEINTRIN_impDERFC:
4856     case FFEINTRIN_impERFC:
4857       break;
4858
4859     case FFEINTRIN_impIARGC:
4860       /* extern int xargc; i__1 = xargc - 1; */
4861       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4862                             ffecom_tree_xargc_,
4863                             convert (TREE_TYPE (ffecom_tree_xargc_),
4864                                      integer_one_node));
4865       return expr_tree;
4866
4867     case FFEINTRIN_impSIGNAL_func:
4868     case FFEINTRIN_impSIGNAL_subr:
4869       {
4870         tree arg1_tree;
4871         tree arg2_tree;
4872         tree arg3_tree;
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         /* Pass procedure as a pointer to it, anything else by value.  */
4881         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4882           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4883         else
4884           arg2_tree = ffecom_ptr_to_expr (arg2);
4885         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4886                              arg2_tree);
4887
4888         if (arg3 != NULL)
4889           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4890         else
4891           arg3_tree = NULL_TREE;
4892
4893         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4894         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4895         TREE_CHAIN (arg1_tree) = arg2_tree;
4896
4897         expr_tree
4898           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4899                           ffecom_gfrt_kindtype (gfrt),
4900                           FALSE,
4901                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4902                            NULL_TREE :
4903                            tree_type),
4904                           arg1_tree,
4905                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4906                           ffebld_nonter_hook (expr));
4907
4908         if (arg3_tree != NULL_TREE)
4909           expr_tree
4910             = ffecom_modify (NULL_TREE, arg3_tree,
4911                              convert (TREE_TYPE (arg3_tree),
4912                                       expr_tree));
4913       }
4914       return expr_tree;
4915
4916     case FFEINTRIN_impALARM:
4917       {
4918         tree arg1_tree;
4919         tree arg2_tree;
4920         tree arg3_tree;
4921
4922         arg1_tree = convert (ffecom_f2c_integer_type_node,
4923                              ffecom_expr (arg1));
4924         arg1_tree = ffecom_1 (ADDR_EXPR,
4925                               build_pointer_type (TREE_TYPE (arg1_tree)),
4926                               arg1_tree);
4927
4928         /* Pass procedure as a pointer to it, anything else by value.  */
4929         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4930           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4931         else
4932           arg2_tree = ffecom_ptr_to_expr (arg2);
4933         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4934                              arg2_tree);
4935
4936         if (arg3 != NULL)
4937           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4938         else
4939           arg3_tree = NULL_TREE;
4940
4941         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4942         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4943         TREE_CHAIN (arg1_tree) = arg2_tree;
4944
4945         expr_tree
4946           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4947                           ffecom_gfrt_kindtype (gfrt),
4948                           FALSE,
4949                           NULL_TREE,
4950                           arg1_tree,
4951                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4952                           ffebld_nonter_hook (expr));
4953
4954         if (arg3_tree != NULL_TREE)
4955           expr_tree
4956             = ffecom_modify (NULL_TREE, arg3_tree,
4957                              convert (TREE_TYPE (arg3_tree),
4958                                       expr_tree));
4959       }
4960       return expr_tree;
4961
4962     case FFEINTRIN_impCHDIR_subr:
4963     case FFEINTRIN_impFDATE_subr:
4964     case FFEINTRIN_impFGET_subr:
4965     case FFEINTRIN_impFPUT_subr:
4966     case FFEINTRIN_impGETCWD_subr:
4967     case FFEINTRIN_impHOSTNM_subr:
4968     case FFEINTRIN_impSYSTEM_subr:
4969     case FFEINTRIN_impUNLINK_subr:
4970       {
4971         tree arg1_len = integer_zero_node;
4972         tree arg1_tree;
4973         tree arg2_tree;
4974
4975         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4976
4977         if (arg2 != NULL)
4978           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4979         else
4980           arg2_tree = NULL_TREE;
4981
4982         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4983         arg1_len = build_tree_list (NULL_TREE, arg1_len);
4984         TREE_CHAIN (arg1_tree) = arg1_len;
4985
4986         expr_tree
4987           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4988                           ffecom_gfrt_kindtype (gfrt),
4989                           FALSE,
4990                           NULL_TREE,
4991                           arg1_tree,
4992                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4993                           ffebld_nonter_hook (expr));
4994
4995         if (arg2_tree != NULL_TREE)
4996           expr_tree
4997             = ffecom_modify (NULL_TREE, arg2_tree,
4998                              convert (TREE_TYPE (arg2_tree),
4999                                       expr_tree));
5000       }
5001       return expr_tree;
5002
5003     case FFEINTRIN_impEXIT:
5004       if (arg1 != NULL)
5005         break;
5006
5007       expr_tree = build_tree_list (NULL_TREE,
5008                                    ffecom_1 (ADDR_EXPR,
5009                                              build_pointer_type
5010                                              (ffecom_integer_type_node),
5011                                              integer_zero_node));
5012
5013       return
5014         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5015                       ffecom_gfrt_kindtype (gfrt),
5016                       FALSE,
5017                       void_type_node,
5018                       expr_tree,
5019                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5020                       ffebld_nonter_hook (expr));
5021
5022     case FFEINTRIN_impFLUSH:
5023       if (arg1 == NULL)
5024         gfrt = FFECOM_gfrtFLUSH;
5025       else
5026         gfrt = FFECOM_gfrtFLUSH1;
5027       break;
5028
5029     case FFEINTRIN_impCHMOD_subr:
5030     case FFEINTRIN_impLINK_subr:
5031     case FFEINTRIN_impRENAME_subr:
5032     case FFEINTRIN_impSYMLNK_subr:
5033       {
5034         tree arg1_len = integer_zero_node;
5035         tree arg1_tree;
5036         tree arg2_len = integer_zero_node;
5037         tree arg2_tree;
5038         tree arg3_tree;
5039
5040         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5041         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5042         if (arg3 != NULL)
5043           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5044         else
5045           arg3_tree = NULL_TREE;
5046
5047         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5048         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5049         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5050         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5051         TREE_CHAIN (arg1_tree) = arg2_tree;
5052         TREE_CHAIN (arg2_tree) = arg1_len;
5053         TREE_CHAIN (arg1_len) = arg2_len;
5054         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5055                                   ffecom_gfrt_kindtype (gfrt),
5056                                   FALSE,
5057                                   NULL_TREE,
5058                                   arg1_tree,
5059                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5060                                   ffebld_nonter_hook (expr));
5061         if (arg3_tree != NULL_TREE)
5062           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5063                                      convert (TREE_TYPE (arg3_tree),
5064                                               expr_tree));
5065       }
5066       return expr_tree;
5067
5068     case FFEINTRIN_impLSTAT_subr:
5069     case FFEINTRIN_impSTAT_subr:
5070       {
5071         tree arg1_len = integer_zero_node;
5072         tree arg1_tree;
5073         tree arg2_tree;
5074         tree arg3_tree;
5075
5076         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5077
5078         arg2_tree = ffecom_ptr_to_expr (arg2);
5079
5080         if (arg3 != NULL)
5081           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5082         else
5083           arg3_tree = NULL_TREE;
5084
5085         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5086         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5087         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5088         TREE_CHAIN (arg1_tree) = arg2_tree;
5089         TREE_CHAIN (arg2_tree) = arg1_len;
5090         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5091                                   ffecom_gfrt_kindtype (gfrt),
5092                                   FALSE,
5093                                   NULL_TREE,
5094                                   arg1_tree,
5095                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5096                                   ffebld_nonter_hook (expr));
5097         if (arg3_tree != NULL_TREE)
5098           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5099                                      convert (TREE_TYPE (arg3_tree),
5100                                               expr_tree));
5101       }
5102       return expr_tree;
5103
5104     case FFEINTRIN_impFGETC_subr:
5105     case FFEINTRIN_impFPUTC_subr:
5106       {
5107         tree arg1_tree;
5108         tree arg2_tree;
5109         tree arg2_len = integer_zero_node;
5110         tree arg3_tree;
5111
5112         arg1_tree = convert (ffecom_f2c_integer_type_node,
5113                              ffecom_expr (arg1));
5114         arg1_tree = ffecom_1 (ADDR_EXPR,
5115                               build_pointer_type (TREE_TYPE (arg1_tree)),
5116                               arg1_tree);
5117
5118         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5119         arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5120
5121         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5122         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5123         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5124         TREE_CHAIN (arg1_tree) = arg2_tree;
5125         TREE_CHAIN (arg2_tree) = arg2_len;
5126
5127         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5128                                   ffecom_gfrt_kindtype (gfrt),
5129                                   FALSE,
5130                                   NULL_TREE,
5131                                   arg1_tree,
5132                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5133                                   ffebld_nonter_hook (expr));
5134         expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5135                                    convert (TREE_TYPE (arg3_tree),
5136                                             expr_tree));
5137       }
5138       return expr_tree;
5139
5140     case FFEINTRIN_impFSTAT_subr:
5141       {
5142         tree arg1_tree;
5143         tree arg2_tree;
5144         tree arg3_tree;
5145
5146         arg1_tree = convert (ffecom_f2c_integer_type_node,
5147                              ffecom_expr (arg1));
5148         arg1_tree = ffecom_1 (ADDR_EXPR,
5149                               build_pointer_type (TREE_TYPE (arg1_tree)),
5150                               arg1_tree);
5151
5152         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5153                              ffecom_ptr_to_expr (arg2));
5154
5155         if (arg3 == NULL)
5156           arg3_tree = NULL_TREE;
5157         else
5158           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5159
5160         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5161         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5162         TREE_CHAIN (arg1_tree) = arg2_tree;
5163         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5164                                   ffecom_gfrt_kindtype (gfrt),
5165                                   FALSE,
5166                                   NULL_TREE,
5167                                   arg1_tree,
5168                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5169                                   ffebld_nonter_hook (expr));
5170         if (arg3_tree != NULL_TREE) {
5171           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5172                                      convert (TREE_TYPE (arg3_tree),
5173                                               expr_tree));
5174         }
5175       }
5176       return expr_tree;
5177
5178     case FFEINTRIN_impKILL_subr:
5179       {
5180         tree arg1_tree;
5181         tree arg2_tree;
5182         tree arg3_tree;
5183
5184         arg1_tree = convert (ffecom_f2c_integer_type_node,
5185                              ffecom_expr (arg1));
5186         arg1_tree = ffecom_1 (ADDR_EXPR,
5187                               build_pointer_type (TREE_TYPE (arg1_tree)),
5188                               arg1_tree);
5189
5190         arg2_tree = convert (ffecom_f2c_integer_type_node,
5191                              ffecom_expr (arg2));
5192         arg2_tree = ffecom_1 (ADDR_EXPR,
5193                               build_pointer_type (TREE_TYPE (arg2_tree)),
5194                               arg2_tree);
5195
5196         if (arg3 == NULL)
5197           arg3_tree = NULL_TREE;
5198         else
5199           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5200
5201         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5202         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5203         TREE_CHAIN (arg1_tree) = arg2_tree;
5204         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5205                                   ffecom_gfrt_kindtype (gfrt),
5206                                   FALSE,
5207                                   NULL_TREE,
5208                                   arg1_tree,
5209                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5210                                   ffebld_nonter_hook (expr));
5211         if (arg3_tree != NULL_TREE) {
5212           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5213                                      convert (TREE_TYPE (arg3_tree),
5214                                               expr_tree));
5215         }
5216       }
5217       return expr_tree;
5218
5219     case FFEINTRIN_impCTIME_subr:
5220     case FFEINTRIN_impTTYNAM_subr:
5221       {
5222         tree arg1_len = integer_zero_node;
5223         tree arg1_tree;
5224         tree arg2_tree;
5225
5226         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5227
5228         arg2_tree = convert (((gfrt == FFEINTRIN_impCTIME_subr) ?
5229                               ffecom_f2c_longint_type_node :
5230                               ffecom_f2c_integer_type_node),
5231                              ffecom_expr (arg2));
5232         arg2_tree = ffecom_1 (ADDR_EXPR,
5233                               build_pointer_type (TREE_TYPE (arg2_tree)),
5234                               arg2_tree);
5235
5236         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5237         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5238         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5239         TREE_CHAIN (arg1_len) = arg2_tree;
5240         TREE_CHAIN (arg1_tree) = arg1_len;
5241
5242         expr_tree
5243           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5244                           ffecom_gfrt_kindtype (gfrt),
5245                           FALSE,
5246                           NULL_TREE,
5247                           arg1_tree,
5248                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5249                           ffebld_nonter_hook (expr));
5250       }
5251       return expr_tree;
5252
5253     case FFEINTRIN_impIRAND:
5254     case FFEINTRIN_impRAND:
5255       /* Arg defaults to 0 (normal random case) */
5256       {
5257         tree arg1_tree;
5258
5259         if (arg1 == NULL)
5260           arg1_tree = ffecom_integer_zero_node;
5261         else
5262           arg1_tree = ffecom_expr (arg1);
5263         arg1_tree = convert (ffecom_f2c_integer_type_node,
5264                              arg1_tree);
5265         arg1_tree = ffecom_1 (ADDR_EXPR,
5266                               build_pointer_type (TREE_TYPE (arg1_tree)),
5267                               arg1_tree);
5268         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5269
5270         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5271                                   ffecom_gfrt_kindtype (gfrt),
5272                                   FALSE,
5273                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5274                                    ffecom_f2c_integer_type_node :
5275                                    ffecom_f2c_real_type_node),
5276                                   arg1_tree,
5277                                   dest_tree, dest, dest_used,
5278                                   NULL_TREE, TRUE,
5279                                   ffebld_nonter_hook (expr));
5280       }
5281       return expr_tree;
5282
5283     case FFEINTRIN_impFTELL_subr:
5284     case FFEINTRIN_impUMASK_subr:
5285       {
5286         tree arg1_tree;
5287         tree arg2_tree;
5288
5289         arg1_tree = convert (ffecom_f2c_integer_type_node,
5290                              ffecom_expr (arg1));
5291         arg1_tree = ffecom_1 (ADDR_EXPR,
5292                               build_pointer_type (TREE_TYPE (arg1_tree)),
5293                               arg1_tree);
5294
5295         if (arg2 == NULL)
5296           arg2_tree = NULL_TREE;
5297         else
5298           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5299
5300         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5301                                   ffecom_gfrt_kindtype (gfrt),
5302                                   FALSE,
5303                                   NULL_TREE,
5304                                   build_tree_list (NULL_TREE, arg1_tree),
5305                                   NULL_TREE, NULL, NULL, NULL_TREE,
5306                                   TRUE,
5307                                   ffebld_nonter_hook (expr));
5308         if (arg2_tree != NULL_TREE) {
5309           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5310                                      convert (TREE_TYPE (arg2_tree),
5311                                               expr_tree));
5312         }
5313       }
5314       return expr_tree;
5315
5316     case FFEINTRIN_impCPU_TIME:
5317     case FFEINTRIN_impSECOND_subr:
5318       {
5319         tree arg1_tree;
5320
5321         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5322
5323         expr_tree
5324           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5325                           ffecom_gfrt_kindtype (gfrt),
5326                           FALSE,
5327                           NULL_TREE,
5328                           NULL_TREE,
5329                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5330                           ffebld_nonter_hook (expr));
5331
5332         expr_tree
5333           = ffecom_modify (NULL_TREE, arg1_tree,
5334                            convert (TREE_TYPE (arg1_tree),
5335                                     expr_tree));
5336       }
5337       return expr_tree;
5338
5339     case FFEINTRIN_impDTIME_subr:
5340     case FFEINTRIN_impETIME_subr:
5341       {
5342         tree arg1_tree;
5343         tree arg2_tree;
5344
5345         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5346
5347         arg2_tree = ffecom_ptr_to_expr (arg2);
5348
5349         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5350                                   ffecom_gfrt_kindtype (gfrt),
5351                                   FALSE,
5352                                   NULL_TREE,
5353                                   build_tree_list (NULL_TREE, arg2_tree),
5354                                   NULL_TREE, NULL, NULL, NULL_TREE,
5355                                   TRUE,
5356                                   ffebld_nonter_hook (expr));
5357         expr_tree = ffecom_modify (NULL_TREE, arg1_tree,
5358                                    convert (TREE_TYPE (arg1_tree),
5359                                             expr_tree));
5360       }
5361       return expr_tree;
5362
5363       /* Straightforward calls of libf2c routines: */
5364     case FFEINTRIN_impABORT:
5365     case FFEINTRIN_impACCESS:
5366     case FFEINTRIN_impBESJ0:
5367     case FFEINTRIN_impBESJ1:
5368     case FFEINTRIN_impBESJN:
5369     case FFEINTRIN_impBESY0:
5370     case FFEINTRIN_impBESY1:
5371     case FFEINTRIN_impBESYN:
5372     case FFEINTRIN_impCHDIR_func:
5373     case FFEINTRIN_impCHMOD_func:
5374     case FFEINTRIN_impDATE:
5375     case FFEINTRIN_impDATE_AND_TIME:
5376     case FFEINTRIN_impDBESJ0:
5377     case FFEINTRIN_impDBESJ1:
5378     case FFEINTRIN_impDBESJN:
5379     case FFEINTRIN_impDBESY0:
5380     case FFEINTRIN_impDBESY1:
5381     case FFEINTRIN_impDBESYN:
5382     case FFEINTRIN_impDTIME_func:
5383     case FFEINTRIN_impETIME_func:
5384     case FFEINTRIN_impFGETC_func:
5385     case FFEINTRIN_impFGET_func:
5386     case FFEINTRIN_impFNUM:
5387     case FFEINTRIN_impFPUTC_func:
5388     case FFEINTRIN_impFPUT_func:
5389     case FFEINTRIN_impFSEEK:
5390     case FFEINTRIN_impFSTAT_func:
5391     case FFEINTRIN_impFTELL_func:
5392     case FFEINTRIN_impGERROR:
5393     case FFEINTRIN_impGETARG:
5394     case FFEINTRIN_impGETCWD_func:
5395     case FFEINTRIN_impGETENV:
5396     case FFEINTRIN_impGETGID:
5397     case FFEINTRIN_impGETLOG:
5398     case FFEINTRIN_impGETPID:
5399     case FFEINTRIN_impGETUID:
5400     case FFEINTRIN_impGMTIME:
5401     case FFEINTRIN_impHOSTNM_func:
5402     case FFEINTRIN_impIDATE_unix:
5403     case FFEINTRIN_impIDATE_vxt:
5404     case FFEINTRIN_impIERRNO:
5405     case FFEINTRIN_impISATTY:
5406     case FFEINTRIN_impITIME:
5407     case FFEINTRIN_impKILL_func:
5408     case FFEINTRIN_impLINK_func:
5409     case FFEINTRIN_impLNBLNK:
5410     case FFEINTRIN_impLSTAT_func:
5411     case FFEINTRIN_impLTIME:
5412     case FFEINTRIN_impMCLOCK8:
5413     case FFEINTRIN_impMCLOCK:
5414     case FFEINTRIN_impPERROR:
5415     case FFEINTRIN_impRENAME_func:
5416     case FFEINTRIN_impSECNDS:
5417     case FFEINTRIN_impSECOND_func:
5418     case FFEINTRIN_impSLEEP:
5419     case FFEINTRIN_impSRAND:
5420     case FFEINTRIN_impSTAT_func:
5421     case FFEINTRIN_impSYMLNK_func:
5422     case FFEINTRIN_impSYSTEM_CLOCK:
5423     case FFEINTRIN_impSYSTEM_func:
5424     case FFEINTRIN_impTIME8:
5425     case FFEINTRIN_impTIME_unix:
5426     case FFEINTRIN_impTIME_vxt:
5427     case FFEINTRIN_impUMASK_func:
5428     case FFEINTRIN_impUNLINK_func:
5429       break;
5430
5431     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5432     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5433     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5434     case FFEINTRIN_impNONE:
5435     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5436       fprintf (stderr, "No %s implementation.\n",
5437                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5438       assert ("unimplemented intrinsic" == NULL);
5439       return error_mark_node;
5440     }
5441
5442   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5443
5444   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5445                                     ffebld_right (expr));
5446
5447   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5448                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5449                        tree_type,
5450                        expr_tree, dest_tree, dest, dest_used,
5451                        NULL_TREE, TRUE,
5452                        ffebld_nonter_hook (expr));
5453
5454   /* See bottom of this file for f2c transforms used to determine
5455      many of the above implementations.  The info seems to confuse
5456      Emacs's C mode indentation, which is why it's been moved to
5457      the bottom of this source file.  */
5458 }
5459
5460 #endif
5461 /* For power (exponentiation) where right-hand operand is type INTEGER,
5462    generate in-line code to do it the fast way (which, if the operand
5463    is a constant, might just mean a series of multiplies).  */
5464
5465 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5466 static tree
5467 ffecom_expr_power_integer_ (ffebld expr)
5468 {
5469   tree l = ffecom_expr (ffebld_left (expr));
5470   tree r = ffecom_expr (ffebld_right (expr));
5471   tree ltype = TREE_TYPE (l);
5472   tree rtype = TREE_TYPE (r);
5473   tree result = NULL_TREE;
5474
5475   if (l == error_mark_node
5476       || r == error_mark_node)
5477     return error_mark_node;
5478
5479   if (TREE_CODE (r) == INTEGER_CST)
5480     {
5481       int sgn = tree_int_cst_sgn (r);
5482
5483       if (sgn == 0)
5484         return convert (ltype, integer_one_node);
5485
5486       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5487           && (sgn < 0))
5488         {
5489           /* Reciprocal of integer is either 0, -1, or 1, so after
5490              calculating that (which we leave to the back end to do
5491              or not do optimally), don't bother with any multiplying.  */
5492
5493           result = ffecom_tree_divide_ (ltype,
5494                                         convert (ltype, integer_one_node),
5495                                         l,
5496                                         NULL_TREE, NULL, NULL, NULL_TREE);
5497           r = ffecom_1 (NEGATE_EXPR,
5498                         rtype,
5499                         r);
5500           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5501             result = ffecom_1 (ABS_EXPR, rtype,
5502                                result);
5503         }
5504
5505       /* Generate appropriate series of multiplies, preceded
5506          by divide if the exponent is negative.  */
5507
5508       l = save_expr (l);
5509
5510       if (sgn < 0)
5511         {
5512           l = ffecom_tree_divide_ (ltype,
5513                                    convert (ltype, integer_one_node),
5514                                    l,
5515                                    NULL_TREE, NULL, NULL,
5516                                    ffebld_nonter_hook (expr));
5517           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5518           assert (TREE_CODE (r) == INTEGER_CST);
5519
5520           if (tree_int_cst_sgn (r) < 0)
5521             {                   /* The "most negative" number.  */
5522               r = ffecom_1 (NEGATE_EXPR, rtype,
5523                             ffecom_2 (RSHIFT_EXPR, rtype,
5524                                       r,
5525                                       integer_one_node));
5526               l = save_expr (l);
5527               l = ffecom_2 (MULT_EXPR, ltype,
5528                             l,
5529                             l);
5530             }
5531         }
5532
5533       for (;;)
5534         {
5535           if (TREE_INT_CST_LOW (r) & 1)
5536             {
5537               if (result == NULL_TREE)
5538                 result = l;
5539               else
5540                 result = ffecom_2 (MULT_EXPR, ltype,
5541                                    result,
5542                                    l);
5543             }
5544
5545           r = ffecom_2 (RSHIFT_EXPR, rtype,
5546                         r,
5547                         integer_one_node);
5548           if (integer_zerop (r))
5549             break;
5550           assert (TREE_CODE (r) == INTEGER_CST);
5551
5552           l = save_expr (l);
5553           l = ffecom_2 (MULT_EXPR, ltype,
5554                         l,
5555                         l);
5556         }
5557       return result;
5558     }
5559
5560   /* Though rhs isn't a constant, in-line code cannot be expanded
5561      while transforming dummies
5562      because the back end cannot be easily convinced to generate
5563      stores (MODIFY_EXPR), handle temporaries, and so on before
5564      all the appropriate rtx's have been generated for things like
5565      dummy args referenced in rhs -- which doesn't happen until
5566      store_parm_decls() is called (expand_function_start, I believe,
5567      does the actual rtx-stuffing of PARM_DECLs).
5568
5569      So, in this case, let the caller generate the call to the
5570      run-time-library function to evaluate the power for us.  */
5571
5572   if (ffecom_transform_only_dummies_)
5573     return NULL_TREE;
5574
5575   /* Right-hand operand not a constant, expand in-line code to figure
5576      out how to do the multiplies, &c.
5577
5578      The returned expression is expressed this way in GNU C, where l and
5579      r are the "inputs":
5580
5581      ({ typeof (r) rtmp = r;
5582         typeof (l) ltmp = l;
5583         typeof (l) result;
5584
5585         if (rtmp == 0)
5586           result = 1;
5587         else
5588           {
5589             if ((basetypeof (l) == basetypeof (int))
5590                 && (rtmp < 0))
5591               {
5592                 result = ((typeof (l)) 1) / ltmp;
5593                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5594                   result = -result;
5595               }
5596             else
5597               {
5598                 result = 1;
5599                 if ((basetypeof (l) != basetypeof (int))
5600                     && (rtmp < 0))
5601                   {
5602                     ltmp = ((typeof (l)) 1) / ltmp;
5603                     rtmp = -rtmp;
5604                     if (rtmp < 0)
5605                       {
5606                         rtmp = -(rtmp >> 1);
5607                         ltmp *= ltmp;
5608                       }
5609                   }
5610                 for (;;)
5611                   {
5612                     if (rtmp & 1)
5613                       result *= ltmp;
5614                     if ((rtmp >>= 1) == 0)
5615                       break;
5616                     ltmp *= ltmp;
5617                   }
5618               }
5619           }
5620         result;
5621      })
5622
5623      Note that some of the above is compile-time collapsable, such as
5624      the first part of the if statements that checks the base type of
5625      l against int.  The if statements are phrased that way to suggest
5626      an easy way to generate the if/else constructs here, knowing that
5627      the back end should (and probably does) eliminate the resulting
5628      dead code (either the int case or the non-int case), something
5629      it couldn't do without the redundant phrasing, requiring explicit
5630      dead-code elimination here, which would be kind of difficult to
5631      read.  */
5632
5633   {
5634     tree rtmp;
5635     tree ltmp;
5636     tree divide;
5637     tree basetypeof_l_is_int;
5638     tree se;
5639     tree t;
5640
5641     basetypeof_l_is_int
5642       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5643
5644     se = expand_start_stmt_expr ();
5645
5646     ffecom_start_compstmt ();
5647
5648 #ifndef HAHA
5649     rtmp = ffecom_make_tempvar ("power_r", rtype,
5650                                 FFETARGET_charactersizeNONE, -1);
5651     ltmp = ffecom_make_tempvar ("power_l", ltype,
5652                                 FFETARGET_charactersizeNONE, -1);
5653     result = ffecom_make_tempvar ("power_res", ltype,
5654                                   FFETARGET_charactersizeNONE, -1);
5655     if (TREE_CODE (ltype) == COMPLEX_TYPE
5656         || TREE_CODE (ltype) == RECORD_TYPE)
5657       divide = ffecom_make_tempvar ("power_div", ltype,
5658                                     FFETARGET_charactersizeNONE, -1);
5659     else
5660       divide = NULL_TREE;
5661 #else  /* HAHA */
5662     {
5663       tree hook;
5664
5665       hook = ffebld_nonter_hook (expr);
5666       assert (hook);
5667       assert (TREE_CODE (hook) == TREE_VEC);
5668       assert (TREE_VEC_LENGTH (hook) == 4);
5669       rtmp = TREE_VEC_ELT (hook, 0);
5670       ltmp = TREE_VEC_ELT (hook, 1);
5671       result = TREE_VEC_ELT (hook, 2);
5672       divide = TREE_VEC_ELT (hook, 3);
5673       if (TREE_CODE (ltype) == COMPLEX_TYPE
5674           || TREE_CODE (ltype) == RECORD_TYPE)
5675         assert (divide);
5676       else
5677         assert (! divide);
5678     }
5679 #endif  /* HAHA */
5680
5681     expand_expr_stmt (ffecom_modify (void_type_node,
5682                                      rtmp,
5683                                      r));
5684     expand_expr_stmt (ffecom_modify (void_type_node,
5685                                      ltmp,
5686                                      l));
5687     expand_start_cond (ffecom_truth_value
5688                        (ffecom_2 (EQ_EXPR, integer_type_node,
5689                                   rtmp,
5690                                   convert (rtype, integer_zero_node))),
5691                        0);
5692     expand_expr_stmt (ffecom_modify (void_type_node,
5693                                      result,
5694                                      convert (ltype, integer_one_node)));
5695     expand_start_else ();
5696     if (! integer_zerop (basetypeof_l_is_int))
5697       {
5698         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5699                                      rtmp,
5700                                      convert (rtype,
5701                                               integer_zero_node)),
5702                            0);
5703         expand_expr_stmt (ffecom_modify (void_type_node,
5704                                          result,
5705                                          ffecom_tree_divide_
5706                                          (ltype,
5707                                           convert (ltype, integer_one_node),
5708                                           ltmp,
5709                                           NULL_TREE, NULL, NULL,
5710                                           divide)));
5711         expand_start_cond (ffecom_truth_value
5712                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5713                                       ffecom_2 (LT_EXPR, integer_type_node,
5714                                                 ltmp,
5715                                                 convert (ltype,
5716                                                          integer_zero_node)),
5717                                       ffecom_2 (EQ_EXPR, integer_type_node,
5718                                                 ffecom_2 (BIT_AND_EXPR,
5719                                                           rtype,
5720                                                           ffecom_1 (NEGATE_EXPR,
5721                                                                     rtype,
5722                                                                     rtmp),
5723                                                           convert (rtype,
5724                                                                    integer_one_node)),
5725                                                 convert (rtype,
5726                                                          integer_zero_node)))),
5727                            0);
5728         expand_expr_stmt (ffecom_modify (void_type_node,
5729                                          result,
5730                                          ffecom_1 (NEGATE_EXPR,
5731                                                    ltype,
5732                                                    result)));
5733         expand_end_cond ();
5734         expand_start_else ();
5735       }
5736     expand_expr_stmt (ffecom_modify (void_type_node,
5737                                      result,
5738                                      convert (ltype, integer_one_node)));
5739     expand_start_cond (ffecom_truth_value
5740                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5741                                   ffecom_truth_value_invert
5742                                   (basetypeof_l_is_int),
5743                                   ffecom_2 (LT_EXPR, integer_type_node,
5744                                             rtmp,
5745                                             convert (rtype,
5746                                                      integer_zero_node)))),
5747                        0);
5748     expand_expr_stmt (ffecom_modify (void_type_node,
5749                                      ltmp,
5750                                      ffecom_tree_divide_
5751                                      (ltype,
5752                                       convert (ltype, integer_one_node),
5753                                       ltmp,
5754                                       NULL_TREE, NULL, NULL,
5755                                       divide)));
5756     expand_expr_stmt (ffecom_modify (void_type_node,
5757                                      rtmp,
5758                                      ffecom_1 (NEGATE_EXPR, rtype,
5759                                                rtmp)));
5760     expand_start_cond (ffecom_truth_value
5761                        (ffecom_2 (LT_EXPR, integer_type_node,
5762                                   rtmp,
5763                                   convert (rtype, integer_zero_node))),
5764                        0);
5765     expand_expr_stmt (ffecom_modify (void_type_node,
5766                                      rtmp,
5767                                      ffecom_1 (NEGATE_EXPR, rtype,
5768                                                ffecom_2 (RSHIFT_EXPR,
5769                                                          rtype,
5770                                                          rtmp,
5771                                                          integer_one_node))));
5772     expand_expr_stmt (ffecom_modify (void_type_node,
5773                                      ltmp,
5774                                      ffecom_2 (MULT_EXPR, ltype,
5775                                                ltmp,
5776                                                ltmp)));
5777     expand_end_cond ();
5778     expand_end_cond ();
5779     expand_start_loop (1);
5780     expand_start_cond (ffecom_truth_value
5781                        (ffecom_2 (BIT_AND_EXPR, rtype,
5782                                   rtmp,
5783                                   convert (rtype, integer_one_node))),
5784                        0);
5785     expand_expr_stmt (ffecom_modify (void_type_node,
5786                                      result,
5787                                      ffecom_2 (MULT_EXPR, ltype,
5788                                                result,
5789                                                ltmp)));
5790     expand_end_cond ();
5791     expand_exit_loop_if_false (NULL,
5792                                ffecom_truth_value
5793                                (ffecom_modify (rtype,
5794                                                rtmp,
5795                                                ffecom_2 (RSHIFT_EXPR,
5796                                                          rtype,
5797                                                          rtmp,
5798                                                          integer_one_node))));
5799     expand_expr_stmt (ffecom_modify (void_type_node,
5800                                      ltmp,
5801                                      ffecom_2 (MULT_EXPR, ltype,
5802                                                ltmp,
5803                                                ltmp)));
5804     expand_end_loop ();
5805     expand_end_cond ();
5806     if (!integer_zerop (basetypeof_l_is_int))
5807       expand_end_cond ();
5808     expand_expr_stmt (result);
5809
5810     t = ffecom_end_compstmt ();
5811
5812     result = expand_end_stmt_expr (se);
5813
5814     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5815
5816     if (TREE_CODE (t) == BLOCK)
5817       {
5818         /* Make a BIND_EXPR for the BLOCK already made.  */
5819         result = build (BIND_EXPR, TREE_TYPE (result),
5820                         NULL_TREE, result, t);
5821         /* Remove the block from the tree at this point.
5822            It gets put back at the proper place
5823            when the BIND_EXPR is expanded.  */
5824         delete_block (t);
5825       }
5826     else
5827       result = t;
5828   }
5829
5830   return result;
5831 }
5832
5833 #endif
5834 /* ffecom_expr_transform_ -- Transform symbols in expr
5835
5836    ffebld expr;  // FFE expression.
5837    ffecom_expr_transform_ (expr);
5838
5839    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5840
5841 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5842 static void
5843 ffecom_expr_transform_ (ffebld expr)
5844 {
5845   tree t;
5846   ffesymbol s;
5847
5848 tail_recurse:                   /* :::::::::::::::::::: */
5849
5850   if (expr == NULL)
5851     return;
5852
5853   switch (ffebld_op (expr))
5854     {
5855     case FFEBLD_opSYMTER:
5856       s = ffebld_symter (expr);
5857       t = ffesymbol_hook (s).decl_tree;
5858       if ((t == NULL_TREE)
5859           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5860               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5861                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5862         {
5863           s = ffecom_sym_transform_ (s);
5864           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5865                                                    DIMENSION expr? */
5866         }
5867       break;                    /* Ok if (t == NULL) here. */
5868
5869     case FFEBLD_opITEM:
5870       ffecom_expr_transform_ (ffebld_head (expr));
5871       expr = ffebld_trail (expr);
5872       goto tail_recurse;        /* :::::::::::::::::::: */
5873
5874     default:
5875       break;
5876     }
5877
5878   switch (ffebld_arity (expr))
5879     {
5880     case 2:
5881       ffecom_expr_transform_ (ffebld_left (expr));
5882       expr = ffebld_right (expr);
5883       goto tail_recurse;        /* :::::::::::::::::::: */
5884
5885     case 1:
5886       expr = ffebld_left (expr);
5887       goto tail_recurse;        /* :::::::::::::::::::: */
5888
5889     default:
5890       break;
5891     }
5892
5893   return;
5894 }
5895
5896 #endif
5897 /* Make a type based on info in live f2c.h file.  */
5898
5899 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5900 static void
5901 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5902 {
5903   switch (tcode)
5904     {
5905     case FFECOM_f2ccodeCHAR:
5906       *type = make_signed_type (CHAR_TYPE_SIZE);
5907       break;
5908
5909     case FFECOM_f2ccodeSHORT:
5910       *type = make_signed_type (SHORT_TYPE_SIZE);
5911       break;
5912
5913     case FFECOM_f2ccodeINT:
5914       *type = make_signed_type (INT_TYPE_SIZE);
5915       break;
5916
5917     case FFECOM_f2ccodeLONG:
5918       *type = make_signed_type (LONG_TYPE_SIZE);
5919       break;
5920
5921     case FFECOM_f2ccodeLONGLONG:
5922       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5923       break;
5924
5925     case FFECOM_f2ccodeCHARPTR:
5926       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5927                                   ? signed_char_type_node
5928                                   : unsigned_char_type_node);
5929       break;
5930
5931     case FFECOM_f2ccodeFLOAT:
5932       *type = make_node (REAL_TYPE);
5933       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5934       layout_type (*type);
5935       break;
5936
5937     case FFECOM_f2ccodeDOUBLE:
5938       *type = make_node (REAL_TYPE);
5939       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5940       layout_type (*type);
5941       break;
5942
5943     case FFECOM_f2ccodeLONGDOUBLE:
5944       *type = make_node (REAL_TYPE);
5945       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5946       layout_type (*type);
5947       break;
5948
5949     case FFECOM_f2ccodeTWOREALS:
5950       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5951       break;
5952
5953     case FFECOM_f2ccodeTWODOUBLEREALS:
5954       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5955       break;
5956
5957     default:
5958       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5959       *type = error_mark_node;
5960       return;
5961     }
5962
5963   pushdecl (build_decl (TYPE_DECL,
5964                         ffecom_get_invented_identifier ("__g77_f2c_%s",
5965                                                         name, -1),
5966                         *type));
5967 }
5968
5969 #endif
5970 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5971 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5972    given size.  */
5973
5974 static void
5975 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5976                           int code)
5977 {
5978   int j;
5979   tree t;
5980
5981   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5982     if (((t = ffecom_tree_type[bt][j]) != NULL_TREE)
5983         && (TREE_INT_CST_LOW (TYPE_SIZE (t)) == size))
5984       {
5985         assert (code != -1);
5986         ffecom_f2c_typecode_[bt][j] = code;
5987         code = -1;
5988       }
5989 }
5990
5991 #endif
5992 /* Finish up globals after doing all program units in file
5993
5994    Need to handle only uninitialized COMMON areas.  */
5995
5996 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5997 static ffeglobal
5998 ffecom_finish_global_ (ffeglobal global)
5999 {
6000   tree cbtype;
6001   tree cbt;
6002   tree size;
6003
6004   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
6005       return global;
6006
6007   if (ffeglobal_common_init (global))
6008       return global;
6009
6010   cbt = ffeglobal_hook (global);
6011   if ((cbt == NULL_TREE)
6012       || !ffeglobal_common_have_size (global))
6013     return global;              /* No need to make common, never ref'd. */
6014
6015   suspend_momentary ();
6016
6017   DECL_EXTERNAL (cbt) = 0;
6018
6019   /* Give the array a size now.  */
6020
6021   size = build_int_2 ((ffeglobal_common_size (global)
6022                       + ffeglobal_common_pad (global)) - 1,
6023                       0);
6024
6025   cbtype = TREE_TYPE (cbt);
6026   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6027                                            integer_zero_node,
6028                                            size);
6029   if (!TREE_TYPE (size))
6030     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6031   layout_type (cbtype);
6032
6033   cbt = start_decl (cbt, FALSE);
6034   assert (cbt == ffeglobal_hook (global));
6035
6036   finish_decl (cbt, NULL_TREE, FALSE);
6037
6038   return global;
6039 }
6040
6041 #endif
6042 /* Finish up any untransformed symbols.  */
6043
6044 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6045 static ffesymbol
6046 ffecom_finish_symbol_transform_ (ffesymbol s)
6047 {
6048   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6049     return s;
6050
6051   /* It's easy to know to transform an untransformed symbol, to make sure
6052      we put out debugging info for it.  But COMMON variables, unlike
6053      EQUIVALENCE ones, aren't given declarations in addition to the
6054      tree expressions that specify offsets, because COMMON variables
6055      can be referenced in the outer scope where only dummy arguments
6056      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6057      VAR_DECLs for COMMON variables when we transform them for real
6058      use, and therefore we do all the VAR_DECL creating here.  */
6059
6060   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6061     {
6062       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6063           || (ffesymbol_where (s) != FFEINFO_whereNONE
6064               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6065               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6066         /* Not transformed, and not CHARACTER*(*), and not a dummy
6067            argument, which can happen only if the entry point names
6068            it "rides in on" are all invalidated for other reasons.  */
6069         s = ffecom_sym_transform_ (s);
6070     }
6071
6072   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6073       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6074     {
6075 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
6076       int yes = suspend_momentary ();
6077
6078       /* This isn't working, at least for dbxout.  The .s file looks
6079          okay to me (burley), but in gdb 4.9 at least, the variables
6080          appear to reside somewhere outside of the common area, so
6081          it doesn't make sense to mislead anyone by generating the info
6082          on those variables until this is fixed.  NOTE: Same problem
6083          with EQUIVALENCE, sadly...see similar #if later.  */
6084       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6085                              ffesymbol_storage (s));
6086
6087       resume_momentary (yes);
6088 #endif
6089     }
6090
6091   return s;
6092 }
6093
6094 #endif
6095 /* Append underscore(s) to name before calling get_identifier.  "us"
6096    is nonzero if the name already contains an underscore and thus
6097    needs two underscores appended.  */
6098
6099 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6100 static tree
6101 ffecom_get_appended_identifier_ (char us, const char *name)
6102 {
6103   int i;
6104   char *newname;
6105   tree id;
6106
6107   newname = xmalloc ((i = strlen (name)) + 1
6108                      + ffe_is_underscoring ()
6109                      + us);
6110   memcpy (newname, name, i);
6111   newname[i] = '_';
6112   newname[i + us] = '_';
6113   newname[i + 1 + us] = '\0';
6114   id = get_identifier (newname);
6115
6116   free (newname);
6117
6118   return id;
6119 }
6120
6121 #endif
6122 /* Decide whether to append underscore to name before calling
6123    get_identifier.  */
6124
6125 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6126 static tree
6127 ffecom_get_external_identifier_ (ffesymbol s)
6128 {
6129   char us;
6130   const char *name = ffesymbol_text (s);
6131
6132   /* If name is a built-in name, just return it as is.  */
6133
6134   if (!ffe_is_underscoring ()
6135       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6136 #if FFETARGET_isENFORCED_MAIN_NAME
6137       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6138 #else
6139       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6140 #endif
6141       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6142     return get_identifier (name);
6143
6144   us = ffe_is_second_underscore ()
6145     ? (strchr (name, '_') != NULL)
6146       : 0;
6147
6148   return ffecom_get_appended_identifier_ (us, name);
6149 }
6150
6151 #endif
6152 /* Decide whether to append underscore to internal name before calling
6153    get_identifier.
6154
6155    This is for non-external, top-function-context names only.  Transform
6156    identifier so it doesn't conflict with the transformed result
6157    of using a _different_ external name.  E.g. if "CALL FOO" is
6158    transformed into "FOO_();", then the variable in "FOO_ = 3"
6159    must be transformed into something that does not conflict, since
6160    these two things should be independent.
6161
6162    The transformation is as follows.  If the name does not contain
6163    an underscore, there is no possible conflict, so just return.
6164    If the name does contain an underscore, then transform it just
6165    like we transform an external identifier.  */
6166
6167 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6168 static tree
6169 ffecom_get_identifier_ (const char *name)
6170 {
6171   /* If name does not contain an underscore, just return it as is.  */
6172
6173   if (!ffe_is_underscoring ()
6174       || (strchr (name, '_') == NULL))
6175     return get_identifier (name);
6176
6177   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6178                                           name);
6179 }
6180
6181 #endif
6182 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6183
6184    tree t;
6185    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6186    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6187          ffesymbol_kindtype(s));
6188
6189    Call after setting up containing function and getting trees for all
6190    other symbols.  */
6191
6192 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6193 static tree
6194 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6195 {
6196   ffebld expr = ffesymbol_sfexpr (s);
6197   tree type;
6198   tree func;
6199   tree result;
6200   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6201   static bool recurse = FALSE;
6202   int yes;
6203   int old_lineno = lineno;
6204   char *old_input_filename = input_filename;
6205
6206   ffecom_nested_entry_ = s;
6207
6208   /* For now, we don't have a handy pointer to where the sfunc is actually
6209      defined, though that should be easy to add to an ffesymbol. (The
6210      token/where info available might well point to the place where the type
6211      of the sfunc is declared, especially if that precedes the place where
6212      the sfunc itself is defined, which is typically the case.)  We should
6213      put out a null pointer rather than point somewhere wrong, but I want to
6214      see how it works at this point.  */
6215
6216   input_filename = ffesymbol_where_filename (s);
6217   lineno = ffesymbol_where_filelinenum (s);
6218
6219   /* Pretransform the expression so any newly discovered things belong to the
6220      outer program unit, not to the statement function. */
6221
6222   ffecom_expr_transform_ (expr);
6223
6224   /* Make sure no recursive invocation of this fn (a specific case of failing
6225      to pretransform an sfunc's expression, i.e. where its expression
6226      references another untransformed sfunc) happens. */
6227
6228   assert (!recurse);
6229   recurse = TRUE;
6230
6231   yes = suspend_momentary ();
6232
6233   push_f_function_context ();
6234
6235   if (charfunc)
6236     type = void_type_node;
6237   else
6238     {
6239       type = ffecom_tree_type[bt][kt];
6240       if (type == NULL_TREE)
6241         type = integer_type_node;       /* _sym_exec_transition reports
6242                                            error. */
6243     }
6244
6245   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6246                   build_function_type (type, NULL_TREE),
6247                   1,            /* nested/inline */
6248                   0);           /* TREE_PUBLIC */
6249
6250   /* We don't worry about COMPLEX return values here, because this is
6251      entirely internal to our code, and gcc has the ability to return COMPLEX
6252      directly as a value.  */
6253
6254   yes = suspend_momentary ();
6255
6256   if (charfunc)
6257     {                           /* Prepend arg for where result goes. */
6258       tree type;
6259
6260       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6261
6262       result = ffecom_get_invented_identifier ("__g77_%s",
6263                                                "result", -1);
6264
6265       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6266
6267       type = build_pointer_type (type);
6268       result = build_decl (PARM_DECL, result, type);
6269
6270       push_parm_decl (result);
6271     }
6272   else
6273     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6274
6275   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6276
6277   resume_momentary (yes);
6278
6279   store_parm_decls (0);
6280
6281   ffecom_start_compstmt ();
6282
6283   if (expr != NULL)
6284     {
6285       if (charfunc)
6286         {
6287           ffetargetCharacterSize sz = ffesymbol_size (s);
6288           tree result_length;
6289
6290           result_length = build_int_2 (sz, 0);
6291           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6292
6293           ffecom_prepare_let_char_ (sz, expr);
6294
6295           ffecom_prepare_end ();
6296
6297           ffecom_let_char_ (result, result_length, sz, expr);
6298           expand_null_return ();
6299         }
6300       else
6301         {
6302           ffecom_prepare_expr (expr);
6303
6304           ffecom_prepare_end ();
6305
6306           expand_return (ffecom_modify (NULL_TREE,
6307                                         DECL_RESULT (current_function_decl),
6308                                         ffecom_expr (expr)));
6309         }
6310
6311       clear_momentary ();
6312     }
6313
6314   ffecom_end_compstmt ();
6315
6316   func = current_function_decl;
6317   finish_function (1);
6318
6319   pop_f_function_context ();
6320
6321   resume_momentary (yes);
6322
6323   recurse = FALSE;
6324
6325   lineno = old_lineno;
6326   input_filename = old_input_filename;
6327
6328   ffecom_nested_entry_ = NULL;
6329
6330   return func;
6331 }
6332
6333 #endif
6334
6335 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6336 static const char *
6337 ffecom_gfrt_args_ (ffecomGfrt ix)
6338 {
6339   return ffecom_gfrt_argstring_[ix];
6340 }
6341
6342 #endif
6343 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6344 static tree
6345 ffecom_gfrt_tree_ (ffecomGfrt ix)
6346 {
6347   if (ffecom_gfrt_[ix] == NULL_TREE)
6348     ffecom_make_gfrt_ (ix);
6349
6350   return ffecom_1 (ADDR_EXPR,
6351                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6352                    ffecom_gfrt_[ix]);
6353 }
6354
6355 #endif
6356 /* Return initialize-to-zero expression for this VAR_DECL.  */
6357
6358 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6359 static tree
6360 ffecom_init_zero_ (tree decl)
6361 {
6362   tree init;
6363   int incremental = TREE_STATIC (decl);
6364   tree type = TREE_TYPE (decl);
6365
6366   if (incremental)
6367     {
6368       int momentary = suspend_momentary ();
6369       push_obstacks_nochange ();
6370       if (TREE_PERMANENT (decl))
6371         end_temporary_allocation ();
6372       make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
6373       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6374       pop_obstacks ();
6375       resume_momentary (momentary);
6376     }
6377
6378   push_momentary ();
6379
6380   if ((TREE_CODE (type) != ARRAY_TYPE)
6381       && (TREE_CODE (type) != RECORD_TYPE)
6382       && (TREE_CODE (type) != UNION_TYPE)
6383       && !incremental)
6384     init = convert (type, integer_zero_node);
6385   else if (!incremental)
6386     {
6387       int momentary = suspend_momentary ();
6388
6389       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6390       TREE_CONSTANT (init) = 1;
6391       TREE_STATIC (init) = 1;
6392
6393       resume_momentary (momentary);
6394     }
6395   else
6396     {
6397       int momentary = suspend_momentary ();
6398
6399       assemble_zeros (int_size_in_bytes (type));
6400       init = error_mark_node;
6401
6402       resume_momentary (momentary);
6403     }
6404
6405   pop_momentary_nofree ();
6406
6407   return init;
6408 }
6409
6410 #endif
6411 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6412 static tree
6413 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6414                          tree *maybe_tree)
6415 {
6416   tree expr_tree;
6417   tree length_tree;
6418
6419   switch (ffebld_op (arg))
6420     {
6421     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6422       if (ffetarget_length_character1
6423           (ffebld_constant_character1
6424            (ffebld_conter (arg))) == 0)
6425         {
6426           *maybe_tree = integer_zero_node;
6427           return convert (tree_type, integer_zero_node);
6428         }
6429
6430       *maybe_tree = integer_one_node;
6431       expr_tree = build_int_2 (*ffetarget_text_character1
6432                                (ffebld_constant_character1
6433                                 (ffebld_conter (arg))),
6434                                0);
6435       TREE_TYPE (expr_tree) = tree_type;
6436       return expr_tree;
6437
6438     case FFEBLD_opSYMTER:
6439     case FFEBLD_opARRAYREF:
6440     case FFEBLD_opFUNCREF:
6441     case FFEBLD_opSUBSTR:
6442       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6443
6444       if ((expr_tree == error_mark_node)
6445           || (length_tree == error_mark_node))
6446         {
6447           *maybe_tree = error_mark_node;
6448           return error_mark_node;
6449         }
6450
6451       if (integer_zerop (length_tree))
6452         {
6453           *maybe_tree = integer_zero_node;
6454           return convert (tree_type, integer_zero_node);
6455         }
6456
6457       expr_tree
6458         = ffecom_1 (INDIRECT_REF,
6459                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6460                     expr_tree);
6461       expr_tree
6462         = ffecom_2 (ARRAY_REF,
6463                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6464                     expr_tree,
6465                     integer_one_node);
6466       expr_tree = convert (tree_type, expr_tree);
6467
6468       if (TREE_CODE (length_tree) == INTEGER_CST)
6469         *maybe_tree = integer_one_node;
6470       else                      /* Must check length at run time.  */
6471         *maybe_tree
6472           = ffecom_truth_value
6473             (ffecom_2 (GT_EXPR, integer_type_node,
6474                        length_tree,
6475                        ffecom_f2c_ftnlen_zero_node));
6476       return expr_tree;
6477
6478     case FFEBLD_opPAREN:
6479     case FFEBLD_opCONVERT:
6480       if (ffeinfo_size (ffebld_info (arg)) == 0)
6481         {
6482           *maybe_tree = integer_zero_node;
6483           return convert (tree_type, integer_zero_node);
6484         }
6485       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6486                                       maybe_tree);
6487
6488     case FFEBLD_opCONCATENATE:
6489       {
6490         tree maybe_left;
6491         tree maybe_right;
6492         tree expr_left;
6493         tree expr_right;
6494
6495         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6496                                              &maybe_left);
6497         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6498                                               &maybe_right);
6499         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6500                                 maybe_left,
6501                                 maybe_right);
6502         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6503                               maybe_left,
6504                               expr_left,
6505                               expr_right);
6506         return expr_tree;
6507       }
6508
6509     default:
6510       assert ("bad op in ICHAR" == NULL);
6511       return error_mark_node;
6512     }
6513 }
6514
6515 #endif
6516 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6517
6518    tree length_arg;
6519    ffebld expr;
6520    length_arg = ffecom_intrinsic_len_ (expr);
6521
6522    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6523    subexpressions by constructing the appropriate tree for the
6524    length-of-character-text argument in a calling sequence.  */
6525
6526 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6527 static tree
6528 ffecom_intrinsic_len_ (ffebld expr)
6529 {
6530   ffetargetCharacter1 val;
6531   tree length;
6532
6533   switch (ffebld_op (expr))
6534     {
6535     case FFEBLD_opCONTER:
6536       val = ffebld_constant_character1 (ffebld_conter (expr));
6537       length = build_int_2 (ffetarget_length_character1 (val), 0);
6538       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6539       break;
6540
6541     case FFEBLD_opSYMTER:
6542       {
6543         ffesymbol s = ffebld_symter (expr);
6544         tree item;
6545
6546         item = ffesymbol_hook (s).decl_tree;
6547         if (item == NULL_TREE)
6548           {
6549             s = ffecom_sym_transform_ (s);
6550             item = ffesymbol_hook (s).decl_tree;
6551           }
6552         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6553           {
6554             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6555               length = ffesymbol_hook (s).length_tree;
6556             else
6557               {
6558                 length = build_int_2 (ffesymbol_size (s), 0);
6559                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6560               }
6561           }
6562         else if (item == error_mark_node)
6563           length = error_mark_node;
6564         else                    /* FFEINFO_kindFUNCTION: */
6565           length = NULL_TREE;
6566       }
6567       break;
6568
6569     case FFEBLD_opARRAYREF:
6570       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6571       break;
6572
6573     case FFEBLD_opSUBSTR:
6574       {
6575         ffebld start;
6576         ffebld end;
6577         ffebld thing = ffebld_right (expr);
6578         tree start_tree;
6579         tree end_tree;
6580
6581         assert (ffebld_op (thing) == FFEBLD_opITEM);
6582         start = ffebld_head (thing);
6583         thing = ffebld_trail (thing);
6584         assert (ffebld_trail (thing) == NULL);
6585         end = ffebld_head (thing);
6586
6587         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6588
6589         if (length == error_mark_node)
6590           break;
6591
6592         if (start == NULL)
6593           {
6594             if (end == NULL)
6595               ;
6596             else
6597               {
6598                 length = convert (ffecom_f2c_ftnlen_type_node,
6599                                   ffecom_expr (end));
6600               }
6601           }
6602         else
6603           {
6604             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6605                                   ffecom_expr (start));
6606
6607             if (start_tree == error_mark_node)
6608               {
6609                 length = error_mark_node;
6610                 break;
6611               }
6612
6613             if (end == NULL)
6614               {
6615                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6616                                    ffecom_f2c_ftnlen_one_node,
6617                                    ffecom_2 (MINUS_EXPR,
6618                                              ffecom_f2c_ftnlen_type_node,
6619                                              length,
6620                                              start_tree));
6621               }
6622             else
6623               {
6624                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6625                                     ffecom_expr (end));
6626
6627                 if (end_tree == error_mark_node)
6628                   {
6629                     length = error_mark_node;
6630                     break;
6631                   }
6632
6633                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6634                                    ffecom_f2c_ftnlen_one_node,
6635                                    ffecom_2 (MINUS_EXPR,
6636                                              ffecom_f2c_ftnlen_type_node,
6637                                              end_tree, start_tree));
6638               }
6639           }
6640       }
6641       break;
6642
6643     case FFEBLD_opCONCATENATE:
6644       length
6645         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6646                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6647                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6648       break;
6649
6650     case FFEBLD_opFUNCREF:
6651     case FFEBLD_opCONVERT:
6652       length = build_int_2 (ffebld_size (expr), 0);
6653       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6654       break;
6655
6656     default:
6657       assert ("bad op for single char arg expr" == NULL);
6658       length = ffecom_f2c_ftnlen_zero_node;
6659       break;
6660     }
6661
6662   assert (length != NULL_TREE);
6663
6664   return length;
6665 }
6666
6667 #endif
6668 /* Handle CHARACTER assignments.
6669
6670    Generates code to do the assignment.  Used by ordinary assignment
6671    statement handler ffecom_let_stmt and by statement-function
6672    handler to generate code for a statement function.  */
6673
6674 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6675 static void
6676 ffecom_let_char_ (tree dest_tree, tree dest_length,
6677                   ffetargetCharacterSize dest_size, ffebld source)
6678 {
6679   ffecomConcatList_ catlist;
6680   tree source_length;
6681   tree source_tree;
6682   tree expr_tree;
6683
6684   if ((dest_tree == error_mark_node)
6685       || (dest_length == error_mark_node))
6686     return;
6687
6688   assert (dest_tree != NULL_TREE);
6689   assert (dest_length != NULL_TREE);
6690
6691   /* Source might be an opCONVERT, which just means it is a different size
6692      than the destination.  Since the underlying implementation here handles
6693      that (directly or via the s_copy or s_cat run-time-library functions),
6694      we don't need the "convenience" of an opCONVERT that tells us to
6695      truncate or blank-pad, particularly since the resulting implementation
6696      would probably be slower than otherwise. */
6697
6698   while (ffebld_op (source) == FFEBLD_opCONVERT)
6699     source = ffebld_left (source);
6700
6701   catlist = ffecom_concat_list_new_ (source, dest_size);
6702   switch (ffecom_concat_list_count_ (catlist))
6703     {
6704     case 0:                     /* Shouldn't happen, but in case it does... */
6705       ffecom_concat_list_kill_ (catlist);
6706       source_tree = null_pointer_node;
6707       source_length = ffecom_f2c_ftnlen_zero_node;
6708       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6709       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6710       TREE_CHAIN (TREE_CHAIN (expr_tree))
6711         = build_tree_list (NULL_TREE, dest_length);
6712       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6713         = build_tree_list (NULL_TREE, source_length);
6714
6715       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6716       TREE_SIDE_EFFECTS (expr_tree) = 1;
6717
6718       expand_expr_stmt (expr_tree);
6719
6720       return;
6721
6722     case 1:                     /* The (fairly) easy case. */
6723       ffecom_char_args_ (&source_tree, &source_length,
6724                          ffecom_concat_list_expr_ (catlist, 0));
6725       ffecom_concat_list_kill_ (catlist);
6726       assert (source_tree != NULL_TREE);
6727       assert (source_length != NULL_TREE);
6728
6729       if ((source_tree == error_mark_node)
6730           || (source_length == error_mark_node))
6731         return;
6732
6733       if (dest_size == 1)
6734         {
6735           dest_tree
6736             = ffecom_1 (INDIRECT_REF,
6737                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6738                                                       (dest_tree))),
6739                         dest_tree);
6740           dest_tree
6741             = ffecom_2 (ARRAY_REF,
6742                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6743                                                       (dest_tree))),
6744                         dest_tree,
6745                         integer_one_node);
6746           source_tree
6747             = ffecom_1 (INDIRECT_REF,
6748                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6749                                                       (source_tree))),
6750                         source_tree);
6751           source_tree
6752             = ffecom_2 (ARRAY_REF,
6753                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6754                                                       (source_tree))),
6755                         source_tree,
6756                         integer_one_node);
6757
6758           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6759
6760           expand_expr_stmt (expr_tree);
6761
6762           return;
6763         }
6764
6765       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6766       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6767       TREE_CHAIN (TREE_CHAIN (expr_tree))
6768         = build_tree_list (NULL_TREE, dest_length);
6769       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6770         = build_tree_list (NULL_TREE, source_length);
6771
6772       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6773       TREE_SIDE_EFFECTS (expr_tree) = 1;
6774
6775       expand_expr_stmt (expr_tree);
6776
6777       return;
6778
6779     default:                    /* Must actually concatenate things. */
6780       break;
6781     }
6782
6783   /* Heavy-duty concatenation. */
6784
6785   {
6786     int count = ffecom_concat_list_count_ (catlist);
6787     int i;
6788     tree lengths;
6789     tree items;
6790     tree length_array;
6791     tree item_array;
6792     tree citem;
6793     tree clength;
6794
6795 #ifdef HOHO
6796     length_array
6797       = lengths
6798       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6799                              FFETARGET_charactersizeNONE, count, TRUE);
6800     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6801                                               FFETARGET_charactersizeNONE,
6802                                               count, TRUE);
6803 #else
6804     {
6805       tree hook;
6806
6807       hook = ffebld_nonter_hook (source);
6808       assert (hook);
6809       assert (TREE_CODE (hook) == TREE_VEC);
6810       assert (TREE_VEC_LENGTH (hook) == 2);
6811       length_array = lengths = TREE_VEC_ELT (hook, 0);
6812       item_array = items = TREE_VEC_ELT (hook, 1);
6813     }
6814 #endif
6815
6816     for (i = 0; i < count; ++i)
6817       {
6818         ffecom_char_args_ (&citem, &clength,
6819                            ffecom_concat_list_expr_ (catlist, i));
6820         if ((citem == error_mark_node)
6821             || (clength == error_mark_node))
6822           {
6823             ffecom_concat_list_kill_ (catlist);
6824             return;
6825           }
6826
6827         items
6828           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6829                       ffecom_modify (void_type_node,
6830                                      ffecom_2 (ARRAY_REF,
6831                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6832                                                item_array,
6833                                                build_int_2 (i, 0)),
6834                                      citem),
6835                       items);
6836         lengths
6837           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6838                       ffecom_modify (void_type_node,
6839                                      ffecom_2 (ARRAY_REF,
6840                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6841                                                length_array,
6842                                                build_int_2 (i, 0)),
6843                                      clength),
6844                       lengths);
6845       }
6846
6847     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6848     TREE_CHAIN (expr_tree)
6849       = build_tree_list (NULL_TREE,
6850                          ffecom_1 (ADDR_EXPR,
6851                                    build_pointer_type (TREE_TYPE (items)),
6852                                    items));
6853     TREE_CHAIN (TREE_CHAIN (expr_tree))
6854       = build_tree_list (NULL_TREE,
6855                          ffecom_1 (ADDR_EXPR,
6856                                    build_pointer_type (TREE_TYPE (lengths)),
6857                                    lengths));
6858     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6859       = build_tree_list
6860         (NULL_TREE,
6861          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6862                    convert (ffecom_f2c_ftnlen_type_node,
6863                             build_int_2 (count, 0))));
6864     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6865       = build_tree_list (NULL_TREE, dest_length);
6866
6867     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6868     TREE_SIDE_EFFECTS (expr_tree) = 1;
6869
6870     expand_expr_stmt (expr_tree);
6871   }
6872
6873   ffecom_concat_list_kill_ (catlist);
6874 }
6875
6876 #endif
6877 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6878
6879    ffecomGfrt ix;
6880    ffecom_make_gfrt_(ix);
6881
6882    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6883    for the indicated run-time routine (ix).  */
6884
6885 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6886 static void
6887 ffecom_make_gfrt_ (ffecomGfrt ix)
6888 {
6889   tree t;
6890   tree ttype;
6891
6892   push_obstacks_nochange ();
6893   end_temporary_allocation ();
6894
6895   switch (ffecom_gfrt_type_[ix])
6896     {
6897     case FFECOM_rttypeVOID_:
6898       ttype = void_type_node;
6899       break;
6900
6901     case FFECOM_rttypeVOIDSTAR_:
6902       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6903       break;
6904
6905     case FFECOM_rttypeFTNINT_:
6906       ttype = ffecom_f2c_ftnint_type_node;
6907       break;
6908
6909     case FFECOM_rttypeINTEGER_:
6910       ttype = ffecom_f2c_integer_type_node;
6911       break;
6912
6913     case FFECOM_rttypeLONGINT_:
6914       ttype = ffecom_f2c_longint_type_node;
6915       break;
6916
6917     case FFECOM_rttypeLOGICAL_:
6918       ttype = ffecom_f2c_logical_type_node;
6919       break;
6920
6921     case FFECOM_rttypeREAL_F2C_:
6922       ttype = double_type_node;
6923       break;
6924
6925     case FFECOM_rttypeREAL_GNU_:
6926       ttype = float_type_node;
6927       break;
6928
6929     case FFECOM_rttypeCOMPLEX_F2C_:
6930       ttype = void_type_node;
6931       break;
6932
6933     case FFECOM_rttypeCOMPLEX_GNU_:
6934       ttype = ffecom_f2c_complex_type_node;
6935       break;
6936
6937     case FFECOM_rttypeDOUBLE_:
6938       ttype = double_type_node;
6939       break;
6940
6941     case FFECOM_rttypeDOUBLEREAL_:
6942       ttype = ffecom_f2c_doublereal_type_node;
6943       break;
6944
6945     case FFECOM_rttypeDBLCMPLX_F2C_:
6946       ttype = void_type_node;
6947       break;
6948
6949     case FFECOM_rttypeDBLCMPLX_GNU_:
6950       ttype = ffecom_f2c_doublecomplex_type_node;
6951       break;
6952
6953     case FFECOM_rttypeCHARACTER_:
6954       ttype = void_type_node;
6955       break;
6956
6957     default:
6958       ttype = NULL;
6959       assert ("bad rttype" == NULL);
6960       break;
6961     }
6962
6963   ttype = build_function_type (ttype, NULL_TREE);
6964   t = build_decl (FUNCTION_DECL,
6965                   get_identifier (ffecom_gfrt_name_[ix]),
6966                   ttype);
6967   DECL_EXTERNAL (t) = 1;
6968   TREE_PUBLIC (t) = 1;
6969   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6970
6971   t = start_decl (t, TRUE);
6972
6973   finish_decl (t, NULL_TREE, TRUE);
6974
6975   resume_temporary_allocation ();
6976   pop_obstacks ();
6977
6978   ffecom_gfrt_[ix] = t;
6979 }
6980
6981 #endif
6982 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6983
6984 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6985 static void
6986 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6987 {
6988   ffesymbol s = ffestorag_symbol (st);
6989
6990   if (ffesymbol_namelisted (s))
6991     ffecom_member_namelisted_ = TRUE;
6992 }
6993
6994 #endif
6995 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
6996    the member so debugger will see it.  Otherwise nobody should be
6997    referencing the member.  */
6998
6999 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7000 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
7001 static void
7002 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7003 {
7004   ffesymbol s;
7005   tree t;
7006   tree mt;
7007   tree type;
7008
7009   if ((mst == NULL)
7010       || ((mt = ffestorag_hook (mst)) == NULL)
7011       || (mt == error_mark_node))
7012     return;
7013
7014   if ((st == NULL)
7015       || ((s = ffestorag_symbol (st)) == NULL))
7016     return;
7017
7018   type = ffecom_type_localvar_ (s,
7019                                 ffesymbol_basictype (s),
7020                                 ffesymbol_kindtype (s));
7021   if (type == error_mark_node)
7022     return;
7023
7024   t = build_decl (VAR_DECL,
7025                   ffecom_get_identifier_ (ffesymbol_text (s)),
7026                   type);
7027
7028   TREE_STATIC (t) = TREE_STATIC (mt);
7029   DECL_INITIAL (t) = NULL_TREE;
7030   TREE_ASM_WRITTEN (t) = 1;
7031
7032   DECL_RTL (t)
7033     = gen_rtx (MEM, TYPE_MODE (type),
7034                plus_constant (XEXP (DECL_RTL (mt), 0),
7035                               ffestorag_modulo (mst)
7036                               + ffestorag_offset (st)
7037                               - ffestorag_offset (mst)));
7038
7039   t = start_decl (t, FALSE);
7040
7041   finish_decl (t, NULL_TREE, FALSE);
7042 }
7043
7044 #endif
7045 #endif
7046 /* Prepare source expression for assignment into a destination perhaps known
7047    to be of a specific size.  */
7048
7049 static void
7050 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7051 {
7052   ffecomConcatList_ catlist;
7053   int count;
7054   int i;
7055   tree ltmp;
7056   tree itmp;
7057   tree tempvar = NULL_TREE;
7058
7059   while (ffebld_op (source) == FFEBLD_opCONVERT)
7060     source = ffebld_left (source);
7061
7062   catlist = ffecom_concat_list_new_ (source, dest_size);
7063   count = ffecom_concat_list_count_ (catlist);
7064
7065   if (count >= 2)
7066     {
7067       ltmp
7068         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7069                                FFETARGET_charactersizeNONE, count);
7070       itmp
7071         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7072                                FFETARGET_charactersizeNONE, count);
7073
7074       tempvar = make_tree_vec (2);
7075       TREE_VEC_ELT (tempvar, 0) = ltmp;
7076       TREE_VEC_ELT (tempvar, 1) = itmp;
7077     }
7078
7079   for (i = 0; i < count; ++i)
7080     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7081
7082   ffecom_concat_list_kill_ (catlist);
7083
7084   if (tempvar)
7085     {
7086       ffebld_nonter_set_hook (source, tempvar);
7087       current_binding_level->prep_state = 1;
7088     }
7089 }
7090
7091 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7092
7093    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7094    (which generates their trees) and then their trees get push_parm_decl'd.
7095
7096    The second arg is TRUE if the dummies are for a statement function, in
7097    which case lengths are not pushed for character arguments (since they are
7098    always known by both the caller and the callee, though the code allows
7099    for someday permitting CHAR*(*) stmtfunc dummies).  */
7100
7101 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7102 static void
7103 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7104 {
7105   ffebld dummy;
7106   ffebld dumlist;
7107   ffesymbol s;
7108   tree parm;
7109
7110   ffecom_transform_only_dummies_ = TRUE;
7111
7112   /* First push the parms corresponding to actual dummy "contents".  */
7113
7114   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7115     {
7116       dummy = ffebld_head (dumlist);
7117       switch (ffebld_op (dummy))
7118         {
7119         case FFEBLD_opSTAR:
7120         case FFEBLD_opANY:
7121           continue;             /* Forget alternate returns. */
7122
7123         default:
7124           break;
7125         }
7126       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7127       s = ffebld_symter (dummy);
7128       parm = ffesymbol_hook (s).decl_tree;
7129       if (parm == NULL_TREE)
7130         {
7131           s = ffecom_sym_transform_ (s);
7132           parm = ffesymbol_hook (s).decl_tree;
7133           assert (parm != NULL_TREE);
7134         }
7135       if (parm != error_mark_node)
7136         push_parm_decl (parm);
7137     }
7138
7139   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7140
7141   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7142     {
7143       dummy = ffebld_head (dumlist);
7144       switch (ffebld_op (dummy))
7145         {
7146         case FFEBLD_opSTAR:
7147         case FFEBLD_opANY:
7148           continue;             /* Forget alternate returns, they mean
7149                                    NOTHING! */
7150
7151         default:
7152           break;
7153         }
7154       s = ffebld_symter (dummy);
7155       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7156         continue;               /* Only looking for CHARACTER arguments. */
7157       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7158         continue;               /* Stmtfunc arg with known size needs no
7159                                    length param. */
7160       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7161         continue;               /* Only looking for variables and arrays. */
7162       parm = ffesymbol_hook (s).length_tree;
7163       assert (parm != NULL_TREE);
7164       if (parm != error_mark_node)
7165         push_parm_decl (parm);
7166     }
7167
7168   ffecom_transform_only_dummies_ = FALSE;
7169 }
7170
7171 #endif
7172 /* ffecom_start_progunit_ -- Beginning of program unit
7173
7174    Does GNU back end stuff necessary to teach it about the start of its
7175    equivalent of a Fortran program unit.  */
7176
7177 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7178 static void
7179 ffecom_start_progunit_ ()
7180 {
7181   ffesymbol fn = ffecom_primary_entry_;
7182   ffebld arglist;
7183   tree id;                      /* Identifier (name) of function. */
7184   tree type;                    /* Type of function. */
7185   tree result;                  /* Result of function. */
7186   ffeinfoBasictype bt;
7187   ffeinfoKindtype kt;
7188   ffeglobal g;
7189   ffeglobalType gt;
7190   ffeglobalType egt = FFEGLOBAL_type;
7191   bool charfunc;
7192   bool cmplxfunc;
7193   bool altentries = (ffecom_num_entrypoints_ != 0);
7194   bool multi
7195   = altentries
7196   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7197   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7198   bool main_program = FALSE;
7199   int old_lineno = lineno;
7200   char *old_input_filename = input_filename;
7201   int yes;
7202
7203   assert (fn != NULL);
7204   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7205
7206   input_filename = ffesymbol_where_filename (fn);
7207   lineno = ffesymbol_where_filelinenum (fn);
7208
7209   /* c-parse.y indeed does call suspend_momentary and not only ignores the
7210      return value, but also never calls resume_momentary, when starting an
7211      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
7212      same thing.  It shouldn't be a problem since start_function calls
7213      temporary_allocation, but it might be necessary.  If it causes a problem
7214      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
7215      comment appears twice in thist file.  */
7216
7217   suspend_momentary ();
7218
7219   switch (ffecom_primary_entry_kind_)
7220     {
7221     case FFEINFO_kindPROGRAM:
7222       main_program = TRUE;
7223       gt = FFEGLOBAL_typeMAIN;
7224       bt = FFEINFO_basictypeNONE;
7225       kt = FFEINFO_kindtypeNONE;
7226       type = ffecom_tree_fun_type_void;
7227       charfunc = FALSE;
7228       cmplxfunc = FALSE;
7229       break;
7230
7231     case FFEINFO_kindBLOCKDATA:
7232       gt = FFEGLOBAL_typeBDATA;
7233       bt = FFEINFO_basictypeNONE;
7234       kt = FFEINFO_kindtypeNONE;
7235       type = ffecom_tree_fun_type_void;
7236       charfunc = FALSE;
7237       cmplxfunc = FALSE;
7238       break;
7239
7240     case FFEINFO_kindFUNCTION:
7241       gt = FFEGLOBAL_typeFUNC;
7242       egt = FFEGLOBAL_typeEXT;
7243       bt = ffesymbol_basictype (fn);
7244       kt = ffesymbol_kindtype (fn);
7245       if (bt == FFEINFO_basictypeNONE)
7246         {
7247           ffeimplic_establish_symbol (fn);
7248           if (ffesymbol_funcresult (fn) != NULL)
7249             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7250           bt = ffesymbol_basictype (fn);
7251           kt = ffesymbol_kindtype (fn);
7252         }
7253
7254       if (multi)
7255         charfunc = cmplxfunc = FALSE;
7256       else if (bt == FFEINFO_basictypeCHARACTER)
7257         charfunc = TRUE, cmplxfunc = FALSE;
7258       else if ((bt == FFEINFO_basictypeCOMPLEX)
7259                && ffesymbol_is_f2c (fn)
7260                && !altentries)
7261         charfunc = FALSE, cmplxfunc = TRUE;
7262       else
7263         charfunc = cmplxfunc = FALSE;
7264
7265       if (multi || charfunc)
7266         type = ffecom_tree_fun_type_void;
7267       else if (ffesymbol_is_f2c (fn) && !altentries)
7268         type = ffecom_tree_fun_type[bt][kt];
7269       else
7270         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7271
7272       if ((type == NULL_TREE)
7273           || (TREE_TYPE (type) == NULL_TREE))
7274         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7275       break;
7276
7277     case FFEINFO_kindSUBROUTINE:
7278       gt = FFEGLOBAL_typeSUBR;
7279       egt = FFEGLOBAL_typeEXT;
7280       bt = FFEINFO_basictypeNONE;
7281       kt = FFEINFO_kindtypeNONE;
7282       if (ffecom_is_altreturning_)
7283         type = ffecom_tree_subr_type;
7284       else
7285         type = ffecom_tree_fun_type_void;
7286       charfunc = FALSE;
7287       cmplxfunc = FALSE;
7288       break;
7289
7290     default:
7291       assert ("say what??" == NULL);
7292       /* Fall through. */
7293     case FFEINFO_kindANY:
7294       gt = FFEGLOBAL_typeANY;
7295       bt = FFEINFO_basictypeNONE;
7296       kt = FFEINFO_kindtypeNONE;
7297       type = error_mark_node;
7298       charfunc = FALSE;
7299       cmplxfunc = FALSE;
7300       break;
7301     }
7302
7303   if (altentries)
7304     {
7305       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7306                                            ffesymbol_text (fn),
7307                                            -1);
7308     }
7309 #if FFETARGET_isENFORCED_MAIN
7310   else if (main_program)
7311     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7312 #endif
7313   else
7314     id = ffecom_get_external_identifier_ (fn);
7315
7316   start_function (id,
7317                   type,
7318                   0,            /* nested/inline */
7319                   !altentries); /* TREE_PUBLIC */
7320
7321   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7322
7323   if (!altentries
7324       && ((g = ffesymbol_global (fn)) != NULL)
7325       && ((ffeglobal_type (g) == gt)
7326           || (ffeglobal_type (g) == egt)))
7327     {
7328       ffeglobal_set_hook (g, current_function_decl);
7329     }
7330
7331   yes = suspend_momentary ();
7332
7333   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7334      exec-transitioning needs current_function_decl to be filled in.  So we
7335      do these things in two phases. */
7336
7337   if (altentries)
7338     {                           /* 1st arg identifies which entrypoint. */
7339       ffecom_which_entrypoint_decl_
7340         = build_decl (PARM_DECL,
7341                       ffecom_get_invented_identifier ("__g77_%s",
7342                                                       "which_entrypoint",
7343                                                       -1),
7344                       integer_type_node);
7345       push_parm_decl (ffecom_which_entrypoint_decl_);
7346     }
7347
7348   if (charfunc
7349       || cmplxfunc
7350       || multi)
7351     {                           /* Arg for result (return value). */
7352       tree type;
7353       tree length;
7354
7355       if (charfunc)
7356         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7357       else if (cmplxfunc)
7358         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7359       else
7360         type = ffecom_multi_type_node_;
7361
7362       result = ffecom_get_invented_identifier ("__g77_%s",
7363                                                "result", -1);
7364
7365       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7366
7367       if (charfunc)
7368         length = ffecom_char_enhance_arg_ (&type, fn);
7369       else
7370         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7371
7372       type = build_pointer_type (type);
7373       result = build_decl (PARM_DECL, result, type);
7374
7375       push_parm_decl (result);
7376       if (multi)
7377         ffecom_multi_retval_ = result;
7378       else
7379         ffecom_func_result_ = result;
7380
7381       if (charfunc)
7382         {
7383           push_parm_decl (length);
7384           ffecom_func_length_ = length;
7385         }
7386     }
7387
7388   if (ffecom_primary_entry_is_proc_)
7389     {
7390       if (altentries)
7391         arglist = ffecom_master_arglist_;
7392       else
7393         arglist = ffesymbol_dummyargs (fn);
7394       ffecom_push_dummy_decls_ (arglist, FALSE);
7395     }
7396
7397   resume_momentary (yes);
7398
7399   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7400     store_parm_decls (main_program ? 1 : 0);
7401
7402   ffecom_start_compstmt ();
7403   /* Disallow temp vars at this level.  */
7404   current_binding_level->prep_state = 2;
7405
7406   lineno = old_lineno;
7407   input_filename = old_input_filename;
7408
7409   /* This handles any symbols still untransformed, in case -g specified.
7410      This used to be done in ffecom_finish_progunit, but it turns out to
7411      be necessary to do it here so that statement functions are
7412      expanded before code.  But don't bother for BLOCK DATA.  */
7413
7414   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7415     ffesymbol_drive (ffecom_finish_symbol_transform_);
7416 }
7417
7418 #endif
7419 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7420
7421    ffesymbol s;
7422    ffecom_sym_transform_(s);
7423
7424    The ffesymbol_hook info for s is updated with appropriate backend info
7425    on the symbol.  */
7426
7427 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7428 static ffesymbol
7429 ffecom_sym_transform_ (ffesymbol s)
7430 {
7431   tree t;                       /* Transformed thingy. */
7432   tree tlen;                    /* Length if CHAR*(*). */
7433   bool addr;                    /* Is t the address of the thingy? */
7434   ffeinfoBasictype bt;
7435   ffeinfoKindtype kt;
7436   ffeglobal g;
7437   int yes;
7438   int old_lineno = lineno;
7439   char *old_input_filename = input_filename;
7440
7441   /* Must ensure special ASSIGN variables are declared at top of outermost
7442      block, else they'll end up in the innermost block when their first
7443      ASSIGN is seen, which leaves them out of scope when they're the
7444      subject of a GOTO or I/O statement.
7445
7446      We make this variable even if -fugly-assign.  Just let it go unused,
7447      in case it turns out there are cases where we really want to use this
7448      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7449
7450   if (! ffecom_transform_only_dummies_
7451       && ffesymbol_assigned (s)
7452       && ! ffesymbol_hook (s).assign_tree)
7453     s = ffecom_sym_transform_assign_ (s);
7454
7455   if (ffesymbol_sfdummyparent (s) == NULL)
7456     {
7457       input_filename = ffesymbol_where_filename (s);
7458       lineno = ffesymbol_where_filelinenum (s);
7459     }
7460   else
7461     {
7462       ffesymbol sf = ffesymbol_sfdummyparent (s);
7463
7464       input_filename = ffesymbol_where_filename (sf);
7465       lineno = ffesymbol_where_filelinenum (sf);
7466     }
7467
7468   bt = ffeinfo_basictype (ffebld_info (s));
7469   kt = ffeinfo_kindtype (ffebld_info (s));
7470
7471   t = NULL_TREE;
7472   tlen = NULL_TREE;
7473   addr = FALSE;
7474
7475   switch (ffesymbol_kind (s))
7476     {
7477     case FFEINFO_kindNONE:
7478       switch (ffesymbol_where (s))
7479         {
7480         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7481           assert (ffecom_transform_only_dummies_);
7482
7483           /* Before 0.4, this could be ENTITY/DUMMY, but see
7484              ffestu_sym_end_transition -- no longer true (in particular, if
7485              it could be an ENTITY, it _will_ be made one, so that
7486              possibility won't come through here).  So we never make length
7487              arg for CHARACTER type.  */
7488
7489           t = build_decl (PARM_DECL,
7490                           ffecom_get_identifier_ (ffesymbol_text (s)),
7491                           ffecom_tree_ptr_to_subr_type);
7492 #if BUILT_FOR_270
7493           DECL_ARTIFICIAL (t) = 1;
7494 #endif
7495           addr = TRUE;
7496           break;
7497
7498         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7499           assert (!ffecom_transform_only_dummies_);
7500
7501           if (((g = ffesymbol_global (s)) != NULL)
7502               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7503                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7504                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7505               && (ffeglobal_hook (g) != NULL_TREE)
7506               && ffe_is_globals ())
7507             {
7508               t = ffeglobal_hook (g);
7509               break;
7510             }
7511
7512           push_obstacks_nochange ();
7513           end_temporary_allocation ();
7514
7515           t = build_decl (FUNCTION_DECL,
7516                           ffecom_get_external_identifier_ (s),
7517                           ffecom_tree_subr_type);       /* Assume subr. */
7518           DECL_EXTERNAL (t) = 1;
7519           TREE_PUBLIC (t) = 1;
7520
7521           t = start_decl (t, FALSE);
7522           finish_decl (t, NULL_TREE, FALSE);
7523
7524           if ((g != NULL)
7525               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7526                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7527                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7528             ffeglobal_set_hook (g, t);
7529
7530           resume_temporary_allocation ();
7531           pop_obstacks ();
7532
7533           break;
7534
7535         default:
7536           assert ("NONE where unexpected" == NULL);
7537           /* Fall through. */
7538         case FFEINFO_whereANY:
7539           break;
7540         }
7541       break;
7542
7543     case FFEINFO_kindENTITY:
7544       switch (ffeinfo_where (ffesymbol_info (s)))
7545         {
7546
7547         case FFEINFO_whereCONSTANT:
7548           /* ~~Debugging info needed? */
7549           assert (!ffecom_transform_only_dummies_);
7550           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7551           break;
7552
7553         case FFEINFO_whereLOCAL:
7554           assert (!ffecom_transform_only_dummies_);
7555
7556           {
7557             ffestorag st = ffesymbol_storage (s);
7558             tree type;
7559
7560             if ((st != NULL)
7561                 && (ffestorag_size (st) == 0))
7562               {
7563                 t = error_mark_node;
7564                 break;
7565               }
7566
7567             yes = suspend_momentary ();
7568             type = ffecom_type_localvar_ (s, bt, kt);
7569             resume_momentary (yes);
7570
7571             if (type == error_mark_node)
7572               {
7573                 t = error_mark_node;
7574                 break;
7575               }
7576
7577             if ((st != NULL)
7578                 && (ffestorag_parent (st) != NULL))
7579               {                 /* Child of EQUIVALENCE parent. */
7580                 ffestorag est;
7581                 tree et;
7582                 int yes;
7583                 ffetargetOffset offset;
7584
7585                 est = ffestorag_parent (st);
7586                 ffecom_transform_equiv_ (est);
7587
7588                 et = ffestorag_hook (est);
7589                 assert (et != NULL_TREE);
7590
7591                 if (! TREE_STATIC (et))
7592                   put_var_into_stack (et);
7593
7594                 yes = suspend_momentary ();
7595
7596                 offset = ffestorag_modulo (est)
7597                   + ffestorag_offset (ffesymbol_storage (s))
7598                   - ffestorag_offset (est);
7599
7600                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7601
7602                 /* (t_type *) (((char *) &et) + offset) */
7603
7604                 t = convert (string_type_node,  /* (char *) */
7605                              ffecom_1 (ADDR_EXPR,
7606                                        build_pointer_type (TREE_TYPE (et)),
7607                                        et));
7608                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7609                               t,
7610                               build_int_2 (offset, 0));
7611                 t = convert (build_pointer_type (type),
7612                              t);
7613                 TREE_CONSTANT (t) = staticp (et);
7614
7615                 addr = TRUE;
7616
7617                 resume_momentary (yes);
7618               }
7619             else
7620               {
7621                 tree initexpr;
7622                 bool init = ffesymbol_is_init (s);
7623
7624                 yes = suspend_momentary ();
7625
7626                 t = build_decl (VAR_DECL,
7627                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7628                                 type);
7629
7630                 if (init
7631                     || ffesymbol_namelisted (s)
7632 #ifdef FFECOM_sizeMAXSTACKITEM
7633                     || ((st != NULL)
7634                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7635 #endif
7636                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7637                         && (ffecom_primary_entry_kind_
7638                             != FFEINFO_kindBLOCKDATA)
7639                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7640                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7641                 else
7642                   TREE_STATIC (t) = 0;  /* No need to make static. */
7643
7644                 if (init || ffe_is_init_local_zero ())
7645                   DECL_INITIAL (t) = error_mark_node;
7646
7647                 /* Keep -Wunused from complaining about var if it
7648                    is used as sfunc arg or DATA implied-DO.  */
7649                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7650                   DECL_IN_SYSTEM_HEADER (t) = 1;
7651
7652                 t = start_decl (t, FALSE);
7653
7654                 if (init)
7655                   {
7656                     if (ffesymbol_init (s) != NULL)
7657                       initexpr = ffecom_expr (ffesymbol_init (s));
7658                     else
7659                       initexpr = ffecom_init_zero_ (t);
7660                   }
7661                 else if (ffe_is_init_local_zero ())
7662                   initexpr = ffecom_init_zero_ (t);
7663                 else
7664                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7665
7666                 finish_decl (t, initexpr, FALSE);
7667
7668                 if ((st != NULL) && (DECL_SIZE (t) != error_mark_node))
7669                   {
7670                     tree size_tree;
7671
7672                     size_tree = size_binop (CEIL_DIV_EXPR,
7673                                             DECL_SIZE (t),
7674                                             size_int (BITS_PER_UNIT));
7675                     assert (TREE_INT_CST_HIGH (size_tree) == 0);
7676                     assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (st));
7677                   }
7678
7679                 resume_momentary (yes);
7680               }
7681           }
7682           break;
7683
7684         case FFEINFO_whereRESULT:
7685           assert (!ffecom_transform_only_dummies_);
7686
7687           if (bt == FFEINFO_basictypeCHARACTER)
7688             {                   /* Result is already in list of dummies, use
7689                                    it (& length). */
7690               t = ffecom_func_result_;
7691               tlen = ffecom_func_length_;
7692               addr = TRUE;
7693               break;
7694             }
7695           if ((ffecom_num_entrypoints_ == 0)
7696               && (bt == FFEINFO_basictypeCOMPLEX)
7697               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7698             {                   /* Result is already in list of dummies, use
7699                                    it. */
7700               t = ffecom_func_result_;
7701               addr = TRUE;
7702               break;
7703             }
7704           if (ffecom_func_result_ != NULL_TREE)
7705             {
7706               t = ffecom_func_result_;
7707               break;
7708             }
7709           if ((ffecom_num_entrypoints_ != 0)
7710               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7711             {
7712               yes = suspend_momentary ();
7713
7714               assert (ffecom_multi_retval_ != NULL_TREE);
7715               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7716                             ffecom_multi_retval_);
7717               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7718                             t, ffecom_multi_fields_[bt][kt]);
7719
7720               resume_momentary (yes);
7721               break;
7722             }
7723
7724           yes = suspend_momentary ();
7725
7726           t = build_decl (VAR_DECL,
7727                           ffecom_get_identifier_ (ffesymbol_text (s)),
7728                           ffecom_tree_type[bt][kt]);
7729           TREE_STATIC (t) = 0;  /* Put result on stack. */
7730           t = start_decl (t, FALSE);
7731           finish_decl (t, NULL_TREE, FALSE);
7732
7733           ffecom_func_result_ = t;
7734
7735           resume_momentary (yes);
7736           break;
7737
7738         case FFEINFO_whereDUMMY:
7739           {
7740             tree type;
7741             ffebld dl;
7742             ffebld dim;
7743             tree low;
7744             tree high;
7745             tree old_sizes;
7746             bool adjustable = FALSE;    /* Conditionally adjustable? */
7747
7748             type = ffecom_tree_type[bt][kt];
7749             if (ffesymbol_sfdummyparent (s) != NULL)
7750               {
7751                 if (current_function_decl == ffecom_outer_function_decl_)
7752                   {                     /* Exec transition before sfunc
7753                                            context; get it later. */
7754                     break;
7755                   }
7756                 t = ffecom_get_identifier_ (ffesymbol_text
7757                                             (ffesymbol_sfdummyparent (s)));
7758               }
7759             else
7760               t = ffecom_get_identifier_ (ffesymbol_text (s));
7761
7762             assert (ffecom_transform_only_dummies_);
7763
7764             old_sizes = get_pending_sizes ();
7765             put_pending_sizes (old_sizes);
7766
7767             if (bt == FFEINFO_basictypeCHARACTER)
7768               tlen = ffecom_char_enhance_arg_ (&type, s);
7769             type = ffecom_check_size_overflow_ (s, type, TRUE);
7770
7771             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7772               {
7773                 if (type == error_mark_node)
7774                   break;
7775
7776                 dim = ffebld_head (dl);
7777                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7778                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7779                   low = ffecom_integer_one_node;
7780                 else
7781                   low = ffecom_expr (ffebld_left (dim));
7782                 assert (ffebld_right (dim) != NULL);
7783                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7784                     || ffecom_doing_entry_)
7785                   {
7786                     /* Used to just do high=low.  But for ffecom_tree_
7787                        canonize_ref_, it probably is important to correctly
7788                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7789                        C(2)=CFUNC(C), overlap can happen, while it can't
7790                        for, say, C(1)=CFUNC(C(2)).  */
7791                     /* Even more recently used to set to INT_MAX, but that
7792                        broke when some overflow checking went into the back
7793                        end.  Now we just leave the upper bound unspecified.  */
7794                     high = NULL;
7795                   }
7796                 else
7797                   high = ffecom_expr (ffebld_right (dim));
7798
7799                 /* Determine whether array is conditionally adjustable,
7800                    to decide whether back-end magic is needed.
7801
7802                    Normally the front end uses the back-end function
7803                    variable_size to wrap SAVE_EXPR's around expressions
7804                    affecting the size/shape of an array so that the
7805                    size/shape info doesn't change during execution
7806                    of the compiled code even though variables and
7807                    functions referenced in those expressions might.
7808
7809                    variable_size also makes sure those saved expressions
7810                    get evaluated immediately upon entry to the
7811                    compiled procedure -- the front end normally doesn't
7812                    have to worry about that.
7813
7814                    However, there is a problem with this that affects
7815                    g77's implementation of entry points, and that is
7816                    that it is _not_ true that each invocation of the
7817                    compiled procedure is permitted to evaluate
7818                    array size/shape info -- because it is possible
7819                    that, for some invocations, that info is invalid (in
7820                    which case it is "promised" -- i.e. a violation of
7821                    the Fortran standard -- that the compiled code
7822                    won't reference the array or its size/shape
7823                    during that particular invocation).
7824
7825                    To phrase this in C terms, consider this gcc function:
7826
7827                      void foo (int *n, float (*a)[*n])
7828                      {
7829                        // a is "pointer to array ...", fyi.
7830                      }
7831
7832                    Suppose that, for some invocations, it is permitted
7833                    for a caller of foo to do this:
7834
7835                        foo (NULL, NULL);
7836
7837                    Now the _written_ code for foo can take such a call
7838                    into account by either testing explicitly for whether
7839                    (a == NULL) || (n == NULL) -- presumably it is
7840                    not permitted to reference *a in various fashions
7841                    if (n == NULL) I suppose -- or it can avoid it by
7842                    looking at other info (other arguments, static/global
7843                    data, etc.).
7844
7845                    However, this won't work in gcc 2.5.8 because it'll
7846                    automatically emit the code to save the "*n"
7847                    expression, which'll yield a NULL dereference for
7848                    the "foo (NULL, NULL)" call, something the code
7849                    for foo cannot prevent.
7850
7851                    g77 definitely needs to avoid executing such
7852                    code anytime the pointer to the adjustable array
7853                    is NULL, because even if its bounds expressions
7854                    don't have any references to possible "absent"
7855                    variables like "*n" -- say all variable references
7856                    are to COMMON variables, i.e. global (though in C,
7857                    local static could actually make sense) -- the
7858                    expressions could yield other run-time problems
7859                    for allowably "dead" values in those variables.
7860
7861                    For example, let's consider a more complicated
7862                    version of foo:
7863
7864                      extern int i;
7865                      extern int j;
7866
7867                      void foo (float (*a)[i/j])
7868                      {
7869                        ...
7870                      }
7871
7872                    The above is (essentially) quite valid for Fortran
7873                    but, again, for a call like "foo (NULL);", it is
7874                    permitted for i and j to be undefined when the
7875                    call is made.  If j happened to be zero, for
7876                    example, emitting the code to evaluate "i/j"
7877                    could result in a run-time error.
7878
7879                    Offhand, though I don't have my F77 or F90
7880                    standards handy, it might even be valid for a
7881                    bounds expression to contain a function reference,
7882                    in which case I doubt it is permitted for an
7883                    implementation to invoke that function in the
7884                    Fortran case involved here (invocation of an
7885                    alternate ENTRY point that doesn't have the adjustable
7886                    array as one of its arguments).
7887
7888                    So, the code that the compiler would normally emit
7889                    to preevaluate the size/shape info for an
7890                    adjustable array _must not_ be executed at run time
7891                    in certain cases.  Specifically, for Fortran,
7892                    the case is when the pointer to the adjustable
7893                    array == NULL.  (For gnu-ish C, it might be nice
7894                    for the source code itself to specify an expression
7895                    that, if TRUE, inhibits execution of the code.  Or
7896                    reverse the sense for elegance.)
7897
7898                    (Note that g77 could use a different test than NULL,
7899                    actually, since it happens to always pass an
7900                    integer to the called function that specifies which
7901                    entry point is being invoked.  Hmm, this might
7902                    solve the next problem.)
7903
7904                    One way a user could, I suppose, write "foo" so
7905                    it works is to insert COND_EXPR's for the
7906                    size/shape info so the dangerous stuff isn't
7907                    actually done, as in:
7908
7909                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7910                      {
7911                        ...
7912                      }
7913
7914                    The next problem is that the front end needs to
7915                    be able to tell the back end about the array's
7916                    decl _before_ it tells it about the conditional
7917                    expression to inhibit evaluation of size/shape info,
7918                    as shown above.
7919
7920                    To solve this, the front end needs to be able
7921                    to give the back end the expression to inhibit
7922                    generation of the preevaluation code _after_
7923                    it makes the decl for the adjustable array.
7924
7925                    Until then, the above example using the COND_EXPR
7926                    doesn't pass muster with gcc because the "(a == NULL)"
7927                    part has a reference to "a", which is still
7928                    undefined at that point.
7929
7930                    g77 will therefore use a different mechanism in the
7931                    meantime.  */
7932
7933                 if (!adjustable
7934                     && ((TREE_CODE (low) != INTEGER_CST)
7935                         || (high && TREE_CODE (high) != INTEGER_CST)))
7936                   adjustable = TRUE;
7937
7938 #if 0                           /* Old approach -- see below. */
7939                 if (TREE_CODE (low) != INTEGER_CST)
7940                   low = ffecom_3 (COND_EXPR, integer_type_node,
7941                                   ffecom_adjarray_passed_ (s),
7942                                   low,
7943                                   ffecom_integer_zero_node);
7944
7945                 if (high && TREE_CODE (high) != INTEGER_CST)
7946                   high = ffecom_3 (COND_EXPR, integer_type_node,
7947                                    ffecom_adjarray_passed_ (s),
7948                                    high,
7949                                    ffecom_integer_zero_node);
7950 #endif
7951
7952                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7953                    probably.  Fixes 950302-1.f.  */
7954
7955                 if (TREE_CODE (low) != INTEGER_CST)
7956                   low = variable_size (low);
7957
7958                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7959                    does this, which is why dumb0.c would work.  */
7960
7961                 if (high && TREE_CODE (high) != INTEGER_CST)
7962                   high = variable_size (high);
7963
7964                 type
7965                   = build_array_type
7966                     (type,
7967                      build_range_type (ffecom_integer_type_node,
7968                                        low, high));
7969                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7970               }
7971
7972             if (type == error_mark_node)
7973               {
7974                 t = error_mark_node;
7975                 break;
7976               }
7977
7978             if ((ffesymbol_sfdummyparent (s) == NULL)
7979                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7980               {
7981                 type = build_pointer_type (type);
7982                 addr = TRUE;
7983               }
7984
7985             t = build_decl (PARM_DECL, t, type);
7986 #if BUILT_FOR_270
7987             DECL_ARTIFICIAL (t) = 1;
7988 #endif
7989
7990             /* If this arg is present in every entry point's list of
7991                dummy args, then we're done.  */
7992
7993             if (ffesymbol_numentries (s)
7994                 == (ffecom_num_entrypoints_ + 1))
7995               break;
7996
7997 #if 1
7998
7999             /* If variable_size in stor-layout has been called during
8000                the above, then get_pending_sizes should have the
8001                yet-to-be-evaluated saved expressions pending.
8002                Make the whole lot of them get emitted, conditionally
8003                on whether the array decl ("t" above) is not NULL.  */
8004
8005             {
8006               tree sizes = get_pending_sizes ();
8007               tree tem;
8008
8009               for (tem = sizes;
8010                    tem != old_sizes;
8011                    tem = TREE_CHAIN (tem))
8012                 {
8013                   tree temv = TREE_VALUE (tem);
8014
8015                   if (sizes == tem)
8016                     sizes = temv;
8017                   else
8018                     sizes
8019                       = ffecom_2 (COMPOUND_EXPR,
8020                                   TREE_TYPE (sizes),
8021                                   temv,
8022                                   sizes);
8023                 }
8024
8025               if (sizes != tem)
8026                 {
8027                   sizes
8028                     = ffecom_3 (COND_EXPR,
8029                                 TREE_TYPE (sizes),
8030                                 ffecom_2 (NE_EXPR,
8031                                           integer_type_node,
8032                                           t,
8033                                           null_pointer_node),
8034                                 sizes,
8035                                 convert (TREE_TYPE (sizes),
8036                                          integer_zero_node));
8037                   sizes = ffecom_save_tree (sizes);
8038
8039                   sizes
8040                     = tree_cons (NULL_TREE, sizes, tem);
8041                 }
8042
8043               if (sizes)
8044                 put_pending_sizes (sizes);
8045             }
8046
8047 #else
8048 #if 0
8049             if (adjustable
8050                 && (ffesymbol_numentries (s)
8051                     != ffecom_num_entrypoints_ + 1))
8052               DECL_SOMETHING (t)
8053                 = ffecom_2 (NE_EXPR, integer_type_node,
8054                             t,
8055                             null_pointer_node);
8056 #else
8057 #if 0
8058             if (adjustable
8059                 && (ffesymbol_numentries (s)
8060                     != ffecom_num_entrypoints_ + 1))
8061               {
8062                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8063                 ffebad_here (0, ffesymbol_where_line (s),
8064                              ffesymbol_where_column (s));
8065                 ffebad_string (ffesymbol_text (s));
8066                 ffebad_finish ();
8067               }
8068 #endif
8069 #endif
8070 #endif
8071           }
8072           break;
8073
8074         case FFEINFO_whereCOMMON:
8075           {
8076             ffesymbol cs;
8077             ffeglobal cg;
8078             tree ct;
8079             ffestorag st = ffesymbol_storage (s);
8080             tree type;
8081             int yes;
8082
8083             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
8084             if (st != NULL)     /* Else not laid out. */
8085               {
8086                 ffecom_transform_common_ (cs);
8087                 st = ffesymbol_storage (s);
8088               }
8089
8090             yes = suspend_momentary ();
8091
8092             type = ffecom_type_localvar_ (s, bt, kt);
8093
8094             cg = ffesymbol_global (cs); /* The global COMMON info.  */
8095             if ((cg == NULL)
8096                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8097               ct = NULL_TREE;
8098             else
8099               ct = ffeglobal_hook (cg); /* The common area's tree.  */
8100
8101             if ((ct == NULL_TREE)
8102                 || (st == NULL)
8103                 || (type == error_mark_node))
8104               t = error_mark_node;
8105             else
8106               {
8107                 ffetargetOffset offset;
8108                 ffestorag cst;
8109
8110                 cst = ffestorag_parent (st);
8111                 assert (cst == ffesymbol_storage (cs));
8112
8113                 offset = ffestorag_modulo (cst)
8114                   + ffestorag_offset (st)
8115                   - ffestorag_offset (cst);
8116
8117                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8118
8119                 /* (t_type *) (((char *) &ct) + offset) */
8120
8121                 t = convert (string_type_node,  /* (char *) */
8122                              ffecom_1 (ADDR_EXPR,
8123                                        build_pointer_type (TREE_TYPE (ct)),
8124                                        ct));
8125                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8126                               t,
8127                               build_int_2 (offset, 0));
8128                 t = convert (build_pointer_type (type),
8129                              t);
8130                 TREE_CONSTANT (t) = 1;
8131
8132                 addr = TRUE;
8133               }
8134
8135             resume_momentary (yes);
8136           }
8137           break;
8138
8139         case FFEINFO_whereIMMEDIATE:
8140         case FFEINFO_whereGLOBAL:
8141         case FFEINFO_whereFLEETING:
8142         case FFEINFO_whereFLEETING_CADDR:
8143         case FFEINFO_whereFLEETING_IADDR:
8144         case FFEINFO_whereINTRINSIC:
8145         case FFEINFO_whereCONSTANT_SUBOBJECT:
8146         default:
8147           assert ("ENTITY where unheard of" == NULL);
8148           /* Fall through. */
8149         case FFEINFO_whereANY:
8150           t = error_mark_node;
8151           break;
8152         }
8153       break;
8154
8155     case FFEINFO_kindFUNCTION:
8156       switch (ffeinfo_where (ffesymbol_info (s)))
8157         {
8158         case FFEINFO_whereLOCAL:        /* Me. */
8159           assert (!ffecom_transform_only_dummies_);
8160           t = current_function_decl;
8161           break;
8162
8163         case FFEINFO_whereGLOBAL:
8164           assert (!ffecom_transform_only_dummies_);
8165
8166           if (((g = ffesymbol_global (s)) != NULL)
8167               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8168                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8169               && (ffeglobal_hook (g) != NULL_TREE)
8170               && ffe_is_globals ())
8171             {
8172               t = ffeglobal_hook (g);
8173               break;
8174             }
8175
8176           push_obstacks_nochange ();
8177           end_temporary_allocation ();
8178
8179           if (ffesymbol_is_f2c (s)
8180               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8181             t = ffecom_tree_fun_type[bt][kt];
8182           else
8183             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8184
8185           t = build_decl (FUNCTION_DECL,
8186                           ffecom_get_external_identifier_ (s),
8187                           t);
8188           DECL_EXTERNAL (t) = 1;
8189           TREE_PUBLIC (t) = 1;
8190
8191           t = start_decl (t, FALSE);
8192           finish_decl (t, NULL_TREE, FALSE);
8193
8194           if ((g != NULL)
8195               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8196                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8197             ffeglobal_set_hook (g, t);
8198
8199           resume_temporary_allocation ();
8200           pop_obstacks ();
8201
8202           break;
8203
8204         case FFEINFO_whereDUMMY:
8205           assert (ffecom_transform_only_dummies_);
8206
8207           if (ffesymbol_is_f2c (s)
8208               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8209             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8210           else
8211             t = build_pointer_type
8212               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8213
8214           t = build_decl (PARM_DECL,
8215                           ffecom_get_identifier_ (ffesymbol_text (s)),
8216                           t);
8217 #if BUILT_FOR_270
8218           DECL_ARTIFICIAL (t) = 1;
8219 #endif
8220           addr = TRUE;
8221           break;
8222
8223         case FFEINFO_whereCONSTANT:     /* Statement function. */
8224           assert (!ffecom_transform_only_dummies_);
8225           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8226           break;
8227
8228         case FFEINFO_whereINTRINSIC:
8229           assert (!ffecom_transform_only_dummies_);
8230           break;                /* Let actual references generate their
8231                                    decls. */
8232
8233         default:
8234           assert ("FUNCTION where unheard of" == NULL);
8235           /* Fall through. */
8236         case FFEINFO_whereANY:
8237           t = error_mark_node;
8238           break;
8239         }
8240       break;
8241
8242     case FFEINFO_kindSUBROUTINE:
8243       switch (ffeinfo_where (ffesymbol_info (s)))
8244         {
8245         case FFEINFO_whereLOCAL:        /* Me. */
8246           assert (!ffecom_transform_only_dummies_);
8247           t = current_function_decl;
8248           break;
8249
8250         case FFEINFO_whereGLOBAL:
8251           assert (!ffecom_transform_only_dummies_);
8252
8253           if (((g = ffesymbol_global (s)) != NULL)
8254               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8255                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8256               && (ffeglobal_hook (g) != NULL_TREE)
8257               && ffe_is_globals ())
8258             {
8259               t = ffeglobal_hook (g);
8260               break;
8261             }
8262
8263           push_obstacks_nochange ();
8264           end_temporary_allocation ();
8265
8266           t = build_decl (FUNCTION_DECL,
8267                           ffecom_get_external_identifier_ (s),
8268                           ffecom_tree_subr_type);
8269           DECL_EXTERNAL (t) = 1;
8270           TREE_PUBLIC (t) = 1;
8271
8272           t = start_decl (t, FALSE);
8273           finish_decl (t, NULL_TREE, FALSE);
8274
8275           if ((g != NULL)
8276               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8277                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8278             ffeglobal_set_hook (g, t);
8279
8280           resume_temporary_allocation ();
8281           pop_obstacks ();
8282
8283           break;
8284
8285         case FFEINFO_whereDUMMY:
8286           assert (ffecom_transform_only_dummies_);
8287
8288           t = build_decl (PARM_DECL,
8289                           ffecom_get_identifier_ (ffesymbol_text (s)),
8290                           ffecom_tree_ptr_to_subr_type);
8291 #if BUILT_FOR_270
8292           DECL_ARTIFICIAL (t) = 1;
8293 #endif
8294           addr = TRUE;
8295           break;
8296
8297         case FFEINFO_whereINTRINSIC:
8298           assert (!ffecom_transform_only_dummies_);
8299           break;                /* Let actual references generate their
8300                                    decls. */
8301
8302         default:
8303           assert ("SUBROUTINE where unheard of" == NULL);
8304           /* Fall through. */
8305         case FFEINFO_whereANY:
8306           t = error_mark_node;
8307           break;
8308         }
8309       break;
8310
8311     case FFEINFO_kindPROGRAM:
8312       switch (ffeinfo_where (ffesymbol_info (s)))
8313         {
8314         case FFEINFO_whereLOCAL:        /* Me. */
8315           assert (!ffecom_transform_only_dummies_);
8316           t = current_function_decl;
8317           break;
8318
8319         case FFEINFO_whereCOMMON:
8320         case FFEINFO_whereDUMMY:
8321         case FFEINFO_whereGLOBAL:
8322         case FFEINFO_whereRESULT:
8323         case FFEINFO_whereFLEETING:
8324         case FFEINFO_whereFLEETING_CADDR:
8325         case FFEINFO_whereFLEETING_IADDR:
8326         case FFEINFO_whereIMMEDIATE:
8327         case FFEINFO_whereINTRINSIC:
8328         case FFEINFO_whereCONSTANT:
8329         case FFEINFO_whereCONSTANT_SUBOBJECT:
8330         default:
8331           assert ("PROGRAM where unheard of" == NULL);
8332           /* Fall through. */
8333         case FFEINFO_whereANY:
8334           t = error_mark_node;
8335           break;
8336         }
8337       break;
8338
8339     case FFEINFO_kindBLOCKDATA:
8340       switch (ffeinfo_where (ffesymbol_info (s)))
8341         {
8342         case FFEINFO_whereLOCAL:        /* Me. */
8343           assert (!ffecom_transform_only_dummies_);
8344           t = current_function_decl;
8345           break;
8346
8347         case FFEINFO_whereGLOBAL:
8348           assert (!ffecom_transform_only_dummies_);
8349
8350           push_obstacks_nochange ();
8351           end_temporary_allocation ();
8352
8353           t = build_decl (FUNCTION_DECL,
8354                           ffecom_get_external_identifier_ (s),
8355                           ffecom_tree_blockdata_type);
8356           DECL_EXTERNAL (t) = 1;
8357           TREE_PUBLIC (t) = 1;
8358
8359           t = start_decl (t, FALSE);
8360           finish_decl (t, NULL_TREE, FALSE);
8361
8362           resume_temporary_allocation ();
8363           pop_obstacks ();
8364
8365           break;
8366
8367         case FFEINFO_whereCOMMON:
8368         case FFEINFO_whereDUMMY:
8369         case FFEINFO_whereRESULT:
8370         case FFEINFO_whereFLEETING:
8371         case FFEINFO_whereFLEETING_CADDR:
8372         case FFEINFO_whereFLEETING_IADDR:
8373         case FFEINFO_whereIMMEDIATE:
8374         case FFEINFO_whereINTRINSIC:
8375         case FFEINFO_whereCONSTANT:
8376         case FFEINFO_whereCONSTANT_SUBOBJECT:
8377         default:
8378           assert ("BLOCKDATA where unheard of" == NULL);
8379           /* Fall through. */
8380         case FFEINFO_whereANY:
8381           t = error_mark_node;
8382           break;
8383         }
8384       break;
8385
8386     case FFEINFO_kindCOMMON:
8387       switch (ffeinfo_where (ffesymbol_info (s)))
8388         {
8389         case FFEINFO_whereLOCAL:
8390           assert (!ffecom_transform_only_dummies_);
8391           ffecom_transform_common_ (s);
8392           break;
8393
8394         case FFEINFO_whereNONE:
8395         case FFEINFO_whereCOMMON:
8396         case FFEINFO_whereDUMMY:
8397         case FFEINFO_whereGLOBAL:
8398         case FFEINFO_whereRESULT:
8399         case FFEINFO_whereFLEETING:
8400         case FFEINFO_whereFLEETING_CADDR:
8401         case FFEINFO_whereFLEETING_IADDR:
8402         case FFEINFO_whereIMMEDIATE:
8403         case FFEINFO_whereINTRINSIC:
8404         case FFEINFO_whereCONSTANT:
8405         case FFEINFO_whereCONSTANT_SUBOBJECT:
8406         default:
8407           assert ("COMMON where unheard of" == NULL);
8408           /* Fall through. */
8409         case FFEINFO_whereANY:
8410           t = error_mark_node;
8411           break;
8412         }
8413       break;
8414
8415     case FFEINFO_kindCONSTRUCT:
8416       switch (ffeinfo_where (ffesymbol_info (s)))
8417         {
8418         case FFEINFO_whereLOCAL:
8419           assert (!ffecom_transform_only_dummies_);
8420           break;
8421
8422         case FFEINFO_whereNONE:
8423         case FFEINFO_whereCOMMON:
8424         case FFEINFO_whereDUMMY:
8425         case FFEINFO_whereGLOBAL:
8426         case FFEINFO_whereRESULT:
8427         case FFEINFO_whereFLEETING:
8428         case FFEINFO_whereFLEETING_CADDR:
8429         case FFEINFO_whereFLEETING_IADDR:
8430         case FFEINFO_whereIMMEDIATE:
8431         case FFEINFO_whereINTRINSIC:
8432         case FFEINFO_whereCONSTANT:
8433         case FFEINFO_whereCONSTANT_SUBOBJECT:
8434         default:
8435           assert ("CONSTRUCT where unheard of" == NULL);
8436           /* Fall through. */
8437         case FFEINFO_whereANY:
8438           t = error_mark_node;
8439           break;
8440         }
8441       break;
8442
8443     case FFEINFO_kindNAMELIST:
8444       switch (ffeinfo_where (ffesymbol_info (s)))
8445         {
8446         case FFEINFO_whereLOCAL:
8447           assert (!ffecom_transform_only_dummies_);
8448           t = ffecom_transform_namelist_ (s);
8449           break;
8450
8451         case FFEINFO_whereNONE:
8452         case FFEINFO_whereCOMMON:
8453         case FFEINFO_whereDUMMY:
8454         case FFEINFO_whereGLOBAL:
8455         case FFEINFO_whereRESULT:
8456         case FFEINFO_whereFLEETING:
8457         case FFEINFO_whereFLEETING_CADDR:
8458         case FFEINFO_whereFLEETING_IADDR:
8459         case FFEINFO_whereIMMEDIATE:
8460         case FFEINFO_whereINTRINSIC:
8461         case FFEINFO_whereCONSTANT:
8462         case FFEINFO_whereCONSTANT_SUBOBJECT:
8463         default:
8464           assert ("NAMELIST where unheard of" == NULL);
8465           /* Fall through. */
8466         case FFEINFO_whereANY:
8467           t = error_mark_node;
8468           break;
8469         }
8470       break;
8471
8472     default:
8473       assert ("kind unheard of" == NULL);
8474       /* Fall through. */
8475     case FFEINFO_kindANY:
8476       t = error_mark_node;
8477       break;
8478     }
8479
8480   ffesymbol_hook (s).decl_tree = t;
8481   ffesymbol_hook (s).length_tree = tlen;
8482   ffesymbol_hook (s).addr = addr;
8483
8484   lineno = old_lineno;
8485   input_filename = old_input_filename;
8486
8487   return s;
8488 }
8489
8490 #endif
8491 /* Transform into ASSIGNable symbol.
8492
8493    Symbol has already been transformed, but for whatever reason, the
8494    resulting decl_tree has been deemed not usable for an ASSIGN target.
8495    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8496    another local symbol of type void * and stuff that in the assign_tree
8497    argument.  The F77/F90 standards allow this implementation.  */
8498
8499 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8500 static ffesymbol
8501 ffecom_sym_transform_assign_ (ffesymbol s)
8502 {
8503   tree t;                       /* Transformed thingy. */
8504   int yes;
8505   int old_lineno = lineno;
8506   char *old_input_filename = input_filename;
8507
8508   if (ffesymbol_sfdummyparent (s) == NULL)
8509     {
8510       input_filename = ffesymbol_where_filename (s);
8511       lineno = ffesymbol_where_filelinenum (s);
8512     }
8513   else
8514     {
8515       ffesymbol sf = ffesymbol_sfdummyparent (s);
8516
8517       input_filename = ffesymbol_where_filename (sf);
8518       lineno = ffesymbol_where_filelinenum (sf);
8519     }
8520
8521   assert (!ffecom_transform_only_dummies_);
8522
8523   yes = suspend_momentary ();
8524
8525   t = build_decl (VAR_DECL,
8526                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8527                                                    ffesymbol_text (s),
8528                                                    -1),
8529                   TREE_TYPE (null_pointer_node));
8530
8531   switch (ffesymbol_where (s))
8532     {
8533     case FFEINFO_whereLOCAL:
8534       /* Unlike for regular vars, SAVE status is easy to determine for
8535          ASSIGNed vars, since there's no initialization, there's no
8536          effective storage association (so "SAVE J" does not apply to
8537          K even given "EQUIVALENCE (J,K)"), there's no size issue
8538          to worry about, etc.  */
8539       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8540           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8541           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8542         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8543       else
8544         TREE_STATIC (t) = 0;    /* No need to make static. */
8545       break;
8546
8547     case FFEINFO_whereCOMMON:
8548       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8549       break;
8550
8551     case FFEINFO_whereDUMMY:
8552       /* Note that twinning a DUMMY means the caller won't see
8553          the ASSIGNed value.  But both F77 and F90 allow implementations
8554          to do this, i.e. disallow Fortran code that would try and
8555          take advantage of actually putting a label into a variable
8556          via a dummy argument (or any other storage association, for
8557          that matter).  */
8558       TREE_STATIC (t) = 0;
8559       break;
8560
8561     default:
8562       TREE_STATIC (t) = 0;
8563       break;
8564     }
8565
8566   t = start_decl (t, FALSE);
8567   finish_decl (t, NULL_TREE, FALSE);
8568
8569   resume_momentary (yes);
8570
8571   ffesymbol_hook (s).assign_tree = t;
8572
8573   lineno = old_lineno;
8574   input_filename = old_input_filename;
8575
8576   return s;
8577 }
8578
8579 #endif
8580 /* Implement COMMON area in back end.
8581
8582    Because COMMON-based variables can be referenced in the dimension
8583    expressions of dummy (adjustable) arrays, and because dummies
8584    (in the gcc back end) need to be put in the outer binding level
8585    of a function (which has two binding levels, the outer holding
8586    the dummies and the inner holding the other vars), special care
8587    must be taken to handle COMMON areas.
8588
8589    The current strategy is basically to always tell the back end about
8590    the COMMON area as a top-level external reference to just a block
8591    of storage of the master type of that area (e.g. integer, real,
8592    character, whatever -- not a structure).  As a distinct action,
8593    if initial values are provided, tell the back end about the area
8594    as a top-level non-external (initialized) area and remember not to
8595    allow further initialization or expansion of the area.  Meanwhile,
8596    if no initialization happens at all, tell the back end about
8597    the largest size we've seen declared so the space does get reserved.
8598    (This function doesn't handle all that stuff, but it does some
8599    of the important things.)
8600
8601    Meanwhile, for COMMON variables themselves, just keep creating
8602    references like *((float *) (&common_area + offset)) each time
8603    we reference the variable.  In other words, don't make a VAR_DECL
8604    or any kind of component reference (like we used to do before 0.4),
8605    though we might do that as well just for debugging purposes (and
8606    stuff the rtl with the appropriate offset expression).  */
8607
8608 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8609 static void
8610 ffecom_transform_common_ (ffesymbol s)
8611 {
8612   ffestorag st = ffesymbol_storage (s);
8613   ffeglobal g = ffesymbol_global (s);
8614   tree cbt;
8615   tree cbtype;
8616   tree init;
8617   tree high;
8618   bool is_init = ffestorag_is_init (st);
8619
8620   assert (st != NULL);
8621
8622   if ((g == NULL)
8623       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8624     return;
8625
8626   /* First update the size of the area in global terms.  */
8627
8628   ffeglobal_size_common (s, ffestorag_size (st));
8629
8630   if (!ffeglobal_common_init (g))
8631     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8632
8633   cbt = ffeglobal_hook (g);
8634
8635   /* If we already have declared this common block for a previous program
8636      unit, and either we already initialized it or we don't have new
8637      initialization for it, just return what we have without changing it.  */
8638
8639   if ((cbt != NULL_TREE)
8640       && (!is_init
8641           || !DECL_EXTERNAL (cbt)))
8642     return;
8643
8644   /* Process inits.  */
8645
8646   if (is_init)
8647     {
8648       if (ffestorag_init (st) != NULL)
8649         {
8650           ffebld sexp;
8651
8652           /* Set the padding for the expression, so ffecom_expr
8653              knows to insert that many zeros.  */
8654           switch (ffebld_op (sexp = ffestorag_init (st)))
8655             {
8656             case FFEBLD_opCONTER:
8657               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8658               break;
8659
8660             case FFEBLD_opARRTER:
8661               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8662               break;
8663
8664             case FFEBLD_opACCTER:
8665               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8666               break;
8667
8668             default:
8669               assert ("bad op for cmn init (pad)" == NULL);
8670               break;
8671             }
8672
8673           init = ffecom_expr (sexp);
8674           if (init == error_mark_node)
8675             {                   /* Hopefully the back end complained! */
8676               init = NULL_TREE;
8677               if (cbt != NULL_TREE)
8678                 return;
8679             }
8680         }
8681       else
8682         init = error_mark_node;
8683     }
8684   else
8685     init = NULL_TREE;
8686
8687   push_obstacks_nochange ();
8688   end_temporary_allocation ();
8689
8690   /* cbtype must be permanently allocated!  */
8691
8692   /* Allocate the MAX of the areas so far, seen filewide.  */
8693   high = build_int_2 ((ffeglobal_common_size (g)
8694                        + ffeglobal_common_pad (g)) - 1, 0);
8695   TREE_TYPE (high) = ffecom_integer_type_node;
8696
8697   if (init)
8698     cbtype = build_array_type (char_type_node,
8699                                build_range_type (integer_type_node,
8700                                                  integer_zero_node,
8701                                                  high));
8702   else
8703     cbtype = build_array_type (char_type_node, NULL_TREE);
8704
8705   if (cbt == NULL_TREE)
8706     {
8707       cbt
8708         = build_decl (VAR_DECL,
8709                       ffecom_get_external_identifier_ (s),
8710                       cbtype);
8711       TREE_STATIC (cbt) = 1;
8712       TREE_PUBLIC (cbt) = 1;
8713     }
8714   else
8715     {
8716       assert (is_init);
8717       TREE_TYPE (cbt) = cbtype;
8718     }
8719   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8720   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8721
8722   cbt = start_decl (cbt, TRUE);
8723   if (ffeglobal_hook (g) != NULL)
8724     assert (cbt == ffeglobal_hook (g));
8725
8726   assert (!init || !DECL_EXTERNAL (cbt));
8727
8728   /* Make sure that any type can live in COMMON and be referenced
8729      without getting a bus error.  We could pick the most restrictive
8730      alignment of all entities actually placed in the COMMON, but
8731      this seems easy enough.  */
8732
8733   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8734
8735   if (is_init && (ffestorag_init (st) == NULL))
8736     init = ffecom_init_zero_ (cbt);
8737
8738   finish_decl (cbt, init, TRUE);
8739
8740   if (is_init)
8741     ffestorag_set_init (st, ffebld_new_any ());
8742
8743   if (init)
8744     {
8745       tree size_tree;
8746
8747       assert (DECL_SIZE (cbt) != NULL_TREE);
8748       assert (TREE_CODE (DECL_SIZE (cbt)) == INTEGER_CST);
8749       size_tree = size_binop (CEIL_DIV_EXPR,
8750                               DECL_SIZE (cbt),
8751                               size_int (BITS_PER_UNIT));
8752       assert (TREE_INT_CST_HIGH (size_tree) == 0);
8753       assert (TREE_INT_CST_LOW (size_tree)
8754               == ffeglobal_common_size (g) + ffeglobal_common_pad (g));
8755     }
8756
8757   ffeglobal_set_hook (g, cbt);
8758
8759   ffestorag_set_hook (st, cbt);
8760
8761   resume_temporary_allocation ();
8762   pop_obstacks ();
8763 }
8764
8765 #endif
8766 /* Make master area for local EQUIVALENCE.  */
8767
8768 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8769 static void
8770 ffecom_transform_equiv_ (ffestorag eqst)
8771 {
8772   tree eqt;
8773   tree eqtype;
8774   tree init;
8775   tree high;
8776   bool is_init = ffestorag_is_init (eqst);
8777   int yes;
8778
8779   assert (eqst != NULL);
8780
8781   eqt = ffestorag_hook (eqst);
8782
8783   if (eqt != NULL_TREE)
8784     return;
8785
8786   /* Process inits.  */
8787
8788   if (is_init)
8789     {
8790       if (ffestorag_init (eqst) != NULL)
8791         {
8792           ffebld sexp;
8793
8794           /* Set the padding for the expression, so ffecom_expr
8795              knows to insert that many zeros.  */
8796           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8797             {
8798             case FFEBLD_opCONTER:
8799               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8800               break;
8801
8802             case FFEBLD_opARRTER:
8803               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8804               break;
8805
8806             case FFEBLD_opACCTER:
8807               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8808               break;
8809
8810             default:
8811               assert ("bad op for eqv init (pad)" == NULL);
8812               break;
8813             }
8814
8815           init = ffecom_expr (sexp);
8816           if (init == error_mark_node)
8817             init = NULL_TREE;   /* Hopefully the back end complained! */
8818         }
8819       else
8820         init = error_mark_node;
8821     }
8822   else if (ffe_is_init_local_zero ())
8823     init = error_mark_node;
8824   else
8825     init = NULL_TREE;
8826
8827   ffecom_member_namelisted_ = FALSE;
8828   ffestorag_drive (ffestorag_list_equivs (eqst),
8829                    &ffecom_member_phase1_,
8830                    eqst);
8831
8832   yes = suspend_momentary ();
8833
8834   high = build_int_2 ((ffestorag_size (eqst)
8835                        + ffestorag_modulo (eqst)) - 1, 0);
8836   TREE_TYPE (high) = ffecom_integer_type_node;
8837
8838   eqtype = build_array_type (char_type_node,
8839                              build_range_type (ffecom_integer_type_node,
8840                                                ffecom_integer_zero_node,
8841                                                high));
8842
8843   eqt = build_decl (VAR_DECL,
8844                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8845                                                     ffesymbol_text
8846                                                     (ffestorag_symbol
8847                                                      (eqst)),
8848                                                     -1),
8849                     eqtype);
8850   DECL_EXTERNAL (eqt) = 0;
8851   if (is_init
8852       || ffecom_member_namelisted_
8853 #ifdef FFECOM_sizeMAXSTACKITEM
8854       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8855 #endif
8856       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8857           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8858           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8859     TREE_STATIC (eqt) = 1;
8860   else
8861     TREE_STATIC (eqt) = 0;
8862   TREE_PUBLIC (eqt) = 0;
8863   DECL_CONTEXT (eqt) = current_function_decl;
8864   if (init)
8865     DECL_INITIAL (eqt) = error_mark_node;
8866   else
8867     DECL_INITIAL (eqt) = NULL_TREE;
8868
8869   eqt = start_decl (eqt, FALSE);
8870
8871   /* Make sure that any type can live in EQUIVALENCE and be referenced
8872      without getting a bus error.  We could pick the most restrictive
8873      alignment of all entities actually placed in the EQUIVALENCE, but
8874      this seems easy enough.  */
8875
8876   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8877
8878   if ((!is_init && ffe_is_init_local_zero ())
8879       || (is_init && (ffestorag_init (eqst) == NULL)))
8880     init = ffecom_init_zero_ (eqt);
8881
8882   finish_decl (eqt, init, FALSE);
8883
8884   if (is_init)
8885     ffestorag_set_init (eqst, ffebld_new_any ());
8886
8887   {
8888     tree size_tree;
8889
8890     size_tree = size_binop (CEIL_DIV_EXPR,
8891                             DECL_SIZE (eqt),
8892                             size_int (BITS_PER_UNIT));
8893     assert (TREE_INT_CST_HIGH (size_tree) == 0);
8894     assert (TREE_INT_CST_LOW (size_tree)
8895             == ffestorag_size (eqst) + ffestorag_modulo (eqst));
8896   }
8897
8898   ffestorag_set_hook (eqst, eqt);
8899
8900 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
8901   ffestorag_drive (ffestorag_list_equivs (eqst),
8902                    &ffecom_member_phase2_,
8903                    eqst);
8904 #endif
8905
8906   resume_momentary (yes);
8907 }
8908
8909 #endif
8910 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8911
8912 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8913 static tree
8914 ffecom_transform_namelist_ (ffesymbol s)
8915 {
8916   tree nmlt;
8917   tree nmltype = ffecom_type_namelist_ ();
8918   tree nmlinits;
8919   tree nameinit;
8920   tree varsinit;
8921   tree nvarsinit;
8922   tree field;
8923   tree high;
8924   int yes;
8925   int i;
8926   static int mynumber = 0;
8927
8928   yes = suspend_momentary ();
8929
8930   nmlt = build_decl (VAR_DECL,
8931                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8932                                                      NULL, mynumber++),
8933                      nmltype);
8934   TREE_STATIC (nmlt) = 1;
8935   DECL_INITIAL (nmlt) = error_mark_node;
8936
8937   nmlt = start_decl (nmlt, FALSE);
8938
8939   /* Process inits.  */
8940
8941   i = strlen (ffesymbol_text (s));
8942
8943   high = build_int_2 (i, 0);
8944   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8945
8946   nameinit = ffecom_build_f2c_string_ (i + 1,
8947                                        ffesymbol_text (s));
8948   TREE_TYPE (nameinit)
8949     = build_type_variant
8950     (build_array_type
8951      (char_type_node,
8952       build_range_type (ffecom_f2c_ftnlen_type_node,
8953                         ffecom_f2c_ftnlen_one_node,
8954                         high)),
8955      1, 0);
8956   TREE_CONSTANT (nameinit) = 1;
8957   TREE_STATIC (nameinit) = 1;
8958   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8959                        nameinit);
8960
8961   varsinit = ffecom_vardesc_array_ (s);
8962   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8963                        varsinit);
8964   TREE_CONSTANT (varsinit) = 1;
8965   TREE_STATIC (varsinit) = 1;
8966
8967   {
8968     ffebld b;
8969
8970     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8971       ++i;
8972   }
8973   nvarsinit = build_int_2 (i, 0);
8974   TREE_TYPE (nvarsinit) = integer_type_node;
8975   TREE_CONSTANT (nvarsinit) = 1;
8976   TREE_STATIC (nvarsinit) = 1;
8977
8978   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8979   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8980                                            varsinit);
8981   TREE_CHAIN (TREE_CHAIN (nmlinits))
8982     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8983
8984   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8985   TREE_CONSTANT (nmlinits) = 1;
8986   TREE_STATIC (nmlinits) = 1;
8987
8988   finish_decl (nmlt, nmlinits, FALSE);
8989
8990   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8991
8992   resume_momentary (yes);
8993
8994   return nmlt;
8995 }
8996
8997 #endif
8998
8999 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
9000    analyzed on the assumption it is calculating a pointer to be
9001    indirected through.  It must return the proper decl and offset,
9002    taking into account different units of measurements for offsets.  */
9003
9004 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9005 static void
9006 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
9007                            tree t)
9008 {
9009   switch (TREE_CODE (t))
9010     {
9011     case NOP_EXPR:
9012     case CONVERT_EXPR:
9013     case NON_LVALUE_EXPR:
9014       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9015       break;
9016
9017     case PLUS_EXPR:
9018       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9019       if ((*decl == NULL_TREE)
9020           || (*decl == error_mark_node))
9021         break;
9022
9023       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
9024         {
9025           /* An offset into COMMON.  */
9026           *offset = size_binop (PLUS_EXPR,
9027                                 *offset,
9028                                 TREE_OPERAND (t, 1));
9029           /* Convert offset (presumably in bytes) into canonical units
9030              (presumably bits).  */
9031           *offset = size_binop (MULT_EXPR,
9032                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))),
9033                                 *offset);
9034           break;
9035         }
9036       /* Not a COMMON reference, so an unrecognized pattern.  */
9037       *decl = error_mark_node;
9038       break;
9039
9040     case PARM_DECL:
9041       *decl = t;
9042       *offset = bitsize_int (0L, 0L);
9043       break;
9044
9045     case ADDR_EXPR:
9046       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
9047         {
9048           /* A reference to COMMON.  */
9049           *decl = TREE_OPERAND (t, 0);
9050           *offset = bitsize_int (0L, 0L);
9051           break;
9052         }
9053       /* Fall through.  */
9054     default:
9055       /* Not a COMMON reference, so an unrecognized pattern.  */
9056       *decl = error_mark_node;
9057       break;
9058     }
9059 }
9060 #endif
9061
9062 /* Given a tree that is possibly intended for use as an lvalue, return
9063    information representing a canonical view of that tree as a decl, an
9064    offset into that decl, and a size for the lvalue.
9065
9066    If there's no applicable decl, NULL_TREE is returned for the decl,
9067    and the other fields are left undefined.
9068
9069    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9070    is returned for the decl, and the other fields are left undefined.
9071
9072    Otherwise, the decl returned currently is either a VAR_DECL or a
9073    PARM_DECL.
9074
9075    The offset returned is always valid, but of course not necessarily
9076    a constant, and not necessarily converted into the appropriate
9077    type, leaving that up to the caller (so as to avoid that overhead
9078    if the decls being looked at are different anyway).
9079
9080    If the size cannot be determined (e.g. an adjustable array),
9081    an ERROR_MARK node is returned for the size.  Otherwise, the
9082    size returned is valid, not necessarily a constant, and not
9083    necessarily converted into the appropriate type as with the
9084    offset.
9085
9086    Note that the offset and size expressions are expressed in the
9087    base storage units (usually bits) rather than in the units of
9088    the type of the decl, because two decls with different types
9089    might overlap but with apparently non-overlapping array offsets,
9090    whereas converting the array offsets to consistant offsets will
9091    reveal the overlap.  */
9092
9093 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9094 static void
9095 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9096                            tree *size, tree t)
9097 {
9098   /* The default path is to report a nonexistant decl.  */
9099   *decl = NULL_TREE;
9100
9101   if (t == NULL_TREE)
9102     return;
9103
9104   switch (TREE_CODE (t))
9105     {
9106     case ERROR_MARK:
9107     case IDENTIFIER_NODE:
9108     case INTEGER_CST:
9109     case REAL_CST:
9110     case COMPLEX_CST:
9111     case STRING_CST:
9112     case CONST_DECL:
9113     case PLUS_EXPR:
9114     case MINUS_EXPR:
9115     case MULT_EXPR:
9116     case TRUNC_DIV_EXPR:
9117     case CEIL_DIV_EXPR:
9118     case FLOOR_DIV_EXPR:
9119     case ROUND_DIV_EXPR:
9120     case TRUNC_MOD_EXPR:
9121     case CEIL_MOD_EXPR:
9122     case FLOOR_MOD_EXPR:
9123     case ROUND_MOD_EXPR:
9124     case RDIV_EXPR:
9125     case EXACT_DIV_EXPR:
9126     case FIX_TRUNC_EXPR:
9127     case FIX_CEIL_EXPR:
9128     case FIX_FLOOR_EXPR:
9129     case FIX_ROUND_EXPR:
9130     case FLOAT_EXPR:
9131     case EXPON_EXPR:
9132     case NEGATE_EXPR:
9133     case MIN_EXPR:
9134     case MAX_EXPR:
9135     case ABS_EXPR:
9136     case FFS_EXPR:
9137     case LSHIFT_EXPR:
9138     case RSHIFT_EXPR:
9139     case LROTATE_EXPR:
9140     case RROTATE_EXPR:
9141     case BIT_IOR_EXPR:
9142     case BIT_XOR_EXPR:
9143     case BIT_AND_EXPR:
9144     case BIT_ANDTC_EXPR:
9145     case BIT_NOT_EXPR:
9146     case TRUTH_ANDIF_EXPR:
9147     case TRUTH_ORIF_EXPR:
9148     case TRUTH_AND_EXPR:
9149     case TRUTH_OR_EXPR:
9150     case TRUTH_XOR_EXPR:
9151     case TRUTH_NOT_EXPR:
9152     case LT_EXPR:
9153     case LE_EXPR:
9154     case GT_EXPR:
9155     case GE_EXPR:
9156     case EQ_EXPR:
9157     case NE_EXPR:
9158     case COMPLEX_EXPR:
9159     case CONJ_EXPR:
9160     case REALPART_EXPR:
9161     case IMAGPART_EXPR:
9162     case LABEL_EXPR:
9163     case COMPONENT_REF:
9164     case COMPOUND_EXPR:
9165     case ADDR_EXPR:
9166       return;
9167
9168     case VAR_DECL:
9169     case PARM_DECL:
9170       *decl = t;
9171       *offset = bitsize_int (0L, 0L);
9172       *size = TYPE_SIZE (TREE_TYPE (t));
9173       return;
9174
9175     case ARRAY_REF:
9176       {
9177         tree array = TREE_OPERAND (t, 0);
9178         tree element = TREE_OPERAND (t, 1);
9179         tree init_offset;
9180
9181         if ((array == NULL_TREE)
9182             || (element == NULL_TREE))
9183           {
9184             *decl = error_mark_node;
9185             return;
9186           }
9187
9188         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9189                                    array);
9190         if ((*decl == NULL_TREE)
9191             || (*decl == error_mark_node))
9192           return;
9193
9194         *offset = size_binop (MULT_EXPR,
9195                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))),
9196                               size_binop (MINUS_EXPR,
9197                                           element,
9198                                           TYPE_MIN_VALUE
9199                                           (TYPE_DOMAIN
9200                                            (TREE_TYPE (array)))));
9201
9202         *offset = size_binop (PLUS_EXPR,
9203                               init_offset,
9204                               *offset);
9205
9206         *size = TYPE_SIZE (TREE_TYPE (t));
9207         return;
9208       }
9209
9210     case INDIRECT_REF:
9211
9212       /* Most of this code is to handle references to COMMON.  And so
9213          far that is useful only for calling library functions, since
9214          external (user) functions might reference common areas.  But
9215          even calling an external function, it's worthwhile to decode
9216          COMMON references because if not storing into COMMON, we don't
9217          want COMMON-based arguments to gratuitously force use of a
9218          temporary.  */
9219
9220       *size = TYPE_SIZE (TREE_TYPE (t));
9221
9222       ffecom_tree_canonize_ptr_ (decl, offset,
9223                                  TREE_OPERAND (t, 0));
9224
9225       return;
9226
9227     case CONVERT_EXPR:
9228     case NOP_EXPR:
9229     case MODIFY_EXPR:
9230     case NON_LVALUE_EXPR:
9231     case RESULT_DECL:
9232     case FIELD_DECL:
9233     case COND_EXPR:             /* More cases than we can handle. */
9234     case SAVE_EXPR:
9235     case REFERENCE_EXPR:
9236     case PREDECREMENT_EXPR:
9237     case PREINCREMENT_EXPR:
9238     case POSTDECREMENT_EXPR:
9239     case POSTINCREMENT_EXPR:
9240     case CALL_EXPR:
9241     default:
9242       *decl = error_mark_node;
9243       return;
9244     }
9245 }
9246 #endif
9247
9248 /* Do divide operation appropriate to type of operands.  */
9249
9250 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9251 static tree
9252 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9253                      tree dest_tree, ffebld dest, bool *dest_used,
9254                      tree hook)
9255 {
9256   if ((left == error_mark_node)
9257       || (right == error_mark_node))
9258     return error_mark_node;
9259
9260   switch (TREE_CODE (tree_type))
9261     {
9262     case INTEGER_TYPE:
9263       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9264                        left,
9265                        right);
9266
9267     case COMPLEX_TYPE:
9268       {
9269         ffecomGfrt ix;
9270
9271         if (TREE_TYPE (tree_type)
9272             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9273           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9274         else
9275           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9276
9277         left = ffecom_1 (ADDR_EXPR,
9278                          build_pointer_type (TREE_TYPE (left)),
9279                          left);
9280         left = build_tree_list (NULL_TREE, left);
9281         right = ffecom_1 (ADDR_EXPR,
9282                           build_pointer_type (TREE_TYPE (right)),
9283                           right);
9284         right = build_tree_list (NULL_TREE, right);
9285         TREE_CHAIN (left) = right;
9286
9287         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9288                              ffecom_gfrt_kindtype (ix),
9289                              ffe_is_f2c_library (),
9290                              tree_type,
9291                              left,
9292                              dest_tree, dest, dest_used,
9293                              NULL_TREE, TRUE, hook);
9294       }
9295       break;
9296
9297     case RECORD_TYPE:
9298       {
9299         ffecomGfrt ix;
9300
9301         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9302             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9303           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9304         else
9305           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9306
9307         left = ffecom_1 (ADDR_EXPR,
9308                          build_pointer_type (TREE_TYPE (left)),
9309                          left);
9310         left = build_tree_list (NULL_TREE, left);
9311         right = ffecom_1 (ADDR_EXPR,
9312                           build_pointer_type (TREE_TYPE (right)),
9313                           right);
9314         right = build_tree_list (NULL_TREE, right);
9315         TREE_CHAIN (left) = right;
9316
9317         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9318                              ffecom_gfrt_kindtype (ix),
9319                              ffe_is_f2c_library (),
9320                              tree_type,
9321                              left,
9322                              dest_tree, dest, dest_used,
9323                              NULL_TREE, TRUE, hook);
9324       }
9325       break;
9326
9327     default:
9328       return ffecom_2 (RDIV_EXPR, tree_type,
9329                        left,
9330                        right);
9331     }
9332 }
9333
9334 #endif
9335 /* Build type info for non-dummy variable.  */
9336
9337 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9338 static tree
9339 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9340                        ffeinfoKindtype kt)
9341 {
9342   tree type;
9343   ffebld dl;
9344   ffebld dim;
9345   tree lowt;
9346   tree hight;
9347
9348   type = ffecom_tree_type[bt][kt];
9349   if (bt == FFEINFO_basictypeCHARACTER)
9350     {
9351       hight = build_int_2 (ffesymbol_size (s), 0);
9352       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9353
9354       type
9355         = build_array_type
9356           (type,
9357            build_range_type (ffecom_f2c_ftnlen_type_node,
9358                              ffecom_f2c_ftnlen_one_node,
9359                              hight));
9360       type = ffecom_check_size_overflow_ (s, type, FALSE);
9361     }
9362
9363   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9364     {
9365       if (type == error_mark_node)
9366         break;
9367
9368       dim = ffebld_head (dl);
9369       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9370
9371       if (ffebld_left (dim) == NULL)
9372         lowt = integer_one_node;
9373       else
9374         lowt = ffecom_expr (ffebld_left (dim));
9375
9376       if (TREE_CODE (lowt) != INTEGER_CST)
9377         lowt = variable_size (lowt);
9378
9379       assert (ffebld_right (dim) != NULL);
9380       hight = ffecom_expr (ffebld_right (dim));
9381
9382       if (TREE_CODE (hight) != INTEGER_CST)
9383         hight = variable_size (hight);
9384
9385       type = build_array_type (type,
9386                                build_range_type (ffecom_integer_type_node,
9387                                                  lowt, hight));
9388       type = ffecom_check_size_overflow_ (s, type, FALSE);
9389     }
9390
9391   return type;
9392 }
9393
9394 #endif
9395 /* Build Namelist type.  */
9396
9397 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9398 static tree
9399 ffecom_type_namelist_ ()
9400 {
9401   static tree type = NULL_TREE;
9402
9403   if (type == NULL_TREE)
9404     {
9405       static tree namefield, varsfield, nvarsfield;
9406       tree vardesctype;
9407
9408       vardesctype = ffecom_type_vardesc_ ();
9409
9410       push_obstacks_nochange ();
9411       end_temporary_allocation ();
9412
9413       type = make_node (RECORD_TYPE);
9414
9415       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9416
9417       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9418                                      string_type_node);
9419       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9420       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9421                                       integer_type_node);
9422
9423       TYPE_FIELDS (type) = namefield;
9424       layout_type (type);
9425
9426       resume_temporary_allocation ();
9427       pop_obstacks ();
9428     }
9429
9430   return type;
9431 }
9432
9433 #endif
9434
9435 /* Make a copy of a type, assuming caller has switched to the permanent
9436    obstacks and that the type is for an aggregate (array) initializer.  */
9437
9438 #if FFECOM_targetCURRENT == FFECOM_targetGCC && 0       /* Not used now. */
9439 static tree
9440 ffecom_type_permanent_copy_ (tree t)
9441 {
9442   tree domain;
9443   tree max;
9444
9445   assert (TREE_TYPE (t) != NULL_TREE);
9446
9447   domain = TYPE_DOMAIN (t);
9448
9449   assert (TREE_CODE (t) == ARRAY_TYPE);
9450   assert (TREE_PERMANENT (TREE_TYPE (t)));
9451   assert (TREE_PERMANENT (TREE_TYPE (domain)));
9452   assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain)));
9453
9454   max = TYPE_MAX_VALUE (domain);
9455   if (!TREE_PERMANENT (max))
9456     {
9457       assert (TREE_CODE (max) == INTEGER_CST);
9458
9459       max = build_int_2 (TREE_INT_CST_LOW (max), TREE_INT_CST_HIGH (max));
9460       TREE_TYPE (max) = TREE_TYPE (TYPE_MIN_VALUE (domain));
9461     }
9462
9463   return build_array_type (TREE_TYPE (t),
9464                            build_range_type (TREE_TYPE (domain),
9465                                              TYPE_MIN_VALUE (domain),
9466                                              max));
9467 }
9468 #endif
9469
9470 /* Build Vardesc type.  */
9471
9472 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9473 static tree
9474 ffecom_type_vardesc_ ()
9475 {
9476   static tree type = NULL_TREE;
9477   static tree namefield, addrfield, dimsfield, typefield;
9478
9479   if (type == NULL_TREE)
9480     {
9481       push_obstacks_nochange ();
9482       end_temporary_allocation ();
9483
9484       type = make_node (RECORD_TYPE);
9485
9486       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9487                                      string_type_node);
9488       addrfield = ffecom_decl_field (type, namefield, "addr",
9489                                      string_type_node);
9490       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9491                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9492       typefield = ffecom_decl_field (type, dimsfield, "type",
9493                                      integer_type_node);
9494
9495       TYPE_FIELDS (type) = namefield;
9496       layout_type (type);
9497
9498       resume_temporary_allocation ();
9499       pop_obstacks ();
9500     }
9501
9502   return type;
9503 }
9504
9505 #endif
9506
9507 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9508 static tree
9509 ffecom_vardesc_ (ffebld expr)
9510 {
9511   ffesymbol s;
9512
9513   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9514   s = ffebld_symter (expr);
9515
9516   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9517     {
9518       int i;
9519       tree vardesctype = ffecom_type_vardesc_ ();
9520       tree var;
9521       tree nameinit;
9522       tree dimsinit;
9523       tree addrinit;
9524       tree typeinit;
9525       tree field;
9526       tree varinits;
9527       int yes;
9528       static int mynumber = 0;
9529
9530       yes = suspend_momentary ();
9531
9532       var = build_decl (VAR_DECL,
9533                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9534                                                         NULL, mynumber++),
9535                         vardesctype);
9536       TREE_STATIC (var) = 1;
9537       DECL_INITIAL (var) = error_mark_node;
9538
9539       var = start_decl (var, FALSE);
9540
9541       /* Process inits.  */
9542
9543       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9544                                            + 1,
9545                                            ffesymbol_text (s));
9546       TREE_TYPE (nameinit)
9547         = build_type_variant
9548         (build_array_type
9549          (char_type_node,
9550           build_range_type (integer_type_node,
9551                             integer_one_node,
9552                             build_int_2 (i, 0))),
9553          1, 0);
9554       TREE_CONSTANT (nameinit) = 1;
9555       TREE_STATIC (nameinit) = 1;
9556       nameinit = ffecom_1 (ADDR_EXPR,
9557                            build_pointer_type (TREE_TYPE (nameinit)),
9558                            nameinit);
9559
9560       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9561
9562       dimsinit = ffecom_vardesc_dims_ (s);
9563
9564       if (typeinit == NULL_TREE)
9565         {
9566           ffeinfoBasictype bt = ffesymbol_basictype (s);
9567           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9568           int tc = ffecom_f2c_typecode (bt, kt);
9569
9570           assert (tc != -1);
9571           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9572         }
9573       else
9574         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9575
9576       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9577                                   nameinit);
9578       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9579                                                addrinit);
9580       TREE_CHAIN (TREE_CHAIN (varinits))
9581         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9582       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9583         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9584
9585       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9586       TREE_CONSTANT (varinits) = 1;
9587       TREE_STATIC (varinits) = 1;
9588
9589       finish_decl (var, varinits, FALSE);
9590
9591       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9592
9593       resume_momentary (yes);
9594
9595       ffesymbol_hook (s).vardesc_tree = var;
9596     }
9597
9598   return ffesymbol_hook (s).vardesc_tree;
9599 }
9600
9601 #endif
9602 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9603 static tree
9604 ffecom_vardesc_array_ (ffesymbol s)
9605 {
9606   ffebld b;
9607   tree list;
9608   tree item = NULL_TREE;
9609   tree var;
9610   int i;
9611   int yes;
9612   static int mynumber = 0;
9613
9614   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9615        b != NULL;
9616        b = ffebld_trail (b), ++i)
9617     {
9618       tree t;
9619
9620       t = ffecom_vardesc_ (ffebld_head (b));
9621
9622       if (list == NULL_TREE)
9623         list = item = build_tree_list (NULL_TREE, t);
9624       else
9625         {
9626           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9627           item = TREE_CHAIN (item);
9628         }
9629     }
9630
9631   yes = suspend_momentary ();
9632
9633   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9634                            build_range_type (integer_type_node,
9635                                              integer_one_node,
9636                                              build_int_2 (i, 0)));
9637   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9638   TREE_CONSTANT (list) = 1;
9639   TREE_STATIC (list) = 1;
9640
9641   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL,
9642                                         mynumber++);
9643   var = build_decl (VAR_DECL, var, item);
9644   TREE_STATIC (var) = 1;
9645   DECL_INITIAL (var) = error_mark_node;
9646   var = start_decl (var, FALSE);
9647   finish_decl (var, list, FALSE);
9648
9649   resume_momentary (yes);
9650
9651   return var;
9652 }
9653
9654 #endif
9655 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9656 static tree
9657 ffecom_vardesc_dims_ (ffesymbol s)
9658 {
9659   if (ffesymbol_dims (s) == NULL)
9660     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9661                     integer_zero_node);
9662
9663   {
9664     ffebld b;
9665     ffebld e;
9666     tree list;
9667     tree backlist;
9668     tree item = NULL_TREE;
9669     tree var;
9670     int yes;
9671     tree numdim;
9672     tree numelem;
9673     tree baseoff = NULL_TREE;
9674     static int mynumber = 0;
9675
9676     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9677     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9678
9679     numelem = ffecom_expr (ffesymbol_arraysize (s));
9680     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9681
9682     list = NULL_TREE;
9683     backlist = NULL_TREE;
9684     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9685          b != NULL;
9686          b = ffebld_trail (b), e = ffebld_trail (e))
9687       {
9688         tree t;
9689         tree low;
9690         tree back;
9691
9692         if (ffebld_trail (b) == NULL)
9693           t = NULL_TREE;
9694         else
9695           {
9696             t = convert (ffecom_f2c_ftnlen_type_node,
9697                          ffecom_expr (ffebld_head (e)));
9698
9699             if (list == NULL_TREE)
9700               list = item = build_tree_list (NULL_TREE, t);
9701             else
9702               {
9703                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9704                 item = TREE_CHAIN (item);
9705               }
9706           }
9707
9708         if (ffebld_left (ffebld_head (b)) == NULL)
9709           low = ffecom_integer_one_node;
9710         else
9711           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9712         low = convert (ffecom_f2c_ftnlen_type_node, low);
9713
9714         back = build_tree_list (low, t);
9715         TREE_CHAIN (back) = backlist;
9716         backlist = back;
9717       }
9718
9719     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9720       {
9721         if (TREE_VALUE (item) == NULL_TREE)
9722           baseoff = TREE_PURPOSE (item);
9723         else
9724           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9725                               TREE_PURPOSE (item),
9726                               ffecom_2 (MULT_EXPR,
9727                                         ffecom_f2c_ftnlen_type_node,
9728                                         TREE_VALUE (item),
9729                                         baseoff));
9730       }
9731
9732     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9733
9734     baseoff = build_tree_list (NULL_TREE, baseoff);
9735     TREE_CHAIN (baseoff) = list;
9736
9737     numelem = build_tree_list (NULL_TREE, numelem);
9738     TREE_CHAIN (numelem) = baseoff;
9739
9740     numdim = build_tree_list (NULL_TREE, numdim);
9741     TREE_CHAIN (numdim) = numelem;
9742
9743     yes = suspend_momentary ();
9744
9745     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9746                              build_range_type (integer_type_node,
9747                                                integer_zero_node,
9748                                                build_int_2
9749                                                ((int) ffesymbol_rank (s)
9750                                                 + 2, 0)));
9751     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9752     TREE_CONSTANT (list) = 1;
9753     TREE_STATIC (list) = 1;
9754
9755     var = ffecom_get_invented_identifier ("__g77_dims_%d", NULL,
9756                                           mynumber++);
9757     var = build_decl (VAR_DECL, var, item);
9758     TREE_STATIC (var) = 1;
9759     DECL_INITIAL (var) = error_mark_node;
9760     var = start_decl (var, FALSE);
9761     finish_decl (var, list, FALSE);
9762
9763     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9764
9765     resume_momentary (yes);
9766
9767     return var;
9768   }
9769 }
9770
9771 #endif
9772 /* Essentially does a "fold (build1 (code, type, node))" while checking
9773    for certain housekeeping things.
9774
9775    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9776    ffecom_1_fn instead.  */
9777
9778 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9779 tree
9780 ffecom_1 (enum tree_code code, tree type, tree node)
9781 {
9782   tree item;
9783
9784   if ((node == error_mark_node)
9785       || (type == error_mark_node))
9786     return error_mark_node;
9787
9788   if (code == ADDR_EXPR)
9789     {
9790       if (!mark_addressable (node))
9791         assert ("can't mark_addressable this node!" == NULL);
9792     }
9793
9794   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9795     {
9796       tree realtype;
9797
9798     case REALPART_EXPR:
9799       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9800       break;
9801
9802     case IMAGPART_EXPR:
9803       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9804       break;
9805
9806
9807     case NEGATE_EXPR:
9808       if (TREE_CODE (type) != RECORD_TYPE)
9809         {
9810           item = build1 (code, type, node);
9811           break;
9812         }
9813       node = ffecom_stabilize_aggregate_ (node);
9814       realtype = TREE_TYPE (TYPE_FIELDS (type));
9815       item =
9816         ffecom_2 (COMPLEX_EXPR, type,
9817                   ffecom_1 (NEGATE_EXPR, realtype,
9818                             ffecom_1 (REALPART_EXPR, realtype,
9819                                       node)),
9820                   ffecom_1 (NEGATE_EXPR, realtype,
9821                             ffecom_1 (IMAGPART_EXPR, realtype,
9822                                       node)));
9823       break;
9824
9825     default:
9826       item = build1 (code, type, node);
9827       break;
9828     }
9829
9830   if (TREE_SIDE_EFFECTS (node))
9831     TREE_SIDE_EFFECTS (item) = 1;
9832   if ((code == ADDR_EXPR) && staticp (node))
9833     TREE_CONSTANT (item) = 1;
9834   return fold (item);
9835 }
9836 #endif
9837
9838 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9839    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9840    does not set TREE_ADDRESSABLE (because calling an inline
9841    function does not mean the function needs to be separately
9842    compiled).  */
9843
9844 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9845 tree
9846 ffecom_1_fn (tree node)
9847 {
9848   tree item;
9849   tree type;
9850
9851   if (node == error_mark_node)
9852     return error_mark_node;
9853
9854   type = build_type_variant (TREE_TYPE (node),
9855                              TREE_READONLY (node),
9856                              TREE_THIS_VOLATILE (node));
9857   item = build1 (ADDR_EXPR,
9858                  build_pointer_type (type), node);
9859   if (TREE_SIDE_EFFECTS (node))
9860     TREE_SIDE_EFFECTS (item) = 1;
9861   if (staticp (node))
9862     TREE_CONSTANT (item) = 1;
9863   return fold (item);
9864 }
9865 #endif
9866
9867 /* Essentially does a "fold (build (code, type, node1, node2))" while
9868    checking for certain housekeeping things.  */
9869
9870 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9871 tree
9872 ffecom_2 (enum tree_code code, tree type, tree node1,
9873           tree node2)
9874 {
9875   tree item;
9876
9877   if ((node1 == error_mark_node)
9878       || (node2 == error_mark_node)
9879       || (type == error_mark_node))
9880     return error_mark_node;
9881
9882   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9883     {
9884       tree a, b, c, d, realtype;
9885
9886     case CONJ_EXPR:
9887       assert ("no CONJ_EXPR support yet" == NULL);
9888       return error_mark_node;
9889
9890     case COMPLEX_EXPR:
9891       item = build_tree_list (TYPE_FIELDS (type), node1);
9892       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9893       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9894       break;
9895
9896     case PLUS_EXPR:
9897       if (TREE_CODE (type) != RECORD_TYPE)
9898         {
9899           item = build (code, type, node1, node2);
9900           break;
9901         }
9902       node1 = ffecom_stabilize_aggregate_ (node1);
9903       node2 = ffecom_stabilize_aggregate_ (node2);
9904       realtype = TREE_TYPE (TYPE_FIELDS (type));
9905       item =
9906         ffecom_2 (COMPLEX_EXPR, type,
9907                   ffecom_2 (PLUS_EXPR, realtype,
9908                             ffecom_1 (REALPART_EXPR, realtype,
9909                                       node1),
9910                             ffecom_1 (REALPART_EXPR, realtype,
9911                                       node2)),
9912                   ffecom_2 (PLUS_EXPR, realtype,
9913                             ffecom_1 (IMAGPART_EXPR, realtype,
9914                                       node1),
9915                             ffecom_1 (IMAGPART_EXPR, realtype,
9916                                       node2)));
9917       break;
9918
9919     case MINUS_EXPR:
9920       if (TREE_CODE (type) != RECORD_TYPE)
9921         {
9922           item = build (code, type, node1, node2);
9923           break;
9924         }
9925       node1 = ffecom_stabilize_aggregate_ (node1);
9926       node2 = ffecom_stabilize_aggregate_ (node2);
9927       realtype = TREE_TYPE (TYPE_FIELDS (type));
9928       item =
9929         ffecom_2 (COMPLEX_EXPR, type,
9930                   ffecom_2 (MINUS_EXPR, realtype,
9931                             ffecom_1 (REALPART_EXPR, realtype,
9932                                       node1),
9933                             ffecom_1 (REALPART_EXPR, realtype,
9934                                       node2)),
9935                   ffecom_2 (MINUS_EXPR, realtype,
9936                             ffecom_1 (IMAGPART_EXPR, realtype,
9937                                       node1),
9938                             ffecom_1 (IMAGPART_EXPR, realtype,
9939                                       node2)));
9940       break;
9941
9942     case MULT_EXPR:
9943       if (TREE_CODE (type) != RECORD_TYPE)
9944         {
9945           item = build (code, type, node1, node2);
9946           break;
9947         }
9948       node1 = ffecom_stabilize_aggregate_ (node1);
9949       node2 = ffecom_stabilize_aggregate_ (node2);
9950       realtype = TREE_TYPE (TYPE_FIELDS (type));
9951       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9952                                node1));
9953       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9954                                node1));
9955       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9956                                node2));
9957       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9958                                node2));
9959       item =
9960         ffecom_2 (COMPLEX_EXPR, type,
9961                   ffecom_2 (MINUS_EXPR, realtype,
9962                             ffecom_2 (MULT_EXPR, realtype,
9963                                       a,
9964                                       c),
9965                             ffecom_2 (MULT_EXPR, realtype,
9966                                       b,
9967                                       d)),
9968                   ffecom_2 (PLUS_EXPR, realtype,
9969                             ffecom_2 (MULT_EXPR, realtype,
9970                                       a,
9971                                       d),
9972                             ffecom_2 (MULT_EXPR, realtype,
9973                                       c,
9974                                       b)));
9975       break;
9976
9977     case EQ_EXPR:
9978       if ((TREE_CODE (node1) != RECORD_TYPE)
9979           && (TREE_CODE (node2) != RECORD_TYPE))
9980         {
9981           item = build (code, type, node1, node2);
9982           break;
9983         }
9984       assert (TREE_CODE (node1) == RECORD_TYPE);
9985       assert (TREE_CODE (node2) == RECORD_TYPE);
9986       node1 = ffecom_stabilize_aggregate_ (node1);
9987       node2 = ffecom_stabilize_aggregate_ (node2);
9988       realtype = TREE_TYPE (TYPE_FIELDS (type));
9989       item =
9990         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9991                   ffecom_2 (code, type,
9992                             ffecom_1 (REALPART_EXPR, realtype,
9993                                       node1),
9994                             ffecom_1 (REALPART_EXPR, realtype,
9995                                       node2)),
9996                   ffecom_2 (code, type,
9997                             ffecom_1 (IMAGPART_EXPR, realtype,
9998                                       node1),
9999                             ffecom_1 (IMAGPART_EXPR, realtype,
10000                                       node2)));
10001       break;
10002
10003     case NE_EXPR:
10004       if ((TREE_CODE (node1) != RECORD_TYPE)
10005           && (TREE_CODE (node2) != RECORD_TYPE))
10006         {
10007           item = build (code, type, node1, node2);
10008           break;
10009         }
10010       assert (TREE_CODE (node1) == RECORD_TYPE);
10011       assert (TREE_CODE (node2) == RECORD_TYPE);
10012       node1 = ffecom_stabilize_aggregate_ (node1);
10013       node2 = ffecom_stabilize_aggregate_ (node2);
10014       realtype = TREE_TYPE (TYPE_FIELDS (type));
10015       item =
10016         ffecom_2 (TRUTH_ORIF_EXPR, type,
10017                   ffecom_2 (code, type,
10018                             ffecom_1 (REALPART_EXPR, realtype,
10019                                       node1),
10020                             ffecom_1 (REALPART_EXPR, realtype,
10021                                       node2)),
10022                   ffecom_2 (code, type,
10023                             ffecom_1 (IMAGPART_EXPR, realtype,
10024                                       node1),
10025                             ffecom_1 (IMAGPART_EXPR, realtype,
10026                                       node2)));
10027       break;
10028
10029     default:
10030       item = build (code, type, node1, node2);
10031       break;
10032     }
10033
10034   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
10035     TREE_SIDE_EFFECTS (item) = 1;
10036   return fold (item);
10037 }
10038
10039 #endif
10040 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
10041
10042    ffesymbol s;  // the ENTRY point itself
10043    if (ffecom_2pass_advise_entrypoint(s))
10044        // the ENTRY point has been accepted
10045
10046    Does whatever compiler needs to do when it learns about the entrypoint,
10047    like determine the return type of the master function, count the
10048    number of entrypoints, etc.  Returns FALSE if the return type is
10049    not compatible with the return type(s) of other entrypoint(s).
10050
10051    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
10052    later (after _finish_progunit) be called with the same entrypoint(s)
10053    as passed to this fn for which TRUE was returned.
10054
10055    03-Jan-92  JCB  2.0
10056       Return FALSE if the return type conflicts with previous entrypoints.  */
10057
10058 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10059 bool
10060 ffecom_2pass_advise_entrypoint (ffesymbol entry)
10061 {
10062   ffebld list;                  /* opITEM. */
10063   ffebld mlist;                 /* opITEM. */
10064   ffebld plist;                 /* opITEM. */
10065   ffebld arg;                   /* ffebld_head(opITEM). */
10066   ffebld item;                  /* opITEM. */
10067   ffesymbol s;                  /* ffebld_symter(arg). */
10068   ffeinfoBasictype bt = ffesymbol_basictype (entry);
10069   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
10070   ffetargetCharacterSize size = ffesymbol_size (entry);
10071   bool ok;
10072
10073   if (ffecom_num_entrypoints_ == 0)
10074     {                           /* First entrypoint, make list of main
10075                                    arglist's dummies. */
10076       assert (ffecom_primary_entry_ != NULL);
10077
10078       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
10079       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
10080       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
10081
10082       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
10083            list != NULL;
10084            list = ffebld_trail (list))
10085         {
10086           arg = ffebld_head (list);
10087           if (ffebld_op (arg) != FFEBLD_opSYMTER)
10088             continue;           /* Alternate return or some such thing. */
10089           item = ffebld_new_item (arg, NULL);
10090           if (plist == NULL)
10091             ffecom_master_arglist_ = item;
10092           else
10093             ffebld_set_trail (plist, item);
10094           plist = item;
10095         }
10096     }
10097
10098   /* If necessary, scan entry arglist for alternate returns.  Do this scan
10099      apparently redundantly (it's done below to UNIONize the arglists) so
10100      that we don't complain about RETURN 1 if an offending ENTRY is the only
10101      one with an alternate return.  */
10102
10103   if (!ffecom_is_altreturning_)
10104     {
10105       for (list = ffesymbol_dummyargs (entry);
10106            list != NULL;
10107            list = ffebld_trail (list))
10108         {
10109           arg = ffebld_head (list);
10110           if (ffebld_op (arg) == FFEBLD_opSTAR)
10111             {
10112               ffecom_is_altreturning_ = TRUE;
10113               break;
10114             }
10115         }
10116     }
10117
10118   /* Now check type compatibility. */
10119
10120   switch (ffecom_master_bt_)
10121     {
10122     case FFEINFO_basictypeNONE:
10123       ok = (bt != FFEINFO_basictypeCHARACTER);
10124       break;
10125
10126     case FFEINFO_basictypeCHARACTER:
10127       ok
10128         = (bt == FFEINFO_basictypeCHARACTER)
10129         && (kt == ffecom_master_kt_)
10130         && (size == ffecom_master_size_);
10131       break;
10132
10133     case FFEINFO_basictypeANY:
10134       return FALSE;             /* Just don't bother. */
10135
10136     default:
10137       if (bt == FFEINFO_basictypeCHARACTER)
10138         {
10139           ok = FALSE;
10140           break;
10141         }
10142       ok = TRUE;
10143       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10144         {
10145           ffecom_master_bt_ = FFEINFO_basictypeNONE;
10146           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10147         }
10148       break;
10149     }
10150
10151   if (!ok)
10152     {
10153       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10154       ffest_ffebad_here_current_stmt (0);
10155       ffebad_finish ();
10156       return FALSE;             /* Can't handle entrypoint. */
10157     }
10158
10159   /* Entrypoint type compatible with previous types. */
10160
10161   ++ffecom_num_entrypoints_;
10162
10163   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10164
10165   for (list = ffesymbol_dummyargs (entry);
10166        list != NULL;
10167        list = ffebld_trail (list))
10168     {
10169       arg = ffebld_head (list);
10170       if (ffebld_op (arg) != FFEBLD_opSYMTER)
10171         continue;               /* Alternate return or some such thing. */
10172       s = ffebld_symter (arg);
10173       for (plist = NULL, mlist = ffecom_master_arglist_;
10174            mlist != NULL;
10175            plist = mlist, mlist = ffebld_trail (mlist))
10176         {                       /* plist points to previous item for easy
10177                                    appending of arg. */
10178           if (ffebld_symter (ffebld_head (mlist)) == s)
10179             break;              /* Already have this arg in the master list. */
10180         }
10181       if (mlist != NULL)
10182         continue;               /* Already have this arg in the master list. */
10183
10184       /* Append this arg to the master list. */
10185
10186       item = ffebld_new_item (arg, NULL);
10187       if (plist == NULL)
10188         ffecom_master_arglist_ = item;
10189       else
10190         ffebld_set_trail (plist, item);
10191     }
10192
10193   return TRUE;
10194 }
10195
10196 #endif
10197 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10198
10199    ffesymbol s;  // the ENTRY point itself
10200    ffecom_2pass_do_entrypoint(s);
10201
10202    Does whatever compiler needs to do to make the entrypoint actually
10203    happen.  Must be called for each entrypoint after
10204    ffecom_finish_progunit is called.  */
10205
10206 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10207 void
10208 ffecom_2pass_do_entrypoint (ffesymbol entry)
10209 {
10210   static int mfn_num = 0;
10211   static int ent_num;
10212
10213   if (mfn_num != ffecom_num_fns_)
10214     {                           /* First entrypoint for this program unit. */
10215       ent_num = 1;
10216       mfn_num = ffecom_num_fns_;
10217       ffecom_do_entry_ (ffecom_primary_entry_, 0);
10218     }
10219   else
10220     ++ent_num;
10221
10222   --ffecom_num_entrypoints_;
10223
10224   ffecom_do_entry_ (entry, ent_num);
10225 }
10226
10227 #endif
10228
10229 /* Essentially does a "fold (build (code, type, node1, node2))" while
10230    checking for certain housekeeping things.  Always sets
10231    TREE_SIDE_EFFECTS.  */
10232
10233 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10234 tree
10235 ffecom_2s (enum tree_code code, tree type, tree node1,
10236            tree node2)
10237 {
10238   tree item;
10239
10240   if ((node1 == error_mark_node)
10241       || (node2 == error_mark_node)
10242       || (type == error_mark_node))
10243     return error_mark_node;
10244
10245   item = build (code, type, node1, node2);
10246   TREE_SIDE_EFFECTS (item) = 1;
10247   return fold (item);
10248 }
10249
10250 #endif
10251 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10252    checking for certain housekeeping things.  */
10253
10254 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10255 tree
10256 ffecom_3 (enum tree_code code, tree type, tree node1,
10257           tree node2, tree node3)
10258 {
10259   tree item;
10260
10261   if ((node1 == error_mark_node)
10262       || (node2 == error_mark_node)
10263       || (node3 == error_mark_node)
10264       || (type == error_mark_node))
10265     return error_mark_node;
10266
10267   item = build (code, type, node1, node2, node3);
10268   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10269       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10270     TREE_SIDE_EFFECTS (item) = 1;
10271   return fold (item);
10272 }
10273
10274 #endif
10275 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10276    checking for certain housekeeping things.  Always sets
10277    TREE_SIDE_EFFECTS.  */
10278
10279 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10280 tree
10281 ffecom_3s (enum tree_code code, tree type, tree node1,
10282            tree node2, tree node3)
10283 {
10284   tree item;
10285
10286   if ((node1 == error_mark_node)
10287       || (node2 == error_mark_node)
10288       || (node3 == error_mark_node)
10289       || (type == error_mark_node))
10290     return error_mark_node;
10291
10292   item = build (code, type, node1, node2, node3);
10293   TREE_SIDE_EFFECTS (item) = 1;
10294   return fold (item);
10295 }
10296
10297 #endif
10298
10299 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10300
10301    See use by ffecom_list_expr.
10302
10303    If expression is NULL, returns an integer zero tree.  If it is not
10304    a CHARACTER expression, returns whatever ffecom_expr
10305    returns and sets the length return value to NULL_TREE.  Otherwise
10306    generates code to evaluate the character expression, returns the proper
10307    pointer to the result, but does NOT set the length return value to a tree
10308    that specifies the length of the result.  (In other words, the length
10309    variable is always set to NULL_TREE, because a length is never passed.)
10310
10311    21-Dec-91  JCB  1.1
10312       Don't set returned length, since nobody needs it (yet; someday if
10313       we allow CHARACTER*(*) dummies to statement functions, we'll need
10314       it).  */
10315
10316 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10317 tree
10318 ffecom_arg_expr (ffebld expr, tree *length)
10319 {
10320   tree ign;
10321
10322   *length = NULL_TREE;
10323
10324   if (expr == NULL)
10325     return integer_zero_node;
10326
10327   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10328     return ffecom_expr (expr);
10329
10330   return ffecom_arg_ptr_to_expr (expr, &ign);
10331 }
10332
10333 #endif
10334 /* Transform expression into constant argument-pointer-to-expression tree.
10335
10336    If the expression can be transformed into a argument-pointer-to-expression
10337    tree that is constant, that is done, and the tree returned.  Else
10338    NULL_TREE is returned.
10339
10340    That way, a caller can attempt to provide compile-time initialization
10341    of a variable and, if that fails, *then* choose to start a new block
10342    and resort to using temporaries, as appropriate.  */
10343
10344 tree
10345 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10346 {
10347   if (! expr)
10348     return integer_zero_node;
10349
10350   if (ffebld_op (expr) == FFEBLD_opANY)
10351     {
10352       if (length)
10353         *length = error_mark_node;
10354       return error_mark_node;
10355     }
10356
10357   if (ffebld_arity (expr) == 0
10358       && (ffebld_op (expr) != FFEBLD_opSYMTER
10359           || ffebld_where (expr) == FFEINFO_whereCOMMON
10360           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10361           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10362     {
10363       tree t;
10364
10365       t = ffecom_arg_ptr_to_expr (expr, length);
10366       assert (TREE_CONSTANT (t));
10367       assert (! length || TREE_CONSTANT (*length));
10368       return t;
10369     }
10370
10371   if (length
10372       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10373     *length = build_int_2 (ffebld_size (expr), 0);
10374   else if (length)
10375     *length = NULL_TREE;
10376   return NULL_TREE;
10377 }
10378
10379 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10380
10381    See use by ffecom_list_ptr_to_expr.
10382
10383    If expression is NULL, returns an integer zero tree.  If it is not
10384    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10385    returns and sets the length return value to NULL_TREE.  Otherwise
10386    generates code to evaluate the character expression, returns the proper
10387    pointer to the result, AND sets the length return value to a tree that
10388    specifies the length of the result.
10389
10390    If the length argument is NULL, this is a slightly special
10391    case of building a FORMAT expression, that is, an expression that
10392    will be used at run time without regard to length.  For the current
10393    implementation, which uses the libf2c library, this means it is nice
10394    to append a null byte to the end of the expression, where feasible,
10395    to make sure any diagnostic about the FORMAT string terminates at
10396    some useful point.
10397
10398    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10399    length argument.  This might even be seen as a feature, if a null
10400    byte can always be appended.  */
10401
10402 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10403 tree
10404 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10405 {
10406   tree item;
10407   tree ign_length;
10408   ffecomConcatList_ catlist;
10409
10410   if (length != NULL)
10411     *length = NULL_TREE;
10412
10413   if (expr == NULL)
10414     return integer_zero_node;
10415
10416   switch (ffebld_op (expr))
10417     {
10418     case FFEBLD_opPERCENT_VAL:
10419       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10420         return ffecom_expr (ffebld_left (expr));
10421       {
10422         tree temp_exp;
10423         tree temp_length;
10424
10425         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10426         if (temp_exp == error_mark_node)
10427           return error_mark_node;
10428
10429         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10430                          temp_exp);
10431       }
10432
10433     case FFEBLD_opPERCENT_REF:
10434       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10435         return ffecom_ptr_to_expr (ffebld_left (expr));
10436       if (length != NULL)
10437         {
10438           ign_length = NULL_TREE;
10439           length = &ign_length;
10440         }
10441       expr = ffebld_left (expr);
10442       break;
10443
10444     case FFEBLD_opPERCENT_DESCR:
10445       switch (ffeinfo_basictype (ffebld_info (expr)))
10446         {
10447 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10448         case FFEINFO_basictypeHOLLERITH:
10449 #endif
10450         case FFEINFO_basictypeCHARACTER:
10451           break;                /* Passed by descriptor anyway. */
10452
10453         default:
10454           item = ffecom_ptr_to_expr (expr);
10455           if (item != error_mark_node)
10456             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10457           break;
10458         }
10459       break;
10460
10461     default:
10462       break;
10463     }
10464
10465 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10466   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10467       && (length != NULL))
10468     {                           /* Pass Hollerith by descriptor. */
10469       ffetargetHollerith h;
10470
10471       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10472       h = ffebld_cu_val_hollerith (ffebld_constant_union
10473                                    (ffebld_conter (expr)));
10474       *length
10475         = build_int_2 (h.length, 0);
10476       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10477     }
10478 #endif
10479
10480   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10481     return ffecom_ptr_to_expr (expr);
10482
10483   assert (ffeinfo_kindtype (ffebld_info (expr))
10484           == FFEINFO_kindtypeCHARACTER1);
10485
10486   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10487   switch (ffecom_concat_list_count_ (catlist))
10488     {
10489     case 0:                     /* Shouldn't happen, but in case it does... */
10490       if (length != NULL)
10491         {
10492           *length = ffecom_f2c_ftnlen_zero_node;
10493           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10494         }
10495       ffecom_concat_list_kill_ (catlist);
10496       return null_pointer_node;
10497
10498     case 1:                     /* The (fairly) easy case. */
10499       if (length == NULL)
10500         ffecom_char_args_with_null_ (&item, &ign_length,
10501                                      ffecom_concat_list_expr_ (catlist, 0));
10502       else
10503         ffecom_char_args_ (&item, length,
10504                            ffecom_concat_list_expr_ (catlist, 0));
10505       ffecom_concat_list_kill_ (catlist);
10506       assert (item != NULL_TREE);
10507       return item;
10508
10509     default:                    /* Must actually concatenate things. */
10510       break;
10511     }
10512
10513   {
10514     int count = ffecom_concat_list_count_ (catlist);
10515     int i;
10516     tree lengths;
10517     tree items;
10518     tree length_array;
10519     tree item_array;
10520     tree citem;
10521     tree clength;
10522     tree temporary;
10523     tree num;
10524     tree known_length;
10525     ffetargetCharacterSize sz;
10526
10527     sz = ffecom_concat_list_maxlen_ (catlist);
10528     /* ~~Kludge! */
10529     assert (sz != FFETARGET_charactersizeNONE);
10530
10531 #ifdef HOHO
10532     length_array
10533       = lengths
10534       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10535                              FFETARGET_charactersizeNONE, count, TRUE);
10536     item_array
10537       = items
10538       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10539                              FFETARGET_charactersizeNONE, count, TRUE);
10540     temporary = ffecom_push_tempvar (char_type_node,
10541                                      sz, -1, TRUE);
10542 #else
10543     {
10544       tree hook;
10545
10546       hook = ffebld_nonter_hook (expr);
10547       assert (hook);
10548       assert (TREE_CODE (hook) == TREE_VEC);
10549       assert (TREE_VEC_LENGTH (hook) == 3);
10550       length_array = lengths = TREE_VEC_ELT (hook, 0);
10551       item_array = items = TREE_VEC_ELT (hook, 1);
10552       temporary = TREE_VEC_ELT (hook, 2);
10553     }
10554 #endif
10555
10556     known_length = ffecom_f2c_ftnlen_zero_node;
10557
10558     for (i = 0; i < count; ++i)
10559       {
10560         if ((i == count)
10561             && (length == NULL))
10562           ffecom_char_args_with_null_ (&citem, &clength,
10563                                        ffecom_concat_list_expr_ (catlist, i));
10564         else
10565           ffecom_char_args_ (&citem, &clength,
10566                              ffecom_concat_list_expr_ (catlist, i));
10567         if ((citem == error_mark_node)
10568             || (clength == error_mark_node))
10569           {
10570             ffecom_concat_list_kill_ (catlist);
10571             *length = error_mark_node;
10572             return error_mark_node;
10573           }
10574
10575         items
10576           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10577                       ffecom_modify (void_type_node,
10578                                      ffecom_2 (ARRAY_REF,
10579                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10580                                                item_array,
10581                                                build_int_2 (i, 0)),
10582                                      citem),
10583                       items);
10584         clength = ffecom_save_tree (clength);
10585         if (length != NULL)
10586           known_length
10587             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10588                         known_length,
10589                         clength);
10590         lengths
10591           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10592                       ffecom_modify (void_type_node,
10593                                      ffecom_2 (ARRAY_REF,
10594                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10595                                                length_array,
10596                                                build_int_2 (i, 0)),
10597                                      clength),
10598                       lengths);
10599       }
10600
10601     temporary = ffecom_1 (ADDR_EXPR,
10602                           build_pointer_type (TREE_TYPE (temporary)),
10603                           temporary);
10604
10605     item = build_tree_list (NULL_TREE, temporary);
10606     TREE_CHAIN (item)
10607       = build_tree_list (NULL_TREE,
10608                          ffecom_1 (ADDR_EXPR,
10609                                    build_pointer_type (TREE_TYPE (items)),
10610                                    items));
10611     TREE_CHAIN (TREE_CHAIN (item))
10612       = build_tree_list (NULL_TREE,
10613                          ffecom_1 (ADDR_EXPR,
10614                                    build_pointer_type (TREE_TYPE (lengths)),
10615                                    lengths));
10616     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10617       = build_tree_list
10618         (NULL_TREE,
10619          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10620                    convert (ffecom_f2c_ftnlen_type_node,
10621                             build_int_2 (count, 0))));
10622     num = build_int_2 (sz, 0);
10623     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10624     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10625       = build_tree_list (NULL_TREE, num);
10626
10627     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10628     TREE_SIDE_EFFECTS (item) = 1;
10629     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10630                      item,
10631                      temporary);
10632
10633     if (length != NULL)
10634       *length = known_length;
10635   }
10636
10637   ffecom_concat_list_kill_ (catlist);
10638   assert (item != NULL_TREE);
10639   return item;
10640 }
10641
10642 #endif
10643 /* Generate call to run-time function.
10644
10645    The first arg is the GNU Fortran Run-Time function index, the second
10646    arg is the list of arguments to pass to it.  Returned is the expression
10647    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10648    result (which may be void).  */
10649
10650 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10651 tree
10652 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10653 {
10654   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10655                        ffecom_gfrt_kindtype (ix),
10656                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10657                        NULL_TREE, args, NULL_TREE, NULL,
10658                        NULL, NULL_TREE, TRUE, hook);
10659 }
10660 #endif
10661
10662 /* Transform constant-union to tree.  */
10663
10664 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10665 tree
10666 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10667                       ffeinfoKindtype kt, tree tree_type)
10668 {
10669   tree item;
10670
10671   switch (bt)
10672     {
10673     case FFEINFO_basictypeINTEGER:
10674       {
10675         int val;
10676
10677         switch (kt)
10678           {
10679 #if FFETARGET_okINTEGER1
10680           case FFEINFO_kindtypeINTEGER1:
10681             val = ffebld_cu_val_integer1 (*cu);
10682             break;
10683 #endif
10684
10685 #if FFETARGET_okINTEGER2
10686           case FFEINFO_kindtypeINTEGER2:
10687             val = ffebld_cu_val_integer2 (*cu);
10688             break;
10689 #endif
10690
10691 #if FFETARGET_okINTEGER3
10692           case FFEINFO_kindtypeINTEGER3:
10693             val = ffebld_cu_val_integer3 (*cu);
10694             break;
10695 #endif
10696
10697 #if FFETARGET_okINTEGER4
10698           case FFEINFO_kindtypeINTEGER4:
10699             val = ffebld_cu_val_integer4 (*cu);
10700             break;
10701 #endif
10702
10703           default:
10704             assert ("bad INTEGER constant kind type" == NULL);
10705             /* Fall through. */
10706           case FFEINFO_kindtypeANY:
10707             return error_mark_node;
10708           }
10709         item = build_int_2 (val, (val < 0) ? -1 : 0);
10710         TREE_TYPE (item) = tree_type;
10711       }
10712       break;
10713
10714     case FFEINFO_basictypeLOGICAL:
10715       {
10716         int val;
10717
10718         switch (kt)
10719           {
10720 #if FFETARGET_okLOGICAL1
10721           case FFEINFO_kindtypeLOGICAL1:
10722             val = ffebld_cu_val_logical1 (*cu);
10723             break;
10724 #endif
10725
10726 #if FFETARGET_okLOGICAL2
10727           case FFEINFO_kindtypeLOGICAL2:
10728             val = ffebld_cu_val_logical2 (*cu);
10729             break;
10730 #endif
10731
10732 #if FFETARGET_okLOGICAL3
10733           case FFEINFO_kindtypeLOGICAL3:
10734             val = ffebld_cu_val_logical3 (*cu);
10735             break;
10736 #endif
10737
10738 #if FFETARGET_okLOGICAL4
10739           case FFEINFO_kindtypeLOGICAL4:
10740             val = ffebld_cu_val_logical4 (*cu);
10741             break;
10742 #endif
10743
10744           default:
10745             assert ("bad LOGICAL constant kind type" == NULL);
10746             /* Fall through. */
10747           case FFEINFO_kindtypeANY:
10748             return error_mark_node;
10749           }
10750         item = build_int_2 (val, (val < 0) ? -1 : 0);
10751         TREE_TYPE (item) = tree_type;
10752       }
10753       break;
10754
10755     case FFEINFO_basictypeREAL:
10756       {
10757         REAL_VALUE_TYPE val;
10758
10759         switch (kt)
10760           {
10761 #if FFETARGET_okREAL1
10762           case FFEINFO_kindtypeREAL1:
10763             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10764             break;
10765 #endif
10766
10767 #if FFETARGET_okREAL2
10768           case FFEINFO_kindtypeREAL2:
10769             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10770             break;
10771 #endif
10772
10773 #if FFETARGET_okREAL3
10774           case FFEINFO_kindtypeREAL3:
10775             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10776             break;
10777 #endif
10778
10779 #if FFETARGET_okREAL4
10780           case FFEINFO_kindtypeREAL4:
10781             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10782             break;
10783 #endif
10784
10785           default:
10786             assert ("bad REAL constant kind type" == NULL);
10787             /* Fall through. */
10788           case FFEINFO_kindtypeANY:
10789             return error_mark_node;
10790           }
10791         item = build_real (tree_type, val);
10792       }
10793       break;
10794
10795     case FFEINFO_basictypeCOMPLEX:
10796       {
10797         REAL_VALUE_TYPE real;
10798         REAL_VALUE_TYPE imag;
10799         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10800
10801         switch (kt)
10802           {
10803 #if FFETARGET_okCOMPLEX1
10804           case FFEINFO_kindtypeREAL1:
10805             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10806             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10807             break;
10808 #endif
10809
10810 #if FFETARGET_okCOMPLEX2
10811           case FFEINFO_kindtypeREAL2:
10812             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10813             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10814             break;
10815 #endif
10816
10817 #if FFETARGET_okCOMPLEX3
10818           case FFEINFO_kindtypeREAL3:
10819             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10820             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10821             break;
10822 #endif
10823
10824 #if FFETARGET_okCOMPLEX4
10825           case FFEINFO_kindtypeREAL4:
10826             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10827             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10828             break;
10829 #endif
10830
10831           default:
10832             assert ("bad REAL constant kind type" == NULL);
10833             /* Fall through. */
10834           case FFEINFO_kindtypeANY:
10835             return error_mark_node;
10836           }
10837         item = ffecom_build_complex_constant_ (tree_type,
10838                                                build_real (el_type, real),
10839                                                build_real (el_type, imag));
10840       }
10841       break;
10842
10843     case FFEINFO_basictypeCHARACTER:
10844       {                         /* Happens only in DATA and similar contexts. */
10845         ffetargetCharacter1 val;
10846
10847         switch (kt)
10848           {
10849 #if FFETARGET_okCHARACTER1
10850           case FFEINFO_kindtypeLOGICAL1:
10851             val = ffebld_cu_val_character1 (*cu);
10852             break;
10853 #endif
10854
10855           default:
10856             assert ("bad CHARACTER constant kind type" == NULL);
10857             /* Fall through. */
10858           case FFEINFO_kindtypeANY:
10859             return error_mark_node;
10860           }
10861         item = build_string (ffetarget_length_character1 (val),
10862                              ffetarget_text_character1 (val));
10863         TREE_TYPE (item)
10864           = build_type_variant (build_array_type (char_type_node,
10865                                                   build_range_type
10866                                                   (integer_type_node,
10867                                                    integer_one_node,
10868                                                    build_int_2
10869                                                 (ffetarget_length_character1
10870                                                  (val), 0))),
10871                                 1, 0);
10872       }
10873       break;
10874
10875     case FFEINFO_basictypeHOLLERITH:
10876       {
10877         ffetargetHollerith h;
10878
10879         h = ffebld_cu_val_hollerith (*cu);
10880
10881         /* If not at least as wide as default INTEGER, widen it.  */
10882         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10883           item = build_string (h.length, h.text);
10884         else
10885           {
10886             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10887
10888             memcpy (str, h.text, h.length);
10889             memset (&str[h.length], ' ',
10890                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10891                     - h.length);
10892             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10893                                  str);
10894           }
10895         TREE_TYPE (item)
10896           = build_type_variant (build_array_type (char_type_node,
10897                                                   build_range_type
10898                                                   (integer_type_node,
10899                                                    integer_one_node,
10900                                                    build_int_2
10901                                                    (h.length, 0))),
10902                                 1, 0);
10903       }
10904       break;
10905
10906     case FFEINFO_basictypeTYPELESS:
10907       {
10908         ffetargetInteger1 ival;
10909         ffetargetTypeless tless;
10910         ffebad error;
10911
10912         tless = ffebld_cu_val_typeless (*cu);
10913         error = ffetarget_convert_integer1_typeless (&ival, tless);
10914         assert (error == FFEBAD);
10915
10916         item = build_int_2 ((int) ival, 0);
10917       }
10918       break;
10919
10920     default:
10921       assert ("not yet on constant type" == NULL);
10922       /* Fall through. */
10923     case FFEINFO_basictypeANY:
10924       return error_mark_node;
10925     }
10926
10927   TREE_CONSTANT (item) = 1;
10928
10929   return item;
10930 }
10931
10932 #endif
10933
10934 /* Transform expression into constant tree.
10935
10936    If the expression can be transformed into a tree that is constant,
10937    that is done, and the tree returned.  Else NULL_TREE is returned.
10938
10939    That way, a caller can attempt to provide compile-time initialization
10940    of a variable and, if that fails, *then* choose to start a new block
10941    and resort to using temporaries, as appropriate.  */
10942
10943 tree
10944 ffecom_const_expr (ffebld expr)
10945 {
10946   if (! expr)
10947     return integer_zero_node;
10948
10949   if (ffebld_op (expr) == FFEBLD_opANY)
10950     return error_mark_node;
10951
10952   if (ffebld_arity (expr) == 0
10953       && (ffebld_op (expr) != FFEBLD_opSYMTER
10954 #if NEWCOMMON
10955           /* ~~Enable once common/equivalence is handled properly?  */
10956           || ffebld_where (expr) == FFEINFO_whereCOMMON
10957 #endif
10958           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10959           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10960     {
10961       tree t;
10962
10963       t = ffecom_expr (expr);
10964       assert (TREE_CONSTANT (t));
10965       return t;
10966     }
10967
10968   return NULL_TREE;
10969 }
10970
10971 /* Handy way to make a field in a struct/union.  */
10972
10973 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10974 tree
10975 ffecom_decl_field (tree context, tree prevfield,
10976                    const char *name, tree type)
10977 {
10978   tree field;
10979
10980   field = build_decl (FIELD_DECL, get_identifier (name), type);
10981   DECL_CONTEXT (field) = context;
10982   DECL_FRAME_SIZE (field) = 0;
10983   if (prevfield != NULL_TREE)
10984     TREE_CHAIN (prevfield) = field;
10985
10986   return field;
10987 }
10988
10989 #endif
10990
10991 void
10992 ffecom_close_include (FILE *f)
10993 {
10994 #if FFECOM_GCC_INCLUDE
10995   ffecom_close_include_ (f);
10996 #endif
10997 }
10998
10999 int
11000 ffecom_decode_include_option (char *spec)
11001 {
11002 #if FFECOM_GCC_INCLUDE
11003   return ffecom_decode_include_option_ (spec);
11004 #else
11005   return 1;
11006 #endif
11007 }
11008
11009 /* End a compound statement (block).  */
11010
11011 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11012 tree
11013 ffecom_end_compstmt (void)
11014 {
11015   return bison_rule_compstmt_ ();
11016 }
11017 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
11018
11019 /* ffecom_end_transition -- Perform end transition on all symbols
11020
11021    ffecom_end_transition();
11022
11023    Calls ffecom_sym_end_transition for each global and local symbol.  */
11024
11025 void
11026 ffecom_end_transition ()
11027 {
11028 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11029   ffebld item;
11030 #endif
11031
11032   if (ffe_is_ffedebug ())
11033     fprintf (dmpout, "; end_stmt_transition\n");
11034
11035 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11036   ffecom_list_blockdata_ = NULL;
11037   ffecom_list_common_ = NULL;
11038 #endif
11039
11040   ffesymbol_drive (ffecom_sym_end_transition);
11041   if (ffe_is_ffedebug ())
11042     {
11043       ffestorag_report ();
11044 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11045       ffesymbol_report_all ();
11046 #endif
11047     }
11048
11049 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11050   ffecom_start_progunit_ ();
11051
11052   for (item = ffecom_list_blockdata_;
11053        item != NULL;
11054        item = ffebld_trail (item))
11055     {
11056       ffebld callee;
11057       ffesymbol s;
11058       tree dt;
11059       tree t;
11060       tree var;
11061       int yes;
11062       static int number = 0;
11063
11064       callee = ffebld_head (item);
11065       s = ffebld_symter (callee);
11066       t = ffesymbol_hook (s).decl_tree;
11067       if (t == NULL_TREE)
11068         {
11069           s = ffecom_sym_transform_ (s);
11070           t = ffesymbol_hook (s).decl_tree;
11071         }
11072
11073       yes = suspend_momentary ();
11074
11075       dt = build_pointer_type (TREE_TYPE (t));
11076
11077       var = build_decl (VAR_DECL,
11078                         ffecom_get_invented_identifier ("__g77_forceload_%d",
11079                                                         NULL, number++),
11080                         dt);
11081       DECL_EXTERNAL (var) = 0;
11082       TREE_STATIC (var) = 1;
11083       TREE_PUBLIC (var) = 0;
11084       DECL_INITIAL (var) = error_mark_node;
11085       TREE_USED (var) = 1;
11086
11087       var = start_decl (var, FALSE);
11088
11089       t = ffecom_1 (ADDR_EXPR, dt, t);
11090
11091       finish_decl (var, t, FALSE);
11092
11093       resume_momentary (yes);
11094     }
11095
11096   /* This handles any COMMON areas that weren't referenced but have, for
11097      example, important initial data.  */
11098
11099   for (item = ffecom_list_common_;
11100        item != NULL;
11101        item = ffebld_trail (item))
11102     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
11103
11104   ffecom_list_common_ = NULL;
11105 #endif
11106 }
11107
11108 /* ffecom_exec_transition -- Perform exec transition on all symbols
11109
11110    ffecom_exec_transition();
11111
11112    Calls ffecom_sym_exec_transition for each global and local symbol.
11113    Make sure error updating not inhibited.  */
11114
11115 void
11116 ffecom_exec_transition ()
11117 {
11118   bool inhibited;
11119
11120   if (ffe_is_ffedebug ())
11121     fprintf (dmpout, "; exec_stmt_transition\n");
11122
11123   inhibited = ffebad_inhibit ();
11124   ffebad_set_inhibit (FALSE);
11125
11126   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
11127   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
11128   if (ffe_is_ffedebug ())
11129     {
11130       ffestorag_report ();
11131 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11132       ffesymbol_report_all ();
11133 #endif
11134     }
11135
11136   if (inhibited)
11137     ffebad_set_inhibit (TRUE);
11138 }
11139
11140 /* Handle assignment statement.
11141
11142    Convert dest and source using ffecom_expr, then join them
11143    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
11144
11145 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11146 void
11147 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11148 {
11149   tree dest_tree;
11150   tree dest_length;
11151   tree source_tree;
11152   tree expr_tree;
11153
11154   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11155     {
11156       bool dest_used;
11157
11158       /* This attempts to replicate the test below, but must not be
11159          true when the test below is false.  (Always err on the side
11160          of creating unused temporaries, to avoid ICEs.)  */
11161       if (ffebld_op (dest) != FFEBLD_opSYMTER
11162           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11163               && (TREE_CODE (dest_tree) != VAR_DECL
11164                   || TREE_ADDRESSABLE (dest_tree))))
11165         {
11166           ffecom_prepare_expr_ (source, dest);
11167           dest_used = TRUE;
11168         }
11169       else
11170         {
11171           ffecom_prepare_expr_ (source, NULL);
11172           dest_used = FALSE;
11173         }
11174
11175       ffecom_prepare_expr_w (NULL_TREE, dest);
11176
11177       ffecom_prepare_end ();
11178
11179       dest_tree = ffecom_expr_w (NULL_TREE, dest);
11180       if (dest_tree == error_mark_node)
11181         return;
11182
11183       if ((TREE_CODE (dest_tree) != VAR_DECL)
11184           || TREE_ADDRESSABLE (dest_tree))
11185         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11186                                     FALSE, FALSE);
11187       else
11188         {
11189           assert (! dest_used);
11190           dest_used = FALSE;
11191           source_tree = ffecom_expr (source);
11192         }
11193       if (source_tree == error_mark_node)
11194         return;
11195
11196       if (dest_used)
11197         expr_tree = source_tree;
11198       else
11199         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11200                                dest_tree,
11201                                source_tree);
11202
11203       expand_expr_stmt (expr_tree);
11204       return;
11205     }
11206
11207   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11208   ffecom_prepare_expr_w (NULL_TREE, dest);
11209
11210   ffecom_prepare_end ();
11211
11212   ffecom_char_args_ (&dest_tree, &dest_length, dest);
11213   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11214                     source);
11215 }
11216
11217 #endif
11218 /* ffecom_expr -- Transform expr into gcc tree
11219
11220    tree t;
11221    ffebld expr;  // FFE expression.
11222    tree = ffecom_expr(expr);
11223
11224    Recursive descent on expr while making corresponding tree nodes and
11225    attaching type info and such.  */
11226
11227 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11228 tree
11229 ffecom_expr (ffebld expr)
11230 {
11231   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11232 }
11233
11234 #endif
11235 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
11236
11237 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11238 tree
11239 ffecom_expr_assign (ffebld expr)
11240 {
11241   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11242 }
11243
11244 #endif
11245 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
11246
11247 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11248 tree
11249 ffecom_expr_assign_w (ffebld expr)
11250 {
11251   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11252 }
11253
11254 #endif
11255 /* Transform expr for use as into read/write tree and stabilize the
11256    reference.  Not for use on CHARACTER expressions.
11257
11258    Recursive descent on expr while making corresponding tree nodes and
11259    attaching type info and such.  */
11260
11261 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11262 tree
11263 ffecom_expr_rw (tree type, ffebld expr)
11264 {
11265   assert (expr != NULL);
11266   /* Different target types not yet supported.  */
11267   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11268
11269   return stabilize_reference (ffecom_expr (expr));
11270 }
11271
11272 #endif
11273 /* Transform expr for use as into write tree and stabilize the
11274    reference.  Not for use on CHARACTER expressions.
11275
11276    Recursive descent on expr while making corresponding tree nodes and
11277    attaching type info and such.  */
11278
11279 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11280 tree
11281 ffecom_expr_w (tree type, ffebld expr)
11282 {
11283   assert (expr != NULL);
11284   /* Different target types not yet supported.  */
11285   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11286
11287   return stabilize_reference (ffecom_expr (expr));
11288 }
11289
11290 #endif
11291 /* Do global stuff.  */
11292
11293 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11294 void
11295 ffecom_finish_compile ()
11296 {
11297   assert (ffecom_outer_function_decl_ == NULL_TREE);
11298   assert (current_function_decl == NULL_TREE);
11299
11300   ffeglobal_drive (ffecom_finish_global_);
11301 }
11302
11303 #endif
11304 /* Public entry point for front end to access finish_decl.  */
11305
11306 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11307 void
11308 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11309 {
11310   assert (!is_top_level);
11311   finish_decl (decl, init, FALSE);
11312 }
11313
11314 #endif
11315 /* Finish a program unit.  */
11316
11317 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11318 void
11319 ffecom_finish_progunit ()
11320 {
11321   ffecom_end_compstmt ();
11322
11323   ffecom_previous_function_decl_ = current_function_decl;
11324   ffecom_which_entrypoint_decl_ = NULL_TREE;
11325
11326   finish_function (0);
11327 }
11328
11329 #endif
11330 /* Wrapper for get_identifier.  pattern is sprintf-like, assumed to contain
11331    one %s if text is not NULL, assumed to contain one %d if number is
11332    not -1.  If both are assumed, the %s is assumed to precede the %d.  */
11333
11334 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11335 tree
11336 ffecom_get_invented_identifier (const char *pattern, const char *text,
11337                                 int number)
11338 {
11339   tree decl;
11340   char *nam;
11341   mallocSize lenlen;
11342   char space[66];
11343
11344   lenlen = 0;
11345   if (text)
11346     lenlen += strlen (text);
11347   if (number != -1)
11348     lenlen += 20;
11349   if (text || number != -1)
11350     {
11351       lenlen += strlen (pattern);
11352       if (lenlen > ARRAY_SIZE (space))
11353         nam = malloc_new_ks (malloc_pool_image (), pattern, lenlen);
11354       else
11355         nam = &space[0];
11356     }
11357   else
11358     {
11359       lenlen = 0;
11360       nam = (char *) pattern;
11361     }
11362
11363   if (text == NULL)
11364     {
11365       if (number != -1)
11366         sprintf (&nam[0], pattern, number);
11367     }
11368   else
11369     {
11370       if (number == -1)
11371         sprintf (&nam[0], pattern, text);
11372       else
11373         sprintf (&nam[0], pattern, text, number);
11374     }
11375
11376   decl = get_identifier (nam);
11377
11378   if (lenlen > ARRAY_SIZE (space))
11379     malloc_kill_ks (malloc_pool_image (), nam, lenlen);
11380
11381   IDENTIFIER_INVENTED (decl) = 1;
11382
11383   return decl;
11384 }
11385
11386 ffeinfoBasictype
11387 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11388 {
11389   assert (gfrt < FFECOM_gfrt);
11390
11391   switch (ffecom_gfrt_type_[gfrt])
11392     {
11393     case FFECOM_rttypeVOID_:
11394     case FFECOM_rttypeVOIDSTAR_:
11395       return FFEINFO_basictypeNONE;
11396
11397     case FFECOM_rttypeFTNINT_:
11398       return FFEINFO_basictypeINTEGER;
11399
11400     case FFECOM_rttypeINTEGER_:
11401       return FFEINFO_basictypeINTEGER;
11402
11403     case FFECOM_rttypeLONGINT_:
11404       return FFEINFO_basictypeINTEGER;
11405
11406     case FFECOM_rttypeLOGICAL_:
11407       return FFEINFO_basictypeLOGICAL;
11408
11409     case FFECOM_rttypeREAL_F2C_:
11410     case FFECOM_rttypeREAL_GNU_:
11411       return FFEINFO_basictypeREAL;
11412
11413     case FFECOM_rttypeCOMPLEX_F2C_:
11414     case FFECOM_rttypeCOMPLEX_GNU_:
11415       return FFEINFO_basictypeCOMPLEX;
11416
11417     case FFECOM_rttypeDOUBLE_:
11418     case FFECOM_rttypeDOUBLEREAL_:
11419       return FFEINFO_basictypeREAL;
11420
11421     case FFECOM_rttypeDBLCMPLX_F2C_:
11422     case FFECOM_rttypeDBLCMPLX_GNU_:
11423       return FFEINFO_basictypeCOMPLEX;
11424
11425     case FFECOM_rttypeCHARACTER_:
11426       return FFEINFO_basictypeCHARACTER;
11427
11428     default:
11429       return FFEINFO_basictypeANY;
11430     }
11431 }
11432
11433 ffeinfoKindtype
11434 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11435 {
11436   assert (gfrt < FFECOM_gfrt);
11437
11438   switch (ffecom_gfrt_type_[gfrt])
11439     {
11440     case FFECOM_rttypeVOID_:
11441     case FFECOM_rttypeVOIDSTAR_:
11442       return FFEINFO_kindtypeNONE;
11443
11444     case FFECOM_rttypeFTNINT_:
11445       return FFEINFO_kindtypeINTEGER1;
11446
11447     case FFECOM_rttypeINTEGER_:
11448       return FFEINFO_kindtypeINTEGER1;
11449
11450     case FFECOM_rttypeLONGINT_:
11451       return FFEINFO_kindtypeINTEGER4;
11452
11453     case FFECOM_rttypeLOGICAL_:
11454       return FFEINFO_kindtypeLOGICAL1;
11455
11456     case FFECOM_rttypeREAL_F2C_:
11457     case FFECOM_rttypeREAL_GNU_:
11458       return FFEINFO_kindtypeREAL1;
11459
11460     case FFECOM_rttypeCOMPLEX_F2C_:
11461     case FFECOM_rttypeCOMPLEX_GNU_:
11462       return FFEINFO_kindtypeREAL1;
11463
11464     case FFECOM_rttypeDOUBLE_:
11465     case FFECOM_rttypeDOUBLEREAL_:
11466       return FFEINFO_kindtypeREAL2;
11467
11468     case FFECOM_rttypeDBLCMPLX_F2C_:
11469     case FFECOM_rttypeDBLCMPLX_GNU_:
11470       return FFEINFO_kindtypeREAL2;
11471
11472     case FFECOM_rttypeCHARACTER_:
11473       return FFEINFO_kindtypeCHARACTER1;
11474
11475     default:
11476       return FFEINFO_kindtypeANY;
11477     }
11478 }
11479
11480 void
11481 ffecom_init_0 ()
11482 {
11483   tree endlink;
11484   int i;
11485   int j;
11486   tree t;
11487   tree field;
11488   ffetype type;
11489   ffetype base_type;
11490
11491   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11492      whether the compiler environment is buggy in known ways, some of which
11493      would, if not explicitly checked here, result in subtle bugs in g77.  */
11494
11495   if (ffe_is_do_internal_checks ())
11496     {
11497       static char names[][12]
11498         =
11499       {"bar", "bletch", "foo", "foobar"};
11500       char *name;
11501       unsigned long ul;
11502       double fl;
11503
11504       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11505                       (int (*)()) strcmp);
11506       if (name != (char *) &names[2])
11507         {
11508           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11509                   == NULL);
11510           abort ();
11511         }
11512
11513       ul = strtoul ("123456789", NULL, 10);
11514       if (ul != 123456789L)
11515         {
11516           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11517  in proj.h" == NULL);
11518           abort ();
11519         }
11520
11521       fl = atof ("56.789");
11522       if ((fl < 56.788) || (fl > 56.79))
11523         {
11524           assert ("atof not type double, fix your #include <stdio.h>"
11525                   == NULL);
11526           abort ();
11527         }
11528     }
11529
11530   /* Set the sizetype before we do anything else.  This _should_ be the
11531      first type we create.  */
11532
11533   t = make_unsigned_type (POINTER_SIZE);
11534   assert (t == sizetype);
11535
11536 #if FFECOM_GCC_INCLUDE
11537   ffecom_initialize_char_syntax_ ();
11538 #endif
11539
11540   ffecom_outer_function_decl_ = NULL_TREE;
11541   current_function_decl = NULL_TREE;
11542   named_labels = NULL_TREE;
11543   current_binding_level = NULL_BINDING_LEVEL;
11544   free_binding_level = NULL_BINDING_LEVEL;
11545   /* Make the binding_level structure for global names.  */
11546   pushlevel (0);
11547   global_binding_level = current_binding_level;
11548   current_binding_level->prep_state = 2;
11549
11550   /* Define `int' and `char' first so that dbx will output them first.  */
11551
11552   integer_type_node = make_signed_type (INT_TYPE_SIZE);
11553   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11554                         integer_type_node));
11555
11556   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11557   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11558                         char_type_node));
11559
11560   long_integer_type_node = make_signed_type (LONG_TYPE_SIZE);
11561   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11562                         long_integer_type_node));
11563
11564   unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE);
11565   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11566                         unsigned_type_node));
11567
11568   long_unsigned_type_node = make_unsigned_type (LONG_TYPE_SIZE);
11569   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11570                         long_unsigned_type_node));
11571
11572   long_long_integer_type_node = make_signed_type (LONG_LONG_TYPE_SIZE);
11573   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11574                         long_long_integer_type_node));
11575
11576   long_long_unsigned_type_node = make_unsigned_type (LONG_LONG_TYPE_SIZE);
11577   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11578                         long_long_unsigned_type_node));
11579
11580   error_mark_node = make_node (ERROR_MARK);
11581   TREE_TYPE (error_mark_node) = error_mark_node;
11582
11583   short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE);
11584   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11585                         short_integer_type_node));
11586
11587   short_unsigned_type_node = make_unsigned_type (SHORT_TYPE_SIZE);
11588   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11589                         short_unsigned_type_node));
11590
11591   /* Define both `signed char' and `unsigned char'.  */
11592   signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE);
11593   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11594                         signed_char_type_node));
11595
11596   unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11597   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11598                         unsigned_char_type_node));
11599
11600   float_type_node = make_node (REAL_TYPE);
11601   TYPE_PRECISION (float_type_node) = FLOAT_TYPE_SIZE;
11602   layout_type (float_type_node);
11603   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11604                         float_type_node));
11605
11606   double_type_node = make_node (REAL_TYPE);
11607   TYPE_PRECISION (double_type_node) = DOUBLE_TYPE_SIZE;
11608   layout_type (double_type_node);
11609   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11610                         double_type_node));
11611
11612   long_double_type_node = make_node (REAL_TYPE);
11613   TYPE_PRECISION (long_double_type_node) = LONG_DOUBLE_TYPE_SIZE;
11614   layout_type (long_double_type_node);
11615   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11616                         long_double_type_node));
11617
11618   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11619   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11620                         complex_integer_type_node));
11621
11622   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11623   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11624                         complex_float_type_node));
11625
11626   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11627   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11628                         complex_double_type_node));
11629
11630   complex_long_double_type_node = ffecom_make_complex_type_ (long_double_type_node);
11631   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11632                         complex_long_double_type_node));
11633
11634   integer_zero_node = build_int_2 (0, 0);
11635   TREE_TYPE (integer_zero_node) = integer_type_node;
11636   integer_one_node = build_int_2 (1, 0);
11637   TREE_TYPE (integer_one_node) = integer_type_node;
11638
11639   size_zero_node = build_int_2 (0, 0);
11640   TREE_TYPE (size_zero_node) = sizetype;
11641   size_one_node = build_int_2 (1, 0);
11642   TREE_TYPE (size_one_node) = sizetype;
11643
11644   void_type_node = make_node (VOID_TYPE);
11645   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11646                         void_type_node));
11647   layout_type (void_type_node); /* Uses integer_zero_node */
11648   /* We are not going to have real types in C with less than byte alignment,
11649      so we might as well not have any types that claim to have it.  */
11650   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11651
11652   null_pointer_node = build_int_2 (0, 0);
11653   TREE_TYPE (null_pointer_node) = build_pointer_type (void_type_node);
11654   layout_type (TREE_TYPE (null_pointer_node));
11655
11656   string_type_node = build_pointer_type (char_type_node);
11657
11658   ffecom_tree_fun_type_void
11659     = build_function_type (void_type_node, NULL_TREE);
11660
11661   ffecom_tree_ptr_to_fun_type_void
11662     = build_pointer_type (ffecom_tree_fun_type_void);
11663
11664   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11665
11666   float_ftype_float
11667     = build_function_type (float_type_node,
11668                            tree_cons (NULL_TREE, float_type_node, endlink));
11669
11670   double_ftype_double
11671     = build_function_type (double_type_node,
11672                            tree_cons (NULL_TREE, double_type_node, endlink));
11673
11674   ldouble_ftype_ldouble
11675     = build_function_type (long_double_type_node,
11676                            tree_cons (NULL_TREE, long_double_type_node,
11677                                       endlink));
11678
11679   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11680     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11681       {
11682         ffecom_tree_type[i][j] = NULL_TREE;
11683         ffecom_tree_fun_type[i][j] = NULL_TREE;
11684         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11685         ffecom_f2c_typecode_[i][j] = -1;
11686       }
11687
11688   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11689      to size FLOAT_TYPE_SIZE because they have to be the same size as
11690      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11691      Compiler options and other such stuff that change the ways these
11692      types are set should not affect this particular setup.  */
11693
11694   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11695     = t = make_signed_type (FLOAT_TYPE_SIZE);
11696   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11697                         t));
11698   type = ffetype_new ();
11699   base_type = type;
11700   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11701                     type);
11702   ffetype_set_ams (type,
11703                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11704                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11705   ffetype_set_star (base_type,
11706                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11707                     type);
11708   ffetype_set_kind (base_type, 1, type);
11709   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11710
11711   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11712     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11713   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11714                         t));
11715
11716   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11717     = t = make_signed_type (CHAR_TYPE_SIZE);
11718   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11719                         t));
11720   type = ffetype_new ();
11721   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11722                     type);
11723   ffetype_set_ams (type,
11724                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11725                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11726   ffetype_set_star (base_type,
11727                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11728                     type);
11729   ffetype_set_kind (base_type, 3, type);
11730   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11731
11732   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11733     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11734   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11735                         t));
11736
11737   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11738     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11739   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11740                         t));
11741   type = ffetype_new ();
11742   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11743                     type);
11744   ffetype_set_ams (type,
11745                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11746                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11747   ffetype_set_star (base_type,
11748                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11749                     type);
11750   ffetype_set_kind (base_type, 6, type);
11751   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11752
11753   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11754     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11755   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11756                         t));
11757
11758   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11759     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11760   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11761                         t));
11762   type = ffetype_new ();
11763   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11764                     type);
11765   ffetype_set_ams (type,
11766                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11767                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11768   ffetype_set_star (base_type,
11769                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11770                     type);
11771   ffetype_set_kind (base_type, 2, type);
11772   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11773
11774   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11775     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11776   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11777                         t));
11778
11779 #if 0
11780   if (ffe_is_do_internal_checks ()
11781       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11782       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11783       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11784       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11785     {
11786       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11787                LONG_TYPE_SIZE);
11788     }
11789 #endif
11790
11791   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11792     = t = make_signed_type (FLOAT_TYPE_SIZE);
11793   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11794                         t));
11795   type = ffetype_new ();
11796   base_type = type;
11797   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11798                     type);
11799   ffetype_set_ams (type,
11800                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11801                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11802   ffetype_set_star (base_type,
11803                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11804                     type);
11805   ffetype_set_kind (base_type, 1, type);
11806   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11807
11808   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11809     = t = make_signed_type (CHAR_TYPE_SIZE);
11810   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11811                         t));
11812   type = ffetype_new ();
11813   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11814                     type);
11815   ffetype_set_ams (type,
11816                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11817                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11818   ffetype_set_star (base_type,
11819                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11820                     type);
11821   ffetype_set_kind (base_type, 3, type);
11822   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11823
11824   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11825     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11826   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11827                         t));
11828   type = ffetype_new ();
11829   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11830                     type);
11831   ffetype_set_ams (type,
11832                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11833                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11834   ffetype_set_star (base_type,
11835                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11836                     type);
11837   ffetype_set_kind (base_type, 6, type);
11838   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11839
11840   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11841     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11842   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11843                         t));
11844   type = ffetype_new ();
11845   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11846                     type);
11847   ffetype_set_ams (type,
11848                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11849                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11850   ffetype_set_star (base_type,
11851                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11852                     type);
11853   ffetype_set_kind (base_type, 2, type);
11854   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11855
11856   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11857     = t = make_node (REAL_TYPE);
11858   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11859   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11860                         t));
11861   layout_type (t);
11862   type = ffetype_new ();
11863   base_type = type;
11864   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11865                     type);
11866   ffetype_set_ams (type,
11867                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11868                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11869   ffetype_set_star (base_type,
11870                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11871                     type);
11872   ffetype_set_kind (base_type, 1, type);
11873   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11874     = FFETARGET_f2cTYREAL;
11875   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11876
11877   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11878     = t = make_node (REAL_TYPE);
11879   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11880   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11881                         t));
11882   layout_type (t);
11883   type = ffetype_new ();
11884   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11885                     type);
11886   ffetype_set_ams (type,
11887                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11888                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11889   ffetype_set_star (base_type,
11890                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11891                     type);
11892   ffetype_set_kind (base_type, 2, type);
11893   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11894     = FFETARGET_f2cTYDREAL;
11895   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11896
11897   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11898     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11899   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11900                         t));
11901   type = ffetype_new ();
11902   base_type = type;
11903   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11904                     type);
11905   ffetype_set_ams (type,
11906                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11907                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11908   ffetype_set_star (base_type,
11909                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11910                     type);
11911   ffetype_set_kind (base_type, 1, type);
11912   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11913     = FFETARGET_f2cTYCOMPLEX;
11914   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11915
11916   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11917     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11918   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11919                         t));
11920   type = ffetype_new ();
11921   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11922                     type);
11923   ffetype_set_ams (type,
11924                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11925                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11926   ffetype_set_star (base_type,
11927                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11928                     type);
11929   ffetype_set_kind (base_type, 2,
11930                     type);
11931   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11932     = FFETARGET_f2cTYDCOMPLEX;
11933   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11934
11935   /* Make function and ptr-to-function types for non-CHARACTER types. */
11936
11937   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11938     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11939       {
11940         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11941           {
11942             if (i == FFEINFO_basictypeINTEGER)
11943               {
11944                 /* Figure out the smallest INTEGER type that can hold
11945                    a pointer on this machine. */
11946                 if (GET_MODE_SIZE (TYPE_MODE (t))
11947                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11948                   {
11949                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11950                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11951                             > GET_MODE_SIZE (TYPE_MODE (t))))
11952                       ffecom_pointer_kind_ = j;
11953                   }
11954               }
11955             else if (i == FFEINFO_basictypeCOMPLEX)
11956               t = void_type_node;
11957             /* For f2c compatibility, REAL functions are really
11958                implemented as DOUBLE PRECISION.  */
11959             else if ((i == FFEINFO_basictypeREAL)
11960                      && (j == FFEINFO_kindtypeREAL1))
11961               t = ffecom_tree_type
11962                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11963
11964             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11965                                                                   NULL_TREE);
11966             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11967           }
11968       }
11969
11970   /* Set up pointer types.  */
11971
11972   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11973     fatal ("no INTEGER type can hold a pointer on this configuration");
11974   else if (0 && ffe_is_do_internal_checks ())
11975     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11976   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11977                                   FFEINFO_kindtypeINTEGERDEFAULT),
11978                     7,
11979                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11980                                   ffecom_pointer_kind_));
11981
11982   if (ffe_is_ugly_assign ())
11983     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11984   else
11985     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11986   if (0 && ffe_is_do_internal_checks ())
11987     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11988
11989   ffecom_integer_type_node
11990     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11991   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11992                                       integer_zero_node);
11993   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11994                                      integer_one_node);
11995
11996   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11997      Turns out that by TYLONG, runtime/libI77/lio.h really means
11998      "whatever size an ftnint is".  For consistency and sanity,
11999      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
12000      all are INTEGER, which we also make out of whatever back-end
12001      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
12002      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
12003      accommodate machines like the Alpha.  Note that this suggests
12004      f2c and libf2c are missing a distinction perhaps needed on
12005      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
12006
12007   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
12008                             FFETARGET_f2cTYLONG);
12009   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
12010                             FFETARGET_f2cTYSHORT);
12011   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
12012                             FFETARGET_f2cTYINT1);
12013   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
12014                             FFETARGET_f2cTYQUAD);
12015   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
12016                             FFETARGET_f2cTYLOGICAL);
12017   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
12018                             FFETARGET_f2cTYLOGICAL2);
12019   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
12020                             FFETARGET_f2cTYLOGICAL1);
12021   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
12022   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
12023                             FFETARGET_f2cTYQUAD);
12024
12025   /* CHARACTER stuff is all special-cased, so it is not handled in the above
12026      loop.  CHARACTER items are built as arrays of unsigned char.  */
12027
12028   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
12029     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
12030   type = ffetype_new ();
12031   base_type = type;
12032   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
12033                     FFEINFO_kindtypeCHARACTER1,
12034                     type);
12035   ffetype_set_ams (type,
12036                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12037                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12038   ffetype_set_kind (base_type, 1, type);
12039   assert (ffetype_size (type)
12040           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
12041
12042   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
12043     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
12044   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
12045     [FFEINFO_kindtypeCHARACTER1]
12046     = ffecom_tree_ptr_to_fun_type_void;
12047   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
12048     = FFETARGET_f2cTYCHAR;
12049
12050   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
12051     = 0;
12052
12053   /* Make multi-return-value type and fields. */
12054
12055   ffecom_multi_type_node_ = make_node (UNION_TYPE);
12056
12057   field = NULL_TREE;
12058
12059   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
12060     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
12061       {
12062         char name[30];
12063
12064         if (ffecom_tree_type[i][j] == NULL_TREE)
12065           continue;             /* Not supported. */
12066         sprintf (&name[0], "bt_%s_kt_%s",
12067                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
12068                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
12069         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
12070                                                  get_identifier (name),
12071                                                  ffecom_tree_type[i][j]);
12072         DECL_CONTEXT (ffecom_multi_fields_[i][j])
12073           = ffecom_multi_type_node_;
12074         DECL_FRAME_SIZE (ffecom_multi_fields_[i][j]) = 0;
12075         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
12076         field = ffecom_multi_fields_[i][j];
12077       }
12078
12079   TYPE_FIELDS (ffecom_multi_type_node_) = field;
12080   layout_type (ffecom_multi_type_node_);
12081
12082   /* Subroutines usually return integer because they might have alternate
12083      returns. */
12084
12085   ffecom_tree_subr_type
12086     = build_function_type (integer_type_node, NULL_TREE);
12087   ffecom_tree_ptr_to_subr_type
12088     = build_pointer_type (ffecom_tree_subr_type);
12089   ffecom_tree_blockdata_type
12090     = build_function_type (void_type_node, NULL_TREE);
12091
12092   builtin_function ("__builtin_sqrtf", float_ftype_float,
12093                     BUILT_IN_FSQRT, "sqrtf");
12094   builtin_function ("__builtin_fsqrt", double_ftype_double,
12095                     BUILT_IN_FSQRT, "sqrt");
12096   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
12097                     BUILT_IN_FSQRT, "sqrtl");
12098   builtin_function ("__builtin_sinf", float_ftype_float,
12099                     BUILT_IN_SIN, "sinf");
12100   builtin_function ("__builtin_sin", double_ftype_double,
12101                     BUILT_IN_SIN, "sin");
12102   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
12103                     BUILT_IN_SIN, "sinl");
12104   builtin_function ("__builtin_cosf", float_ftype_float,
12105                     BUILT_IN_COS, "cosf");
12106   builtin_function ("__builtin_cos", double_ftype_double,
12107                     BUILT_IN_COS, "cos");
12108   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
12109                     BUILT_IN_COS, "cosl");
12110
12111 #if BUILT_FOR_270
12112   pedantic_lvalues = FALSE;
12113 #endif
12114
12115   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
12116                          FFECOM_f2cINTEGER,
12117                          "integer");
12118   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
12119                          FFECOM_f2cADDRESS,
12120                          "address");
12121   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
12122                          FFECOM_f2cREAL,
12123                          "real");
12124   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
12125                          FFECOM_f2cDOUBLEREAL,
12126                          "doublereal");
12127   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
12128                          FFECOM_f2cCOMPLEX,
12129                          "complex");
12130   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
12131                          FFECOM_f2cDOUBLECOMPLEX,
12132                          "doublecomplex");
12133   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
12134                          FFECOM_f2cLONGINT,
12135                          "longint");
12136   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
12137                          FFECOM_f2cLOGICAL,
12138                          "logical");
12139   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
12140                          FFECOM_f2cFLAG,
12141                          "flag");
12142   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
12143                          FFECOM_f2cFTNLEN,
12144                          "ftnlen");
12145   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
12146                          FFECOM_f2cFTNINT,
12147                          "ftnint");
12148
12149   ffecom_f2c_ftnlen_zero_node
12150     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
12151
12152   ffecom_f2c_ftnlen_one_node
12153     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
12154
12155   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
12156   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
12157
12158   ffecom_f2c_ptr_to_ftnlen_type_node
12159     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
12160
12161   ffecom_f2c_ptr_to_ftnint_type_node
12162     = build_pointer_type (ffecom_f2c_ftnint_type_node);
12163
12164   ffecom_f2c_ptr_to_integer_type_node
12165     = build_pointer_type (ffecom_f2c_integer_type_node);
12166
12167   ffecom_f2c_ptr_to_real_type_node
12168     = build_pointer_type (ffecom_f2c_real_type_node);
12169
12170   ffecom_float_zero_ = build_real (float_type_node, dconst0);
12171   ffecom_double_zero_ = build_real (double_type_node, dconst0);
12172   {
12173     REAL_VALUE_TYPE point_5;
12174
12175 #ifdef REAL_ARITHMETIC
12176     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12177 #else
12178     point_5 = .5;
12179 #endif
12180     ffecom_float_half_ = build_real (float_type_node, point_5);
12181     ffecom_double_half_ = build_real (double_type_node, point_5);
12182   }
12183
12184   /* Do "extern int xargc;".  */
12185
12186   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12187                                    get_identifier ("f__xargc"),
12188                                    integer_type_node);
12189   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12190   TREE_STATIC (ffecom_tree_xargc_) = 1;
12191   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12192   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12193   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12194
12195 #if 0   /* This is being fixed, and seems to be working now. */
12196   if ((FLOAT_TYPE_SIZE != 32)
12197       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12198     {
12199       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12200                (int) FLOAT_TYPE_SIZE);
12201       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12202           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12203       warning ("properly unless they all are 32 bits wide.");
12204       warning ("Please keep this in mind before you report bugs.  g77 should");
12205       warning ("support non-32-bit machines better as of version 0.6.");
12206     }
12207 #endif
12208
12209 #if 0   /* Code in ste.c that would crash has been commented out. */
12210   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12211       < TYPE_PRECISION (string_type_node))
12212     /* I/O will probably crash.  */
12213     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12214              TYPE_PRECISION (string_type_node),
12215              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12216 #endif
12217
12218 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12219   if (TYPE_PRECISION (ffecom_integer_type_node)
12220       < TYPE_PRECISION (string_type_node))
12221     /* ASSIGN 10 TO I will crash.  */
12222     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12223  ASSIGN statement might fail",
12224              TYPE_PRECISION (string_type_node),
12225              TYPE_PRECISION (ffecom_integer_type_node));
12226 #endif
12227 }
12228
12229 #endif
12230 /* ffecom_init_2 -- Initialize
12231
12232    ffecom_init_2();  */
12233
12234 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12235 void
12236 ffecom_init_2 ()
12237 {
12238   assert (ffecom_outer_function_decl_ == NULL_TREE);
12239   assert (current_function_decl == NULL_TREE);
12240   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12241
12242   ffecom_master_arglist_ = NULL;
12243   ++ffecom_num_fns_;
12244   ffecom_primary_entry_ = NULL;
12245   ffecom_is_altreturning_ = FALSE;
12246   ffecom_func_result_ = NULL_TREE;
12247   ffecom_multi_retval_ = NULL_TREE;
12248 }
12249
12250 #endif
12251 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12252
12253    tree t;
12254    ffebld expr;  // FFE opITEM list.
12255    tree = ffecom_list_expr(expr);
12256
12257    List of actual args is transformed into corresponding gcc backend list.  */
12258
12259 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12260 tree
12261 ffecom_list_expr (ffebld expr)
12262 {
12263   tree list;
12264   tree *plist = &list;
12265   tree trail = NULL_TREE;       /* Append char length args here. */
12266   tree *ptrail = &trail;
12267   tree length;
12268
12269   while (expr != NULL)
12270     {
12271       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12272
12273       if (texpr == error_mark_node)
12274         return error_mark_node;
12275
12276       *plist = build_tree_list (NULL_TREE, texpr);
12277       plist = &TREE_CHAIN (*plist);
12278       expr = ffebld_trail (expr);
12279       if (length != NULL_TREE)
12280         {
12281           *ptrail = build_tree_list (NULL_TREE, length);
12282           ptrail = &TREE_CHAIN (*ptrail);
12283         }
12284     }
12285
12286   *plist = trail;
12287
12288   return list;
12289 }
12290
12291 #endif
12292 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12293
12294    tree t;
12295    ffebld expr;  // FFE opITEM list.
12296    tree = ffecom_list_ptr_to_expr(expr);
12297
12298    List of actual args is transformed into corresponding gcc backend list for
12299    use in calling an external procedure (vs. a statement function).  */
12300
12301 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12302 tree
12303 ffecom_list_ptr_to_expr (ffebld expr)
12304 {
12305   tree list;
12306   tree *plist = &list;
12307   tree trail = NULL_TREE;       /* Append char length args here. */
12308   tree *ptrail = &trail;
12309   tree length;
12310
12311   while (expr != NULL)
12312     {
12313       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12314
12315       if (texpr == error_mark_node)
12316         return error_mark_node;
12317
12318       *plist = build_tree_list (NULL_TREE, texpr);
12319       plist = &TREE_CHAIN (*plist);
12320       expr = ffebld_trail (expr);
12321       if (length != NULL_TREE)
12322         {
12323           *ptrail = build_tree_list (NULL_TREE, length);
12324           ptrail = &TREE_CHAIN (*ptrail);
12325         }
12326     }
12327
12328   *plist = trail;
12329
12330   return list;
12331 }
12332
12333 #endif
12334 /* Obtain gcc's LABEL_DECL tree for label.  */
12335
12336 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12337 tree
12338 ffecom_lookup_label (ffelab label)
12339 {
12340   tree glabel;
12341
12342   if (ffelab_hook (label) == NULL_TREE)
12343     {
12344       char labelname[16];
12345
12346       switch (ffelab_type (label))
12347         {
12348         case FFELAB_typeLOOPEND:
12349         case FFELAB_typeNOTLOOP:
12350         case FFELAB_typeENDIF:
12351           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12352           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12353                                void_type_node);
12354           DECL_CONTEXT (glabel) = current_function_decl;
12355           DECL_MODE (glabel) = VOIDmode;
12356           break;
12357
12358         case FFELAB_typeFORMAT:
12359           push_obstacks_nochange ();
12360           end_temporary_allocation ();
12361
12362           glabel = build_decl (VAR_DECL,
12363                                ffecom_get_invented_identifier
12364                                ("__g77_format_%d", NULL,
12365                                 (int) ffelab_value (label)),
12366                                build_type_variant (build_array_type
12367                                                    (char_type_node,
12368                                                     NULL_TREE),
12369                                                    1, 0));
12370           TREE_CONSTANT (glabel) = 1;
12371           TREE_STATIC (glabel) = 1;
12372           DECL_CONTEXT (glabel) = 0;
12373           DECL_INITIAL (glabel) = NULL;
12374           make_decl_rtl (glabel, NULL, 0);
12375           expand_decl (glabel);
12376
12377           resume_temporary_allocation ();
12378           pop_obstacks ();
12379
12380           break;
12381
12382         case FFELAB_typeANY:
12383           glabel = error_mark_node;
12384           break;
12385
12386         default:
12387           assert ("bad label type" == NULL);
12388           glabel = NULL;
12389           break;
12390         }
12391       ffelab_set_hook (label, glabel);
12392     }
12393   else
12394     {
12395       glabel = ffelab_hook (label);
12396     }
12397
12398   return glabel;
12399 }
12400
12401 #endif
12402 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12403    a single source specification (as in the fourth argument of MVBITS).
12404    If the type is NULL_TREE, the type of lhs is used to make the type of
12405    the MODIFY_EXPR.  */
12406
12407 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12408 tree
12409 ffecom_modify (tree newtype, tree lhs,
12410                tree rhs)
12411 {
12412   if (lhs == error_mark_node || rhs == error_mark_node)
12413     return error_mark_node;
12414
12415   if (newtype == NULL_TREE)
12416     newtype = TREE_TYPE (lhs);
12417
12418   if (TREE_SIDE_EFFECTS (lhs))
12419     lhs = stabilize_reference (lhs);
12420
12421   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12422 }
12423
12424 #endif
12425
12426 /* Register source file name.  */
12427
12428 void
12429 ffecom_file (char *name)
12430 {
12431 #if FFECOM_GCC_INCLUDE
12432   ffecom_file_ (name);
12433 #endif
12434 }
12435
12436 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12437
12438    ffestorag st;
12439    ffecom_notify_init_storage(st);
12440
12441    Gets called when all possible units in an aggregate storage area (a LOCAL
12442    with equivalences or a COMMON) have been initialized.  The initialization
12443    info either is in ffestorag_init or, if that is NULL,
12444    ffestorag_accretion:
12445
12446    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12447    even for an array if the array is one element in length!
12448
12449    ffestorag_accretion will contain an opACCTER.  It is much like an
12450    opARRTER except it has an ffebit object in it instead of just a size.
12451    The back end can use the info in the ffebit object, if it wants, to
12452    reduce the amount of actual initialization, but in any case it should
12453    kill the ffebit object when done.  Also, set accretion to NULL but
12454    init to a non-NULL value.
12455
12456    After performing initialization, DO NOT set init to NULL, because that'll
12457    tell the front end it is ok for more initialization to happen.  Instead,
12458    set init to an opANY expression or some such thing that you can use to
12459    tell that you've already initialized the object.
12460
12461    27-Oct-91  JCB  1.1
12462       Support two-pass FFE.  */
12463
12464 void
12465 ffecom_notify_init_storage (ffestorag st)
12466 {
12467   ffebld init;                  /* The initialization expression. */
12468 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12469   ffetargetOffset size;         /* The size of the entity. */
12470   ffetargetAlign pad;           /* Its initial padding. */
12471 #endif
12472
12473   if (ffestorag_init (st) == NULL)
12474     {
12475       init = ffestorag_accretion (st);
12476       assert (init != NULL);
12477       ffestorag_set_accretion (st, NULL);
12478       ffestorag_set_accretes (st, 0);
12479
12480 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12481       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12482       size = ffebld_accter_size (init);
12483       pad = ffebld_accter_pad (init);
12484       ffebit_kill (ffebld_accter_bits (init));
12485       ffebld_set_op (init, FFEBLD_opARRTER);
12486       ffebld_set_arrter (init, ffebld_accter (init));
12487       ffebld_arrter_set_size (init, size);
12488       ffebld_arrter_set_pad (init, size);
12489 #endif
12490
12491 #if FFECOM_TWOPASS
12492       ffestorag_set_init (st, init);
12493 #endif
12494     }
12495 #if FFECOM_ONEPASS
12496   else
12497     init = ffestorag_init (st);
12498 #endif
12499
12500 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12501   ffestorag_set_init (st, ffebld_new_any ());
12502
12503   if (ffebld_op (init) == FFEBLD_opANY)
12504     return;                     /* Oh, we already did this! */
12505
12506 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12507   {
12508     ffesymbol s;
12509
12510     if (ffestorag_symbol (st) != NULL)
12511       s = ffestorag_symbol (st);
12512     else
12513       s = ffestorag_typesymbol (st);
12514
12515     fprintf (dmpout, "= initialize_storage \"%s\" ",
12516              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12517     ffebld_dump (init);
12518     fputc ('\n', dmpout);
12519   }
12520 #endif
12521
12522 #endif /* if FFECOM_ONEPASS */
12523 }
12524
12525 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12526
12527    ffesymbol s;
12528    ffecom_notify_init_symbol(s);
12529
12530    Gets called when all possible units in a symbol (not placed in COMMON
12531    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12532    have been initialized.  The initialization info either is in
12533    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12534
12535    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12536    even for an array if the array is one element in length!
12537
12538    ffesymbol_accretion will contain an opACCTER.  It is much like an
12539    opARRTER except it has an ffebit object in it instead of just a size.
12540    The back end can use the info in the ffebit object, if it wants, to
12541    reduce the amount of actual initialization, but in any case it should
12542    kill the ffebit object when done.  Also, set accretion to NULL but
12543    init to a non-NULL value.
12544
12545    After performing initialization, DO NOT set init to NULL, because that'll
12546    tell the front end it is ok for more initialization to happen.  Instead,
12547    set init to an opANY expression or some such thing that you can use to
12548    tell that you've already initialized the object.
12549
12550    27-Oct-91  JCB  1.1
12551       Support two-pass FFE.  */
12552
12553 void
12554 ffecom_notify_init_symbol (ffesymbol s)
12555 {
12556   ffebld init;                  /* The initialization expression. */
12557 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12558   ffetargetOffset size;         /* The size of the entity. */
12559   ffetargetAlign pad;           /* Its initial padding. */
12560 #endif
12561
12562   if (ffesymbol_storage (s) == NULL)
12563     return;                     /* Do nothing until COMMON/EQUIVALENCE
12564                                    possibilities checked. */
12565
12566   if ((ffesymbol_init (s) == NULL)
12567       && ((init = ffesymbol_accretion (s)) != NULL))
12568     {
12569       ffesymbol_set_accretion (s, NULL);
12570       ffesymbol_set_accretes (s, 0);
12571
12572 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12573       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12574       size = ffebld_accter_size (init);
12575       pad = ffebld_accter_pad (init);
12576       ffebit_kill (ffebld_accter_bits (init));
12577       ffebld_set_op (init, FFEBLD_opARRTER);
12578       ffebld_set_arrter (init, ffebld_accter (init));
12579       ffebld_arrter_set_size (init, size);
12580       ffebld_arrter_set_pad (init, size);
12581 #endif
12582
12583 #if FFECOM_TWOPASS
12584       ffesymbol_set_init (s, init);
12585 #endif
12586     }
12587 #if FFECOM_ONEPASS
12588   else
12589     init = ffesymbol_init (s);
12590 #endif
12591
12592 #if FFECOM_ONEPASS
12593   ffesymbol_set_init (s, ffebld_new_any ());
12594
12595   if (ffebld_op (init) == FFEBLD_opANY)
12596     return;                     /* Oh, we already did this! */
12597
12598 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12599   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12600   ffebld_dump (init);
12601   fputc ('\n', dmpout);
12602 #endif
12603
12604 #endif /* if FFECOM_ONEPASS */
12605 }
12606
12607 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12608
12609    ffesymbol s;
12610    ffecom_notify_primary_entry(s);
12611
12612    Gets called when implicit or explicit PROGRAM statement seen or when
12613    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12614    global symbol that serves as the entry point.  */
12615
12616 void
12617 ffecom_notify_primary_entry (ffesymbol s)
12618 {
12619   ffecom_primary_entry_ = s;
12620   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12621
12622   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12623       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12624     ffecom_primary_entry_is_proc_ = TRUE;
12625   else
12626     ffecom_primary_entry_is_proc_ = FALSE;
12627
12628   if (!ffe_is_silent ())
12629     {
12630       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12631         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12632       else
12633         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12634     }
12635
12636 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12637   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12638     {
12639       ffebld list;
12640       ffebld arg;
12641
12642       for (list = ffesymbol_dummyargs (s);
12643            list != NULL;
12644            list = ffebld_trail (list))
12645         {
12646           arg = ffebld_head (list);
12647           if (ffebld_op (arg) == FFEBLD_opSTAR)
12648             {
12649               ffecom_is_altreturning_ = TRUE;
12650               break;
12651             }
12652         }
12653     }
12654 #endif
12655 }
12656
12657 FILE *
12658 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12659 {
12660 #if FFECOM_GCC_INCLUDE
12661   return ffecom_open_include_ (name, l, c);
12662 #else
12663   return fopen (name, "r");
12664 #endif
12665 }
12666
12667 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12668
12669    tree t;
12670    ffebld expr;  // FFE expression.
12671    tree = ffecom_ptr_to_expr(expr);
12672
12673    Like ffecom_expr, but sticks address-of in front of most things.  */
12674
12675 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12676 tree
12677 ffecom_ptr_to_expr (ffebld expr)
12678 {
12679   tree item;
12680   ffeinfoBasictype bt;
12681   ffeinfoKindtype kt;
12682   ffesymbol s;
12683
12684   assert (expr != NULL);
12685
12686   switch (ffebld_op (expr))
12687     {
12688     case FFEBLD_opSYMTER:
12689       s = ffebld_symter (expr);
12690       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12691         {
12692           ffecomGfrt ix;
12693
12694           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12695           assert (ix != FFECOM_gfrt);
12696           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12697             {
12698               ffecom_make_gfrt_ (ix);
12699               item = ffecom_gfrt_[ix];
12700             }
12701         }
12702       else
12703         {
12704           item = ffesymbol_hook (s).decl_tree;
12705           if (item == NULL_TREE)
12706             {
12707               s = ffecom_sym_transform_ (s);
12708               item = ffesymbol_hook (s).decl_tree;
12709             }
12710         }
12711       assert (item != NULL);
12712       if (item == error_mark_node)
12713         return item;
12714       if (!ffesymbol_hook (s).addr)
12715         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12716                          item);
12717       return item;
12718
12719     case FFEBLD_opARRAYREF:
12720       {
12721         item = ffecom_ptr_to_expr (ffebld_left (expr));
12722
12723         if (item == error_mark_node)
12724           return item;
12725
12726         if ((ffebld_where (expr) == FFEINFO_whereFLEETING)
12727             && !mark_addressable (item))
12728           return error_mark_node;       /* Make sure non-const ref is to
12729                                            non-reg. */
12730
12731         item = ffecom_arrayref_ (item, expr, 1);
12732       }
12733       return item;
12734
12735     case FFEBLD_opCONTER:
12736
12737       bt = ffeinfo_basictype (ffebld_info (expr));
12738       kt = ffeinfo_kindtype (ffebld_info (expr));
12739
12740       item = ffecom_constantunion (&ffebld_constant_union
12741                                    (ffebld_conter (expr)), bt, kt,
12742                                    ffecom_tree_type[bt][kt]);
12743       if (item == error_mark_node)
12744         return error_mark_node;
12745       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12746                        item);
12747       return item;
12748
12749     case FFEBLD_opANY:
12750       return error_mark_node;
12751
12752     default:
12753       bt = ffeinfo_basictype (ffebld_info (expr));
12754       kt = ffeinfo_kindtype (ffebld_info (expr));
12755
12756       item = ffecom_expr (expr);
12757       if (item == error_mark_node)
12758         return error_mark_node;
12759
12760       /* The back end currently optimizes a bit too zealously for us, in that
12761          we fail JCB001 if the following block of code is omitted.  It checks
12762          to see if the transformed expression is a symbol or array reference,
12763          and encloses it in a SAVE_EXPR if that is the case.  */
12764
12765       STRIP_NOPS (item);
12766       if ((TREE_CODE (item) == VAR_DECL)
12767           || (TREE_CODE (item) == PARM_DECL)
12768           || (TREE_CODE (item) == RESULT_DECL)
12769           || (TREE_CODE (item) == INDIRECT_REF)
12770           || (TREE_CODE (item) == ARRAY_REF)
12771           || (TREE_CODE (item) == COMPONENT_REF)
12772 #ifdef OFFSET_REF
12773           || (TREE_CODE (item) == OFFSET_REF)
12774 #endif
12775           || (TREE_CODE (item) == BUFFER_REF)
12776           || (TREE_CODE (item) == REALPART_EXPR)
12777           || (TREE_CODE (item) == IMAGPART_EXPR))
12778         {
12779           item = ffecom_save_tree (item);
12780         }
12781
12782       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12783                        item);
12784       return item;
12785     }
12786
12787   assert ("fall-through error" == NULL);
12788   return error_mark_node;
12789 }
12790
12791 #endif
12792 /* Obtain a temp var with given data type.
12793
12794    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12795    or >= 0 for a CHARACTER type.
12796
12797    elements is -1 for a scalar or > 0 for an array of type.  */
12798
12799 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12800 tree
12801 ffecom_make_tempvar (const char *commentary, tree type,
12802                      ffetargetCharacterSize size, int elements)
12803 {
12804   int yes;
12805   tree t;
12806   static int mynumber;
12807
12808   assert (current_binding_level->prep_state < 2);
12809
12810   if (type == error_mark_node)
12811     return error_mark_node;
12812
12813   yes = suspend_momentary ();
12814
12815   if (size != FFETARGET_charactersizeNONE)
12816     type = build_array_type (type,
12817                              build_range_type (ffecom_f2c_ftnlen_type_node,
12818                                                ffecom_f2c_ftnlen_one_node,
12819                                                build_int_2 (size, 0)));
12820   if (elements != -1)
12821     type = build_array_type (type,
12822                              build_range_type (integer_type_node,
12823                                                integer_zero_node,
12824                                                build_int_2 (elements - 1,
12825                                                             0)));
12826   t = build_decl (VAR_DECL,
12827                   ffecom_get_invented_identifier ("__g77_%s_%d",
12828                                                   commentary,
12829                                                   mynumber++),
12830                   type);
12831
12832   t = start_decl (t, FALSE);
12833   finish_decl (t, NULL_TREE, FALSE);
12834
12835   resume_momentary (yes);
12836
12837   return t;
12838 }
12839 #endif
12840
12841 /* Prepare argument pointer to expression.
12842
12843    Like ffecom_prepare_expr, except for expressions to be evaluated
12844    via ffecom_arg_ptr_to_expr.  */
12845
12846 void
12847 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12848 {
12849   /* ~~For now, it seems to be the same thing.  */
12850   ffecom_prepare_expr (expr);
12851   return;
12852 }
12853
12854 /* End of preparations.  */
12855
12856 bool
12857 ffecom_prepare_end (void)
12858 {
12859   int prep_state = current_binding_level->prep_state;
12860
12861   assert (prep_state < 2);
12862   current_binding_level->prep_state = 2;
12863
12864   return (prep_state == 1) ? TRUE : FALSE;
12865 }
12866
12867 /* Prepare expression.
12868
12869    This is called before any code is generated for the current block.
12870    It scans the expression, declares any temporaries that might be needed
12871    during evaluation of the expression, and stores those temporaries in
12872    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12873    specifies the destination that ffecom_expr_ will see, in case that
12874    helps avoid generating unused temporaries.
12875
12876    ~~Improve to avoid allocating unused temporaries by taking `dest'
12877    into account vis-a-vis aliasing requirements of complex/character
12878    functions.  */
12879
12880 void
12881 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12882 {
12883   ffeinfoBasictype bt;
12884   ffeinfoKindtype kt;
12885   ffetargetCharacterSize sz;
12886   tree tempvar = NULL_TREE;
12887
12888   assert (current_binding_level->prep_state < 2);
12889
12890   if (! expr)
12891     return;
12892
12893   bt = ffeinfo_basictype (ffebld_info (expr));
12894   kt = ffeinfo_kindtype (ffebld_info (expr));
12895   sz = ffeinfo_size (ffebld_info (expr));
12896
12897   /* Generate whatever temporaries are needed to represent the result
12898      of the expression.  */
12899
12900   switch (ffebld_op (expr))
12901     {
12902     default:
12903       /* Don't make temps for SYMTER, CONTER, etc.  */
12904       if (ffebld_arity (expr) == 0)
12905         break;
12906
12907       switch (bt)
12908         {
12909         case FFEINFO_basictypeCOMPLEX:
12910           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12911             {
12912               ffesymbol s;
12913
12914               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12915                 break;
12916
12917               s = ffebld_symter (ffebld_left (expr));
12918               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12919                   || ! ffesymbol_is_f2c (s))
12920                 break;
12921             }
12922           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12923             {
12924               /* Requires special treatment.  There's no POW_CC function
12925                  in libg2c, so POW_ZZ is used, which means we always
12926                  need a double-complex temp, not a single-complex.  */
12927               kt = FFEINFO_kindtypeREAL2;
12928             }
12929           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12930             /* The other ops don't need temps for complex operands.  */
12931             break;
12932
12933           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12934              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12935           tempvar = ffecom_make_tempvar ("complex",
12936                                          ffecom_tree_type
12937                                          [FFEINFO_basictypeCOMPLEX][kt],
12938                                          FFETARGET_charactersizeNONE,
12939                                          -1);
12940           break;
12941
12942         case FFEINFO_basictypeCHARACTER:
12943           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12944             break;
12945
12946           if (sz == FFETARGET_charactersizeNONE)
12947             /* ~~Kludge alert!  This should someday be fixed. */
12948             sz = 24;
12949
12950           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12951           break;
12952
12953         default:
12954           break;
12955         }
12956       break;
12957
12958 #ifdef HAHA
12959     case FFEBLD_opPOWER:
12960       {
12961         tree rtype, ltype;
12962         tree rtmp, ltmp, result;
12963
12964         ltype = ffecom_type_expr (ffebld_left (expr));
12965         rtype = ffecom_type_expr (ffebld_right (expr));
12966
12967         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12968         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12969         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12970
12971         tempvar = make_tree_vec (3);
12972         TREE_VEC_ELT (tempvar, 0) = rtmp;
12973         TREE_VEC_ELT (tempvar, 1) = ltmp;
12974         TREE_VEC_ELT (tempvar, 2) = result;
12975       }
12976       break;
12977 #endif  /* HAHA */
12978
12979     case FFEBLD_opCONCATENATE:
12980       {
12981         /* This gets special handling, because only one set of temps
12982            is needed for a tree of these -- the tree is treated as
12983            a flattened list of concatenations when generating code.  */
12984
12985         ffecomConcatList_ catlist;
12986         tree ltmp, itmp, result;
12987         int count;
12988         int i;
12989
12990         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12991         count = ffecom_concat_list_count_ (catlist);
12992
12993         if (count >= 2)
12994           {
12995             ltmp
12996               = ffecom_make_tempvar ("concat_len",
12997                                      ffecom_f2c_ftnlen_type_node,
12998                                      FFETARGET_charactersizeNONE, count);
12999             itmp
13000               = ffecom_make_tempvar ("concat_item",
13001                                      ffecom_f2c_address_type_node,
13002                                      FFETARGET_charactersizeNONE, count);
13003             result
13004               = ffecom_make_tempvar ("concat_res",
13005                                      char_type_node,
13006                                      ffecom_concat_list_maxlen_ (catlist),
13007                                      -1);
13008
13009             tempvar = make_tree_vec (3);
13010             TREE_VEC_ELT (tempvar, 0) = ltmp;
13011             TREE_VEC_ELT (tempvar, 1) = itmp;
13012             TREE_VEC_ELT (tempvar, 2) = result;
13013           }
13014
13015         for (i = 0; i < count; ++i)
13016           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
13017                                                                     i));
13018
13019         ffecom_concat_list_kill_ (catlist);
13020
13021         if (tempvar)
13022           {
13023             ffebld_nonter_set_hook (expr, tempvar);
13024             current_binding_level->prep_state = 1;
13025           }
13026       }
13027       return;
13028
13029     case FFEBLD_opCONVERT:
13030       if (bt == FFEINFO_basictypeCHARACTER
13031           && ((ffebld_size_known (ffebld_left (expr))
13032                == FFETARGET_charactersizeNONE)
13033               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
13034         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
13035       break;
13036     }
13037
13038   if (tempvar)
13039     {
13040       ffebld_nonter_set_hook (expr, tempvar);
13041       current_binding_level->prep_state = 1;
13042     }
13043
13044   /* Prepare subexpressions for this expr.  */
13045
13046   switch (ffebld_op (expr))
13047     {
13048     case FFEBLD_opPERCENT_LOC:
13049       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
13050       break;
13051
13052     case FFEBLD_opPERCENT_VAL:
13053     case FFEBLD_opPERCENT_REF:
13054       ffecom_prepare_expr (ffebld_left (expr));
13055       break;
13056
13057     case FFEBLD_opPERCENT_DESCR:
13058       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
13059       break;
13060
13061     case FFEBLD_opITEM:
13062       {
13063         ffebld item;
13064
13065         for (item = expr;
13066              item != NULL;
13067              item = ffebld_trail (item))
13068           if (ffebld_head (item) != NULL)
13069             ffecom_prepare_expr (ffebld_head (item));
13070       }
13071       break;
13072
13073     default:
13074       /* Need to handle character conversion specially.  */
13075       switch (ffebld_arity (expr))
13076         {
13077         case 2:
13078           ffecom_prepare_expr (ffebld_left (expr));
13079           ffecom_prepare_expr (ffebld_right (expr));
13080           break;
13081
13082         case 1:
13083           ffecom_prepare_expr (ffebld_left (expr));
13084           break;
13085
13086         default:
13087           break;
13088         }
13089     }
13090
13091   return;
13092 }
13093
13094 /* Prepare expression for reading and writing.
13095
13096    Like ffecom_prepare_expr, except for expressions to be evaluated
13097    via ffecom_expr_rw.  */
13098
13099 void
13100 ffecom_prepare_expr_rw (tree type, ffebld expr)
13101 {
13102   /* This is all we support for now.  */
13103   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13104
13105   /* ~~For now, it seems to be the same thing.  */
13106   ffecom_prepare_expr (expr);
13107   return;
13108 }
13109
13110 /* Prepare expression for writing.
13111
13112    Like ffecom_prepare_expr, except for expressions to be evaluated
13113    via ffecom_expr_w.  */
13114
13115 void
13116 ffecom_prepare_expr_w (tree type, ffebld expr)
13117 {
13118   /* This is all we support for now.  */
13119   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13120
13121   /* ~~For now, it seems to be the same thing.  */
13122   ffecom_prepare_expr (expr);
13123   return;
13124 }
13125
13126 /* Prepare expression for returning.
13127
13128    Like ffecom_prepare_expr, except for expressions to be evaluated
13129    via ffecom_return_expr.  */
13130
13131 void
13132 ffecom_prepare_return_expr (ffebld expr)
13133 {
13134   assert (current_binding_level->prep_state < 2);
13135
13136   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
13137       && ffecom_is_altreturning_
13138       && expr != NULL)
13139     ffecom_prepare_expr (expr);
13140 }
13141
13142 /* Prepare pointer to expression.
13143
13144    Like ffecom_prepare_expr, except for expressions to be evaluated
13145    via ffecom_ptr_to_expr.  */
13146
13147 void
13148 ffecom_prepare_ptr_to_expr (ffebld expr)
13149 {
13150   /* ~~For now, it seems to be the same thing.  */
13151   ffecom_prepare_expr (expr);
13152   return;
13153 }
13154
13155 /* Transform expression into constant pointer-to-expression tree.
13156
13157    If the expression can be transformed into a pointer-to-expression tree
13158    that is constant, that is done, and the tree returned.  Else NULL_TREE
13159    is returned.
13160
13161    That way, a caller can attempt to provide compile-time initialization
13162    of a variable and, if that fails, *then* choose to start a new block
13163    and resort to using temporaries, as appropriate.  */
13164
13165 tree
13166 ffecom_ptr_to_const_expr (ffebld expr)
13167 {
13168   if (! expr)
13169     return integer_zero_node;
13170
13171   if (ffebld_op (expr) == FFEBLD_opANY)
13172     return error_mark_node;
13173
13174   if (ffebld_arity (expr) == 0
13175       && (ffebld_op (expr) != FFEBLD_opSYMTER
13176           || ffebld_where (expr) == FFEINFO_whereCOMMON
13177           || ffebld_where (expr) == FFEINFO_whereGLOBAL
13178           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
13179     {
13180       tree t;
13181
13182       t = ffecom_ptr_to_expr (expr);
13183       assert (TREE_CONSTANT (t));
13184       return t;
13185     }
13186
13187   return NULL_TREE;
13188 }
13189
13190 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13191
13192    tree rtn;  // NULL_TREE means use expand_null_return()
13193    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13194    rtn = ffecom_return_expr(expr);
13195
13196    Based on the program unit type and other info (like return function
13197    type, return master function type when alternate ENTRY points,
13198    whether subroutine has any alternate RETURN points, etc), returns the
13199    appropriate expression to be returned to the caller, or NULL_TREE
13200    meaning no return value or the caller expects it to be returned somewhere
13201    else (which is handled by other parts of this module).  */
13202
13203 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13204 tree
13205 ffecom_return_expr (ffebld expr)
13206 {
13207   tree rtn;
13208
13209   switch (ffecom_primary_entry_kind_)
13210     {
13211     case FFEINFO_kindPROGRAM:
13212     case FFEINFO_kindBLOCKDATA:
13213       rtn = NULL_TREE;
13214       break;
13215
13216     case FFEINFO_kindSUBROUTINE:
13217       if (!ffecom_is_altreturning_)
13218         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13219       else if (expr == NULL)
13220         rtn = integer_zero_node;
13221       else
13222         rtn = ffecom_expr (expr);
13223       break;
13224
13225     case FFEINFO_kindFUNCTION:
13226       if ((ffecom_multi_retval_ != NULL_TREE)
13227           || (ffesymbol_basictype (ffecom_primary_entry_)
13228               == FFEINFO_basictypeCHARACTER)
13229           || ((ffesymbol_basictype (ffecom_primary_entry_)
13230                == FFEINFO_basictypeCOMPLEX)
13231               && (ffecom_num_entrypoints_ == 0)
13232               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13233         {                       /* Value is returned by direct assignment
13234                                    into (implicit) dummy. */
13235           rtn = NULL_TREE;
13236           break;
13237         }
13238       rtn = ffecom_func_result_;
13239 #if 0
13240       /* Spurious error if RETURN happens before first reference!  So elide
13241          this code.  In particular, for debugging registry, rtn should always
13242          be non-null after all, but TREE_USED won't be set until we encounter
13243          a reference in the code.  Perfectly okay (but weird) code that,
13244          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13245          this diagnostic for no reason.  Have people use -O -Wuninitialized
13246          and leave it to the back end to find obviously weird cases.  */
13247
13248       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13249          situation; if the return value has never been referenced, it won't
13250          have a tree under 2pass mode. */
13251       if ((rtn == NULL_TREE)
13252           || !TREE_USED (rtn))
13253         {
13254           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13255           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13256                        ffesymbol_where_column (ffecom_primary_entry_));
13257           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13258                                          (ffecom_primary_entry_)));
13259           ffebad_finish ();
13260         }
13261 #endif
13262       break;
13263
13264     default:
13265       assert ("bad unit kind" == NULL);
13266     case FFEINFO_kindANY:
13267       rtn = error_mark_node;
13268       break;
13269     }
13270
13271   return rtn;
13272 }
13273
13274 #endif
13275 /* Do save_expr only if tree is not error_mark_node.  */
13276
13277 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13278 tree
13279 ffecom_save_tree (tree t)
13280 {
13281   return save_expr (t);
13282 }
13283 #endif
13284
13285 /* Start a compound statement (block).  */
13286
13287 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13288 void
13289 ffecom_start_compstmt (void)
13290 {
13291   bison_rule_pushlevel_ ();
13292 }
13293 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13294
13295 /* Public entry point for front end to access start_decl.  */
13296
13297 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13298 tree
13299 ffecom_start_decl (tree decl, bool is_initialized)
13300 {
13301   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13302   return start_decl (decl, FALSE);
13303 }
13304
13305 #endif
13306 /* ffecom_sym_commit -- Symbol's state being committed to reality
13307
13308    ffesymbol s;
13309    ffecom_sym_commit(s);
13310
13311    Does whatever the backend needs when a symbol is committed after having
13312    been backtrackable for a period of time.  */
13313
13314 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13315 void
13316 ffecom_sym_commit (ffesymbol s UNUSED)
13317 {
13318   assert (!ffesymbol_retractable ());
13319 }
13320
13321 #endif
13322 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13323
13324    ffecom_sym_end_transition();
13325
13326    Does backend-specific stuff and also calls ffest_sym_end_transition
13327    to do the necessary FFE stuff.
13328
13329    Backtracking is never enabled when this fn is called, so don't worry
13330    about it.  */
13331
13332 ffesymbol
13333 ffecom_sym_end_transition (ffesymbol s)
13334 {
13335   ffestorag st;
13336
13337   assert (!ffesymbol_retractable ());
13338
13339   s = ffest_sym_end_transition (s);
13340
13341 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13342   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13343       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13344     {
13345       ffecom_list_blockdata_
13346         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13347                                               FFEINTRIN_specNONE,
13348                                               FFEINTRIN_impNONE),
13349                            ffecom_list_blockdata_);
13350     }
13351 #endif
13352
13353   /* This is where we finally notice that a symbol has partial initialization
13354      and finalize it. */
13355
13356   if (ffesymbol_accretion (s) != NULL)
13357     {
13358       assert (ffesymbol_init (s) == NULL);
13359       ffecom_notify_init_symbol (s);
13360     }
13361   else if (((st = ffesymbol_storage (s)) != NULL)
13362            && ((st = ffestorag_parent (st)) != NULL)
13363            && (ffestorag_accretion (st) != NULL))
13364     {
13365       assert (ffestorag_init (st) == NULL);
13366       ffecom_notify_init_storage (st);
13367     }
13368
13369 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13370   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13371       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13372       && (ffesymbol_storage (s) != NULL))
13373     {
13374       ffecom_list_common_
13375         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13376                                               FFEINTRIN_specNONE,
13377                                               FFEINTRIN_impNONE),
13378                            ffecom_list_common_);
13379     }
13380 #endif
13381
13382   return s;
13383 }
13384
13385 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13386
13387    ffecom_sym_exec_transition();
13388
13389    Does backend-specific stuff and also calls ffest_sym_exec_transition
13390    to do the necessary FFE stuff.
13391
13392    See the long-winded description in ffecom_sym_learned for info
13393    on handling the situation where backtracking is inhibited.  */
13394
13395 ffesymbol
13396 ffecom_sym_exec_transition (ffesymbol s)
13397 {
13398   s = ffest_sym_exec_transition (s);
13399
13400   return s;
13401 }
13402
13403 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13404
13405    ffesymbol s;
13406    s = ffecom_sym_learned(s);
13407
13408    Called when a new symbol is seen after the exec transition or when more
13409    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13410    it arrives here is that all its latest info is updated already, so its
13411    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13412    field filled in if its gone through here or exec_transition first, and
13413    so on.
13414
13415    The backend probably wants to check ffesymbol_retractable() to see if
13416    backtracking is in effect.  If so, the FFE's changes to the symbol may
13417    be retracted (undone) or committed (ratified), at which time the
13418    appropriate ffecom_sym_retract or _commit function will be called
13419    for that function.
13420
13421    If the backend has its own backtracking mechanism, great, use it so that
13422    committal is a simple operation.  Though it doesn't make much difference,
13423    I suppose: the reason for tentative symbol evolution in the FFE is to
13424    enable error detection in weird incorrect statements early and to disable
13425    incorrect error detection on a correct statement.  The backend is not
13426    likely to introduce any information that'll get involved in these
13427    considerations, so it is probably just fine that the implementation
13428    model for this fn and for _exec_transition is to not do anything
13429    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13430    and instead wait until ffecom_sym_commit is called (which it never
13431    will be as long as we're using ambiguity-detecting statement analysis in
13432    the FFE, which we are initially to shake out the code, but don't depend
13433    on this), otherwise go ahead and do whatever is needed.
13434
13435    In essence, then, when this fn and _exec_transition get called while
13436    backtracking is enabled, a general mechanism would be to flag which (or
13437    both) of these were called (and in what order? neat question as to what
13438    might happen that I'm too lame to think through right now) and then when
13439    _commit is called reproduce the original calling sequence, if any, for
13440    the two fns (at which point backtracking will, of course, be disabled).  */
13441
13442 ffesymbol
13443 ffecom_sym_learned (ffesymbol s)
13444 {
13445   ffestorag_exec_layout (s);
13446
13447   return s;
13448 }
13449
13450 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13451
13452    ffesymbol s;
13453    ffecom_sym_retract(s);
13454
13455    Does whatever the backend needs when a symbol is retracted after having
13456    been backtrackable for a period of time.  */
13457
13458 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13459 void
13460 ffecom_sym_retract (ffesymbol s UNUSED)
13461 {
13462   assert (!ffesymbol_retractable ());
13463
13464 #if 0                           /* GCC doesn't commit any backtrackable sins,
13465                                    so nothing needed here. */
13466   switch (ffesymbol_hook (s).state)
13467     {
13468     case 0:                     /* nothing happened yet. */
13469       break;
13470
13471     case 1:                     /* exec transition happened. */
13472       break;
13473
13474     case 2:                     /* learned happened. */
13475       break;
13476
13477     case 3:                     /* learned then exec. */
13478       break;
13479
13480     case 4:                     /* exec then learned. */
13481       break;
13482
13483     default:
13484       assert ("bad hook state" == NULL);
13485       break;
13486     }
13487 #endif
13488 }
13489
13490 #endif
13491 /* Create temporary gcc label.  */
13492
13493 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13494 tree
13495 ffecom_temp_label ()
13496 {
13497   tree glabel;
13498   static int mynumber = 0;
13499
13500   glabel = build_decl (LABEL_DECL,
13501                        ffecom_get_invented_identifier ("__g77_label_%d",
13502                                                        NULL,
13503                                                        mynumber++),
13504                        void_type_node);
13505   DECL_CONTEXT (glabel) = current_function_decl;
13506   DECL_MODE (glabel) = VOIDmode;
13507
13508   return glabel;
13509 }
13510
13511 #endif
13512 /* Return an expression that is usable as an arg in a conditional context
13513    (IF, DO WHILE, .NOT., and so on).
13514
13515    Use the one provided for the back end as of >2.6.0.  */
13516
13517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13518 tree
13519 ffecom_truth_value (tree expr)
13520 {
13521   return truthvalue_conversion (expr);
13522 }
13523
13524 #endif
13525 /* Return the inversion of a truth value (the inversion of what
13526    ffecom_truth_value builds).
13527
13528    Apparently invert_truthvalue, which is properly in the back end, is
13529    enough for now, so just use it.  */
13530
13531 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13532 tree
13533 ffecom_truth_value_invert (tree expr)
13534 {
13535   return invert_truthvalue (ffecom_truth_value (expr));
13536 }
13537
13538 #endif
13539
13540 /* Return the tree that is the type of the expression, as would be
13541    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13542    transforming the expression, generating temporaries, etc.  */
13543
13544 tree
13545 ffecom_type_expr (ffebld expr)
13546 {
13547   ffeinfoBasictype bt;
13548   ffeinfoKindtype kt;
13549   tree tree_type;
13550
13551   assert (expr != NULL);
13552
13553   bt = ffeinfo_basictype (ffebld_info (expr));
13554   kt = ffeinfo_kindtype (ffebld_info (expr));
13555   tree_type = ffecom_tree_type[bt][kt];
13556
13557   switch (ffebld_op (expr))
13558     {
13559     case FFEBLD_opCONTER:
13560     case FFEBLD_opSYMTER:
13561     case FFEBLD_opARRAYREF:
13562     case FFEBLD_opUPLUS:
13563     case FFEBLD_opPAREN:
13564     case FFEBLD_opUMINUS:
13565     case FFEBLD_opADD:
13566     case FFEBLD_opSUBTRACT:
13567     case FFEBLD_opMULTIPLY:
13568     case FFEBLD_opDIVIDE:
13569     case FFEBLD_opPOWER:
13570     case FFEBLD_opNOT:
13571     case FFEBLD_opFUNCREF:
13572     case FFEBLD_opSUBRREF:
13573     case FFEBLD_opAND:
13574     case FFEBLD_opOR:
13575     case FFEBLD_opXOR:
13576     case FFEBLD_opNEQV:
13577     case FFEBLD_opEQV:
13578     case FFEBLD_opCONVERT:
13579     case FFEBLD_opLT:
13580     case FFEBLD_opLE:
13581     case FFEBLD_opEQ:
13582     case FFEBLD_opNE:
13583     case FFEBLD_opGT:
13584     case FFEBLD_opGE:
13585     case FFEBLD_opPERCENT_LOC:
13586       return tree_type;
13587
13588     case FFEBLD_opACCTER:
13589     case FFEBLD_opARRTER:
13590     case FFEBLD_opITEM:
13591     case FFEBLD_opSTAR:
13592     case FFEBLD_opBOUNDS:
13593     case FFEBLD_opREPEAT:
13594     case FFEBLD_opLABTER:
13595     case FFEBLD_opLABTOK:
13596     case FFEBLD_opIMPDO:
13597     case FFEBLD_opCONCATENATE:
13598     case FFEBLD_opSUBSTR:
13599     default:
13600       assert ("bad op for ffecom_type_expr" == NULL);
13601       /* Fall through. */
13602     case FFEBLD_opANY:
13603       return error_mark_node;
13604     }
13605 }
13606
13607 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13608
13609    If the PARM_DECL already exists, return it, else create it.  It's an
13610    integer_type_node argument for the master function that implements a
13611    subroutine or function with more than one entrypoint and is bound at
13612    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13613    first ENTRY statement, and so on).  */
13614
13615 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13616 tree
13617 ffecom_which_entrypoint_decl ()
13618 {
13619   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13620
13621   return ffecom_which_entrypoint_decl_;
13622 }
13623
13624 #endif
13625 \f
13626 /* The following sections consists of private and public functions
13627    that have the same names and perform roughly the same functions
13628    as counterparts in the C front end.  Changes in the C front end
13629    might affect how things should be done here.  Only functions
13630    needed by the back end should be public here; the rest should
13631    be private (static in the C sense).  Functions needed by other
13632    g77 front-end modules should be accessed by them via public
13633    ffecom_* names, which should themselves call private versions
13634    in this section so the private versions are easy to recognize
13635    when upgrading to a new gcc and finding interesting changes
13636    in the front end.
13637
13638    Functions named after rule "foo:" in c-parse.y are named
13639    "bison_rule_foo_" so they are easy to find.  */
13640
13641 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13642
13643 static void
13644 bison_rule_pushlevel_ ()
13645 {
13646   emit_line_note (input_filename, lineno);
13647   pushlevel (0);
13648   clear_last_expr ();
13649   push_momentary ();
13650   expand_start_bindings (0);
13651 }
13652
13653 static tree
13654 bison_rule_compstmt_ ()
13655 {
13656   tree t;
13657   int keep = kept_level_p ();
13658
13659   /* Make the temps go away.  */
13660   if (! keep)
13661     current_binding_level->names = NULL_TREE;
13662
13663   emit_line_note (input_filename, lineno);
13664   expand_end_bindings (getdecls (), keep, 0);
13665   t = poplevel (keep, 1, 0);
13666   pop_momentary ();
13667
13668   return t;
13669 }
13670
13671 /* Return a definition for a builtin function named NAME and whose data type
13672    is TYPE.  TYPE should be a function type with argument types.
13673    FUNCTION_CODE tells later passes how to compile calls to this function.
13674    See tree.h for its possible values.
13675
13676    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13677    the name to be called if we can't opencode the function.  */
13678
13679 static tree
13680 builtin_function (const char *name, tree type,
13681                   enum built_in_function function_code,
13682                   const char *library_name)
13683 {
13684   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13685   DECL_EXTERNAL (decl) = 1;
13686   TREE_PUBLIC (decl) = 1;
13687   if (library_name)
13688     DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13689   make_decl_rtl (decl, NULL_PTR, 1);
13690   pushdecl (decl);
13691   if (function_code != NOT_BUILT_IN)
13692     {
13693       DECL_BUILT_IN (decl) = 1;
13694       DECL_FUNCTION_CODE (decl) = function_code;
13695     }
13696
13697   return decl;
13698 }
13699
13700 /* Handle when a new declaration NEWDECL
13701    has the same name as an old one OLDDECL
13702    in the same binding contour.
13703    Prints an error message if appropriate.
13704
13705    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13706    Otherwise, return 0.  */
13707
13708 static int
13709 duplicate_decls (tree newdecl, tree olddecl)
13710 {
13711   int types_match = 1;
13712   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13713                            && DECL_INITIAL (newdecl) != 0);
13714   tree oldtype = TREE_TYPE (olddecl);
13715   tree newtype = TREE_TYPE (newdecl);
13716
13717   if (olddecl == newdecl)
13718     return 1;
13719
13720   if (TREE_CODE (newtype) == ERROR_MARK
13721       || TREE_CODE (oldtype) == ERROR_MARK)
13722     types_match = 0;
13723
13724   /* New decl is completely inconsistent with the old one =>
13725      tell caller to replace the old one.
13726      This is always an error except in the case of shadowing a builtin.  */
13727   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13728     return 0;
13729
13730   /* For real parm decl following a forward decl,
13731      return 1 so old decl will be reused.  */
13732   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13733       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13734     return 1;
13735
13736   /* The new declaration is the same kind of object as the old one.
13737      The declarations may partially match.  Print warnings if they don't
13738      match enough.  Ultimately, copy most of the information from the new
13739      decl to the old one, and keep using the old one.  */
13740
13741   if (TREE_CODE (olddecl) == FUNCTION_DECL
13742       && DECL_BUILT_IN (olddecl))
13743     {
13744       /* A function declaration for a built-in function.  */
13745       if (!TREE_PUBLIC (newdecl))
13746         return 0;
13747       else if (!types_match)
13748         {
13749           /* Accept the return type of the new declaration if same modes.  */
13750           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13751           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13752
13753           /* Make sure we put the new type in the same obstack as the old ones.
13754              If the old types are not both in the same obstack, use the
13755              permanent one.  */
13756           if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
13757             push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
13758           else
13759             {
13760               push_obstacks_nochange ();
13761               end_temporary_allocation ();
13762             }
13763
13764           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13765             {
13766               /* Function types may be shared, so we can't just modify
13767                  the return type of olddecl's function type.  */
13768               tree newtype
13769                 = build_function_type (newreturntype,
13770                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13771
13772               types_match = 1;
13773               if (types_match)
13774                 TREE_TYPE (olddecl) = newtype;
13775             }
13776
13777           pop_obstacks ();
13778         }
13779       if (!types_match)
13780         return 0;
13781     }
13782   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13783            && DECL_SOURCE_LINE (olddecl) == 0)
13784     {
13785       /* A function declaration for a predeclared function
13786          that isn't actually built in.  */
13787       if (!TREE_PUBLIC (newdecl))
13788         return 0;
13789       else if (!types_match)
13790         {
13791           /* If the types don't match, preserve volatility indication.
13792              Later on, we will discard everything else about the
13793              default declaration.  */
13794           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13795         }
13796     }
13797
13798   /* Copy all the DECL_... slots specified in the new decl
13799      except for any that we copy here from the old type.
13800
13801      Past this point, we don't change OLDTYPE and NEWTYPE
13802      even if we change the types of NEWDECL and OLDDECL.  */
13803
13804   if (types_match)
13805     {
13806       /* Make sure we put the new type in the same obstack as the old ones.
13807          If the old types are not both in the same obstack, use the permanent
13808          one.  */
13809       if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
13810         push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
13811       else
13812         {
13813           push_obstacks_nochange ();
13814           end_temporary_allocation ();
13815         }
13816
13817       /* Merge the data types specified in the two decls.  */
13818       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13819         TREE_TYPE (newdecl)
13820           = TREE_TYPE (olddecl)
13821             = TREE_TYPE (newdecl);
13822
13823       /* Lay the type out, unless already done.  */
13824       if (oldtype != TREE_TYPE (newdecl))
13825         {
13826           if (TREE_TYPE (newdecl) != error_mark_node)
13827             layout_type (TREE_TYPE (newdecl));
13828           if (TREE_CODE (newdecl) != FUNCTION_DECL
13829               && TREE_CODE (newdecl) != TYPE_DECL
13830               && TREE_CODE (newdecl) != CONST_DECL)
13831             layout_decl (newdecl, 0);
13832         }
13833       else
13834         {
13835           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13836           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13837           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13838             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13839               DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13840         }
13841
13842       /* Keep the old rtl since we can safely use it.  */
13843       DECL_RTL (newdecl) = DECL_RTL (olddecl);
13844
13845       /* Merge the type qualifiers.  */
13846       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13847           && !TREE_THIS_VOLATILE (newdecl))
13848         TREE_THIS_VOLATILE (olddecl) = 0;
13849       if (TREE_READONLY (newdecl))
13850         TREE_READONLY (olddecl) = 1;
13851       if (TREE_THIS_VOLATILE (newdecl))
13852         {
13853           TREE_THIS_VOLATILE (olddecl) = 1;
13854           if (TREE_CODE (newdecl) == VAR_DECL)
13855             make_var_volatile (newdecl);
13856         }
13857
13858       /* Keep source location of definition rather than declaration.
13859          Likewise, keep decl at outer scope.  */
13860       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13861           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13862         {
13863           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13864           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13865
13866           if (DECL_CONTEXT (olddecl) == 0
13867               && TREE_CODE (newdecl) != FUNCTION_DECL)
13868             DECL_CONTEXT (newdecl) = 0;
13869         }
13870
13871       /* Merge the unused-warning information.  */
13872       if (DECL_IN_SYSTEM_HEADER (olddecl))
13873         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13874       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13875         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13876
13877       /* Merge the initialization information.  */
13878       if (DECL_INITIAL (newdecl) == 0)
13879         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13880
13881       /* Merge the section attribute.
13882          We want to issue an error if the sections conflict but that must be
13883          done later in decl_attributes since we are called before attributes
13884          are assigned.  */
13885       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13886         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13887
13888 #if BUILT_FOR_270
13889       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13890         {
13891           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13892           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13893         }
13894 #endif
13895
13896       pop_obstacks ();
13897     }
13898   /* If cannot merge, then use the new type and qualifiers,
13899      and don't preserve the old rtl.  */
13900   else
13901     {
13902       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13903       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13904       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13905       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13906     }
13907
13908   /* Merge the storage class information.  */
13909   /* For functions, static overrides non-static.  */
13910   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13911     {
13912       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13913       /* This is since we don't automatically
13914          copy the attributes of NEWDECL into OLDDECL.  */
13915       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13916       /* If this clears `static', clear it in the identifier too.  */
13917       if (! TREE_PUBLIC (olddecl))
13918         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13919     }
13920   if (DECL_EXTERNAL (newdecl))
13921     {
13922       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13923       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13924       /* An extern decl does not override previous storage class.  */
13925       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13926     }
13927   else
13928     {
13929       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13930       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13931     }
13932
13933   /* If either decl says `inline', this fn is inline,
13934      unless its definition was passed already.  */
13935   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13936     DECL_INLINE (olddecl) = 1;
13937   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13938
13939   /* Get rid of any built-in function if new arg types don't match it
13940      or if we have a function definition.  */
13941   if (TREE_CODE (newdecl) == FUNCTION_DECL
13942       && DECL_BUILT_IN (olddecl)
13943       && (!types_match || new_is_definition))
13944     {
13945       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13946       DECL_BUILT_IN (olddecl) = 0;
13947     }
13948
13949   /* If redeclaring a builtin function, and not a definition,
13950      it stays built in.
13951      Also preserve various other info from the definition.  */
13952   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13953     {
13954       if (DECL_BUILT_IN (olddecl))
13955         {
13956           DECL_BUILT_IN (newdecl) = 1;
13957           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13958         }
13959       else
13960         DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
13961
13962       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13963       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13964       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13965       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13966     }
13967
13968   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13969      But preserve olddecl's DECL_UID.  */
13970   {
13971     register unsigned olddecl_uid = DECL_UID (olddecl);
13972
13973     memcpy ((char *) olddecl + sizeof (struct tree_common),
13974             (char *) newdecl + sizeof (struct tree_common),
13975             sizeof (struct tree_decl) - sizeof (struct tree_common));
13976     DECL_UID (olddecl) = olddecl_uid;
13977   }
13978
13979   return 1;
13980 }
13981
13982 /* Finish processing of a declaration;
13983    install its initial value.
13984    If the length of an array type is not known before,
13985    it must be determined now, from the initial value, or it is an error.  */
13986
13987 static void
13988 finish_decl (tree decl, tree init, bool is_top_level)
13989 {
13990   register tree type = TREE_TYPE (decl);
13991   int was_incomplete = (DECL_SIZE (decl) == 0);
13992   int temporary = allocation_temporary_p ();
13993   bool at_top_level = (current_binding_level == global_binding_level);
13994   bool top_level = is_top_level || at_top_level;
13995
13996   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13997      level anyway.  */
13998   assert (!is_top_level || !at_top_level);
13999
14000   if (TREE_CODE (decl) == PARM_DECL)
14001     assert (init == NULL_TREE);
14002   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
14003      overlaps DECL_ARG_TYPE.  */
14004   else if (init == NULL_TREE)
14005     assert (DECL_INITIAL (decl) == NULL_TREE);
14006   else
14007     assert (DECL_INITIAL (decl) == error_mark_node);
14008
14009   if (init != NULL_TREE)
14010     {
14011       if (TREE_CODE (decl) != TYPE_DECL)
14012         DECL_INITIAL (decl) = init;
14013       else
14014         {
14015           /* typedef foo = bar; store the type of bar as the type of foo.  */
14016           TREE_TYPE (decl) = TREE_TYPE (init);
14017           DECL_INITIAL (decl) = init = 0;
14018         }
14019     }
14020
14021   /* Pop back to the obstack that is current for this binding level. This is
14022      because MAXINDEX, rtl, etc. to be made below must go in the permanent
14023      obstack.  But don't discard the temporary data yet.  */
14024   pop_obstacks ();
14025
14026   /* Deduce size of array from initialization, if not already known */
14027
14028   if (TREE_CODE (type) == ARRAY_TYPE
14029       && TYPE_DOMAIN (type) == 0
14030       && TREE_CODE (decl) != TYPE_DECL)
14031     {
14032       assert (top_level);
14033       assert (was_incomplete);
14034
14035       layout_decl (decl, 0);
14036     }
14037
14038   if (TREE_CODE (decl) == VAR_DECL)
14039     {
14040       if (DECL_SIZE (decl) == NULL_TREE
14041           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
14042         layout_decl (decl, 0);
14043
14044       if (DECL_SIZE (decl) == NULL_TREE
14045           && (TREE_STATIC (decl)
14046               ?
14047       /* A static variable with an incomplete type is an error if it is
14048          initialized. Also if it is not file scope. Otherwise, let it
14049          through, but if it is not `extern' then it may cause an error
14050          message later.  */
14051               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
14052               :
14053       /* An automatic variable with an incomplete type is an error.  */
14054               !DECL_EXTERNAL (decl)))
14055         {
14056           assert ("storage size not known" == NULL);
14057           abort ();
14058         }
14059
14060       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
14061           && (DECL_SIZE (decl) != 0)
14062           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
14063         {
14064           assert ("storage size not constant" == NULL);
14065           abort ();
14066         }
14067     }
14068
14069   /* Output the assembler code and/or RTL code for variables and functions,
14070      unless the type is an undefined structure or union. If not, it will get
14071      done when the type is completed.  */
14072
14073   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
14074     {
14075       rest_of_decl_compilation (decl, NULL,
14076                                 DECL_CONTEXT (decl) == 0,
14077                                 0);
14078
14079       if (DECL_CONTEXT (decl) != 0)
14080         {
14081           /* Recompute the RTL of a local array now if it used to be an
14082              incomplete type.  */
14083           if (was_incomplete
14084               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
14085             {
14086               /* If we used it already as memory, it must stay in memory.  */
14087               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
14088               /* If it's still incomplete now, no init will save it.  */
14089               if (DECL_SIZE (decl) == 0)
14090                 DECL_INITIAL (decl) = 0;
14091               expand_decl (decl);
14092             }
14093           /* Compute and store the initial value.  */
14094           if (TREE_CODE (decl) != FUNCTION_DECL)
14095             expand_decl_init (decl);
14096         }
14097     }
14098   else if (TREE_CODE (decl) == TYPE_DECL)
14099     {
14100       rest_of_decl_compilation (decl, NULL_PTR,
14101                                 DECL_CONTEXT (decl) == 0,
14102                                 0);
14103     }
14104
14105   /* This test used to include TREE_PERMANENT, however, we have the same
14106      problem with initializers at the function level.  Such initializers get
14107      saved until the end of the function on the momentary_obstack.  */
14108   if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
14109       && temporary
14110   /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
14111      DECL_ARG_TYPE.  */
14112       && TREE_CODE (decl) != PARM_DECL)
14113     {
14114       /* We need to remember that this array HAD an initialization, but
14115          discard the actual temporary nodes, since we can't have a permanent
14116          node keep pointing to them.  */
14117       /* We make an exception for inline functions, since it's normal for a
14118          local extern redeclaration of an inline function to have a copy of
14119          the top-level decl's DECL_INLINE.  */
14120       if ((DECL_INITIAL (decl) != 0)
14121           && (DECL_INITIAL (decl) != error_mark_node))
14122         {
14123           /* If this is a const variable, then preserve the
14124              initializer instead of discarding it so that we can optimize
14125              references to it.  */
14126           /* This test used to include TREE_STATIC, but this won't be set
14127              for function level initializers.  */
14128           if (TREE_READONLY (decl))
14129             {
14130               preserve_initializer ();
14131               /* Hack?  Set the permanent bit for something that is
14132                  permanent, but not on the permenent obstack, so as to
14133                  convince output_constant_def to make its rtl on the
14134                  permanent obstack.  */
14135               TREE_PERMANENT (DECL_INITIAL (decl)) = 1;
14136
14137               /* The initializer and DECL must have the same (or equivalent
14138                  types), but if the initializer is a STRING_CST, its type
14139                  might not be on the right obstack, so copy the type
14140                  of DECL.  */
14141               TREE_TYPE (DECL_INITIAL (decl)) = type;
14142             }
14143           else
14144             DECL_INITIAL (decl) = error_mark_node;
14145         }
14146     }
14147
14148   /* If requested, warn about definitions of large data objects.  */
14149
14150   if (warn_larger_than
14151       && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL)
14152       && !DECL_EXTERNAL (decl))
14153     {
14154       register tree decl_size = DECL_SIZE (decl);
14155
14156       if (decl_size && TREE_CODE (decl_size) == INTEGER_CST)
14157         {
14158            unsigned units = TREE_INT_CST_LOW (decl_size) / BITS_PER_UNIT;
14159
14160           if (units > larger_than_size)
14161             warning_with_decl (decl, "size of `%s' is %u bytes", units);
14162         }
14163     }
14164
14165   /* If we have gone back from temporary to permanent allocation, actually
14166      free the temporary space that we no longer need.  */
14167   if (temporary && !allocation_temporary_p ())
14168     permanent_allocation (0);
14169
14170   /* At the end of a declaration, throw away any variable type sizes of types
14171      defined inside that declaration.  There is no use computing them in the
14172      following function definition.  */
14173   if (current_binding_level == global_binding_level)
14174     get_pending_sizes ();
14175 }
14176
14177 /* Finish up a function declaration and compile that function
14178    all the way to assembler language output.  The free the storage
14179    for the function definition.
14180
14181    This is called after parsing the body of the function definition.
14182
14183    NESTED is nonzero if the function being finished is nested in another.  */
14184
14185 static void
14186 finish_function (int nested)
14187 {
14188   register tree fndecl = current_function_decl;
14189
14190   assert (fndecl != NULL_TREE);
14191   if (TREE_CODE (fndecl) != ERROR_MARK)
14192     {
14193       if (nested)
14194         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
14195       else
14196         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
14197     }
14198
14199 /*  TREE_READONLY (fndecl) = 1;
14200     This caused &foo to be of type ptr-to-const-function
14201     which then got a warning when stored in a ptr-to-function variable.  */
14202
14203   poplevel (1, 0, 1);
14204
14205   if (TREE_CODE (fndecl) != ERROR_MARK)
14206     {
14207       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
14208
14209       /* Must mark the RESULT_DECL as being in this function.  */
14210
14211       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
14212
14213       /* Obey `register' declarations if `setjmp' is called in this fn.  */
14214       /* Generate rtl for function exit.  */
14215       expand_function_end (input_filename, lineno, 0);
14216
14217       /* So we can tell if jump_optimize sets it to 1.  */
14218       can_reach_end = 0;
14219
14220       /* Run the optimizers and output the assembler code for this function.  */
14221       rest_of_compilation (fndecl);
14222     }
14223
14224   /* Free all the tree nodes making up this function.  */
14225   /* Switch back to allocating nodes permanently until we start another
14226      function.  */
14227   if (!nested)
14228     permanent_allocation (1);
14229
14230   if (TREE_CODE (fndecl) != ERROR_MARK
14231       && !nested
14232       && DECL_SAVED_INSNS (fndecl) == 0)
14233     {
14234       /* Stop pointing to the local nodes about to be freed.  */
14235       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14236          function definition.  */
14237       /* For a nested function, this is done in pop_f_function_context.  */
14238       /* If rest_of_compilation set this to 0, leave it 0.  */
14239       if (DECL_INITIAL (fndecl) != 0)
14240         DECL_INITIAL (fndecl) = error_mark_node;
14241       DECL_ARGUMENTS (fndecl) = 0;
14242     }
14243
14244   if (!nested)
14245     {
14246       /* Let the error reporting routines know that we're outside a function.
14247          For a nested function, this value is used in pop_c_function_context
14248          and then reset via pop_function_context.  */
14249       ffecom_outer_function_decl_ = current_function_decl = NULL;
14250     }
14251 }
14252
14253 /* Plug-in replacement for identifying the name of a decl and, for a
14254    function, what we call it in diagnostics.  For now, "program unit"
14255    should suffice, since it's a bit of a hassle to figure out which
14256    of several kinds of things it is.  Note that it could conceivably
14257    be a statement function, which probably isn't really a program unit
14258    per se, but if that comes up, it should be easy to check (being a
14259    nested function and all).  */
14260
14261 static char *
14262 lang_printable_name (tree decl, int v)
14263 {
14264   /* Just to keep GCC quiet about the unused variable.
14265      In theory, differing values of V should produce different
14266      output.  */
14267   switch (v)
14268     {
14269     default:
14270       if (TREE_CODE (decl) == ERROR_MARK)
14271         return "erroneous code";
14272       return IDENTIFIER_POINTER (DECL_NAME (decl));
14273     }
14274 }
14275
14276 /* g77's function to print out name of current function that caused
14277    an error.  */
14278
14279 #if BUILT_FOR_270
14280 void
14281 lang_print_error_function (file)
14282      char *file;
14283 {
14284   static ffeglobal last_g = NULL;
14285   static ffesymbol last_s = NULL;
14286   ffeglobal g;
14287   ffesymbol s;
14288   const char *kind;
14289
14290   if ((ffecom_primary_entry_ == NULL)
14291       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14292     {
14293       g = NULL;
14294       s = NULL;
14295       kind = NULL;
14296     }
14297   else
14298     {
14299       g = ffesymbol_global (ffecom_primary_entry_);
14300       if (ffecom_nested_entry_ == NULL)
14301         {
14302           s = ffecom_primary_entry_;
14303           switch (ffesymbol_kind (s))
14304             {
14305             case FFEINFO_kindFUNCTION:
14306               kind = "function";
14307               break;
14308
14309             case FFEINFO_kindSUBROUTINE:
14310               kind = "subroutine";
14311               break;
14312
14313             case FFEINFO_kindPROGRAM:
14314               kind = "program";
14315               break;
14316
14317             case FFEINFO_kindBLOCKDATA:
14318               kind = "block-data";
14319               break;
14320
14321             default:
14322               kind = ffeinfo_kind_message (ffesymbol_kind (s));
14323               break;
14324             }
14325         }
14326       else
14327         {
14328           s = ffecom_nested_entry_;
14329           kind = "statement function";
14330         }
14331     }
14332
14333   if ((last_g != g) || (last_s != s))
14334     {
14335       if (file)
14336         fprintf (stderr, "%s: ", file);
14337
14338       if (s == NULL)
14339         fprintf (stderr, "Outside of any program unit:\n");
14340       else
14341         {
14342           const char *name = ffesymbol_text (s);
14343
14344           fprintf (stderr, "In %s `%s':\n", kind, name);
14345         }
14346
14347       last_g = g;
14348       last_s = s;
14349     }
14350 }
14351 #endif
14352
14353 /* Similar to `lookup_name' but look only at current binding level.  */
14354
14355 static tree
14356 lookup_name_current_level (tree name)
14357 {
14358   register tree t;
14359
14360   if (current_binding_level == global_binding_level)
14361     return IDENTIFIER_GLOBAL_VALUE (name);
14362
14363   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14364     return 0;
14365
14366   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14367     if (DECL_NAME (t) == name)
14368       break;
14369
14370   return t;
14371 }
14372
14373 /* Create a new `struct binding_level'.  */
14374
14375 static struct binding_level *
14376 make_binding_level ()
14377 {
14378   /* NOSTRICT */
14379   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14380 }
14381
14382 /* Save and restore the variables in this file and elsewhere
14383    that keep track of the progress of compilation of the current function.
14384    Used for nested functions.  */
14385
14386 struct f_function
14387 {
14388   struct f_function *next;
14389   tree named_labels;
14390   tree shadowed_labels;
14391   struct binding_level *binding_level;
14392 };
14393
14394 struct f_function *f_function_chain;
14395
14396 /* Restore the variables used during compilation of a C function.  */
14397
14398 static void
14399 pop_f_function_context ()
14400 {
14401   struct f_function *p = f_function_chain;
14402   tree link;
14403
14404   /* Bring back all the labels that were shadowed.  */
14405   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14406     if (DECL_NAME (TREE_VALUE (link)) != 0)
14407       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14408         = TREE_VALUE (link);
14409
14410   if (current_function_decl != error_mark_node
14411       && DECL_SAVED_INSNS (current_function_decl) == 0)
14412     {
14413       /* Stop pointing to the local nodes about to be freed.  */
14414       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14415          function definition.  */
14416       DECL_INITIAL (current_function_decl) = error_mark_node;
14417       DECL_ARGUMENTS (current_function_decl) = 0;
14418     }
14419
14420   pop_function_context ();
14421
14422   f_function_chain = p->next;
14423
14424   named_labels = p->named_labels;
14425   shadowed_labels = p->shadowed_labels;
14426   current_binding_level = p->binding_level;
14427
14428   free (p);
14429 }
14430
14431 /* Save and reinitialize the variables
14432    used during compilation of a C function.  */
14433
14434 static void
14435 push_f_function_context ()
14436 {
14437   struct f_function *p
14438   = (struct f_function *) xmalloc (sizeof (struct f_function));
14439
14440   push_function_context ();
14441
14442   p->next = f_function_chain;
14443   f_function_chain = p;
14444
14445   p->named_labels = named_labels;
14446   p->shadowed_labels = shadowed_labels;
14447   p->binding_level = current_binding_level;
14448 }
14449
14450 static void
14451 push_parm_decl (tree parm)
14452 {
14453   int old_immediate_size_expand = immediate_size_expand;
14454
14455   /* Don't try computing parm sizes now -- wait till fn is called.  */
14456
14457   immediate_size_expand = 0;
14458
14459   push_obstacks_nochange ();
14460
14461   /* Fill in arg stuff.  */
14462
14463   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14464   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14465   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14466
14467   parm = pushdecl (parm);
14468
14469   immediate_size_expand = old_immediate_size_expand;
14470
14471   finish_decl (parm, NULL_TREE, FALSE);
14472 }
14473
14474 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14475
14476 static tree
14477 pushdecl_top_level (x)
14478      tree x;
14479 {
14480   register tree t;
14481   register struct binding_level *b = current_binding_level;
14482   register tree f = current_function_decl;
14483
14484   current_binding_level = global_binding_level;
14485   current_function_decl = NULL_TREE;
14486   t = pushdecl (x);
14487   current_binding_level = b;
14488   current_function_decl = f;
14489   return t;
14490 }
14491
14492 /* Store the list of declarations of the current level.
14493    This is done for the parameter declarations of a function being defined,
14494    after they are modified in the light of any missing parameters.  */
14495
14496 static tree
14497 storedecls (decls)
14498      tree decls;
14499 {
14500   return current_binding_level->names = decls;
14501 }
14502
14503 /* Store the parameter declarations into the current function declaration.
14504    This is called after parsing the parameter declarations, before
14505    digesting the body of the function.
14506
14507    For an old-style definition, modify the function's type
14508    to specify at least the number of arguments.  */
14509
14510 static void
14511 store_parm_decls (int is_main_program UNUSED)
14512 {
14513   register tree fndecl = current_function_decl;
14514
14515   if (fndecl == error_mark_node)
14516     return;
14517
14518   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14519   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14520
14521   /* Initialize the RTL code for the function.  */
14522
14523   init_function_start (fndecl, input_filename, lineno);
14524
14525   /* Set up parameters and prepare for return, for the function.  */
14526
14527   expand_function_start (fndecl, 0);
14528 }
14529
14530 static tree
14531 start_decl (tree decl, bool is_top_level)
14532 {
14533   register tree tem;
14534   bool at_top_level = (current_binding_level == global_binding_level);
14535   bool top_level = is_top_level || at_top_level;
14536
14537   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14538      level anyway.  */
14539   assert (!is_top_level || !at_top_level);
14540
14541   /* The corresponding pop_obstacks is in finish_decl.  */
14542   push_obstacks_nochange ();
14543
14544   if (DECL_INITIAL (decl) != NULL_TREE)
14545     {
14546       assert (DECL_INITIAL (decl) == error_mark_node);
14547       assert (!DECL_EXTERNAL (decl));
14548     }
14549   else if (top_level)
14550     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14551
14552   /* For Fortran, we by default put things in .common when possible.  */
14553   DECL_COMMON (decl) = 1;
14554
14555   /* Add this decl to the current binding level. TEM may equal DECL or it may
14556      be a previous decl of the same name.  */
14557   if (is_top_level)
14558     tem = pushdecl_top_level (decl);
14559   else
14560     tem = pushdecl (decl);
14561
14562   /* For a local variable, define the RTL now.  */
14563   if (!top_level
14564   /* But not if this is a duplicate decl and we preserved the rtl from the
14565      previous one (which may or may not happen).  */
14566       && DECL_RTL (tem) == 0)
14567     {
14568       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14569         expand_decl (tem);
14570       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14571                && DECL_INITIAL (tem) != 0)
14572         expand_decl (tem);
14573     }
14574
14575   if (DECL_INITIAL (tem) != NULL_TREE)
14576     {
14577       /* When parsing and digesting the initializer, use temporary storage.
14578          Do this even if we will ignore the value.  */
14579       if (at_top_level)
14580         temporary_allocation ();
14581     }
14582
14583   return tem;
14584 }
14585
14586 /* Create the FUNCTION_DECL for a function definition.
14587    DECLSPECS and DECLARATOR are the parts of the declaration;
14588    they describe the function's name and the type it returns,
14589    but twisted together in a fashion that parallels the syntax of C.
14590
14591    This function creates a binding context for the function body
14592    as well as setting up the FUNCTION_DECL in current_function_decl.
14593
14594    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14595    (it defines a datum instead), we return 0, which tells
14596    yyparse to report a parse error.
14597
14598    NESTED is nonzero for a function nested within another function.  */
14599
14600 static void
14601 start_function (tree name, tree type, int nested, int public)
14602 {
14603   tree decl1;
14604   tree restype;
14605   int old_immediate_size_expand = immediate_size_expand;
14606
14607   named_labels = 0;
14608   shadowed_labels = 0;
14609
14610   /* Don't expand any sizes in the return type of the function.  */
14611   immediate_size_expand = 0;
14612
14613   if (nested)
14614     {
14615       assert (!public);
14616       assert (current_function_decl != NULL_TREE);
14617       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14618     }
14619   else
14620     {
14621       assert (current_function_decl == NULL_TREE);
14622     }
14623
14624   if (TREE_CODE (type) == ERROR_MARK)
14625     decl1 = current_function_decl = error_mark_node;
14626   else
14627     {
14628       decl1 = build_decl (FUNCTION_DECL,
14629                           name,
14630                           type);
14631       TREE_PUBLIC (decl1) = public ? 1 : 0;
14632       if (nested)
14633         DECL_INLINE (decl1) = 1;
14634       TREE_STATIC (decl1) = 1;
14635       DECL_EXTERNAL (decl1) = 0;
14636
14637       announce_function (decl1);
14638
14639       /* Make the init_value nonzero so pushdecl knows this is not tentative.
14640          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14641       DECL_INITIAL (decl1) = error_mark_node;
14642
14643       /* Record the decl so that the function name is defined. If we already have
14644          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14645
14646       current_function_decl = pushdecl (decl1);
14647     }
14648
14649   if (!nested)
14650     ffecom_outer_function_decl_ = current_function_decl;
14651
14652   pushlevel (0);
14653   current_binding_level->prep_state = 2;
14654
14655   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14656     {
14657       make_function_rtl (current_function_decl);
14658
14659       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14660       DECL_RESULT (current_function_decl)
14661         = build_decl (RESULT_DECL, NULL_TREE, restype);
14662     }
14663
14664   if (!nested)
14665     /* Allocate further tree nodes temporarily during compilation of this
14666        function only.  */
14667     temporary_allocation ();
14668
14669   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14670     TREE_ADDRESSABLE (current_function_decl) = 1;
14671
14672   immediate_size_expand = old_immediate_size_expand;
14673 }
14674 \f
14675 /* Here are the public functions the GNU back end needs.  */
14676
14677 tree
14678 convert (type, expr)
14679      tree type, expr;
14680 {
14681   register tree e = expr;
14682   register enum tree_code code = TREE_CODE (type);
14683
14684   if (type == TREE_TYPE (e)
14685       || TREE_CODE (e) == ERROR_MARK)
14686     return e;
14687   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14688     return fold (build1 (NOP_EXPR, type, e));
14689   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14690       || code == ERROR_MARK)
14691     return error_mark_node;
14692   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14693     {
14694       assert ("void value not ignored as it ought to be" == NULL);
14695       return error_mark_node;
14696     }
14697   if (code == VOID_TYPE)
14698     return build1 (CONVERT_EXPR, type, e);
14699   if ((code != RECORD_TYPE)
14700       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14701     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14702                   e);
14703   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14704     return fold (convert_to_integer (type, e));
14705   if (code == POINTER_TYPE)
14706     return fold (convert_to_pointer (type, e));
14707   if (code == REAL_TYPE)
14708     return fold (convert_to_real (type, e));
14709   if (code == COMPLEX_TYPE)
14710     return fold (convert_to_complex (type, e));
14711   if (code == RECORD_TYPE)
14712     return fold (ffecom_convert_to_complex_ (type, e));
14713
14714   assert ("conversion to non-scalar type requested" == NULL);
14715   return error_mark_node;
14716 }
14717
14718 /* integrate_decl_tree calls this function, but since we don't use the
14719    DECL_LANG_SPECIFIC field, this is a no-op.  */
14720
14721 void
14722 copy_lang_decl (node)
14723      tree node UNUSED;
14724 {
14725 }
14726
14727 /* Return the list of declarations of the current level.
14728    Note that this list is in reverse order unless/until
14729    you nreverse it; and when you do nreverse it, you must
14730    store the result back using `storedecls' or you will lose.  */
14731
14732 tree
14733 getdecls ()
14734 {
14735   return current_binding_level->names;
14736 }
14737
14738 /* Nonzero if we are currently in the global binding level.  */
14739
14740 int
14741 global_bindings_p ()
14742 {
14743   return current_binding_level == global_binding_level;
14744 }
14745
14746 /* Print an error message for invalid use of an incomplete type.
14747    VALUE is the expression that was used (or 0 if that isn't known)
14748    and TYPE is the type that was invalid.  */
14749
14750 void
14751 incomplete_type_error (value, type)
14752      tree value UNUSED;
14753      tree type;
14754 {
14755   if (TREE_CODE (type) == ERROR_MARK)
14756     return;
14757
14758   assert ("incomplete type?!?" == NULL);
14759 }
14760
14761 void
14762 init_decl_processing ()
14763 {
14764   malloc_init ();
14765   ffe_init_0 ();
14766 }
14767
14768 char *
14769 init_parse (filename)
14770      char *filename;
14771 {
14772 #if BUILT_FOR_270
14773   extern void (*print_error_function) (char *);
14774 #endif
14775
14776   /* Open input file.  */
14777   if (filename == 0 || !strcmp (filename, "-"))
14778     {
14779       finput = stdin;
14780       filename = "stdin";
14781     }
14782   else
14783     finput = fopen (filename, "r");
14784   if (finput == 0)
14785     pfatal_with_name (filename);
14786
14787 #ifdef IO_BUFFER_SIZE
14788   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14789 #endif
14790
14791   /* Make identifier nodes long enough for the language-specific slots.  */
14792   set_identifier_size (sizeof (struct lang_identifier));
14793   decl_printable_name = lang_printable_name;
14794 #if BUILT_FOR_270
14795   print_error_function = lang_print_error_function;
14796 #endif
14797
14798   return filename;
14799 }
14800
14801 void
14802 finish_parse ()
14803 {
14804   fclose (finput);
14805 }
14806
14807 /* Delete the node BLOCK from the current binding level.
14808    This is used for the block inside a stmt expr ({...})
14809    so that the block can be reinserted where appropriate.  */
14810
14811 static void
14812 delete_block (block)
14813      tree block;
14814 {
14815   tree t;
14816   if (current_binding_level->blocks == block)
14817     current_binding_level->blocks = TREE_CHAIN (block);
14818   for (t = current_binding_level->blocks; t;)
14819     {
14820       if (TREE_CHAIN (t) == block)
14821         TREE_CHAIN (t) = TREE_CHAIN (block);
14822       else
14823         t = TREE_CHAIN (t);
14824     }
14825   TREE_CHAIN (block) = NULL;
14826   /* Clear TREE_USED which is always set by poplevel.
14827      The flag is set again if insert_block is called.  */
14828   TREE_USED (block) = 0;
14829 }
14830
14831 void
14832 insert_block (block)
14833      tree block;
14834 {
14835   TREE_USED (block) = 1;
14836   current_binding_level->blocks
14837     = chainon (current_binding_level->blocks, block);
14838 }
14839
14840 int
14841 lang_decode_option (argc, argv)
14842      int argc;
14843      char **argv;
14844 {
14845   return ffe_decode_option (argc, argv);
14846 }
14847
14848 /* used by print-tree.c */
14849
14850 void
14851 lang_print_xnode (file, node, indent)
14852      FILE *file UNUSED;
14853      tree node UNUSED;
14854      int indent UNUSED;
14855 {
14856 }
14857
14858 void
14859 lang_finish ()
14860 {
14861   ffe_terminate_0 ();
14862
14863   if (ffe_is_ffedebug ())
14864     malloc_pool_display (malloc_pool_image ());
14865 }
14866
14867 char *
14868 lang_identify ()
14869 {
14870   return "f77";
14871 }
14872
14873 void
14874 lang_init_options ()
14875 {
14876   /* Set default options for Fortran.  */
14877   flag_move_all_movables = 1;
14878   flag_reduce_all_givs = 1;
14879   flag_argument_noalias = 2;
14880 }
14881
14882 void
14883 lang_init ()
14884 {
14885   /* If the file is output from cpp, it should contain a first line
14886      `# 1 "real-filename"', and the current design of gcc (toplev.c
14887      in particular and the way it sets up information relied on by
14888      INCLUDE) requires that we read this now, and store the
14889      "real-filename" info in master_input_filename.  Ask the lexer
14890      to try doing this.  */
14891   ffelex_hash_kludge (finput);
14892 }
14893
14894 int
14895 mark_addressable (exp)
14896      tree exp;
14897 {
14898   register tree x = exp;
14899   while (1)
14900     switch (TREE_CODE (x))
14901       {
14902       case ADDR_EXPR:
14903       case COMPONENT_REF:
14904       case ARRAY_REF:
14905         x = TREE_OPERAND (x, 0);
14906         break;
14907
14908       case CONSTRUCTOR:
14909         TREE_ADDRESSABLE (x) = 1;
14910         return 1;
14911
14912       case VAR_DECL:
14913       case CONST_DECL:
14914       case PARM_DECL:
14915       case RESULT_DECL:
14916         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14917             && DECL_NONLOCAL (x))
14918           {
14919             if (TREE_PUBLIC (x))
14920               {
14921                 assert ("address of global register var requested" == NULL);
14922                 return 0;
14923               }
14924             assert ("address of register variable requested" == NULL);
14925           }
14926         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14927           {
14928             if (TREE_PUBLIC (x))
14929               {
14930                 assert ("address of global register var requested" == NULL);
14931                 return 0;
14932               }
14933             assert ("address of register var requested" == NULL);
14934           }
14935         put_var_into_stack (x);
14936
14937         /* drops in */
14938       case FUNCTION_DECL:
14939         TREE_ADDRESSABLE (x) = 1;
14940 #if 0                           /* poplevel deals with this now.  */
14941         if (DECL_CONTEXT (x) == 0)
14942           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14943 #endif
14944
14945       default:
14946         return 1;
14947       }
14948 }
14949
14950 /* If DECL has a cleanup, build and return that cleanup here.
14951    This is a callback called by expand_expr.  */
14952
14953 tree
14954 maybe_build_cleanup (decl)
14955      tree decl UNUSED;
14956 {
14957   /* There are no cleanups in Fortran.  */
14958   return NULL_TREE;
14959 }
14960
14961 /* Exit a binding level.
14962    Pop the level off, and restore the state of the identifier-decl mappings
14963    that were in effect when this level was entered.
14964
14965    If KEEP is nonzero, this level had explicit declarations, so
14966    and create a "block" (a BLOCK node) for the level
14967    to record its declarations and subblocks for symbol table output.
14968
14969    If FUNCTIONBODY is nonzero, this level is the body of a function,
14970    so create a block as if KEEP were set and also clear out all
14971    label names.
14972
14973    If REVERSE is nonzero, reverse the order of decls before putting
14974    them into the BLOCK.  */
14975
14976 tree
14977 poplevel (keep, reverse, functionbody)
14978      int keep;
14979      int reverse;
14980      int functionbody;
14981 {
14982   register tree link;
14983   /* The chain of decls was accumulated in reverse order.
14984      Put it into forward order, just for cleanliness.  */
14985   tree decls;
14986   tree subblocks = current_binding_level->blocks;
14987   tree block = 0;
14988   tree decl;
14989   int block_previously_created;
14990
14991   /* Get the decls in the order they were written.
14992      Usually current_binding_level->names is in reverse order.
14993      But parameter decls were previously put in forward order.  */
14994
14995   if (reverse)
14996     current_binding_level->names
14997       = decls = nreverse (current_binding_level->names);
14998   else
14999     decls = current_binding_level->names;
15000
15001   /* Output any nested inline functions within this block
15002      if they weren't already output.  */
15003
15004   for (decl = decls; decl; decl = TREE_CHAIN (decl))
15005     if (TREE_CODE (decl) == FUNCTION_DECL
15006         && ! TREE_ASM_WRITTEN (decl)
15007         && DECL_INITIAL (decl) != 0
15008         && TREE_ADDRESSABLE (decl))
15009       {
15010         /* If this decl was copied from a file-scope decl
15011            on account of a block-scope extern decl,
15012            propagate TREE_ADDRESSABLE to the file-scope decl.
15013
15014            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
15015            true, since then the decl goes through save_for_inline_copying.  */
15016         if (DECL_ABSTRACT_ORIGIN (decl) != 0
15017             && DECL_ABSTRACT_ORIGIN (decl) != decl)
15018           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
15019         else if (DECL_SAVED_INSNS (decl) != 0)
15020           {
15021             push_function_context ();
15022             output_inline_function (decl);
15023             pop_function_context ();
15024           }
15025       }
15026
15027   /* If there were any declarations or structure tags in that level,
15028      or if this level is a function body,
15029      create a BLOCK to record them for the life of this function.  */
15030
15031   block = 0;
15032   block_previously_created = (current_binding_level->this_block != 0);
15033   if (block_previously_created)
15034     block = current_binding_level->this_block;
15035   else if (keep || functionbody)
15036     block = make_node (BLOCK);
15037   if (block != 0)
15038     {
15039       BLOCK_VARS (block) = decls;
15040       BLOCK_SUBBLOCKS (block) = subblocks;
15041       remember_end_note (block);
15042     }
15043
15044   /* In each subblock, record that this is its superior.  */
15045
15046   for (link = subblocks; link; link = TREE_CHAIN (link))
15047     BLOCK_SUPERCONTEXT (link) = block;
15048
15049   /* Clear out the meanings of the local variables of this level.  */
15050
15051   for (link = decls; link; link = TREE_CHAIN (link))
15052     {
15053       if (DECL_NAME (link) != 0)
15054         {
15055           /* If the ident. was used or addressed via a local extern decl,
15056              don't forget that fact.  */
15057           if (DECL_EXTERNAL (link))
15058             {
15059               if (TREE_USED (link))
15060                 TREE_USED (DECL_NAME (link)) = 1;
15061               if (TREE_ADDRESSABLE (link))
15062                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
15063             }
15064           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
15065         }
15066     }
15067
15068   /* If the level being exited is the top level of a function,
15069      check over all the labels, and clear out the current
15070      (function local) meanings of their names.  */
15071
15072   if (functionbody)
15073     {
15074       /* If this is the top level block of a function,
15075          the vars are the function's parameters.
15076          Don't leave them in the BLOCK because they are
15077          found in the FUNCTION_DECL instead.  */
15078
15079       BLOCK_VARS (block) = 0;
15080     }
15081
15082   /* Pop the current level, and free the structure for reuse.  */
15083
15084   {
15085     register struct binding_level *level = current_binding_level;
15086     current_binding_level = current_binding_level->level_chain;
15087
15088     level->level_chain = free_binding_level;
15089     free_binding_level = level;
15090   }
15091
15092   /* Dispose of the block that we just made inside some higher level.  */
15093   if (functionbody
15094       && current_function_decl != error_mark_node)
15095     DECL_INITIAL (current_function_decl) = block;
15096   else if (block)
15097     {
15098       if (!block_previously_created)
15099         current_binding_level->blocks
15100           = chainon (current_binding_level->blocks, block);
15101     }
15102   /* If we did not make a block for the level just exited,
15103      any blocks made for inner levels
15104      (since they cannot be recorded as subblocks in that level)
15105      must be carried forward so they will later become subblocks
15106      of something else.  */
15107   else if (subblocks)
15108     current_binding_level->blocks
15109       = chainon (current_binding_level->blocks, subblocks);
15110
15111   if (block)
15112     TREE_USED (block) = 1;
15113   return block;
15114 }
15115
15116 void
15117 print_lang_decl (file, node, indent)
15118      FILE *file UNUSED;
15119      tree node UNUSED;
15120      int indent UNUSED;
15121 {
15122 }
15123
15124 void
15125 print_lang_identifier (file, node, indent)
15126      FILE *file;
15127      tree node;
15128      int indent;
15129 {
15130   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
15131   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
15132 }
15133
15134 void
15135 print_lang_statistics ()
15136 {
15137 }
15138
15139 void
15140 print_lang_type (file, node, indent)
15141      FILE *file UNUSED;
15142      tree node UNUSED;
15143      int indent UNUSED;
15144 {
15145 }
15146
15147 /* Record a decl-node X as belonging to the current lexical scope.
15148    Check for errors (such as an incompatible declaration for the same
15149    name already seen in the same scope).
15150
15151    Returns either X or an old decl for the same name.
15152    If an old decl is returned, it may have been smashed
15153    to agree with what X says.  */
15154
15155 tree
15156 pushdecl (x)
15157      tree x;
15158 {
15159   register tree t;
15160   register tree name = DECL_NAME (x);
15161   register struct binding_level *b = current_binding_level;
15162
15163   if ((TREE_CODE (x) == FUNCTION_DECL)
15164       && (DECL_INITIAL (x) == 0)
15165       && DECL_EXTERNAL (x))
15166     DECL_CONTEXT (x) = NULL_TREE;
15167   else
15168     DECL_CONTEXT (x) = current_function_decl;
15169
15170   if (name)
15171     {
15172       if (IDENTIFIER_INVENTED (name))
15173         {
15174 #if BUILT_FOR_270
15175           DECL_ARTIFICIAL (x) = 1;
15176 #endif
15177           DECL_IN_SYSTEM_HEADER (x) = 1;
15178         }
15179
15180       t = lookup_name_current_level (name);
15181
15182       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
15183
15184       /* Don't push non-parms onto list for parms until we understand
15185          why we're doing this and whether it works.  */
15186
15187       assert ((b == global_binding_level)
15188               || !ffecom_transform_only_dummies_
15189               || TREE_CODE (x) == PARM_DECL);
15190
15191       if ((t != NULL_TREE) && duplicate_decls (x, t))
15192         return t;
15193
15194       /* If we are processing a typedef statement, generate a whole new
15195          ..._TYPE node (which will be just an variant of the existing
15196          ..._TYPE node with identical properties) and then install the
15197          TYPE_DECL node generated to represent the typedef name as the
15198          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15199
15200          The whole point here is to end up with a situation where each and every
15201          ..._TYPE node the compiler creates will be uniquely associated with
15202          AT MOST one node representing a typedef name. This way, even though
15203          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15204          (i.e. "typedef name") nodes very early on, later parts of the
15205          compiler can always do the reverse translation and get back the
15206          corresponding typedef name.  For example, given:
15207
15208          typedef struct S MY_TYPE; MY_TYPE object;
15209
15210          Later parts of the compiler might only know that `object' was of type
15211          `struct S' if it were not for code just below.  With this code
15212          however, later parts of the compiler see something like:
15213
15214          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15215
15216          And they can then deduce (from the node for type struct S') that the
15217          original object declaration was:
15218
15219          MY_TYPE object;
15220
15221          Being able to do this is important for proper support of protoize, and
15222          also for generating precise symbolic debugging information which
15223          takes full account of the programmer's (typedef) vocabulary.
15224
15225          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15226          TYPE_DECL node that we are now processing really represents a
15227          standard built-in type.
15228
15229          Since all standard types are effectively declared at line zero in the
15230          source file, we can easily check to see if we are working on a
15231          standard type by checking the current value of lineno.  */
15232
15233       if (TREE_CODE (x) == TYPE_DECL)
15234         {
15235           if (DECL_SOURCE_LINE (x) == 0)
15236             {
15237               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15238                 TYPE_NAME (TREE_TYPE (x)) = x;
15239             }
15240           else if (TREE_TYPE (x) != error_mark_node)
15241             {
15242               tree tt = TREE_TYPE (x);
15243
15244               tt = build_type_copy (tt);
15245               TYPE_NAME (tt) = x;
15246               TREE_TYPE (x) = tt;
15247             }
15248         }
15249
15250       /* This name is new in its binding level. Install the new declaration
15251          and return it.  */
15252       if (b == global_binding_level)
15253         IDENTIFIER_GLOBAL_VALUE (name) = x;
15254       else
15255         IDENTIFIER_LOCAL_VALUE (name) = x;
15256     }
15257
15258   /* Put decls on list in reverse order. We will reverse them later if
15259      necessary.  */
15260   TREE_CHAIN (x) = b->names;
15261   b->names = x;
15262
15263   return x;
15264 }
15265
15266 /* Nonzero if the current level needs to have a BLOCK made.  */
15267
15268 static int
15269 kept_level_p ()
15270 {
15271   tree decl;
15272
15273   for (decl = current_binding_level->names;
15274        decl;
15275        decl = TREE_CHAIN (decl))
15276     {
15277       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15278           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15279         /* Currently, there aren't supposed to be non-artificial names
15280            at other than the top block for a function -- they're
15281            believed to always be temps.  But it's wise to check anyway.  */
15282         return 1;
15283     }
15284   return 0;
15285 }
15286
15287 /* Enter a new binding level.
15288    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15289    not for that of tags.  */
15290
15291 void
15292 pushlevel (tag_transparent)
15293      int tag_transparent;
15294 {
15295   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15296
15297   assert (! tag_transparent);
15298
15299   if (current_binding_level == global_binding_level)
15300     {
15301       named_labels = 0;
15302     }
15303
15304   /* Reuse or create a struct for this binding level.  */
15305
15306   if (free_binding_level)
15307     {
15308       newlevel = free_binding_level;
15309       free_binding_level = free_binding_level->level_chain;
15310     }
15311   else
15312     {
15313       newlevel = make_binding_level ();
15314     }
15315
15316   /* Add this level to the front of the chain (stack) of levels that
15317      are active.  */
15318
15319   *newlevel = clear_binding_level;
15320   newlevel->level_chain = current_binding_level;
15321   current_binding_level = newlevel;
15322 }
15323
15324 /* Set the BLOCK node for the innermost scope
15325    (the one we are currently in).  */
15326
15327 void
15328 set_block (block)
15329      register tree block;
15330 {
15331   current_binding_level->this_block = block;
15332 }
15333
15334 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
15335
15336 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15337
15338 void
15339 set_yydebug (value)
15340      int value;
15341 {
15342   if (value)
15343     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15344 }
15345
15346 tree
15347 signed_or_unsigned_type (unsignedp, type)
15348      int unsignedp;
15349      tree type;
15350 {
15351   tree type2;
15352
15353   if (! INTEGRAL_TYPE_P (type))
15354     return type;
15355   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15356     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15357   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15358     return unsignedp ? unsigned_type_node : integer_type_node;
15359   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15360     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15361   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15362     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15363   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15364     return (unsignedp ? long_long_unsigned_type_node
15365             : long_long_integer_type_node);
15366
15367   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15368   if (type2 == NULL_TREE)
15369     return type;
15370
15371   return type2;
15372 }
15373
15374 tree
15375 signed_type (type)
15376      tree type;
15377 {
15378   tree type1 = TYPE_MAIN_VARIANT (type);
15379   ffeinfoKindtype kt;
15380   tree type2;
15381
15382   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15383     return signed_char_type_node;
15384   if (type1 == unsigned_type_node)
15385     return integer_type_node;
15386   if (type1 == short_unsigned_type_node)
15387     return short_integer_type_node;
15388   if (type1 == long_unsigned_type_node)
15389     return long_integer_type_node;
15390   if (type1 == long_long_unsigned_type_node)
15391     return long_long_integer_type_node;
15392 #if 0   /* gcc/c-* files only */
15393   if (type1 == unsigned_intDI_type_node)
15394     return intDI_type_node;
15395   if (type1 == unsigned_intSI_type_node)
15396     return intSI_type_node;
15397   if (type1 == unsigned_intHI_type_node)
15398     return intHI_type_node;
15399   if (type1 == unsigned_intQI_type_node)
15400     return intQI_type_node;
15401 #endif
15402
15403   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15404   if (type2 != NULL_TREE)
15405     return type2;
15406
15407   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15408     {
15409       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15410
15411       if (type1 == type2)
15412         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15413     }
15414
15415   return type;
15416 }
15417
15418 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15419    or validate its data type for an `if' or `while' statement or ?..: exp.
15420
15421    This preparation consists of taking the ordinary
15422    representation of an expression expr and producing a valid tree
15423    boolean expression describing whether expr is nonzero.  We could
15424    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15425    but we optimize comparisons, &&, ||, and !.
15426
15427    The resulting type should always be `integer_type_node'.  */
15428
15429 tree
15430 truthvalue_conversion (expr)
15431      tree expr;
15432 {
15433   if (TREE_CODE (expr) == ERROR_MARK)
15434     return expr;
15435
15436 #if 0 /* This appears to be wrong for C++.  */
15437   /* These really should return error_mark_node after 2.4 is stable.
15438      But not all callers handle ERROR_MARK properly.  */
15439   switch (TREE_CODE (TREE_TYPE (expr)))
15440     {
15441     case RECORD_TYPE:
15442       error ("struct type value used where scalar is required");
15443       return integer_zero_node;
15444
15445     case UNION_TYPE:
15446       error ("union type value used where scalar is required");
15447       return integer_zero_node;
15448
15449     case ARRAY_TYPE:
15450       error ("array type value used where scalar is required");
15451       return integer_zero_node;
15452
15453     default:
15454       break;
15455     }
15456 #endif /* 0 */
15457
15458   switch (TREE_CODE (expr))
15459     {
15460       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15461          or comparison expressions as truth values at this level.  */
15462 #if 0
15463     case COMPONENT_REF:
15464       /* A one-bit unsigned bit-field is already acceptable.  */
15465       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15466           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15467         return expr;
15468       break;
15469 #endif
15470
15471     case EQ_EXPR:
15472       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15473          or comparison expressions as truth values at this level.  */
15474 #if 0
15475       if (integer_zerop (TREE_OPERAND (expr, 1)))
15476         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15477 #endif
15478     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15479     case TRUTH_ANDIF_EXPR:
15480     case TRUTH_ORIF_EXPR:
15481     case TRUTH_AND_EXPR:
15482     case TRUTH_OR_EXPR:
15483     case TRUTH_XOR_EXPR:
15484       TREE_TYPE (expr) = integer_type_node;
15485       return expr;
15486
15487     case ERROR_MARK:
15488       return expr;
15489
15490     case INTEGER_CST:
15491       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15492
15493     case REAL_CST:
15494       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15495
15496     case ADDR_EXPR:
15497       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15498         return build (COMPOUND_EXPR, integer_type_node,
15499                       TREE_OPERAND (expr, 0), integer_one_node);
15500       else
15501         return integer_one_node;
15502
15503     case COMPLEX_EXPR:
15504       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15505                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15506                        integer_type_node,
15507                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15508                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15509
15510     case NEGATE_EXPR:
15511     case ABS_EXPR:
15512     case FLOAT_EXPR:
15513     case FFS_EXPR:
15514       /* These don't change whether an object is non-zero or zero.  */
15515       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15516
15517     case LROTATE_EXPR:
15518     case RROTATE_EXPR:
15519       /* These don't change whether an object is zero or non-zero, but
15520          we can't ignore them if their second arg has side-effects.  */
15521       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15522         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15523                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15524       else
15525         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15526
15527     case COND_EXPR:
15528       /* Distribute the conversion into the arms of a COND_EXPR.  */
15529       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15530                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15531                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15532
15533     case CONVERT_EXPR:
15534       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15535          since that affects how `default_conversion' will behave.  */
15536       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15537           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15538         break;
15539       /* fall through... */
15540     case NOP_EXPR:
15541       /* If this is widening the argument, we can ignore it.  */
15542       if (TYPE_PRECISION (TREE_TYPE (expr))
15543           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15544         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15545       break;
15546
15547     case MINUS_EXPR:
15548       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15549          this case.  */
15550       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15551           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15552         break;
15553       /* fall through... */
15554     case BIT_XOR_EXPR:
15555       /* This and MINUS_EXPR can be changed into a comparison of the
15556          two objects.  */
15557       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15558           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15559         return ffecom_2 (NE_EXPR, integer_type_node,
15560                          TREE_OPERAND (expr, 0),
15561                          TREE_OPERAND (expr, 1));
15562       return ffecom_2 (NE_EXPR, integer_type_node,
15563                        TREE_OPERAND (expr, 0),
15564                        fold (build1 (NOP_EXPR,
15565                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15566                                      TREE_OPERAND (expr, 1))));
15567
15568     case BIT_AND_EXPR:
15569       if (integer_onep (TREE_OPERAND (expr, 1)))
15570         return expr;
15571       break;
15572
15573     case MODIFY_EXPR:
15574 #if 0                           /* No such thing in Fortran. */
15575       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15576         warning ("suggest parentheses around assignment used as truth value");
15577 #endif
15578       break;
15579
15580     default:
15581       break;
15582     }
15583
15584   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15585     return (ffecom_2
15586             ((TREE_SIDE_EFFECTS (expr)
15587               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15588              integer_type_node,
15589              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15590                                               TREE_TYPE (TREE_TYPE (expr)),
15591                                               expr)),
15592              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15593                                               TREE_TYPE (TREE_TYPE (expr)),
15594                                               expr))));
15595
15596   return ffecom_2 (NE_EXPR, integer_type_node,
15597                    expr,
15598                    convert (TREE_TYPE (expr), integer_zero_node));
15599 }
15600
15601 tree
15602 type_for_mode (mode, unsignedp)
15603      enum machine_mode mode;
15604      int unsignedp;
15605 {
15606   int i;
15607   int j;
15608   tree t;
15609
15610   if (mode == TYPE_MODE (integer_type_node))
15611     return unsignedp ? unsigned_type_node : integer_type_node;
15612
15613   if (mode == TYPE_MODE (signed_char_type_node))
15614     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15615
15616   if (mode == TYPE_MODE (short_integer_type_node))
15617     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15618
15619   if (mode == TYPE_MODE (long_integer_type_node))
15620     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15621
15622   if (mode == TYPE_MODE (long_long_integer_type_node))
15623     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15624
15625   if (mode == TYPE_MODE (float_type_node))
15626     return float_type_node;
15627
15628   if (mode == TYPE_MODE (double_type_node))
15629     return double_type_node;
15630
15631   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15632     return build_pointer_type (char_type_node);
15633
15634   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15635     return build_pointer_type (integer_type_node);
15636
15637   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15638     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15639       {
15640         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15641             && (mode == TYPE_MODE (t)))
15642           {
15643             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15644               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15645             else
15646               return t;
15647           }
15648       }
15649
15650   return 0;
15651 }
15652
15653 tree
15654 type_for_size (bits, unsignedp)
15655      unsigned bits;
15656      int unsignedp;
15657 {
15658   ffeinfoKindtype kt;
15659   tree type_node;
15660
15661   if (bits == TYPE_PRECISION (integer_type_node))
15662     return unsignedp ? unsigned_type_node : integer_type_node;
15663
15664   if (bits == TYPE_PRECISION (signed_char_type_node))
15665     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15666
15667   if (bits == TYPE_PRECISION (short_integer_type_node))
15668     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15669
15670   if (bits == TYPE_PRECISION (long_integer_type_node))
15671     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15672
15673   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15674     return (unsignedp ? long_long_unsigned_type_node
15675             : long_long_integer_type_node);
15676
15677   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15678     {
15679       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15680
15681       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15682         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15683           : type_node;
15684     }
15685
15686   return 0;
15687 }
15688
15689 tree
15690 unsigned_type (type)
15691      tree type;
15692 {
15693   tree type1 = TYPE_MAIN_VARIANT (type);
15694   ffeinfoKindtype kt;
15695   tree type2;
15696
15697   if (type1 == signed_char_type_node || type1 == char_type_node)
15698     return unsigned_char_type_node;
15699   if (type1 == integer_type_node)
15700     return unsigned_type_node;
15701   if (type1 == short_integer_type_node)
15702     return short_unsigned_type_node;
15703   if (type1 == long_integer_type_node)
15704     return long_unsigned_type_node;
15705   if (type1 == long_long_integer_type_node)
15706     return long_long_unsigned_type_node;
15707 #if 0   /* gcc/c-* files only */
15708   if (type1 == intDI_type_node)
15709     return unsigned_intDI_type_node;
15710   if (type1 == intSI_type_node)
15711     return unsigned_intSI_type_node;
15712   if (type1 == intHI_type_node)
15713     return unsigned_intHI_type_node;
15714   if (type1 == intQI_type_node)
15715     return unsigned_intQI_type_node;
15716 #endif
15717
15718   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15719   if (type2 != NULL_TREE)
15720     return type2;
15721
15722   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15723     {
15724       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15725
15726       if (type1 == type2)
15727         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15728     }
15729
15730   return type;
15731 }
15732
15733 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15734 \f
15735 #if FFECOM_GCC_INCLUDE
15736
15737 /* From gcc/cccp.c, the code to handle -I.  */
15738
15739 /* Skip leading "./" from a directory name.
15740    This may yield the empty string, which represents the current directory.  */
15741
15742 static const char *
15743 skip_redundant_dir_prefix (const char *dir)
15744 {
15745   while (dir[0] == '.' && dir[1] == '/')
15746     for (dir += 2; *dir == '/'; dir++)
15747       continue;
15748   if (dir[0] == '.' && !dir[1])
15749     dir++;
15750   return dir;
15751 }
15752
15753 /* The file_name_map structure holds a mapping of file names for a
15754    particular directory.  This mapping is read from the file named
15755    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15756    map filenames on a file system with severe filename restrictions,
15757    such as DOS.  The format of the file name map file is just a series
15758    of lines with two tokens on each line.  The first token is the name
15759    to map, and the second token is the actual name to use.  */
15760
15761 struct file_name_map
15762 {
15763   struct file_name_map *map_next;
15764   char *map_from;
15765   char *map_to;
15766 };
15767
15768 #define FILE_NAME_MAP_FILE "header.gcc"
15769
15770 /* Current maximum length of directory names in the search path
15771    for include files.  (Altered as we get more of them.)  */
15772
15773 static int max_include_len = 0;
15774
15775 struct file_name_list
15776   {
15777     struct file_name_list *next;
15778     char *fname;
15779     /* Mapping of file names for this directory.  */
15780     struct file_name_map *name_map;
15781     /* Non-zero if name_map is valid.  */
15782     int got_name_map;
15783   };
15784
15785 static struct file_name_list *include = NULL;   /* First dir to search */
15786 static struct file_name_list *last_include = NULL;      /* Last in chain */
15787
15788 /* I/O buffer structure.
15789    The `fname' field is nonzero for source files and #include files
15790    and for the dummy text used for -D and -U.
15791    It is zero for rescanning results of macro expansion
15792    and for expanding macro arguments.  */
15793 #define INPUT_STACK_MAX 400
15794 static struct file_buf {
15795   char *fname;
15796   /* Filename specified with #line command.  */
15797   char *nominal_fname;
15798   /* Record where in the search path this file was found.
15799      For #include_next.  */
15800   struct file_name_list *dir;
15801   ffewhereLine line;
15802   ffewhereColumn column;
15803 } instack[INPUT_STACK_MAX];
15804
15805 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15806 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15807
15808 /* Current nesting level of input sources.
15809    `instack[indepth]' is the level currently being read.  */
15810 static int indepth = -1;
15811
15812 typedef struct file_buf FILE_BUF;
15813
15814 typedef unsigned char U_CHAR;
15815
15816 /* table to tell if char can be part of a C identifier. */
15817 U_CHAR is_idchar[256];
15818 /* table to tell if char can be first char of a c identifier. */
15819 U_CHAR is_idstart[256];
15820 /* table to tell if c is horizontal space.  */
15821 U_CHAR is_hor_space[256];
15822 /* table to tell if c is horizontal or vertical space.  */
15823 static U_CHAR is_space[256];
15824
15825 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15826 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15827
15828 /* Nonzero means -I- has been seen,
15829    so don't look for #include "foo" the source-file directory.  */
15830 static int ignore_srcdir;
15831
15832 #ifndef INCLUDE_LEN_FUDGE
15833 #define INCLUDE_LEN_FUDGE 0
15834 #endif
15835
15836 static void append_include_chain (struct file_name_list *first,
15837                                   struct file_name_list *last);
15838 static FILE *open_include_file (char *filename,
15839                                 struct file_name_list *searchptr);
15840 static void print_containing_files (ffebadSeverity sev);
15841 static const char *skip_redundant_dir_prefix (const char *);
15842 static char *read_filename_string (int ch, FILE *f);
15843 static struct file_name_map *read_name_map (const char *dirname);
15844
15845 /* Append a chain of `struct file_name_list's
15846    to the end of the main include chain.
15847    FIRST is the beginning of the chain to append, and LAST is the end.  */
15848
15849 static void
15850 append_include_chain (first, last)
15851      struct file_name_list *first, *last;
15852 {
15853   struct file_name_list *dir;
15854
15855   if (!first || !last)
15856     return;
15857
15858   if (include == 0)
15859     include = first;
15860   else
15861     last_include->next = first;
15862
15863   for (dir = first; ; dir = dir->next) {
15864     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15865     if (len > max_include_len)
15866       max_include_len = len;
15867     if (dir == last)
15868       break;
15869   }
15870
15871   last->next = NULL;
15872   last_include = last;
15873 }
15874
15875 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15876    being tried from the include file search path.  This function maps
15877    filenames on file systems based on information read by
15878    read_name_map.  */
15879
15880 static FILE *
15881 open_include_file (filename, searchptr)
15882      char *filename;
15883      struct file_name_list *searchptr;
15884 {
15885   register struct file_name_map *map;
15886   register char *from;
15887   char *p, *dir;
15888
15889   if (searchptr && ! searchptr->got_name_map)
15890     {
15891       searchptr->name_map = read_name_map (searchptr->fname
15892                                            ? searchptr->fname : ".");
15893       searchptr->got_name_map = 1;
15894     }
15895
15896   /* First check the mapping for the directory we are using.  */
15897   if (searchptr && searchptr->name_map)
15898     {
15899       from = filename;
15900       if (searchptr->fname)
15901         from += strlen (searchptr->fname) + 1;
15902       for (map = searchptr->name_map; map; map = map->map_next)
15903         {
15904           if (! strcmp (map->map_from, from))
15905             {
15906               /* Found a match.  */
15907               return fopen (map->map_to, "r");
15908             }
15909         }
15910     }
15911
15912   /* Try to find a mapping file for the particular directory we are
15913      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15914      in /usr/include/header.gcc and look up types.h in
15915      /usr/include/sys/header.gcc.  */
15916   p = rindex (filename, '/');
15917 #ifdef DIR_SEPARATOR
15918   if (! p) p = rindex (filename, DIR_SEPARATOR);
15919   else {
15920     char *tmp = rindex (filename, DIR_SEPARATOR);
15921     if (tmp != NULL && tmp > p) p = tmp;
15922   }
15923 #endif
15924   if (! p)
15925     p = filename;
15926   if (searchptr
15927       && searchptr->fname
15928       && strlen (searchptr->fname) == (size_t) (p - filename)
15929       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15930     {
15931       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15932       return fopen (filename, "r");
15933     }
15934
15935   if (p == filename)
15936     {
15937       from = filename;
15938       map = read_name_map (".");
15939     }
15940   else
15941     {
15942       dir = (char *) xmalloc (p - filename + 1);
15943       memcpy (dir, filename, p - filename);
15944       dir[p - filename] = '\0';
15945       from = p + 1;
15946       map = read_name_map (dir);
15947       free (dir);
15948     }
15949   for (; map; map = map->map_next)
15950     if (! strcmp (map->map_from, from))
15951       return fopen (map->map_to, "r");
15952
15953   return fopen (filename, "r");
15954 }
15955
15956 /* Print the file names and line numbers of the #include
15957    commands which led to the current file.  */
15958
15959 static void
15960 print_containing_files (ffebadSeverity sev)
15961 {
15962   FILE_BUF *ip = NULL;
15963   int i;
15964   int first = 1;
15965   const char *str1;
15966   const char *str2;
15967
15968   /* If stack of files hasn't changed since we last printed
15969      this info, don't repeat it.  */
15970   if (last_error_tick == input_file_stack_tick)
15971     return;
15972
15973   for (i = indepth; i >= 0; i--)
15974     if (instack[i].fname != NULL) {
15975       ip = &instack[i];
15976       break;
15977     }
15978
15979   /* Give up if we don't find a source file.  */
15980   if (ip == NULL)
15981     return;
15982
15983   /* Find the other, outer source files.  */
15984   for (i--; i >= 0; i--)
15985     if (instack[i].fname != NULL)
15986       {
15987         ip = &instack[i];
15988         if (first)
15989           {
15990             first = 0;
15991             str1 = "In file included";
15992           }
15993         else
15994           {
15995             str1 = "...          ...";
15996           }
15997
15998         if (i == 1)
15999           str2 = ":";
16000         else
16001           str2 = "";
16002
16003         ffebad_start_msg ("%A from %B at %0%C", sev);
16004         ffebad_here (0, ip->line, ip->column);
16005         ffebad_string (str1);
16006         ffebad_string (ip->nominal_fname);
16007         ffebad_string (str2);
16008         ffebad_finish ();
16009       }
16010
16011   /* Record we have printed the status as of this time.  */
16012   last_error_tick = input_file_stack_tick;
16013 }
16014
16015 /* Read a space delimited string of unlimited length from a stdio
16016    file.  */
16017
16018 static char *
16019 read_filename_string (ch, f)
16020      int ch;
16021      FILE *f;
16022 {
16023   char *alloc, *set;
16024   int len;
16025
16026   len = 20;
16027   set = alloc = xmalloc (len + 1);
16028   if (! is_space[ch])
16029     {
16030       *set++ = ch;
16031       while ((ch = getc (f)) != EOF && ! is_space[ch])
16032         {
16033           if (set - alloc == len)
16034             {
16035               len *= 2;
16036               alloc = xrealloc (alloc, len + 1);
16037               set = alloc + len / 2;
16038             }
16039           *set++ = ch;
16040         }
16041     }
16042   *set = '\0';
16043   ungetc (ch, f);
16044   return alloc;
16045 }
16046
16047 /* Read the file name map file for DIRNAME.  */
16048
16049 static struct file_name_map *
16050 read_name_map (dirname)
16051      const char *dirname;
16052 {
16053   /* This structure holds a linked list of file name maps, one per
16054      directory.  */
16055   struct file_name_map_list
16056     {
16057       struct file_name_map_list *map_list_next;
16058       char *map_list_name;
16059       struct file_name_map *map_list_map;
16060     };
16061   static struct file_name_map_list *map_list;
16062   register struct file_name_map_list *map_list_ptr;
16063   char *name;
16064   FILE *f;
16065   size_t dirlen;
16066   int separator_needed;
16067
16068   dirname = skip_redundant_dir_prefix (dirname);
16069
16070   for (map_list_ptr = map_list; map_list_ptr;
16071        map_list_ptr = map_list_ptr->map_list_next)
16072     if (! strcmp (map_list_ptr->map_list_name, dirname))
16073       return map_list_ptr->map_list_map;
16074
16075   map_list_ptr = ((struct file_name_map_list *)
16076                   xmalloc (sizeof (struct file_name_map_list)));
16077   map_list_ptr->map_list_name = xstrdup (dirname);
16078   map_list_ptr->map_list_map = NULL;
16079
16080   dirlen = strlen (dirname);
16081   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
16082   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
16083   strcpy (name, dirname);
16084   name[dirlen] = '/';
16085   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
16086   f = fopen (name, "r");
16087   free (name);
16088   if (!f)
16089     map_list_ptr->map_list_map = NULL;
16090   else
16091     {
16092       int ch;
16093
16094       while ((ch = getc (f)) != EOF)
16095         {
16096           char *from, *to;
16097           struct file_name_map *ptr;
16098
16099           if (is_space[ch])
16100             continue;
16101           from = read_filename_string (ch, f);
16102           while ((ch = getc (f)) != EOF && is_hor_space[ch])
16103             ;
16104           to = read_filename_string (ch, f);
16105
16106           ptr = ((struct file_name_map *)
16107                  xmalloc (sizeof (struct file_name_map)));
16108           ptr->map_from = from;
16109
16110           /* Make the real filename absolute.  */
16111           if (*to == '/')
16112             ptr->map_to = to;
16113           else
16114             {
16115               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
16116               strcpy (ptr->map_to, dirname);
16117               ptr->map_to[dirlen] = '/';
16118               strcpy (ptr->map_to + dirlen + separator_needed, to);
16119               free (to);
16120             }
16121
16122           ptr->map_next = map_list_ptr->map_list_map;
16123           map_list_ptr->map_list_map = ptr;
16124
16125           while ((ch = getc (f)) != '\n')
16126             if (ch == EOF)
16127               break;
16128         }
16129       fclose (f);
16130     }
16131
16132   map_list_ptr->map_list_next = map_list;
16133   map_list = map_list_ptr;
16134
16135   return map_list_ptr->map_list_map;
16136 }
16137
16138 static void
16139 ffecom_file_ (char *name)
16140 {
16141   FILE_BUF *fp;
16142
16143   /* Do partial setup of input buffer for the sake of generating
16144      early #line directives (when -g is in effect).  */
16145
16146   fp = &instack[++indepth];
16147   memset ((char *) fp, 0, sizeof (FILE_BUF));
16148   if (name == NULL)
16149     name = "";
16150   fp->nominal_fname = fp->fname = name;
16151 }
16152
16153 /* Initialize syntactic classifications of characters.  */
16154
16155 static void
16156 ffecom_initialize_char_syntax_ ()
16157 {
16158   register int i;
16159
16160   /*
16161    * Set up is_idchar and is_idstart tables.  These should be
16162    * faster than saying (is_alpha (c) || c == '_'), etc.
16163    * Set up these things before calling any routines tthat
16164    * refer to them.
16165    */
16166   for (i = 'a'; i <= 'z'; i++) {
16167     is_idchar[i - 'a' + 'A'] = 1;
16168     is_idchar[i] = 1;
16169     is_idstart[i - 'a' + 'A'] = 1;
16170     is_idstart[i] = 1;
16171   }
16172   for (i = '0'; i <= '9'; i++)
16173     is_idchar[i] = 1;
16174   is_idchar['_'] = 1;
16175   is_idstart['_'] = 1;
16176
16177   /* horizontal space table */
16178   is_hor_space[' '] = 1;
16179   is_hor_space['\t'] = 1;
16180   is_hor_space['\v'] = 1;
16181   is_hor_space['\f'] = 1;
16182   is_hor_space['\r'] = 1;
16183
16184   is_space[' '] = 1;
16185   is_space['\t'] = 1;
16186   is_space['\v'] = 1;
16187   is_space['\f'] = 1;
16188   is_space['\n'] = 1;
16189   is_space['\r'] = 1;
16190 }
16191
16192 static void
16193 ffecom_close_include_ (FILE *f)
16194 {
16195   fclose (f);
16196
16197   indepth--;
16198   input_file_stack_tick++;
16199
16200   ffewhere_line_kill (instack[indepth].line);
16201   ffewhere_column_kill (instack[indepth].column);
16202 }
16203
16204 static int
16205 ffecom_decode_include_option_ (char *spec)
16206 {
16207   struct file_name_list *dirtmp;
16208
16209   if (! ignore_srcdir && !strcmp (spec, "-"))
16210     ignore_srcdir = 1;
16211   else
16212     {
16213       dirtmp = (struct file_name_list *)
16214         xmalloc (sizeof (struct file_name_list));
16215       dirtmp->next = 0;         /* New one goes on the end */
16216       if (spec[0] != 0)
16217         dirtmp->fname = spec;
16218       else
16219         fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16220       dirtmp->got_name_map = 0;
16221       append_include_chain (dirtmp, dirtmp);
16222     }
16223   return 1;
16224 }
16225
16226 /* Open INCLUDEd file.  */
16227
16228 static FILE *
16229 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16230 {
16231   char *fbeg = name;
16232   size_t flen = strlen (fbeg);
16233   struct file_name_list *search_start = include; /* Chain of dirs to search */
16234   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16235   struct file_name_list *searchptr = 0;
16236   char *fname;          /* Dynamically allocated fname buffer */
16237   FILE *f;
16238   FILE_BUF *fp;
16239
16240   if (flen == 0)
16241     return NULL;
16242
16243   dsp[0].fname = NULL;
16244
16245   /* If -I- was specified, don't search current dir, only spec'd ones. */
16246   if (!ignore_srcdir)
16247     {
16248       for (fp = &instack[indepth]; fp >= instack; fp--)
16249         {
16250           int n;
16251           char *ep;
16252           char *nam;
16253
16254           if ((nam = fp->nominal_fname) != NULL)
16255             {
16256               /* Found a named file.  Figure out dir of the file,
16257                  and put it in front of the search list.  */
16258               dsp[0].next = search_start;
16259               search_start = dsp;
16260 #ifndef VMS
16261               ep = rindex (nam, '/');
16262 #ifdef DIR_SEPARATOR
16263             if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR);
16264             else {
16265               char *tmp = rindex (nam, DIR_SEPARATOR);
16266               if (tmp != NULL && tmp > ep) ep = tmp;
16267             }
16268 #endif
16269 #else                           /* VMS */
16270               ep = rindex (nam, ']');
16271               if (ep == NULL) ep = rindex (nam, '>');
16272               if (ep == NULL) ep = rindex (nam, ':');
16273               if (ep != NULL) ep++;
16274 #endif                          /* VMS */
16275               if (ep != NULL)
16276                 {
16277                   n = ep - nam;
16278                   dsp[0].fname = (char *) xmalloc (n + 1);
16279                   strncpy (dsp[0].fname, nam, n);
16280                   dsp[0].fname[n] = '\0';
16281                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16282                     max_include_len = n + INCLUDE_LEN_FUDGE;
16283                 }
16284               else
16285                 dsp[0].fname = NULL; /* Current directory */
16286               dsp[0].got_name_map = 0;
16287               break;
16288             }
16289         }
16290     }
16291
16292   /* Allocate this permanently, because it gets stored in the definitions
16293      of macros.  */
16294   fname = xmalloc (max_include_len + flen + 4);
16295   /* + 2 above for slash and terminating null.  */
16296   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16297      for g77 yet).  */
16298
16299   /* If specified file name is absolute, just open it.  */
16300
16301   if (*fbeg == '/'
16302 #ifdef DIR_SEPARATOR
16303       || *fbeg == DIR_SEPARATOR
16304 #endif
16305       )
16306     {
16307       strncpy (fname, (char *) fbeg, flen);
16308       fname[flen] = 0;
16309       f = open_include_file (fname, NULL_PTR);
16310     }
16311   else
16312     {
16313       f = NULL;
16314
16315       /* Search directory path, trying to open the file.
16316          Copy each filename tried into FNAME.  */
16317
16318       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16319         {
16320           if (searchptr->fname)
16321             {
16322               /* The empty string in a search path is ignored.
16323                  This makes it possible to turn off entirely
16324                  a standard piece of the list.  */
16325               if (searchptr->fname[0] == 0)
16326                 continue;
16327               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16328               if (fname[0] && fname[strlen (fname) - 1] != '/')
16329                 strcat (fname, "/");
16330               fname[strlen (fname) + flen] = 0;
16331             }
16332           else
16333             fname[0] = 0;
16334
16335           strncat (fname, fbeg, flen);
16336 #ifdef VMS
16337           /* Change this 1/2 Unix 1/2 VMS file specification into a
16338              full VMS file specification */
16339           if (searchptr->fname && (searchptr->fname[0] != 0))
16340             {
16341               /* Fix up the filename */
16342               hack_vms_include_specification (fname);
16343             }
16344           else
16345             {
16346               /* This is a normal VMS filespec, so use it unchanged.  */
16347               strncpy (fname, (char *) fbeg, flen);
16348               fname[flen] = 0;
16349 #if 0   /* Not for g77.  */
16350               /* if it's '#include filename', add the missing .h */
16351               if (index (fname, '.') == NULL)
16352                 strcat (fname, ".h");
16353 #endif
16354             }
16355 #endif /* VMS */
16356           f = open_include_file (fname, searchptr);
16357 #ifdef EACCES
16358           if (f == NULL && errno == EACCES)
16359             {
16360               print_containing_files (FFEBAD_severityWARNING);
16361               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16362                                 FFEBAD_severityWARNING);
16363               ffebad_string (fname);
16364               ffebad_here (0, l, c);
16365               ffebad_finish ();
16366             }
16367 #endif
16368           if (f != NULL)
16369             break;
16370         }
16371     }
16372
16373   if (f == NULL)
16374     {
16375       /* A file that was not found.  */
16376
16377       strncpy (fname, (char *) fbeg, flen);
16378       fname[flen] = 0;
16379       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16380       ffebad_start (FFEBAD_OPEN_INCLUDE);
16381       ffebad_here (0, l, c);
16382       ffebad_string (fname);
16383       ffebad_finish ();
16384     }
16385
16386   if (dsp[0].fname != NULL)
16387     free (dsp[0].fname);
16388
16389   if (f == NULL)
16390     return NULL;
16391
16392   if (indepth >= (INPUT_STACK_MAX - 1))
16393     {
16394       print_containing_files (FFEBAD_severityFATAL);
16395       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16396                         FFEBAD_severityFATAL);
16397       ffebad_string (fname);
16398       ffebad_here (0, l, c);
16399       ffebad_finish ();
16400       return NULL;
16401     }
16402
16403   instack[indepth].line = ffewhere_line_use (l);
16404   instack[indepth].column = ffewhere_column_use (c);
16405
16406   fp = &instack[indepth + 1];
16407   memset ((char *) fp, 0, sizeof (FILE_BUF));
16408   fp->nominal_fname = fp->fname = fname;
16409   fp->dir = searchptr;
16410
16411   indepth++;
16412   input_file_stack_tick++;
16413
16414   return f;
16415 }
16416 #endif  /* FFECOM_GCC_INCLUDE */
16417
16418 /**INDENT* (Do not reformat this comment even with -fca option.)
16419    Data-gathering files: Given the source file listed below, compiled with
16420    f2c I obtained the output file listed after that, and from the output
16421    file I derived the above code.
16422
16423 -------- (begin input file to f2c)
16424         implicit none
16425         character*10 A1,A2
16426         complex C1,C2
16427         integer I1,I2
16428         real R1,R2
16429         double precision D1,D2
16430 C
16431         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16432 c /
16433         call fooI(I1/I2)
16434         call fooR(R1/I1)
16435         call fooD(D1/I1)
16436         call fooC(C1/I1)
16437         call fooR(R1/R2)
16438         call fooD(R1/D1)
16439         call fooD(D1/D2)
16440         call fooD(D1/R1)
16441         call fooC(C1/C2)
16442         call fooC(C1/R1)
16443         call fooZ(C1/D1)
16444 c **
16445         call fooI(I1**I2)
16446         call fooR(R1**I1)
16447         call fooD(D1**I1)
16448         call fooC(C1**I1)
16449         call fooR(R1**R2)
16450         call fooD(R1**D1)
16451         call fooD(D1**D2)
16452         call fooD(D1**R1)
16453         call fooC(C1**C2)
16454         call fooC(C1**R1)
16455         call fooZ(C1**D1)
16456 c FFEINTRIN_impABS
16457         call fooR(ABS(R1))
16458 c FFEINTRIN_impACOS
16459         call fooR(ACOS(R1))
16460 c FFEINTRIN_impAIMAG
16461         call fooR(AIMAG(C1))
16462 c FFEINTRIN_impAINT
16463         call fooR(AINT(R1))
16464 c FFEINTRIN_impALOG
16465         call fooR(ALOG(R1))
16466 c FFEINTRIN_impALOG10
16467         call fooR(ALOG10(R1))
16468 c FFEINTRIN_impAMAX0
16469         call fooR(AMAX0(I1,I2))
16470 c FFEINTRIN_impAMAX1
16471         call fooR(AMAX1(R1,R2))
16472 c FFEINTRIN_impAMIN0
16473         call fooR(AMIN0(I1,I2))
16474 c FFEINTRIN_impAMIN1
16475         call fooR(AMIN1(R1,R2))
16476 c FFEINTRIN_impAMOD
16477         call fooR(AMOD(R1,R2))
16478 c FFEINTRIN_impANINT
16479         call fooR(ANINT(R1))
16480 c FFEINTRIN_impASIN
16481         call fooR(ASIN(R1))
16482 c FFEINTRIN_impATAN
16483         call fooR(ATAN(R1))
16484 c FFEINTRIN_impATAN2
16485         call fooR(ATAN2(R1,R2))
16486 c FFEINTRIN_impCABS
16487         call fooR(CABS(C1))
16488 c FFEINTRIN_impCCOS
16489         call fooC(CCOS(C1))
16490 c FFEINTRIN_impCEXP
16491         call fooC(CEXP(C1))
16492 c FFEINTRIN_impCHAR
16493         call fooA(CHAR(I1))
16494 c FFEINTRIN_impCLOG
16495         call fooC(CLOG(C1))
16496 c FFEINTRIN_impCONJG
16497         call fooC(CONJG(C1))
16498 c FFEINTRIN_impCOS
16499         call fooR(COS(R1))
16500 c FFEINTRIN_impCOSH
16501         call fooR(COSH(R1))
16502 c FFEINTRIN_impCSIN
16503         call fooC(CSIN(C1))
16504 c FFEINTRIN_impCSQRT
16505         call fooC(CSQRT(C1))
16506 c FFEINTRIN_impDABS
16507         call fooD(DABS(D1))
16508 c FFEINTRIN_impDACOS
16509         call fooD(DACOS(D1))
16510 c FFEINTRIN_impDASIN
16511         call fooD(DASIN(D1))
16512 c FFEINTRIN_impDATAN
16513         call fooD(DATAN(D1))
16514 c FFEINTRIN_impDATAN2
16515         call fooD(DATAN2(D1,D2))
16516 c FFEINTRIN_impDCOS
16517         call fooD(DCOS(D1))
16518 c FFEINTRIN_impDCOSH
16519         call fooD(DCOSH(D1))
16520 c FFEINTRIN_impDDIM
16521         call fooD(DDIM(D1,D2))
16522 c FFEINTRIN_impDEXP
16523         call fooD(DEXP(D1))
16524 c FFEINTRIN_impDIM
16525         call fooR(DIM(R1,R2))
16526 c FFEINTRIN_impDINT
16527         call fooD(DINT(D1))
16528 c FFEINTRIN_impDLOG
16529         call fooD(DLOG(D1))
16530 c FFEINTRIN_impDLOG10
16531         call fooD(DLOG10(D1))
16532 c FFEINTRIN_impDMAX1
16533         call fooD(DMAX1(D1,D2))
16534 c FFEINTRIN_impDMIN1
16535         call fooD(DMIN1(D1,D2))
16536 c FFEINTRIN_impDMOD
16537         call fooD(DMOD(D1,D2))
16538 c FFEINTRIN_impDNINT
16539         call fooD(DNINT(D1))
16540 c FFEINTRIN_impDPROD
16541         call fooD(DPROD(R1,R2))
16542 c FFEINTRIN_impDSIGN
16543         call fooD(DSIGN(D1,D2))
16544 c FFEINTRIN_impDSIN
16545         call fooD(DSIN(D1))
16546 c FFEINTRIN_impDSINH
16547         call fooD(DSINH(D1))
16548 c FFEINTRIN_impDSQRT
16549         call fooD(DSQRT(D1))
16550 c FFEINTRIN_impDTAN
16551         call fooD(DTAN(D1))
16552 c FFEINTRIN_impDTANH
16553         call fooD(DTANH(D1))
16554 c FFEINTRIN_impEXP
16555         call fooR(EXP(R1))
16556 c FFEINTRIN_impIABS
16557         call fooI(IABS(I1))
16558 c FFEINTRIN_impICHAR
16559         call fooI(ICHAR(A1))
16560 c FFEINTRIN_impIDIM
16561         call fooI(IDIM(I1,I2))
16562 c FFEINTRIN_impIDNINT
16563         call fooI(IDNINT(D1))
16564 c FFEINTRIN_impINDEX
16565         call fooI(INDEX(A1,A2))
16566 c FFEINTRIN_impISIGN
16567         call fooI(ISIGN(I1,I2))
16568 c FFEINTRIN_impLEN
16569         call fooI(LEN(A1))
16570 c FFEINTRIN_impLGE
16571         call fooL(LGE(A1,A2))
16572 c FFEINTRIN_impLGT
16573         call fooL(LGT(A1,A2))
16574 c FFEINTRIN_impLLE
16575         call fooL(LLE(A1,A2))
16576 c FFEINTRIN_impLLT
16577         call fooL(LLT(A1,A2))
16578 c FFEINTRIN_impMAX0
16579         call fooI(MAX0(I1,I2))
16580 c FFEINTRIN_impMAX1
16581         call fooI(MAX1(R1,R2))
16582 c FFEINTRIN_impMIN0
16583         call fooI(MIN0(I1,I2))
16584 c FFEINTRIN_impMIN1
16585         call fooI(MIN1(R1,R2))
16586 c FFEINTRIN_impMOD
16587         call fooI(MOD(I1,I2))
16588 c FFEINTRIN_impNINT
16589         call fooI(NINT(R1))
16590 c FFEINTRIN_impSIGN
16591         call fooR(SIGN(R1,R2))
16592 c FFEINTRIN_impSIN
16593         call fooR(SIN(R1))
16594 c FFEINTRIN_impSINH
16595         call fooR(SINH(R1))
16596 c FFEINTRIN_impSQRT
16597         call fooR(SQRT(R1))
16598 c FFEINTRIN_impTAN
16599         call fooR(TAN(R1))
16600 c FFEINTRIN_impTANH
16601         call fooR(TANH(R1))
16602 c FFEINTRIN_imp_CMPLX_C
16603         call fooC(cmplx(C1,C2))
16604 c FFEINTRIN_imp_CMPLX_D
16605         call fooZ(cmplx(D1,D2))
16606 c FFEINTRIN_imp_CMPLX_I
16607         call fooC(cmplx(I1,I2))
16608 c FFEINTRIN_imp_CMPLX_R
16609         call fooC(cmplx(R1,R2))
16610 c FFEINTRIN_imp_DBLE_C
16611         call fooD(dble(C1))
16612 c FFEINTRIN_imp_DBLE_D
16613         call fooD(dble(D1))
16614 c FFEINTRIN_imp_DBLE_I
16615         call fooD(dble(I1))
16616 c FFEINTRIN_imp_DBLE_R
16617         call fooD(dble(R1))
16618 c FFEINTRIN_imp_INT_C
16619         call fooI(int(C1))
16620 c FFEINTRIN_imp_INT_D
16621         call fooI(int(D1))
16622 c FFEINTRIN_imp_INT_I
16623         call fooI(int(I1))
16624 c FFEINTRIN_imp_INT_R
16625         call fooI(int(R1))
16626 c FFEINTRIN_imp_REAL_C
16627         call fooR(real(C1))
16628 c FFEINTRIN_imp_REAL_D
16629         call fooR(real(D1))
16630 c FFEINTRIN_imp_REAL_I
16631         call fooR(real(I1))
16632 c FFEINTRIN_imp_REAL_R
16633         call fooR(real(R1))
16634 c
16635 c FFEINTRIN_imp_INT_D:
16636 c
16637 c FFEINTRIN_specIDINT
16638         call fooI(IDINT(D1))
16639 c
16640 c FFEINTRIN_imp_INT_R:
16641 c
16642 c FFEINTRIN_specIFIX
16643         call fooI(IFIX(R1))
16644 c FFEINTRIN_specINT
16645         call fooI(INT(R1))
16646 c
16647 c FFEINTRIN_imp_REAL_D:
16648 c
16649 c FFEINTRIN_specSNGL
16650         call fooR(SNGL(D1))
16651 c
16652 c FFEINTRIN_imp_REAL_I:
16653 c
16654 c FFEINTRIN_specFLOAT
16655         call fooR(FLOAT(I1))
16656 c FFEINTRIN_specREAL
16657         call fooR(REAL(I1))
16658 c
16659         end
16660 -------- (end input file to f2c)
16661
16662 -------- (begin output from providing above input file as input to:
16663 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16664 --------     -e "s:^#.*$::g"')
16665
16666 //  -- translated by f2c (version 19950223).
16667    You must link the resulting object file with the libraries:
16668         -lf2c -lm   (in that order)
16669 //
16670
16671
16672 // f2c.h  --  Standard Fortran to C header file //
16673
16674 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16675
16676         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16677
16678
16679
16680
16681 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16682 // we assume short, float are OK //
16683 typedef long int // long int // integer;
16684 typedef char *address;
16685 typedef short int shortint;
16686 typedef float real;
16687 typedef double doublereal;
16688 typedef struct { real r, i; } complex;
16689 typedef struct { doublereal r, i; } doublecomplex;
16690 typedef long int // long int // logical;
16691 typedef short int shortlogical;
16692 typedef char logical1;
16693 typedef char integer1;
16694 // typedef long long longint; // // system-dependent //
16695
16696
16697
16698
16699 // Extern is for use with -E //
16700
16701
16702
16703
16704 // I/O stuff //
16705
16706
16707
16708
16709
16710
16711
16712
16713 typedef long int // int or long int // flag;
16714 typedef long int // int or long int // ftnlen;
16715 typedef long int // int or long int // ftnint;
16716
16717
16718 //external read, write//
16719 typedef struct
16720 {       flag cierr;
16721         ftnint ciunit;
16722         flag ciend;
16723         char *cifmt;
16724         ftnint cirec;
16725 } cilist;
16726
16727 //internal read, write//
16728 typedef struct
16729 {       flag icierr;
16730         char *iciunit;
16731         flag iciend;
16732         char *icifmt;
16733         ftnint icirlen;
16734         ftnint icirnum;
16735 } icilist;
16736
16737 //open//
16738 typedef struct
16739 {       flag oerr;
16740         ftnint ounit;
16741         char *ofnm;
16742         ftnlen ofnmlen;
16743         char *osta;
16744         char *oacc;
16745         char *ofm;
16746         ftnint orl;
16747         char *oblnk;
16748 } olist;
16749
16750 //close//
16751 typedef struct
16752 {       flag cerr;
16753         ftnint cunit;
16754         char *csta;
16755 } cllist;
16756
16757 //rewind, backspace, endfile//
16758 typedef struct
16759 {       flag aerr;
16760         ftnint aunit;
16761 } alist;
16762
16763 // inquire //
16764 typedef struct
16765 {       flag inerr;
16766         ftnint inunit;
16767         char *infile;
16768         ftnlen infilen;
16769         ftnint  *inex;  //parameters in standard's order//
16770         ftnint  *inopen;
16771         ftnint  *innum;
16772         ftnint  *innamed;
16773         char    *inname;
16774         ftnlen  innamlen;
16775         char    *inacc;
16776         ftnlen  inacclen;
16777         char    *inseq;
16778         ftnlen  inseqlen;
16779         char    *indir;
16780         ftnlen  indirlen;
16781         char    *infmt;
16782         ftnlen  infmtlen;
16783         char    *inform;
16784         ftnint  informlen;
16785         char    *inunf;
16786         ftnlen  inunflen;
16787         ftnint  *inrecl;
16788         ftnint  *innrec;
16789         char    *inblank;
16790         ftnlen  inblanklen;
16791 } inlist;
16792
16793
16794
16795 union Multitype {       // for multiple entry points //
16796         integer1 g;
16797         shortint h;
16798         integer i;
16799         // longint j; //
16800         real r;
16801         doublereal d;
16802         complex c;
16803         doublecomplex z;
16804         };
16805
16806 typedef union Multitype Multitype;
16807
16808 typedef long Long;      // No longer used; formerly in Namelist //
16809
16810 struct Vardesc {        // for Namelist //
16811         char *name;
16812         char *addr;
16813         ftnlen *dims;
16814         int  type;
16815         };
16816 typedef struct Vardesc Vardesc;
16817
16818 struct Namelist {
16819         char *name;
16820         Vardesc **vars;
16821         int nvars;
16822         };
16823 typedef struct Namelist Namelist;
16824
16825
16826
16827
16828
16829
16830
16831
16832 // procedure parameter types for -A and -C++ //
16833
16834
16835
16836
16837 typedef int // Unknown procedure type // (*U_fp)();
16838 typedef shortint (*J_fp)();
16839 typedef integer (*I_fp)();
16840 typedef real (*R_fp)();
16841 typedef doublereal (*D_fp)(), (*E_fp)();
16842 typedef // Complex // void  (*C_fp)();
16843 typedef // Double Complex // void  (*Z_fp)();
16844 typedef logical (*L_fp)();
16845 typedef shortlogical (*K_fp)();
16846 typedef // Character // void  (*H_fp)();
16847 typedef // Subroutine // int (*S_fp)();
16848
16849 // E_fp is for real functions when -R is not specified //
16850 typedef void  C_f;      // complex function //
16851 typedef void  H_f;      // character function //
16852 typedef void  Z_f;      // double complex function //
16853 typedef doublereal E_f; // real function with -R not specified //
16854
16855 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16856
16857
16858 // (No such symbols should be defined in a strict ANSI C compiler.
16859    We can avoid trouble with f2c-translated code by using
16860    gcc -ansi [-traditional].) //
16861
16862
16863
16864
16865
16866
16867
16868
16869
16870
16871
16872
16873
16874
16875
16876
16877
16878
16879
16880
16881
16882
16883
16884 // Main program // MAIN__()
16885 {
16886     // System generated locals //
16887     integer i__1;
16888     real r__1, r__2;
16889     doublereal d__1, d__2;
16890     complex q__1;
16891     doublecomplex z__1, z__2, z__3;
16892     logical L__1;
16893     char ch__1[1];
16894
16895     // Builtin functions //
16896     void c_div();
16897     integer pow_ii();
16898     double pow_ri(), pow_di();
16899     void pow_ci();
16900     double pow_dd();
16901     void pow_zz();
16902     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16903             asin(), atan(), atan2(), c_abs();
16904     void c_cos(), c_exp(), c_log(), r_cnjg();
16905     double cos(), cosh();
16906     void c_sin(), c_sqrt();
16907     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16908             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16909     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16910     logical l_ge(), l_gt(), l_le(), l_lt();
16911     integer i_nint();
16912     double r_sign();
16913
16914     // Local variables //
16915     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16916             fool_(), fooz_(), getem_();
16917     static char a1[10], a2[10];
16918     static complex c1, c2;
16919     static doublereal d1, d2;
16920     static integer i1, i2;
16921     static real r1, r2;
16922
16923
16924     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16925 // / //
16926     i__1 = i1 / i2;
16927     fooi_(&i__1);
16928     r__1 = r1 / i1;
16929     foor_(&r__1);
16930     d__1 = d1 / i1;
16931     food_(&d__1);
16932     d__1 = (doublereal) i1;
16933     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16934     fooc_(&q__1);
16935     r__1 = r1 / r2;
16936     foor_(&r__1);
16937     d__1 = r1 / d1;
16938     food_(&d__1);
16939     d__1 = d1 / d2;
16940     food_(&d__1);
16941     d__1 = d1 / r1;
16942     food_(&d__1);
16943     c_div(&q__1, &c1, &c2);
16944     fooc_(&q__1);
16945     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16946     fooc_(&q__1);
16947     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16948     fooz_(&z__1);
16949 // ** //
16950     i__1 = pow_ii(&i1, &i2);
16951     fooi_(&i__1);
16952     r__1 = pow_ri(&r1, &i1);
16953     foor_(&r__1);
16954     d__1 = pow_di(&d1, &i1);
16955     food_(&d__1);
16956     pow_ci(&q__1, &c1, &i1);
16957     fooc_(&q__1);
16958     d__1 = (doublereal) r1;
16959     d__2 = (doublereal) r2;
16960     r__1 = pow_dd(&d__1, &d__2);
16961     foor_(&r__1);
16962     d__2 = (doublereal) r1;
16963     d__1 = pow_dd(&d__2, &d1);
16964     food_(&d__1);
16965     d__1 = pow_dd(&d1, &d2);
16966     food_(&d__1);
16967     d__2 = (doublereal) r1;
16968     d__1 = pow_dd(&d1, &d__2);
16969     food_(&d__1);
16970     z__2.r = c1.r, z__2.i = c1.i;
16971     z__3.r = c2.r, z__3.i = c2.i;
16972     pow_zz(&z__1, &z__2, &z__3);
16973     q__1.r = z__1.r, q__1.i = z__1.i;
16974     fooc_(&q__1);
16975     z__2.r = c1.r, z__2.i = c1.i;
16976     z__3.r = r1, z__3.i = 0.;
16977     pow_zz(&z__1, &z__2, &z__3);
16978     q__1.r = z__1.r, q__1.i = z__1.i;
16979     fooc_(&q__1);
16980     z__2.r = c1.r, z__2.i = c1.i;
16981     z__3.r = d1, z__3.i = 0.;
16982     pow_zz(&z__1, &z__2, &z__3);
16983     fooz_(&z__1);
16984 // FFEINTRIN_impABS //
16985     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16986     foor_(&r__1);
16987 // FFEINTRIN_impACOS //
16988     r__1 = acos(r1);
16989     foor_(&r__1);
16990 // FFEINTRIN_impAIMAG //
16991     r__1 = r_imag(&c1);
16992     foor_(&r__1);
16993 // FFEINTRIN_impAINT //
16994     r__1 = r_int(&r1);
16995     foor_(&r__1);
16996 // FFEINTRIN_impALOG //
16997     r__1 = log(r1);
16998     foor_(&r__1);
16999 // FFEINTRIN_impALOG10 //
17000     r__1 = r_lg10(&r1);
17001     foor_(&r__1);
17002 // FFEINTRIN_impAMAX0 //
17003     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17004     foor_(&r__1);
17005 // FFEINTRIN_impAMAX1 //
17006     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17007     foor_(&r__1);
17008 // FFEINTRIN_impAMIN0 //
17009     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17010     foor_(&r__1);
17011 // FFEINTRIN_impAMIN1 //
17012     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17013     foor_(&r__1);
17014 // FFEINTRIN_impAMOD //
17015     r__1 = r_mod(&r1, &r2);
17016     foor_(&r__1);
17017 // FFEINTRIN_impANINT //
17018     r__1 = r_nint(&r1);
17019     foor_(&r__1);
17020 // FFEINTRIN_impASIN //
17021     r__1 = asin(r1);
17022     foor_(&r__1);
17023 // FFEINTRIN_impATAN //
17024     r__1 = atan(r1);
17025     foor_(&r__1);
17026 // FFEINTRIN_impATAN2 //
17027     r__1 = atan2(r1, r2);
17028     foor_(&r__1);
17029 // FFEINTRIN_impCABS //
17030     r__1 = c_abs(&c1);
17031     foor_(&r__1);
17032 // FFEINTRIN_impCCOS //
17033     c_cos(&q__1, &c1);
17034     fooc_(&q__1);
17035 // FFEINTRIN_impCEXP //
17036     c_exp(&q__1, &c1);
17037     fooc_(&q__1);
17038 // FFEINTRIN_impCHAR //
17039     *(unsigned char *)&ch__1[0] = i1;
17040     fooa_(ch__1, 1L);
17041 // FFEINTRIN_impCLOG //
17042     c_log(&q__1, &c1);
17043     fooc_(&q__1);
17044 // FFEINTRIN_impCONJG //
17045     r_cnjg(&q__1, &c1);
17046     fooc_(&q__1);
17047 // FFEINTRIN_impCOS //
17048     r__1 = cos(r1);
17049     foor_(&r__1);
17050 // FFEINTRIN_impCOSH //
17051     r__1 = cosh(r1);
17052     foor_(&r__1);
17053 // FFEINTRIN_impCSIN //
17054     c_sin(&q__1, &c1);
17055     fooc_(&q__1);
17056 // FFEINTRIN_impCSQRT //
17057     c_sqrt(&q__1, &c1);
17058     fooc_(&q__1);
17059 // FFEINTRIN_impDABS //
17060     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
17061     food_(&d__1);
17062 // FFEINTRIN_impDACOS //
17063     d__1 = acos(d1);
17064     food_(&d__1);
17065 // FFEINTRIN_impDASIN //
17066     d__1 = asin(d1);
17067     food_(&d__1);
17068 // FFEINTRIN_impDATAN //
17069     d__1 = atan(d1);
17070     food_(&d__1);
17071 // FFEINTRIN_impDATAN2 //
17072     d__1 = atan2(d1, d2);
17073     food_(&d__1);
17074 // FFEINTRIN_impDCOS //
17075     d__1 = cos(d1);
17076     food_(&d__1);
17077 // FFEINTRIN_impDCOSH //
17078     d__1 = cosh(d1);
17079     food_(&d__1);
17080 // FFEINTRIN_impDDIM //
17081     d__1 = d_dim(&d1, &d2);
17082     food_(&d__1);
17083 // FFEINTRIN_impDEXP //
17084     d__1 = exp(d1);
17085     food_(&d__1);
17086 // FFEINTRIN_impDIM //
17087     r__1 = r_dim(&r1, &r2);
17088     foor_(&r__1);
17089 // FFEINTRIN_impDINT //
17090     d__1 = d_int(&d1);
17091     food_(&d__1);
17092 // FFEINTRIN_impDLOG //
17093     d__1 = log(d1);
17094     food_(&d__1);
17095 // FFEINTRIN_impDLOG10 //
17096     d__1 = d_lg10(&d1);
17097     food_(&d__1);
17098 // FFEINTRIN_impDMAX1 //
17099     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
17100     food_(&d__1);
17101 // FFEINTRIN_impDMIN1 //
17102     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
17103     food_(&d__1);
17104 // FFEINTRIN_impDMOD //
17105     d__1 = d_mod(&d1, &d2);
17106     food_(&d__1);
17107 // FFEINTRIN_impDNINT //
17108     d__1 = d_nint(&d1);
17109     food_(&d__1);
17110 // FFEINTRIN_impDPROD //
17111     d__1 = (doublereal) r1 * r2;
17112     food_(&d__1);
17113 // FFEINTRIN_impDSIGN //
17114     d__1 = d_sign(&d1, &d2);
17115     food_(&d__1);
17116 // FFEINTRIN_impDSIN //
17117     d__1 = sin(d1);
17118     food_(&d__1);
17119 // FFEINTRIN_impDSINH //
17120     d__1 = sinh(d1);
17121     food_(&d__1);
17122 // FFEINTRIN_impDSQRT //
17123     d__1 = sqrt(d1);
17124     food_(&d__1);
17125 // FFEINTRIN_impDTAN //
17126     d__1 = tan(d1);
17127     food_(&d__1);
17128 // FFEINTRIN_impDTANH //
17129     d__1 = tanh(d1);
17130     food_(&d__1);
17131 // FFEINTRIN_impEXP //
17132     r__1 = exp(r1);
17133     foor_(&r__1);
17134 // FFEINTRIN_impIABS //
17135     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
17136     fooi_(&i__1);
17137 // FFEINTRIN_impICHAR //
17138     i__1 = *(unsigned char *)a1;
17139     fooi_(&i__1);
17140 // FFEINTRIN_impIDIM //
17141     i__1 = i_dim(&i1, &i2);
17142     fooi_(&i__1);
17143 // FFEINTRIN_impIDNINT //
17144     i__1 = i_dnnt(&d1);
17145     fooi_(&i__1);
17146 // FFEINTRIN_impINDEX //
17147     i__1 = i_indx(a1, a2, 10L, 10L);
17148     fooi_(&i__1);
17149 // FFEINTRIN_impISIGN //
17150     i__1 = i_sign(&i1, &i2);
17151     fooi_(&i__1);
17152 // FFEINTRIN_impLEN //
17153     i__1 = i_len(a1, 10L);
17154     fooi_(&i__1);
17155 // FFEINTRIN_impLGE //
17156     L__1 = l_ge(a1, a2, 10L, 10L);
17157     fool_(&L__1);
17158 // FFEINTRIN_impLGT //
17159     L__1 = l_gt(a1, a2, 10L, 10L);
17160     fool_(&L__1);
17161 // FFEINTRIN_impLLE //
17162     L__1 = l_le(a1, a2, 10L, 10L);
17163     fool_(&L__1);
17164 // FFEINTRIN_impLLT //
17165     L__1 = l_lt(a1, a2, 10L, 10L);
17166     fool_(&L__1);
17167 // FFEINTRIN_impMAX0 //
17168     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17169     fooi_(&i__1);
17170 // FFEINTRIN_impMAX1 //
17171     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17172     fooi_(&i__1);
17173 // FFEINTRIN_impMIN0 //
17174     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17175     fooi_(&i__1);
17176 // FFEINTRIN_impMIN1 //
17177     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17178     fooi_(&i__1);
17179 // FFEINTRIN_impMOD //
17180     i__1 = i1 % i2;
17181     fooi_(&i__1);
17182 // FFEINTRIN_impNINT //
17183     i__1 = i_nint(&r1);
17184     fooi_(&i__1);
17185 // FFEINTRIN_impSIGN //
17186     r__1 = r_sign(&r1, &r2);
17187     foor_(&r__1);
17188 // FFEINTRIN_impSIN //
17189     r__1 = sin(r1);
17190     foor_(&r__1);
17191 // FFEINTRIN_impSINH //
17192     r__1 = sinh(r1);
17193     foor_(&r__1);
17194 // FFEINTRIN_impSQRT //
17195     r__1 = sqrt(r1);
17196     foor_(&r__1);
17197 // FFEINTRIN_impTAN //
17198     r__1 = tan(r1);
17199     foor_(&r__1);
17200 // FFEINTRIN_impTANH //
17201     r__1 = tanh(r1);
17202     foor_(&r__1);
17203 // FFEINTRIN_imp_CMPLX_C //
17204     r__1 = c1.r;
17205     r__2 = c2.r;
17206     q__1.r = r__1, q__1.i = r__2;
17207     fooc_(&q__1);
17208 // FFEINTRIN_imp_CMPLX_D //
17209     z__1.r = d1, z__1.i = d2;
17210     fooz_(&z__1);
17211 // FFEINTRIN_imp_CMPLX_I //
17212     r__1 = (real) i1;
17213     r__2 = (real) i2;
17214     q__1.r = r__1, q__1.i = r__2;
17215     fooc_(&q__1);
17216 // FFEINTRIN_imp_CMPLX_R //
17217     q__1.r = r1, q__1.i = r2;
17218     fooc_(&q__1);
17219 // FFEINTRIN_imp_DBLE_C //
17220     d__1 = (doublereal) c1.r;
17221     food_(&d__1);
17222 // FFEINTRIN_imp_DBLE_D //
17223     d__1 = d1;
17224     food_(&d__1);
17225 // FFEINTRIN_imp_DBLE_I //
17226     d__1 = (doublereal) i1;
17227     food_(&d__1);
17228 // FFEINTRIN_imp_DBLE_R //
17229     d__1 = (doublereal) r1;
17230     food_(&d__1);
17231 // FFEINTRIN_imp_INT_C //
17232     i__1 = (integer) c1.r;
17233     fooi_(&i__1);
17234 // FFEINTRIN_imp_INT_D //
17235     i__1 = (integer) d1;
17236     fooi_(&i__1);
17237 // FFEINTRIN_imp_INT_I //
17238     i__1 = i1;
17239     fooi_(&i__1);
17240 // FFEINTRIN_imp_INT_R //
17241     i__1 = (integer) r1;
17242     fooi_(&i__1);
17243 // FFEINTRIN_imp_REAL_C //
17244     r__1 = c1.r;
17245     foor_(&r__1);
17246 // FFEINTRIN_imp_REAL_D //
17247     r__1 = (real) d1;
17248     foor_(&r__1);
17249 // FFEINTRIN_imp_REAL_I //
17250     r__1 = (real) i1;
17251     foor_(&r__1);
17252 // FFEINTRIN_imp_REAL_R //
17253     r__1 = r1;
17254     foor_(&r__1);
17255
17256 // FFEINTRIN_imp_INT_D: //
17257
17258 // FFEINTRIN_specIDINT //
17259     i__1 = (integer) d1;
17260     fooi_(&i__1);
17261
17262 // FFEINTRIN_imp_INT_R: //
17263
17264 // FFEINTRIN_specIFIX //
17265     i__1 = (integer) r1;
17266     fooi_(&i__1);
17267 // FFEINTRIN_specINT //
17268     i__1 = (integer) r1;
17269     fooi_(&i__1);
17270
17271 // FFEINTRIN_imp_REAL_D: //
17272
17273 // FFEINTRIN_specSNGL //
17274     r__1 = (real) d1;
17275     foor_(&r__1);
17276
17277 // FFEINTRIN_imp_REAL_I: //
17278
17279 // FFEINTRIN_specFLOAT //
17280     r__1 = (real) i1;
17281     foor_(&r__1);
17282 // FFEINTRIN_specREAL //
17283     r__1 = (real) i1;
17284     foor_(&r__1);
17285
17286 } // MAIN__ //
17287
17288 -------- (end output file from f2c)
17289
17290 */