home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / g77-0.5.15-src.tgz / tar.out / fsf / g77 / f / com.c < prev    next >
C/C++ Source or Header  |  1996-09-28  |  379KB  |  13,639 lines
  1. /* com.c -- Implementation File (module.c template V1.0)
  2.    Copyright (C) 1995 Free Software Foundation, Inc.
  3.    Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
  4.  
  5. This file is part of GNU Fortran.
  6.  
  7. GNU Fortran is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2, or (at your option)
  10. any later version.
  11.  
  12. GNU Fortran is distributed in the hope that it will be useful,
  13. but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15. GNU General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with GNU Fortran; see the file COPYING.  If not, write to
  19. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.    Related Modules:
  22.       None
  23.  
  24.    Description:
  25.       Contains compiler-specific functions.
  26.  
  27.    Modifications:
  28. */
  29.  
  30. /* Understanding this module means understanding the interface between
  31.    the g77 front end and the gcc back end (or, perhaps, some other
  32.    back end).  In here are the functions called by the front end proper
  33.    to notify whatever back end is in place about certain things, and
  34.    also the back-end-specific functions.  It's a bear to deal with, so
  35.    lately I've been trying to simplify things, especially with regard
  36.    to the gcc-back-end-specific stuff.
  37.  
  38.    Building expressions generally seems quite easy, but building decls
  39.    has been challenging and is undergoing revision.  gcc has several
  40.    kinds of decls:
  41.  
  42.    TYPE_DECL -- a type (int, float, struct, function, etc.)
  43.    CONST_DECL -- a constant of some type other than function
  44.    LABEL_DECL -- a variable or a constant?
  45.    PARM_DECL -- an argument to a function (a variable that is a dummy)
  46.    RESULT_DECL -- the return value of a function (a variable)
  47.    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
  48.    FUNCTION_DECL -- a function (either the actual function or an extern ref)
  49.    FIELD_DECL -- a field in a struct or union (goes into types)
  50.  
  51.    g77 has a set of functions that somewhat parallels the gcc front end
  52.    when it comes to building decls:
  53.  
  54.    Internal Function (one we define, not just declare as extern):
  55.    int yes;
  56.    yes = suspend_momentary ();
  57.    if (is_nested) push_f_function_context ();
  58.    start_function (get_identifier ("function_name"), function_type,
  59.            is_nested, is_public);
  60.    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  61.    store_parm_decls (is_main_program);
  62.    ffecom_start_compstmt_ ();
  63.    // for stmts and decls inside function, do appropriate things;
  64.    ffecom_end_compstmt_ ();
  65.    finish_function (is_nested);
  66.    if (is_nested) pop_f_function_context ();
  67.    if (is_nested) resume_momentary (yes);
  68.  
  69.    Everything Else:
  70.    int yes;
  71.    tree d;
  72.    tree init;
  73.    yes = suspend_momentary ();
  74.    // fill in external, public, static, &c for decl, and
  75.    // set DECL_INITIAL to error_mark_node if going to initialize
  76.    // set is_top_level TRUE only if not at top level and decl
  77.    // must go in top level (i.e. not within current function decl context)
  78.    d = start_decl (decl, is_top_level);
  79.    init = ...;    // if have initializer
  80.    finish_decl (d, init, is_top_level);
  81.    resume_momentary (yes);
  82.  
  83. */
  84.  
  85. /* Include files. */
  86.  
  87. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  88. #include "config.j"
  89. #include "flags.j"
  90. #include "rtl.j"
  91. #include "tree.j"
  92. #include "convert.j"
  93. #endif    /* GCC */
  94.  
  95. #define FFECOM_GCC_INCLUDE 1    /* Enable -I. */
  96.  
  97. /* BEGIN stuff from gcc/cccp.c.  */
  98.  
  99. /* This defines "errno" properly for VMS, and gives us EACCES. */
  100. #include <errno.h>
  101.  
  102. /* VMS-specific definitions */
  103. #ifdef VMS
  104. #include <time.h>
  105. #include <descrip.h>
  106. #define O_RDONLY    0    /* Open arg for Read/Only  */
  107. #define O_WRONLY    1    /* Open arg for Write/Only */
  108. #define read(fd,buf,size)    VMS_read (fd,buf,size)
  109. #define write(fd,buf,size)    VMS_write (fd,buf,size)
  110. #define open(fname,mode,prot)    VMS_open (fname,mode,prot)
  111. #define fopen(fname,mode)    VMS_fopen (fname,mode)
  112. #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
  113. #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
  114. static char * VMS_strncat ();
  115. static int VMS_read ();
  116. static int VMS_write ();
  117. static int VMS_open ();
  118. static FILE * VMS_fopen ();
  119. static FILE * VMS_freopen ();
  120. static void hack_vms_include_specification ();
  121. typedef struct { unsigned :16, :16, :16; } vms_ino_t;
  122. #define ino_t vms_ino_t
  123. #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
  124. #ifdef __GNUC__
  125. #define BSTRING            /* VMS/GCC supplies the bstring routines */
  126. #endif /* __GNUC__ */
  127. #endif /* VMS */
  128.   
  129. extern char *index ();
  130. extern char *rindex ();
  131.  
  132. #ifndef O_RDONLY
  133. #define O_RDONLY 0
  134. #endif
  135.  
  136. /* END stuff from gcc/cccp.c.  */
  137.  
  138. #include "proj.h"
  139. #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
  140. #include "com.h"
  141. #include "bad.h"
  142. #include "bld.h"
  143. #include "equiv.h"
  144. #include "expr.h"
  145. #include "implic.h"
  146. #include "info.h"
  147. #include "malloc.h"
  148. #include "src.h"
  149. #include "st.h"
  150. #include "storag.h"
  151. #include "symbol.h"
  152. #include "target.h"
  153. #include "top.h"
  154. #include "type.h"
  155.  
  156. /* Externals defined here.  */
  157.  
  158. #define FFECOM_FASTER_ARRAY_REFS 0    /* Generates faster code? */
  159.  
  160. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  161.  
  162. /* tree.h declares a bunch of stuff that it expects the front end to
  163.    define.  Here are the definitions, which in the C front end are
  164.    found in the file c-decl.c.  */
  165.  
  166. tree integer_zero_node;
  167. tree integer_one_node;
  168. tree null_pointer_node;
  169. tree error_mark_node;
  170. tree void_type_node;
  171. tree integer_type_node;
  172. tree unsigned_type_node;
  173. tree char_type_node;
  174. tree current_function_decl;
  175.  
  176. /* ~~tree.h SHOULD declare this, because toplev.c and dwarfout.c reference
  177.    it.  */
  178.  
  179. char *language_string = "GNU F77";
  180.  
  181. /* These definitions parallel those in c-decl.c so that code from that
  182.    module can be used pretty much as is.  Much of these defs aren't
  183.    otherwise used, i.e. by g77 code per se, except some of them are used
  184.    to build some of them that are.  The ones that are global (i.e. not
  185.    "static") are those that ste.c and such might use (directly
  186.    or by using com macros that reference them in their definitions).  */
  187.  
  188. static tree short_integer_type_node;
  189. tree long_integer_type_node;
  190. static tree long_long_integer_type_node;
  191.  
  192. static tree short_unsigned_type_node;
  193. static tree long_unsigned_type_node;
  194. static tree long_long_unsigned_type_node;
  195.  
  196. static tree unsigned_char_type_node;
  197. static tree signed_char_type_node;
  198.  
  199. static tree float_type_node;
  200. static tree double_type_node;
  201. static tree complex_float_type_node;
  202. tree complex_double_type_node;
  203. static tree long_double_type_node;
  204. static tree complex_integer_type_node;
  205. static tree complex_long_double_type_node;
  206.  
  207. tree string_type_node;
  208.  
  209. /* The rest of these are inventions for g77, though there might be
  210.    similar things in the C front end.  As they are found, these
  211.    inventions should be renamed to be canonical.  Note that only
  212.    the ones currently required to be global are so.  */
  213.  
  214. static tree ffecom_tree_fun_type_void;
  215. static tree ffecom_tree_ptr_to_fun_type_void;
  216. static tree ffecom_tree_fun_type_double;
  217.  
  218. tree ffecom_integer_type_node;    /* Abbrev for _tree_type[blah][blah]. */
  219. tree ffecom_integer_zero_node;    /* Like *_*_* with g77's integer type. */
  220. tree ffecom_integer_one_node;    /* " */
  221. tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
  222.  
  223. /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
  224.    just use build_function_type and build_pointer_type on the
  225.    appropriate _tree_type array element.  */
  226.  
  227. static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
  228. static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
  229. static tree ffecom_tree_subr_type;
  230. static tree ffecom_tree_ptr_to_subr_type;
  231. static tree ffecom_tree_blockdata_type;
  232.  
  233. ffecomSymbol ffecom_symbol_null_
  234. =
  235. {
  236.   NULL_TREE,
  237.   NULL_TREE,
  238.   NULL_TREE,
  239. };
  240.  
  241. int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
  242. tree ffecom_f2c_integer_type_node;
  243. tree ffecom_f2c_address_type_node;
  244. tree ffecom_f2c_real_type_node;
  245. tree ffecom_f2c_doublereal_type_node;
  246. tree ffecom_f2c_complex_type_node;
  247. tree ffecom_f2c_doublecomplex_type_node;
  248. tree ffecom_f2c_logical_type_node;
  249. tree ffecom_f2c_flag_type_node;
  250. tree ffecom_f2c_ftnlen_type_node;
  251. tree ffecom_f2c_ftnlen_zero_node;
  252. tree ffecom_f2c_ftnlen_one_node;
  253. tree ffecom_f2c_ftnlen_two_node;
  254. tree ffecom_f2c_ptr_to_ftnlen_type_node;
  255. tree ffecom_f2c_ftnint_type_node;
  256. tree ffecom_f2c_ptr_to_ftnint_type_node;
  257. #endif
  258.  
  259. /* Simple definitions and enumerations. */
  260.  
  261. #ifndef FFECOM_sizeMAXSTACKITEM
  262. #define FFECOM_sizeMAXSTACKITEM 32*1024    /* Keep user-declared things
  263.                        larger than this # bytes
  264.                        off stack if possible. */
  265. #endif
  266.  
  267. /* For systems that have large enough stacks, they should define
  268.    this to 0, and here, for ease of use later on, we just undefine
  269.    it if it is 0.  */
  270.  
  271. #if FFECOM_sizeMAXSTACKITEM == 0
  272. #undef FFECOM_sizeMAXSTACKITEM
  273. #endif
  274.  
  275. typedef enum
  276.   {
  277.     FFECOM_rttypeVOID_,
  278.     FFECOM_rttypeINTEGER_,
  279.     FFECOM_rttypeLOGICAL_,
  280.     FFECOM_rttypeREAL_,
  281.     FFECOM_rttypeCOMPLEX_,
  282.     FFECOM_rttypeDOUBLE_,    /* C's double type. */
  283.     FFECOM_rttypeDOUBLEREAL_,
  284.     FFECOM_rttypeDBLCMPLX_,
  285.     FFECOM_rttype_
  286.   } ffecomRttype_;
  287.  
  288. /* Internal typedefs. */
  289.  
  290. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  291. typedef struct _ffecom_concat_list_ ffecomConcatList_;
  292. typedef struct _ffecom_temp_ *ffecomTemp_;
  293. #endif
  294.  
  295. /* Private include files. */
  296.  
  297.  
  298. /* Internal structure definitions. */
  299.  
  300. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  301. struct _ffecom_concat_list_
  302.   {
  303.     ffebld *exprs;
  304.     int count;
  305.     int max;
  306.     ffetargetCharacterSize minlen;
  307.     ffetargetCharacterSize maxlen;
  308.   };
  309.  
  310. struct _ffecom_temp_
  311.   {
  312.     ffecomTemp_ next;
  313.     tree type;            /* Base type (w/o size/array applied). */
  314.     tree t;
  315.     ffetargetCharacterSize size;
  316.     int elements;
  317.     bool in_use;
  318.     bool auto_pop;
  319.   };
  320.  
  321. #endif
  322.  
  323. /* Static functions (internal). */
  324.  
  325. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  326. static tree ffecom_build_f2c_string_ (int i, char *s);
  327. static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
  328.               bool is_f2c_complex, tree type,
  329.               tree args, tree dest_tree,
  330.               ffeinfo dest_info, bool *dest_used);
  331. static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
  332.                 bool is_f2c_complex, tree type,
  333.                 ffebld left, ffebld right,
  334.                 tree dest_tree, ffeinfo dest_info,
  335.                 bool *dest_used);
  336. static void ffecom_char_args_ (tree *xitem, tree *length,
  337.                    ffebld expr);
  338. static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
  339. static ffecomConcatList_
  340.   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
  341.                   ffebld expr,
  342.                   ffetargetCharacterSize max);
  343. static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
  344. static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
  345.                         ffetargetCharacterSize max);
  346. static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
  347. static tree ffecom_expr_ (ffebld expr, tree dest_tree,
  348.               ffeinfo dest_info, bool *dest_used,
  349.               bool assignp);
  350. static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
  351.                     ffeinfo dest_info, bool *dest_used);
  352. static tree ffecom_expr_power_integer_ (ffebld left, ffebld right);
  353. static void ffecom_expr_transform_ (ffebld expr);
  354. static void ffecom_f2c_make_type_ (tree *type, int tcode, char *name);
  355. static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
  356.                       int code);
  357. static ffeglobal ffecom_finish_global_ (ffeglobal global);
  358. static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
  359. #if FFETARGET_isEXTERNAL_UNDERSCORED || FFETARGET_isUNDERSCORED_EXTERNAL_UNDERSCORED
  360. static tree ffecom_get_appended_identifier_ (char us, char *text);
  361. static tree ffecom_get_external_identifier_ (char *text);
  362. static tree ffecom_get_identifier_ (char *text);
  363. #else
  364. #define ffecom_get_external_identifier_(name) get_identifier (name)
  365. #define ffecom_get_identifier_(name) get_identifier (name)
  366. #endif
  367. static tree ffecom_gen_sfuncdef_ (ffesymbol s,
  368.                   ffeinfoBasictype bt,
  369.                   ffeinfoKindtype kt);
  370. static ffeinfoKindtype ffecom_gfrt_kind_type_ (ffecomGfrt ix);
  371. static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
  372. static tree ffecom_init_local_zero_ (tree decl);
  373. static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
  374.                      tree *maybe_tree);
  375. static tree ffecom_intrinsic_len_ (ffebld expr);
  376. static void ffecom_let_char_ (tree dest_tree,
  377.                   tree dest_length,
  378.                   ffetargetCharacterSize dest_size,
  379.                   ffebld source);
  380. static void ffecom_make_gfrt_ (ffecomGfrt ix);
  381. static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
  382. #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
  383. static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
  384. #endif
  385. static void ffecom_push_dummy_decls_ (ffebld dumlist,
  386.                       bool stmtfunc);
  387. static void ffecom_start_progunit_ (void);
  388. static ffesymbol ffecom_sym_transform_ (ffesymbol s);
  389. static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
  390. static void ffecom_transform_common_ (ffesymbol s);
  391. static void ffecom_transform_equiv_ (ffestorag st);
  392. static tree ffecom_transform_namelist_ (ffesymbol s);
  393. static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
  394.                  tree dest_tree, ffeinfo dest_info,
  395.                  bool *dest_used);
  396. static tree ffecom_type_localvar_ (ffesymbol s,
  397.                    ffeinfoBasictype bt,
  398.                    ffeinfoKindtype kt);
  399. static tree ffecom_type_namelist_ (void);
  400. #if 0
  401. static tree ffecom_type_permanent_copy_ (tree t);
  402. #endif
  403. static tree ffecom_type_vardesc_ (void);
  404. static tree ffecom_vardesc_ (ffebld expr);
  405. static tree ffecom_vardesc_array_ (ffesymbol s);
  406. static tree ffecom_vardesc_dims_ (ffesymbol s);
  407. #endif
  408.  
  409. /* These are static functions that parallel those found in the C front
  410.    end and thus have the same names.  */
  411.  
  412. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  413. static void bison_rule_compstmt_ (void);
  414. static void bison_rule_pushlevel_ (void);
  415. static tree builtin_function (char *name, tree type,
  416.                   enum built_in_function function_code,
  417.                   char *library_name);
  418. static int duplicate_decls (tree newdecl, tree olddecl);
  419. static void finish_decl (tree decl, tree init, bool is_top_level);
  420. static void finish_function (int nested);
  421. static char *lang_printable_name (tree decl, char **kind);
  422. static tree lookup_name_current_level (tree name);
  423. static struct binding_level *make_binding_level (void);
  424. static void pop_f_function_context (void);
  425. static void push_f_function_context (void);
  426. static void push_parm_decl (tree parm);
  427. static tree pushdecl_top_level (tree decl);
  428. static tree storedecls (tree decls);
  429. static void store_parm_decls (int is_main_program);
  430. static tree start_decl (tree decl, bool is_top_level);
  431. static void start_function (tree name, tree type, int nested, int public);
  432. #endif
  433. #if FFECOM_GCC_INCLUDE
  434. static void ffecom_file_ (char *name);
  435. static void ffecom_initialize_char_syntax_ (void);
  436. static void ffecom_close_include_ (FILE *f);
  437. static int ffecom_decode_include_option_ (char *spec);
  438. static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
  439.                    ffewhereColumn c);
  440. #endif    /* FFECOM_GCC_INCLUDE */
  441.  
  442. /* Static objects accessed by functions in this module. */
  443.  
  444. static ffesymbol ffecom_primary_entry_ = NULL;
  445. static ffeinfoKind ffecom_primary_entry_kind_;
  446. static bool ffecom_primary_entry_is_proc_;
  447. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  448. static tree ffecom_outer_function_decl_;
  449. static tree ffecom_previous_function_decl_;
  450. static tree ffecom_which_entrypoint_decl_;
  451. static ffecomTemp_ ffecom_latest_temp_;
  452. static int ffecom_pending_calls_ = 0;
  453. static int ffecom_no_new_tempvars_ = 0;
  454. static tree ffecom_float_zero_ = NULL_TREE;
  455. static tree ffecom_float_half_ = NULL_TREE;
  456. static tree ffecom_double_zero_ = NULL_TREE;
  457. static tree ffecom_double_half_ = NULL_TREE;
  458. static tree ffecom_func_result_;/* For functions. */
  459. static tree ffecom_func_length_;/* For CHARACTER fns. */
  460. static ffebld ffecom_list_blockdata_;
  461. static ffebld ffecom_list_common_;
  462. static ffebld ffecom_master_arglist_;
  463. static ffeinfoBasictype ffecom_master_bt_;
  464. static ffeinfoKindtype ffecom_master_kt_;
  465. static ffetargetCharacterSize ffecom_master_size_;
  466. static int ffecom_num_fns_ = 0;
  467. static int ffecom_num_entrypoints_ = 0;
  468. static bool ffecom_is_altreturning_ = FALSE;
  469. static tree ffecom_multi_type_node_;
  470. static tree ffecom_multi_retval_;
  471. static tree
  472.   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
  473. static bool ffecom_member_namelisted_;    /* _member_phase1_ namelisted? */
  474. static bool ffecom_doing_entry_ = FALSE;
  475. static bool ffecom_transform_only_dummies_ = FALSE;
  476.  
  477. /* Holds pointer-to-function expressions.  */
  478.  
  479. static tree ffecom_gfrt_[FFECOM_gfrt]
  480. =
  481. {
  482. #define DEFGFRT(CODE,NAME,TYPE,VOLATILE,COMPLEX) NULL_TREE,
  483. #include "com-rt.def"
  484. #undef DEFGFRT
  485. };
  486.  
  487. /* Holds the external names of the functions.  */
  488.  
  489. static char *ffecom_gfrt_name_[FFECOM_gfrt]
  490. =
  491. {
  492. #define DEFGFRT(CODE,NAME,TYPE,VOLATILE,COMPLEX) NAME,
  493. #include "com-rt.def"
  494. #undef DEFGFRT
  495. };
  496.  
  497. /* Whether the function returns.  */
  498.  
  499. static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
  500. =
  501. {
  502. #define DEFGFRT(CODE,NAME,TYPE,VOLATILE,COMPLEX) VOLATILE,
  503. #include "com-rt.def"
  504. #undef DEFGFRT
  505. };
  506.  
  507. /* Whether the function returns type complex.  */
  508.  
  509. static bool ffecom_gfrt_complex_[FFECOM_gfrt]
  510. =
  511. {
  512. #define DEFGFRT(CODE,NAME,TYPE,VOLATILE,COMPLEX) COMPLEX,
  513. #include "com-rt.def"
  514. #undef DEFGFRT
  515. };
  516.  
  517. /* Type code for the function return value.  */
  518.  
  519. static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
  520. =
  521. {
  522. #define DEFGFRT(CODE,NAME,TYPE,VOLATILE,COMPLEX) TYPE,
  523. #include "com-rt.def"
  524. #undef DEFGFRT
  525. };
  526.  
  527. /* Kind type of (complex) function return value.  */
  528.  
  529. static ffeinfoBasictype ffecom_gfrt_kt_[FFECOM_gfrt];
  530.  
  531. #endif
  532.  
  533. /* Internal macros. */
  534.  
  535. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  536.  
  537. /* We let tm.h override the types used here, to handle trivial differences
  538.    such as the choice of unsigned int or long unsigned int for size_t.
  539.    When machines start needing nontrivial differences in the size type,
  540.    it would be best to do something here to figure out automatically
  541.    from other information what type to use.  */
  542.  
  543. /* NOTE: g77 currently doesn't use these; see setting of sizetype and
  544.    change that if you need to.    -- jcb 09/01/91. */
  545.  
  546. #ifndef SIZE_TYPE
  547. #define SIZE_TYPE "long unsigned int"
  548. #endif
  549.  
  550. #ifndef WCHAR_TYPE
  551. #define WCHAR_TYPE "int"
  552. #endif
  553.  
  554. #define ffecom_concat_list_count_(catlist) ((catlist).count)
  555. #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
  556. #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
  557. #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
  558.  
  559. #define ffecom_start_compstmt_ bison_rule_pushlevel_
  560. #define ffecom_end_compstmt_ bison_rule_compstmt_
  561.  
  562. /* For each binding contour we allocate a binding_level structure
  563.  * which records the names defined in that contour.
  564.  * Contours include:
  565.  *  0) the global one
  566.  *  1) one for each function definition,
  567.  *     where internal declarations of the parameters appear.
  568.  *
  569.  * The current meaning of a name can be found by searching the levels from
  570.  * the current one out to the global one.
  571.  */
  572.  
  573. /* Note that the information in the `names' component of the global contour
  574.    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
  575.  
  576. struct binding_level
  577.   {
  578.     /* A chain of _DECL nodes for all variables, constants, functions, and
  579.        typedef types.  These are in the reverse of the order supplied. */
  580.     tree names;
  581.  
  582.     /* For each level (except not the global one), a chain of BLOCK nodes for
  583.        all the levels that were entered and exited one level down.  */
  584.     tree blocks;
  585.  
  586.     /* The BLOCK node for this level, if one has been preallocated. If 0, the
  587.        BLOCK is allocated (if needed) when the level is popped.  */
  588.     tree this_block;
  589.  
  590.     /* The binding level which this one is contained in (inherits from).  */
  591.     struct binding_level *level_chain;
  592.   };
  593.  
  594. #define NULL_BINDING_LEVEL (struct binding_level *) NULL
  595.  
  596. /* The binding level currently in effect.  */
  597.  
  598. static struct binding_level *current_binding_level;
  599.  
  600. /* A chain of binding_level structures awaiting reuse.  */
  601.  
  602. static struct binding_level *free_binding_level;
  603.  
  604. /* The outermost binding level, for names of file scope.
  605.    This is created when the compiler is started and exists
  606.    through the entire run.  */
  607.  
  608. static struct binding_level *global_binding_level;
  609.  
  610. /* Binding level structures are initialized by copying this one.  */
  611.  
  612. static struct binding_level clear_binding_level
  613. =
  614. {NULL, NULL, NULL, NULL_BINDING_LEVEL};
  615.  
  616. /* Language-dependent contents of an identifier.  */
  617.  
  618. struct lang_identifier
  619.   {
  620.     struct tree_identifier ignore;
  621.     tree global_value, local_value, label_value;
  622.     bool invented;
  623.   };
  624.  
  625. /* Macros for access to language-specific slots in an identifier.  */
  626. /* Each of these slots contains a DECL node or null.  */
  627.  
  628. /* This represents the value which the identifier has in the
  629.    file-scope namespace.  */
  630. #define IDENTIFIER_GLOBAL_VALUE(NODE)    \
  631.   (((struct lang_identifier *)(NODE))->global_value)
  632. /* This represents the value which the identifier has in the current
  633.    scope.  */
  634. #define IDENTIFIER_LOCAL_VALUE(NODE)    \
  635.   (((struct lang_identifier *)(NODE))->local_value)
  636. /* This represents the value which the identifier has as a label in
  637.    the current label scope.  */
  638. #define IDENTIFIER_LABEL_VALUE(NODE)    \
  639.   (((struct lang_identifier *)(NODE))->label_value)
  640. /* This is nonzero if the identifier was "made up" by g77 code.  */
  641. #define IDENTIFIER_INVENTED(NODE)    \
  642.   (((struct lang_identifier *)(NODE))->invented)
  643.  
  644. /* In identifiers, C uses the following fields in a special way:
  645.    TREE_PUBLIC          to record that there was a previous local extern decl.
  646.    TREE_USED          to record that such a decl was used.
  647.    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
  648.  
  649. /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
  650.    that have names.  Here so we can clear out their names' definitions
  651.    at the end of the function.  */
  652.  
  653. static tree named_labels;
  654.  
  655. /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
  656.  
  657. static tree shadowed_labels;
  658.  
  659. #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
  660.  
  661. /* Build a string for a variable name as used by NAMELIST.  This means that
  662.    if we're using the f2c library, we build an uppercase string, since
  663.    f2c does this.  */
  664.  
  665. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  666. static tree
  667. ffecom_build_f2c_string_ (int i, char *s)
  668. {
  669.   if (!ffe_is_f2c_library ())
  670.     return build_string (i, s);
  671.  
  672.   {
  673.     char *tmp;
  674.     char *p;
  675.     char *q;
  676.     char space[34];
  677.     tree t;
  678.  
  679.     if (i > ARRAY_SIZE (space))
  680.       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
  681.     else
  682.       tmp = &space[0];
  683.  
  684.     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
  685.       *q = ffesrc_toupper (*p);
  686.     *q = '\0';
  687.  
  688.     t = build_string (i, tmp);
  689.  
  690.     if (i > ARRAY_SIZE (space))
  691.       malloc_kill_ks (malloc_pool_image (), tmp, i);
  692.  
  693.     return t;
  694.   }
  695. }
  696.  
  697. #endif
  698. /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
  699.    type to just get whatever the function returns), handling the
  700.    f2c complex-returning convention, if required, by prepending
  701.    to the arglist a pointer to a temporary to receive the return value.     */
  702.  
  703. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  704. static tree
  705. ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
  706.           tree type, tree args, tree dest_tree,
  707.           ffeinfo dest_info, bool *dest_used)
  708. {
  709.   tree item;
  710.   tree tempvar;
  711.  
  712.   if (dest_used != NULL)
  713.     *dest_used = FALSE;
  714.  
  715.   if (is_f2c_complex)
  716.     {
  717.       if ((dest_used == NULL)
  718.       || (ffeinfo_basictype (dest_info) != FFEINFO_basictypeCOMPLEX)
  719.       || (ffeinfo_kindtype (dest_info) != kt)
  720.       || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type)))
  721.     {
  722.       tempvar = ffecom_push_tempvar (ffecom_tree_type
  723.                      [FFEINFO_basictypeCOMPLEX][kt],
  724.                      FFETARGET_charactersizeNONE,
  725.                      -1, TRUE);
  726.     }
  727.       else
  728.     {
  729.       *dest_used = TRUE;
  730.       tempvar = dest_tree;
  731.       type = NULL_TREE;
  732.     }
  733.  
  734.       item
  735.     = build_tree_list (NULL_TREE,
  736.                ffecom_1 (ADDR_EXPR,
  737.                    build_pointer_type (TREE_TYPE (tempvar)),
  738.                      tempvar));
  739.       TREE_CHAIN (item) = args;
  740.  
  741.       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
  742.             item, NULL_TREE);
  743.  
  744.       if (tempvar != dest_tree)
  745.     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
  746.     }
  747.   else
  748.     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
  749.               args, NULL_TREE);
  750.  
  751.   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
  752.     item = convert (type, item);
  753.  
  754.   return item;
  755. }
  756. #endif
  757.  
  758. /* Given two arguments, transform them and make a call to the given
  759.    function via ffecom_call_.  */
  760.  
  761. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  762. static tree
  763. ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
  764.             tree type, ffebld left, ffebld right,
  765.             tree dest_tree, ffeinfo dest_info, bool *dest_used)
  766. {
  767.   tree left_tree;
  768.   tree right_tree;
  769.   tree left_length;
  770.   tree right_length;
  771.  
  772.   ffecom_push_calltemps ();
  773.   left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
  774.   right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
  775.   ffecom_pop_calltemps ();
  776.  
  777.   left_tree = build_tree_list (NULL_TREE, left_tree);
  778.   right_tree = build_tree_list (NULL_TREE, right_tree);
  779.   TREE_CHAIN (left_tree) = right_tree;
  780.  
  781.   if (left_length != NULL_TREE)
  782.     {
  783.       left_length = build_tree_list (NULL_TREE, left_length);
  784.       TREE_CHAIN (right_tree) = left_length;
  785.     }
  786.  
  787.   if (right_length != NULL_TREE)
  788.     {
  789.       right_length = build_tree_list (NULL_TREE, right_length);
  790.       if (left_length != NULL_TREE)
  791.     TREE_CHAIN (left_length) = right_length;
  792.       else
  793.     TREE_CHAIN (right_tree) = right_length;
  794.     }
  795.  
  796.   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
  797.                dest_tree, dest_info, dest_used);
  798. }
  799. #endif
  800.  
  801. /* ffecom_char_args_ -- Return ptr/length args for char subexpression
  802.  
  803.    tree ptr_arg;
  804.    tree length_arg;
  805.    ffebld expr;
  806.    ffecom_char_args_(&ptr_arg,&length_arg,expr);
  807.  
  808.    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
  809.    subexpressions by constructing the appropriate trees for the ptr-to-
  810.    character-text and length-of-character-text arguments in a calling
  811.    sequence.  */
  812.  
  813. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  814. static void
  815. ffecom_char_args_ (tree *xitem, tree *length, ffebld expr)
  816. {
  817.   tree item;
  818.   ffetargetCharacter1 val;
  819.  
  820.   switch (ffebld_op (expr))
  821.     {
  822.     case FFEBLD_opCONTER:
  823.       val = ffebld_constant_character1 (ffebld_conter (expr));
  824.       *length = build_int_2 (ffetarget_length_character1 (val), 0);
  825.       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
  826.       item = build_string (ffetarget_length_character1 (val),
  827.                ffetarget_text_character1 (val));
  828.       TREE_TYPE (item)
  829.     = build_type_variant
  830.     (build_array_type
  831.      (char_type_node,
  832.       build_range_type
  833.       (ffecom_f2c_ftnlen_type_node,
  834.        ffecom_f2c_ftnlen_one_node,
  835.        build_int_2
  836.        (ffetarget_length_character1 (val),
  837.         0))),
  838.      1, 0);
  839.       TREE_CONSTANT (item) = 1;
  840.       TREE_STATIC (item) = 1;
  841.       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
  842.                item);
  843.       break;
  844.  
  845.     case FFEBLD_opSYMTER:
  846.       {
  847.     ffesymbol s = ffebld_symter (expr);
  848.  
  849.     item = ffesymbol_hook (s).decl_tree;
  850.     if (item == NULL_TREE)
  851.       {
  852.         s = ffecom_sym_transform_ (s);
  853.         item = ffesymbol_hook (s).decl_tree;
  854.       }
  855.     if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
  856.       {
  857.         if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
  858.           *length = ffesymbol_hook (s).length_tree;
  859.         else
  860.           {
  861.         *length = build_int_2 (ffesymbol_size (s), 0);
  862.         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
  863.           }
  864.       }
  865.     else            /* FFEINFO_kindFUNCTION: */
  866.       *length = NULL_TREE;
  867.     if (!ffesymbol_hook (s).addr
  868.         && (item != error_mark_node))
  869.       item = ffecom_1 (ADDR_EXPR,
  870.                build_pointer_type (TREE_TYPE (item)),
  871.                item);
  872.       }
  873.       break;
  874.  
  875.     case FFEBLD_opARRAYREF:
  876.       {
  877.     ffebld dims[FFECOM_dimensionsMAX];
  878.     tree array;
  879.     int i;
  880.  
  881.     ffecom_push_calltemps ();
  882.     ffecom_char_args_ (&item, length, ffebld_left (expr));
  883.     ffecom_pop_calltemps ();
  884.  
  885.     if (item == error_mark_node || *length == error_mark_node)
  886.       {
  887.         item = *length = error_mark_node;
  888.         break;
  889.       }
  890.  
  891.     /* Build up ARRAY_REFs in reverse order (since we're column major
  892.        here in Fortran land). */
  893.  
  894.     for (i = 0, expr = ffebld_right (expr);
  895.          expr != NULL;
  896.          expr = ffebld_trail (expr))
  897.       dims[i++] = ffebld_head (expr);
  898.  
  899.     for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
  900.          i >= 0;
  901.          --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
  902.       {
  903.         item = ffecom_2 (PLUS_EXPR, build_pointer_type (TREE_TYPE (array)),
  904.                  item,
  905.                  size_binop (MULT_EXPR,
  906.                      size_in_bytes (TREE_TYPE (array)),
  907.                      size_binop (MINUS_EXPR,
  908.                              ffecom_expr (dims[i]),
  909.                     TYPE_MIN_VALUE (TYPE_DOMAIN (array)))));
  910.       }
  911.       }
  912.       break;
  913.  
  914.     case FFEBLD_opSUBSTR:
  915.       {
  916.     ffebld start;
  917.     ffebld end;
  918.     ffebld thing = ffebld_right (expr);
  919.     tree start_tree;
  920.     tree end_tree;
  921.  
  922.     assert (ffebld_op (thing) == FFEBLD_opITEM);
  923.     start = ffebld_head (thing);
  924.     thing = ffebld_trail (thing);
  925.     assert (ffebld_trail (thing) == NULL);
  926.     end = ffebld_head (thing);
  927.  
  928.     ffecom_push_calltemps ();
  929.     ffecom_char_args_ (&item, length, ffebld_left (expr));
  930.     ffecom_pop_calltemps ();
  931.  
  932.     if (item == error_mark_node || *length == error_mark_node)
  933.       {
  934.         item = *length = error_mark_node;
  935.         break;
  936.       }
  937.  
  938.     if (start == NULL)
  939.       {
  940.         if (end == NULL)
  941.           ;
  942.         else
  943.           {
  944.         end_tree = convert (ffecom_f2c_ftnlen_type_node,
  945.                     ffecom_expr (end));
  946.  
  947.         if (end_tree == error_mark_node)
  948.           {
  949.             item = *length = error_mark_node;
  950.             break;
  951.           }
  952.  
  953.         *length = end_tree;
  954.           }
  955.       }
  956.     else
  957.       {
  958.         start_tree = convert (ffecom_f2c_ftnlen_type_node,
  959.                   ffecom_expr (start));
  960.  
  961.         if (start_tree == error_mark_node)
  962.           {
  963.         item = *length = error_mark_node;
  964.         break;
  965.           }
  966.  
  967.         start_tree = ffecom_save_tree (start_tree);
  968.  
  969.         item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
  970.                  item,
  971.                  ffecom_2 (MINUS_EXPR,
  972.                        TREE_TYPE (start_tree),
  973.                        start_tree,
  974.                        ffecom_f2c_ftnlen_one_node));
  975.  
  976.         if (end == NULL)
  977.           {
  978.         *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
  979.                     ffecom_f2c_ftnlen_one_node,
  980.                     ffecom_2 (MINUS_EXPR,
  981.                           ffecom_f2c_ftnlen_type_node,
  982.                           *length,
  983.                           start_tree));
  984.           }
  985.         else
  986.           {
  987.         end_tree = convert (ffecom_f2c_ftnlen_type_node,
  988.                     ffecom_expr (end));
  989.  
  990.         if (end_tree == error_mark_node)
  991.           {
  992.             item = *length = error_mark_node;
  993.             break;
  994.           }
  995.  
  996.         *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
  997.                     ffecom_f2c_ftnlen_one_node,
  998.                     ffecom_2 (MINUS_EXPR,
  999.                           ffecom_f2c_ftnlen_type_node,
  1000.                           end_tree, start_tree));
  1001.           }
  1002.       }
  1003.       }
  1004.       break;
  1005.  
  1006.     case FFEBLD_opFUNCREF:
  1007.       {
  1008.     ffesymbol s = ffebld_symter (ffebld_left (expr));
  1009.     tree tempvar;
  1010.     tree dt;
  1011.     tree args;
  1012.  
  1013.     *length = build_int_2 (ffeinfo_size (ffebld_info (expr)), 0);
  1014.     TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
  1015.  
  1016.     if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
  1017.         == FFEINFO_whereINTRINSIC)
  1018.       {            /* Invocation of an intrinsic. */
  1019.         item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
  1020.                        ffeinfo_new_null (), NULL);
  1021.         break;
  1022.       }
  1023.  
  1024.     assert (ffecom_pending_calls_ != 0);
  1025.     tempvar = ffecom_push_tempvar (char_type_node,
  1026.                        ffeinfo_size (ffebld_info (expr)),
  1027.                        -1, TRUE);
  1028.     tempvar = ffecom_1 (ADDR_EXPR,
  1029.                 build_pointer_type (TREE_TYPE (tempvar)),
  1030.                 tempvar);
  1031.  
  1032.     ffecom_push_calltemps ();
  1033.     dt = ffesymbol_hook (s).decl_tree;
  1034.     if (dt == NULL_TREE)
  1035.       {
  1036.         s = ffecom_sym_transform_ (s);
  1037.         dt = ffesymbol_hook (s).decl_tree;
  1038.       }
  1039.     if (dt == error_mark_node)
  1040.       {
  1041.         item = *length = error_mark_node;
  1042.         break;
  1043.       }
  1044.  
  1045.     if (ffesymbol_hook (s).addr)
  1046.       item = dt;
  1047.     else
  1048.       item = ffecom_1_fn (dt);
  1049.  
  1050.     args = build_tree_list (NULL_TREE, tempvar);
  1051.  
  1052.     if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)    /* Sfunc args by value. */
  1053.       TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
  1054.     else
  1055.       {
  1056.         TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
  1057.         TREE_CHAIN (TREE_CHAIN (args))
  1058.           = ffecom_list_ptr_to_expr (ffebld_right (expr));
  1059.       }
  1060.  
  1061.     item = ffecom_3s (CALL_EXPR,
  1062.               TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
  1063.               item, args, NULL_TREE);
  1064.     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
  1065.              tempvar);
  1066.  
  1067.     ffecom_pop_calltemps ();
  1068.       }
  1069.       break;
  1070.  
  1071.     case FFEBLD_opCONVERT:
  1072.  
  1073.       ffecom_push_calltemps ();
  1074.       ffecom_char_args_ (&item, length, ffebld_left (expr));
  1075.       ffecom_pop_calltemps ();
  1076.  
  1077.       if (item == error_mark_node || *length == error_mark_node)
  1078.     {
  1079.       item = *length = error_mark_node;
  1080.       break;
  1081.     }
  1082.  
  1083.       if ((ffebld_size_known (ffebld_left (expr))
  1084.        == FFETARGET_charactersizeNONE)
  1085.       || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
  1086.     {            /* Possible blank-padding needed, copy into
  1087.                    temporary. */
  1088.       tree tempvar;
  1089.       tree args;
  1090.       tree newlen;
  1091.  
  1092.       assert (ffecom_pending_calls_ != 0);
  1093.       tempvar = ffecom_push_tempvar (char_type_node,
  1094.                      ffebld_size (expr), -1, TRUE);
  1095.       tempvar = ffecom_1 (ADDR_EXPR,
  1096.                   build_pointer_type (TREE_TYPE (tempvar)),
  1097.                   tempvar);
  1098.  
  1099.       newlen = build_int_2 (ffebld_size (expr), 0);
  1100.       TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
  1101.  
  1102.       args = build_tree_list (NULL_TREE, tempvar);
  1103.       TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
  1104.       TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
  1105.       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
  1106.         = build_tree_list (NULL_TREE, *length);
  1107.  
  1108.       item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args);
  1109.       TREE_SIDE_EFFECTS (item) = 1;
  1110.       item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
  1111.                tempvar);
  1112.       *length = newlen;
  1113.     }
  1114.       else
  1115.     {            /* Just truncate the length. */
  1116.       *length = build_int_2 (ffebld_size (expr), 0);
  1117.       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
  1118.     }
  1119.       break;
  1120.  
  1121.     default:
  1122.       assert ("bad op for single char arg expr" == NULL);
  1123.       item = NULL_TREE;
  1124.       break;
  1125.     }
  1126.  
  1127.   *xitem = item;
  1128. }
  1129.  
  1130. #endif
  1131. /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
  1132.    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
  1133.    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
  1134.  
  1135. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  1136. static tree
  1137. ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
  1138. {
  1139.   ffetargetCharacterSize sz = ffesymbol_size (s);
  1140.   tree highval;
  1141.   tree tlen;
  1142.   tree type = *xtype;
  1143.  
  1144.   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
  1145.     tlen = NULL_TREE;        /* A statement function, no length passed. */
  1146.   else
  1147.     {
  1148.       tlen = ffecom_get_invented_identifier ("__g77_length_%s",
  1149.                          ffesymbol_text (s), 0);
  1150.       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
  1151.     }
  1152.  
  1153.   if (sz == FFETARGET_charactersizeNONE)
  1154.     {
  1155.       assert (tlen != NULL_TREE);
  1156.       highval = tlen;
  1157.     }
  1158.   else
  1159.     {
  1160.       highval = build_int_2 (sz, 0);
  1161.       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
  1162.     }
  1163.  
  1164.   type = build_array_type (type,
  1165.                build_range_type (ffecom_f2c_ftnlen_type_node,
  1166.                          ffecom_f2c_ftnlen_one_node,
  1167.                          highval));
  1168.  
  1169.   *xtype = type;
  1170.   return tlen;
  1171. }
  1172.  
  1173. #endif
  1174. /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
  1175.  
  1176.    ffecomConcatList_ catlist;
  1177.    ffebld expr;     // expr of CHARACTER basictype.
  1178.    ffetargetCharacterSize max;    // max chars to gather or _...NONE if no max
  1179.    catlist = ffecom_concat_list_gather_(catlist,expr,max);
  1180.  
  1181.    Scans expr for character subexpressions, updates and returns catlist
  1182.    accordingly.     */
  1183.  
  1184. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  1185. static ffecomConcatList_
  1186. ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
  1187.                 ffetargetCharacterSize max)
  1188. {
  1189.   ffetargetCharacterSize sz;
  1190.  
  1191. recurse:            /* :::::::::::::::::::: */
  1192.  
  1193.   if (expr == NULL)
  1194.     return catlist;
  1195.  
  1196.   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
  1197.     return catlist;        /* Don't append any more items. */
  1198.  
  1199.   switch (ffebld_op (expr))
  1200.     {
  1201.     case FFEBLD_opCONTER:
  1202.     case FFEBLD_opSYMTER:
  1203.     case FFEBLD_opARRAYREF:
  1204.     case FFEBLD_opFUNCREF:
  1205.     case FFEBLD_opSUBSTR:
  1206.     case FFEBLD_opCONVERT:    /* Callers should strip this off beforehand
  1207.                    if they don't need to preserve it. */
  1208.       if (catlist.count == catlist.max)
  1209.     {            /* Make a (larger) list. */
  1210.       ffebld *newx;
  1211.       int newmax;
  1212.  
  1213.       newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
  1214.       newx = malloc_new_ks (malloc_pool_image (), "catlist",
  1215.                 newmax * sizeof (newx[0]));
  1216.       if (catlist.max != 0)
  1217.         {
  1218.           memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
  1219.           malloc_kill_ks (malloc_pool_image (), catlist.exprs,
  1220.                   catlist.max * sizeof (newx[0]));
  1221.         }
  1222.       catlist.max = newmax;
  1223.       catlist.exprs = newx;
  1224.     }
  1225.       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
  1226.     catlist.minlen += sz;
  1227.       else
  1228.     ++catlist.minlen;    /* Not true for F90; can be 0 length. */
  1229.       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
  1230.     catlist.maxlen = sz;
  1231.       else
  1232.     catlist.maxlen += sz;
  1233.       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
  1234.     {            /* This item overlaps (or is beyond) the end
  1235.                    of the destination. */
  1236.       switch (ffebld_op (expr))
  1237.         {
  1238.         case FFEBLD_opCONTER:
  1239.         case FFEBLD_opSYMTER:
  1240.         case FFEBLD_opARRAYREF:
  1241.         case FFEBLD_opFUNCREF:
  1242.         case FFEBLD_opSUBSTR:
  1243.           break;        /* ~~Do useful truncations here. */
  1244.  
  1245.         default:
  1246.           assert ("op changed or inconsistent switches!" == NULL);
  1247.           break;
  1248.         }
  1249.     }
  1250.       catlist.exprs[catlist.count++] = expr;
  1251.       return catlist;
  1252.  
  1253.     case FFEBLD_opPAREN:
  1254.       expr = ffebld_left (expr);
  1255.       goto recurse;        /* :::::::::::::::::::: */
  1256.  
  1257.     case FFEBLD_opCONCATENATE:
  1258.       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
  1259.       expr = ffebld_right (expr);
  1260.       goto recurse;        /* :::::::::::::::::::: */
  1261.  
  1262. #if 0                /* Breaks passing small actual arg to larger
  1263.                    dummy arg of sfunc */
  1264.     case FFEBLD_opCONVERT:
  1265.       expr = ffebld_left (expr);
  1266.       {
  1267.     ffetargetCharacterSize cmax;
  1268.  
  1269.     cmax = catlist.len + ffebld_size_known (expr);
  1270.  
  1271.     if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
  1272.       max = cmax;
  1273.       }
  1274.       goto recurse;        /* :::::::::::::::::::: */
  1275. #endif
  1276.  
  1277.     case FFEBLD_opANY:
  1278.       return catlist;
  1279.  
  1280.     default:
  1281.       assert ("bad op in _gather_" == NULL);
  1282.       return catlist;
  1283.     }
  1284. }
  1285.  
  1286. #endif
  1287. /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
  1288.  
  1289.    ffecomConcatList_ catlist;
  1290.    ffecom_concat_list_kill_(catlist);
  1291.  
  1292.    Anything allocated within the list info is deallocated.  */
  1293.  
  1294. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  1295. static void
  1296. ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
  1297. {
  1298.   if (catlist.max != 0)
  1299.     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
  1300.             catlist.max * sizeof (catlist.exprs[0]));
  1301. }
  1302.  
  1303. #endif
  1304. /* ffecom_concat_list_new_ -- Make list of concatenated string exprs
  1305.  
  1306.    ffecomConcatList_ catlist;
  1307.    ffebld expr;     // Root expr of CHARACTER basictype.
  1308.    ffetargetCharacterSize max;    // max chars to gather or _...NONE if no max
  1309.    catlist = ffecom_concat_list_new_(expr,max);
  1310.  
  1311.    Returns a flattened list of concatenated subexpressions given a
  1312.    tree of such expressions.  */
  1313.  
  1314. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  1315. static ffecomConcatList_
  1316. ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
  1317. {
  1318.   ffecomConcatList_ catlist;
  1319.  
  1320.   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
  1321.   return ffecom_concat_list_gather_ (catlist, expr, max);
  1322. }
  1323.  
  1324. #endif
  1325. /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
  1326.  
  1327.    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
  1328.    int i;  // entry# for this entrypoint (used by master fn)
  1329.    ffecom_do_entrypoint_(s,i);
  1330.  
  1331.    Makes a public entry point that calls our private master fn (already
  1332.    compiled).  */
  1333.  
  1334. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  1335. static void
  1336. ffecom_do_entry_ (ffesymbol fn, int entrynum)
  1337. {
  1338.   ffebld item;
  1339.   tree type;            /* Type of function. */
  1340.   tree multi_retval;        /* Var holding return value (union). */
  1341.   tree result;            /* Var holding result. */
  1342.   ffeinfoBasictype bt;
  1343.   ffeinfoKindtype kt;
  1344.   bool charfunc;        /* All entry points return same type
  1345.                    CHARACTER. */
  1346.   bool cmplxfunc;        /* Use f2c way of returning COMPLEX. */
  1347.   bool multi;            /* Master fn has multiple return types. */
  1348.   bool altreturning = FALSE;    /* This entry point has alternate returns. */
  1349.   int yes;
  1350.  
  1351.   /* c-parse.y indeed does call suspend_momentary and not only ignores the
  1352.      return value, but also never calls resume_momentary, when starting an
  1353.      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
  1354.      same thing.  It shouldn't be a problem since start_function calls
  1355.      temporary_allocation, but it might be necessary.  If it causes a problem
  1356.      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
  1357.      comment appears twice in thist file.  */
  1358.  
  1359.   suspend_momentary ();
  1360.  
  1361.   ffecom_doing_entry_ = TRUE;    /* Don't bother with array dimensions. */
  1362.  
  1363.   switch (ffecom_primary_entry_kind_)
  1364.     {
  1365.     case FFEINFO_kindFUNCTION:
  1366.  
  1367.       /* Determine actual return type for function. */
  1368.  
  1369.       bt = ffesymbol_basictype (fn);
  1370.       kt = ffesymbol_kindtype (fn);
  1371.       if (bt == FFEINFO_basictypeNONE)
  1372.     {
  1373.       ffeimplic_establish_symbol (fn);
  1374.       if (ffesymbol_funcresult (fn) != NULL)
  1375.         ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
  1376.       bt = ffesymbol_basictype (fn);
  1377.       kt = ffesymbol_kindtype (fn);
  1378.     }
  1379.  
  1380.       if (bt == FFEINFO_basictypeCHARACTER)
  1381.     charfunc = TRUE, cmplxfunc = FALSE;
  1382.       else if ((bt == FFEINFO_basictypeCOMPLEX)
  1383.            && ffesymbol_is_f2c (fn))
  1384.     charfunc = FALSE, cmplxfunc = TRUE;
  1385.       else
  1386.     charfunc = cmplxfunc = FALSE;
  1387.  
  1388.       if (charfunc)
  1389.     type = ffecom_tree_fun_type_void;
  1390.       else if (ffesymbol_is_f2c (fn))
  1391.     type = ffecom_tree_fun_type[bt][kt];
  1392.       else
  1393.     type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
  1394.  
  1395.       if ((type == NULL_TREE)
  1396.       || (TREE_TYPE (type) == NULL_TREE))
  1397.     type = ffecom_tree_fun_type_void;    /* _sym_exec_transition. */
  1398.  
  1399.       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
  1400.       break;
  1401.  
  1402.     case FFEINFO_kindSUBROUTINE:
  1403.       bt = FFEINFO_basictypeNONE;
  1404.       kt = FFEINFO_kindtypeNONE;
  1405.       if (ffecom_is_altreturning_)
  1406.     {            /* Am _I_ altreturning? */
  1407.       for (item = ffesymbol_dummyargs (fn);
  1408.            item != NULL;
  1409.            item = ffebld_trail (item))
  1410.         {
  1411.           if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
  1412.         {
  1413.           altreturning = TRUE;
  1414.           break;
  1415.         }
  1416.         }
  1417.       if (altreturning)
  1418.         type = ffecom_tree_subr_type;
  1419.       else
  1420.         type = ffecom_tree_fun_type_void;
  1421.     }
  1422.       else
  1423.     type = ffecom_tree_fun_type_void;
  1424.       charfunc = FALSE;
  1425.       cmplxfunc = FALSE;
  1426.       multi = FALSE;
  1427.       break;
  1428.  
  1429.     default:
  1430.       assert ("say what??" == NULL);
  1431.       /* Fall through. */
  1432.     case FFEINFO_kindANY:
  1433.       bt = FFEINFO_basictypeNONE;
  1434.       kt = FFEINFO_kindtypeNONE;
  1435.       type = error_mark_node;
  1436.       charfunc = FALSE;
  1437.       cmplxfunc = FALSE;
  1438.       multi = FALSE;
  1439.       break;
  1440.     }
  1441.  
  1442.   /* build_decl uses the current lineno and input_filename to set the decl
  1443.      source info.  So, I've putzed with ffestd and ffeste code to update that
  1444.      source info to point to the appropriate statement just before calling
  1445.      ffecom_do_entrypoint (which calls this fn).  */
  1446.  
  1447.   start_function (ffecom_get_external_identifier_ (ffesymbol_text (fn)),
  1448.           type,
  1449.           0,        /* nested/inline */
  1450.           1);        /* TREE_PUBLIC */
  1451.  
  1452.   /* Reset args in master arg list so they get retransitioned. */
  1453.  
  1454.   for (item = ffecom_master_arglist_;
  1455.        item != NULL;
  1456.        item = ffebld_trail (item))
  1457.     {
  1458.       ffebld arg;
  1459.       ffesymbol s;
  1460.  
  1461.       arg = ffebld_head (item);
  1462.       if (ffebld_op (arg) != FFEBLD_opSYMTER)
  1463.     continue;        /* Alternate return or some such thing. */
  1464.       s = ffebld_symter (arg);
  1465.       ffesymbol_hook (s).decl_tree = NULL_TREE;
  1466.       ffesymbol_hook (s).length_tree = NULL_TREE;
  1467.     }
  1468.  
  1469.   /* Build dummy arg list for this entry point. */
  1470.  
  1471.   yes = suspend_momentary ();
  1472.  
  1473.   if (charfunc || cmplxfunc)
  1474.     {                /* Prepend arg for where result goes. */
  1475.       tree type;
  1476.       tree length;
  1477.  
  1478.       if (charfunc)
  1479.     type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
  1480.       else
  1481.     type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
  1482.  
  1483.       result = ffecom_get_invented_identifier ("__g77_result_%s",
  1484.                            ffesymbol_text (fn), 0);
  1485.  
  1486.       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
  1487.  
  1488.       if (charfunc)
  1489.     length = ffecom_char_enhance_arg_ (&type, fn);
  1490.       else
  1491.     length = NULL_TREE;    /* Not ref'd if !charfunc. */
  1492.  
  1493.       type = build_pointer_type (type);
  1494.       result = build_decl (PARM_DECL, result, type);
  1495.  
  1496.       push_parm_decl (result);
  1497.       ffecom_func_result_ = result;
  1498.  
  1499.       if (charfunc)
  1500.     {
  1501.       push_parm_decl (length);
  1502.       ffecom_func_length_ = length;
  1503.     }
  1504.     }
  1505.   else
  1506.     result = DECL_RESULT (current_function_decl);
  1507.  
  1508.   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
  1509.  
  1510.   resume_momentary (yes);
  1511.  
  1512.   store_parm_decls (0);
  1513.  
  1514.   ffecom_start_compstmt_ ();
  1515.  
  1516.   /* Make local var to hold return type for multi-type master fn. */
  1517.  
  1518.   if (multi)
  1519.     {
  1520.       yes = suspend_momentary ();
  1521.  
  1522.       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
  1523.                              "multi_retval", 0);
  1524.       multi_retval = build_decl (VAR_DECL, multi_retval,
  1525.                  ffecom_multi_type_node_);
  1526.       multi_retval = start_decl (multi_retval, FALSE);
  1527.       finish_decl (multi_retval, NULL_TREE, FALSE);
  1528.  
  1529.       resume_momentary (yes);
  1530.     }
  1531.   else
  1532.     multi_retval = NULL_TREE;    /* Not actually ref'd if !multi. */
  1533.  
  1534.   /* Here we emit the actual code for the entry point. */
  1535.  
  1536.   {
  1537.     ffebld list;
  1538.     ffebld arg;
  1539.     ffesymbol s;
  1540.     tree arglist = NULL_TREE;
  1541.     tree *plist = &arglist;
  1542.     tree prepend;
  1543.     tree call;
  1544.     tree actarg;
  1545.     tree master_fn;
  1546.  
  1547.     /* Prepare actual arg list based on master arg list. */
  1548.  
  1549.     for (list = ffecom_master_arglist_;
  1550.      list != NULL;
  1551.      list = ffebld_trail (list))
  1552.       {
  1553.     arg = ffebld_head (list);
  1554.     if (ffebld_op (arg) != FFEBLD_opSYMTER)
  1555.       continue;
  1556.     s = ffebld_symter (arg);
  1557.     if (ffesymbol_hook (s).decl_tree == NULL_TREE)
  1558.       actarg = null_pointer_node;    /* We don't have this arg. */
  1559.     else
  1560.       actarg = ffesymbol_hook (s).decl_tree;
  1561.     *plist = build_tree_list (NULL_TREE, actarg);
  1562.     plist = &TREE_CHAIN (*plist);
  1563.       }
  1564.  
  1565.     /* This code appends the length arguments for character
  1566.        variables/arrays.  */
  1567.  
  1568.     for (list = ffecom_master_arglist_;
  1569.      list != NULL;
  1570.      list = ffebld_trail (list))
  1571.       {
  1572.     arg = ffebld_head (list);
  1573.     if (ffebld_op (arg) != FFEBLD_opSYMTER)
  1574.       continue;
  1575.     s = ffebld_symter (arg);
  1576.     if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
  1577.       continue;        /* Only looking for CHARACTER arguments. */
  1578.     if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
  1579.       continue;        /* Only looking for variables and arrays. */
  1580.     if (ffesymbol_hook (s).length_tree == NULL_TREE)
  1581.       actarg = ffecom_f2c_ftnlen_zero_node;    /* We don't have this arg. */
  1582.     else
  1583.       actarg = ffesymbol_hook (s).length_tree;
  1584.     *plist = build_tree_list (NULL_TREE, actarg);
  1585.     plist = &TREE_CHAIN (*plist);
  1586.       }
  1587.  
  1588.     /* Prepend character-value return info to actual arg list. */
  1589.  
  1590.     if (charfunc)
  1591.       {
  1592.     prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
  1593.     TREE_CHAIN (prepend)
  1594.       = build_tree_list (NULL_TREE, ffecom_func_length_);
  1595.     TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
  1596.     arglist = prepend;
  1597.       }
  1598.  
  1599.     /* Prepend multi-type return value to actual arg list. */
  1600.  
  1601.     if (multi)
  1602.       {
  1603.     prepend
  1604.       = build_tree_list (NULL_TREE,
  1605.                  ffecom_1 (ADDR_EXPR,
  1606.                   build_pointer_type (TREE_TYPE (multi_retval)),
  1607.                        multi_retval));
  1608.     TREE_CHAIN (prepend) = arglist;
  1609.     arglist = prepend;
  1610.       }
  1611.  
  1612.     /* Prepend my entry-point number to the actual arg list. */
  1613.  
  1614.     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
  1615.     TREE_CHAIN (prepend) = arglist;
  1616.     arglist = prepend;
  1617.  
  1618.     /* Build the call to the master function. */
  1619.  
  1620.     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
  1621.     call = ffecom_3s (CALL_EXPR,
  1622.               TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
  1623.               master_fn, arglist, NULL_TREE);
  1624.  
  1625.     /* Decide whether the master function is a function or subroutine, and
  1626.        handle the return value for my entry point. */
  1627.  
  1628.     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
  1629.              && !altreturning))
  1630.       {
  1631.     expand_expr_stmt (call);
  1632.     expand_null_return ();
  1633.       }
  1634.     else if (multi && cmplxfunc)
  1635.       {
  1636.     expand_expr_stmt (call);
  1637.     result
  1638.       = ffecom_1 (INDIRECT_REF,
  1639.               TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
  1640.               result);
  1641.     result = ffecom_modify (NULL_TREE, result,
  1642.                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
  1643.                       multi_retval,
  1644.                       ffecom_multi_fields_[bt][kt]));
  1645.     expand_expr_stmt (result);
  1646.     expand_null_return ();
  1647.       }
  1648.     else if (multi)
  1649.       {
  1650.     expand_expr_stmt (call);
  1651.     result
  1652.       = ffecom_modify (NULL_TREE, result,
  1653.                convert (TREE_TYPE (result),
  1654.                     ffecom_2 (COMPONENT_REF,
  1655.                           ffecom_tree_type[bt][kt],
  1656.                           multi_retval,
  1657.                           ffecom_multi_fields_[bt][kt])));
  1658.     expand_return (result);
  1659.       }
  1660.     else if (cmplxfunc)
  1661.       {
  1662.     result
  1663.       = ffecom_1 (INDIRECT_REF,
  1664.               TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
  1665.               result);
  1666.     result = ffecom_modify (NULL_TREE, result, call);
  1667.     expand_expr_stmt (result);
  1668.     expand_null_return ();
  1669.       }
  1670.     else
  1671.       {
  1672.     result = ffecom_modify (NULL_TREE,
  1673.                 result,
  1674.                 convert (TREE_TYPE (result),
  1675.                      call));
  1676.     expand_return (result);
  1677.       }
  1678.  
  1679.     clear_momentary ();
  1680.   }
  1681.  
  1682.   ffecom_end_compstmt_ ();
  1683.  
  1684.   finish_function (0);
  1685.  
  1686.   ffecom_doing_entry_ = FALSE;
  1687. }
  1688.  
  1689. #endif
  1690. /* Transform expr into gcc tree with possible destination
  1691.  
  1692.    Recursive descent on expr while making corresponding tree nodes and
  1693.    attaching type info and such.  If destination supplied and compatible
  1694.    with temporary that would be made in certain cases, temporary isn't
  1695.    made, destination used instead, and dest_used flag set TRUE.  */
  1696.  
  1697. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  1698. static tree
  1699. ffecom_expr_ (ffebld expr, tree dest_tree,
  1700.           ffeinfo dest_info, bool *dest_used,
  1701.           bool assignp)
  1702. {
  1703.   tree item;
  1704.   tree list;
  1705.   tree args;
  1706.   ffeinfoBasictype bt;
  1707.   ffeinfoKindtype kt;
  1708.   tree t;
  1709.   tree tree_type;
  1710.   tree dt;            /* decl_tree for an ffesymbol. */
  1711.   ffesymbol s;
  1712.   enum tree_code code;
  1713.  
  1714.   assert (expr != NULL);
  1715.  
  1716.   if (dest_used != NULL)
  1717.     *dest_used = FALSE;
  1718.  
  1719.   bt = ffeinfo_basictype (ffebld_info (expr));
  1720.   kt = ffeinfo_kindtype (ffebld_info (expr));
  1721.  
  1722.   switch (ffebld_op (expr))
  1723.     {
  1724.     case FFEBLD_opARRTER:
  1725.       tree_type = ffecom_tree_type[bt][kt];
  1726.       {
  1727.     ffetargetOffset i;
  1728.  
  1729.     list = item = NULL;
  1730.     for (i = 0; i < ffebld_arrter_size (expr); ++i)
  1731.       {
  1732.         ffebldConstantUnion cu
  1733.         = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
  1734.  
  1735.         t = ffecom_constantunion (&cu, bt, kt, tree_type);
  1736.  
  1737.         if (list == NULL)
  1738.           list = item = build_tree_list (NULL_TREE, t);
  1739.         else
  1740.           {
  1741.         TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
  1742.         item = TREE_CHAIN (item);
  1743.           }
  1744.       }
  1745.       }
  1746.  
  1747.       item
  1748.     = build_array_type
  1749.       (tree_type,
  1750.        build_range_type (ffecom_integer_type_node,
  1751.                  ffecom_integer_one_node,
  1752.                  convert (ffecom_integer_type_node,
  1753.                       build_int_2 (ffebld_arrter_size
  1754.                            (expr),
  1755.                            0))));
  1756.       list = build (CONSTRUCTOR, item, NULL_TREE, list);
  1757.       TREE_CONSTANT (list) = 1;
  1758.       TREE_STATIC (list) = 1;
  1759.       return list;
  1760.  
  1761.     case FFEBLD_opCONTER:
  1762.       tree_type = ffecom_tree_type[bt][kt];
  1763.       item
  1764.     = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
  1765.                 bt, kt, tree_type);
  1766.       return item;
  1767.  
  1768.     case FFEBLD_opSYMTER:
  1769.       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
  1770.       || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
  1771.     return ffecom_ptr_to_expr (expr);    /* Same as %REF(intrinsic). */
  1772.       s = ffebld_symter (expr);
  1773.       if (assignp)
  1774.     {            /* ASSIGN'ed-label expr. */
  1775.       t = ffesymbol_hook (s).length_tree;
  1776.       if (t == NULL_TREE)
  1777.         {
  1778.           s = ffecom_sym_transform_assign_ (s);
  1779.           t = ffesymbol_hook (s).length_tree;
  1780.           assert (t != NULL_TREE);
  1781.         }
  1782.     }
  1783.       else
  1784.     {
  1785.       t = ffesymbol_hook (s).decl_tree;
  1786.       if (t == NULL_TREE)
  1787.         {
  1788.           s = ffecom_sym_transform_ (s);
  1789.           t = ffesymbol_hook (s).decl_tree;
  1790.           assert (t != NULL_TREE);
  1791.         }
  1792.       if (ffesymbol_hook (s).addr)
  1793.         t = ffecom_1 (INDIRECT_REF,
  1794.               TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
  1795.     }
  1796.       return t;
  1797.  
  1798.     case FFEBLD_opARRAYREF:
  1799.       {
  1800.     ffebld dims[FFECOM_dimensionsMAX];
  1801. #if FFECOM_FASTER_ARRAY_REFS
  1802.     tree array;
  1803. #endif
  1804.     int i;
  1805.  
  1806. #if FFECOM_FASTER_ARRAY_REFS
  1807.     t = ffecom_ptr_to_expr (ffebld_left (expr));
  1808. #else
  1809.     t = ffecom_expr (ffebld_left (expr));
  1810. #endif
  1811.     if (t == error_mark_node)
  1812.       return t;
  1813.  
  1814.     if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING)
  1815.         && !mark_addressable (t))
  1816.       return error_mark_node;    /* Make sure non-const ref is to
  1817.                        non-reg. */
  1818.  
  1819.     /* Build up ARRAY_REFs in reverse order (since we're column major
  1820.        here in Fortran land). */
  1821.  
  1822.     for (i = 0, expr = ffebld_right (expr);
  1823.          expr != NULL;
  1824.          expr = ffebld_trail (expr))
  1825.       dims[i++] = ffebld_head (expr);
  1826.  
  1827. #if FFECOM_FASTER_ARRAY_REFS
  1828.     for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t)));
  1829.          i >= 0;
  1830.          --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
  1831.       t
  1832.         = ffecom_2 (PLUS_EXPR,
  1833.             build_pointer_type (TREE_TYPE (array)),
  1834.             t,
  1835.             size_binop (MULT_EXPR,
  1836.                     size_in_bytes (TREE_TYPE (array)),
  1837.                     size_binop (MINUS_EXPR,
  1838.                         ffecom_expr (dims[i]),
  1839.                         TYPE_MIN_VALUE (TYPE_DOMAIN (array)))));
  1840.     t = ffecom_1 (INDIRECT_REF,
  1841.               TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))),
  1842.               t);
  1843. #else
  1844.     while (i > 0)
  1845.       t = ffecom_2 (ARRAY_REF,
  1846.             TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))),
  1847.             t,
  1848.             ffecom_expr (dims[--i]));
  1849. #endif
  1850.  
  1851.     return t;
  1852.       }
  1853.  
  1854.     case FFEBLD_opUPLUS:
  1855.       tree_type = ffecom_tree_type[bt][kt];
  1856.       return ffecom_1 (NOP_EXPR, tree_type, ffecom_expr (ffebld_left (expr)));
  1857.  
  1858.     case FFEBLD_opPAREN:    /* ~~~Make sure Fortran rules respected here */
  1859.       tree_type = ffecom_tree_type[bt][kt];
  1860.       return ffecom_1 (NOP_EXPR, tree_type, ffecom_expr (ffebld_left (expr)));
  1861.  
  1862.     case FFEBLD_opUMINUS:
  1863.       tree_type = ffecom_tree_type[bt][kt];
  1864.       return ffecom_1 (NEGATE_EXPR, tree_type,
  1865.                ffecom_expr (ffebld_left (expr)));
  1866.  
  1867.     case FFEBLD_opADD:
  1868.       tree_type = ffecom_tree_type[bt][kt];
  1869.       return ffecom_2 (PLUS_EXPR, tree_type,
  1870.                ffecom_expr (ffebld_left (expr)),
  1871.                ffecom_expr (ffebld_right (expr)));
  1872.       break;
  1873.  
  1874.     case FFEBLD_opSUBTRACT:
  1875.       tree_type = ffecom_tree_type[bt][kt];
  1876.       return ffecom_2 (MINUS_EXPR, tree_type,
  1877.                ffecom_expr (ffebld_left (expr)),
  1878.                ffecom_expr (ffebld_right (expr)));
  1879.  
  1880.     case FFEBLD_opMULTIPLY:
  1881.       tree_type = ffecom_tree_type[bt][kt];
  1882.       return ffecom_2 (MULT_EXPR, tree_type,
  1883.                ffecom_expr (ffebld_left (expr)),
  1884.                ffecom_expr (ffebld_right (expr)));
  1885.  
  1886.     case FFEBLD_opDIVIDE:
  1887.       tree_type = ffecom_tree_type[bt][kt];
  1888.       return
  1889.     ffecom_tree_divide_ (tree_type,
  1890.                  ffecom_expr (ffebld_left (expr)),
  1891.                  ffecom_expr (ffebld_right (expr)),
  1892.                  dest_tree, dest_info, dest_used);
  1893.  
  1894.     case FFEBLD_opPOWER:
  1895.       tree_type = ffecom_tree_type[bt][kt];
  1896.       {
  1897.     ffebld left = ffebld_left (expr);
  1898.     ffebld right = ffebld_right (expr);
  1899.     ffecomGfrt code;
  1900.  
  1901.     switch (ffeinfo_basictype (ffebld_info (right)))
  1902.       {
  1903.       case FFEINFO_basictypeINTEGER:
  1904.         if (1 || optimize)
  1905.           return ffecom_expr_power_integer_ (left, right);
  1906.  
  1907.         switch (ffeinfo_basictype (ffebld_info (left)))
  1908.           {
  1909.           case FFEINFO_basictypeINTEGER:
  1910.         code = FFECOM_gfrtPOW_II;
  1911.         break;
  1912.  
  1913.           case FFEINFO_basictypeREAL:
  1914.         if (ffeinfo_kindtype (ffebld_info (left))
  1915.             == FFEINFO_kindtypeREAL1)
  1916.           code = FFECOM_gfrtPOW_RI;
  1917.         else
  1918.           code = FFECOM_gfrtPOW_DI;
  1919.         break;
  1920.  
  1921.           case FFEINFO_basictypeCOMPLEX:
  1922.         if (ffeinfo_kindtype (ffebld_info (left))
  1923.             == FFEINFO_kindtypeREAL1)
  1924.           code = FFECOM_gfrtPOW_CI;
  1925.         else
  1926.           code = FFECOM_gfrtPOW_ZI;
  1927.         break;
  1928.  
  1929.           default:
  1930.         assert ("bad pow_*i" == NULL);
  1931.         code = FFECOM_gfrtPOW_CI;
  1932.         break;
  1933.           }
  1934.         break;
  1935.  
  1936.       case FFEINFO_basictypeREAL:
  1937.         if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
  1938.           left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
  1939.                       FFEINFO_kindtypeREALDOUBLE, 0,
  1940.                       FFETARGET_charactersizeNONE,
  1941.                       FFEEXPR_contextLET);
  1942.         if (ffeinfo_kindtype (ffebld_info (right))
  1943.         == FFEINFO_kindtypeREAL1)
  1944.           right = ffeexpr_convert (right, NULL, NULL,
  1945.                        FFEINFO_basictypeREAL,
  1946.                        FFEINFO_kindtypeREALDOUBLE, 0,
  1947.                        FFETARGET_charactersizeNONE,
  1948.                        FFEEXPR_contextLET);
  1949.         code = FFECOM_gfrtPOW_DD;
  1950.         break;
  1951.  
  1952.       case FFEINFO_basictypeCOMPLEX:
  1953.         if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
  1954.           left = ffeexpr_convert (left, NULL, NULL,
  1955.                       FFEINFO_basictypeCOMPLEX,
  1956.                       FFEINFO_kindtypeREALDOUBLE, 0,
  1957.                       FFETARGET_charactersizeNONE,
  1958.                       FFEEXPR_contextLET);
  1959.         if (ffeinfo_kindtype (ffebld_info (right))
  1960.         == FFEINFO_kindtypeREAL1)
  1961.           right = ffeexpr_convert (right, NULL, NULL,
  1962.                        FFEINFO_basictypeCOMPLEX,
  1963.                        FFEINFO_kindtypeREALDOUBLE, 0,
  1964.                        FFETARGET_charactersizeNONE,
  1965.                        FFEEXPR_contextLET);
  1966.         code = FFECOM_gfrtPOW_ZZ;
  1967.         break;
  1968.  
  1969.       default:
  1970.         assert ("bad pow_x*" == NULL);
  1971.         code = FFECOM_gfrtPOW_II;
  1972.         break;
  1973.       }
  1974.     return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
  1975.                    ffecom_gfrt_kind_type_ (code),
  1976.                    ffe_is_f2c_library ()
  1977.                    && ffecom_gfrt_complex_[code],
  1978.                    tree_type, left, right,
  1979.                    dest_tree, dest_info, dest_used);
  1980.       }
  1981.  
  1982.     case FFEBLD_opNOT:
  1983.       tree_type = ffecom_tree_type[bt][kt];
  1984.       switch (bt)
  1985.     {
  1986.     case FFEINFO_basictypeLOGICAL:
  1987.       item = ffecom_2 (EQ_EXPR, integer_type_node,
  1988.                ffecom_expr (ffebld_left (expr)),
  1989.                convert (tree_type, integer_zero_node));
  1990.       return convert (tree_type, item);
  1991.  
  1992.     case FFEINFO_basictypeINTEGER:
  1993.       return ffecom_1 (BIT_NOT_EXPR, tree_type,
  1994.                ffecom_expr (ffebld_left (expr)));
  1995.  
  1996.     default:
  1997.       assert ("NOT bad basictype" == NULL);
  1998.       /* Fall through. */
  1999.     case FFEINFO_basictypeANY:
  2000.       return error_mark_node;
  2001.     }
  2002.       break;
  2003.  
  2004.     case FFEBLD_opFUNCREF:
  2005.       assert (ffeinfo_basictype (ffebld_info (expr))
  2006.           != FFEINFO_basictypeCHARACTER);
  2007.       /* Fall through.     */
  2008.     case FFEBLD_opSUBRREF:
  2009.       tree_type = ffecom_tree_type[bt][kt];
  2010.       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
  2011.       == FFEINFO_whereINTRINSIC)
  2012.     {            /* Invocation of an intrinsic. */
  2013.       item = ffecom_expr_intrinsic_ (expr, dest_tree, dest_info,
  2014.                      dest_used);
  2015.       return item;
  2016.     }
  2017.       s = ffebld_symter (ffebld_left (expr));
  2018.       dt = ffesymbol_hook (s).decl_tree;
  2019.       if (dt == NULL_TREE)
  2020.     {
  2021.       s = ffecom_sym_transform_ (s);
  2022.       dt = ffesymbol_hook (s).decl_tree;
  2023.     }
  2024.       if (dt == error_mark_node)
  2025.     return dt;
  2026.  
  2027.       if (ffesymbol_hook (s).addr)
  2028.     item = dt;
  2029.       else
  2030.     item = ffecom_1_fn (dt);
  2031.  
  2032.       ffecom_push_calltemps ();
  2033.       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
  2034.     args = ffecom_list_expr (ffebld_right (expr));
  2035.       else
  2036.     args = ffecom_list_ptr_to_expr (ffebld_right (expr));
  2037.       ffecom_pop_calltemps ();
  2038.  
  2039.       item = ffecom_call_ (item, kt,
  2040.                ffesymbol_is_f2c (s)
  2041.                && (bt == FFEINFO_basictypeCOMPLEX)
  2042.                && (ffesymbol_where (s)
  2043.                    != FFEINFO_whereCONSTANT),
  2044.                tree_type,
  2045.                args,
  2046.                dest_tree, dest_info, dest_used);
  2047.       TREE_SIDE_EFFECTS (item) = 1;
  2048.       return item;
  2049.  
  2050.     case FFEBLD_opAND:
  2051.       tree_type = ffecom_tree_type[bt][kt];
  2052.       switch (bt)
  2053.     {
  2054.     case FFEINFO_basictypeLOGICAL:
  2055.       return
  2056.         ffecom_2 (TRUTH_ANDIF_EXPR, tree_type,
  2057.               ffecom_2 (NE_EXPR, tree_type,
  2058.                 ffecom_expr (ffebld_left (expr)),
  2059.                 convert (tree_type, integer_zero_node)),
  2060.               ffecom_2 (NE_EXPR, tree_type,
  2061.                 ffecom_expr (ffebld_right (expr)),
  2062.                 convert (tree_type,
  2063.                      integer_zero_node)));
  2064.  
  2065.     case FFEINFO_basictypeINTEGER:
  2066.       return ffecom_2 (BIT_AND_EXPR, tree_type,
  2067.                ffecom_expr (ffebld_left (expr)),
  2068.                ffecom_expr (ffebld_right (expr)));
  2069.  
  2070.     default:
  2071.       assert ("AND bad basictype" == NULL);
  2072.       /* Fall through. */
  2073.     case FFEINFO_basictypeANY:
  2074.       return error_mark_node;
  2075.     }
  2076.       break;
  2077.  
  2078.     case FFEBLD_opOR:
  2079.       tree_type = ffecom_tree_type[bt][kt];
  2080.       switch (bt)
  2081.     {
  2082.     case FFEINFO_basictypeLOGICAL:
  2083.       return
  2084.         ffecom_2 (TRUTH_ORIF_EXPR, tree_type,
  2085.               ffecom_2 (NE_EXPR, tree_type,
  2086.                 ffecom_expr (ffebld_left (expr)),
  2087.                 convert (tree_type, integer_zero_node)),
  2088.               ffecom_2 (NE_EXPR, tree_type,
  2089.                 ffecom_expr (ffebld_right (expr)),
  2090.                 convert (tree_type,
  2091.                      integer_zero_node)));
  2092.  
  2093.     case FFEINFO_basictypeINTEGER:
  2094.       return ffecom_2 (BIT_IOR_EXPR, tree_type,
  2095.                ffecom_expr (ffebld_left (expr)),
  2096.                ffecom_expr (ffebld_right (expr)));
  2097.  
  2098.     default:
  2099.       assert ("OR bad basictype" == NULL);
  2100.       /* Fall through. */
  2101.     case FFEINFO_basictypeANY:
  2102.       return error_mark_node;
  2103.     }
  2104.       break;
  2105.  
  2106.     case FFEBLD_opXOR:
  2107.     case FFEBLD_opNEQV:
  2108.       tree_type = ffecom_tree_type[bt][kt];
  2109.       switch (bt)
  2110.     {
  2111.     case FFEINFO_basictypeLOGICAL:
  2112.       {
  2113.         tree left_tree = ffecom_expr (ffebld_left (expr));
  2114.         tree right_tree = ffecom_expr (ffebld_right (expr));
  2115.  
  2116.         if (left_tree == error_mark_node || right_tree == error_mark_node)
  2117.           return error_mark_node;
  2118.  
  2119.         item
  2120.           = ffecom_2 (BIT_XOR_EXPR, integer_type_node,
  2121.               ffecom_truth_value
  2122.               (ffecom_2 (NE_EXPR,
  2123.                      integer_type_node,
  2124.                      left_tree,
  2125.                      convert (tree_type,
  2126.                           integer_zero_node))),
  2127.               ffecom_truth_value
  2128.               (ffecom_2 (NE_EXPR, integer_type_node,
  2129.                      right_tree,
  2130.                      convert (tree_type,
  2131.                           integer_zero_node))));
  2132.         return convert (tree_type, item);
  2133.       }
  2134.  
  2135.     case FFEINFO_basictypeINTEGER:
  2136.       return ffecom_2 (BIT_XOR_EXPR, tree_type,
  2137.                ffecom_expr (ffebld_left (expr)),
  2138.                ffecom_expr (ffebld_right (expr)));
  2139.  
  2140.     default:
  2141.       assert ("XOR/NEQV bad basictype" == NULL);
  2142.       /* Fall through. */
  2143.     case FFEINFO_basictypeANY:
  2144.       return error_mark_node;
  2145.     }
  2146.       break;
  2147.  
  2148.     case FFEBLD_opEQV:
  2149.       tree_type = ffecom_tree_type[bt][kt];
  2150.       switch (bt)
  2151.     {
  2152.     case FFEINFO_basictypeLOGICAL:
  2153.       {
  2154.         tree left_tree = ffecom_expr (ffebld_left (expr));
  2155.         tree right_tree = ffecom_expr (ffebld_right (expr));
  2156.  
  2157.         if (left_tree == error_mark_node || right_tree == error_mark_node)
  2158.           return error_mark_node;
  2159.  
  2160.         item
  2161.           = ffecom_2 (BIT_XOR_EXPR, integer_type_node,
  2162.               ffecom_2 (EQ_EXPR, integer_type_node,
  2163.                     left_tree,
  2164.                     convert (tree_type,
  2165.                          integer_zero_node)),
  2166.               ffecom_truth_value
  2167.               (ffecom_2 (NE_EXPR, integer_type_node,
  2168.                      right_tree,
  2169.                      convert (tree_type,
  2170.                           integer_zero_node))));
  2171.         return convert (tree_type, item);
  2172.       }
  2173.  
  2174.     case FFEINFO_basictypeINTEGER:
  2175.       {
  2176.         tree left_tree = ffecom_expr (ffebld_left (expr));
  2177.         tree right_tree = ffecom_expr (ffebld_right (expr));
  2178.  
  2179.         if (left_tree == error_mark_node || right_tree == error_mark_node)
  2180.           return error_mark_node;
  2181.  
  2182.         return
  2183.           ffecom_1 (BIT_NOT_EXPR, tree_type,
  2184.             ffecom_2 (BIT_XOR_EXPR, tree_type,
  2185.                   left_tree,
  2186.                   right_tree));
  2187.       }
  2188.  
  2189.     default:
  2190.       assert ("EQV bad basictype" == NULL);
  2191.       /* Fall through. */
  2192.     case FFEINFO_basictypeANY:
  2193.       return error_mark_node;
  2194.     }
  2195.       break;
  2196.  
  2197.     case FFEBLD_opCONVERT:
  2198.       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
  2199.     return error_mark_node;
  2200.  
  2201.       tree_type = ffecom_tree_type[bt][kt];
  2202.       switch (bt)
  2203.     {
  2204.     case FFEINFO_basictypeLOGICAL:
  2205.     case FFEINFO_basictypeINTEGER:
  2206.     case FFEINFO_basictypeREAL:
  2207.       return convert (tree_type, ffecom_expr (ffebld_left (expr)));
  2208.  
  2209.     case FFEINFO_basictypeCOMPLEX:
  2210.       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
  2211.         {
  2212.         case FFEINFO_basictypeINTEGER:
  2213.         case FFEINFO_basictypeLOGICAL:
  2214.         case FFEINFO_basictypeREAL:
  2215.           item = ffecom_expr (ffebld_left (expr));
  2216.           if (item == error_mark_node)
  2217.         return error_mark_node;
  2218.           item = convert (TREE_TYPE (tree_type), item);
  2219.           item = convert (tree_type, item);
  2220.           return item;
  2221.  
  2222.         case FFEINFO_basictypeCOMPLEX:
  2223.           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
  2224.  
  2225.         default:
  2226.           assert ("CONVERT COMPLEX bad basictype" == NULL);
  2227.           /* Fall through. */
  2228.         case FFEINFO_basictypeANY:
  2229.           return error_mark_node;
  2230.         }
  2231.       break;
  2232.  
  2233.     default:
  2234.       assert ("CONVERT bad basictype" == NULL);
  2235.       /* Fall through. */
  2236.     case FFEINFO_basictypeANY:
  2237.       return error_mark_node;
  2238.     }
  2239.       break;
  2240.  
  2241.     case FFEBLD_opLT:
  2242.       code = LT_EXPR;
  2243.       goto relational;        /* :::::::::::::::::::: */
  2244.  
  2245.     case FFEBLD_opLE:
  2246.       code = LE_EXPR;
  2247.       goto relational;        /* :::::::::::::::::::: */
  2248.  
  2249.     case FFEBLD_opEQ:
  2250.       code = EQ_EXPR;
  2251.       goto relational;        /* :::::::::::::::::::: */
  2252.  
  2253.     case FFEBLD_opNE:
  2254.       code = NE_EXPR;
  2255.       goto relational;        /* :::::::::::::::::::: */
  2256.  
  2257.     case FFEBLD_opGT:
  2258.       code = GT_EXPR;
  2259.       goto relational;        /* :::::::::::::::::::: */
  2260.  
  2261.     case FFEBLD_opGE:
  2262.       code = GE_EXPR;
  2263.  
  2264.     relational:        /* :::::::::::::::::::: */
  2265.  
  2266.       tree_type = ffecom_tree_type[bt][kt];
  2267.       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
  2268.     {
  2269.     case FFEINFO_basictypeLOGICAL:
  2270.     case FFEINFO_basictypeINTEGER:
  2271.     case FFEINFO_basictypeREAL:
  2272.       item = ffecom_2 (code, integer_type_node,
  2273.                ffecom_expr (ffebld_left (expr)),
  2274.                ffecom_expr (ffebld_right (expr)));
  2275.       return convert (tree_type, item);
  2276.  
  2277.     case FFEINFO_basictypeCOMPLEX:
  2278.       assert (code == EQ_EXPR || code == NE_EXPR);
  2279.       {
  2280.         tree real_type;
  2281.         tree arg1 = ffecom_expr (ffebld_left (expr));
  2282.         tree arg2 = ffecom_expr (ffebld_right (expr));
  2283.  
  2284.         if (arg1 == error_mark_node || arg2 == error_mark_node)
  2285.           return error_mark_node;
  2286.  
  2287.         arg1 = ffecom_save_tree (arg1);
  2288.         arg2 = ffecom_save_tree (arg2);
  2289.  
  2290.         real_type = TREE_TYPE (TREE_TYPE (arg1));
  2291.         assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
  2292.  
  2293.         item
  2294.           = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
  2295.               ffecom_2 (EQ_EXPR, integer_type_node,
  2296.                   ffecom_1 (REALPART_EXPR, real_type, arg1),
  2297.                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
  2298.               ffecom_2 (EQ_EXPR, integer_type_node,
  2299.                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
  2300.                     ffecom_1 (IMAGPART_EXPR, real_type,
  2301.                           arg2)));
  2302.         if (code == EQ_EXPR)
  2303.           item = ffecom_truth_value (item);
  2304.         else
  2305.           item = ffecom_truth_value_invert (item);
  2306.         return convert (tree_type, item);
  2307.       }
  2308.  
  2309.     case FFEINFO_basictypeCHARACTER:
  2310.       ffecom_push_calltemps ();    /* Even though we might not call. */
  2311.  
  2312.       {
  2313.         ffebld left = ffebld_left (expr);
  2314.         ffebld right = ffebld_right (expr);
  2315.         tree left_tree;
  2316.         tree right_tree;
  2317.         tree left_length;
  2318.         tree right_length;
  2319.  
  2320.         /* f2c run-time functions do the implicit blank-padding for us,
  2321.            so we don't usually have to implement blank-padding ourselves.
  2322.            (The exception is when we pass an argument to a separately
  2323.            compiled statement function -- if we know the arg is not the
  2324.            same length as the dummy, we must truncate or extend it.     If
  2325.            we "inline" statement functions, that necessity goes away as
  2326.            well.)
  2327.  
  2328.            Strip off the CONVERT operators that blank-pad.  (Truncation by
  2329.            CONVERT shouldn't happen here, but it can happen in
  2330.            assignments.) */
  2331.  
  2332.         while (ffebld_op (left) == FFEBLD_opCONVERT)
  2333.           left = ffebld_left (left);
  2334.         while (ffebld_op (right) == FFEBLD_opCONVERT)
  2335.           right = ffebld_left (right);
  2336.  
  2337.         left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
  2338.         right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
  2339.  
  2340.         if (left_tree == error_mark_node || left_length == error_mark_node
  2341.         || right_tree == error_mark_node
  2342.         || right_length == error_mark_node)
  2343.           {
  2344.         ffecom_pop_calltemps ();
  2345.         return error_mark_node;
  2346.           }
  2347.  
  2348.         if ((ffebld_size_known (left) == 1)
  2349.         && (ffebld_size_known (right) == 1))
  2350.           {
  2351.         left_tree
  2352.           = ffecom_1 (INDIRECT_REF,
  2353.               TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
  2354.                   left_tree);
  2355.         right_tree
  2356.           = ffecom_1 (INDIRECT_REF,
  2357.              TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
  2358.                   right_tree);
  2359.  
  2360.         item
  2361.           = ffecom_2 (code, integer_type_node,
  2362.                   ffecom_2 (ARRAY_REF,
  2363.               TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
  2364.                     left_tree,
  2365.                     integer_one_node),
  2366.                   ffecom_2 (ARRAY_REF,
  2367.              TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
  2368.                     right_tree,
  2369.                     integer_one_node));
  2370.           }
  2371.         else
  2372.           {
  2373.         item = build_tree_list (NULL_TREE, left_tree);
  2374.         TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
  2375.         TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
  2376.                                    left_length);
  2377.         TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
  2378.           = build_tree_list (NULL_TREE, right_length);
  2379.         item = ffecom_call_gfrt (FFECOM_gfrtCMP, item);
  2380.         item = ffecom_2 (code, integer_type_node,
  2381.                  item,
  2382.                  convert (TREE_TYPE (item),
  2383.                       integer_zero_node));
  2384.           }
  2385.         item = convert (tree_type, item);
  2386.       }
  2387.  
  2388.       ffecom_pop_calltemps ();
  2389.       return item;
  2390.  
  2391.     default:
  2392.       assert ("relational bad basictype" == NULL);
  2393.       /* Fall through. */
  2394.     case FFEINFO_basictypeANY:
  2395.       return error_mark_node;
  2396.     }
  2397.       break;
  2398.  
  2399.     case FFEBLD_opPERCENT_LOC:
  2400.       tree_type = ffecom_tree_type[bt][kt];
  2401.       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
  2402.       return convert (tree_type, item);
  2403.  
  2404.     case FFEBLD_opITEM:
  2405.     case FFEBLD_opSTAR:
  2406.     case FFEBLD_opBOUNDS:
  2407.     case FFEBLD_opREPEAT:
  2408.     case FFEBLD_opLABTER:
  2409.     case FFEBLD_opLABTOK:
  2410.     case FFEBLD_opIMPDO:
  2411.     case FFEBLD_opCONCATENATE:
  2412.     case FFEBLD_opSUBSTR:
  2413.     default:
  2414.       assert ("bad op" == NULL);
  2415.       /* Fall through. */
  2416.     case FFEBLD_opANY:
  2417.       return error_mark_node;
  2418.     }
  2419.  
  2420. #if 1
  2421.   assert ("didn't think anything got here anymore!!" == NULL);
  2422. #else
  2423.   switch (ffebld_arity (expr))
  2424.     {
  2425.     case 2:
  2426.       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
  2427.       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
  2428.       if (TREE_OPERAND (item, 0) == error_mark_node
  2429.       || TREE_OPERAND (item, 1) == error_mark_node)
  2430.     return error_mark_node;
  2431.       break;
  2432.  
  2433.     case 1:
  2434.       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
  2435.       if (TREE_OPERAND (item, 0) == error_mark_node)
  2436.     return error_mark_node;
  2437.       break;
  2438.  
  2439.     default:
  2440.       break;
  2441.     }
  2442.  
  2443.   return fold (item);
  2444. #endif
  2445. }
  2446.  
  2447. #endif
  2448. /* Returns the tree that does the intrinsic invocation.     */
  2449.  
  2450. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  2451. static tree
  2452. ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
  2453.             ffeinfo dest_info, bool *dest_used)
  2454. {
  2455.   tree expr_tree;
  2456.   tree saved_expr1;        /* For those who need it. */
  2457.   tree saved_expr2;        /* For those who need it. */
  2458.   ffeinfoBasictype bt;
  2459.   ffeinfoKindtype kt;
  2460.   tree tree_type;
  2461.   tree arg1_type;
  2462.   tree real_type;        /* REAL type corresponding to COMPLEX. */
  2463.   tree tempvar;
  2464.   ffebld list = ffebld_right (expr);    /* List of (some) args. */
  2465.   ffebld arg1;            /* For handy reference. */
  2466.   ffebld arg2;
  2467.   ffebld arg3;
  2468.   ffecomGfrt ix;
  2469.   bool returns_complex = FALSE;
  2470.  
  2471.   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
  2472.  
  2473.   if (dest_used != NULL)
  2474.     *dest_used = FALSE;
  2475.  
  2476.   bt = ffeinfo_basictype (ffebld_info (expr));
  2477.   kt = ffeinfo_kindtype (ffebld_info (expr));
  2478.   tree_type = ffecom_tree_type[bt][kt];
  2479.  
  2480.   if (list != NULL)
  2481.     {
  2482.       arg1 = ffebld_head (list);
  2483.       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
  2484.     return error_mark_node;
  2485.       if ((list = ffebld_trail (list)) != NULL)
  2486.     {
  2487.       arg2 = ffebld_head (list);
  2488.       if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
  2489.         return error_mark_node;
  2490.       if ((list = ffebld_trail (list)) != NULL)
  2491.         {
  2492.           arg3 = ffebld_head (list);
  2493.           if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
  2494.         return error_mark_node;
  2495.         }
  2496.       else
  2497.         arg3 = NULL;
  2498.     }
  2499.       else
  2500.     arg2 = arg3 = NULL;
  2501.     }
  2502.   else
  2503.     arg1 = arg2 = arg3 = NULL;
  2504.  
  2505.   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
  2506.      args.  This is used by the MAX/MIN expansions. */
  2507.  
  2508.   if (arg1 != NULL)
  2509.     arg1_type = ffecom_tree_type
  2510.       [ffeinfo_basictype (ffebld_info (arg1))]
  2511.       [ffeinfo_kindtype (ffebld_info (arg1))];
  2512.   else
  2513.     arg1_type = NULL_TREE;    /* Really not needed, but might catch bugs
  2514.                    here. */
  2515.  
  2516.   /* There are several ways for each of the cases in the following switch
  2517.      statements to exit (from simplest to use to most complicated):
  2518.  
  2519.      break;  (when expr_tree == NULL)
  2520.  
  2521.      A standard call is made to the specific intrinsic just as if it had been
  2522.      passed in as a dummy procedure and called as any old procedure.  This
  2523.      method can produce slower code but in some cases its the easiest way for
  2524.      now.
  2525.  
  2526.      goto library;
  2527.  
  2528.      ix contains the gfrt index of a library function to call, passing the
  2529.      argument(s) by value rather than by reference.
  2530.  
  2531.      return expr_tree;
  2532.  
  2533.      The expr_tree has been completely set up and is ready to be returned as is.
  2534.      No further actions are taken.  Use this when the tree is not in the
  2535.      simple form for one of the arity_n labels.     */
  2536.  
  2537.   /* For info on how the switch statement cases were written, see the files
  2538.      enclosed in comments below the switch statement. */
  2539.  
  2540.   switch (ffebld_symter_implementation (ffebld_left (expr)))
  2541.     {
  2542.     case FFEINTRIN_impNONE:
  2543.       assert ("No specific intrinsic to invoke!" == NULL);
  2544.       break;            /* Use wrapper. */
  2545.  
  2546.     case FFEINTRIN_impABS:
  2547.       /* r__1 = (doublereal)((    r1  ) >= 0 ? (    r1  ) : -(  r1    ))  ; */
  2548.       return ffecom_1 (ABS_EXPR, tree_type, ffecom_expr (arg1));
  2549.  
  2550.     case FFEINTRIN_impACOS:
  2551.       /* r__1 = acos(r1); */
  2552.       ix = FFECOM_gfrtL_ACOS;
  2553.       goto library;        /* :::::::::::::::::::: */
  2554.  
  2555.     case FFEINTRIN_impAIMAG:
  2556.     case FFEINTRIN_impDIMAG:
  2557.       /* r__1 = r_imag(&c1); */
  2558.       return ffecom_1 (IMAGPART_EXPR, tree_type, ffecom_expr (arg1));
  2559.  
  2560.     case FFEINTRIN_impAINT:
  2561.       /* r__1 = r_int(&r1); */
  2562. #if 0                /* ~~ someday implement FIX_TRUNC_EXPR
  2563.                    yielding same type as arg */
  2564.       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
  2565. #else /* in the meantime, must use floor to avoid range problems with ints */
  2566.       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
  2567.       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
  2568.       return
  2569.     convert (tree_type,
  2570.          ffecom_3 (COND_EXPR, double_type_node,
  2571.                ffecom_truth_value
  2572.                (ffecom_2 (GE_EXPR, integer_type_node,
  2573.                       saved_expr1,
  2574.                       ffecom_float_zero_)),
  2575.                ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
  2576.                          build_tree_list (NULL_TREE,
  2577.                           convert (double_type_node,
  2578.                                saved_expr1))),
  2579.                ffecom_1 (NEGATE_EXPR, double_type_node,
  2580.                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
  2581.                          build_tree_list (NULL_TREE,
  2582.                           convert (double_type_node,
  2583.                               ffecom_1 (NEGATE_EXPR,
  2584.                                 tree_type,
  2585.                                  saved_expr1))))
  2586.                ))
  2587.     );
  2588. #endif
  2589.     case FFEINTRIN_impALOG:
  2590.       /* r__1 = log(r1); */
  2591.       ix = FFECOM_gfrtL_LOG;
  2592.       goto library;        /* :::::::::::::::::::: */
  2593.  
  2594.     case FFEINTRIN_impALOG10:
  2595.       /* r__1 = r_lg10(&r1); */
  2596.       break;            /* Use wrapper. */
  2597.  
  2598.     case FFEINTRIN_impAMAX0:
  2599.       /* r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ; */
  2600.       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
  2601.                 ffecom_expr (arg1),
  2602.                 ffecom_expr (arg2));
  2603.       while (list != NULL)
  2604.     {
  2605.       if (ffebld_op (ffebld_head (list)) == FFEBLD_opANY)
  2606.         continue;
  2607.       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
  2608.                 expr_tree,
  2609.                 ffecom_expr (ffebld_head (list)));
  2610.       list = ffebld_trail (list);
  2611.     }
  2612.       return convert (tree_type, expr_tree);
  2613.  
  2614.     case FFEINTRIN_impAMAX1:
  2615.       /* r__1 = (doublereal)((    r1  ) >= (  r2    ) ? (  r1  ) : (  r2  ))  ; */
  2616.       expr_tree = ffecom_2 (MAX_EXPR, tree_type,
  2617.                 ffecom_expr (arg1),
  2618.                 ffecom_expr (arg2));
  2619.       while (list != NULL)
  2620.     {
  2621.       if (ffebld_op (ffebld_head (list)) == FFEBLD_opANY)
  2622.         continue;
  2623.       expr_tree = ffecom_2 (MAX_EXPR, tree_type,
  2624.                 expr_tree,
  2625.                 ffecom_expr (ffebld_head (list)));
  2626.       list = ffebld_trail (list);
  2627.     }
  2628.       return expr_tree;
  2629.  
  2630.     case FFEINTRIN_impAMIN0:
  2631.       /* r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ; */
  2632.       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
  2633.                 ffecom_expr (arg1),
  2634.                 ffecom_expr (arg2));
  2635.       while (list != NULL)
  2636.     {
  2637.       if (ffebld_op (ffebld_head (list)) == FFEBLD_opANY)
  2638.         continue;
  2639.       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
  2640.                 expr_tree,
  2641.                 ffecom_expr (ffebld_head (list)));
  2642.       list = ffebld_trail (list);
  2643.     }
  2644.       return convert (tree_type, expr_tree);
  2645.  
  2646.     case FFEINTRIN_impAMIN1:
  2647.       /* r__1 = (doublereal)((    r1  ) <= (  r2    ) ? (  r1  ) : (  r2  ))  ; */
  2648.       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
  2649.                 ffecom_expr (arg1),
  2650.                 ffecom_expr (arg2));
  2651.       while (list != NULL)
  2652.     {
  2653.       if (ffebld_op (ffebld_head (list)) == FFEBLD_opANY)
  2654.         continue;
  2655.       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
  2656.                 expr_tree,
  2657.                 ffecom_expr (ffebld_head (list)));
  2658.       list = ffebld_trail (list);
  2659.     }
  2660.       return expr_tree;
  2661.  
  2662.     case FFEINTRIN_impAMOD:
  2663.       /* r__1 = r_mod(&r1, &r2); */
  2664.       /* Ideally we'd have a handy operator to do this, but we don't, and we
  2665.          don't want to do it in the integer domain or we might lose precision
  2666.          or range, so just call the r_mod function. */
  2667.       break;            /* Use wrapper. */
  2668.  
  2669.     case FFEINTRIN_impANINT:
  2670.       /* r__1 = r_nint(&r1); */
  2671. #if 0                /* This way of doing it won't handle real
  2672.                    numbers of large magnitudes. */
  2673.       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
  2674.       expr_tree = convert (tree_type,
  2675.                convert (integer_type_node,
  2676.                     ffecom_3 (COND_EXPR, tree_type,
  2677.                           ffecom_truth_value
  2678.                           (ffecom_2 (GE_EXPR,
  2679.                              integer_type_node,
  2680.                              saved_expr1,
  2681.                                ffecom_float_zero_)),
  2682.                           ffecom_2 (PLUS_EXPR,
  2683.                             tree_type,
  2684.                             saved_expr1,
  2685.                             ffecom_float_half_),
  2686.                           ffecom_2 (MINUS_EXPR,
  2687.                             tree_type,
  2688.                             saved_expr1,
  2689.                              ffecom_float_half_))));
  2690.       return expr_tree;
  2691. #else /* So we instead call floor. */
  2692.       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
  2693.       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
  2694.       return
  2695.     convert (tree_type,
  2696.          ffecom_3 (COND_EXPR, double_type_node,
  2697.                ffecom_truth_value
  2698.                (ffecom_2 (GE_EXPR, integer_type_node,
  2699.                       saved_expr1,
  2700.                       ffecom_float_zero_)),
  2701.                ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
  2702.                          build_tree_list (NULL_TREE,
  2703.                           convert (double_type_node,
  2704.     ffecom_2 (PLUS_EXPR, tree_type, saved_expr1, ffecom_float_half_)))),
  2705.                ffecom_1 (NEGATE_EXPR, double_type_node,
  2706.                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
  2707.                          build_tree_list (NULL_TREE,
  2708.                           convert (double_type_node,
  2709.                                ffecom_2 (MINUS_EXPR,
  2710.                                  tree_type,
  2711.                              ffecom_float_half_,
  2712.                                 saved_expr1)))))
  2713.          )
  2714.     );
  2715. #endif
  2716.  
  2717.     case FFEINTRIN_impASIN:
  2718.       /* r__1 = asin(r1); */
  2719.       ix = FFECOM_gfrtL_ASIN;
  2720.       goto library;        /* :::::::::::::::::::: */
  2721.  
  2722.     case FFEINTRIN_impATAN:
  2723.       /* r__1 = atan(r1); */
  2724.       ix = FFECOM_gfrtL_ATAN;
  2725.       goto library;        /* :::::::::::::::::::: */
  2726.  
  2727.     case FFEINTRIN_impATAN2:
  2728.       /* r__1 = atan2(r1, r2); */
  2729.       ix = FFECOM_gfrtL_ATAN2;
  2730.       goto library;        /* :::::::::::::::::::: */
  2731.  
  2732.     case FFEINTRIN_impCABS:
  2733.     case FFEINTRIN_impCDABS:
  2734.       /* r__1 = c_abs(&c1); */
  2735. #if 0
  2736.       return ffecom_1 (ABS_EXPR, tree_type, ffecom_expr (arg1));
  2737. #else
  2738.       break;            /* Use wrapper. */
  2739. #endif
  2740.  
  2741.     case FFEINTRIN_impCCOS:
  2742.     case FFEINTRIN_impCDCOS:
  2743.       /* c_cos(&q__1, &c1); */
  2744.       returns_complex = TRUE;
  2745.       break;            /* Use wrapper. */
  2746.  
  2747.     case FFEINTRIN_impCEXP:
  2748.     case FFEINTRIN_impCDEXP:
  2749.       /* c_exp(&q__1, &c1); */
  2750.       returns_complex = TRUE;
  2751.       break;            /* Use wrapper. */
  2752.  
  2753.     case FFEINTRIN_impCHAR:
  2754.     case FFEINTRIN_impACHAR:
  2755.       /* ch__1[0] = i1; */
  2756.       assert (ffecom_pending_calls_ != 0);
  2757.       tempvar = ffecom_push_tempvar (char_type_node,
  2758.                      1, -1, TRUE);
  2759.       {
  2760.     tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
  2761.  
  2762.     expr_tree = ffecom_modify (tmv,
  2763.                    ffecom_2 (ARRAY_REF, tmv, tempvar,
  2764.                          integer_one_node),
  2765.                    convert (tmv, ffecom_expr (arg1)));
  2766.       }
  2767.       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
  2768.                 expr_tree,
  2769.                 tempvar);
  2770.       expr_tree = ffecom_1 (ADDR_EXPR,
  2771.                 build_pointer_type (TREE_TYPE (expr_tree)),
  2772.                 expr_tree);
  2773.       return expr_tree;
  2774.  
  2775.     case FFEINTRIN_impCLOG:
  2776.     case FFEINTRIN_impCDLOG:
  2777.       /* c_log(&q__1, &c1); */
  2778.       returns_complex = TRUE;
  2779.       break;            /* Use wrapper. */
  2780.  
  2781.     case FFEINTRIN_impCONJG:
  2782.     case FFEINTRIN_impDCONJG:
  2783.       /* r_cnjg(&q__1, &c1); */
  2784.       returns_complex = TRUE;
  2785.       break;            /* Use wrapper. */
  2786.  
  2787.     case FFEINTRIN_impCOS:
  2788.       /* r__1 = cos(r1); */
  2789.       ix = FFECOM_gfrtL_COS;
  2790.       goto library;        /* :::::::::::::::::::: */
  2791.  
  2792.     case FFEINTRIN_impCOSH:
  2793.       /* r__1 = cosh(r1); */
  2794.       ix = FFECOM_gfrtL_COSH;
  2795.       goto library;        /* :::::::::::::::::::: */
  2796.  
  2797.     case FFEINTRIN_impCSIN:
  2798.     case FFEINTRIN_impCDSIN:
  2799.       /* c_sin(&q__1, &c1); */
  2800.       returns_complex = TRUE;
  2801.       break;            /* Use wrapper. */
  2802.  
  2803.     case FFEINTRIN_impCSQRT:
  2804.     case FFEINTRIN_impCDSQRT:
  2805.       /* c_sqrt(&q__1, &c1); */
  2806.       returns_complex = TRUE;
  2807.       break;            /* Use wrapper. */
  2808.  
  2809.     case FFEINTRIN_impDABS:
  2810.       /* d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ; */
  2811.       return ffecom_1 (ABS_EXPR, tree_type, ffecom_expr (arg1));
  2812.  
  2813.     case FFEINTRIN_impDACOS:
  2814.       /* d__1 = acos(d1); */
  2815.       ix = FFECOM_gfrtL_ACOS;
  2816.       goto library;        /* :::::::::::::::::::: */
  2817.  
  2818.     case FFEINTRIN_impDASIN:
  2819.       /* d__1 = asin(d1); */
  2820.       ix = FFECOM_gfrtL_ASIN;
  2821.       goto library;        /* :::::::::::::::::::: */
  2822.  
  2823.     case FFEINTRIN_impDATAN:
  2824.       /* d__1 = atan(d1); */
  2825.       ix = FFECOM_gfrtL_ATAN;
  2826.       goto library;        /* :::::::::::::::::::: */
  2827.  
  2828.     case FFEINTRIN_impDATAN2:
  2829.       /* d__1 = atan2(d1, d2); */
  2830.       ix = FFECOM_gfrtL_ATAN2;
  2831.       goto library;        /* :::::::::::::::::::: */
  2832.  
  2833.     case FFEINTRIN_impDCOS:
  2834.       /* d__1 = cos(d1); */
  2835.       ix = FFECOM_gfrtL_COS;
  2836.       goto library;        /* :::::::::::::::::::: */
  2837.  
  2838.     case FFEINTRIN_impDCOSH:
  2839.       /* d__1 = cosh(d1); */
  2840.       ix = FFECOM_gfrtL_COSH;
  2841.       goto library;        /* :::::::::::::::::::: */
  2842.  
  2843.     case FFEINTRIN_impDDIM:
  2844.       /* d__1 = d_dim(&d1, &d2); */
  2845.       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
  2846.       saved_expr2 = ffecom_save_tree (ffecom_expr (arg2));
  2847.       return
  2848.     ffecom_3 (COND_EXPR, tree_type,
  2849.           ffecom_truth_value
  2850.           (ffecom_2 (GT_EXPR, integer_type_node,
  2851.                  saved_expr1,
  2852.                  saved_expr2)),
  2853.           ffecom_2 (MINUS_EXPR, tree_type,
  2854.                 saved_expr1,
  2855.                 saved_expr2),
  2856.           ffecom_double_zero_);
  2857.  
  2858.     case FFEINTRIN_impDEXP:
  2859.       /* d__1 = exp(d1); */
  2860.       ix = FFECOM_gfrtL_EXP;
  2861.       goto library;        /* :::::::::::::::::::: */
  2862.  
  2863.     case FFEINTRIN_impDIM:
  2864.       /* r__1 = r_dim(&r1, &r2); */
  2865.       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
  2866.       saved_expr2 = ffecom_save_tree (ffecom_expr (arg2));
  2867.       return
  2868.     ffecom_3 (COND_EXPR, tree_type,
  2869.           ffecom_truth_value
  2870.           (ffecom_2 (GT_EXPR, integer_type_node,
  2871.                  saved_expr1,
  2872.                  saved_expr2)),
  2873.           ffecom_2 (MINUS_EXPR, tree_type,
  2874.                 saved_expr1,
  2875.                 saved_expr2),
  2876.           ffecom_float_zero_);
  2877.  
  2878.     case FFEINTRIN_impDINT:
  2879.       /* d__1 = d_int(&d1); */
  2880. #if 0                /* ~~ someday implement FIX_TRUNC_EXPR
  2881.                    yielding same type as arg */
  2882.       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
  2883. #else /* cannot float a fix, or might garbage up a very large number */
  2884.       /* d__1 = d1 > 0 ? floor(d1) : -floor(d1); */
  2885.       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
  2886.       return
  2887.     ffecom_3 (COND_EXPR, tree_type,
  2888.           ffecom_truth_value
  2889.           (ffecom_2 (GE_EXPR, integer_type_node,
  2890.                  saved_expr1,
  2891.                  ffecom_double_zero_)),
  2892.           ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
  2893.                     build_tree_list (NULL_TREE,
  2894.                              saved_expr1)),
  2895.           ffecom_1 (NEGATE_EXPR, tree_type,
  2896.                 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
  2897.                           build_tree_list (NULL_TREE,
  2898.                               ffecom_1 (NEGATE_EXPR,
  2899.                                 tree_type,
  2900.                                   saved_expr1)))
  2901.           ));
  2902. #endif
  2903.  
  2904.     case FFEINTRIN_impDLOG:
  2905.       /* d__1 = log(d1); */
  2906.       ix = FFECOM_gfrtL_LOG;
  2907.       goto library;        /* :::::::::::::::::::: */
  2908.  
  2909.     case FFEINTRIN_impDLOG10:
  2910.       /* d__1 = d_lg10(&d1); */
  2911.       break;            /* Use wrapper. */
  2912.  
  2913.     case FFEINTRIN_impDMAX1:
  2914.       /* d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ; */
  2915.       expr_tree = ffecom_2 (MAX_EXPR, tree_type,
  2916.                 ffecom_expr (arg1),
  2917.                 ffecom_expr (arg2));
  2918.       while (list != NULL)
  2919.     {
  2920.       if (ffebld_op (ffebld_head (list)) == FFEBLD_opANY)
  2921.         continue;
  2922.       expr_tree = ffecom_2 (MAX_EXPR, tree_type,
  2923.                 expr_tree,
  2924.                 ffecom_expr (ffebld_head (list)));
  2925.       list = ffebld_trail (list);
  2926.     }
  2927.       return expr_tree;
  2928.  
  2929.     case FFEINTRIN_impDMIN1:
  2930.       /* d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ; */
  2931.       expr_tree = ffecom_2 (MIN_EXPR, tree_type,
  2932.                 ffecom_expr (arg1),
  2933.                 ffecom_expr (arg2));
  2934.       while (list != NULL)
  2935.     {
  2936.       if (ffebld_op (ffebld_head (list)) == FFEBLD_opANY)
  2937.         continue;
  2938.       expr_tree = ffecom_2 (MIN_EXPR, tree_type,
  2939.                 expr_tree,
  2940.                 ffecom_expr (ffebld_head (list)));
  2941.       list = ffebld_trail (list);
  2942.     }
  2943.       return expr_tree;
  2944.  
  2945.     case FFEINTRIN_impDMOD:
  2946.       /* d__1 = d_mod(&d1, &d2); */
  2947.       break;            /* Use wrapper. */
  2948.  
  2949.     case FFEINTRIN_impDNINT:
  2950.       /* d__1 = d_nint(&d1); */
  2951. #if 0                /* This way of doing it won't handle real
  2952.                    numbers of large magnitudes. */
  2953.       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
  2954.       return
  2955.     convert (tree_type,
  2956.          convert (integer_type_node,
  2957.               ffecom_3 (COND_EXPR, tree_type,
  2958.                     ffecom_truth_value
  2959.                     (ffecom_2 (GE_EXPR, integer_type_node,
  2960.                            saved_expr1,
  2961.                            ffecom_double_zero_)),
  2962.                     ffecom_2 (PLUS_EXPR, tree_type,
  2963.                           saved_expr1,
  2964.                           ffecom_double_half_),
  2965.                     ffecom_2 (MINUS_EXPR, tree_type,
  2966.                           saved_expr1,
  2967.                           ffecom_double_half_))));
  2968. #else /* So we instead call floor. */
  2969.       /* d__1 = d1 >= 0 ? floor(d1 + .5) : -floor(.5 - d1) */
  2970.       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
  2971.       return
  2972.     ffecom_3 (COND_EXPR, double_type_node,
  2973.           ffecom_truth_value
  2974.           (ffecom_2 (GE_EXPR, integer_type_node,
  2975.                  saved_expr1,
  2976.                  ffecom_double_zero_)),
  2977.           ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
  2978.                     build_tree_list (NULL_TREE,
  2979.                              ffecom_2 (PLUS_EXPR,
  2980.                                    tree_type,
  2981.                                    saved_expr1,
  2982.                              ffecom_double_half_))),
  2983.           ffecom_1 (NEGATE_EXPR, tree_type,
  2984.                 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
  2985.                           build_tree_list (NULL_TREE,
  2986.                                ffecom_2 (MINUS_EXPR,
  2987.                                  tree_type,
  2988.                             ffecom_double_half_,
  2989.                                  saved_expr1))))
  2990.     );
  2991. #endif
  2992.  
  2993.     case FFEINTRIN_impDPROD:
  2994.       /* d__1 = (doublereal) r1 * r2; */
  2995.       return
  2996.     ffecom_2 (MULT_EXPR, tree_type,
  2997.           convert (tree_type, ffecom_expr (arg1)),
  2998.           convert (tree_type, ffecom_expr (arg2)));
  2999.  
  3000.     case FFEINTRIN_impDSIGN:
  3001.       /* d__1 = d_sign(&d1, &d2); */
  3002.       saved_expr1 = ffecom_save_tree (ffecom_1 (ABS_EXPR, tree_type,
  3003.                         ffecom_expr (arg1)));
  3004.       expr_tree
  3005.     = ffecom_3 (COND_EXPR, tree_type,
  3006.             ffecom_truth_value
  3007.             (ffecom_2 (GE_EXPR, integer_type_node,
  3008.                    ffecom_expr (arg2),
  3009.                    ffecom_double_zero_)),
  3010.             saved_expr1,
  3011.             ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
  3012.       /* Make sure SAVE_EXPRs get referenced early enough. */
  3013.       expr_tree
  3014.     = ffecom_2 (COMPOUND_EXPR, tree_type,
  3015.             convert (void_type_node, saved_expr1),
  3016.             expr_tree);
  3017.       return expr_tree;
  3018.  
  3019.     case FFEINTRIN_impDSIN:
  3020.       /* d__1 = sin(d1); */
  3021.       ix = FFECOM_gfrtL_SIN;
  3022.       goto library;        /* :::::::::::::::::::: */
  3023.  
  3024.     case FFEINTRIN_impDSINH:
  3025.       /* d__1 = sinh(d1); */
  3026.       ix = FFECOM_gfrtL_SINH;
  3027.       goto library;        /* :::::::::::::::::::: */
  3028.  
  3029.     case FFEINTRIN_impDSQRT:
  3030.       /* d__1 = sqrt(d1); */
  3031.       ix = FFECOM_gfrtL_SQRT;
  3032.       goto library;        /* :::::::::::::::::::: */
  3033.  
  3034.     case FFEINTRIN_impDTAN:
  3035.       /* d__1 = tan(d1); */
  3036.       ix = FFECOM_gfrtL_TAN;
  3037.       goto library;        /* :::::::::::::::::::: */
  3038.  
  3039.     case FFEINTRIN_impDTANH:
  3040.       /* d__1 = tanh(d1); */
  3041.       ix = FFECOM_gfrtL_TANH;
  3042.       goto library;        /* :::::::::::::::::::: */
  3043.  
  3044.     case FFEINTRIN_impEXP:
  3045.       /* r__1 = exp(r1); */
  3046.       ix = FFECOM_gfrtL_EXP;
  3047.       goto library;        /* :::::::::::::::::::: */
  3048.  
  3049.     case FFEINTRIN_impIABS:
  3050.       /* i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ; */
  3051.       return ffecom_1 (ABS_EXPR, tree_type, ffecom_expr (arg1));
  3052.  
  3053.     case FFEINTRIN_impICHAR:
  3054.     case FFEINTRIN_impIACHAR:
  3055.       /* i__1 = *a1; */
  3056. #if 0                /* The simple approach. */
  3057.       ffecom_push_calltemps ();
  3058.       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
  3059.       ffecom_pop_calltemps ();
  3060.       expr_tree
  3061.     = ffecom_1 (INDIRECT_REF,
  3062.             TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
  3063.             expr_tree);
  3064.       expr_tree
  3065.     = ffecom_2 (ARRAY_REF,
  3066.             TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
  3067.             expr_tree,
  3068.             integer_one_node);
  3069.       return convert (tree_type, expr_tree);
  3070. #else /* The more interesting (and more optimal) approach. */
  3071.       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
  3072.       expr_tree = ffecom_3 (COND_EXPR, tree_type,
  3073.                 saved_expr1,
  3074.                 expr_tree,
  3075.                 convert (tree_type, integer_zero_node));
  3076.       return expr_tree;
  3077. #endif
  3078.  
  3079.     case FFEINTRIN_impIDIM:
  3080.       /* i__1 = i_dim(&i1, &i2); */
  3081.       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
  3082.       saved_expr2 = ffecom_save_tree (ffecom_expr (arg2));
  3083.       return
  3084.     ffecom_3 (COND_EXPR, tree_type,
  3085.           ffecom_truth_value
  3086.           (ffecom_2 (GT_EXPR, integer_type_node,
  3087.                  saved_expr1,
  3088.                  saved_expr2)),
  3089.           ffecom_2 (MINUS_EXPR, tree_type,
  3090.                 saved_expr1,
  3091.                 saved_expr2),
  3092.           convert (tree_type, integer_zero_node));
  3093.  
  3094.     case FFEINTRIN_impIDNINT:
  3095.       /* i__1 = i_dnnt(&d1); */
  3096. #if 0                /* ~~ ideally FIX_ROUND_EXPR would be
  3097.                    implemented, but it ain't yet */
  3098.       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
  3099. #else
  3100.       /* i__1 = d1 >= 0 ? floor(d1 + .5) : -floor(.5 - d1); */
  3101.       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
  3102.       return
  3103.     convert (ffecom_integer_type_node,
  3104.          ffecom_3 (COND_EXPR, arg1_type,
  3105.                ffecom_truth_value
  3106.                (ffecom_2 (GE_EXPR, integer_type_node,
  3107.                       saved_expr1,
  3108.                       ffecom_double_zero_)),
  3109.                ffecom_2 (PLUS_EXPR, arg1_type,
  3110.                      saved_expr1,
  3111.                      ffecom_double_half_),
  3112.                ffecom_2 (MINUS_EXPR, arg1_type,
  3113.                      saved_expr1,
  3114.                      ffecom_double_half_)));
  3115. #endif
  3116.  
  3117.     case FFEINTRIN_impINDEX:
  3118.       /* i__1 = i_indx(a1, a2, 10L, 10L); */
  3119.       break;            /* Use wrapper. */
  3120.  
  3121.     case FFEINTRIN_impISIGN:
  3122.       /* i__1 = i_sign(&i1, &i2); */
  3123.       saved_expr1 = ffecom_save_tree (ffecom_1 (ABS_EXPR, tree_type,
  3124.                         ffecom_expr (arg1)));
  3125.       expr_tree
  3126.     = ffecom_3 (COND_EXPR, tree_type,
  3127.             ffecom_truth_value
  3128.             (ffecom_2 (GE_EXPR, integer_type_node,
  3129.                    ffecom_expr (arg2),
  3130.                    convert (tree_type, integer_zero_node))),
  3131.             saved_expr1,
  3132.             ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
  3133.       /* Make sure SAVE_EXPRs get referenced early enough. */
  3134.       expr_tree
  3135.     = ffecom_2 (COMPOUND_EXPR, tree_type,
  3136.             convert (void_type_node, saved_expr1),
  3137.             expr_tree);
  3138.       return expr_tree;
  3139.  
  3140.     case FFEINTRIN_impLEN:
  3141.       /* i__1 = i_len(a1, 10L); */
  3142. #if 0                /* The simple approach. */
  3143.       break;            /* Use wrapper. */
  3144. #else /* The more interesting (and more optimal) approach. */
  3145.       return ffecom_intrinsic_len_ (arg1);
  3146. #endif
  3147.  
  3148.     case FFEINTRIN_impLGE:
  3149.       /* L__1 = l_ge(a1, a2, 10L, 10L); */
  3150.       break;            /* Use wrapper. */
  3151.  
  3152.     case FFEINTRIN_impLGT:
  3153.       /* L__1 = l_gt(a1, a2, 10L, 10L); */
  3154.       break;            /* Use wrapper. */
  3155.  
  3156.     case FFEINTRIN_impLLE:
  3157.       /* L__1 = l_le(a1, a2, 10L, 10L); */
  3158.       break;            /* Use wrapper. */
  3159.  
  3160.     case FFEINTRIN_impLLT:
  3161.       /* L__1 = l_lt(a1, a2, 10L, 10L); */
  3162.       break;            /* Use wrapper. */
  3163.  
  3164.     case FFEINTRIN_impMAX0:
  3165.       /* i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ; */
  3166.       expr_tree = ffecom_2 (MAX_EXPR, tree_type,
  3167.                 ffecom_expr (arg1),
  3168.                 ffecom_expr (arg2));
  3169.       while (list != NULL)
  3170.     {
  3171.       if (ffebld_op (ffebld_head (list)) == FFEBLD_opANY)
  3172.         continue;
  3173.       expr_tree = ffecom_2 (MAX_EXPR, tree_type,
  3174.                 expr_tree,
  3175.                 ffecom_expr (ffebld_head (list)));
  3176.       list = ffebld_trail (list);
  3177.     }
  3178.       return expr_tree;
  3179.  
  3180.     case FFEINTRIN_impMAX1:
  3181.       /* i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (     r1  ) : ( r2
  3182.          ))     ; */
  3183.       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
  3184.                 ffecom_expr (arg1),
  3185.                 ffecom_expr (arg2));
  3186.       while (list != NULL)
  3187.     {
  3188.       if (ffebld_op (ffebld_head (list)) == FFEBLD_opANY)
  3189.         continue;
  3190.       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
  3191.                 expr_tree,
  3192.                 ffecom_expr (ffebld_head (list)));
  3193.       list = ffebld_trail (list);
  3194.     }
  3195.       return convert (tree_type, expr_tree);
  3196.  
  3197.     case FFEINTRIN_impMIN0:
  3198.       /* i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ; */
  3199.       expr_tree = ffecom_2 (MIN_EXPR, tree_type,
  3200.                 ffecom_expr (arg1),
  3201.                 ffecom_expr (arg2));
  3202.       while (list != NULL)
  3203.     {
  3204.       if (ffebld_op (ffebld_head (list)) == FFEBLD_opANY)
  3205.         continue;
  3206.       expr_tree = ffecom_2 (MIN_EXPR, tree_type,
  3207.                 expr_tree,
  3208.                 ffecom_expr (ffebld_head (list)));
  3209.       list = ffebld_trail (list);
  3210.     }
  3211.       return expr_tree;
  3212.  
  3213.     case FFEINTRIN_impMIN1:
  3214.       /* i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (     r1  ) : ( r2
  3215.          ))     ; */
  3216.       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
  3217.                 ffecom_expr (arg1),
  3218.                 ffecom_expr (arg2));
  3219.       while (list != NULL)
  3220.     {
  3221.       if (ffebld_op (ffebld_head (list)) == FFEBLD_opANY)
  3222.         continue;
  3223.       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
  3224.                 expr_tree,
  3225.                 ffecom_expr (ffebld_head (list)));
  3226.       list = ffebld_trail (list);
  3227.     }
  3228.       return convert (tree_type, expr_tree);
  3229.  
  3230.     case FFEINTRIN_impMOD:
  3231.       /* i__1 = i1 % i2; */
  3232.       return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
  3233.                ffecom_expr (arg1),
  3234.                ffecom_expr (arg2));
  3235.  
  3236.     case FFEINTRIN_impNINT:
  3237.       /* i__1 = i_nint(&r1); */
  3238. #if 0                /* ~~ ideally FIX_ROUND_EXPR would be
  3239.                    implemented, but it ain't yet */
  3240.       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
  3241. #else
  3242.       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
  3243.       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
  3244.       return
  3245.     convert (ffecom_integer_type_node,
  3246.          ffecom_3 (COND_EXPR, arg1_type,
  3247.                ffecom_truth_value
  3248.                (ffecom_2 (GE_EXPR, integer_type_node,
  3249.                       saved_expr1,
  3250.                       ffecom_float_zero_)),
  3251.                ffecom_2 (PLUS_EXPR, arg1_type,
  3252.                      saved_expr1,
  3253.                      ffecom_float_half_),
  3254.                ffecom_2 (MINUS_EXPR, arg1_type,
  3255.                      saved_expr1,
  3256.                      ffecom_float_half_)));
  3257. #endif
  3258.  
  3259.     case FFEINTRIN_impSIGN:
  3260.       /* r__1 = r_sign(&r1, &r2); */
  3261.       saved_expr1 = ffecom_save_tree (ffecom_1 (ABS_EXPR, tree_type,
  3262.                         ffecom_expr (arg1)));
  3263.       expr_tree
  3264.     = ffecom_3 (COND_EXPR, tree_type,
  3265.             ffecom_truth_value
  3266.             (ffecom_2 (GE_EXPR, integer_type_node,
  3267.                    ffecom_expr (arg2),
  3268.                    ffecom_float_zero_)),
  3269.             saved_expr1,
  3270.             ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
  3271.       /* Make sure SAVE_EXPRs get referenced early enough. */
  3272.       expr_tree
  3273.     = ffecom_2 (COMPOUND_EXPR, tree_type,
  3274.             convert (void_type_node, saved_expr1),
  3275.             expr_tree);
  3276.       return expr_tree;
  3277.  
  3278.     case FFEINTRIN_impSIN:
  3279.       /* r__1 = sin(r1); */
  3280.       ix = FFECOM_gfrtL_SIN;
  3281.       goto library;        /* :::::::::::::::::::: */
  3282.  
  3283.     case FFEINTRIN_impSINH:
  3284.       /* r__1 = sinh(r1); */
  3285.       ix = FFECOM_gfrtL_SINH;
  3286.       goto library;        /* :::::::::::::::::::: */
  3287.  
  3288.     case FFEINTRIN_impSQRT:
  3289.       /* r__1 = sqrt(r1); */
  3290.       ix = FFECOM_gfrtL_SQRT;
  3291.       goto library;        /* :::::::::::::::::::: */
  3292.  
  3293.     case FFEINTRIN_impTAN:
  3294.       /* r__1 = tan(r1); */
  3295.       ix = FFECOM_gfrtL_TAN;
  3296.       goto library;        /* :::::::::::::::::::: */
  3297.  
  3298.     case FFEINTRIN_impTANH:
  3299.       /* r__1 = tanh(r1); */
  3300.       ix = FFECOM_gfrtL_TANH;
  3301.       goto library;        /* :::::::::::::::::::: */
  3302.  
  3303.     case FFEINTRIN_imp_CMPLX_C:
  3304.     case FFEINTRIN_imp_DCMPLX_E:
  3305.       /* d__1 = c1.r; d__2 = c2.r; q__1.r = d__1, q__1.i = d__2; */
  3306.       if (arg2 == NULL)
  3307.     {            /* Only one arg, just use it! */
  3308.       expr_tree = ffecom_expr (arg1);
  3309.       return expr_tree;
  3310.     }
  3311.       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
  3312.       return
  3313.     ffecom_2 (COMPLEX_EXPR, tree_type,
  3314.           ffecom_1 (REALPART_EXPR, real_type,
  3315.                 ffecom_expr (arg1)),
  3316.           ffecom_1 (REALPART_EXPR, real_type,
  3317.                 ffecom_expr (arg2)));
  3318.  
  3319.     case FFEINTRIN_imp_CMPLX_D:
  3320.     case FFEINTRIN_imp_DCMPLX_R:
  3321.       /* d__1 = d1; d__2 = d2; q__1.r = d__1, q__1.i = d__2; */
  3322.       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
  3323.       return
  3324.     ffecom_2 (COMPLEX_EXPR, tree_type,
  3325.           convert (real_type, ffecom_expr (arg1)),
  3326.           convert (real_type,
  3327.                (arg2 == NULL) ? ffecom_float_zero_
  3328.                : ffecom_expr (arg2)));
  3329.  
  3330.     case FFEINTRIN_imp_CMPLX_E:
  3331.     case FFEINTRIN_imp_DCMPLX_C:
  3332.       {
  3333.     tree real_part;
  3334.     tree imag_part;
  3335.  
  3336.     real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
  3337.     real_part = ffecom_expr (arg1);
  3338.     if (arg2 == NULL)
  3339.       imag_part = real_part;
  3340.     else
  3341.       imag_part = ffecom_expr (arg2);
  3342.     real_part = ffecom_1 (REALPART_EXPR,
  3343.                   TREE_TYPE (TREE_TYPE (real_part)),
  3344.                   real_part);
  3345.     imag_part = ffecom_1 ((arg2 == NULL)
  3346.                   ? IMAGPART_EXPR : REALPART_EXPR,
  3347.                   TREE_TYPE (TREE_TYPE (imag_part)),
  3348.                   imag_part);
  3349.     return
  3350.       ffecom_2 (COMPLEX_EXPR, tree_type,
  3351.             convert (real_type, real_part),
  3352.             convert (real_type, imag_part));
  3353.       }
  3354.  
  3355.     case FFEINTRIN_imp_CMPLX_I:
  3356.     case FFEINTRIN_imp_DCMPLX_I:
  3357.       /* d__1 = (real) i1; d__2 = (real) i2; q__1.r = d__1, q__1.i = d__2; */
  3358.       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
  3359.       return
  3360.     ffecom_2 (COMPLEX_EXPR, tree_type,
  3361.           convert (real_type,
  3362.                ffecom_expr (arg1)),
  3363.           convert (real_type,
  3364.                (arg2 == NULL)
  3365.                ? ffecom_float_zero_
  3366.                : ffecom_expr (arg2)));
  3367.  
  3368.     case FFEINTRIN_imp_CMPLX_R:
  3369.     case FFEINTRIN_imp_DCMPLX_D:
  3370.       /* q__1.r = r1, q__1.i = r2; */
  3371.       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
  3372.       return
  3373.     ffecom_2 (COMPLEX_EXPR, tree_type,
  3374.           ffecom_expr (arg1),
  3375.           (arg2 == NULL) ? convert (real_type, ffecom_float_zero_)
  3376.           : ffecom_expr (arg2));
  3377.  
  3378.     case FFEINTRIN_imp_DBLE_C:
  3379.     case FFEINTRIN_imp_REAL_E:
  3380.       /* d__1 = (doublereal) c1.r; */
  3381.       expr_tree = ffecom_expr (arg1);
  3382.       return
  3383.     convert (tree_type,
  3384.          ffecom_1 (REALPART_EXPR, TREE_TYPE (TREE_TYPE (expr_tree)),
  3385.                expr_tree));
  3386.  
  3387.     case FFEINTRIN_imp_DBLE_D:
  3388.       /* */
  3389.       return ffecom_expr (arg1);
  3390.  
  3391.     case FFEINTRIN_imp_DBLE_I:
  3392.       /* d__1 = (doublereal) i1; */
  3393.       return convert (tree_type, ffecom_expr (arg1));
  3394.  
  3395.     case FFEINTRIN_imp_DBLE_R:
  3396.       /* d__1 = (doublereal) r1; */
  3397.       return convert (tree_type, ffecom_expr (arg1));
  3398.  
  3399.     case FFEINTRIN_imp_INT_C:
  3400.     case FFEINTRIN_imp_INT_E:
  3401.       /* i__1 = (integer) c1.r; */
  3402.       real_type = ffecom_tree_type[FFEINFO_basictypeREAL]
  3403.     [ffeinfo_kindtype (ffebld_info (arg1))];
  3404.       return convert (tree_type,
  3405.               ffecom_1 (REALPART_EXPR, real_type,
  3406.                 ffecom_expr (arg1)));
  3407.  
  3408.     case FFEINTRIN_imp_INT_D:
  3409.       /* i__1 = (integer) d1; */
  3410.       return convert (tree_type, ffecom_expr (arg1));
  3411.  
  3412.     case FFEINTRIN_imp_INT_I:
  3413.       /* */
  3414.       return ffecom_expr (arg1);
  3415.  
  3416.     case FFEINTRIN_imp_INT_R:
  3417.       /* i__1 = (integer) r1; */
  3418.       return convert (tree_type, ffecom_expr (arg1));
  3419.  
  3420.     case FFEINTRIN_imp_REAL_C:
  3421.     case FFEINTRIN_imp_DBLE_E:
  3422.       /* r__1 = c1.r; */
  3423.       return ffecom_1 (REALPART_EXPR, tree_type, ffecom_expr (arg1));
  3424.  
  3425.     case FFEINTRIN_imp_REAL_D:
  3426.       /* r__1 = d1; */
  3427.       return convert (tree_type, ffecom_expr (arg1));
  3428.  
  3429.     case FFEINTRIN_imp_REAL_I:
  3430.       /* r__1 = (real) i1; */
  3431.       return convert (tree_type, ffecom_expr (arg1));
  3432.  
  3433.     case FFEINTRIN_imp_REAL_R:
  3434.       /* */
  3435.       return ffecom_expr (arg1);
  3436.  
  3437.     case FFEINTRIN_impIAND:
  3438.     case FFEINTRIN_imp_AND_L:
  3439.       return ffecom_2 (BIT_AND_EXPR, tree_type,
  3440.                ffecom_expr (arg1),
  3441.                ffecom_expr (arg2));
  3442.  
  3443.     case FFEINTRIN_impIOR:
  3444.     case FFEINTRIN_imp_OR_L:
  3445.       return ffecom_2 (BIT_IOR_EXPR, tree_type,
  3446.                ffecom_expr (arg1),
  3447.                ffecom_expr (arg2));
  3448.  
  3449.     case FFEINTRIN_impIEOR:
  3450.     case FFEINTRIN_imp_XOR_L:
  3451.       return ffecom_2 (BIT_XOR_EXPR, tree_type,
  3452.                ffecom_expr (arg1),
  3453.                ffecom_expr (arg2));
  3454.  
  3455.     case FFEINTRIN_imp_LSHIFT_I:
  3456.     case FFEINTRIN_imp_LSHIFT_L:
  3457.       return ffecom_2 (LSHIFT_EXPR, tree_type,
  3458.                ffecom_expr (arg1),
  3459.                ffecom_expr (arg2));
  3460.  
  3461.     case FFEINTRIN_imp_RSHIFT_I:
  3462.     case FFEINTRIN_imp_RSHIFT_L:
  3463.       return ffecom_2 (RSHIFT_EXPR, tree_type,
  3464.                ffecom_expr (arg1),
  3465.                ffecom_expr (arg2));
  3466.  
  3467.     case FFEINTRIN_impNOT:
  3468.     case FFEINTRIN_imp_NOT_L:
  3469.       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
  3470.  
  3471.     case FFEINTRIN_impBIT_SIZE:
  3472.       return convert (tree_type, TYPE_SIZE (arg1_type));
  3473.  
  3474.     case FFEINTRIN_impBTEST:
  3475.       {
  3476.     ffetargetLogical1 true;
  3477.     ffetargetLogical1 false;
  3478.     tree true_tree;
  3479.     tree false_tree;
  3480.  
  3481.     ffetarget_logical1 (&true, TRUE);
  3482.     ffetarget_logical1 (&false, FALSE);
  3483.     if (true == 1)
  3484.       true_tree = convert (tree_type, integer_one_node);
  3485.     else
  3486.       true_tree = convert (tree_type, build_int_2 (true, 0));
  3487.     if (false == 0)
  3488.       false_tree = convert (tree_type, integer_zero_node);
  3489.     else
  3490.       false_tree = convert (tree_type, build_int_2 (false, 0));
  3491.  
  3492.     return
  3493.       ffecom_3 (COND_EXPR, tree_type,
  3494.             ffecom_truth_value
  3495.             (ffecom_2 (EQ_EXPR, integer_type_node,
  3496.                    ffecom_2 (BIT_AND_EXPR, arg1_type,
  3497.                      ffecom_expr (arg1),
  3498.                      ffecom_2 (LSHIFT_EXPR, arg1_type,
  3499.                            convert (arg1_type,
  3500.                               integer_one_node),
  3501.                            ffecom_expr (arg2))),
  3502.                    convert (arg1_type,
  3503.                     integer_zero_node))),
  3504.             false_tree,
  3505.             true_tree);
  3506.       }
  3507.  
  3508.     case FFEINTRIN_impIBCLR:
  3509.       return
  3510.     ffecom_2 (BIT_AND_EXPR, tree_type,
  3511.           ffecom_expr (arg1),
  3512.           ffecom_1 (BIT_NOT_EXPR, tree_type,
  3513.                 ffecom_2 (LSHIFT_EXPR, tree_type,
  3514.                       convert (tree_type,
  3515.                            integer_one_node),
  3516.                       convert (integer_type_node,
  3517.                            ffecom_expr (arg2)))));
  3518.  
  3519.     case FFEINTRIN_impIBITS:
  3520.       {
  3521.     tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
  3522.                             ffecom_expr (arg3)));
  3523.     tree uns_type
  3524.     = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
  3525.  
  3526.     expr_tree
  3527.       = ffecom_2 (BIT_AND_EXPR, tree_type,
  3528.               ffecom_2 (RSHIFT_EXPR, tree_type,
  3529.                 ffecom_expr (arg1),
  3530.                 ffecom_expr (arg2)),
  3531.               convert (tree_type,
  3532.                    ffecom_2 (RSHIFT_EXPR, uns_type,
  3533.                      ffecom_1 (BIT_NOT_EXPR,
  3534.                            uns_type,
  3535.                            convert (uns_type,
  3536.                             integer_zero_node)),
  3537.                      ffecom_2 (MINUS_EXPR,
  3538.                            integer_type_node,
  3539.                            TYPE_SIZE (uns_type),
  3540.                            arg3_tree))));
  3541. #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
  3542.     expr_tree
  3543.       = ffecom_3 (COND_EXPR, tree_type,
  3544.               ffecom_truth_value
  3545.               (ffecom_2 (NE_EXPR, integer_type_node,
  3546.                  arg3_tree,
  3547.                  integer_zero_node)),
  3548.               expr_tree,
  3549.               convert (tree_type, integer_zero_node));
  3550. #endif
  3551.       }
  3552.       return expr_tree;
  3553.  
  3554.     case FFEINTRIN_impIBSET:
  3555.       return
  3556.     ffecom_2 (BIT_IOR_EXPR, tree_type,
  3557.           ffecom_expr (arg1),
  3558.           ffecom_2 (LSHIFT_EXPR, tree_type,
  3559.                 convert (tree_type, integer_one_node),
  3560.                 convert (integer_type_node,
  3561.                      ffecom_expr (arg2))));
  3562.  
  3563.     case FFEINTRIN_impISHFT:
  3564.       {
  3565.     tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
  3566.     tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
  3567.                             ffecom_expr (arg2)));
  3568.     tree uns_type
  3569.     = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
  3570.  
  3571.     expr_tree
  3572.       = ffecom_3 (COND_EXPR, tree_type,
  3573.               ffecom_truth_value
  3574.               (ffecom_2 (GE_EXPR, integer_type_node,
  3575.                  arg2_tree,
  3576.                  integer_zero_node)),
  3577.               ffecom_2 (LSHIFT_EXPR, tree_type,
  3578.                 arg1_tree,
  3579.                 arg2_tree),
  3580.               convert (tree_type,
  3581.                    ffecom_2 (RSHIFT_EXPR, uns_type,
  3582.                      convert (uns_type, arg1_tree),
  3583.                      ffecom_1 (NEGATE_EXPR,
  3584.                            integer_type_node,
  3585.                            arg2_tree))));
  3586. #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
  3587.     expr_tree
  3588.       = ffecom_3 (COND_EXPR, tree_type,
  3589.               ffecom_truth_value
  3590.               (ffecom_2 (NE_EXPR, integer_type_node,
  3591.                  arg2_tree,
  3592.                  TYPE_SIZE (uns_type))),
  3593.               expr_tree,
  3594.               convert (tree_type, integer_zero_node));
  3595. #endif
  3596.     /* Make sure SAVE_EXPRs get referenced early enough. */
  3597.     expr_tree
  3598.       = ffecom_2 (COMPOUND_EXPR, tree_type,
  3599.               convert (void_type_node, arg1_tree),
  3600.               ffecom_2 (COMPOUND_EXPR, tree_type,
  3601.                 convert (void_type_node, arg2_tree),
  3602.                 expr_tree));
  3603.       }
  3604.       return expr_tree;
  3605.  
  3606.     case FFEINTRIN_impISHFTC:
  3607.       {
  3608.     tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
  3609.     tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
  3610.                             ffecom_expr (arg2)));
  3611.     tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
  3612.     : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
  3613.     tree shift_neg;
  3614.     tree shift_pos;
  3615.     tree mask_arg1;
  3616.     tree masked_arg1;
  3617.     tree uns_type
  3618.     = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
  3619.  
  3620.     mask_arg1
  3621.       = ffecom_2 (LSHIFT_EXPR, tree_type,
  3622.               ffecom_1 (BIT_NOT_EXPR, tree_type,
  3623.                 convert (tree_type, integer_zero_node)),
  3624.               arg3_tree);
  3625. #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
  3626.     mask_arg1
  3627.       = ffecom_3 (COND_EXPR, tree_type,
  3628.               ffecom_truth_value
  3629.               (ffecom_2 (NE_EXPR, integer_type_node,
  3630.                  arg3_tree,
  3631.                  TYPE_SIZE (uns_type))),
  3632.               mask_arg1,
  3633.               convert (tree_type, integer_zero_node));
  3634. #endif
  3635.     mask_arg1 = ffecom_save_tree (mask_arg1);
  3636.     masked_arg1
  3637.       = ffecom_2 (BIT_AND_EXPR, tree_type,
  3638.               arg1_tree,
  3639.               ffecom_1 (BIT_NOT_EXPR, tree_type,
  3640.                 mask_arg1));
  3641.     masked_arg1 = ffecom_save_tree (masked_arg1);
  3642.     shift_neg
  3643.       = ffecom_2 (BIT_IOR_EXPR, tree_type,
  3644.               convert (tree_type,
  3645.                    ffecom_2 (RSHIFT_EXPR, uns_type,
  3646.                      convert (uns_type, masked_arg1),
  3647.                      ffecom_1 (NEGATE_EXPR,
  3648.                            integer_type_node,
  3649.                            arg2_tree))),
  3650.               ffecom_2 (LSHIFT_EXPR, tree_type,
  3651.                 arg1_tree,
  3652.                 ffecom_2 (PLUS_EXPR, integer_type_node,
  3653.                       arg2_tree,
  3654.                       arg3_tree)));
  3655.     shift_pos
  3656.       = ffecom_2 (BIT_IOR_EXPR, tree_type,
  3657.               ffecom_2 (LSHIFT_EXPR, tree_type,
  3658.                 arg1_tree,
  3659.                 arg2_tree),
  3660.               convert (tree_type,
  3661.                    ffecom_2 (RSHIFT_EXPR, uns_type,
  3662.                      convert (uns_type, masked_arg1),
  3663.                      ffecom_2 (MINUS_EXPR,
  3664.                            integer_type_node,
  3665.                            arg3_tree,
  3666.                            arg2_tree))));
  3667.     expr_tree
  3668.       = ffecom_3 (COND_EXPR, tree_type,
  3669.               ffecom_truth_value
  3670.               (ffecom_2 (LT_EXPR, integer_type_node,
  3671.                  arg2_tree,
  3672.                  integer_zero_node)),
  3673.               shift_neg,
  3674.               shift_pos);
  3675.     expr_tree
  3676.       = ffecom_2 (BIT_IOR_EXPR, tree_type,
  3677.               ffecom_2 (BIT_AND_EXPR, tree_type,
  3678.                 mask_arg1,
  3679.                 arg1_tree),
  3680.               ffecom_2 (BIT_AND_EXPR, tree_type,
  3681.                 ffecom_1 (BIT_NOT_EXPR, tree_type,
  3682.                       mask_arg1),
  3683.                 expr_tree));
  3684.     expr_tree
  3685.       = ffecom_3 (COND_EXPR, tree_type,
  3686.               ffecom_truth_value
  3687.               (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
  3688.                  ffecom_2 (EQ_EXPR, integer_type_node,
  3689.                        ffecom_1 (ABS_EXPR,
  3690.                              integer_type_node,
  3691.                              arg2_tree),
  3692.                        arg3_tree),
  3693.                  ffecom_2 (EQ_EXPR, integer_type_node,
  3694.                        arg2_tree,
  3695.                        integer_zero_node))),
  3696.               arg1_tree,
  3697.               expr_tree);
  3698.     /* Make sure SAVE_EXPRs get referenced early enough. */
  3699.     expr_tree
  3700.       = ffecom_2 (COMPOUND_EXPR, tree_type,
  3701.               convert (void_type_node, arg1_tree),
  3702.               ffecom_2 (COMPOUND_EXPR, tree_type,
  3703.                 convert (void_type_node, arg2_tree),
  3704.                 ffecom_2 (COMPOUND_EXPR, tree_type,
  3705.                       convert (void_type_node,
  3706.                            mask_arg1),
  3707.                       ffecom_2 (COMPOUND_EXPR, tree_type,
  3708.                             convert (void_type_node,
  3709.                                  masked_arg1),
  3710.                             expr_tree))));
  3711.     expr_tree
  3712.       = ffecom_2 (COMPOUND_EXPR, tree_type,
  3713.               convert (void_type_node,
  3714.                    arg3_tree),
  3715.               expr_tree);
  3716.       }
  3717.       return expr_tree;
  3718.  
  3719.     case FFEINTRIN_impLOC:
  3720.       {
  3721.     tree arg1_tree = ffecom_expr (arg1);
  3722.  
  3723.     expr_tree
  3724.       = convert (tree_type,
  3725.              ffecom_1 (ADDR_EXPR,
  3726.                    build_pointer_type (TREE_TYPE (arg1_tree)),
  3727.                    arg1_tree));
  3728.       }
  3729.       return expr_tree;
  3730.  
  3731.     case FFEINTRIN_impMVBITS:
  3732.       tree_type = void_type_node;    /* Instead of NULL_TREE for SUBR. */
  3733.       {
  3734.     tree arg1_tree;
  3735.     tree arg2_tree = convert (integer_type_node,
  3736.                   ffecom_expr (arg2));
  3737.     tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
  3738.                             ffecom_expr (arg3)));
  3739.     ffebld arg4 = ffebld_head (ffebld_trail (list));
  3740.     tree arg4_tree;
  3741.     tree arg4_type;
  3742.     ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
  3743.     tree arg5_tree = ffecom_save_tree (convert (integer_type_node,
  3744.                             ffecom_expr (arg5)));
  3745.     tree prep_arg1;
  3746.     tree prep_arg4;
  3747.     tree arg5_plus_arg3;
  3748.  
  3749.     arg4_tree = ffecom_expr_rw (arg4);
  3750.     arg4_type = TREE_TYPE (arg4_tree);
  3751.  
  3752.     arg1_tree = ffecom_save_tree (convert (arg4_type,
  3753.                            ffecom_expr (arg1)));
  3754.  
  3755.     prep_arg1
  3756.       = ffecom_2 (LSHIFT_EXPR, arg4_type,
  3757.               ffecom_2 (BIT_AND_EXPR, arg4_type,
  3758.                 ffecom_2 (RSHIFT_EXPR, arg4_type,
  3759.                       arg1_tree,
  3760.                       arg2_tree),
  3761.                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
  3762.                       ffecom_2 (LSHIFT_EXPR, arg4_type,
  3763.                             ffecom_1 (BIT_NOT_EXPR,
  3764.                                   arg4_type,
  3765.                                   convert
  3766.                                   (arg4_type,
  3767.                             integer_zero_node)),
  3768.                             arg3_tree))),
  3769.               arg5_tree);
  3770.     arg5_plus_arg3
  3771.       = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
  3772.                     arg5_tree,
  3773.                     arg3_tree));
  3774.     prep_arg4
  3775.       = ffecom_2 (LSHIFT_EXPR, arg4_type,
  3776.               ffecom_1 (BIT_NOT_EXPR, arg4_type,
  3777.                 convert (arg4_type,
  3778.                      integer_zero_node)),
  3779.               arg5_plus_arg3);
  3780. #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
  3781.     prep_arg4
  3782.       = ffecom_3 (COND_EXPR, arg4_type,
  3783.               ffecom_truth_value
  3784.               (ffecom_2 (NE_EXPR, integer_type_node,
  3785.                  arg5_plus_arg3,
  3786.                  convert (TREE_TYPE (arg5_plus_arg3),
  3787.                       TYPE_SIZE (arg4_type)))),
  3788.               prep_arg4,
  3789.               convert (arg4_type, integer_zero_node));
  3790. #endif
  3791.     prep_arg4
  3792.       = ffecom_2 (BIT_AND_EXPR, arg4_type,
  3793.               arg4_tree,
  3794.               ffecom_2 (BIT_IOR_EXPR, arg4_type,
  3795.                 prep_arg4,
  3796.                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
  3797.                       ffecom_2 (LSHIFT_EXPR, arg4_type,
  3798.                             ffecom_1 (BIT_NOT_EXPR,
  3799.                                   arg4_type,
  3800.                                   convert
  3801.                                   (arg4_type,
  3802.                             integer_zero_node)),
  3803.                             arg5_tree))));
  3804.     prep_arg1
  3805.       = ffecom_2 (BIT_IOR_EXPR, arg4_type,
  3806.               prep_arg1,
  3807.               prep_arg4);
  3808. #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
  3809.     prep_arg1
  3810.       = ffecom_3 (COND_EXPR, arg4_type,
  3811.               ffecom_truth_value
  3812.               (ffecom_2 (NE_EXPR, integer_type_node,
  3813.                  arg3_tree,
  3814.                  convert (TREE_TYPE (arg3_tree),
  3815.                       integer_zero_node))),
  3816.               prep_arg1,
  3817.               arg4_tree);
  3818.     prep_arg1
  3819.       = ffecom_3 (COND_EXPR, arg4_type,
  3820.               ffecom_truth_value
  3821.               (ffecom_2 (NE_EXPR, integer_type_node,
  3822.                  arg3_tree,
  3823.                  convert (TREE_TYPE (arg3_tree),
  3824.                       TYPE_SIZE (arg4_type)))),
  3825.               prep_arg1,
  3826.               arg1_tree);
  3827. #endif
  3828.     expr_tree
  3829.       = ffecom_2s (MODIFY_EXPR, tree_type,
  3830.                arg4_tree,
  3831.                prep_arg1);
  3832.     /* Make sure SAVE_EXPRs get referenced early enough. */
  3833.     expr_tree
  3834.       = ffecom_2 (COMPOUND_EXPR, tree_type,
  3835.               convert (tree_type, arg1_tree),
  3836.               ffecom_2 (COMPOUND_EXPR, tree_type,
  3837.                 convert (tree_type, arg3_tree),
  3838.                 ffecom_2 (COMPOUND_EXPR, tree_type,
  3839.                       convert (tree_type,
  3840.                            arg5_tree),
  3841.                       ffecom_2 (COMPOUND_EXPR, tree_type,
  3842.                             convert (tree_type,
  3843.                                  arg5_plus_arg3),
  3844.                             expr_tree))));
  3845.     expr_tree
  3846.       = ffecom_2 (COMPOUND_EXPR, tree_type,
  3847.               convert (tree_type, arg4_tree),
  3848.               expr_tree);
  3849.  
  3850.       }
  3851.       return expr_tree;
  3852.  
  3853.     default:
  3854.       assert ("unimplemented intrinsic" == NULL);
  3855.       return error_mark_node;
  3856.     }
  3857.  
  3858.   ffecom_push_calltemps ();
  3859.   expr_tree = ffecom_list_ptr_to_expr (ffebld_right (expr));
  3860.   ffecom_pop_calltemps ();
  3861.  
  3862.   ix = ffeintrin_gfrt (ffebld_symter_implementation (ffebld_left (expr)));
  3863.   return ffecom_call_ (ffecom_gfrt_tree_ (ix), ffecom_gfrt_kind_type_ (ix),
  3864.                ffe_is_f2c_library () && returns_complex, tree_type,
  3865.                expr_tree, dest_tree, dest_info, dest_used);
  3866.  
  3867. library:            /* :::::::::::::::::::: */
  3868.  
  3869.   /* First promote all REAL arguments to DOUBLE PRECISION, since all args to
  3870.      C library functions are double. */
  3871.  
  3872.   for (list = ffebld_right (expr); list != NULL; list = ffebld_trail (list))
  3873.     {
  3874.       ffebld arg = ffebld_head (list);
  3875.  
  3876.       if ((arg == NULL)
  3877.     || (ffeinfo_basictype (ffebld_info (arg)) != FFEINFO_basictypeREAL))
  3878.     continue;
  3879.       if (ffeinfo_kindtype (ffebld_info (arg)) != FFEINFO_kindtypeREAL1)
  3880.     continue;
  3881.       ffebld_set_head (list,
  3882.                ffeexpr_convert (arg, NULL, NULL,
  3883.                     FFEINFO_basictypeREAL,
  3884.                     FFEINFO_kindtypeREALDOUBLE, 0,
  3885.                     FFETARGET_charactersizeNONE,
  3886.                     FFEEXPR_contextLET));
  3887.     }
  3888.  
  3889.   ffecom_push_calltemps ();
  3890.   expr_tree = ffecom_list_expr (ffebld_right (expr));
  3891.   ffecom_pop_calltemps ();
  3892.  
  3893.   return ffecom_call_ (ffecom_gfrt_tree_ (ix), ffecom_gfrt_kind_type_ (ix),
  3894.                ffe_is_f2c_library () && returns_complex, tree_type,
  3895.                expr_tree, dest_tree, dest_info, dest_used);
  3896.  
  3897.   /**INDENT* (Do not reformat this comment even with -fca option.)
  3898.    Data-gathering files: Given the source file listed below, compiled with
  3899.    f2c I obtained the output file listed after that, and from the output
  3900.    file I derived the above code.
  3901.  
  3902. -------- (begin input file to f2c)
  3903.     implicit none
  3904.     character*10 A1,A2
  3905.     complex C1,C2
  3906.     integer I1,I2
  3907.     real R1,R2
  3908.     double precision D1,D2
  3909. C
  3910.     call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
  3911. c /
  3912.         call fooI(I1/I2)
  3913.         call fooR(R1/I1)
  3914.         call fooD(D1/I1)
  3915.         call fooC(C1/I1)
  3916.         call fooR(R1/R2)
  3917.         call fooD(R1/D1)
  3918.         call fooD(D1/D2)
  3919.         call fooD(D1/R1)
  3920.         call fooC(C1/C2)
  3921.         call fooC(C1/R1)
  3922.         call fooZ(C1/D1)
  3923. c **
  3924.         call fooI(I1**I2)
  3925.         call fooR(R1**I1)
  3926.         call fooD(D1**I1)
  3927.         call fooC(C1**I1)
  3928.         call fooR(R1**R2)
  3929.         call fooD(R1**D1)
  3930.         call fooD(D1**D2)
  3931.         call fooD(D1**R1)
  3932.         call fooC(C1**C2)
  3933.         call fooC(C1**R1)
  3934.         call fooZ(C1**D1)
  3935. c FFEINTRIN_impABS
  3936.     call fooR(ABS(R1))
  3937. c FFEINTRIN_impACOS
  3938.     call fooR(ACOS(R1))
  3939. c FFEINTRIN_impAIMAG
  3940.     call fooR(AIMAG(C1))
  3941. c FFEINTRIN_impAINT
  3942.     call fooR(AINT(R1))
  3943. c FFEINTRIN_impALOG
  3944.     call fooR(ALOG(R1))
  3945. c FFEINTRIN_impALOG10
  3946.     call fooR(ALOG10(R1))
  3947. c FFEINTRIN_impAMAX0
  3948.     call fooR(AMAX0(I1,I2))
  3949. c FFEINTRIN_impAMAX1
  3950.     call fooR(AMAX1(R1,R2))
  3951. c FFEINTRIN_impAMIN0
  3952.     call fooR(AMIN0(I1,I2))
  3953. c FFEINTRIN_impAMIN1
  3954.     call fooR(AMIN1(R1,R2))
  3955. c FFEINTRIN_impAMOD
  3956.     call fooR(AMOD(R1,R2))
  3957. c FFEINTRIN_impANINT
  3958.     call fooR(ANINT(R1))
  3959. c FFEINTRIN_impASIN
  3960.     call fooR(ASIN(R1))
  3961. c FFEINTRIN_impATAN
  3962.     call fooR(ATAN(R1))
  3963. c FFEINTRIN_impATAN2
  3964.     call fooR(ATAN2(R1,R2))
  3965. c FFEINTRIN_impCABS
  3966.     call fooR(CABS(C1))
  3967. c FFEINTRIN_impCCOS
  3968.     call fooC(CCOS(C1))
  3969. c FFEINTRIN_impCEXP
  3970.     call fooC(CEXP(C1))
  3971. c FFEINTRIN_impCHAR
  3972.     call fooA(CHAR(I1))
  3973. c FFEINTRIN_impCLOG
  3974.     call fooC(CLOG(C1))
  3975. c FFEINTRIN_impCONJG
  3976.     call fooC(CONJG(C1))
  3977. c FFEINTRIN_impCOS
  3978.     call fooR(COS(R1))
  3979. c FFEINTRIN_impCOSH
  3980.     call fooR(COSH(R1))
  3981. c FFEINTRIN_impCSIN
  3982.     call fooC(CSIN(C1))
  3983. c FFEINTRIN_impCSQRT
  3984.     call fooC(CSQRT(C1))
  3985. c FFEINTRIN_impDABS
  3986.     call fooD(DABS(D1))
  3987. c FFEINTRIN_impDACOS
  3988.     call fooD(DACOS(D1))
  3989. c FFEINTRIN_impDASIN
  3990.     call fooD(DASIN(D1))
  3991. c FFEINTRIN_impDATAN
  3992.     call fooD(DATAN(D1))
  3993. c FFEINTRIN_impDATAN2
  3994.     call fooD(DATAN2(D1,D2))
  3995. c FFEINTRIN_impDCOS
  3996.     call fooD(DCOS(D1))
  3997. c FFEINTRIN_impDCOSH
  3998.     call fooD(DCOSH(D1))
  3999. c FFEINTRIN_impDDIM
  4000.     call fooD(DDIM(D1,D2))
  4001. c FFEINTRIN_impDEXP
  4002.     call fooD(DEXP(D1))
  4003. c FFEINTRIN_impDIM
  4004.     call fooR(DIM(R1,R2))
  4005. c FFEINTRIN_impDINT
  4006.     call fooD(DINT(D1))
  4007. c FFEINTRIN_impDLOG
  4008.     call fooD(DLOG(D1))
  4009. c FFEINTRIN_impDLOG10
  4010.     call fooD(DLOG10(D1))
  4011. c FFEINTRIN_impDMAX1
  4012.     call fooD(DMAX1(D1,D2))
  4013. c FFEINTRIN_impDMIN1
  4014.     call fooD(DMIN1(D1,D2))
  4015. c FFEINTRIN_impDMOD
  4016.     call fooD(DMOD(D1,D2))
  4017. c FFEINTRIN_impDNINT
  4018.     call fooD(DNINT(D1))
  4019. c FFEINTRIN_impDPROD
  4020.     call fooD(DPROD(R1,R2))
  4021. c FFEINTRIN_impDSIGN
  4022.     call fooD(DSIGN(D1,D2))
  4023. c FFEINTRIN_impDSIN
  4024.     call fooD(DSIN(D1))
  4025. c FFEINTRIN_impDSINH
  4026.     call fooD(DSINH(D1))
  4027. c FFEINTRIN_impDSQRT
  4028.     call fooD(DSQRT(D1))
  4029. c FFEINTRIN_impDTAN
  4030.     call fooD(DTAN(D1))
  4031. c FFEINTRIN_impDTANH
  4032.     call fooD(DTANH(D1))
  4033. c FFEINTRIN_impEXP
  4034.     call fooR(EXP(R1))
  4035. c FFEINTRIN_impIABS
  4036.     call fooI(IABS(I1))
  4037. c FFEINTRIN_impICHAR
  4038.     call fooI(ICHAR(A1))
  4039. c FFEINTRIN_impIDIM
  4040.     call fooI(IDIM(I1,I2))
  4041. c FFEINTRIN_impIDNINT
  4042.     call fooI(IDNINT(D1))
  4043. c FFEINTRIN_impINDEX
  4044.     call fooI(INDEX(A1,A2))
  4045. c FFEINTRIN_impISIGN
  4046.     call fooI(ISIGN(I1,I2))
  4047. c FFEINTRIN_impLEN
  4048.     call fooI(LEN(A1))
  4049. c FFEINTRIN_impLGE
  4050.     call fooL(LGE(A1,A2))
  4051. c FFEINTRIN_impLGT
  4052.     call fooL(LGT(A1,A2))
  4053. c FFEINTRIN_impLLE
  4054.     call fooL(LLE(A1,A2))
  4055. c FFEINTRIN_impLLT
  4056.     call fooL(LLT(A1,A2))
  4057. c FFEINTRIN_impMAX0
  4058.     call fooI(MAX0(I1,I2))
  4059. c FFEINTRIN_impMAX1
  4060.     call fooI(MAX1(R1,R2))
  4061. c FFEINTRIN_impMIN0
  4062.     call fooI(MIN0(I1,I2))
  4063. c FFEINTRIN_impMIN1
  4064.     call fooI(MIN1(R1,R2))
  4065. c FFEINTRIN_impMOD
  4066.     call fooI(MOD(I1,I2))
  4067. c FFEINTRIN_impNINT
  4068.     call fooI(NINT(R1))
  4069. c FFEINTRIN_impSIGN
  4070.     call fooR(SIGN(R1,R2))
  4071. c FFEINTRIN_impSIN
  4072.     call fooR(SIN(R1))
  4073. c FFEINTRIN_impSINH
  4074.     call fooR(SINH(R1))
  4075. c FFEINTRIN_impSQRT
  4076.     call fooR(SQRT(R1))
  4077. c FFEINTRIN_impTAN
  4078.     call fooR(TAN(R1))
  4079. c FFEINTRIN_impTANH
  4080.     call fooR(TANH(R1))
  4081. c FFEINTRIN_imp_CMPLX_C
  4082.     call fooC(cmplx(C1,C2))
  4083. c FFEINTRIN_imp_CMPLX_D
  4084.     call fooZ(cmplx(D1,D2))
  4085. c FFEINTRIN_imp_CMPLX_I
  4086.     call fooC(cmplx(I1,I2))
  4087. c FFEINTRIN_imp_CMPLX_R
  4088.     call fooC(cmplx(R1,R2))
  4089. c FFEINTRIN_imp_DBLE_C
  4090.     call fooD(dble(C1))
  4091. c FFEINTRIN_imp_DBLE_D
  4092.     call fooD(dble(D1))
  4093. c FFEINTRIN_imp_DBLE_I
  4094.     call fooD(dble(I1))
  4095. c FFEINTRIN_imp_DBLE_R
  4096.     call fooD(dble(R1))
  4097. c FFEINTRIN_imp_INT_C
  4098.     call fooI(int(C1))
  4099. c FFEINTRIN_imp_INT_D
  4100.     call fooI(int(D1))
  4101. c FFEINTRIN_imp_INT_I
  4102.     call fooI(int(I1))
  4103. c FFEINTRIN_imp_INT_R
  4104.     call fooI(int(R1))
  4105. c FFEINTRIN_imp_REAL_C
  4106.     call fooR(real(C1))
  4107. c FFEINTRIN_imp_REAL_D
  4108.     call fooR(real(D1))
  4109. c FFEINTRIN_imp_REAL_I
  4110.     call fooR(real(I1))
  4111. c FFEINTRIN_imp_REAL_R
  4112.     call fooR(real(R1))
  4113. c
  4114. c FFEINTRIN_imp_INT_D:
  4115. c
  4116. c FFEINTRIN_specIDINT
  4117.     call fooI(IDINT(D1))
  4118. c
  4119. c FFEINTRIN_imp_INT_R:
  4120. c
  4121. c FFEINTRIN_specIFIX
  4122.     call fooI(IFIX(R1))
  4123. c FFEINTRIN_specINT
  4124.     call fooI(INT(R1))
  4125. c
  4126. c FFEINTRIN_imp_REAL_D:
  4127. c
  4128. c FFEINTRIN_specSNGL
  4129.     call fooR(SNGL(D1))
  4130. c
  4131. c FFEINTRIN_imp_REAL_I:
  4132. c
  4133. c FFEINTRIN_specFLOAT
  4134.     call fooR(FLOAT(I1))
  4135. c FFEINTRIN_specREAL
  4136.     call fooR(REAL(I1))
  4137. c
  4138.     end
  4139. -------- (end input file to f2c)
  4140.  
  4141. -------- (begin output from providing above input file as input to:
  4142. --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
  4143. --------     -e "s:^#.*$::g"')
  4144.  
  4145. //  -- translated by f2c (version 19950223).
  4146.    You must link the resulting object file with the libraries:
  4147.         -lf2c -lm   (in that order)
  4148. //
  4149.  
  4150.  
  4151. // f2c.h  --  Standard Fortran to C header file //
  4152.  
  4153. ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
  4154.  
  4155.         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
  4156.  
  4157.  
  4158.  
  4159.  
  4160. // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
  4161. // we assume short, float are OK //
  4162. typedef long int // long int // integer;
  4163. typedef char *address;
  4164. typedef short int shortint;
  4165. typedef float real;
  4166. typedef double doublereal;
  4167. typedef struct { real r, i; } complex;
  4168. typedef struct { doublereal r, i; } doublecomplex;
  4169. typedef long int // long int // logical;
  4170. typedef short int shortlogical;
  4171. typedef char logical1;
  4172. typedef char integer1;
  4173. // typedef long long longint; // // system-dependent //
  4174.  
  4175.  
  4176.  
  4177.  
  4178. // Extern is for use with -E //
  4179.  
  4180.  
  4181.  
  4182.  
  4183. // I/O stuff //
  4184.  
  4185.  
  4186.  
  4187.  
  4188.  
  4189.  
  4190.  
  4191.  
  4192. typedef long int // int or long int // flag;
  4193. typedef long int // int or long int // ftnlen;
  4194. typedef long int // int or long int // ftnint;
  4195.  
  4196.  
  4197. //external read, write//
  4198. typedef struct
  4199. {       flag cierr;
  4200.         ftnint ciunit;
  4201.         flag ciend;
  4202.         char *cifmt;
  4203.         ftnint cirec;
  4204. } cilist;
  4205.  
  4206. //internal read, write//
  4207. typedef struct
  4208. {       flag icierr;
  4209.         char *iciunit;
  4210.         flag iciend;
  4211.         char *icifmt;
  4212.         ftnint icirlen;
  4213.         ftnint icirnum;
  4214. } icilist;
  4215.  
  4216. //open//
  4217. typedef struct
  4218. {       flag oerr;
  4219.         ftnint ounit;
  4220.         char *ofnm;
  4221.         ftnlen ofnmlen;
  4222.         char *osta;
  4223.         char *oacc;
  4224.         char *ofm;
  4225.         ftnint orl;
  4226.         char *oblnk;
  4227. } olist;
  4228.  
  4229. //close//
  4230. typedef struct
  4231. {       flag cerr;
  4232.         ftnint cunit;
  4233.         char *csta;
  4234. } cllist;
  4235.  
  4236. //rewind, backspace, endfile//
  4237. typedef struct
  4238. {       flag aerr;
  4239.         ftnint aunit;
  4240. } alist;
  4241.  
  4242. // inquire //
  4243. typedef struct
  4244. {       flag inerr;
  4245.         ftnint inunit;
  4246.         char *infile;
  4247.         ftnlen infilen;
  4248.         ftnint  *inex;  //parameters in standard's order//
  4249.         ftnint  *inopen;
  4250.         ftnint  *innum;
  4251.         ftnint  *innamed;
  4252.         char    *inname;
  4253.         ftnlen  innamlen;
  4254.         char    *inacc;
  4255.         ftnlen  inacclen;
  4256.         char    *inseq;
  4257.         ftnlen  inseqlen;
  4258.         char    *indir;
  4259.         ftnlen  indirlen;
  4260.         char    *infmt;
  4261.         ftnlen  infmtlen;
  4262.         char    *inform;
  4263.         ftnint  informlen;
  4264.         char    *inunf;
  4265.         ftnlen  inunflen;
  4266.         ftnint  *inrecl;
  4267.         ftnint  *innrec;
  4268.         char    *inblank;
  4269.         ftnlen  inblanklen;
  4270. } inlist;
  4271.  
  4272.  
  4273.  
  4274. union Multitype {       // for multiple entry points //
  4275.         integer1 g;
  4276.         shortint h;
  4277.         integer i;
  4278.         // longint j; //
  4279.         real r;
  4280.         doublereal d;
  4281.         complex c;
  4282.         doublecomplex z;
  4283.         };
  4284.  
  4285. typedef union Multitype Multitype;
  4286.  
  4287. typedef long Long;      // No longer used; formerly in Namelist //
  4288.  
  4289. struct Vardesc {        // for Namelist //
  4290.         char *name;
  4291.         char *addr;
  4292.         ftnlen *dims;
  4293.         int  type;
  4294.         };
  4295. typedef struct Vardesc Vardesc;
  4296.  
  4297. struct Namelist {
  4298.         char *name;
  4299.         Vardesc **vars;
  4300.         int nvars;
  4301.         };
  4302. typedef struct Namelist Namelist;
  4303.  
  4304.  
  4305.  
  4306.  
  4307.  
  4308.  
  4309.  
  4310.  
  4311. // procedure parameter types for -A and -C++ //
  4312.  
  4313.  
  4314.  
  4315.  
  4316. typedef int // Unknown procedure type // (*U_fp)();
  4317. typedef shortint (*J_fp)();
  4318. typedef integer (*I_fp)();
  4319. typedef real (*R_fp)();
  4320. typedef doublereal (*D_fp)(), (*E_fp)();
  4321. typedef // Complex // void  (*C_fp)();
  4322. typedef // Double Complex // void  (*Z_fp)();
  4323. typedef logical (*L_fp)();
  4324. typedef shortlogical (*K_fp)();
  4325. typedef // Character // void  (*H_fp)();
  4326. typedef // Subroutine // int (*S_fp)();
  4327.  
  4328. // E_fp is for real functions when -R is not specified //
  4329. typedef void  C_f;      // complex function //
  4330. typedef void  H_f;      // character function //
  4331. typedef void  Z_f;      // double complex function //
  4332. typedef doublereal E_f; // real function with -R not specified //
  4333.  
  4334. // undef any lower-case symbols that your C compiler predefines, e.g.: //
  4335.  
  4336.  
  4337. // (No such symbols should be defined in a strict ANSI C compiler.
  4338.    We can avoid trouble with f2c-translated code by using
  4339.    gcc -ansi [-traditional].) //
  4340.  
  4341.  
  4342.  
  4343.  
  4344.  
  4345.  
  4346.  
  4347.  
  4348.  
  4349.  
  4350.  
  4351.  
  4352.  
  4353.  
  4354.  
  4355.  
  4356.  
  4357.  
  4358.  
  4359.  
  4360.  
  4361.  
  4362.  
  4363. // Main program // MAIN__()
  4364. {
  4365.     // System generated locals //
  4366.     integer i__1;
  4367.     real r__1, r__2;
  4368.     doublereal d__1, d__2;
  4369.     complex q__1;
  4370.     doublecomplex z__1, z__2, z__3;
  4371.     logical L__1;
  4372.     char ch__1[1];
  4373.  
  4374.     // Builtin functions //
  4375.     void c_div();
  4376.     integer pow_ii();
  4377.     double pow_ri(), pow_di();
  4378.     void pow_ci();
  4379.     double pow_dd();
  4380.     void pow_zz();
  4381.     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(), 
  4382.             asin(), atan(), atan2(), c_abs();
  4383.     void c_cos(), c_exp(), c_log(), r_cnjg();
  4384.     double cos(), cosh();
  4385.     void c_sin(), c_sqrt();
  4386.     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(), 
  4387.             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
  4388.     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
  4389.     logical l_ge(), l_gt(), l_le(), l_lt();
  4390.     integer i_nint();
  4391.     double r_sign();
  4392.  
  4393.     // Local variables //
  4394.     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(), 
  4395.             fool_(), fooz_(), getem_();
  4396.     static char a1[10], a2[10];
  4397.     static complex c1, c2;
  4398.     static doublereal d1, d2;
  4399.     static integer i1, i2;
  4400.     static real r1, r2;
  4401.  
  4402.  
  4403.     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
  4404. // / //
  4405.     i__1 = i1 / i2;
  4406.     fooi_(&i__1);
  4407.     r__1 = r1 / i1;
  4408.     foor_(&r__1);
  4409.     d__1 = d1 / i1;
  4410.     food_(&d__1);
  4411.     d__1 = (doublereal) i1;
  4412.     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
  4413.     fooc_(&q__1);
  4414.     r__1 = r1 / r2;
  4415.     foor_(&r__1);
  4416.     d__1 = r1 / d1;
  4417.     food_(&d__1);
  4418.     d__1 = d1 / d2;
  4419.     food_(&d__1);
  4420.     d__1 = d1 / r1;
  4421.     food_(&d__1);
  4422.     c_div(&q__1, &c1, &c2);
  4423.     fooc_(&q__1);
  4424.     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
  4425.     fooc_(&q__1);
  4426.     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
  4427.     fooz_(&z__1);
  4428. // ** //
  4429.     i__1 = pow_ii(&i1, &i2);
  4430.     fooi_(&i__1);
  4431.     r__1 = pow_ri(&r1, &i1);
  4432.     foor_(&r__1);
  4433.     d__1 = pow_di(&d1, &i1);
  4434.     food_(&d__1);
  4435.     pow_ci(&q__1, &c1, &i1);
  4436.     fooc_(&q__1);
  4437.     d__1 = (doublereal) r1;
  4438.     d__2 = (doublereal) r2;
  4439.     r__1 = pow_dd(&d__1, &d__2);
  4440.     foor_(&r__1);
  4441.     d__2 = (doublereal) r1;
  4442.     d__1 = pow_dd(&d__2, &d1);
  4443.     food_(&d__1);
  4444.     d__1 = pow_dd(&d1, &d2);
  4445.     food_(&d__1);
  4446.     d__2 = (doublereal) r1;
  4447.     d__1 = pow_dd(&d1, &d__2);
  4448.     food_(&d__1);
  4449.     z__2.r = c1.r, z__2.i = c1.i;
  4450.     z__3.r = c2.r, z__3.i = c2.i;
  4451.     pow_zz(&z__1, &z__2, &z__3);
  4452.     q__1.r = z__1.r, q__1.i = z__1.i;
  4453.     fooc_(&q__1);
  4454.     z__2.r = c1.r, z__2.i = c1.i;
  4455.     z__3.r = r1, z__3.i = 0.;
  4456.     pow_zz(&z__1, &z__2, &z__3);
  4457.     q__1.r = z__1.r, q__1.i = z__1.i;
  4458.     fooc_(&q__1);
  4459.     z__2.r = c1.r, z__2.i = c1.i;
  4460.     z__3.r = d1, z__3.i = 0.;
  4461.     pow_zz(&z__1, &z__2, &z__3);
  4462.     fooz_(&z__1);
  4463. // FFEINTRIN_impABS //
  4464.     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
  4465.     foor_(&r__1);
  4466. // FFEINTRIN_impACOS //
  4467.     r__1 = acos(r1);
  4468.     foor_(&r__1);
  4469. // FFEINTRIN_impAIMAG //
  4470.     r__1 = r_imag(&c1);
  4471.     foor_(&r__1);
  4472. // FFEINTRIN_impAINT //
  4473.     r__1 = r_int(&r1);
  4474.     foor_(&r__1);
  4475. // FFEINTRIN_impALOG //
  4476.     r__1 = log(r1);
  4477.     foor_(&r__1);
  4478. // FFEINTRIN_impALOG10 //
  4479.     r__1 = r_lg10(&r1);
  4480.     foor_(&r__1);
  4481. // FFEINTRIN_impAMAX0 //
  4482.     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
  4483.     foor_(&r__1);
  4484. // FFEINTRIN_impAMAX1 //
  4485.     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
  4486.     foor_(&r__1);
  4487. // FFEINTRIN_impAMIN0 //
  4488.     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
  4489.     foor_(&r__1);
  4490. // FFEINTRIN_impAMIN1 //
  4491.     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
  4492.     foor_(&r__1);
  4493. // FFEINTRIN_impAMOD //
  4494.     r__1 = r_mod(&r1, &r2);
  4495.     foor_(&r__1);
  4496. // FFEINTRIN_impANINT //
  4497.     r__1 = r_nint(&r1);
  4498.     foor_(&r__1);
  4499. // FFEINTRIN_impASIN //
  4500.     r__1 = asin(r1);
  4501.     foor_(&r__1);
  4502. // FFEINTRIN_impATAN //
  4503.     r__1 = atan(r1);
  4504.     foor_(&r__1);
  4505. // FFEINTRIN_impATAN2 //
  4506.     r__1 = atan2(r1, r2);
  4507.     foor_(&r__1);
  4508. // FFEINTRIN_impCABS //
  4509.     r__1 = c_abs(&c1);
  4510.     foor_(&r__1);
  4511. // FFEINTRIN_impCCOS //
  4512.     c_cos(&q__1, &c1);
  4513.     fooc_(&q__1);
  4514. // FFEINTRIN_impCEXP //
  4515.     c_exp(&q__1, &c1);
  4516.     fooc_(&q__1);
  4517. // FFEINTRIN_impCHAR //
  4518.     *(unsigned char *)&ch__1[0] = i1;
  4519.     fooa_(ch__1, 1L);
  4520. // FFEINTRIN_impCLOG //
  4521.     c_log(&q__1, &c1);
  4522.     fooc_(&q__1);
  4523. // FFEINTRIN_impCONJG //
  4524.     r_cnjg(&q__1, &c1);
  4525.     fooc_(&q__1);
  4526. // FFEINTRIN_impCOS //
  4527.     r__1 = cos(r1);
  4528.     foor_(&r__1);
  4529. // FFEINTRIN_impCOSH //
  4530.     r__1 = cosh(r1);
  4531.     foor_(&r__1);
  4532. // FFEINTRIN_impCSIN //
  4533.     c_sin(&q__1, &c1);
  4534.     fooc_(&q__1);
  4535. // FFEINTRIN_impCSQRT //
  4536.     c_sqrt(&q__1, &c1);
  4537.     fooc_(&q__1);
  4538. // FFEINTRIN_impDABS //
  4539.     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
  4540.     food_(&d__1);
  4541. // FFEINTRIN_impDACOS //
  4542.     d__1 = acos(d1);
  4543.     food_(&d__1);
  4544. // FFEINTRIN_impDASIN //
  4545.     d__1 = asin(d1);
  4546.     food_(&d__1);
  4547. // FFEINTRIN_impDATAN //
  4548.     d__1 = atan(d1);
  4549.     food_(&d__1);
  4550. // FFEINTRIN_impDATAN2 //
  4551.     d__1 = atan2(d1, d2);
  4552.     food_(&d__1);
  4553. // FFEINTRIN_impDCOS //
  4554.     d__1 = cos(d1);
  4555.     food_(&d__1);
  4556. // FFEINTRIN_impDCOSH //
  4557.     d__1 = cosh(d1);
  4558.     food_(&d__1);
  4559. // FFEINTRIN_impDDIM //
  4560.     d__1 = d_dim(&d1, &d2);
  4561.     food_(&d__1);
  4562. // FFEINTRIN_impDEXP //
  4563.     d__1 = exp(d1);
  4564.     food_(&d__1);
  4565. // FFEINTRIN_impDIM //
  4566.     r__1 = r_dim(&r1, &r2);
  4567.     foor_(&r__1);
  4568. // FFEINTRIN_impDINT //
  4569.     d__1 = d_int(&d1);
  4570.     food_(&d__1);
  4571. // FFEINTRIN_impDLOG //
  4572.     d__1 = log(d1);
  4573.     food_(&d__1);
  4574. // FFEINTRIN_impDLOG10 //
  4575.     d__1 = d_lg10(&d1);
  4576.     food_(&d__1);
  4577. // FFEINTRIN_impDMAX1 //
  4578.     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
  4579.     food_(&d__1);
  4580. // FFEINTRIN_impDMIN1 //
  4581.     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
  4582.     food_(&d__1);
  4583. // FFEINTRIN_impDMOD //
  4584.     d__1 = d_mod(&d1, &d2);
  4585.     food_(&d__1);
  4586. // FFEINTRIN_impDNINT //
  4587.     d__1 = d_nint(&d1);
  4588.     food_(&d__1);
  4589. // FFEINTRIN_impDPROD //
  4590.     d__1 = (doublereal) r1 * r2;
  4591.     food_(&d__1);
  4592. // FFEINTRIN_impDSIGN //
  4593.     d__1 = d_sign(&d1, &d2);
  4594.     food_(&d__1);
  4595. // FFEINTRIN_impDSIN //
  4596.     d__1 = sin(d1);
  4597.     food_(&d__1);
  4598. // FFEINTRIN_impDSINH //
  4599.     d__1 = sinh(d1);
  4600.     food_(&d__1);
  4601. // FFEINTRIN_impDSQRT //
  4602.     d__1 = sqrt(d1);
  4603.     food_(&d__1);
  4604. // FFEINTRIN_impDTAN //
  4605.     d__1 = tan(d1);
  4606.     food_(&d__1);
  4607. // FFEINTRIN_impDTANH //
  4608.     d__1 = tanh(d1);
  4609.     food_(&d__1);
  4610. // FFEINTRIN_impEXP //
  4611.     r__1 = exp(r1);
  4612.     foor_(&r__1);
  4613. // FFEINTRIN_impIABS //
  4614.     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
  4615.     fooi_(&i__1);
  4616. // FFEINTRIN_impICHAR //
  4617.     i__1 = *(unsigned char *)a1;
  4618.     fooi_(&i__1);
  4619. // FFEINTRIN_impIDIM //
  4620.     i__1 = i_dim(&i1, &i2);
  4621.     fooi_(&i__1);
  4622. // FFEINTRIN_impIDNINT //
  4623.     i__1 = i_dnnt(&d1);
  4624.     fooi_(&i__1);
  4625. // FFEINTRIN_impINDEX //
  4626.     i__1 = i_indx(a1, a2, 10L, 10L);
  4627.     fooi_(&i__1);
  4628. // FFEINTRIN_impISIGN //
  4629.     i__1 = i_sign(&i1, &i2);
  4630.     fooi_(&i__1);
  4631. // FFEINTRIN_impLEN //
  4632.     i__1 = i_len(a1, 10L);
  4633.     fooi_(&i__1);
  4634. // FFEINTRIN_impLGE //
  4635.     L__1 = l_ge(a1, a2, 10L, 10L);
  4636.     fool_(&L__1);
  4637. // FFEINTRIN_impLGT //
  4638.     L__1 = l_gt(a1, a2, 10L, 10L);
  4639.     fool_(&L__1);
  4640. // FFEINTRIN_impLLE //
  4641.     L__1 = l_le(a1, a2, 10L, 10L);
  4642.     fool_(&L__1);
  4643. // FFEINTRIN_impLLT //
  4644.     L__1 = l_lt(a1, a2, 10L, 10L);
  4645.     fool_(&L__1);
  4646. // FFEINTRIN_impMAX0 //
  4647.     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
  4648.     fooi_(&i__1);
  4649. // FFEINTRIN_impMAX1 //
  4650.     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
  4651.     fooi_(&i__1);
  4652. // FFEINTRIN_impMIN0 //
  4653.     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
  4654.     fooi_(&i__1);
  4655. // FFEINTRIN_impMIN1 //
  4656.     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
  4657.     fooi_(&i__1);
  4658. // FFEINTRIN_impMOD //
  4659.     i__1 = i1 % i2;
  4660.     fooi_(&i__1);
  4661. // FFEINTRIN_impNINT //
  4662.     i__1 = i_nint(&r1);
  4663.     fooi_(&i__1);
  4664. // FFEINTRIN_impSIGN //
  4665.     r__1 = r_sign(&r1, &r2);
  4666.     foor_(&r__1);
  4667. // FFEINTRIN_impSIN //
  4668.     r__1 = sin(r1);
  4669.     foor_(&r__1);
  4670. // FFEINTRIN_impSINH //
  4671.     r__1 = sinh(r1);
  4672.     foor_(&r__1);
  4673. // FFEINTRIN_impSQRT //
  4674.     r__1 = sqrt(r1);
  4675.     foor_(&r__1);
  4676. // FFEINTRIN_impTAN //
  4677.     r__1 = tan(r1);
  4678.     foor_(&r__1);
  4679. // FFEINTRIN_impTANH //
  4680.     r__1 = tanh(r1);
  4681.     foor_(&r__1);
  4682. // FFEINTRIN_imp_CMPLX_C //
  4683.     r__1 = c1.r;
  4684.     r__2 = c2.r;
  4685.     q__1.r = r__1, q__1.i = r__2;
  4686.     fooc_(&q__1);
  4687. // FFEINTRIN_imp_CMPLX_D //
  4688.     z__1.r = d1, z__1.i = d2;
  4689.     fooz_(&z__1);
  4690. // FFEINTRIN_imp_CMPLX_I //
  4691.     r__1 = (real) i1;
  4692.     r__2 = (real) i2;
  4693.     q__1.r = r__1, q__1.i = r__2;
  4694.     fooc_(&q__1);
  4695. // FFEINTRIN_imp_CMPLX_R //
  4696.     q__1.r = r1, q__1.i = r2;
  4697.     fooc_(&q__1);
  4698. // FFEINTRIN_imp_DBLE_C //
  4699.     d__1 = (doublereal) c1.r;
  4700.     food_(&d__1);
  4701. // FFEINTRIN_imp_DBLE_D //
  4702.     d__1 = d1;
  4703.     food_(&d__1);
  4704. // FFEINTRIN_imp_DBLE_I //
  4705.     d__1 = (doublereal) i1;
  4706.     food_(&d__1);
  4707. // FFEINTRIN_imp_DBLE_R //
  4708.     d__1 = (doublereal) r1;
  4709.     food_(&d__1);
  4710. // FFEINTRIN_imp_INT_C //
  4711.     i__1 = (integer) c1.r;
  4712.     fooi_(&i__1);
  4713. // FFEINTRIN_imp_INT_D //
  4714.     i__1 = (integer) d1;
  4715.     fooi_(&i__1);
  4716. // FFEINTRIN_imp_INT_I //
  4717.     i__1 = i1;
  4718.     fooi_(&i__1);
  4719. // FFEINTRIN_imp_INT_R //
  4720.     i__1 = (integer) r1;
  4721.     fooi_(&i__1);
  4722. // FFEINTRIN_imp_REAL_C //
  4723.     r__1 = c1.r;
  4724.     foor_(&r__1);
  4725. // FFEINTRIN_imp_REAL_D //
  4726.     r__1 = (real) d1;
  4727.     foor_(&r__1);
  4728. // FFEINTRIN_imp_REAL_I //
  4729.     r__1 = (real) i1;
  4730.     foor_(&r__1);
  4731. // FFEINTRIN_imp_REAL_R //
  4732.     r__1 = r1;
  4733.     foor_(&r__1);
  4734.  
  4735. // FFEINTRIN_imp_INT_D: //
  4736.  
  4737. // FFEINTRIN_specIDINT //
  4738.     i__1 = (integer) d1;
  4739.     fooi_(&i__1);
  4740.  
  4741. // FFEINTRIN_imp_INT_R: //
  4742.  
  4743. // FFEINTRIN_specIFIX //
  4744.     i__1 = (integer) r1;
  4745.     fooi_(&i__1);
  4746. // FFEINTRIN_specINT //
  4747.     i__1 = (integer) r1;
  4748.     fooi_(&i__1);
  4749.  
  4750. // FFEINTRIN_imp_REAL_D: //
  4751.  
  4752. // FFEINTRIN_specSNGL //
  4753.     r__1 = (real) d1;
  4754.     foor_(&r__1);
  4755.  
  4756. // FFEINTRIN_imp_REAL_I: //
  4757.  
  4758. // FFEINTRIN_specFLOAT //
  4759.     r__1 = (real) i1;
  4760.     foor_(&r__1);
  4761. // FFEINTRIN_specREAL //
  4762.     r__1 = (real) i1;
  4763.     foor_(&r__1);
  4764.  
  4765. } // MAIN__ //
  4766.  
  4767. -------- (end output file from f2c)
  4768.  
  4769. */
  4770. }
  4771.  
  4772. #endif
  4773. /* For power (exponentiation) where right-hand operand is type INTEGER,
  4774.    generate in-line code to do it the fast way (which, if the operand
  4775.    is a constant, might just mean a series of multiplies).  */
  4776.  
  4777. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  4778. static tree
  4779. ffecom_expr_power_integer_ (ffebld left, ffebld right)
  4780. {
  4781.   tree l = ffecom_expr (left);
  4782.   tree r = ffecom_expr (right);
  4783.   tree ltype = TREE_TYPE (l);
  4784.   tree rtype = TREE_TYPE (r);
  4785.   tree result = NULL_TREE;
  4786.  
  4787.   if (TREE_CODE (r) == INTEGER_CST)
  4788.     {
  4789.       int sgn = tree_int_cst_sgn (r);
  4790.  
  4791.       if (sgn == 0)
  4792.     return convert (ltype, integer_one_node);
  4793.  
  4794.       if ((TREE_CODE (ltype) == INTEGER_TYPE)
  4795.       && (sgn < 0))
  4796.     {
  4797.       /* Reciprocal of integer is either 0, -1, or 1, so after
  4798.          calculating that (which we leave to the back end to do
  4799.          or not do optimally), don't bother with any multiplying.  */
  4800.  
  4801.       return ffecom_tree_divide_ (ltype,
  4802.                       convert (ltype, integer_one_node),
  4803.                       l,
  4804.                       NULL_TREE, ffeinfo_new_null (), NULL);
  4805.     }
  4806.  
  4807.       /* Generate appropriate series of multiplies, preceded
  4808.      by divide if the exponent is negative.  */
  4809.  
  4810.       l = save_expr (l);
  4811.  
  4812.       if (sgn < 0)
  4813.     {
  4814.       l = ffecom_tree_divide_ (ltype,
  4815.                    convert (ltype, integer_one_node),
  4816.                    l,
  4817.                    NULL_TREE, ffeinfo_new_null (), NULL);
  4818.       r = ffecom_1 (NEGATE_EXPR, rtype, r);
  4819.       assert (TREE_CODE (r) == INTEGER_CST);
  4820.  
  4821.       if (tree_int_cst_sgn (r) < 0)
  4822.         {            /* The "most negative" number.  */
  4823.           r = ffecom_1 (NEGATE_EXPR, rtype,
  4824.                 ffecom_2 (RSHIFT_EXPR, rtype,
  4825.                       r,
  4826.                       integer_one_node));
  4827.           l = ffecom_2 (MULT_EXPR, ltype,
  4828.                 l,
  4829.                 l);
  4830.         }
  4831.     }
  4832.  
  4833.       for (;;)
  4834.     {
  4835.       if (TREE_INT_CST_LOW (r) & 1)
  4836.         {
  4837.           if (result == NULL_TREE)
  4838.         result = l;
  4839.           else
  4840.         result = ffecom_2 (MULT_EXPR, ltype,
  4841.                    result,
  4842.                    l);
  4843.         }
  4844.  
  4845.       r = ffecom_2 (RSHIFT_EXPR, rtype,
  4846.             r,
  4847.             integer_one_node);
  4848.       if (integer_zerop (r))
  4849.         break;
  4850.       assert (TREE_CODE (r) == INTEGER_CST);
  4851.  
  4852.       l = ffecom_2 (MULT_EXPR, ltype,
  4853.             l,
  4854.             l);
  4855.     }
  4856.       return result;
  4857.     }
  4858.  
  4859.   /* Right-hand operand not a constant, expand in-line code to figure
  4860.      out how to do the multiplies, &c.
  4861.  
  4862.      The returned expression is expressed this way in GNU C, where l and
  4863.      r are the "inputs":
  4864.  
  4865.      ({ typeof (r) rtmp = r;
  4866.         typeof (l) ltmp = l;
  4867.         typeof (l) result;
  4868.  
  4869.     if (rtmp == 0)
  4870.       result = 1;
  4871.     else
  4872.       {
  4873.         if ((basetypeof (l) == basetypeof (int))
  4874.             && (rtmp < 0))
  4875.           result = ((typeof (l)) 1) / ltmp;
  4876.         else
  4877.           {
  4878.             result = 1;
  4879.             if ((basetypeof (l) != basetypeof (int))
  4880.             && (rtmp < 0))
  4881.               {
  4882.                 ltmp = ((typeof (l)) 1) / ltmp;
  4883.                 rtmp = -rtmp;
  4884.             if (rtmp < 0)
  4885.               {
  4886.                 rtmp = -(rtmp >> 1);
  4887.                 ltmp *= ltmp;
  4888.               }
  4889.               }
  4890.             for (;;)
  4891.               {
  4892.                 if (rtmp & 1)
  4893.               result *= ltmp;
  4894.             if ((rtmp >>= 1) == 0)
  4895.               break;
  4896.             ltmp *= ltmp;
  4897.           }
  4898.           }
  4899.       }
  4900.     result;
  4901.      })
  4902.  
  4903.      Note that some of the above is compile-time collapsable, such as
  4904.      the first part of the if statements that checks the base type of
  4905.      l against int.  The if statements are phrased that way to suggest
  4906.      an easy way to generate the if/else constructs here, knowing that
  4907.      the back end should (and probably does) eliminate the resulting
  4908.      dead code (either the int case or the non-int case), something
  4909.      it couldn't do without the redundant phrasing, requiring explicit
  4910.      dead-code elimination here, which would be kind of difficult to
  4911.      read.  */
  4912.  
  4913.   {
  4914.     tree rtmp;
  4915.     tree ltmp;
  4916.     tree basetypeof_l_is_int;
  4917.     tree se;
  4918.  
  4919.     basetypeof_l_is_int
  4920.       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
  4921.  
  4922.     rtmp = ffecom_push_tempvar (rtype, FFETARGET_charactersizeNONE, -1,
  4923.                 TRUE);
  4924.     ltmp = ffecom_push_tempvar (ltype, FFETARGET_charactersizeNONE, -1,
  4925.                 TRUE);
  4926.     result = ffecom_push_tempvar (ltype, FFETARGET_charactersizeNONE, -1,
  4927.                   TRUE);
  4928.  
  4929.     se = expand_start_stmt_expr ();
  4930.     ++ffecom_no_new_tempvars_;    /* not while expanding stmt expr,
  4931.                    see sequence_rtl_expr in back end. */
  4932.  
  4933.     expand_expr_stmt (ffecom_modify (void_type_node,
  4934.                      rtmp,
  4935.                      r));
  4936.     expand_expr_stmt (ffecom_modify (void_type_node,
  4937.                      ltmp,
  4938.                      l));
  4939.     expand_start_cond (ffecom_truth_value
  4940.                (ffecom_2 (EQ_EXPR, integer_type_node,
  4941.                   rtmp,
  4942.                   convert (rtype, integer_zero_node))),
  4943.                0);
  4944.     expand_expr_stmt (ffecom_modify (void_type_node,
  4945.                      result,
  4946.                      convert (ltype, integer_one_node)));
  4947.     expand_start_else ();
  4948.     expand_start_cond (ffecom_truth_value
  4949.                (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
  4950.                   basetypeof_l_is_int,
  4951.                   ffecom_2 (LT_EXPR, integer_type_node,
  4952.                         rtmp,
  4953.                         convert (rtype,
  4954.                              integer_zero_node)))),
  4955.                0);
  4956.     expand_expr_stmt (ffecom_modify (void_type_node,
  4957.                      result,
  4958.                      ffecom_tree_divide_
  4959.                      (ltype,
  4960.                       convert (ltype, integer_one_node),
  4961.                       ltmp,
  4962.                       NULL_TREE, ffeinfo_new_null (), NULL)));
  4963.     expand_start_else ();
  4964.     expand_expr_stmt (ffecom_modify (void_type_node,
  4965.                      result,
  4966.                      convert (ltype, integer_one_node)));
  4967.     expand_start_cond (ffecom_truth_value
  4968.                (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
  4969.                   ffecom_truth_value_invert
  4970.                   (basetypeof_l_is_int),
  4971.                   ffecom_2 (LT_EXPR, integer_type_node,
  4972.                         rtmp,
  4973.                         convert (rtype,
  4974.                              integer_zero_node)))),
  4975.                0);
  4976.     expand_expr_stmt (ffecom_modify (void_type_node,
  4977.                      ltmp,
  4978.                      ffecom_tree_divide_
  4979.                      (ltype,
  4980.                       convert (ltype, integer_one_node),
  4981.                       ltmp,
  4982.                       NULL_TREE, ffeinfo_new_null (), NULL)));
  4983.     expand_expr_stmt (ffecom_modify (void_type_node,
  4984.                      rtmp,
  4985.                      ffecom_1 (NEGATE_EXPR, rtype,
  4986.                            rtmp)));
  4987.     expand_start_cond (ffecom_truth_value
  4988.                (ffecom_2 (LT_EXPR, integer_type_node,
  4989.                   rtmp,
  4990.                   convert (rtype, integer_zero_node))),
  4991.                0);
  4992.     expand_expr_stmt (ffecom_modify (void_type_node,
  4993.                      rtmp,
  4994.                      ffecom_1 (NEGATE_EXPR, rtype,
  4995.                            ffecom_2 (RSHIFT_EXPR,
  4996.                              rtype,
  4997.                              rtmp,
  4998.                              integer_one_node))));
  4999.     expand_expr_stmt (ffecom_modify (void_type_node,
  5000.                      ltmp,
  5001.                      ffecom_2 (MULT_EXPR, ltype,
  5002.                            ltmp,
  5003.                            ltmp)));
  5004.     expand_end_cond ();
  5005.     expand_end_cond ();
  5006.     expand_start_loop (1);
  5007.     expand_start_cond (ffecom_truth_value
  5008.                (ffecom_2 (BIT_AND_EXPR, rtype,
  5009.                   rtmp,
  5010.                   convert (rtype, integer_one_node))),
  5011.                0);
  5012.     expand_expr_stmt (ffecom_modify (void_type_node,
  5013.                      result,
  5014.                      ffecom_2 (MULT_EXPR, ltype,
  5015.                            result,
  5016.                            ltmp)));
  5017.     expand_end_cond ();
  5018.     expand_exit_loop_if_false (NULL,
  5019.                    ffecom_truth_value
  5020.                    (ffecom_modify (rtype,
  5021.                            rtmp,
  5022.                            ffecom_2 (RSHIFT_EXPR,
  5023.                              rtype,
  5024.                              rtmp,
  5025.                              integer_one_node))));
  5026.     expand_expr_stmt (ffecom_modify (void_type_node,
  5027.                      ltmp,
  5028.                      ffecom_2 (MULT_EXPR, ltype,
  5029.                            ltmp,
  5030.                            ltmp)));
  5031.     expand_end_loop ();
  5032.     expand_end_cond ();
  5033.     expand_end_cond ();
  5034.     expand_expr_stmt (result);
  5035.  
  5036.     --ffecom_no_new_tempvars_;
  5037.     result = expand_end_stmt_expr (se);
  5038.     TREE_SIDE_EFFECTS (result) = 1;
  5039.   }
  5040.  
  5041.   return result;
  5042. }
  5043.  
  5044. #endif
  5045. /* ffecom_expr_transform_ -- Transform symbols in expr
  5046.  
  5047.    ffebld expr;     // FFE expression.
  5048.    ffecom_expr_transform_ (expr);
  5049.  
  5050.    Recursive descent on expr while transforming any untransformed SYMTERs.  */
  5051.  
  5052. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5053. static void
  5054. ffecom_expr_transform_ (ffebld expr)
  5055. {
  5056.   tree t;
  5057.   ffesymbol s;
  5058.  
  5059. tail_recurse:            /* :::::::::::::::::::: */
  5060.  
  5061.   if (expr == NULL)
  5062.     return;
  5063.  
  5064.   switch (ffebld_op (expr))
  5065.     {
  5066.     case FFEBLD_opSYMTER:
  5067.       s = ffebld_symter (expr);
  5068.       t = ffesymbol_hook (s).decl_tree;
  5069.       if (t == NULL_TREE)
  5070.     {
  5071.       s = ffecom_sym_transform_ (s);
  5072.       t = ffesymbol_hook (s).decl_tree;    /* Sfunc expr non-dummy,
  5073.                            DIMENSION expr? */
  5074.     }
  5075.       break;            /* Ok if (t == NULL) here. */
  5076.  
  5077.     case FFEBLD_opITEM:
  5078.       ffecom_expr_transform_ (ffebld_head (expr));
  5079.       expr = ffebld_trail (expr);
  5080.       goto tail_recurse;    /* :::::::::::::::::::: */
  5081.  
  5082.     default:
  5083.       break;
  5084.     }
  5085.  
  5086.   switch (ffebld_arity (expr))
  5087.     {
  5088.     case 2:
  5089.       ffecom_expr_transform_ (ffebld_left (expr));
  5090.       expr = ffebld_right (expr);
  5091.       goto tail_recurse;    /* :::::::::::::::::::: */
  5092.  
  5093.     case 1:
  5094.       expr = ffebld_left (expr);
  5095.       goto tail_recurse;    /* :::::::::::::::::::: */
  5096.  
  5097.     default:
  5098.       break;
  5099.     }
  5100.  
  5101.   return;
  5102. }
  5103.  
  5104. #endif
  5105. /* Make a type based on info in live f2c.h file.  */
  5106.  
  5107. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5108. static void
  5109. ffecom_f2c_make_type_ (tree *type, int tcode, char *name)
  5110. {
  5111.   switch (tcode)
  5112.     {
  5113.     case FFECOM_f2ccodeCHAR:
  5114.       *type = make_signed_type (CHAR_TYPE_SIZE);
  5115.       break;
  5116.  
  5117.     case FFECOM_f2ccodeSHORT:
  5118.       *type = make_signed_type (SHORT_TYPE_SIZE);
  5119.       break;
  5120.  
  5121.     case FFECOM_f2ccodeINT:
  5122.       *type = make_signed_type (INT_TYPE_SIZE);
  5123.       break;
  5124.  
  5125.     case FFECOM_f2ccodeLONG:
  5126.       *type = make_signed_type (LONG_TYPE_SIZE);
  5127.       break;
  5128.  
  5129.     case FFECOM_f2ccodeLONGLONG:
  5130.       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
  5131.       break;
  5132.  
  5133.     case FFECOM_f2ccodeCHARPTR:
  5134.       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
  5135.                   ? signed_char_type_node
  5136.                   : unsigned_char_type_node);
  5137.       break;
  5138.  
  5139.     case FFECOM_f2ccodeFLOAT:
  5140.       *type = make_node (REAL_TYPE);
  5141.       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
  5142.       layout_type (*type);
  5143.       break;
  5144.  
  5145.     case FFECOM_f2ccodeDOUBLE:
  5146.       *type = make_node (REAL_TYPE);
  5147.       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
  5148.       layout_type (*type);
  5149.       break;
  5150.  
  5151.     case FFECOM_f2ccodeLONGDOUBLE:
  5152.       *type = make_node (REAL_TYPE);
  5153.       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
  5154.       layout_type (*type);
  5155.       break;
  5156.  
  5157.     case FFECOM_f2ccodeTWOREALS:
  5158.       *type = make_node (COMPLEX_TYPE);
  5159.       TREE_TYPE (*type) = ffecom_f2c_real_type_node;
  5160.       break;
  5161.  
  5162.     case FFECOM_f2ccodeTWODOUBLEREALS:
  5163.       *type = make_node (COMPLEX_TYPE);
  5164.       TREE_TYPE (*type) = ffecom_f2c_doublereal_type_node;
  5165.       break;
  5166.  
  5167.     default:
  5168.       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
  5169.       *type = error_mark_node;
  5170.       return;
  5171.     }
  5172.  
  5173.   pushdecl (build_decl (TYPE_DECL,
  5174.             ffecom_get_invented_identifier ("__g77_f2c_%s",
  5175.                             name, 0),
  5176.             *type));
  5177. }
  5178.  
  5179. #endif
  5180. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5181. /* Set the f2c list-directed-I/O code for whatever (integral) type has the
  5182.    given size.  */
  5183.  
  5184. static void
  5185. ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
  5186.               int code)
  5187. {
  5188.   int j;
  5189.   tree t;
  5190.  
  5191.   for (j = 0; j < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
  5192.     if (((t = ffecom_tree_type[bt][j]) != NULL_TREE)
  5193.     && (TYPE_PRECISION (t) == size))
  5194.       {
  5195.     assert (code != -1);
  5196.     ffecom_f2c_typecode_[bt][j] = code;
  5197.     code = -1;
  5198.       }
  5199. }
  5200.  
  5201. #endif
  5202. /* Finish up globals after doing all program units in file
  5203.  
  5204.    Need to handle only uninitialized COMMON areas.  */
  5205.  
  5206. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5207. static ffeglobal
  5208. ffecom_finish_global_ (ffeglobal global)
  5209. {
  5210.   tree cbtype;
  5211.   tree cbt;
  5212.   tree size;
  5213.  
  5214.   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
  5215.       return global;
  5216.  
  5217.   if (ffeglobal_common_init (global))
  5218.       return global;
  5219.  
  5220.   cbt = ffeglobal_hook (global);
  5221.   if ((cbt == NULL_TREE)
  5222.       || !ffeglobal_have_size (global))
  5223.     return global;        /* No need to make common, never ref'd. */
  5224.  
  5225.   suspend_momentary ();
  5226.  
  5227.   DECL_EXTERNAL (cbt) = 0;
  5228.  
  5229.   /* Give the array a size now.  */
  5230.  
  5231.   size = build_int_2 (ffeglobal_size (global), 0);
  5232.  
  5233.   cbtype = TREE_TYPE (cbt);
  5234.   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
  5235.                        integer_one_node,
  5236.                        size);
  5237.   if (!TREE_TYPE (size))
  5238.     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
  5239.   layout_type (cbtype);
  5240.  
  5241.   cbt = start_decl (cbt, FALSE);
  5242.   assert (cbt == ffeglobal_hook (global));
  5243.  
  5244.   finish_decl (cbt, NULL_TREE, FALSE);
  5245.  
  5246.   return global;
  5247. }
  5248.  
  5249. #endif
  5250. /* Finish up any untransformed symbols.  */
  5251.  
  5252. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5253. static ffesymbol
  5254. ffecom_finish_symbol_transform_ (ffesymbol s)
  5255. {
  5256.   if (s == NULL)
  5257.     return s;
  5258.  
  5259.   /* It's easy to know to transform an untransformed symbol, to make sure
  5260.      we put out debugging info for it.  But COMMON variables, unlike
  5261.      EQUIVALENCE ones, aren't given declarations in addition to the
  5262.      tree expressions that specify offsets, because COMMON variables
  5263.      can be referenced in the outer scope where only dummy arguments
  5264.      (PARM_DECLs) should really be seen.  To be safe, just don't do any
  5265.      VAR_DECLs for COMMON variables when we transform them for real
  5266.      use, and therefore we do all the VAR_DECL creating here.  */
  5267.  
  5268.   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
  5269.     s = ffecom_sym_transform_ (s);
  5270.  
  5271.   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
  5272.       && (ffesymbol_hook (s).decl_tree != error_mark_node))
  5273.     {
  5274. #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
  5275.       int yes = suspend_momentary ();
  5276.  
  5277.       /* This isn't working, at least for dbxout.  The .s file looks
  5278.      okay to me (burley), but in gdb 4.9 at least, the variables
  5279.      appear to reside somewhere outside of the common area, so
  5280.      it doesn't make sense to mislead anyone by generating the info
  5281.      on those variables until this is fixed.  NOTE: Same problem
  5282.      with EQUIVALENCE, sadly...see similar #if later.  */
  5283.       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
  5284.                  ffesymbol_storage (s));
  5285.  
  5286.       resume_momentary (yes);
  5287. #endif
  5288.     }
  5289.  
  5290.   return s;
  5291. }
  5292.  
  5293. #endif
  5294. /* Append underscore(s) to name before calling get_identifier.  "us"
  5295.    is nonzero if the name already contains an underscore and thus
  5296.    needs two underscores appended.  */
  5297.  
  5298. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5299. #ifndef ffecom_get_external_identifier_
  5300. static tree
  5301. ffecom_get_appended_identifier_ (char us, char *name)
  5302. {
  5303.   int i;
  5304.   char *newname;
  5305.   tree id;
  5306.  
  5307.   newname = xmalloc ((i = strlen (name)) + 1
  5308.              + FFETARGET_isEXTERNAL_UNDERSCORED
  5309.              + us);
  5310.   memcpy (newname, name, i);
  5311.   newname[i] = '_';
  5312.   newname[i + us] = '_';
  5313.   newname[i + 1 + us] = '\0';
  5314.   id = get_identifier (newname);
  5315.  
  5316.   free (newname);
  5317.  
  5318.   return id;
  5319. }
  5320.  
  5321. #endif
  5322. #endif
  5323. /* Decide whether to append underscore to name before calling
  5324.    get_identifier.  */
  5325.  
  5326. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5327. #ifndef ffecom_get_external_identifier_
  5328. static tree
  5329. ffecom_get_external_identifier_ (char *name)
  5330. {
  5331.   char us = FFETARGET_isUNDERSCORED_EXTERNAL_UNDERSCORED
  5332.     ? (strchr (name, '_') != NULL)
  5333.       : 0;
  5334.  
  5335.   /* If name is a built-in name, just return it as is.  */
  5336.  
  5337.   if ((strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
  5338. #if FFETARGET_isENFORCED_MAIN_NAME
  5339.       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
  5340. #else
  5341.       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
  5342. #endif
  5343.       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
  5344.     return get_identifier (name);
  5345.  
  5346.   return ffecom_get_appended_identifier_ (us, name);
  5347. }
  5348.  
  5349. #endif
  5350. #endif
  5351. /* Decide whether to append underscore to internal name before calling
  5352.    get_identifier.
  5353.  
  5354.    This is for non-external, top-function-context names only.  Transform
  5355.    identifier so it doesn't conflict with the transformed result
  5356.    of using a _different_ external name.  E.g. if "CALL FOO" is
  5357.    transformed into "FOO_();", then the variable in "FOO_ = 3"
  5358.    must be transformed into something that does not conflict, since
  5359.    these two things should be independent.
  5360.  
  5361.    The transformation is as follows.  If the name does not contain
  5362.    an underscore, there is no possible conflict, so just return.
  5363.    If the name does contain an underscore, then transform it just
  5364.    like we transform an external identifier.  */
  5365.  
  5366. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5367. #ifndef ffecom_get_identifier_
  5368. static tree
  5369. ffecom_get_identifier_ (char *name)
  5370. {
  5371.   char us = (strchr (name, '_') != NULL);
  5372.  
  5373.   /* If name does not contain an underscore, just return it as is.  */
  5374.  
  5375.   if (us == 0)
  5376.     return get_identifier (name);
  5377.  
  5378.   return ffecom_get_appended_identifier_ (FFETARGET_isUNDERSCORED_EXTERNAL_UNDERSCORED,
  5379.                       name);
  5380. }
  5381.  
  5382. #endif
  5383. #endif
  5384. /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
  5385.  
  5386.    tree t;
  5387.    ffesymbol s;     // kindFUNCTION, whereIMMEDIATE.
  5388.    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
  5389.      ffesymbol_kindtype(s));
  5390.  
  5391.    Call after setting up containing function and getting trees for all
  5392.    other symbols.  */
  5393.  
  5394. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5395. static tree
  5396. ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
  5397. {
  5398.   ffebld expr = ffesymbol_sfexpr (s);
  5399.   tree type;
  5400.   tree func;
  5401.   tree result;
  5402.   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
  5403.   static bool recurse = FALSE;
  5404.   int yes;
  5405.   int old_lineno = lineno;
  5406.   char *old_input_filename = input_filename;
  5407.  
  5408.   /* For now, we don't have a handy pointer to where the sfunc is actually
  5409.      defined, though that should be easy to add to an ffesymbol. (The
  5410.      token/where info available might well point to the place where the type
  5411.      of the sfunc is declared, especially if that precedes the place where
  5412.      the sfunc itself is defined, which is typically the case.)  We should
  5413.      put out a null pointer rather than point somewhere wrong, but I want to
  5414.      see how it works at this point.  */
  5415.  
  5416.   input_filename = ffesymbol_where_filename (s);
  5417.   lineno = ffesymbol_where_filelinenum (s);
  5418.  
  5419.   /* Pretransform the expression so any newly discovered things belong to the
  5420.      outer program unit, not to the statement function. */
  5421.  
  5422.   ffecom_expr_transform_ (expr);
  5423.  
  5424.   /* Make sure no recursive invocation of this fn (a specific case of failing
  5425.      to pretransform an sfunc's expression, i.e. where its expression
  5426.      references another untransformed sfunc) happens. */
  5427.  
  5428.   assert (!recurse);
  5429.   recurse = TRUE;
  5430.  
  5431.   yes = suspend_momentary ();
  5432.  
  5433.   push_f_function_context ();
  5434.  
  5435.   ffecom_push_calltemps ();
  5436.  
  5437.   if (charfunc)
  5438.     type = void_type_node;
  5439.   else
  5440.     {
  5441.       type = ffecom_tree_type[bt][kt];
  5442.       if (type == NULL_TREE)
  5443.     type = integer_type_node;    /* _sym_exec_transition reports
  5444.                        error. */
  5445.     }
  5446.  
  5447.   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
  5448.           build_function_type (type, NULL_TREE),
  5449.           1,        /* nested/inline */
  5450.           0);        /* TREE_PUBLIC */
  5451.  
  5452.   /* We don't worry about COMPLEX return values here, because this is
  5453.      entirely internal to our code, and gcc has the ability to return COMPLEX
  5454.      directly as a value.  */
  5455.  
  5456.   yes = suspend_momentary ();
  5457.  
  5458.   if (charfunc)
  5459.     {                /* Prepend arg for where result goes. */
  5460.       tree type;
  5461.  
  5462.       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
  5463.  
  5464.       result = ffecom_get_invented_identifier ("__g77_result_%s",
  5465.                            ffesymbol_text (s), 0);
  5466.  
  5467.       ffecom_char_enhance_arg_ (&type, s);    /* Ignore returned length. */
  5468.  
  5469.       type = build_pointer_type (type);
  5470.       result = build_decl (PARM_DECL, result, type);
  5471.  
  5472.       push_parm_decl (result);
  5473.     }
  5474.   else
  5475.     result = NULL_TREE;        /* Not ref'd if !charfunc. */
  5476.  
  5477.   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
  5478.  
  5479.   resume_momentary (yes);
  5480.  
  5481.   store_parm_decls (0);
  5482.  
  5483.   ffecom_start_compstmt_ ();
  5484.  
  5485.   if (expr != NULL)
  5486.     {
  5487.       if (charfunc)
  5488.     {
  5489.       ffetargetCharacterSize sz = ffesymbol_size (s);
  5490.       tree result_length;
  5491.  
  5492.       result_length = build_int_2 (sz, 0);
  5493.       TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
  5494.  
  5495.       ffecom_let_char_ (result, result_length, sz, expr);
  5496.       expand_null_return ();
  5497.     }
  5498.       else
  5499.     expand_return (ffecom_modify (NULL_TREE,
  5500.                       DECL_RESULT (current_function_decl),
  5501.                       ffecom_expr (expr)));
  5502.  
  5503.       clear_momentary ();
  5504.     }
  5505.  
  5506.   ffecom_end_compstmt_ ();
  5507.  
  5508.   func = current_function_decl;
  5509.   finish_function (1);
  5510.  
  5511.   ffecom_pop_calltemps ();
  5512.  
  5513.   pop_f_function_context ();
  5514.  
  5515.   resume_momentary (yes);
  5516.  
  5517.   recurse = FALSE;
  5518.  
  5519.   lineno = old_lineno;
  5520.   input_filename = old_input_filename;
  5521.  
  5522.   return func;
  5523. }
  5524.  
  5525. #endif
  5526.  
  5527. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5528. static ffeinfoKindtype
  5529. ffecom_gfrt_kind_type_ (ffecomGfrt ix)
  5530. {
  5531.   if (ffecom_gfrt_[ix] == NULL_TREE)
  5532.     ffecom_make_gfrt_ (ix);
  5533.  
  5534.   return ffecom_gfrt_kt_[ix];
  5535. }
  5536.  
  5537. #endif
  5538. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5539. static tree
  5540. ffecom_gfrt_tree_ (ffecomGfrt ix)
  5541. {
  5542.   if (ffecom_gfrt_[ix] == NULL_TREE)
  5543.     ffecom_make_gfrt_ (ix);
  5544.  
  5545.   return ffecom_1 (ADDR_EXPR,
  5546.            build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
  5547.            ffecom_gfrt_[ix]);
  5548. }
  5549.  
  5550. #endif
  5551. /* Return initialize-to-zero expression for this VAR_DECL.  */
  5552.  
  5553. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5554. static tree
  5555. ffecom_init_local_zero_ (tree decl)
  5556. {
  5557.   tree init;
  5558.   int incremental = TREE_STATIC (decl);
  5559.   tree type = TREE_TYPE (decl);
  5560.  
  5561.   if (TREE_CODE (type) == RECORD_TYPE
  5562.       || TREE_CODE (type) == UNION_TYPE)
  5563.     assert ("No -finit-local-zero on structs/unions!!" == NULL);
  5564.  
  5565.   if (incremental)
  5566.     {
  5567.       int momentary = suspend_momentary ();
  5568.       push_obstacks_nochange ();
  5569.       if (TREE_PERMANENT (decl))
  5570.     end_temporary_allocation ();
  5571.       make_decl_rtl (decl, NULL, 0);
  5572.       assemble_variable (decl, 0, 0, 1);
  5573.       pop_obstacks ();
  5574.       resume_momentary (momentary);
  5575.     }
  5576.  
  5577.   push_momentary ();
  5578.  
  5579.   if ((TREE_CODE (type) != ARRAY_TYPE)
  5580.       && !incremental)
  5581.     init = convert (type, integer_zero_node);
  5582.   else if (!incremental)
  5583.     {
  5584.       int momentary = suspend_momentary ();
  5585.       
  5586.       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
  5587.       TREE_CONSTANT (init) = 1;
  5588.       TREE_STATIC (init) = 1;
  5589.       
  5590.       resume_momentary (momentary);
  5591.     }
  5592.   else
  5593.     {
  5594.       int momentary = suspend_momentary ();
  5595.  
  5596.       assemble_zeros (int_size_in_bytes (type));
  5597.       init = error_mark_node;
  5598.  
  5599.       resume_momentary (momentary);
  5600.     }
  5601.  
  5602.   pop_momentary_nofree ();
  5603.  
  5604.   return init;
  5605. }
  5606.  
  5607. #endif
  5608. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5609. static tree
  5610. ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
  5611.              tree *maybe_tree)
  5612. {
  5613.   tree expr_tree;
  5614.   tree length_tree;
  5615.   
  5616.   switch (ffebld_op (arg))
  5617.     {
  5618.     case FFEBLD_opCONTER:    /* For F90, check 0-length. */
  5619.       if (ffetarget_length_character1
  5620.       (ffebld_constant_character1
  5621.        (ffebld_conter (arg))) == 0)
  5622.     {
  5623.       *maybe_tree = integer_zero_node;
  5624.       return convert (tree_type, integer_zero_node);
  5625.     }
  5626.  
  5627.       *maybe_tree = integer_one_node;
  5628.       expr_tree = build_int_2 (*ffetarget_text_character1
  5629.                    (ffebld_constant_character1
  5630.                 (ffebld_conter (arg))),
  5631.                    0);
  5632.       TREE_TYPE (expr_tree) = tree_type;
  5633.       return expr_tree;
  5634.       
  5635.     case FFEBLD_opSYMTER:
  5636.     case FFEBLD_opARRAYREF:
  5637.     case FFEBLD_opFUNCREF:
  5638.     case FFEBLD_opSUBSTR:
  5639.       ffecom_push_calltemps ();
  5640.       ffecom_char_args_ (&expr_tree, &length_tree, arg);
  5641.       ffecom_pop_calltemps ();
  5642.  
  5643.       if ((expr_tree == error_mark_node)
  5644.       || (length_tree == error_mark_node))
  5645.     {
  5646.       *maybe_tree = error_mark_node;
  5647.       return error_mark_node;
  5648.     }
  5649.  
  5650.       if (integer_zerop (length_tree))
  5651.     {
  5652.       *maybe_tree = integer_zero_node;
  5653.       return convert (tree_type, integer_zero_node);
  5654.     }
  5655.  
  5656.       expr_tree
  5657.     = ffecom_1 (INDIRECT_REF,
  5658.             TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
  5659.             expr_tree);
  5660.       expr_tree
  5661.     = ffecom_2 (ARRAY_REF,
  5662.             TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
  5663.             expr_tree,
  5664.             integer_one_node);
  5665.       expr_tree = convert (tree_type, expr_tree);
  5666.  
  5667.       if (TREE_CODE (length_tree) == INTEGER_CST)
  5668.     *maybe_tree = integer_one_node;
  5669.       else            /* Must check length at run time.  */
  5670.     *maybe_tree
  5671.       = ffecom_truth_value
  5672.         (ffecom_2 (GT_EXPR, integer_type_node,
  5673.                length_tree,
  5674.                ffecom_f2c_ftnlen_zero_node));
  5675.       return expr_tree;
  5676.       
  5677.     case FFEBLD_opPAREN:
  5678.     case FFEBLD_opCONVERT:
  5679.       if (ffeinfo_size (ffebld_info (arg)) == 0)
  5680.     {
  5681.       *maybe_tree = integer_zero_node;
  5682.       return convert (tree_type, integer_zero_node);
  5683.     }
  5684.       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
  5685.                       maybe_tree);
  5686.       
  5687.     case FFEBLD_opCONCATENATE:
  5688.       {
  5689.     tree maybe_left;
  5690.     tree maybe_right;
  5691.     tree expr_left;
  5692.     tree expr_right;
  5693.  
  5694.     expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
  5695.                          &maybe_left);
  5696.     expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
  5697.                           &maybe_right);
  5698.     *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
  5699.                 maybe_left,
  5700.                 maybe_right);
  5701.     expr_tree = ffecom_3 (COND_EXPR, tree_type,
  5702.                   maybe_left,
  5703.                   expr_left,
  5704.                   expr_right);
  5705.     return expr_tree;
  5706.       }
  5707.  
  5708.     default:
  5709.       assert ("bad op in ICHAR" == NULL);
  5710.       return error_mark_node;
  5711.     }
  5712. }
  5713.  
  5714. #endif
  5715. /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
  5716.  
  5717.    tree length_arg;
  5718.    ffebld expr;
  5719.    length_arg = ffecom_intrinsic_len_ (expr);
  5720.  
  5721.    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
  5722.    subexpressions by constructing the appropriate tree for the
  5723.    length-of-character-text argument in a calling sequence.  */
  5724.  
  5725. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5726. static tree
  5727. ffecom_intrinsic_len_ (ffebld expr)
  5728. {
  5729.   ffetargetCharacter1 val;
  5730.   tree length;
  5731.  
  5732.   switch (ffebld_op (expr))
  5733.     {
  5734.     case FFEBLD_opCONTER:
  5735.       val = ffebld_constant_character1 (ffebld_conter (expr));
  5736.       length = build_int_2 (ffetarget_length_character1 (val), 0);
  5737.       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
  5738.       break;
  5739.  
  5740.     case FFEBLD_opSYMTER:
  5741.       {
  5742.     ffesymbol s = ffebld_symter (expr);
  5743.     tree item;
  5744.  
  5745.     item = ffesymbol_hook (s).decl_tree;
  5746.     if (item == NULL_TREE)
  5747.       {
  5748.         s = ffecom_sym_transform_ (s);
  5749.         item = ffesymbol_hook (s).decl_tree;
  5750.       }
  5751.     if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
  5752.       {
  5753.         if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
  5754.           length = ffesymbol_hook (s).length_tree;
  5755.         else
  5756.           {
  5757.         length = build_int_2 (ffesymbol_size (s), 0);
  5758.         TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
  5759.           }
  5760.       }
  5761.     else            /* FFEINFO_kindFUNCTION: */
  5762.       length = NULL_TREE;
  5763.       }
  5764.       break;
  5765.  
  5766.     case FFEBLD_opARRAYREF:
  5767.       length = ffecom_intrinsic_len_ (ffebld_left (expr));
  5768.       break;
  5769.  
  5770.     case FFEBLD_opSUBSTR:
  5771.       {
  5772.     ffebld start;
  5773.     ffebld end;
  5774.     ffebld thing = ffebld_right (expr);
  5775.     tree start_tree;
  5776.     tree end_tree;
  5777.  
  5778.     assert (ffebld_op (thing) == FFEBLD_opITEM);
  5779.     start = ffebld_head (thing);
  5780.     thing = ffebld_trail (thing);
  5781.     assert (ffebld_trail (thing) == NULL);
  5782.     end = ffebld_head (thing);
  5783.  
  5784.     length = ffecom_intrinsic_len_ (ffebld_left (expr));
  5785.  
  5786.     if (length == error_mark_node)
  5787.       break;
  5788.  
  5789.     if (start == NULL)
  5790.       {
  5791.         if (end == NULL)
  5792.           ;
  5793.         else
  5794.           {
  5795.         length = convert (ffecom_f2c_ftnlen_type_node,
  5796.                   ffecom_expr (end));
  5797.           }
  5798.       }
  5799.     else
  5800.       {
  5801.         start_tree = convert (ffecom_f2c_ftnlen_type_node,
  5802.                   ffecom_expr (start));
  5803.  
  5804.         if (start_tree == error_mark_node)
  5805.           {
  5806.         length = error_mark_node;
  5807.         break;
  5808.           }
  5809.  
  5810.         if (end == NULL)
  5811.           {
  5812.         length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
  5813.                    ffecom_f2c_ftnlen_one_node,
  5814.                    ffecom_2 (MINUS_EXPR,
  5815.                          ffecom_f2c_ftnlen_type_node,
  5816.                          length,
  5817.                          start_tree));
  5818.           }
  5819.         else
  5820.           {
  5821.         end_tree = convert (ffecom_f2c_ftnlen_type_node,
  5822.                     ffecom_expr (end));
  5823.  
  5824.         if (end_tree == error_mark_node)
  5825.           {
  5826.             length = error_mark_node;
  5827.             break;
  5828.           }
  5829.  
  5830.         length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
  5831.                    ffecom_f2c_ftnlen_one_node,
  5832.                    ffecom_2 (MINUS_EXPR,
  5833.                          ffecom_f2c_ftnlen_type_node,
  5834.                          end_tree, start_tree));
  5835.           }
  5836.       }
  5837.       }
  5838.       break;
  5839.  
  5840.     case FFEBLD_opCONCATENATE:
  5841.       length
  5842.     = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
  5843.             ffecom_intrinsic_len_ (ffebld_left (expr)),
  5844.             ffecom_intrinsic_len_ (ffebld_right (expr)));
  5845.       break;
  5846.  
  5847.     case FFEBLD_opFUNCREF:
  5848.     case FFEBLD_opCONVERT:
  5849.       length = build_int_2 (ffebld_size (expr), 0);
  5850.       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
  5851.       break;
  5852.  
  5853.     default:
  5854.       assert ("bad op for single char arg expr" == NULL);
  5855.       length = ffecom_f2c_ftnlen_zero_node;
  5856.       break;
  5857.     }
  5858.  
  5859.   assert (length != NULL_TREE);
  5860.  
  5861.   return length;
  5862. }
  5863.  
  5864. #endif
  5865. /* ffecom_let_char_ -- Do assignment stuff for character type
  5866.  
  5867.    tree dest_tree;  // destination (ADDR_EXPR)
  5868.    tree dest_length;  // length (INT_CST/INDIRECT_REF(PARM_DECL))
  5869.    ffetargetCharacterSize dest_size;  // length
  5870.    ffebld source;  // source expression
  5871.    ffecom_let_char_(dest_tree,dest_length,dest_size,source);
  5872.  
  5873.    Generates code to do the assignment.     Used by ordinary assignment
  5874.    statement handler ffecom_let_stmt and by statement-function
  5875.    handler to generate code for a statement function.  */
  5876.  
  5877. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  5878. static void
  5879. ffecom_let_char_ (tree dest_tree, tree dest_length,
  5880.           ffetargetCharacterSize dest_size, ffebld source)
  5881. {
  5882.   ffecomConcatList_ catlist;
  5883.   tree source_length;
  5884.   tree source_tree;
  5885.   tree expr_tree;
  5886.  
  5887.   if ((dest_tree == error_mark_node)
  5888.       || (dest_length == error_mark_node))
  5889.     return;
  5890.  
  5891.   assert (dest_tree != NULL_TREE);
  5892.   assert (dest_length != NULL_TREE);
  5893.  
  5894.   /* Source might be an opCONVERT, which just means it is a different size
  5895.      than the destination.  Since the underlying implementation here handles
  5896.      that (directly or via the s_copy or s_cat run-time-library functions),
  5897.      we don't need the "convenience" of an opCONVERT that tells us to
  5898.      truncate or blank-pad, particularly since the resulting implementation
  5899.      would probably be slower than otherwise. */
  5900.  
  5901.   while (ffebld_op (source) == FFEBLD_opCONVERT)
  5902.     source = ffebld_left (source);
  5903.  
  5904.   catlist = ffecom_concat_list_new_ (source, dest_size);
  5905.   switch (ffecom_concat_list_count_ (catlist))
  5906.     {
  5907.     case 0:            /* Shouldn't happen, but in case it does... */
  5908.       ffecom_concat_list_kill_ (catlist);
  5909.       source_tree = null_pointer_node;
  5910.       source_length = ffecom_f2c_ftnlen_zero_node;
  5911.       expr_tree = build_tree_list (NULL_TREE, dest_tree);
  5912.       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
  5913.       TREE_CHAIN (TREE_CHAIN (expr_tree))
  5914.     = build_tree_list (NULL_TREE, dest_length);
  5915.       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
  5916.     = build_tree_list (NULL_TREE, source_length);
  5917.  
  5918.       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree);
  5919.       TREE_SIDE_EFFECTS (expr_tree) = 1;
  5920.  
  5921.       expand_expr_stmt (expr_tree);
  5922.  
  5923.       return;
  5924.  
  5925.     case 1:            /* The (fairly) easy case. */
  5926.       ffecom_char_args_ (&source_tree, &source_length,
  5927.              ffecom_concat_list_expr_ (catlist, 0));
  5928.       ffecom_concat_list_kill_ (catlist);
  5929.       assert (source_tree != NULL_TREE);
  5930.       assert (source_length != NULL_TREE);
  5931.  
  5932.       if (dest_size == 1)
  5933.     {
  5934.       dest_tree
  5935.         = ffecom_1 (INDIRECT_REF,
  5936.             TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
  5937.                               (dest_tree))),
  5938.             dest_tree);
  5939.       dest_tree
  5940.         = ffecom_2 (ARRAY_REF,
  5941.             TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
  5942.                               (dest_tree))),
  5943.             dest_tree,
  5944.             integer_one_node);
  5945.       source_tree
  5946.         = ffecom_1 (INDIRECT_REF,
  5947.             TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
  5948.                               (source_tree))),
  5949.             source_tree);
  5950.       source_tree
  5951.         = ffecom_2 (ARRAY_REF,
  5952.             TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
  5953.                               (source_tree))),
  5954.             source_tree,
  5955.             integer_one_node);
  5956.  
  5957.       expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
  5958.  
  5959.       expand_expr_stmt (expr_tree);
  5960.  
  5961.       return;
  5962.     }
  5963.  
  5964.       expr_tree = build_tree_list (NULL_TREE, dest_tree);
  5965.       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
  5966.       TREE_CHAIN (TREE_CHAIN (expr_tree))
  5967.     = build_tree_list (NULL_TREE, dest_length);
  5968.       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
  5969.     = build_tree_list (NULL_TREE, source_length);
  5970.  
  5971.       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree);
  5972.       TREE_SIDE_EFFECTS (expr_tree) = 1;
  5973.  
  5974.       expand_expr_stmt (expr_tree);
  5975.  
  5976.       return;
  5977.  
  5978.     default:            /* Must actually concatenate things. */
  5979.       break;
  5980.     }
  5981.  
  5982.   /* Heavy-duty concatenation. */
  5983.  
  5984.   {
  5985.     int count = ffecom_concat_list_count_ (catlist);
  5986.     int i;
  5987.     tree lengths;
  5988.     tree items;
  5989.     tree length_array;
  5990.     tree item_array;
  5991.     tree citem;
  5992.     tree clength;
  5993.  
  5994.     length_array
  5995.       = lengths
  5996.       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
  5997.                  FFETARGET_charactersizeNONE, count, TRUE);
  5998.     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
  5999.                           FFETARGET_charactersizeNONE,
  6000.                           count, TRUE);
  6001.  
  6002.     for (i = 0; i < count; ++i)
  6003.       {
  6004.     ffecom_char_args_ (&citem, &clength,
  6005.                ffecom_concat_list_expr_ (catlist, i));
  6006.     items
  6007.       = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
  6008.               ffecom_modify (void_type_node,
  6009.                      ffecom_2 (ARRAY_REF,
  6010.              TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
  6011.                            item_array,
  6012.                            build_int_2 (i, 0)),
  6013.                      citem),
  6014.               items);
  6015.     lengths
  6016.       = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
  6017.               ffecom_modify (void_type_node,
  6018.                      ffecom_2 (ARRAY_REF,
  6019.            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
  6020.                            length_array,
  6021.                            build_int_2 (i, 0)),
  6022.                      clength),
  6023.               lengths);
  6024.       }
  6025.  
  6026.     expr_tree = build_tree_list (NULL_TREE, dest_tree);
  6027.     TREE_CHAIN (expr_tree)
  6028.       = build_tree_list (NULL_TREE,
  6029.              ffecom_1 (ADDR_EXPR,
  6030.                    build_pointer_type (TREE_TYPE (items)),
  6031.                    items));
  6032.     TREE_CHAIN (TREE_CHAIN (expr_tree))
  6033.       = build_tree_list (NULL_TREE,
  6034.              ffecom_1 (ADDR_EXPR,
  6035.                    build_pointer_type (TREE_TYPE (lengths)),
  6036.                    lengths));
  6037.     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
  6038.       = build_tree_list
  6039.     (NULL_TREE,
  6040.      ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
  6041.            convert (ffecom_f2c_ftnlen_type_node,
  6042.                 build_int_2 (count, 0))));
  6043.     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
  6044.       = build_tree_list (NULL_TREE, dest_length);
  6045.  
  6046.     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree);
  6047.     TREE_SIDE_EFFECTS (expr_tree) = 1;
  6048.  
  6049.     expand_expr_stmt (expr_tree);
  6050.   }
  6051.  
  6052.   ffecom_concat_list_kill_ (catlist);
  6053. }
  6054.  
  6055. #endif
  6056. /* ffecom_make_gfrt_ -- Make initial info for run-time routine
  6057.  
  6058.    ffecomGfrt ix;
  6059.    ffecom_make_gfrt_(ix);
  6060.  
  6061.    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
  6062.    for the indicated run-time routine (ix).  */
  6063.  
  6064. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  6065. static void
  6066. ffecom_make_gfrt_ (ffecomGfrt ix)
  6067. {
  6068.   tree t;
  6069.   tree ttype;
  6070.   ffeinfoKindtype kt;
  6071.  
  6072.   push_obstacks_nochange ();
  6073.   end_temporary_allocation ();
  6074.  
  6075.   switch (ffecom_gfrt_type_[ix])
  6076.     {
  6077.     case FFECOM_rttypeVOID_:
  6078.       ttype = void_type_node;
  6079.       kt = FFEINFO_kindtypeNONE;
  6080.       break;
  6081.  
  6082.     case FFECOM_rttypeINTEGER_:
  6083.       ttype = ffecom_f2c_integer_type_node;
  6084.       kt = FFEINFO_kindtypeINTEGER1;
  6085.       break;
  6086.  
  6087.     case FFECOM_rttypeLOGICAL_:
  6088.       ttype = ffecom_f2c_logical_type_node;
  6089.       kt = FFEINFO_kindtypeLOGICAL1;
  6090.       break;
  6091.  
  6092.     case FFECOM_rttypeREAL_:
  6093.       ttype = ffecom_f2c_real_type_node;
  6094.       kt = FFEINFO_kindtypeREAL1;
  6095.       break;
  6096.  
  6097.     case FFECOM_rttypeCOMPLEX_:
  6098.       ttype = ffecom_f2c_complex_type_node;
  6099.       kt = FFEINFO_kindtypeREAL1;
  6100.       break;
  6101.  
  6102.     case FFECOM_rttypeDOUBLE_:
  6103.       ttype = double_type_node;
  6104.       kt = FFEINFO_kindtypeREAL2;
  6105.       break;
  6106.  
  6107.     case FFECOM_rttypeDBLCMPLX_:
  6108.       ttype = ffecom_f2c_doublecomplex_type_node;
  6109.       kt = FFEINFO_kindtypeREAL2;
  6110.       break;
  6111.  
  6112.     default:
  6113.       ttype = NULL;
  6114.       kt = FFEINFO_kindtypeANY;
  6115.       assert ("bad rttype" == NULL);
  6116.       break;
  6117.     }
  6118.  
  6119.   ffecom_gfrt_kt_[ix] = kt;
  6120.  
  6121.   if (ffecom_gfrt_complex_[ix] && ffe_is_f2c_library ())
  6122.     ttype = void_type_node;
  6123.   ttype = build_function_type (ttype, NULL_TREE);
  6124.   t = build_decl (FUNCTION_DECL,
  6125.           get_identifier (ffecom_gfrt_name_[ix]),
  6126.           ttype);
  6127.   DECL_EXTERNAL (t) = 1;
  6128.   TREE_PUBLIC (t) = 1;
  6129.   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
  6130.  
  6131.   t = start_decl (t, TRUE);
  6132.  
  6133.   finish_decl (t, NULL_TREE, TRUE);
  6134.  
  6135.   resume_temporary_allocation ();
  6136.   pop_obstacks ();
  6137.  
  6138.   ffecom_gfrt_[ix] = t;
  6139. }
  6140.  
  6141. #endif
  6142. /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
  6143.  
  6144. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  6145. static void
  6146. ffecom_member_phase1_ (ffestorag mst, ffestorag st)
  6147. {
  6148.   ffesymbol s = ffestorag_symbol (st);
  6149.  
  6150.   if (ffesymbol_namelisted (s))
  6151.     ffecom_member_namelisted_ = TRUE;
  6152. }
  6153.  
  6154. #endif
  6155. /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
  6156.    the member so debugger will see it.  Otherwise nobody should be
  6157.    referencing the member.  */
  6158.  
  6159. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  6160. #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
  6161. static void
  6162. ffecom_member_phase2_ (ffestorag mst, ffestorag st)
  6163. {
  6164.   ffesymbol s;
  6165.   tree t;
  6166.   tree mt;
  6167.   tree type;
  6168.  
  6169.   if ((mst == NULL)
  6170.       || ((mt = ffestorag_hook (mst)) == NULL)
  6171.       || (mt == error_mark_node))
  6172.     return;
  6173.  
  6174.   if ((st == NULL)
  6175.       || ((s = ffestorag_symbol (st)) == NULL))
  6176.     return;
  6177.  
  6178.   type = ffecom_type_localvar_ (s,
  6179.                 ffesymbol_basictype (s),
  6180.                 ffesymbol_kindtype (s));
  6181.  
  6182.   t = build_decl (VAR_DECL,
  6183.           ffecom_get_identifier_ (ffesymbol_text (s)),
  6184.           type);
  6185.  
  6186.   TREE_STATIC (t) = TREE_STATIC (mt);
  6187.   DECL_INITIAL (t) = NULL_TREE;
  6188.   TREE_ASM_WRITTEN (t) = 1;
  6189.  
  6190.   DECL_RTL (t)
  6191.     = gen_rtx (MEM, TYPE_MODE (type),
  6192.            plus_constant (XEXP (DECL_RTL (mt), 0),
  6193.                   ffestorag_modulo (mst)
  6194.                   + ffestorag_offset (st)));
  6195.  
  6196.   t = start_decl (t, FALSE);
  6197.  
  6198.   finish_decl (t, NULL_TREE, FALSE);
  6199. }
  6200.  
  6201. #endif
  6202. #endif
  6203. /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
  6204.  
  6205.    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
  6206.    (which generates their trees) and then their trees get push_parm_decl'd.
  6207.  
  6208.    The second arg is TRUE if the dummies are for a statement function, in
  6209.    which case lengths are not pushed for character arguments (since they are
  6210.    always known by both the caller and the callee, though the code allows
  6211.    for someday permitting CHAR*(*) stmtfunc dummies).  */
  6212.  
  6213. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  6214. static void
  6215. ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
  6216. {
  6217.   ffebld dummy;
  6218.   ffebld dumlist;
  6219.   ffesymbol s;
  6220.   tree parm;
  6221.  
  6222.   ffecom_transform_only_dummies_ = TRUE;
  6223.  
  6224.   /* First push the parms corresponding to actual dummy "contents".  */
  6225.  
  6226.   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
  6227.     {
  6228.       dummy = ffebld_head (dumlist);
  6229.       switch (ffebld_op (dummy))
  6230.     {
  6231.     case FFEBLD_opSTAR:
  6232.     case FFEBLD_opANY:
  6233.       continue;        /* Forget alternate returns. */
  6234.  
  6235.     default:
  6236.       break;
  6237.     }
  6238.       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
  6239.       s = ffebld_symter (dummy);
  6240.       parm = ffesymbol_hook (s).decl_tree;
  6241.       if (parm == NULL_TREE)
  6242.     {
  6243.       s = ffecom_sym_transform_ (s);
  6244.       parm = ffesymbol_hook (s).decl_tree;
  6245.       assert (parm != NULL_TREE);
  6246.     }
  6247.       if (parm != error_mark_node)
  6248.     push_parm_decl (parm);
  6249.     }
  6250.  
  6251.   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
  6252.  
  6253.   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
  6254.     {
  6255.       dummy = ffebld_head (dumlist);
  6256.       switch (ffebld_op (dummy))
  6257.     {
  6258.     case FFEBLD_opSTAR:
  6259.     case FFEBLD_opANY:
  6260.       continue;        /* Forget alternate returns, they mean
  6261.                    NOTHING! */
  6262.  
  6263.     default:
  6264.       break;
  6265.     }
  6266.       s = ffebld_symter (dummy);
  6267.       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
  6268.     continue;        /* Only looking for CHARACTER arguments. */
  6269.       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
  6270.     continue;        /* Stmtfunc arg with known size needs no
  6271.                    length param. */
  6272.       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
  6273.     continue;        /* Only looking for variables and arrays. */
  6274.       parm = ffesymbol_hook (s).length_tree;
  6275.       assert (parm != NULL_TREE);
  6276.       if (parm != error_mark_node)
  6277.     push_parm_decl (parm);
  6278.     }
  6279.  
  6280.   ffecom_transform_only_dummies_ = FALSE;
  6281. }
  6282.  
  6283. #endif
  6284. /* ffecom_start_progunit_ -- Beginning of program unit
  6285.  
  6286.    Does GNU back end stuff necessary to teach it about the start of its
  6287.    equivalent of a Fortran program unit.  */
  6288.  
  6289. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  6290. static void
  6291. ffecom_start_progunit_ ()
  6292. {
  6293.   ffesymbol fn = ffecom_primary_entry_;
  6294.   ffebld arglist;
  6295.   tree id;            /* Identifier (name) of function. */
  6296.   tree type;            /* Type of function. */
  6297.   tree result;            /* Result of function. */
  6298.   ffeinfoBasictype bt;
  6299.   ffeinfoKindtype kt;
  6300.   bool charfunc;
  6301.   bool cmplxfunc;
  6302.   bool altentries = (ffecom_num_entrypoints_ != 0);
  6303.   bool multi
  6304.   = altentries
  6305.   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
  6306.   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
  6307.   bool main_program = FALSE;
  6308.   int old_lineno = lineno;
  6309.   char *old_input_filename = input_filename;
  6310.   int yes;
  6311.  
  6312.   assert (fn != NULL);
  6313.   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
  6314.  
  6315.   input_filename = ffesymbol_where_filename (fn);
  6316.   lineno = ffesymbol_where_filelinenum (fn);
  6317.  
  6318.   /* c-parse.y indeed does call suspend_momentary and not only ignores the
  6319.      return value, but also never calls resume_momentary, when starting an
  6320.      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
  6321.      same thing.  It shouldn't be a problem since start_function calls
  6322.      temporary_allocation, but it might be necessary.  If it causes a problem
  6323.      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
  6324.      comment appears twice in thist file.  */
  6325.  
  6326.   suspend_momentary ();
  6327.  
  6328.   switch (ffecom_primary_entry_kind_)
  6329.     {
  6330.     case FFEINFO_kindPROGRAM:
  6331.       main_program = TRUE;
  6332.       /* Fall through. */
  6333.     case FFEINFO_kindBLOCKDATA:
  6334.       bt = FFEINFO_basictypeNONE;
  6335.       kt = FFEINFO_kindtypeNONE;
  6336.       type = ffecom_tree_fun_type_void;
  6337.       charfunc = FALSE;
  6338.       cmplxfunc = FALSE;
  6339.       break;
  6340.  
  6341.     case FFEINFO_kindFUNCTION:
  6342.       bt = ffesymbol_basictype (fn);
  6343.       kt = ffesymbol_kindtype (fn);
  6344.       if (bt == FFEINFO_basictypeNONE)
  6345.     {
  6346.       ffeimplic_establish_symbol (fn);
  6347.       if (ffesymbol_funcresult (fn) != NULL)
  6348.         ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
  6349.       bt = ffesymbol_basictype (fn);
  6350.       kt = ffesymbol_kindtype (fn);
  6351.     }
  6352.  
  6353.       if (multi)
  6354.     charfunc = cmplxfunc = FALSE;
  6355.       else if (bt == FFEINFO_basictypeCHARACTER)
  6356.     charfunc = TRUE, cmplxfunc = FALSE;
  6357.       else if ((bt == FFEINFO_basictypeCOMPLEX)
  6358.            && ffesymbol_is_f2c (fn)
  6359.            && !altentries)
  6360.     charfunc = FALSE, cmplxfunc = TRUE;
  6361.       else
  6362.     charfunc = cmplxfunc = FALSE;
  6363.  
  6364.       if (multi || charfunc)
  6365.     type = ffecom_tree_fun_type_void;
  6366.       else if (ffesymbol_is_f2c (fn) && !altentries)
  6367.     type = ffecom_tree_fun_type[bt][kt];
  6368.       else
  6369.     type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
  6370.  
  6371.       if ((type == NULL_TREE)
  6372.       || (TREE_TYPE (type) == NULL_TREE))
  6373.     type = ffecom_tree_fun_type_void;    /* _sym_exec_transition. */
  6374.       break;
  6375.  
  6376.     case FFEINFO_kindSUBROUTINE:
  6377.       bt = FFEINFO_basictypeNONE;
  6378.       kt = FFEINFO_kindtypeNONE;
  6379.       if (ffecom_is_altreturning_)
  6380.     type = ffecom_tree_subr_type;
  6381.       else
  6382.     type = ffecom_tree_fun_type_void;
  6383.       charfunc = FALSE;
  6384.       cmplxfunc = FALSE;
  6385.       break;
  6386.  
  6387.     default:
  6388.       assert ("say what??" == NULL);
  6389.       /* Fall through. */
  6390.     case FFEINFO_kindANY:
  6391.       bt = FFEINFO_basictypeNONE;
  6392.       kt = FFEINFO_kindtypeNONE;
  6393.       type = error_mark_node;
  6394.       charfunc = FALSE;
  6395.       cmplxfunc = FALSE;
  6396.       break;
  6397.     }
  6398.  
  6399.   if (altentries)
  6400.     id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
  6401.                      ffesymbol_text (fn),
  6402.                      0);
  6403. #if FFETARGET_isENFORCED_MAIN
  6404.   else if (main_program)
  6405.     id = ffecom_get_external_identifier_ (FFETARGET_nameENFORCED_MAIN_NAME);
  6406. #endif
  6407.   else
  6408.     id = ffecom_get_external_identifier_ (ffesymbol_text (fn));
  6409.  
  6410.   start_function (id,
  6411.           type,
  6412.           0,        /* nested/inline */
  6413.           !altentries);    /* TREE_PUBLIC */
  6414.  
  6415.   yes = suspend_momentary ();
  6416.  
  6417.   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
  6418.      exec-transitioning needs current_function_decl to be filled in.  So we
  6419.      do these things in two phases. */
  6420.  
  6421.   if (altentries)
  6422.     {                /* 1st arg identifies which entrypoint. */
  6423.       ffecom_which_entrypoint_decl_
  6424.     = build_decl (PARM_DECL,
  6425.               ffecom_get_invented_identifier ("__g77_%s",
  6426.                               "which_entrypoint",
  6427.                               0),
  6428.               integer_type_node);
  6429.       push_parm_decl (ffecom_which_entrypoint_decl_);
  6430.     }
  6431.  
  6432.   if (charfunc
  6433.       || cmplxfunc
  6434.       || multi)
  6435.     {                /* Arg for result (return value). */
  6436.       tree type;
  6437.       tree length;
  6438.  
  6439.       if (charfunc)
  6440.     type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
  6441.       else if (cmplxfunc)
  6442.     type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
  6443.       else
  6444.     type = ffecom_multi_type_node_;
  6445.  
  6446.       result = ffecom_get_invented_identifier ("__g77_result_%s",
  6447.                            ffesymbol_text (fn), 0);
  6448.  
  6449.       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
  6450.  
  6451.       if (charfunc)
  6452.     length = ffecom_char_enhance_arg_ (&type, fn);
  6453.       else
  6454.     length = NULL_TREE;    /* Not ref'd if !charfunc. */
  6455.  
  6456.       type = build_pointer_type (type);
  6457.       result = build_decl (PARM_DECL, result, type);
  6458.  
  6459.       push_parm_decl (result);
  6460.       if (multi)
  6461.     ffecom_multi_retval_ = result;
  6462.       else
  6463.     ffecom_func_result_ = result;
  6464.  
  6465.       if (charfunc)
  6466.     {
  6467.       push_parm_decl (length);
  6468.       ffecom_func_length_ = length;
  6469.     }
  6470.     }
  6471.  
  6472.   if (ffecom_primary_entry_is_proc_)
  6473.     {
  6474.       if (altentries)
  6475.     arglist = ffecom_master_arglist_;
  6476.       else
  6477.     arglist = ffesymbol_dummyargs (fn);
  6478.       ffecom_push_dummy_decls_ (arglist, FALSE);
  6479.     }
  6480.  
  6481.   resume_momentary (yes);
  6482.  
  6483.   store_parm_decls (main_program ? 1 : 0);
  6484.  
  6485.   ffecom_start_compstmt_ ();
  6486.  
  6487.   lineno = old_lineno;
  6488.   input_filename = old_input_filename;
  6489.  
  6490.   /* This handles any symbols still untransformed, in case -g specified.
  6491.      This used to be done in ffecom_finish_progunit, but it turns out to
  6492.      be necessary to do it here so that statement functions are
  6493.      expanded before code.  But don't bother for BLOCK DATA.  */
  6494.  
  6495.   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
  6496.     ffesymbol_drive (ffecom_finish_symbol_transform_);
  6497. }
  6498.  
  6499. #endif
  6500. /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
  6501.  
  6502.    ffesymbol s;
  6503.    ffecom_sym_transform_(s);
  6504.  
  6505.    The ffesymbol_hook info for s is updated with appropriate backend info
  6506.    on the symbol.  */
  6507.  
  6508. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  6509. static ffesymbol
  6510. ffecom_sym_transform_ (ffesymbol s)
  6511. {
  6512.   tree t;            /* Transformed thingy. */
  6513.   tree tlen;            /* Length if CHAR*(*). */
  6514.   bool addr;            /* Is t the address of the thingy? */
  6515.   ffeinfoBasictype bt;
  6516.   ffeinfoKindtype kt;
  6517.   int yes;
  6518.   int old_lineno = lineno;
  6519.   char *old_input_filename = input_filename;
  6520.  
  6521.   if (ffesymbol_sfdummyparent (s) == NULL)
  6522.     {
  6523.       input_filename = ffesymbol_where_filename (s);
  6524.       lineno = ffesymbol_where_filelinenum (s);
  6525.     }
  6526.   else
  6527.     {
  6528.       ffesymbol sf = ffesymbol_sfdummyparent (s);
  6529.  
  6530.       input_filename = ffesymbol_where_filename (sf);
  6531.       lineno = ffesymbol_where_filelinenum (sf);
  6532.     }
  6533.  
  6534.   bt = ffeinfo_basictype (ffebld_info (s));
  6535.   kt = ffeinfo_kindtype (ffebld_info (s));
  6536.  
  6537.   t = NULL_TREE;
  6538.   tlen = NULL_TREE;
  6539.   addr = FALSE;
  6540.  
  6541.   switch (ffesymbol_kind (s))
  6542.     {
  6543.     case FFEINFO_kindNONE:
  6544.       switch (ffesymbol_where (s))
  6545.     {
  6546.     case FFEINFO_whereDUMMY:    /* Subroutine or function. */
  6547.       assert (ffecom_transform_only_dummies_);
  6548.  
  6549.       /* Before 0.4, this could be ENTITY/DUMMY, but see
  6550.          ffestu_sym_end_transition -- no longer true (in particular, if
  6551.          it could be an ENTITY, it _will_ be made one, so that
  6552.          possibility won't come through here).  So we never make length
  6553.          arg for CHARACTER type.  */
  6554.  
  6555.       t = build_decl (PARM_DECL,
  6556.               ffecom_get_identifier_ (ffesymbol_text (s)),
  6557.               ffecom_tree_ptr_to_subr_type);
  6558.       addr = TRUE;
  6559.       break;
  6560.  
  6561.     case FFEINFO_whereGLOBAL:    /* Subroutine or function. */
  6562.       assert (!ffecom_transform_only_dummies_);
  6563.  
  6564.       yes = suspend_momentary ();
  6565.  
  6566.       t = build_decl (FUNCTION_DECL,
  6567.               ffecom_get_external_identifier_ (ffesymbol_text (s)),
  6568.               ffecom_tree_subr_type);    /* Assume subr. */
  6569.       DECL_EXTERNAL (t) = 1;
  6570.       TREE_PUBLIC (t) = 1;
  6571.  
  6572.       t = start_decl (t, FALSE);
  6573.       finish_decl (t, NULL_TREE, FALSE);
  6574.  
  6575.       if (current_function_decl != NULL_TREE)
  6576.         resume_momentary (yes);
  6577.  
  6578.       break;
  6579.  
  6580.     default:
  6581.       assert ("NONE where unexpected" == NULL);
  6582.       /* Fall through. */
  6583.     case FFEINFO_whereANY:
  6584.       break;
  6585.     }
  6586.       break;
  6587.  
  6588.     case FFEINFO_kindENTITY:
  6589.       switch (ffeinfo_where (ffesymbol_info (s)))
  6590.     {
  6591.  
  6592.     case FFEINFO_whereCONSTANT:    /* ~~debugging info needed? */
  6593.       assert (!ffecom_transform_only_dummies_);
  6594.       t = error_mark_node;    /* Shouldn't ever see this in expr. */
  6595.       break;
  6596.  
  6597.     case FFEINFO_whereLOCAL:
  6598.       assert (!ffecom_transform_only_dummies_);
  6599.  
  6600.       {
  6601.         ffestorag st = ffesymbol_storage (s);
  6602.         tree type;
  6603.  
  6604.         assert (st != NULL);
  6605.         if (ffestorag_size (st) == 0)
  6606.           {
  6607.         t = error_mark_node;
  6608.         break;
  6609.           }
  6610.  
  6611.         yes = suspend_momentary ();
  6612.         type = ffecom_type_localvar_ (s, bt, kt);
  6613.         resume_momentary (yes);
  6614.  
  6615.         if (ffestorag_parent (ffesymbol_storage (s)) != NULL)
  6616.           {            /* Child of EQUIVALENCE parent. */
  6617.         ffestorag est;
  6618.         tree et;
  6619.         int yes;
  6620.  
  6621.         if (st == NULL)
  6622.           est = NULL;
  6623.         else
  6624.           est = ffestorag_parent (st);
  6625.  
  6626.         if (est == NULL)
  6627.           et = NULL;
  6628.         else
  6629.           {
  6630.             ffecom_transform_equiv_ (est);
  6631.             et = ffestorag_hook (est);
  6632.  
  6633.             if (! TREE_STATIC (et))
  6634.               put_var_into_stack (et);
  6635.           }
  6636.  
  6637.         yes = suspend_momentary ();
  6638.  
  6639.         if ((et == NULL_TREE)
  6640.             || (est == NULL))
  6641.           t = error_mark_node;
  6642.         else
  6643.           {
  6644.             ffetargetOffset offset;
  6645.  
  6646.             offset = ffestorag_modulo (est)
  6647.               + ffestorag_offset (ffesymbol_storage (s));
  6648.  
  6649.             /* (t_type *) (((void *) &et) + offset */
  6650.  
  6651.             t = convert (TREE_TYPE (null_pointer_node),    /* (void *) */
  6652.                  ffecom_1 (ADDR_EXPR,
  6653.                        build_pointer_type (TREE_TYPE (et)),
  6654.                        et));
  6655.             t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
  6656.                   t,
  6657.                   build_int_2 (offset, 0));
  6658.             t = convert (build_pointer_type (type),
  6659.                  t);
  6660.  
  6661.             addr = TRUE;
  6662.           }
  6663.  
  6664.         resume_momentary (yes);
  6665.           }
  6666.         else
  6667.           {
  6668.         tree initexpr;
  6669.         bool init = (ffesymbol_init (s) != NULL)
  6670.           && (ffebld_op (ffesymbol_init (s)) != FFEBLD_opANY);
  6671.           
  6672.         yes = suspend_momentary ();
  6673.           
  6674.         t = build_decl (VAR_DECL,
  6675.                 ffecom_get_identifier_ (ffesymbol_text (s)),
  6676.                 type);
  6677.           
  6678.         if (init
  6679.             || ffesymbol_namelisted (s)
  6680. #ifdef FFECOM_sizeMAXSTACKITEM
  6681.             || (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM)
  6682. #endif
  6683.             || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
  6684.             && (ffecom_primary_entry_kind_
  6685.                 != FFEINFO_kindBLOCKDATA)
  6686.             && (ffesymbol_save (s) || ffe_is_saveall ())))
  6687.           TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
  6688.         else
  6689.           TREE_STATIC (t) = 0;    /* No need to make static. */
  6690.  
  6691.         if (init || ffe_is_init_local_zero ())
  6692.           DECL_INITIAL (t) = error_mark_node;
  6693.  
  6694.         t = start_decl (t, FALSE);
  6695.         
  6696.         if (init)
  6697.           initexpr = ffecom_expr (ffesymbol_init (s));
  6698.         else if (ffe_is_init_local_zero ())
  6699.           initexpr = ffecom_init_local_zero_ (t);
  6700.         else
  6701.           initexpr = NULL_TREE;    /* Not ref'd if !init. */
  6702.  
  6703.         finish_decl (t, initexpr, FALSE);
  6704.  
  6705.         assert (ffestorag_size (st) * BITS_PER_UNIT
  6706.             == TREE_INT_CST_LOW (DECL_SIZE (t)));
  6707.  
  6708.         resume_momentary (yes);
  6709.           }
  6710.       }
  6711.       break;
  6712.  
  6713.     case FFEINFO_whereRESULT:
  6714.       assert (!ffecom_transform_only_dummies_);
  6715.  
  6716.       if (bt == FFEINFO_basictypeCHARACTER)
  6717.         {            /* Result is already in list of dummies, use
  6718.                    it (& length). */
  6719.           t = ffecom_func_result_;
  6720.           tlen = ffecom_func_length_;
  6721.           addr = TRUE;
  6722.           break;
  6723.         }
  6724.       if ((ffecom_num_entrypoints_ == 0)
  6725.           && (bt == FFEINFO_basictypeCOMPLEX)
  6726.           && (ffesymbol_is_f2c (ffecom_primary_entry_)))
  6727.         {            /* Result is already in list of dummies, use
  6728.                    it. */
  6729.           t = ffecom_func_result_;
  6730.           addr = TRUE;
  6731.           break;
  6732.         }
  6733.       if (ffecom_func_result_ != NULL_TREE)
  6734.         {
  6735.           t = ffecom_func_result_;
  6736.           break;
  6737.         }
  6738.       if ((ffecom_num_entrypoints_ != 0)
  6739.           && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
  6740.         {
  6741.           yes = suspend_momentary ();
  6742.  
  6743.           assert (ffecom_multi_retval_ != NULL_TREE);
  6744.           t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
  6745.                 ffecom_multi_retval_);
  6746.           t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
  6747.                 t, ffecom_multi_fields_[bt][kt]);
  6748.  
  6749.           resume_momentary (yes);
  6750.           break;
  6751.         }
  6752.  
  6753.       yes = suspend_momentary ();
  6754.  
  6755.       t = build_decl (VAR_DECL,
  6756.               ffecom_get_identifier_ (ffesymbol_text (s)),
  6757.               ffecom_tree_type[bt][kt]);
  6758.       TREE_STATIC (t) = 0;    /* Put result on stack. */
  6759.       t = start_decl (t, FALSE);
  6760.       finish_decl (t, NULL_TREE, FALSE);
  6761.  
  6762.       ffecom_func_result_ = t;
  6763.  
  6764.       resume_momentary (yes);
  6765.       break;
  6766.  
  6767.     case FFEINFO_whereDUMMY:
  6768.       {
  6769.         tree type;
  6770.         ffebld dl;
  6771.         ffebld dim;
  6772.         tree low;
  6773.         tree high;
  6774.         tree old_sizes;
  6775.         bool adjustable = FALSE;    /* Conditionally adjustable? */
  6776.  
  6777.         type = ffecom_tree_type[bt][kt];
  6778.         if (ffesymbol_sfdummyparent (s) != NULL)
  6779.           {
  6780.         if (current_function_decl == ffecom_outer_function_decl_)
  6781.           {            /* Exec transition before sfunc
  6782.                        context; get it later. */
  6783.             break;
  6784.           }
  6785.         t = ffecom_get_identifier_ (ffesymbol_text
  6786.                         (ffesymbol_sfdummyparent (s)));
  6787.           }
  6788.         else
  6789.           t = ffecom_get_identifier_ (ffesymbol_text (s));
  6790.  
  6791.         assert (ffecom_transform_only_dummies_);
  6792.  
  6793.         old_sizes = get_pending_sizes ();
  6794.         put_pending_sizes (old_sizes);
  6795.  
  6796.         if (bt == FFEINFO_basictypeCHARACTER)
  6797.           tlen = ffecom_char_enhance_arg_ (&type, s);
  6798.  
  6799.         for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
  6800.           {
  6801.         dim = ffebld_head (dl);
  6802.         assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
  6803.         if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
  6804.           low = ffecom_integer_one_node;
  6805.         else
  6806.           low = ffecom_expr (ffebld_left (dim));
  6807.         assert (ffebld_right (dim) != NULL);
  6808.         if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
  6809.             || ffecom_doing_entry_)
  6810.           high = low;    /* ~~Someday be able to do NULL_TREE here */
  6811.         else
  6812.           high = ffecom_expr (ffebld_right (dim));
  6813.  
  6814.         /* Determine whether array is conditionally adjustable,
  6815.            to decide whether back-end magic is needed.
  6816.  
  6817.            Normally the front end uses the back-end function
  6818.            variable_size to wrap SAVE_EXPR's around expressions
  6819.            affecting the size/shape of an array so that the
  6820.            size/shape info doesn't change during execution
  6821.            of the compiled code even though variables and
  6822.            functions referenced in those expressions might.
  6823.  
  6824.            variable_size also makes sure those saved expressions
  6825.            get evaluated immediately upon entry to the
  6826.            compiled procedure -- the front end normally doesn't
  6827.            have to worry about that.
  6828.  
  6829.            However, there is a problem with this that affects
  6830.            g77's implementation of entry points, and that is
  6831.            that it is _not_ true that each invocation of the
  6832.            compiled procedure is permitted to evaluate
  6833.            array size/shape info -- because it is possible
  6834.            that, for some invocations, that info is invalid (in
  6835.            which case it is "promised" -- i.e. a violation of
  6836.            the Fortran standard -- that the compiled code
  6837.            won't reference the array or its size/shape
  6838.            during that particular invocation).
  6839.  
  6840.            To phrase this in C terms, consider this gcc function:
  6841.  
  6842.              void foo (int *n, float (*a)[*n])
  6843.              {
  6844.                // a is "pointer to array ...", fyi.
  6845.              }
  6846.  
  6847.            Suppose that, for some invocations, it is permitted
  6848.            for a caller of foo to do this:
  6849.  
  6850.                foo (NULL, NULL);
  6851.  
  6852.            Now the _written_ code for foo can take such a call
  6853.            into account by either testing explicitly for whether
  6854.            (a == NULL) || (n == NULL) -- presumably it is
  6855.            not permitted to reference *a in various fashions
  6856.            if (n == NULL) I suppose -- or it can avoid it by
  6857.            looking at other info (other arguments, static/global
  6858.            data, etc.).
  6859.  
  6860.            However, this won't work in gcc 2.5.8 because it'll
  6861.            automatically emit the code to save the "*n"
  6862.            expression, which'll yield a NULL dereference for
  6863.            the "foo (NULL, NULL)" call, something the code
  6864.            for foo cannot prevent.
  6865.  
  6866.            g77 definitely needs to avoid executing such
  6867.            code anytime the pointer to the adjustable array
  6868.            is NULL, because even if its bounds expressions
  6869.            don't have any references to possible "absent"
  6870.            variables like "*n" -- say all variable references
  6871.            are to COMMON variables, i.e. global (though in C,
  6872.            local static could actually make sense) -- the
  6873.            expressions could yield other run-time problems
  6874.            for allowably "dead" values in those variables.
  6875.  
  6876.            For example, let's consider a more complicated
  6877.            version of foo:
  6878.  
  6879.              extern int i;
  6880.              extern int j;
  6881.  
  6882.              void foo (float (*a)[i/j])
  6883.              {
  6884.                ...
  6885.              }
  6886.  
  6887.            The above is (essentially) quite valid for Fortran
  6888.            but, again, for a call like "foo (NULL);", it is
  6889.            permitted for i and j to be undefined when the
  6890.            call is made.  If j happened to be zero, for
  6891.            example, emitting the code to evaluate "i/j"
  6892.            could result in a run-time error.
  6893.  
  6894.            Offhand, though I don't have my F77 or F90
  6895.            standards handy, it might even be valid for a
  6896.            bounds expression to contain a function reference,
  6897.            in which case I doubt it is permitted for an
  6898.            implementation to invoke that function in the
  6899.            Fortran case involved here (invocation of an
  6900.            alternate ENTRY point that doesn't have the adjustable
  6901.            array as one of its arguments).
  6902.  
  6903.            So, the code that the compiler would normally emit
  6904.            to preevaluate the size/shape info for an
  6905.            adjustable array _must not_ be executed at run time
  6906.            in certain cases.  Specifically, for Fortran,
  6907.            the case is when the pointer to the adjustable
  6908.            array == NULL.  (For gnu-ish C, it might be nice
  6909.            for the source code itself to specify an expression
  6910.            that, if TRUE, inhibits execution of the code.  Or
  6911.            reverse the sense for elegance.)
  6912.  
  6913.            (Note that g77 could use a different test than NULL,
  6914.            actually, since it happens to always pass an
  6915.            integer to the called function that specifies which
  6916.            entry point is being invoked.  Hmm, this might
  6917.            solve the next problem.)
  6918.  
  6919.            One way a user could, I suppose, write "foo" so
  6920.            it works is to insert COND_EXPR's for the
  6921.            size/shape info so the dangerous stuff isn't
  6922.            actually done, as in:
  6923.  
  6924.              void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
  6925.              {
  6926.                ...
  6927.              }
  6928.  
  6929.            The next problem is that the front end needs to
  6930.            be able to tell the back end about the array's
  6931.            decl _before_ it tells it about the conditional
  6932.            expression to inhibit evaluation of size/shape info,
  6933.            as shown above.
  6934.  
  6935.            To solve this, the front end needs to be able
  6936.            to give the back end the expression to inhibit
  6937.            generation of the preevaluation code _after_
  6938.            it makes the decl for the adjustable array.
  6939.  
  6940.            Until then, the above example using the COND_EXPR
  6941.            doesn't pass muster with gcc because the "(a == NULL)"
  6942.            part has a reference to "a", which is still
  6943.            undefined at that point.
  6944.  
  6945.            g77 will therefore use a different mechanism in the
  6946.            meantime.  */
  6947.  
  6948.         if (!adjustable
  6949.             && ((TREE_CODE (low) != INTEGER_CST)
  6950.             || (TREE_CODE (high) != INTEGER_CST)))
  6951.           adjustable = TRUE;
  6952.  
  6953. #if 0                /* Old approach -- see below. */
  6954.         if (TREE_CODE (low) != INTEGER_CST)
  6955.           low = ffecom_3 (COND_EXPR, integer_type_node,
  6956.                   ffecom_adjarray_passed_ (s),
  6957.                   low,
  6958.                   ffecom_integer_zero_node);
  6959.  
  6960.         if (TREE_CODE (high) != INTEGER_CST)
  6961.           high = ffecom_3 (COND_EXPR, integer_type_node,
  6962.                    ffecom_adjarray_passed_ (s),
  6963.                    high,
  6964.                    ffecom_integer_zero_node);
  6965. #endif
  6966.  
  6967.         /* ~~~gcc/stor-layout.c/layout_type should do this,
  6968.            probably.  Fixes 950302-1.f.  */
  6969.  
  6970.         if (TREE_CODE (low) != INTEGER_CST)
  6971.           low = variable_size (low);
  6972.  
  6973.         type
  6974.           = build_array_type
  6975.             (type,
  6976.              build_range_type (ffecom_integer_type_node,
  6977.                        low, high));
  6978.           }
  6979.         if ((ffesymbol_sfdummyparent (s) == NULL)
  6980.         || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
  6981.           {
  6982.         type = build_pointer_type (type);
  6983.         addr = TRUE;
  6984.           }
  6985.  
  6986.         t = build_decl (PARM_DECL, t, type);
  6987.  
  6988.         /* If this arg is present in every entry point's list of
  6989.            dummy args, then we're done.  */
  6990.  
  6991.         if (ffesymbol_numentries (s)
  6992.         == (ffecom_num_entrypoints_ + 1))
  6993.           break;
  6994.  
  6995. #if 1
  6996.  
  6997.         /* If variable_size in stor-layout has been called during
  6998.            the above, then get_pending_sizes should have the
  6999.            yet-to-be-evaluated saved expressions pending.
  7000.            Make the whole lot of them get emitted, conditionally
  7001.            on whether the array decl ("t" above) is not NULL.  */
  7002.  
  7003.         {
  7004.           tree sizes = get_pending_sizes ();
  7005.           tree tem;
  7006.  
  7007.           for (tem = sizes;
  7008.            tem != old_sizes;
  7009.            tem = TREE_CHAIN (tem))
  7010.         {
  7011.           tree temv = TREE_VALUE (tem);
  7012.  
  7013.           if (sizes == tem)
  7014.             sizes = temv;
  7015.           else
  7016.             sizes
  7017.               = ffecom_2 (COMPOUND_EXPR,
  7018.                   TREE_TYPE (sizes),
  7019.                   temv,
  7020.                   sizes);
  7021.         }
  7022.  
  7023.           if (sizes != tem)
  7024.         {
  7025.           sizes
  7026.             = ffecom_3 (COND_EXPR,
  7027.                 TREE_TYPE (sizes),
  7028.                 ffecom_2 (NE_EXPR,
  7029.                       integer_type_node,
  7030.                       t,
  7031.                       null_pointer_node),
  7032.                 sizes,
  7033.                 convert (TREE_TYPE (sizes),
  7034.                      integer_zero_node));
  7035.           sizes = ffecom_save_tree (sizes);
  7036.  
  7037.           sizes
  7038.             = tree_cons (NULL_TREE, sizes, tem);
  7039.         }
  7040.  
  7041.           if (sizes)
  7042.         put_pending_sizes (sizes);
  7043.         }
  7044.  
  7045. #else
  7046. #if 0
  7047.         if (adjustable
  7048.         && (ffesymbol_numentries (s)
  7049.             != ffecom_num_entrypoints_ + 1))
  7050.           DECL_SOMETHING (t)
  7051.         = ffecom_2 (NE_EXPR, integer_type_node,
  7052.                 t,
  7053.                 null_pointer_node);
  7054. #else
  7055. #if 0
  7056.         if (adjustable
  7057.         && (ffesymbol_numentries (s)
  7058.             != ffecom_num_entrypoints_ + 1))
  7059.           {
  7060.         ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
  7061.         ffebad_here (0, ffesymbol_where_line (s),
  7062.                  ffesymbol_where_column (s));
  7063.         ffebad_string (ffesymbol_text (s));
  7064.         ffebad_finish ();
  7065.           }
  7066. #endif
  7067. #endif
  7068. #endif
  7069.       }
  7070.       break;
  7071.  
  7072.     case FFEINFO_whereCOMMON:
  7073.       {
  7074.         ffesymbol cs;
  7075.         ffeglobal cg;
  7076.         tree ct;
  7077.         ffestorag st = ffesymbol_storage (s);
  7078.         tree type;
  7079.         int yes;
  7080.  
  7081.         cs = ffesymbol_common (s);    /* The COMMON area itself.  */
  7082.         if (st != NULL)    /* Else not laid out. */
  7083.           ffecom_transform_common_ (cs);
  7084.  
  7085.         yes = suspend_momentary ();
  7086.  
  7087.         type = ffecom_type_localvar_ (s, bt, kt);
  7088.  
  7089.         cg = ffesymbol_global (cs);    /* The global COMMON info.  */
  7090.         if ((cg == NULL)
  7091.         || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
  7092.           ct = NULL_TREE;
  7093.         else
  7094.           ct = ffeglobal_hook (cg);    /* The common area's tree.  */
  7095.  
  7096.         if ((ct == NULL_TREE)
  7097.         || (st == NULL))
  7098.           t = error_mark_node;
  7099.         else
  7100.           {
  7101.         ffetargetOffset offset;
  7102.  
  7103.         offset = ffestorag_modulo (ffesymbol_storage (cs))
  7104.           + ffestorag_offset (st);
  7105.  
  7106.         /* (t_type *) (((void *) &ct) + offset */
  7107.  
  7108.         t = convert (TREE_TYPE (null_pointer_node),    /* (void *) */
  7109.                  ffecom_1 (ADDR_EXPR,
  7110.                        build_pointer_type (TREE_TYPE (ct)),
  7111.                        ct));
  7112.         t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
  7113.                   t,
  7114.                   build_int_2 (offset, 0));
  7115.         t = convert (build_pointer_type (type),
  7116.                  t);
  7117.  
  7118.         addr = TRUE;
  7119.           }
  7120.  
  7121.         resume_momentary (yes);
  7122.       }
  7123.       break;
  7124.  
  7125.     case FFEINFO_whereIMMEDIATE:
  7126.     case FFEINFO_whereGLOBAL:
  7127.     case FFEINFO_whereFLEETING:
  7128.     case FFEINFO_whereFLEETING_CADDR:
  7129.     case FFEINFO_whereFLEETING_IADDR:
  7130.     case FFEINFO_whereINTRINSIC:
  7131.     case FFEINFO_whereCONSTANT_SUBOBJECT:
  7132.     default:
  7133.       assert ("ENTITY where unheard of" == NULL);
  7134.       /* Fall through. */
  7135.     case FFEINFO_whereANY:
  7136.       t = error_mark_node;
  7137.       break;
  7138.     }
  7139.       break;
  7140.  
  7141.     case FFEINFO_kindFUNCTION:
  7142.       switch (ffeinfo_where (ffesymbol_info (s)))
  7143.     {
  7144.     case FFEINFO_whereLOCAL:    /* Me. */
  7145.       assert (!ffecom_transform_only_dummies_);
  7146.       t = current_function_decl;
  7147.       break;
  7148.  
  7149.     case FFEINFO_whereGLOBAL:
  7150.       assert (!ffecom_transform_only_dummies_);
  7151.  
  7152.       yes = suspend_momentary ();
  7153.  
  7154.       if (ffesymbol_is_f2c (s)
  7155.           && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
  7156.         t = ffecom_tree_fun_type[bt][kt];
  7157.       else
  7158.         t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
  7159.  
  7160.       t = build_decl (FUNCTION_DECL,
  7161.               ffecom_get_external_identifier_ (ffesymbol_text (s)),
  7162.               t);
  7163.       DECL_EXTERNAL (t) = 1;
  7164.       TREE_PUBLIC (t) = 1;
  7165.  
  7166.       t = start_decl (t, FALSE);
  7167.       finish_decl (t, NULL_TREE, FALSE);
  7168.  
  7169.       if (current_function_decl != NULL_TREE)
  7170.         resume_momentary (yes);
  7171.  
  7172.       break;
  7173.  
  7174.     case FFEINFO_whereDUMMY:
  7175.       assert (ffecom_transform_only_dummies_);
  7176.  
  7177.       if (ffesymbol_is_f2c (s)
  7178.           && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
  7179.         t = ffecom_tree_ptr_to_fun_type[bt][kt];
  7180.       else
  7181.         t = build_pointer_type
  7182.           (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
  7183.  
  7184.       t = build_decl (PARM_DECL,
  7185.               ffecom_get_identifier_ (ffesymbol_text (s)),
  7186.               t);
  7187.       addr = TRUE;
  7188.       break;
  7189.  
  7190.     case FFEINFO_whereCONSTANT:    /* Statement function. */
  7191.       assert (!ffecom_transform_only_dummies_);
  7192.       t = ffecom_gen_sfuncdef_ (s, bt, kt);
  7193.       break;
  7194.  
  7195.     case FFEINFO_whereINTRINSIC:
  7196.       assert (!ffecom_transform_only_dummies_);
  7197.       break;        /* Let actual references generate their
  7198.                    decls. */
  7199.  
  7200.     default:
  7201.       assert ("FUNCTION where unheard of" == NULL);
  7202.       /* Fall through. */
  7203.     case FFEINFO_whereANY:
  7204.       t = error_mark_node;
  7205.       break;
  7206.     }
  7207.       break;
  7208.  
  7209.     case FFEINFO_kindSUBROUTINE:
  7210.       switch (ffeinfo_where (ffesymbol_info (s)))
  7211.     {
  7212.     case FFEINFO_whereLOCAL:    /* Me. */
  7213.       assert (!ffecom_transform_only_dummies_);
  7214.       t = current_function_decl;
  7215.       break;
  7216.  
  7217.     case FFEINFO_whereGLOBAL:
  7218.       assert (!ffecom_transform_only_dummies_);
  7219.  
  7220.       yes = suspend_momentary ();
  7221.  
  7222.       t = build_decl (FUNCTION_DECL,
  7223.                ffecom_get_external_identifier_ (ffesymbol_text (s)),
  7224.               ffecom_tree_subr_type);
  7225.       DECL_EXTERNAL (t) = 1;
  7226.       TREE_PUBLIC (t) = 1;
  7227.  
  7228.       t = start_decl (t, FALSE);
  7229.       finish_decl (t, NULL_TREE, FALSE);
  7230.  
  7231.       if (current_function_decl != NULL_TREE)
  7232.         resume_momentary (yes);
  7233.  
  7234.       break;
  7235.  
  7236.     case FFEINFO_whereDUMMY:
  7237.       assert (ffecom_transform_only_dummies_);
  7238.  
  7239.       t = build_decl (PARM_DECL,
  7240.               ffecom_get_identifier_ (ffesymbol_text (s)),
  7241.               ffecom_tree_ptr_to_subr_type);
  7242.       addr = TRUE;
  7243.       break;
  7244.  
  7245.     case FFEINFO_whereINTRINSIC:
  7246.       assert (!ffecom_transform_only_dummies_);
  7247.       break;        /* Let actual references generate their
  7248.                    decls. */
  7249.  
  7250.     default:
  7251.       assert ("SUBROUTINE where unheard of" == NULL);
  7252.       /* Fall through. */
  7253.     case FFEINFO_whereANY:
  7254.       t = error_mark_node;
  7255.       break;
  7256.     }
  7257.       break;
  7258.  
  7259.     case FFEINFO_kindPROGRAM:
  7260.       switch (ffeinfo_where (ffesymbol_info (s)))
  7261.     {
  7262.     case FFEINFO_whereLOCAL:    /* Me. */
  7263.       assert (!ffecom_transform_only_dummies_);
  7264.       t = current_function_decl;
  7265.       break;
  7266.  
  7267.     case FFEINFO_whereCOMMON:
  7268.     case FFEINFO_whereDUMMY:
  7269.     case FFEINFO_whereGLOBAL:
  7270.     case FFEINFO_whereRESULT:
  7271.     case FFEINFO_whereFLEETING:
  7272.     case FFEINFO_whereFLEETING_CADDR:
  7273.     case FFEINFO_whereFLEETING_IADDR:
  7274.     case FFEINFO_whereIMMEDIATE:
  7275.     case FFEINFO_whereINTRINSIC:
  7276.     case FFEINFO_whereCONSTANT:
  7277.     case FFEINFO_whereCONSTANT_SUBOBJECT:
  7278.     default:
  7279.       assert ("PROGRAM where unheard of" == NULL);
  7280.       /* Fall through. */
  7281.     case FFEINFO_whereANY:
  7282.       t = error_mark_node;
  7283.       break;
  7284.     }
  7285.       break;
  7286.  
  7287.     case FFEINFO_kindBLOCKDATA:
  7288.       switch (ffeinfo_where (ffesymbol_info (s)))
  7289.     {
  7290.     case FFEINFO_whereLOCAL:    /* Me. */
  7291.       assert (!ffecom_transform_only_dummies_);
  7292.       t = current_function_decl;
  7293.       break;
  7294.  
  7295.     case FFEINFO_whereGLOBAL:
  7296.       assert (!ffecom_transform_only_dummies_);
  7297.  
  7298.       yes = suspend_momentary ();
  7299.  
  7300.       t = build_decl (FUNCTION_DECL,
  7301.                ffecom_get_external_identifier_ (ffesymbol_text (s)),
  7302.               ffecom_tree_blockdata_type);
  7303.       DECL_EXTERNAL (t) = 1;
  7304.       TREE_PUBLIC (t) = 1;
  7305.  
  7306.       t = start_decl (t, FALSE);
  7307.       finish_decl (t, NULL_TREE, FALSE);
  7308.  
  7309.       if (current_function_decl != NULL_TREE)
  7310.         resume_momentary (yes);
  7311.  
  7312.       break;
  7313.  
  7314.     case FFEINFO_whereCOMMON:
  7315.     case FFEINFO_whereDUMMY:
  7316.     case FFEINFO_whereRESULT:
  7317.     case FFEINFO_whereFLEETING:
  7318.     case FFEINFO_whereFLEETING_CADDR:
  7319.     case FFEINFO_whereFLEETING_IADDR:
  7320.     case FFEINFO_whereIMMEDIATE:
  7321.     case FFEINFO_whereINTRINSIC:
  7322.     case FFEINFO_whereCONSTANT:
  7323.     case FFEINFO_whereCONSTANT_SUBOBJECT:
  7324.     default:
  7325.       assert ("BLOCKDATA where unheard of" == NULL);
  7326.       /* Fall through. */
  7327.     case FFEINFO_whereANY:
  7328.       t = error_mark_node;
  7329.       break;
  7330.     }
  7331.       break;
  7332.  
  7333.     case FFEINFO_kindCOMMON:
  7334.       switch (ffeinfo_where (ffesymbol_info (s)))
  7335.     {
  7336.     case FFEINFO_whereLOCAL:
  7337.       assert (!ffecom_transform_only_dummies_);
  7338.       ffecom_transform_common_ (s);
  7339.       break;
  7340.  
  7341.     case FFEINFO_whereNONE:
  7342.     case FFEINFO_whereCOMMON:
  7343.     case FFEINFO_whereDUMMY:
  7344.     case FFEINFO_whereGLOBAL:
  7345.     case FFEINFO_whereRESULT:
  7346.     case FFEINFO_whereFLEETING:
  7347.     case FFEINFO_whereFLEETING_CADDR:
  7348.     case FFEINFO_whereFLEETING_IADDR:
  7349.     case FFEINFO_whereIMMEDIATE:
  7350.     case FFEINFO_whereINTRINSIC:
  7351.     case FFEINFO_whereCONSTANT:
  7352.     case FFEINFO_whereCONSTANT_SUBOBJECT:
  7353.     default:
  7354.       assert ("COMMON where unheard of" == NULL);
  7355.       /* Fall through. */
  7356.     case FFEINFO_whereANY:
  7357.       t = error_mark_node;
  7358.       break;
  7359.     }
  7360.       break;
  7361.  
  7362.     case FFEINFO_kindCONSTRUCT:
  7363.       switch (ffeinfo_where (ffesymbol_info (s)))
  7364.     {
  7365.     case FFEINFO_whereLOCAL:
  7366.       assert (!ffecom_transform_only_dummies_);
  7367.       break;
  7368.  
  7369.     case FFEINFO_whereNONE:
  7370.     case FFEINFO_whereCOMMON:
  7371.     case FFEINFO_whereDUMMY:
  7372.     case FFEINFO_whereGLOBAL:
  7373.     case FFEINFO_whereRESULT:
  7374.     case FFEINFO_whereFLEETING:
  7375.     case FFEINFO_whereFLEETING_CADDR:
  7376.     case FFEINFO_whereFLEETING_IADDR:
  7377.     case FFEINFO_whereIMMEDIATE:
  7378.     case FFEINFO_whereINTRINSIC:
  7379.     case FFEINFO_whereCONSTANT:
  7380.     case FFEINFO_whereCONSTANT_SUBOBJECT:
  7381.     default:
  7382.       assert ("CONSTRUCT where unheard of" == NULL);
  7383.       /* Fall through. */
  7384.     case FFEINFO_whereANY:
  7385.       t = error_mark_node;
  7386.       break;
  7387.     }
  7388.       break;
  7389.  
  7390.     case FFEINFO_kindNAMELIST:
  7391.       switch (ffeinfo_where (ffesymbol_info (s)))
  7392.     {
  7393.     case FFEINFO_whereLOCAL:
  7394.       assert (!ffecom_transform_only_dummies_);
  7395.       t = ffecom_transform_namelist_ (s);
  7396.       break;
  7397.  
  7398.     case FFEINFO_whereNONE:
  7399.     case FFEINFO_whereCOMMON:
  7400.     case FFEINFO_whereDUMMY:
  7401.     case FFEINFO_whereGLOBAL:
  7402.     case FFEINFO_whereRESULT:
  7403.     case FFEINFO_whereFLEETING:
  7404.     case FFEINFO_whereFLEETING_CADDR:
  7405.     case FFEINFO_whereFLEETING_IADDR:
  7406.     case FFEINFO_whereIMMEDIATE:
  7407.     case FFEINFO_whereINTRINSIC:
  7408.     case FFEINFO_whereCONSTANT:
  7409.     case FFEINFO_whereCONSTANT_SUBOBJECT:
  7410.     default:
  7411.       assert ("NAMELIST where unheard of" == NULL);
  7412.       /* Fall through. */
  7413.     case FFEINFO_whereANY:
  7414.       t = error_mark_node;
  7415.       break;
  7416.     }
  7417.       break;
  7418.  
  7419.     default:
  7420.       assert ("kind unheard of" == NULL);
  7421.       /* Fall through. */
  7422.     case FFEINFO_kindANY:
  7423.       t = error_mark_node;
  7424.       break;
  7425.     }
  7426.  
  7427.   ffesymbol_hook (s).decl_tree = t;
  7428.   ffesymbol_hook (s).length_tree = tlen;
  7429.   ffesymbol_hook (s).addr = addr;
  7430.  
  7431.   lineno = old_lineno;
  7432.   input_filename = old_input_filename;
  7433.  
  7434.   return s;
  7435. }
  7436.  
  7437. #endif
  7438. /* Transform into ASSIGNable symbol.
  7439.  
  7440.    Symbol has already been transformed, but for whatever reason, the
  7441.    resulting decl_tree has been deemed not usable for an ASSIGN target.
  7442.    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
  7443.    another local symbol of type void * and stuff that in the length_tree
  7444.    argument.  The F77/F90 standards allow this implementation.  */
  7445.  
  7446. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  7447. static ffesymbol
  7448. ffecom_sym_transform_assign_ (ffesymbol s)
  7449. {
  7450.   tree t;            /* Transformed thingy. */
  7451.   int yes;
  7452.   int old_lineno = lineno;
  7453.   char *old_input_filename = input_filename;
  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.   assert (!ffecom_transform_only_dummies_);
  7469.  
  7470.   yes = suspend_momentary ();
  7471.  
  7472.   t = build_decl (VAR_DECL,
  7473.           ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
  7474.                            ffesymbol_text (s),
  7475.                            0),
  7476.           TREE_TYPE (null_pointer_node));
  7477.   TREE_STATIC (t) = 0;    /* No need to make static. */
  7478.  
  7479.   t = start_decl (t, FALSE);
  7480.   finish_decl (t, NULL_TREE, FALSE);
  7481.  
  7482.   resume_momentary (yes);
  7483.  
  7484.   ffesymbol_hook (s).length_tree = t;
  7485.  
  7486.   lineno = old_lineno;
  7487.   input_filename = old_input_filename;
  7488.  
  7489.   return s;
  7490. }
  7491.  
  7492. #endif
  7493. /* Implement COMMON area in back end.
  7494.  
  7495.    Because COMMON-based variables can be referenced in the dimension
  7496.    expressions of dummy (adjustable) arrays, and because dummies
  7497.    (in the gcc back end) need to be put in the outer binding level
  7498.    of a function (which has two binding levels, the outer holding
  7499.    the dummies and the inner holding the other vars), special care
  7500.    must be taken to handle COMMON areas.
  7501.  
  7502.    The current strategy is basically to always tell the back end about
  7503.    the COMMON area as a top-level external reference to just a block
  7504.    of storage of the master type of that area (e.g. integer, real,
  7505.    character, whatever -- not a structure).  As a distinct action,
  7506.    if initial values are provided, tell the back end about the area
  7507.    as a top-level non-external (initialized) area and remember not to
  7508.    allow further initialization or expansion of the area.  Meanwhile,
  7509.    if no initialization happens at all, tell the back end about
  7510.    the largest size we've seen declared so the space does get reserved.
  7511.    (This function doesn't handle all that stuff, but it does some
  7512.    of the important things.)
  7513.  
  7514.    Meanwhile, for COMMON variables themselves, just keep creating
  7515.    references like *((float *) (&common_area + offset)) each time
  7516.    we reference the variable.  In other words, don't make a VAR_DECL
  7517.    or any kind of component reference (like we used to do before 0.4),
  7518.    though we might do that as well just for debugging purposes (and
  7519.    stuff the rtl with the appropriate offset expression).  */
  7520.  
  7521. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  7522. static void
  7523. ffecom_transform_common_ (ffesymbol s)
  7524. {
  7525.   ffestorag st = ffesymbol_storage (s);
  7526.   ffeglobal g = ffesymbol_global (s);
  7527.   tree cbt;
  7528.   tree cbtype;
  7529.   tree init;
  7530.   bool is_init = (ffestorag_init (st) != NULL)
  7531.   && (ffebld_op (ffestorag_init (st)) != FFEBLD_opANY);
  7532.  
  7533.   assert (st != NULL);
  7534.  
  7535.   if ((g == NULL)
  7536.       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
  7537.     return;
  7538.  
  7539.   /* First update the size of the area in global terms.  */
  7540.  
  7541.   ffeglobal_size_common (s, ffestorag_size (st));
  7542.  
  7543.   cbt = ffeglobal_hook (g);
  7544.  
  7545.   /* If we already have declared this common block for a previous program
  7546.      unit, and either we already initialized it or we don't have new
  7547.      initialization for it, just return what we have without changing it.  */
  7548.  
  7549.   if ((cbt != NULL_TREE)
  7550.       && (!is_init
  7551.       || !DECL_EXTERNAL (ffeglobal_hook (g))))
  7552.     return;
  7553.  
  7554.   /* Process inits.  */
  7555.  
  7556.   if (is_init)
  7557.     {
  7558.       init = ffecom_expr (ffestorag_init (st));
  7559.       if (init == error_mark_node)
  7560.     {            /* Hopefully the back end complained! */
  7561.       init = NULL_TREE;
  7562.       if (cbt != NULL_TREE)
  7563.         return;
  7564.     }
  7565.     }
  7566.   else
  7567.     init = NULL_TREE;
  7568.  
  7569.   push_obstacks_nochange ();
  7570.   end_temporary_allocation ();
  7571.  
  7572.   /* cbtype must be permanently allocated!  */
  7573.  
  7574.   if (init)
  7575.     cbtype = build_array_type (char_type_node,
  7576.                    build_range_type (integer_type_node,
  7577.                          integer_one_node,
  7578.                          build_int_2
  7579.                          (ffeglobal_size (g),
  7580.                           0)));
  7581.   else
  7582.     cbtype = build_array_type (char_type_node, NULL_TREE);
  7583.                    
  7584.   if (cbt == NULL_TREE)
  7585.     {
  7586.       cbt
  7587.     = build_decl (VAR_DECL,
  7588.               ffecom_get_external_identifier_ (ffesymbol_text (s)),
  7589.               cbtype);
  7590.       DECL_EXTERNAL (cbt) = init ? 0 : 1;
  7591.       TREE_STATIC (cbt) = 1;
  7592.       TREE_PUBLIC (cbt) = 1;
  7593.       if (init)
  7594.     DECL_INITIAL (cbt) = error_mark_node;
  7595.     }
  7596.   else
  7597.     {
  7598.       assert (init);
  7599.  
  7600.       TREE_TYPE (cbt) = cbtype;
  7601.       DECL_EXTERNAL (cbt) = 0;
  7602.       DECL_INITIAL (cbt) = error_mark_node;
  7603.     }
  7604.  
  7605.   cbt = start_decl (cbt, TRUE);
  7606.   if (ffeglobal_hook (g) != NULL)
  7607.     assert (cbt == ffeglobal_hook (g));
  7608.  
  7609.   assert (!init || !DECL_EXTERNAL (cbt));
  7610.  
  7611.   /* Make sure that any type can live in COMMON and be referenced
  7612.      without getting a bus error.  We could pick the most restrictive
  7613.      alignment of all entities actually placed in the COMMON, but
  7614.      this seems easy enough.  */
  7615.  
  7616.   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
  7617.  
  7618.   finish_decl (cbt, init, TRUE);
  7619.  
  7620.   if (is_init)
  7621.     ffestorag_set_init (st, ffebld_new_any ());
  7622.  
  7623.   if (init)
  7624.     {
  7625.       assert (DECL_SIZE (cbt) != NULL_TREE);
  7626.       assert (TREE_CODE (DECL_SIZE (cbt)) == INTEGER_CST);
  7627.       assert (TREE_INT_CST_HIGH (DECL_SIZE (cbt)) == 0);
  7628.       assert (TREE_INT_CST_LOW (DECL_SIZE (cbt))
  7629.           == (ffeglobal_size (g) * BITS_PER_UNIT));
  7630.     }
  7631.  
  7632.   ffeglobal_set_hook (g, cbt);
  7633.  
  7634.   ffestorag_set_hook (st, cbt);
  7635.  
  7636.   resume_temporary_allocation ();
  7637.   pop_obstacks ();
  7638. }
  7639.  
  7640. #endif
  7641. /* Make master area for local EQUIVALENCE.  */
  7642.  
  7643. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  7644. static void
  7645. ffecom_transform_equiv_ (ffestorag eqst)
  7646. {
  7647.   tree eqt;
  7648.   tree eqtype;
  7649.   tree init;
  7650.   bool is_init = (ffestorag_init (eqst) != NULL)
  7651.     && (ffebld_op (ffestorag_init (eqst)) != FFEBLD_opANY);
  7652.   int yes;
  7653.   static int mynumber = 0;
  7654.  
  7655.   assert (eqst != NULL);
  7656.  
  7657.   eqt = ffestorag_hook (eqst);
  7658.  
  7659.   if (eqt != NULL_TREE)
  7660.     return;
  7661.  
  7662.   /* Process inits.  */
  7663.  
  7664.   if (is_init)
  7665.     {
  7666.       init = ffecom_expr (ffestorag_init (eqst));
  7667.       if (init == error_mark_node)
  7668.     init = NULL_TREE;    /* Hopefully the back end complained! */
  7669.     }
  7670.   else if (ffe_is_init_local_zero ())
  7671.     init = error_mark_node;
  7672.   else
  7673.     init = NULL_TREE;
  7674.  
  7675.   ffecom_member_namelisted_ = FALSE;
  7676.   ffestorag_drive (ffestorag_list_equivs (eqst),
  7677.            &ffecom_member_phase1_,
  7678.            eqst);
  7679.  
  7680.   yes = suspend_momentary ();
  7681.  
  7682.   if (is_init && (init != NULL))
  7683.     eqtype = TREE_TYPE (init);
  7684.   else
  7685.     eqtype = build_array_type (char_type_node,
  7686.                    build_range_type (integer_type_node,
  7687.                          integer_one_node,
  7688.                          build_int_2
  7689.                          (ffestorag_size (eqst),
  7690.                           0)));
  7691.  
  7692.   eqt = build_decl (VAR_DECL,
  7693.             ffecom_get_invented_identifier ("__g77_equiv_%d", NULL,
  7694.                             mynumber++),
  7695.             eqtype);
  7696.   DECL_EXTERNAL (eqt) = 0;
  7697.   if (is_init
  7698.       || ffecom_member_namelisted_
  7699. #ifdef FFECOM_sizeMAXSTACKITEM
  7700.       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
  7701. #endif
  7702.       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
  7703.       && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
  7704.       && (ffestorag_save (eqst) || ffe_is_saveall ())))
  7705.     TREE_STATIC (eqt) = 1;
  7706.   else
  7707.     TREE_STATIC (eqt) = 0;
  7708.   TREE_PUBLIC (eqt) = 0;
  7709.   DECL_CONTEXT (eqt) = current_function_decl;
  7710.   if (init)
  7711.     DECL_INITIAL (eqt) = error_mark_node;
  7712.   else
  7713.     DECL_INITIAL (eqt) = NULL_TREE;
  7714.  
  7715.   eqt = start_decl (eqt, FALSE);
  7716.  
  7717.   /* Make sure that any type can live in EQUIVALENCE and be referenced
  7718.      without getting a bus error.  We could pick the most restrictive
  7719.      alignment of all entities actually placed in the EQUIVALENCE, but
  7720.      this seems easy enough.  */
  7721.  
  7722.   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
  7723.  
  7724.   if (!is_init && ffe_is_init_local_zero ())
  7725.     init = ffecom_init_local_zero_ (eqt);
  7726.  
  7727.   finish_decl (eqt, init, FALSE);
  7728.  
  7729.   if (is_init)
  7730.     ffestorag_set_init (eqst, ffebld_new_any ());
  7731.  
  7732.   assert (ffestorag_size (eqst) * BITS_PER_UNIT
  7733.       == TREE_INT_CST_LOW (DECL_SIZE (eqt)));
  7734.  
  7735.   ffestorag_set_hook (eqst, eqt);
  7736.  
  7737. #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
  7738.   ffestorag_drive (ffestorag_list_equivs (eqst),
  7739.            &ffecom_member_phase2_,
  7740.            eqst);
  7741. #endif
  7742.  
  7743.   resume_momentary (yes);
  7744. }
  7745.  
  7746. #endif
  7747. /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
  7748.  
  7749. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  7750. static tree
  7751. ffecom_transform_namelist_ (ffesymbol s)
  7752. {
  7753.   tree nmlt;
  7754.   tree nmltype = ffecom_type_namelist_ ();
  7755.   tree nmlinits;
  7756.   tree nameinit;
  7757.   tree varsinit;
  7758.   tree nvarsinit;
  7759.   tree field;
  7760.   int yes;
  7761.   int i;
  7762.   static int mynumber = 0;
  7763.  
  7764.   yes = suspend_momentary ();
  7765.  
  7766.   nmlt = build_decl (VAR_DECL,
  7767.              ffecom_get_invented_identifier ("__g77_namelist_%d",
  7768.                              NULL, mynumber++),
  7769.              nmltype);
  7770.   TREE_STATIC (nmlt) = 1;
  7771.   DECL_INITIAL (nmlt) = error_mark_node;
  7772.  
  7773.   nmlt = start_decl (nmlt, FALSE);
  7774.  
  7775.   /* Process inits.  */
  7776.  
  7777.   nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s))) + 1,
  7778.                        ffesymbol_text (s));
  7779.   TREE_TYPE (nameinit)
  7780.     = build_type_variant
  7781.     (build_array_type
  7782.      (char_type_node,
  7783.       build_range_type (ffecom_f2c_ftnlen_type_node,
  7784.             ffecom_f2c_ftnlen_one_node,
  7785.             convert (ffecom_f2c_ftnlen_type_node,
  7786.                  build_int_2 (i, 0)))),
  7787.      1, 0);
  7788.   TREE_CONSTANT (nameinit) = 1;
  7789.   TREE_STATIC (nameinit) = 1;
  7790.   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
  7791.                nameinit);
  7792.  
  7793.   varsinit = ffecom_vardesc_array_ (s);
  7794.   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
  7795.                varsinit);
  7796.   TREE_CONSTANT (varsinit) = 1;
  7797.   TREE_STATIC (varsinit) = 1;
  7798.  
  7799.   {
  7800.     ffebld b;
  7801.  
  7802.     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
  7803.       ++i;
  7804.   }
  7805.   nvarsinit = build_int_2 (i, 0);
  7806.   TREE_TYPE (nvarsinit) = integer_type_node;
  7807.   TREE_CONSTANT (nvarsinit) = 1;
  7808.   TREE_STATIC (nvarsinit) = 1;
  7809.  
  7810.   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
  7811.   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
  7812.                        varsinit);
  7813.   TREE_CHAIN (TREE_CHAIN (nmlinits))
  7814.     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
  7815.  
  7816.   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
  7817.   TREE_CONSTANT (nmlinits) = 1;
  7818.   TREE_STATIC (nmlinits) = 1;
  7819.  
  7820.   finish_decl (nmlt, nmlinits, FALSE);
  7821.  
  7822.   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
  7823.  
  7824.   resume_momentary (yes);
  7825.  
  7826.   return nmlt;
  7827. }
  7828.  
  7829. #endif
  7830. /* Do divide operation appropriate to type of operands.  */
  7831.  
  7832. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  7833. static tree
  7834. ffecom_tree_divide_ (tree tree_type, tree left, tree right,
  7835.              tree dest_tree, ffeinfo dest_info, bool *dest_used)
  7836. {
  7837.   if ((left == error_mark_node)
  7838.       || (right == error_mark_node))
  7839.     return error_mark_node;
  7840.  
  7841.   switch (TREE_CODE (tree_type))
  7842.     {
  7843.     case INTEGER_TYPE:
  7844.       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
  7845.                left,
  7846.                right);
  7847.  
  7848.     case COMPLEX_TYPE:
  7849.       {
  7850.     ffecomGfrt ix;
  7851.  
  7852.     if (TREE_TYPE (tree_type)
  7853.         == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
  7854.       ix = FFECOM_gfrtDIV_CC;
  7855.     else
  7856.       ix = FFECOM_gfrtDIV_ZZ;
  7857.  
  7858.     left = ffecom_1 (ADDR_EXPR,
  7859.              build_pointer_type (TREE_TYPE (left)),
  7860.              left);
  7861.     left = build_tree_list (NULL_TREE, left);
  7862.     right = ffecom_1 (ADDR_EXPR,
  7863.               build_pointer_type (TREE_TYPE (right)),
  7864.               right);
  7865.     right = build_tree_list (NULL_TREE, right);
  7866.     TREE_CHAIN (left) = right;
  7867.  
  7868.     return ffecom_call_ (ffecom_gfrt_tree_ (ix),
  7869.                  ffecom_gfrt_kind_type_ (ix),
  7870.                  ffe_is_f2c_library (),
  7871.                  tree_type,
  7872.                  left,
  7873.                  dest_tree, dest_info, dest_used);
  7874.       }
  7875.  
  7876.     default:
  7877.       return ffecom_2 (RDIV_EXPR, tree_type,
  7878.                left,
  7879.                right);
  7880.     }
  7881. }
  7882.  
  7883. #endif
  7884. /* ffecom_type_localvar_ -- Build type info for non-dummy variable
  7885.  
  7886.    tree type;
  7887.    ffesymbol s;     // the variable's symbol
  7888.    ffeinfoBasictype bt;     // it's basictype
  7889.    ffeinfoKindtype kt; // it's kindtype
  7890.  
  7891.    type = ffecom_type_localvar_(s,bt,kt);
  7892.  
  7893.    Handles static arrays, CHARACTER type, etc.    */
  7894.  
  7895. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  7896. static tree
  7897. ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
  7898.                ffeinfoKindtype kt)
  7899. {
  7900.   tree type;
  7901.   ffebld dl;
  7902.   ffebld dim;
  7903.   ffetargetInteger1 low;
  7904.   ffetargetInteger1 lowh;
  7905.   ffetargetInteger1 high;
  7906.   ffetargetInteger1 highh;
  7907.   tree lowt;
  7908.   tree hight;
  7909.  
  7910.   type = ffecom_tree_type[bt][kt];
  7911.   if (bt == FFEINFO_basictypeCHARACTER)
  7912.     type
  7913.       = build_array_type
  7914.     (type,
  7915.      build_range_type (ffecom_f2c_ftnlen_type_node,
  7916.                ffecom_f2c_ftnlen_one_node,
  7917.                convert (ffecom_f2c_ftnlen_type_node,
  7918.                     build_int_2 (ffesymbol_size (s), 0))));
  7919.   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
  7920.     {
  7921.       dim = ffebld_head (dl);
  7922.       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
  7923.       if (ffebld_left (dim) == NULL)
  7924.     low = 1, lowh = 0;
  7925.       else
  7926.     {
  7927.       assert (ffebld_op (ffebld_left (dim)) == FFEBLD_opCONTER);
  7928.       low = ffebld_constant_integer1 (ffebld_conter
  7929.                       (ffebld_left (dim)));
  7930.       lowh = (low < 0) ? -1 : 0;
  7931.     }
  7932.       assert (ffebld_right (dim) != NULL);
  7933.       assert (ffebld_op (ffebld_right (dim)) == FFEBLD_opCONTER);
  7934.       high = ffebld_constant_integer1 (ffebld_conter
  7935.                        (ffebld_right (dim)));
  7936.       highh = (high < 0) ? -1 : 0;
  7937.  
  7938.       lowt = build_int_2 (low, lowh);
  7939.       TREE_TYPE (lowt) = ffecom_integer_type_node;
  7940.  
  7941.       hight = build_int_2 (high, highh);
  7942.       TREE_TYPE (hight) = ffecom_integer_type_node;
  7943.  
  7944.       type = build_array_type (type,
  7945.                    build_range_type (ffecom_integer_type_node,
  7946.                          lowt, hight));
  7947.     }
  7948.  
  7949.   return type;
  7950. }
  7951.  
  7952. #endif
  7953. /* Build Namelist type.  */
  7954.  
  7955. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  7956. static tree
  7957. ffecom_type_namelist_ ()
  7958. {
  7959.   static tree type = NULL_TREE;
  7960.  
  7961.   if (type == NULL_TREE)
  7962.     {
  7963.       static tree namefield, varsfield, nvarsfield;
  7964.       tree vardesctype;
  7965.  
  7966.       vardesctype = ffecom_type_vardesc_ ();
  7967.  
  7968.       push_obstacks_nochange ();
  7969.       end_temporary_allocation ();
  7970.  
  7971.       type = make_node (RECORD_TYPE);
  7972.  
  7973.       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
  7974.  
  7975.       namefield = ffecom_decl_field (type, NULL_TREE, "name",
  7976.                      string_type_node);
  7977.       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
  7978.       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
  7979.                       integer_type_node);
  7980.  
  7981.       TYPE_FIELDS (type) = namefield;
  7982.       layout_type (type);
  7983.  
  7984.       resume_temporary_allocation ();
  7985.       pop_obstacks ();
  7986.     }
  7987.  
  7988.   return type;
  7989. }
  7990.  
  7991. #endif
  7992.  
  7993. /* Make a copy of a type, assuming caller has switched to the permanent
  7994.    obstacks and that the type is for an aggregate (array) initializer.  */
  7995.  
  7996. #if FFECOM_targetCURRENT == FFECOM_targetGCC && 0    /* Not used now. */
  7997. static tree
  7998. ffecom_type_permanent_copy_ (tree t)
  7999. {
  8000.   tree domain;
  8001.   tree max;
  8002.  
  8003.   assert (TREE_TYPE (t) != NULL_TREE);
  8004.  
  8005.   domain = TYPE_DOMAIN (t);
  8006.  
  8007.   assert (TREE_CODE (t) == ARRAY_TYPE);
  8008.   assert (TREE_PERMANENT (TREE_TYPE (t)));
  8009.   assert (TREE_PERMANENT (TREE_TYPE (domain)));
  8010.   assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain)));
  8011.  
  8012.   max = TYPE_MAX_VALUE (domain);
  8013.   if (!TREE_PERMANENT (max))
  8014.     {
  8015.       assert (TREE_CODE (max) == INTEGER_CST);
  8016.  
  8017.       max = build_int_2 (TREE_INT_CST_LOW (max), TREE_INT_CST_HIGH (max));
  8018.     }
  8019.  
  8020.   return build_array_type (TREE_TYPE (t),
  8021.                build_range_type (TREE_TYPE (domain),
  8022.                          TYPE_MIN_VALUE (domain),
  8023.                          max));
  8024. }
  8025. #endif
  8026.  
  8027. /* Build Vardesc type.  */
  8028.  
  8029. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  8030. static tree
  8031. ffecom_type_vardesc_ ()
  8032. {
  8033.   static tree type = NULL_TREE;
  8034.   static tree namefield, addrfield, dimsfield, typefield;
  8035.  
  8036.   if (type == NULL_TREE)
  8037.     {
  8038.       push_obstacks_nochange ();
  8039.       end_temporary_allocation ();
  8040.  
  8041.       type = make_node (RECORD_TYPE);
  8042.  
  8043.       namefield = ffecom_decl_field (type, NULL_TREE, "name",
  8044.                      string_type_node);
  8045.       addrfield = ffecom_decl_field (type, namefield, "addr",
  8046.                      string_type_node);
  8047.       dimsfield = ffecom_decl_field (type, addrfield, "dims",
  8048.                      ffecom_f2c_ftnlen_type_node);
  8049.       typefield = ffecom_decl_field (type, dimsfield, "type",
  8050.                      integer_type_node);
  8051.  
  8052.       TYPE_FIELDS (type) = namefield;
  8053.       layout_type (type);
  8054.  
  8055.       resume_temporary_allocation ();
  8056.       pop_obstacks ();
  8057.     }
  8058.  
  8059.   return type;
  8060. }
  8061.  
  8062. #endif
  8063.  
  8064. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  8065. static tree
  8066. ffecom_vardesc_ (ffebld expr)
  8067. {
  8068.   ffesymbol s;
  8069.  
  8070.   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
  8071.   s = ffebld_symter (expr);
  8072.  
  8073.   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
  8074.     {
  8075.       int i;
  8076.       tree vardesctype = ffecom_type_vardesc_ ();
  8077.       tree var;
  8078.       tree nameinit;
  8079.       tree dimsinit;
  8080.       tree addrinit;
  8081.       tree typeinit;
  8082.       tree field;
  8083.       tree varinits;
  8084.       int yes;
  8085.       static int mynumber = 0;
  8086.  
  8087.       yes = suspend_momentary ();
  8088.  
  8089.       var = build_decl (VAR_DECL,
  8090.             ffecom_get_invented_identifier ("__g77_vardesc_%d",
  8091.                             NULL, mynumber++),
  8092.             vardesctype);
  8093.       TREE_STATIC (var) = 1;
  8094.       DECL_INITIAL (var) = error_mark_node;
  8095.  
  8096.       var = start_decl (var, FALSE);
  8097.  
  8098.       /* Process inits.  */
  8099.  
  8100.       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
  8101.                        + 1,
  8102.                        ffesymbol_text (s));
  8103.       TREE_TYPE (nameinit)
  8104.     = build_type_variant
  8105.     (build_array_type
  8106.      (char_type_node,
  8107.       build_range_type (integer_type_node,
  8108.                 integer_one_node,
  8109.                 build_int_2 (i, 0))),
  8110.      1, 0);
  8111.       TREE_CONSTANT (nameinit) = 1;
  8112.       TREE_STATIC (nameinit) = 1;
  8113.       nameinit = ffecom_1 (ADDR_EXPR,
  8114.                build_pointer_type (TREE_TYPE (nameinit)),
  8115.                nameinit);
  8116.  
  8117.       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
  8118.  
  8119.       dimsinit = ffecom_vardesc_dims_ (s);
  8120.  
  8121.       if (typeinit == NULL_TREE)
  8122.     {
  8123.       ffeinfoBasictype bt = ffesymbol_basictype (s);
  8124.       ffeinfoKindtype kt = ffesymbol_kindtype (s);
  8125.       int tc = ffecom_f2c_typecode (bt, kt);
  8126.  
  8127.       assert (tc != -1);
  8128.       typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
  8129.     }
  8130.       else
  8131.     typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
  8132.  
  8133.       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
  8134.                   nameinit);
  8135.       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
  8136.                            addrinit);
  8137.       TREE_CHAIN (TREE_CHAIN (varinits))
  8138.     = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
  8139.       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
  8140.     = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
  8141.  
  8142.       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
  8143.       TREE_CONSTANT (varinits) = 1;
  8144.       TREE_STATIC (varinits) = 1;
  8145.  
  8146.       finish_decl (var, varinits, FALSE);
  8147.  
  8148.       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
  8149.  
  8150.       resume_momentary (yes);
  8151.  
  8152.       ffesymbol_hook (s).vardesc_tree = var;
  8153.     }
  8154.  
  8155.   return ffesymbol_hook (s).vardesc_tree;
  8156. }
  8157.  
  8158. #endif
  8159. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  8160. static tree
  8161. ffecom_vardesc_array_ (ffesymbol s)
  8162. {
  8163.   ffebld b;
  8164.   tree list;
  8165.   tree item = NULL_TREE;
  8166.   tree var;
  8167.   int i;
  8168.   int yes;
  8169.   static int mynumber = 0;
  8170.  
  8171.   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
  8172.        b != NULL;
  8173.        b = ffebld_trail (b), ++i)
  8174.     {
  8175.       tree t;
  8176.  
  8177.       t = ffecom_vardesc_ (ffebld_head (b));
  8178.  
  8179.       if (list == NULL_TREE)
  8180.     list = item = build_tree_list (NULL_TREE, t);
  8181.       else
  8182.     {
  8183.       TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
  8184.       item = TREE_CHAIN (item);
  8185.     }
  8186.     }
  8187.  
  8188.   yes = suspend_momentary ();
  8189.  
  8190.   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
  8191.                build_range_type (integer_type_node,
  8192.                          integer_one_node,
  8193.                          build_int_2 (i, 0)));
  8194.   list = build (CONSTRUCTOR, item, NULL_TREE, list);
  8195.   TREE_CONSTANT (list) = 1;
  8196.   TREE_STATIC (list) = 1;
  8197.  
  8198.   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL,
  8199.                     mynumber++);
  8200.   var = build_decl (VAR_DECL, var, item);
  8201.   TREE_STATIC (var) = 1;
  8202.   DECL_INITIAL (var) = error_mark_node;
  8203.   var = start_decl (var, FALSE);
  8204.   finish_decl (var, list, FALSE);
  8205.  
  8206.   resume_momentary (yes);
  8207.  
  8208.   return var;
  8209. }
  8210.  
  8211. #endif
  8212. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  8213. static tree
  8214. ffecom_vardesc_dims_ (ffesymbol s)
  8215. {
  8216.   if (ffesymbol_dims (s) == NULL)
  8217.     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
  8218.             integer_zero_node);
  8219.  
  8220.   {
  8221.     ffebld b;
  8222.     ffebld e;
  8223.     tree list;
  8224.     tree backlist;
  8225.     tree item = NULL_TREE;
  8226.     tree var;
  8227.     int yes;
  8228.     tree numdim;
  8229.     tree numelem;
  8230.     tree baseoff = NULL_TREE;
  8231.     static int mynumber = 0;
  8232.  
  8233.     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
  8234.     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
  8235.  
  8236.     numelem = ffecom_expr (ffesymbol_arraysize (s));
  8237.     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
  8238.  
  8239.     list = NULL_TREE;
  8240.     backlist = NULL_TREE;
  8241.     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
  8242.      b != NULL;
  8243.      b = ffebld_trail (b), e = ffebld_trail (e))
  8244.       {
  8245.     tree t;
  8246.     tree low;
  8247.     tree back;
  8248.  
  8249.     if (ffebld_trail (b) == NULL)
  8250.       t = NULL_TREE;
  8251.     else
  8252.       {
  8253.         t = convert (ffecom_f2c_ftnlen_type_node,
  8254.              ffecom_expr (ffebld_head (e)));
  8255.  
  8256.         if (list == NULL_TREE)
  8257.           list = item = build_tree_list (NULL_TREE, t);
  8258.         else
  8259.           {
  8260.         TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
  8261.         item = TREE_CHAIN (item);
  8262.           }
  8263.       }
  8264.  
  8265.     if (ffebld_left (ffebld_head (b)) == NULL)
  8266.       low = ffecom_integer_one_node;
  8267.     else
  8268.       low = ffecom_expr (ffebld_left (ffebld_head (b)));
  8269.     low = convert (ffecom_f2c_ftnlen_type_node, low);
  8270.  
  8271.     back = build_tree_list (low, t);
  8272.     TREE_CHAIN (back) = backlist;
  8273.     backlist = back;
  8274.       }
  8275.  
  8276.     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
  8277.       {
  8278.     if (TREE_VALUE (item) == NULL_TREE)
  8279.       baseoff = TREE_PURPOSE (item);
  8280.     else
  8281.       baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
  8282.                   TREE_PURPOSE (item),
  8283.                   ffecom_2 (MULT_EXPR,
  8284.                     ffecom_f2c_ftnlen_type_node,
  8285.                     TREE_VALUE (item),
  8286.                     baseoff));
  8287.       }
  8288.  
  8289.     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
  8290.  
  8291.     baseoff = build_tree_list (NULL_TREE, baseoff);
  8292.     TREE_CHAIN (baseoff) = list;
  8293.  
  8294.     numelem = build_tree_list (NULL_TREE, numelem);
  8295.     TREE_CHAIN (numelem) = baseoff;
  8296.  
  8297.     numdim = build_tree_list (NULL_TREE, numdim);
  8298.     TREE_CHAIN (numdim) = numelem;
  8299.  
  8300.     yes = suspend_momentary ();
  8301.  
  8302.     item = build_array_type (ffecom_f2c_ftnlen_type_node,
  8303.                  build_range_type (integer_type_node,
  8304.                            integer_zero_node,
  8305.                            build_int_2
  8306.                            ((int) ffesymbol_rank (s)
  8307.                         + 2, 0)));
  8308.     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
  8309.     TREE_CONSTANT (list) = 1;
  8310.     TREE_STATIC (list) = 1;
  8311.  
  8312.     var = ffecom_get_invented_identifier ("__g77_dims_%d", NULL,
  8313.                       mynumber++);
  8314.     var = build_decl (VAR_DECL, var, item);
  8315.     TREE_STATIC (var) = 1;
  8316.     DECL_INITIAL (var) = error_mark_node;
  8317.     var = start_decl (var, FALSE);
  8318.     finish_decl (var, list, FALSE);
  8319.  
  8320.     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
  8321.  
  8322.     resume_momentary (yes);
  8323.  
  8324.     return var;
  8325.   }
  8326. }
  8327.  
  8328. #endif
  8329. /* Essentially does a "fold (build1 (code, type, node))" while checking
  8330.    for certain housekeeping things.
  8331.  
  8332.    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
  8333.    ffecom_1_fn instead.  */
  8334.  
  8335. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  8336. tree
  8337. ffecom_1 (enum tree_code code, tree type, tree node)
  8338. {
  8339.   tree item;
  8340.  
  8341.   if ((node == error_mark_node)
  8342.       || (type == error_mark_node))
  8343.     return error_mark_node;
  8344.  
  8345.   if (code == ADDR_EXPR)
  8346.     {
  8347.       if (!mark_addressable (node))
  8348.     assert ("can't mark_addressable this node!" == NULL);
  8349.     }
  8350.   item = build1 (code, type, node);
  8351.   if (TREE_SIDE_EFFECTS (node))
  8352.     TREE_SIDE_EFFECTS (item) = 1;
  8353.   if ((code == ADDR_EXPR) && staticp (node))
  8354.     TREE_CONSTANT (item) = 1;
  8355.   return fold (item);
  8356. }
  8357. #endif
  8358.  
  8359. /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
  8360.    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
  8361.    does not set TREE_ADDRESSABLE (because calling an inline
  8362.    function does not mean the function needs to be separately
  8363.    compiled).  */
  8364.  
  8365. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  8366. tree
  8367. ffecom_1_fn (tree node)
  8368. {
  8369.   tree item;
  8370.   tree type;
  8371.  
  8372.   if (node == error_mark_node)
  8373.     return error_mark_node;
  8374.  
  8375.   type = build_type_variant (TREE_TYPE (node),
  8376.                  TREE_READONLY (node),
  8377.                  TREE_THIS_VOLATILE (node));
  8378.   item = build1 (ADDR_EXPR,
  8379.          build_pointer_type (type), node);
  8380.   if (TREE_SIDE_EFFECTS (node))
  8381.     TREE_SIDE_EFFECTS (item) = 1;
  8382.   if (staticp (node))
  8383.     TREE_CONSTANT (item) = 1;
  8384.   return fold (item);
  8385. }
  8386. #endif
  8387.  
  8388. /* Essentially does a "fold (build (code, type, node1, node2))" while
  8389.    checking for certain housekeeping things.  */
  8390.  
  8391. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  8392. tree
  8393. ffecom_2 (enum tree_code code, tree type, tree node1,
  8394.       tree node2)
  8395. {
  8396.   tree item;
  8397.  
  8398.   if ((node1 == error_mark_node)
  8399.       || (node2 == error_mark_node)
  8400.       || (type == error_mark_node))
  8401.     return error_mark_node;
  8402.  
  8403.   item = build (code, type, node1, node2);
  8404.   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
  8405.     TREE_SIDE_EFFECTS (item) = 1;
  8406.   return fold (item);
  8407. }
  8408.  
  8409. #endif
  8410. /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
  8411.  
  8412.    ffesymbol s;     // the ENTRY point itself
  8413.    if (ffecom_2pass_advise_entrypoint(s))
  8414.        // the ENTRY point has been accepted
  8415.  
  8416.    Does whatever compiler needs to do when it learns about the entrypoint,
  8417.    like determine the return type of the master function, count the
  8418.    number of entrypoints, etc.    Returns FALSE if the return type is
  8419.    not compatible with the return type(s) of other entrypoint(s).
  8420.  
  8421.    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
  8422.    later (after _finish_progunit) be called with the same entrypoint(s)
  8423.    as passed to this fn for which TRUE was returned.
  8424.  
  8425.    03-Jan-92  JCB  2.0
  8426.       Return FALSE if the return type conflicts with previous entrypoints.  */
  8427.  
  8428. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  8429. bool
  8430. ffecom_2pass_advise_entrypoint (ffesymbol entry)
  8431. {
  8432.   ffebld list;            /* opITEM. */
  8433.   ffebld mlist;            /* opITEM. */
  8434.   ffebld plist;            /* opITEM. */
  8435.   ffebld arg;            /* ffebld_head(opITEM). */
  8436.   ffebld item;            /* opITEM. */
  8437.   ffesymbol s;            /* ffebld_symter(arg). */
  8438.   ffeinfoBasictype bt = ffesymbol_basictype (entry);
  8439.   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
  8440.   ffetargetCharacterSize size = ffesymbol_size (entry);
  8441.   bool ok;
  8442.  
  8443.   if (ffecom_num_entrypoints_ == 0)
  8444.     {                /* First entrypoint, make list of main
  8445.                    arglist's dummies. */
  8446.       assert (ffecom_primary_entry_ != NULL);
  8447.  
  8448.       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
  8449.       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
  8450.       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
  8451.  
  8452.       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
  8453.        list != NULL;
  8454.        list = ffebld_trail (list))
  8455.     {
  8456.       arg = ffebld_head (list);
  8457.       if (ffebld_op (arg) != FFEBLD_opSYMTER)
  8458.         continue;        /* Alternate return or some such thing. */
  8459.       item = ffebld_new_item (arg, NULL);
  8460.       if (plist == NULL)
  8461.         ffecom_master_arglist_ = item;
  8462.       else
  8463.         ffebld_set_trail (plist, item);
  8464.       plist = item;
  8465.     }
  8466.     }
  8467.  
  8468.   /* If necessary, scan entry arglist for alternate returns.  Do this scan
  8469.      apparently redundantly (it's done below to UNIONize the arglists) so
  8470.      that we don't complain about RETURN 1 if an offending ENTRY is the only
  8471.      one with an alternate return.  */
  8472.  
  8473.   if (!ffecom_is_altreturning_)
  8474.     {
  8475.       for (list = ffesymbol_dummyargs (entry);
  8476.        list != NULL;
  8477.        list = ffebld_trail (list))
  8478.     {
  8479.       arg = ffebld_head (list);
  8480.       if (ffebld_op (arg) == FFEBLD_opSTAR)
  8481.         {
  8482.           ffecom_is_altreturning_ = TRUE;
  8483.           break;
  8484.         }
  8485.     }
  8486.     }
  8487.  
  8488.   /* Now check type compatibility. */
  8489.  
  8490.   switch (ffecom_master_bt_)
  8491.     {
  8492.     case FFEINFO_basictypeNONE:
  8493.       ok = (bt != FFEINFO_basictypeCHARACTER);
  8494.       break;
  8495.  
  8496.     case FFEINFO_basictypeCHARACTER:
  8497.       ok
  8498.     = (bt == FFEINFO_basictypeCHARACTER)
  8499.     && (kt == ffecom_master_kt_)
  8500.     && (size == ffecom_master_size_);
  8501.       break;
  8502.  
  8503.     case FFEINFO_basictypeANY:
  8504.       return FALSE;        /* Just don't bother. */
  8505.  
  8506.     default:
  8507.       if (bt == FFEINFO_basictypeCHARACTER)
  8508.     {
  8509.       ok = FALSE;
  8510.       break;
  8511.     }
  8512.       ok = TRUE;
  8513.       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
  8514.     {
  8515.       ffecom_master_bt_ = FFEINFO_basictypeNONE;
  8516.       ffecom_master_kt_ = FFEINFO_kindtypeNONE;
  8517.     }
  8518.       break;
  8519.     }
  8520.  
  8521.   if (!ok)
  8522.     {
  8523.       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
  8524.       ffest_ffebad_here_current_stmt (0);
  8525.       ffebad_finish ();
  8526.       return FALSE;        /* Can't handle entrypoint. */
  8527.     }
  8528.  
  8529.   /* Entrypoint type compatible with previous types. */
  8530.  
  8531.   ++ffecom_num_entrypoints_;
  8532.  
  8533.   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
  8534.  
  8535.   for (list = ffesymbol_dummyargs (entry);
  8536.        list != NULL;
  8537.        list = ffebld_trail (list))
  8538.     {
  8539.       arg = ffebld_head (list);
  8540.       if (ffebld_op (arg) != FFEBLD_opSYMTER)
  8541.     continue;        /* Alternate return or some such thing. */
  8542.       s = ffebld_symter (arg);
  8543.       for (plist = NULL, mlist = ffecom_master_arglist_;
  8544.        mlist != NULL;
  8545.        plist = mlist, mlist = ffebld_trail (mlist))
  8546.     {            /* plist points to previous item for easy
  8547.                    appending of arg. */
  8548.       if (ffebld_symter (ffebld_head (mlist)) == s)
  8549.         break;        /* Already have this arg in the master list. */
  8550.     }
  8551.       if (mlist != NULL)
  8552.     continue;        /* Already have this arg in the master list. */
  8553.  
  8554.       /* Append this arg to the master list. */
  8555.  
  8556.       item = ffebld_new_item (arg, NULL);
  8557.       if (plist == NULL)
  8558.     ffecom_master_arglist_ = item;
  8559.       else
  8560.     ffebld_set_trail (plist, item);
  8561.     }
  8562.  
  8563.   return TRUE;
  8564. }
  8565.  
  8566. #endif
  8567. /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
  8568.  
  8569.    ffesymbol s;     // the ENTRY point itself
  8570.    ffecom_2pass_do_entrypoint(s);
  8571.  
  8572.    Does whatever compiler needs to do to make the entrypoint actually
  8573.    happen.  Must be called for each entrypoint after
  8574.    ffecom_finish_progunit is called.  */
  8575.  
  8576. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  8577. void
  8578. ffecom_2pass_do_entrypoint (ffesymbol entry)
  8579. {
  8580.   static int mfn_num = 0;
  8581.   static int ent_num;
  8582.  
  8583.   if (mfn_num != ffecom_num_fns_)
  8584.     {                /* First entrypoint for this program unit. */
  8585.       ent_num = 1;
  8586.       mfn_num = ffecom_num_fns_;
  8587.       ffecom_do_entry_ (ffecom_primary_entry_, 0);
  8588.     }
  8589.   else
  8590.     ++ent_num;
  8591.  
  8592.   --ffecom_num_entrypoints_;
  8593.  
  8594.   ffecom_do_entry_ (entry, ent_num);
  8595. }
  8596.  
  8597. #endif
  8598.  
  8599. /* Essentially does a "fold (build (code, type, node1, node2))" while
  8600.    checking for certain housekeeping things.  Always sets
  8601.    TREE_SIDE_EFFECTS.  */
  8602.  
  8603. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  8604. tree
  8605. ffecom_2s (enum tree_code code, tree type, tree node1,
  8606.        tree node2)
  8607. {
  8608.   tree item;
  8609.  
  8610.   if ((node1 == error_mark_node)
  8611.       || (node2 == error_mark_node)
  8612.       || (type == error_mark_node))
  8613.     return error_mark_node;
  8614.  
  8615.   item = build (code, type, node1, node2);
  8616.   TREE_SIDE_EFFECTS (item) = 1;
  8617.   return fold (item);
  8618. }
  8619.  
  8620. #endif
  8621. /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
  8622.    checking for certain housekeeping things.  */
  8623.  
  8624. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  8625. tree
  8626. ffecom_3 (enum tree_code code, tree type, tree node1,
  8627.       tree node2, tree node3)
  8628. {
  8629.   tree item;
  8630.  
  8631.   if ((node1 == error_mark_node)
  8632.       || (node2 == error_mark_node)
  8633.       || (node3 == error_mark_node)
  8634.       || (type == error_mark_node))
  8635.     return error_mark_node;
  8636.  
  8637.   item = build (code, type, node1, node2, node3);
  8638.   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
  8639.       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
  8640.     TREE_SIDE_EFFECTS (item) = 1;
  8641.   return fold (item);
  8642. }
  8643.  
  8644. #endif
  8645. /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
  8646.    checking for certain housekeeping things.  Always sets
  8647.    TREE_SIDE_EFFECTS.  */
  8648.  
  8649. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  8650. tree
  8651. ffecom_3s (enum tree_code code, tree type, tree node1,
  8652.        tree node2, tree node3)
  8653. {
  8654.   tree item;
  8655.  
  8656.   if ((node1 == error_mark_node)
  8657.       || (node2 == error_mark_node)
  8658.       || (node3 == error_mark_node)
  8659.       || (type == error_mark_node))
  8660.     return error_mark_node;
  8661.  
  8662.   item = build (code, type, node1, node2, node3);
  8663.   TREE_SIDE_EFFECTS (item) = 1;
  8664.   return fold (item);
  8665. }
  8666.  
  8667. #endif
  8668. /* ffecom_arg_expr -- Transform argument expr into gcc tree
  8669.  
  8670.    See use by ffecom_list_expr.
  8671.  
  8672.    If expression is NULL, returns an integer zero tree.     If it is not
  8673.    a CHARACTER expression, returns whatever ffecom_expr
  8674.    returns and sets the length return value to NULL_TREE.  Otherwise
  8675.    generates code to evaluate the character expression, returns the proper
  8676.    pointer to the result, but does NOT set the length return value to a tree
  8677.    that specifies the length of the result.  (In other words, the length
  8678.    variable is always set to NULL_TREE, because a length is never passed.)
  8679.  
  8680.    21-Dec-91  JCB  1.1
  8681.       Don't set returned length, since nobody needs it (yet; someday if
  8682.       we allow CHARACTER*(*) dummies to statement functions, we'll need
  8683.       it).  */
  8684.  
  8685. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  8686. tree
  8687. ffecom_arg_expr (ffebld expr, tree *length)
  8688. {
  8689.   tree ign;
  8690.  
  8691.   *length = NULL_TREE;
  8692.  
  8693.   if (expr == NULL)
  8694.     return integer_zero_node;
  8695.  
  8696.   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
  8697.     return ffecom_expr (expr);
  8698.  
  8699.   return ffecom_arg_ptr_to_expr (expr, &ign);
  8700. }
  8701.  
  8702. #endif
  8703. /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
  8704.  
  8705.    See use by ffecom_list_ptr_to_expr.
  8706.  
  8707.    If expression is NULL, returns an integer zero tree.     If it is not
  8708.    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
  8709.    returns and sets the length return value to NULL_TREE.  Otherwise
  8710.    generates code to evaluate the character expression, returns the proper
  8711.    pointer to the result, AND sets the length return value to a tree that
  8712.    specifies the length of the result.    */
  8713.  
  8714. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  8715. tree
  8716. ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
  8717. {
  8718.   tree item;
  8719.   tree ign_length;
  8720.   ffecomConcatList_ catlist;
  8721.  
  8722.   *length = NULL_TREE;
  8723.  
  8724.   if (expr == NULL)
  8725.     return integer_zero_node;
  8726.  
  8727.   switch (ffebld_op (expr))
  8728.     {
  8729.     case FFEBLD_opPERCENT_VAL:
  8730.       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
  8731.     return ffecom_expr (ffebld_left (expr));
  8732.       {
  8733.     tree temp_exp;
  8734.     tree temp_length;
  8735.  
  8736.     temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
  8737.     return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
  8738.              temp_exp);
  8739.       }
  8740.  
  8741.     case FFEBLD_opPERCENT_REF:
  8742.       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
  8743.     return ffecom_ptr_to_expr (ffebld_left (expr));
  8744.       ign_length = NULL_TREE;
  8745.       length = &ign_length;
  8746.       expr = ffebld_left (expr);
  8747.       break;
  8748.  
  8749.     case FFEBLD_opPERCENT_DESCR:
  8750.       switch (ffeinfo_basictype (ffebld_info (expr)))
  8751.     {
  8752. #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
  8753.     case FFEINFO_basictypeHOLLERITH:
  8754. #endif
  8755.     case FFEINFO_basictypeCHARACTER:
  8756.       break;        /* Passed by descriptor anyway. */
  8757.  
  8758.     default:
  8759.       item = ffecom_ptr_to_expr (expr);
  8760.       if (item != error_mark_node)
  8761.         *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
  8762.       break;
  8763.     }
  8764.       break;
  8765.  
  8766.     default:
  8767.       break;
  8768.     }
  8769.  
  8770. #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
  8771.   if (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
  8772.     {                /* Pass Hollerith by descriptor. */
  8773.       ffetargetHollerith h;
  8774.  
  8775.       assert (ffebld_op (expr) == FFEBLD_opCONTER);
  8776.       h = ffebld_cu_val_hollerith (ffebld_constant_union
  8777.                    (ffebld_conter (expr)));
  8778.       *length
  8779.     = build_int_2 (h.length, 0);
  8780.       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
  8781.     }
  8782. #endif
  8783.  
  8784.   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
  8785.     return ffecom_ptr_to_expr (expr);
  8786.  
  8787.   assert (ffeinfo_kindtype (ffebld_info (expr))
  8788.       == FFEINFO_kindtypeCHARACTER1);
  8789.  
  8790.   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
  8791.   switch (ffecom_concat_list_count_ (catlist))
  8792.     {
  8793.     case 0:            /* Shouldn't happen, but in case it does... */
  8794.       *length = ffecom_f2c_ftnlen_zero_node;
  8795.       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
  8796.       ffecom_concat_list_kill_ (catlist);
  8797.       return null_pointer_node;
  8798.  
  8799.     case 1:            /* The (fairly) easy case. */
  8800.       ffecom_char_args_ (&item, length,
  8801.              ffecom_concat_list_expr_ (catlist, 0));
  8802.       ffecom_concat_list_kill_ (catlist);
  8803.       assert (item != NULL_TREE);
  8804.       return item;
  8805.  
  8806.     default:            /* Must actually concatenate things. */
  8807.       break;
  8808.     }
  8809.  
  8810.   {
  8811.     int count = ffecom_concat_list_count_ (catlist);
  8812.     int i;
  8813.     tree lengths;
  8814.     tree items;
  8815.     tree length_array;
  8816.     tree item_array;
  8817.     tree citem;
  8818.     tree clength;
  8819.     tree temporary;
  8820.     tree num;
  8821.     tree known_length;
  8822.     ffetargetCharacterSize sz;
  8823.  
  8824.     length_array
  8825.       = lengths
  8826.       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
  8827.                  FFETARGET_charactersizeNONE, count, TRUE);
  8828.     item_array
  8829.       = items
  8830.       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
  8831.                  FFETARGET_charactersizeNONE, count, TRUE);
  8832.  
  8833.     known_length = ffecom_f2c_ftnlen_zero_node;
  8834.  
  8835.     for (i = 0; i < count; ++i)
  8836.       {
  8837.     ffecom_char_args_ (&citem, &clength,
  8838.                ffecom_concat_list_expr_ (catlist, i));
  8839.     items
  8840.       = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
  8841.               ffecom_modify (void_type_node,
  8842.                      ffecom_2 (ARRAY_REF,
  8843.              TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
  8844.                            item_array,
  8845.                            build_int_2 (i, 0)),
  8846.                      citem),
  8847.               items);
  8848.     clength = ffecom_save_tree (clength);
  8849.     known_length
  8850.       = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
  8851.               known_length,
  8852.               clength);
  8853.     lengths
  8854.       = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
  8855.               ffecom_modify (void_type_node,
  8856.                      ffecom_2 (ARRAY_REF,
  8857.            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
  8858.                            length_array,
  8859.                            build_int_2 (i, 0)),
  8860.                      clength),
  8861.               lengths);
  8862.       }
  8863.  
  8864.     sz = ffecom_concat_list_maxlen_ (catlist);
  8865.     assert (sz != FFETARGET_charactersizeNONE);
  8866.  
  8867.     temporary = ffecom_push_tempvar (char_type_node,
  8868.                      sz, -1, TRUE);
  8869.     temporary = ffecom_1 (ADDR_EXPR,
  8870.               build_pointer_type (TREE_TYPE (temporary)),
  8871.               temporary);
  8872.  
  8873.     item = build_tree_list (NULL_TREE, temporary);
  8874.     TREE_CHAIN (item)
  8875.       = build_tree_list (NULL_TREE,
  8876.              ffecom_1 (ADDR_EXPR,
  8877.                    build_pointer_type (TREE_TYPE (items)),
  8878.                    items));
  8879.     TREE_CHAIN (TREE_CHAIN (item))
  8880.       = build_tree_list (NULL_TREE,
  8881.              ffecom_1 (ADDR_EXPR,
  8882.                    build_pointer_type (TREE_TYPE (lengths)),
  8883.                    lengths));
  8884.     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
  8885.       = build_tree_list
  8886.     (NULL_TREE,
  8887.      ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
  8888.            convert (ffecom_f2c_ftnlen_type_node,
  8889.                 build_int_2 (count, 0))));
  8890.     num = build_int_2 (sz, 0);
  8891.     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
  8892.     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
  8893.       = build_tree_list (NULL_TREE, num);
  8894.  
  8895.     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item);
  8896.     TREE_SIDE_EFFECTS (item) = 1;
  8897.     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
  8898.              item,
  8899.              temporary);
  8900.  
  8901.     *length = known_length;
  8902.   }
  8903.  
  8904.   ffecom_concat_list_kill_ (catlist);
  8905.   assert (item != NULL_TREE);
  8906.   return item;
  8907. }
  8908.  
  8909. #endif
  8910. /* ffecom_call_gfrt -- Generate call to run-time function
  8911.  
  8912.    tree expr;
  8913.    expr = ffecom_call_gfrt(FFECOM_gfrtSTOPNIL,NULL_TREE);
  8914.  
  8915.    The first arg is the GNU Fortran Run-Time function index, the second
  8916.    arg is the list of arguments to pass to it.    Returned is the expression
  8917.    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
  8918.    result (which may be void).    */
  8919.  
  8920. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  8921. tree
  8922. ffecom_call_gfrt (ffecomGfrt ix, tree args)
  8923. {
  8924.   return ffecom_call_ (ffecom_gfrt_tree_ (ix), ffecom_gfrt_kind_type_ (ix),
  8925.                ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
  8926.                NULL_TREE, args, NULL_TREE, ffeinfo_new_null (),
  8927.                NULL);
  8928. }
  8929. #endif
  8930.  
  8931. /* ffecom_constantunion -- Transform constant-union to tree
  8932.  
  8933.    ffebldConstantUnion cu;  // the constant to transform
  8934.    ffeinfoBasictype bt;     // its basic type
  8935.    ffeinfoKindtype kt;    // its kind type
  8936.    tree tree_type;  // ffecom_tree_type[bt][kt]
  8937.    ffecom_constantunion(&cu,bt,kt,tree_type);  */
  8938.  
  8939. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  8940. tree
  8941. ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
  8942.               ffeinfoKindtype kt, tree tree_type)
  8943. {
  8944.   tree item;
  8945.  
  8946.   switch (bt)
  8947.     {
  8948.     case FFEINFO_basictypeINTEGER:
  8949.       {
  8950.     int val;
  8951.  
  8952.     switch (kt)
  8953.       {
  8954. #if FFETARGET_okINTEGER1
  8955.       case FFEINFO_kindtypeINTEGER1:
  8956.         val = ffebld_cu_val_integer1 (*cu);
  8957.         break;
  8958. #endif
  8959.  
  8960. #if FFETARGET_okINTEGER2
  8961.       case FFEINFO_kindtypeINTEGER2:
  8962.         val = ffebld_cu_val_integer2 (*cu);
  8963.         break;
  8964. #endif
  8965.  
  8966. #if FFETARGET_okINTEGER3
  8967.       case FFEINFO_kindtypeINTEGER3:
  8968.         val = ffebld_cu_val_integer3 (*cu);
  8969.         break;
  8970. #endif
  8971.  
  8972. #if FFETARGET_okINTEGER4
  8973.       case FFEINFO_kindtypeINTEGER4:
  8974.         val = ffebld_cu_val_integer4 (*cu);
  8975.         break;
  8976. #endif
  8977.  
  8978.       default:
  8979.         assert ("bad INTEGER constant kind type" == NULL);
  8980.         /* Fall through. */
  8981.       case FFEINFO_kindtypeANY:
  8982.         return error_mark_node;
  8983.       }
  8984.     item = build_int_2 (val, (val < 0) ? -1 : 0);
  8985.     TREE_TYPE (item) = tree_type;
  8986.       }
  8987.       break;
  8988.  
  8989.     case FFEINFO_basictypeLOGICAL:
  8990.       {
  8991.     int val;
  8992.  
  8993.     switch (kt)
  8994.       {
  8995. #if FFETARGET_okLOGICAL1
  8996.       case FFEINFO_kindtypeLOGICAL1:
  8997.         val = ffebld_cu_val_logical1 (*cu);
  8998.         break;
  8999. #endif
  9000.  
  9001. #if FFETARGET_okLOGICAL2
  9002.       case FFEINFO_kindtypeLOGICAL2:
  9003.         val = ffebld_cu_val_logical2 (*cu);
  9004.         break;
  9005. #endif
  9006.  
  9007. #if FFETARGET_okLOGICAL3
  9008.       case FFEINFO_kindtypeLOGICAL3:
  9009.         val = ffebld_cu_val_logical3 (*cu);
  9010.         break;
  9011. #endif
  9012.  
  9013. #if FFETARGET_okLOGICAL4
  9014.       case FFEINFO_kindtypeLOGICAL4:
  9015.         val = ffebld_cu_val_logical4 (*cu);
  9016.         break;
  9017. #endif
  9018.  
  9019.       default:
  9020.         assert ("bad LOGICAL constant kind type" == NULL);
  9021.         /* Fall through. */
  9022.       case FFEINFO_kindtypeANY:
  9023.         return error_mark_node;
  9024.       }
  9025.     item = build_int_2 (val, (val < 0) ? -1 : 0);
  9026.     TREE_TYPE (item) = tree_type;
  9027.       }
  9028.       break;
  9029.  
  9030.     case FFEINFO_basictypeREAL:
  9031.       {
  9032.     REAL_VALUE_TYPE val;
  9033.  
  9034.     switch (kt)
  9035.       {
  9036. #if FFETARGET_okREAL1
  9037.       case FFEINFO_kindtypeREAL1:
  9038.         val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
  9039.         break;
  9040. #endif
  9041.  
  9042. #if FFETARGET_okREAL2
  9043.       case FFEINFO_kindtypeREAL2:
  9044.         val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
  9045.         break;
  9046. #endif
  9047.  
  9048. #if FFETARGET_okREAL3
  9049.       case FFEINFO_kindtypeREAL3:
  9050.         val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
  9051.         break;
  9052. #endif
  9053.  
  9054. #if FFETARGET_okREAL4
  9055.       case FFEINFO_kindtypeREAL4:
  9056.         val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
  9057.         break;
  9058. #endif
  9059.  
  9060.       default:
  9061.         assert ("bad REAL constant kind type" == NULL);
  9062.         /* Fall through. */
  9063.       case FFEINFO_kindtypeANY:
  9064.         return error_mark_node;
  9065.       }
  9066.     item = build_real (tree_type, val);
  9067.       }
  9068.       break;
  9069.  
  9070.     case FFEINFO_basictypeCOMPLEX:
  9071.       {
  9072.     REAL_VALUE_TYPE real;
  9073.     REAL_VALUE_TYPE imag;
  9074.     tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
  9075.  
  9076.     switch (kt)
  9077.       {
  9078. #if FFETARGET_okCOMPLEX1
  9079.       case FFEINFO_kindtypeREAL1:
  9080.         real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
  9081.         imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
  9082.         break;
  9083. #endif
  9084.  
  9085. #if FFETARGET_okCOMPLEX2
  9086.       case FFEINFO_kindtypeREAL2:
  9087.         real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
  9088.         imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
  9089.         break;
  9090. #endif
  9091.  
  9092. #if FFETARGET_okCOMPLEX3
  9093.       case FFEINFO_kindtypeREAL3:
  9094.         real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
  9095.         imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
  9096.         break;
  9097. #endif
  9098.  
  9099. #if FFETARGET_okCOMPLEX4
  9100.       case FFEINFO_kindtypeREAL4:
  9101.         real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
  9102.         imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
  9103.         break;
  9104. #endif
  9105.  
  9106.       default:
  9107.         assert ("bad REAL constant kind type" == NULL);
  9108.         /* Fall through. */
  9109.       case FFEINFO_kindtypeANY:
  9110.         return error_mark_node;
  9111.       }
  9112.     item = build_complex (build_real (el_type, real),
  9113.                   build_real (el_type, imag));
  9114.     TREE_TYPE (item) = tree_type;
  9115.       }
  9116.       break;
  9117.  
  9118.     case FFEINFO_basictypeCHARACTER:
  9119.       {                /* Happens only in DATA and similar contexts. */
  9120.     ffetargetCharacter1 val;
  9121.  
  9122.     switch (kt)
  9123.       {
  9124. #if FFETARGET_okCHARACTER1
  9125.       case FFEINFO_kindtypeLOGICAL1:
  9126.         val = ffebld_cu_val_character1 (*cu);
  9127.         break;
  9128. #endif
  9129.  
  9130.       default:
  9131.         assert ("bad CHARACTER constant kind type" == NULL);
  9132.         /* Fall through. */
  9133.       case FFEINFO_kindtypeANY:
  9134.         return error_mark_node;
  9135.       }
  9136.     item = build_string (ffetarget_length_character1 (val),
  9137.                  ffetarget_text_character1 (val));
  9138.     TREE_TYPE (item)
  9139.       = build_type_variant (build_array_type (char_type_node,
  9140.                           build_range_type
  9141.                           (integer_type_node,
  9142.                            integer_one_node,
  9143.                            build_int_2
  9144.                         (ffetarget_length_character1
  9145.                          (val), 0))),
  9146.                 1, 0);
  9147.       }
  9148.       break;
  9149.  
  9150.     case FFEINFO_basictypeHOLLERITH:
  9151.       {
  9152.     ffetargetHollerith h;
  9153.  
  9154.     h = ffebld_cu_val_hollerith (*cu);
  9155.  
  9156.     /* If not at least as wide as default INTEGER, widen it.  */
  9157.     if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
  9158.       item = build_string (h.length, h.text);
  9159.     else
  9160.       {
  9161.         char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
  9162.  
  9163.         memcpy (str, h.text, h.length);
  9164.         memset (&str[h.length], ' ',
  9165.             FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
  9166.             - h.length);
  9167.         item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
  9168.                  str);
  9169.       }
  9170.     TREE_TYPE (item)
  9171.       = build_type_variant (build_array_type (char_type_node,
  9172.                           build_range_type
  9173.                           (integer_type_node,
  9174.                            integer_one_node,
  9175.                            build_int_2
  9176.                            (h.length, 0))),
  9177.                 1, 0);
  9178.       }
  9179.       break;
  9180.  
  9181.     case FFEINFO_basictypeTYPELESS:
  9182.       {
  9183.     ffetargetInteger1 ival;
  9184.     ffetargetTypeless tless;
  9185.     ffebad error;
  9186.  
  9187.     tless = ffebld_cu_val_typeless (*cu);
  9188.     error = ffetarget_convert_integer1_typeless (&ival, tless);
  9189.     assert (error == FFEBAD);
  9190.  
  9191.     item = build_int_2 ((int) ival, 0);
  9192.       }
  9193.       break;
  9194.  
  9195.     default:
  9196.       assert ("not yet on constant type" == NULL);
  9197.       /* Fall through. */
  9198.     case FFEINFO_basictypeANY:
  9199.       return error_mark_node;
  9200.     }
  9201.  
  9202.   TREE_CONSTANT (item) = 1;
  9203.  
  9204.   return item;
  9205. }
  9206.  
  9207. #endif
  9208.  
  9209. /* Handy way to make a field in a struct/union.  */
  9210.  
  9211. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  9212. tree
  9213. ffecom_decl_field (tree context, tree prevfield,
  9214.            char *name, tree type)
  9215. {
  9216.   tree field;
  9217.  
  9218.   field = build_decl (FIELD_DECL, get_identifier (name), type);
  9219.   DECL_CONTEXT (field) = context;
  9220.   DECL_FRAME_SIZE (field) = 0;
  9221.   if (prevfield != NULL_TREE)
  9222.     TREE_CHAIN (prevfield) = field;
  9223.  
  9224.   return field;
  9225. }
  9226.  
  9227. #endif
  9228.  
  9229. void
  9230. ffecom_close_include (FILE *f)
  9231. {
  9232. #if FFECOM_GCC_INCLUDE
  9233.   ffecom_close_include_ (f);
  9234. #endif
  9235. }
  9236.  
  9237. int
  9238. ffecom_decode_include_option (char *spec)
  9239. {
  9240. #if FFECOM_GCC_INCLUDE
  9241.   return ffecom_decode_include_option_ (spec);
  9242. #else
  9243.   return 1;
  9244. #endif
  9245. }
  9246.  
  9247. /* ffecom_end_transition -- Perform end transition on all symbols
  9248.  
  9249.    ffecom_end_transition();
  9250.  
  9251.    Calls ffecom_sym_end_transition for each global and local symbol.  */
  9252.  
  9253. void
  9254. ffecom_end_transition ()
  9255. {
  9256. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  9257.   ffebld item;
  9258. #endif
  9259.  
  9260.   if (ffe_is_ffedebug ())
  9261.     fprintf (stdout, "; end_stmt_transition\n");
  9262.  
  9263. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  9264.   ffecom_list_blockdata_ = NULL;
  9265.   ffecom_list_common_ = NULL;
  9266. #endif
  9267.  
  9268.   ffesymbol_drive (ffecom_sym_end_transition);
  9269.   if (ffe_is_ffedebug ())
  9270.     {
  9271.       ffestorag_report ();
  9272.       ffesymbol_report_all ();
  9273.     }
  9274.  
  9275. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  9276.   ffecom_start_progunit_ ();
  9277.  
  9278.   for (item = ffecom_list_blockdata_;
  9279.        item != NULL;
  9280.        item = ffebld_trail (item))
  9281.     {
  9282.       ffebld callee;
  9283.       ffesymbol s;
  9284.       tree dt;
  9285.       tree t;
  9286.       tree var;
  9287.       int yes;
  9288.       static int number = 0;
  9289.  
  9290.       callee = ffebld_head (item);
  9291.       s = ffebld_symter (callee);
  9292.       t = ffesymbol_hook (s).decl_tree;
  9293.       if (t == NULL_TREE)
  9294.     {
  9295.       s = ffecom_sym_transform_ (s);
  9296.       t = ffesymbol_hook (s).decl_tree;
  9297.     }
  9298.  
  9299.       yes = suspend_momentary ();
  9300.  
  9301.       dt = build_pointer_type (TREE_TYPE (t));
  9302.  
  9303.       var = build_decl (VAR_DECL,
  9304.             ffecom_get_invented_identifier ("__g77_forceload_%d",
  9305.                             NULL, number++),
  9306.             dt);
  9307.       DECL_EXTERNAL (var) = 0;
  9308.       TREE_STATIC (var) = 1;
  9309.       TREE_PUBLIC (var) = 0;
  9310.       DECL_INITIAL (var) = error_mark_node;
  9311.       TREE_USED (var) = 1;
  9312.  
  9313.       var = start_decl (var, FALSE);
  9314.  
  9315.       t = ffecom_1 (ADDR_EXPR, dt, t);
  9316.  
  9317.       finish_decl (var, t, FALSE);
  9318.  
  9319.       resume_momentary (yes);
  9320.     }
  9321.  
  9322.   /* This handles any COMMON areas that weren't referenced but have, for
  9323.      example, important initial data.  */
  9324.  
  9325.   for (item = ffecom_list_common_;
  9326.        item != NULL;
  9327.        item = ffebld_trail (item))
  9328.     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
  9329.  
  9330. #endif
  9331. }
  9332.  
  9333. /* ffecom_exec_transition -- Perform exec transition on all symbols
  9334.  
  9335.    ffecom_exec_transition();
  9336.  
  9337.    Calls ffecom_sym_exec_transition for each global and local symbol.
  9338.    Make sure error updating not inhibited.  */
  9339.  
  9340. void
  9341. ffecom_exec_transition ()
  9342. {
  9343.   bool inhibited;
  9344.  
  9345.   if (ffe_is_ffedebug ())
  9346.     fprintf (stdout, "; exec_stmt_transition\n");
  9347.  
  9348.   inhibited = ffebad_inhibit ();
  9349.   ffebad_set_inhibit (FALSE);
  9350.  
  9351.   ffesymbol_drive (ffecom_sym_exec_transition);    /* Don't retract! */
  9352.   ffeequiv_exec_transition ();    /* Handle all pending EQUIVALENCEs. */
  9353.   if (ffe_is_ffedebug ())
  9354.     {
  9355.       ffestorag_report ();
  9356.       ffesymbol_report_all ();
  9357.     }
  9358.  
  9359.   if (inhibited)
  9360.     ffebad_set_inhibit (TRUE);
  9361. }
  9362.  
  9363. /* ffecom_expand_let_stmt -- Compile let (assignment) statement
  9364.  
  9365.    ffebld dest;
  9366.    ffebld source;
  9367.    ffecom_expand_let_stmt(dest,source);
  9368.  
  9369.    Convert dest and source using ffecom_expr, then join them
  9370.    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
  9371.  
  9372. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  9373. void
  9374. ffecom_expand_let_stmt (ffebld dest, ffebld source)
  9375. {
  9376.   tree dest_tree;
  9377.   tree dest_length;
  9378.   tree source_tree;
  9379.   tree expr_tree;
  9380.  
  9381.   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
  9382.     {
  9383.       bool dest_used;
  9384.  
  9385.       dest_tree = ffecom_expr_rw (dest);
  9386.       if (dest_tree == error_mark_node)
  9387.     return;
  9388.  
  9389.       if ((TREE_CODE (dest_tree) != VAR_DECL)
  9390.       || TREE_ADDRESSABLE (dest_tree))
  9391.     source_tree = ffecom_expr_ (source, dest_tree, ffebld_info (dest),
  9392.                     &dest_used, FALSE);
  9393.       else
  9394.     {
  9395.       source_tree = ffecom_expr (source);
  9396.       dest_used = FALSE;
  9397.     }
  9398.       if (source_tree == error_mark_node)
  9399.     return;
  9400.  
  9401.       if (dest_used)
  9402.     expr_tree = source_tree;
  9403.       else
  9404.     expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
  9405.                    dest_tree,
  9406.                    source_tree);
  9407.  
  9408.       expand_expr_stmt (expr_tree);
  9409.       return;
  9410.     }
  9411.  
  9412.   ffecom_push_calltemps ();
  9413.   ffecom_char_args_ (&dest_tree, &dest_length, dest);
  9414.   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
  9415.             source);
  9416.   ffecom_pop_calltemps ();
  9417. }
  9418.  
  9419. #endif
  9420. /* ffecom_expr -- Transform expr into gcc tree
  9421.  
  9422.    tree t;
  9423.    ffebld expr;     // FFE expression.
  9424.    tree = ffecom_expr(expr);
  9425.  
  9426.    Recursive descent on expr while making corresponding tree nodes and
  9427.    attaching type info and such.  */
  9428.  
  9429. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  9430. tree
  9431. ffecom_expr (ffebld expr)
  9432. {
  9433.   return ffecom_expr_ (expr, NULL_TREE, ffeinfo_new_null (), NULL,
  9434.                FALSE);
  9435. }
  9436.  
  9437. #endif
  9438. /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
  9439.  
  9440. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  9441. tree
  9442. ffecom_expr_assign (ffebld expr)
  9443. {
  9444.   return ffecom_expr_ (expr, NULL_TREE, ffeinfo_new_null (), NULL,
  9445.                TRUE);
  9446. }
  9447.  
  9448. #endif
  9449. /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
  9450.  
  9451. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  9452. tree
  9453. ffecom_expr_assign_w (ffebld expr)
  9454. {
  9455.   return ffecom_expr_ (expr, NULL_TREE, ffeinfo_new_null (), NULL,
  9456.                TRUE);
  9457. }
  9458.  
  9459. #endif
  9460. /* Transform expr for use as into read/write tree and stabilize the
  9461.    reference.  Not for use on CHARACTER expressions.
  9462.  
  9463.    Recursive descent on expr while making corresponding tree nodes and
  9464.    attaching type info and such.  */
  9465.  
  9466. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  9467. tree
  9468. ffecom_expr_rw (ffebld expr)
  9469. {
  9470.   assert (expr != NULL);
  9471.  
  9472.   return stabilize_reference (ffecom_expr (expr));
  9473. }
  9474.  
  9475. #endif
  9476. /* Do global stuff.  */
  9477.  
  9478. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  9479. void
  9480. ffecom_finish_compile ()
  9481. {
  9482.   assert (ffecom_outer_function_decl_ == NULL_TREE);
  9483.   assert (current_function_decl == NULL_TREE);
  9484.  
  9485.   ffeglobal_drive (ffecom_finish_global_);
  9486. }
  9487.  
  9488. #endif
  9489. /* Public entry point for front end to access finish_decl.  */
  9490.  
  9491. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  9492. void
  9493. ffecom_finish_decl (tree decl, tree init, bool is_top_level)
  9494. {
  9495.   assert (!is_top_level);
  9496.   finish_decl (decl, init, FALSE);
  9497. }
  9498.  
  9499. #endif
  9500. /* Finish a program unit.  */
  9501.  
  9502. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  9503. void
  9504. ffecom_finish_progunit ()
  9505. {
  9506.   ffecom_end_compstmt_ ();
  9507.  
  9508.   ffecom_previous_function_decl_ = current_function_decl;
  9509.   ffecom_which_entrypoint_decl_ = NULL_TREE;
  9510.  
  9511.   finish_function (0);
  9512. }
  9513.  
  9514. #endif
  9515. /* Wrapper for get_identifier.  pattern is like "...%s...", text is
  9516.    inserted into final name in place of "%s", or if text is NULL,
  9517.    pattern is like "...%d..." and text form of number is inserted
  9518.    in place of "%d".  */
  9519.  
  9520. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  9521. tree
  9522. ffecom_get_invented_identifier (char *pattern, char *text, int number)
  9523. {
  9524.   tree decl;
  9525.   char *nam;
  9526.   mallocSize lenlen;
  9527.   char space[66];
  9528.  
  9529.   if (text == NULL)
  9530.     lenlen = strlen (pattern) + 20;
  9531.   else
  9532.     lenlen = strlen (pattern) + strlen (text) - 1;
  9533.   if (lenlen > ARRAY_SIZE (space))
  9534.     nam = malloc_new_ks (malloc_pool_image (), pattern, lenlen);
  9535.   else
  9536.     nam = &space[0];
  9537.   if (text == NULL)
  9538.     sprintf (&nam[0], pattern, number);
  9539.   else
  9540.     sprintf (&nam[0], pattern, text);
  9541.   decl = get_identifier (nam);
  9542.   if (lenlen > ARRAY_SIZE (space))
  9543.     malloc_kill_ks (malloc_pool_image (), nam, lenlen);
  9544.  
  9545.   IDENTIFIER_INVENTED (decl) = 1;
  9546.  
  9547.   return decl;
  9548. }
  9549.  
  9550. #endif
  9551. /* ffecom_init_0 -- Initialize
  9552.  
  9553.    ffecom_init_0();  */
  9554.  
  9555. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  9556. void
  9557. ffecom_init_0 ()
  9558. {
  9559.   int i;
  9560.   int j;
  9561.   tree t;
  9562.   tree field;
  9563.   ffetype type;
  9564.   ffetype base_type;
  9565.  
  9566.   /* This block of code comes from the now-obsolete cktyps.c.  It checks
  9567.      whether the compiler environment is buggy in known ways, some of which
  9568.      would, if not explicitly checked here, result in subtle bugs in g77.  */
  9569.  
  9570.   {
  9571.     static char names[][12]
  9572.     =
  9573.     {"bar", "bletch", "foo", "foobar"};
  9574.     char *name;
  9575.     unsigned long ul;
  9576.     double fl;
  9577.  
  9578.     name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
  9579.             (int (*)()) strcmp);
  9580.     if (name != (char *) &names[2])
  9581.       {
  9582.     assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
  9583.         == NULL);
  9584.     abort ();
  9585.       }
  9586.  
  9587.     ul = strtoul ("123456789", NULL, 10);
  9588.     if (ul != 123456789L)
  9589.       {
  9590.     assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
  9591.  in proj.h" == NULL);
  9592.     abort ();
  9593.       }
  9594.  
  9595.     fl = atof ("56.789");
  9596.     if ((fl < 56.788) || (fl > 56.79))
  9597.       {
  9598.     assert ("atof not type double, fix your #include <stdio.h>"
  9599.         == NULL);
  9600.     abort ();
  9601.       }
  9602.   }
  9603.  
  9604. #if FFECOM_GCC_INCLUDE
  9605.   ffecom_initialize_char_syntax_ ();
  9606. #endif
  9607.  
  9608.   ffecom_outer_function_decl_ = NULL_TREE;
  9609.   current_function_decl = NULL_TREE;
  9610.   named_labels = NULL_TREE;
  9611.   current_binding_level = NULL_BINDING_LEVEL;
  9612.   free_binding_level = NULL_BINDING_LEVEL;
  9613.   pushlevel (0);        /* make the binding_level structure for
  9614.                    global names */
  9615.   global_binding_level = current_binding_level;
  9616.  
  9617.   /* Define `int' and `char' first so that dbx will output them first.  */
  9618.  
  9619.   integer_type_node = make_signed_type (INT_TYPE_SIZE);
  9620.   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
  9621.             integer_type_node));
  9622.  
  9623.   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
  9624.   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
  9625.             char_type_node));
  9626.  
  9627.   long_integer_type_node = make_signed_type (LONG_TYPE_SIZE);
  9628.   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
  9629.             long_integer_type_node));
  9630.  
  9631.   unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE);
  9632.   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
  9633.             unsigned_type_node));
  9634.  
  9635.   long_unsigned_type_node = make_unsigned_type (LONG_TYPE_SIZE);
  9636.   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
  9637.             long_unsigned_type_node));
  9638.  
  9639.   long_long_integer_type_node = make_signed_type (LONG_LONG_TYPE_SIZE);
  9640.   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
  9641.             long_long_integer_type_node));
  9642.  
  9643.   long_long_unsigned_type_node = make_unsigned_type (LONG_LONG_TYPE_SIZE);
  9644.   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
  9645.             long_long_unsigned_type_node));
  9646.  
  9647.   sizetype
  9648.     = TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE)));
  9649.  
  9650.   TREE_TYPE (TYPE_SIZE (integer_type_node)) = sizetype;
  9651.   TREE_TYPE (TYPE_SIZE (char_type_node)) = sizetype;
  9652.   TREE_TYPE (TYPE_SIZE (unsigned_type_node)) = sizetype;
  9653.   TREE_TYPE (TYPE_SIZE (long_unsigned_type_node)) = sizetype;
  9654.   TREE_TYPE (TYPE_SIZE (long_integer_type_node)) = sizetype;
  9655.   TREE_TYPE (TYPE_SIZE (long_long_integer_type_node)) = sizetype;
  9656.   TREE_TYPE (TYPE_SIZE (long_long_unsigned_type_node)) = sizetype;
  9657.  
  9658.   error_mark_node = make_node (ERROR_MARK);
  9659.   TREE_TYPE (error_mark_node) = error_mark_node;
  9660.  
  9661.   short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE);
  9662.   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
  9663.             short_integer_type_node));
  9664.  
  9665.   short_unsigned_type_node = make_unsigned_type (SHORT_TYPE_SIZE);
  9666.   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
  9667.             short_unsigned_type_node));
  9668.  
  9669.   /* Define both `signed char' and `unsigned char'.  */
  9670.   signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE);
  9671.   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
  9672.             signed_char_type_node));
  9673.  
  9674.   unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
  9675.   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
  9676.             unsigned_char_type_node));
  9677.  
  9678.   float_type_node = make_node (REAL_TYPE);
  9679.   TYPE_PRECISION (float_type_node) = FLOAT_TYPE_SIZE;
  9680.   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
  9681.             float_type_node));
  9682.   layout_type (float_type_node);
  9683.  
  9684.   double_type_node = make_node (REAL_TYPE);
  9685.   TYPE_PRECISION (double_type_node) = DOUBLE_TYPE_SIZE;
  9686.   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
  9687.             double_type_node));
  9688.   layout_type (double_type_node);
  9689.  
  9690.   long_double_type_node = make_node (REAL_TYPE);
  9691.   TYPE_PRECISION (long_double_type_node) = LONG_DOUBLE_TYPE_SIZE;
  9692.   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
  9693.             long_double_type_node));
  9694.   layout_type (long_double_type_node);
  9695.  
  9696.   complex_integer_type_node = make_node (COMPLEX_TYPE);
  9697.   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
  9698.             complex_integer_type_node));
  9699.   TREE_TYPE (complex_integer_type_node) = integer_type_node;
  9700.   layout_type (complex_integer_type_node);
  9701.  
  9702.   complex_float_type_node = make_node (COMPLEX_TYPE);
  9703.   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
  9704.             complex_float_type_node));
  9705.   TREE_TYPE (complex_float_type_node) = float_type_node;
  9706.   layout_type (complex_float_type_node);
  9707.  
  9708.   complex_double_type_node = make_node (COMPLEX_TYPE);
  9709.   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
  9710.             complex_double_type_node));
  9711.   TREE_TYPE (complex_double_type_node) = double_type_node;
  9712.   layout_type (complex_double_type_node);
  9713.  
  9714.   complex_long_double_type_node = make_node (COMPLEX_TYPE);
  9715.   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
  9716.             complex_long_double_type_node));
  9717.   TREE_TYPE (complex_long_double_type_node) = long_double_type_node;
  9718.   layout_type (complex_long_double_type_node);
  9719.  
  9720.   integer_zero_node = build_int_2 (0, 0);
  9721.   TREE_TYPE (integer_zero_node) = integer_type_node;
  9722.   integer_one_node = build_int_2 (1, 0);
  9723.   TREE_TYPE (integer_one_node) = integer_type_node;
  9724.  
  9725.   size_zero_node = build_int_2 (0, 0);
  9726.   TREE_TYPE (size_zero_node) = sizetype;
  9727.   size_one_node = build_int_2 (1, 0);
  9728.   TREE_TYPE (size_one_node) = sizetype;
  9729.  
  9730.   void_type_node = make_node (VOID_TYPE);
  9731.   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
  9732.             void_type_node));
  9733.   layout_type (void_type_node);    /* Uses integer_zero_node */
  9734.   /* We are not going to have real types in C with less than byte alignment,
  9735.      so we might as well not have any types that claim to have it.  */
  9736.   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
  9737.  
  9738.   null_pointer_node = build_int_2 (0, 0);
  9739.   TREE_TYPE (null_pointer_node) = build_pointer_type (void_type_node);
  9740.   layout_type (TREE_TYPE (null_pointer_node));
  9741.  
  9742.   string_type_node = build_pointer_type (char_type_node);
  9743.  
  9744.   ffecom_tree_fun_type_void
  9745.     = build_function_type (void_type_node, NULL_TREE);
  9746.  
  9747.   ffecom_tree_ptr_to_fun_type_void
  9748.     = build_pointer_type (ffecom_tree_fun_type_void);
  9749.  
  9750.   ffecom_tree_fun_type_double
  9751.     = build_function_type (double_type_node, NULL_TREE);
  9752.  
  9753.   for (i = 0; i < ARRAY_SIZE (ffecom_tree_type); ++i)
  9754.     for (j = 0; j < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
  9755.       {
  9756.     ffecom_tree_type[i][j] = NULL_TREE;
  9757.     ffecom_tree_fun_type[i][j] = NULL_TREE;
  9758.     ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
  9759.     ffecom_f2c_typecode_[i][j] = -1;
  9760.       }
  9761.  
  9762.   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
  9763.      to size FLOAT_TYPE_SIZE because they have to be the same size as
  9764.      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
  9765.      Compiler options and other such stuff that change the ways these
  9766.      types are set should not affect this particular setup.  */
  9767.  
  9768.   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
  9769.     = t = make_signed_type (FLOAT_TYPE_SIZE);
  9770.   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
  9771.             t));
  9772.   type = ffetype_new ();
  9773.   base_type = type;
  9774.   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
  9775.             type);
  9776.   ffetype_set_ams (type,
  9777.            TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
  9778.            TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
  9779.   ffetype_set_star (base_type,
  9780.             TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
  9781.             type);
  9782.   ffetype_set_kind (base_type, 1, type);
  9783.  
  9784.   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
  9785.     = t = make_unsigned_type (FLOAT_TYPE_SIZE);    /* HOLLERITH means unsigned. */
  9786.   pushdecl (build_decl (TYPE_DECL, get_identifier ("hollerith"),
  9787.             t));
  9788.  
  9789.   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
  9790.     = t = make_signed_type (FLOAT_TYPE_SIZE);
  9791.   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
  9792.             t));
  9793.   type = ffetype_new ();
  9794.   base_type = type;
  9795.   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
  9796.             type);
  9797.   ffetype_set_ams (type,
  9798.            TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
  9799.            TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
  9800.   ffetype_set_star (base_type,
  9801.             TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
  9802.             type);
  9803.   ffetype_set_kind (base_type, 1, type);
  9804.  
  9805.   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
  9806.     = t = make_node (REAL_TYPE);
  9807.   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
  9808.   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
  9809.             t));
  9810.   layout_type (t);
  9811.   type = ffetype_new ();
  9812.   base_type = type;
  9813.   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
  9814.             type);
  9815.   ffetype_set_ams (type,
  9816.            TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
  9817.            TYPE_PRECISION (t) / BITS_PER_UNIT);
  9818.   ffetype_set_star (base_type,
  9819.             TYPE_PRECISION (t) / CHAR_TYPE_SIZE,
  9820.             type);
  9821.   ffetype_set_kind (base_type, 1, type);
  9822.   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
  9823.     = FFETARGET_f2cTYREAL;
  9824.  
  9825.   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
  9826.     = t = make_node (REAL_TYPE);
  9827.   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;    /* Always twice REAL. */
  9828.   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
  9829.             t));
  9830.   layout_type (t);
  9831.   type = ffetype_new ();
  9832.   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
  9833.             type);
  9834.   ffetype_set_ams (type,
  9835.            TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
  9836.            TYPE_PRECISION (t) / BITS_PER_UNIT);
  9837.   ffetype_set_star (base_type,
  9838.             TYPE_PRECISION (t) / CHAR_TYPE_SIZE,
  9839.             type);
  9840.   ffetype_set_kind (base_type, 2, type);
  9841.   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
  9842.     = FFETARGET_f2cTYDREAL;
  9843.  
  9844.   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
  9845.     = t = make_node (COMPLEX_TYPE);
  9846.   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
  9847.             t));
  9848.   TREE_TYPE (t)
  9849.     = ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1];
  9850.   layout_type (t);
  9851.   type = ffetype_new ();
  9852.   base_type = type;
  9853.   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
  9854.             type);
  9855.   ffetype_set_ams (type,
  9856.            TYPE_ALIGN (TREE_TYPE (t)) / BITS_PER_UNIT, 0,
  9857.            TYPE_PRECISION (TREE_TYPE (t)) * 2 / BITS_PER_UNIT);
  9858.   ffetype_set_star (base_type,
  9859.             TYPE_PRECISION (TREE_TYPE (t)) * 2 / CHAR_TYPE_SIZE,
  9860.             type);
  9861.   ffetype_set_kind (base_type, 1, type);
  9862.   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
  9863.     = FFETARGET_f2cTYCOMPLEX;
  9864.  
  9865.   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
  9866.     = t = make_node (COMPLEX_TYPE);
  9867.   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
  9868.             t));
  9869.   TREE_TYPE (t)
  9870.     = ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
  9871.   layout_type (t);
  9872.   type = ffetype_new ();
  9873.   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
  9874.             type);
  9875.   ffetype_set_ams (type,
  9876.            TYPE_ALIGN (TREE_TYPE (t)) / BITS_PER_UNIT, 0,
  9877.            TYPE_PRECISION (TREE_TYPE (t)) * 2 / BITS_PER_UNIT);
  9878.   ffetype_set_star (base_type,
  9879.             TYPE_PRECISION (TREE_TYPE (t)) * 2 / CHAR_TYPE_SIZE,
  9880.             type);
  9881.   ffetype_set_kind (base_type, 2,
  9882.             type);
  9883.   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
  9884.     = FFETARGET_f2cTYDCOMPLEX;
  9885.  
  9886.   /* Make function and ptr-to-function types for non-CHARACTER types. */
  9887.  
  9888.   for (i = 0; i < ARRAY_SIZE (ffecom_tree_type); ++i)
  9889.     for (j = 0; j < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
  9890.       {
  9891.     if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
  9892.       {
  9893.         if (i == FFEINFO_basictypeCOMPLEX)
  9894.           t = void_type_node;
  9895.         /* For f2c compatibility, REAL functions are really
  9896.            implemented as DOUBLE PRECISION.  */
  9897.         else if ((i == FFEINFO_basictypeREAL)
  9898.              && (j == FFEINFO_kindtypeREAL1))
  9899.           t = ffecom_tree_type
  9900.         [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
  9901.  
  9902.         t = ffecom_tree_fun_type[i][j] = build_function_type (t,
  9903.                                   NULL_TREE);
  9904.         ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
  9905.       }
  9906.       }
  9907.  
  9908.   ffecom_integer_type_node
  9909.     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
  9910.   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
  9911.                       integer_zero_node);
  9912.   ffecom_integer_one_node = convert (ffecom_integer_type_node,
  9913.                      integer_one_node);
  9914.  
  9915.   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
  9916.      Turns out that by TYLONG, runtime/libI77/lio.h really means
  9917.      "whatever size an ftnint is".  For consistency and sanity,
  9918.      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
  9919.      all are INTEGER, which we also make out of whatever back-end
  9920.      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
  9921.      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
  9922.      accommodate machines like the Alpha.  Note that this suggests
  9923.      f2c and libf2c are missing a distinction perhaps needed on
  9924.      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
  9925.  
  9926.   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
  9927.                 FFETARGET_f2cTYLONG);
  9928.   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
  9929.                 FFETARGET_f2cTYSHORT);
  9930.   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
  9931.                 FFETARGET_f2cTYINT1);
  9932.   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
  9933.                 FFETARGET_f2cTYQUAD);
  9934.   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
  9935.                 FFETARGET_f2cTYLOGICAL);
  9936.   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
  9937.                 FFETARGET_f2cTYLOGICAL2);
  9938.   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
  9939.                 FFETARGET_f2cTYLOGICAL1);
  9940.   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
  9941.                 FFETARGET_f2cTYQUAD    /* ~~~ */);
  9942.  
  9943.   /* CHARACTER stuff is all special-cased, so it is not handled in the above
  9944.      loop.  CHARACTER items are built as arrays of unsigned char.  */
  9945.  
  9946.   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
  9947.     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
  9948.   type = ffetype_new ();
  9949.   base_type = type;
  9950.   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
  9951.             FFEINFO_kindtypeCHARACTER1,
  9952.             type);
  9953.   ffetype_set_ams (type,
  9954.            TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
  9955.            TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
  9956.   ffetype_set_kind (base_type, 1, type);
  9957.  
  9958.   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
  9959.     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
  9960.   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
  9961.     [FFEINFO_kindtypeCHARACTER1]
  9962.     = ffecom_tree_ptr_to_fun_type_void;
  9963.   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
  9964.     = FFETARGET_f2cTYCHAR;
  9965.  
  9966.   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
  9967.     = 0;
  9968.  
  9969.   /* Make multi-return-value type and fields. */
  9970.  
  9971.   ffecom_multi_type_node_ = make_node (UNION_TYPE);
  9972.  
  9973.   field = NULL_TREE;
  9974.  
  9975.   for (i = 0; i < ARRAY_SIZE (ffecom_tree_type); ++i)
  9976.     for (j = 0; j < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
  9977.       {
  9978.     char name[30];
  9979.  
  9980.     if (ffecom_tree_type[i][j] == NULL_TREE)
  9981.       continue;        /* Not supported. */
  9982.     sprintf (&name[0], "bt_%s_kt_%s",
  9983.          ffeinfo_basictype_string ((ffeinfoBasictype) i),
  9984.          ffeinfo_kindtype_string ((ffeinfoKindtype) j));
  9985.     ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
  9986.                          get_identifier (name),
  9987.                          ffecom_tree_type[i][j]);
  9988.     DECL_CONTEXT (ffecom_multi_fields_[i][j])
  9989.       = ffecom_multi_type_node_;
  9990.     DECL_FRAME_SIZE (ffecom_multi_fields_[i][j]) = 0;
  9991.     TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
  9992.     field = ffecom_multi_fields_[i][j];
  9993.       }
  9994.  
  9995.   TYPE_FIELDS (ffecom_multi_type_node_) = field;
  9996.   layout_type (ffecom_multi_type_node_);
  9997.  
  9998.   /* Subroutines usually return integer because they might have alternate
  9999.      returns. */
  10000.  
  10001.   ffecom_tree_subr_type
  10002.     = build_function_type (integer_type_node, NULL_TREE);
  10003.   ffecom_tree_ptr_to_subr_type
  10004.     = build_pointer_type (ffecom_tree_subr_type);
  10005.   ffecom_tree_blockdata_type
  10006.     = build_function_type (void_type_node, NULL_TREE);
  10007.  
  10008.   builtin_function ("__builtin_fsqrt", ffecom_tree_fun_type_double,
  10009.             BUILT_IN_FSQRT, "sqrt");
  10010.   builtin_function ("__builtin_sin", ffecom_tree_fun_type_double,
  10011.             BUILT_IN_SIN, "sin");
  10012.   builtin_function ("__builtin_cos", ffecom_tree_fun_type_double,
  10013.             BUILT_IN_COS, "cos");
  10014.  
  10015.   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
  10016.              FFECOM_f2cINTEGER,
  10017.              "integer");
  10018.   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
  10019.              FFECOM_f2cADDRESS,
  10020.              "address");
  10021.   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
  10022.              FFECOM_f2cREAL,
  10023.              "real");
  10024.   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
  10025.              FFECOM_f2cDOUBLEREAL,
  10026.              "doublereal");
  10027.   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
  10028.              FFECOM_f2cCOMPLEX,
  10029.              "complex");
  10030.   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
  10031.              FFECOM_f2cDOUBLECOMPLEX,
  10032.              "doublecomplex");
  10033.   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
  10034.              FFECOM_f2cLOGICAL,
  10035.              "logical");
  10036.   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
  10037.              FFECOM_f2cFLAG,
  10038.              "flag");
  10039.   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
  10040.              FFECOM_f2cFTNLEN,
  10041.              "ftnlen");
  10042.   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
  10043.              FFECOM_f2cFTNINT,
  10044.              "ftnint");
  10045.  
  10046.   ffecom_f2c_ftnlen_zero_node
  10047.     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
  10048.  
  10049.   ffecom_f2c_ftnlen_one_node
  10050.     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
  10051.  
  10052.   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
  10053.   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
  10054.  
  10055.   ffecom_f2c_ptr_to_ftnlen_type_node
  10056.     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
  10057.  
  10058.   ffecom_f2c_ptr_to_ftnint_type_node
  10059.     = build_pointer_type (ffecom_f2c_ftnint_type_node);
  10060.  
  10061.   ffecom_float_zero_ = build_real (float_type_node, dconst0);
  10062.   ffecom_double_zero_ = build_real (double_type_node, dconst0);
  10063.   {
  10064.     REAL_VALUE_TYPE point_5;
  10065.  
  10066. #ifdef REAL_ARITHMETIC
  10067.     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
  10068. #else
  10069.     point_5 = .5;
  10070. #endif
  10071.     ffecom_float_half_ = build_real (float_type_node, point_5);
  10072.     ffecom_double_half_ = build_real (double_type_node, point_5);
  10073.   }
  10074.  
  10075. #if 0    /* Code in ste.c that would crash has been commented out. */
  10076.   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
  10077.       < TYPE_PRECISION (string_type_node))
  10078.     /* I/O will probably crash.  */
  10079.     warning ("configuration: char * holds %d bits, but ftnlen only %d",
  10080.          TYPE_PRECISION (string_type_node),
  10081.          TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
  10082. #endif
  10083.  
  10084. #if 0    /* ASSIGN-related stuff has been changed to accommodate this. */
  10085.   if (TYPE_PRECISION (ffecom_integer_type_node)
  10086.       < TYPE_PRECISION (string_type_node))
  10087.     /* ASSIGN 10 TO I will crash.  */
  10088.     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
  10089.  ASSIGN statement might fail",
  10090.          TYPE_PRECISION (string_type_node),
  10091.          TYPE_PRECISION (ffecom_integer_type_node));
  10092. #endif
  10093. }
  10094.  
  10095. #endif
  10096. /* ffecom_init_2 -- Initialize
  10097.  
  10098.    ffecom_init_2();  */
  10099.  
  10100. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10101. void
  10102. ffecom_init_2 ()
  10103. {
  10104.   assert (ffecom_outer_function_decl_ == NULL_TREE);
  10105.   assert (current_function_decl == NULL_TREE);
  10106.   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
  10107.  
  10108.   ffecom_master_arglist_ = NULL;
  10109.   ++ffecom_num_fns_;
  10110.   ffecom_latest_temp_ = NULL;
  10111.   ffecom_primary_entry_ = NULL;
  10112.   ffecom_is_altreturning_ = FALSE;
  10113.   ffecom_func_result_ = NULL_TREE;
  10114.   ffecom_multi_retval_ = NULL_TREE;
  10115. }
  10116.  
  10117. #endif
  10118. /* ffecom_list_expr -- Transform list of exprs into gcc tree
  10119.  
  10120.    tree t;
  10121.    ffebld expr;     // FFE opITEM list.
  10122.    tree = ffecom_list_expr(expr);
  10123.  
  10124.    List of actual args is transformed into corresponding gcc backend list.  */
  10125.  
  10126. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10127. tree
  10128. ffecom_list_expr (ffebld expr)
  10129. {
  10130.   tree list;
  10131.   tree *plist = &list;
  10132.   tree trail = NULL_TREE;    /* Append char length args here. */
  10133.   tree *ptrail = &trail;
  10134.   tree length;
  10135.  
  10136.   while (expr != NULL)
  10137.     {
  10138.       *plist
  10139.     = build_tree_list (NULL_TREE, ffecom_arg_expr (ffebld_head (expr),
  10140.                                &length));
  10141.       plist = &TREE_CHAIN (*plist);
  10142.       expr = ffebld_trail (expr);
  10143.       if (length != NULL)
  10144.     {
  10145.       *ptrail = build_tree_list (NULL_TREE, length);
  10146.       ptrail = &TREE_CHAIN (*ptrail);
  10147.     }
  10148.     }
  10149.  
  10150.   *plist = trail;
  10151.  
  10152.   return list;
  10153. }
  10154.  
  10155. #endif
  10156. /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
  10157.  
  10158.    tree t;
  10159.    ffebld expr;     // FFE opITEM list.
  10160.    tree = ffecom_list_ptr_to_expr(expr);
  10161.  
  10162.    List of actual args is transformed into corresponding gcc backend list for
  10163.    use in calling an external procedure (vs. a statement function).  */
  10164.  
  10165. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10166. tree
  10167. ffecom_list_ptr_to_expr (ffebld expr)
  10168. {
  10169.   tree list;
  10170.   tree *plist = &list;
  10171.   tree trail = NULL_TREE;    /* Append char length args here. */
  10172.   tree *ptrail = &trail;
  10173.   tree length;
  10174.  
  10175.   while (expr != NULL)
  10176.     {
  10177.       *plist
  10178.     = build_tree_list (NULL_TREE,
  10179.                ffecom_arg_ptr_to_expr (ffebld_head (expr),
  10180.                            &length));
  10181.       plist = &TREE_CHAIN (*plist);
  10182.       expr = ffebld_trail (expr);
  10183.       if (length != NULL_TREE)
  10184.     {
  10185.       *ptrail = build_tree_list (NULL_TREE, length);
  10186.       ptrail = &TREE_CHAIN (*ptrail);
  10187.     }
  10188.     }
  10189.  
  10190.   *plist = trail;
  10191.  
  10192.   return list;
  10193. }
  10194.  
  10195. #endif
  10196. /* Obtain gcc's LABEL_DECL tree for label.  */
  10197.  
  10198. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10199. tree
  10200. ffecom_lookup_label (ffelab label)
  10201. {
  10202.   tree glabel;
  10203.  
  10204.   if (ffelab_hook (label) == NULL_TREE)
  10205.     {
  10206.       char labelname[16];
  10207.  
  10208.       switch (ffelab_type (label))
  10209.     {
  10210.     case FFELAB_typeLOOPEND:
  10211.     case FFELAB_typeNOTLOOP:
  10212.     case FFELAB_typeENDIF:
  10213.       sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
  10214.       glabel = build_decl (LABEL_DECL, get_identifier (labelname),
  10215.                    void_type_node);
  10216.       DECL_CONTEXT (glabel) = current_function_decl;
  10217.       DECL_MODE (glabel) = VOIDmode;
  10218.       break;
  10219.  
  10220.     case FFELAB_typeFORMAT:
  10221.       push_obstacks_nochange ();
  10222.       end_temporary_allocation ();
  10223.  
  10224.       glabel = build_decl (VAR_DECL,
  10225.                    ffecom_get_invented_identifier
  10226.                    ("__g77_format_%d", NULL,
  10227.                 (int) ffelab_value (label)),
  10228.                    build_type_variant (build_array_type
  10229.                            (char_type_node,
  10230.                             NULL_TREE),
  10231.                            1, 0));
  10232.       TREE_CONSTANT (glabel) = 1;
  10233.       TREE_STATIC (glabel) = 1;
  10234.       DECL_CONTEXT (glabel) = 0;
  10235.       DECL_INITIAL (glabel) = NULL;
  10236.       make_decl_rtl (glabel, NULL, 0);
  10237.       expand_decl (glabel);
  10238.  
  10239.       resume_temporary_allocation ();
  10240.       pop_obstacks ();
  10241.  
  10242.       break;
  10243.  
  10244.     case FFELAB_typeANY:
  10245.       glabel = error_mark_node;
  10246.       break;
  10247.  
  10248.     default:
  10249.       assert ("bad label type" == NULL);
  10250.       glabel = NULL;
  10251.       break;
  10252.     }
  10253.       ffelab_set_hook (label, glabel);
  10254.     }
  10255.   else
  10256.     {
  10257.       glabel = ffelab_hook (label);
  10258.     }
  10259.  
  10260.   return glabel;
  10261. }
  10262.  
  10263. #endif
  10264. /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
  10265.    a single source specification (as in the fourth argument of MVBITS).
  10266.    If the type is NULL_TREE, the type of lhs is used to make the type of
  10267.    the MODIFY_EXPR.  */
  10268.  
  10269. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10270. tree
  10271. ffecom_modify (tree newtype, tree lhs,
  10272.            tree rhs)
  10273. {
  10274.   if (lhs == error_mark_node || rhs == error_mark_node)
  10275.     return error_mark_node;
  10276.  
  10277.   if (newtype == NULL_TREE)
  10278.     newtype = TREE_TYPE (lhs);
  10279.  
  10280.   if (TREE_SIDE_EFFECTS (lhs))
  10281.     lhs = stabilize_reference (lhs);
  10282.  
  10283.   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
  10284. }
  10285.  
  10286. #endif
  10287.  
  10288. /* Register source file name.  */
  10289.  
  10290. void
  10291. ffecom_file (char *name)
  10292. {
  10293. #if FFECOM_GCC_INCLUDE
  10294.   ffecom_file_ (name);
  10295. #endif
  10296. }
  10297.  
  10298. /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
  10299.  
  10300.    ffestorag st;
  10301.    ffecom_notify_init_storage(st);
  10302.  
  10303.    Gets called when all possible units in an aggregate storage area (a LOCAL
  10304.    with equivalences or a COMMON) have been initialized.  The initialization
  10305.    info either is in ffestorag_init or, if that is NULL,
  10306.    ffestorag_accretion:
  10307.  
  10308.    ffestorag_init may contain an opCONTER or opARRTER.    opCONTER may occur
  10309.    even for an array if the array is one element in length!
  10310.  
  10311.    ffestorag_accretion will contain an opACCTER.  It is much like an
  10312.    opARRTER except it has an ffebit object in it instead of just a size.
  10313.    The back end can use the info in the ffebit object, if it wants, to
  10314.    reduce the amount of actual initialization, but in any case it should
  10315.    kill the ffebit object when done.  Also, set accretion to NULL but
  10316.    init to a non-NULL value.
  10317.  
  10318.    After performing initialization, DO NOT set init to NULL, because that'll
  10319.    tell the front end it is ok for more initialization to happen.  Instead,
  10320.    set init to an opANY expression or some such thing that you can use to
  10321.    tell that you've already initialized the object.
  10322.  
  10323.    27-Oct-91  JCB  1.1
  10324.       Support two-pass FFE.  */
  10325.  
  10326. void
  10327. ffecom_notify_init_storage (ffestorag st)
  10328. {
  10329.   ffebld init;            /* The initialization expression. */
  10330. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10331.   ffetargetOffset size;        /* The size of the entity. */
  10332. #endif
  10333.  
  10334.   if (ffestorag_init (st) == NULL)
  10335.     {
  10336.       init = ffestorag_accretion (st);
  10337.       assert (init != NULL);
  10338.       ffestorag_set_accretion (st, NULL);
  10339.       ffestorag_set_accretes (st, 0);
  10340.  
  10341. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10342.       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
  10343.       size = ffebld_accter_size (init);
  10344.       ffebit_kill (ffebld_accter_bits (init));
  10345.       ffebld_set_op (init, FFEBLD_opARRTER);
  10346.       ffebld_set_arrter (init, ffebld_accter (init));
  10347.       ffebld_arrter_set_size (init, size);
  10348. #endif
  10349.  
  10350. #if FFECOM_TWOPASS
  10351.       ffestorag_set_init (st, init);
  10352. #endif
  10353.     }
  10354. #if FFECOM_ONEPASS
  10355.   else
  10356.     init = ffestorag_init (st);
  10357. #endif
  10358.  
  10359. #if FFECOM_ONEPASS        /* Process the inits, wipe 'em out. */
  10360.   ffestorag_set_init (st, ffebld_new_any ());
  10361.  
  10362.   if (ffebld_op (init) == FFEBLD_opANY)
  10363.     return;            /* Oh, we already did this! */
  10364.  
  10365.   if (ffestorag_symbol (st) != NULL)
  10366.     s = ffestorag_symbol (st);
  10367.   else
  10368.     s = ffestorag_typesymbol (st);
  10369.  
  10370. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  10371.   fprintf (stdout, "= initialize_storage \"%s\" ",
  10372.        (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
  10373.   ffebld_dump (init);
  10374.   fputc ('\n', stdout);
  10375. #endif
  10376.  
  10377. #endif /* if FFECOM_ONEPASS */
  10378. }
  10379.  
  10380. /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
  10381.  
  10382.    ffesymbol s;
  10383.    ffecom_notify_init_symbol(s);
  10384.  
  10385.    Gets called when all possible units in a symbol (not placed in COMMON
  10386.    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
  10387.    have been initialized.  The initialization info either is in
  10388.    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
  10389.  
  10390.    ffesymbol_init may contain an opCONTER or opARRTER.    opCONTER may occur
  10391.    even for an array if the array is one element in length!
  10392.  
  10393.    ffesymbol_accretion will contain an opACCTER.  It is much like an
  10394.    opARRTER except it has an ffebit object in it instead of just a size.
  10395.    The back end can use the info in the ffebit object, if it wants, to
  10396.    reduce the amount of actual initialization, but in any case it should
  10397.    kill the ffebit object when done.  Also, set accretion to NULL but
  10398.    init to a non-NULL value.
  10399.  
  10400.    After performing initialization, DO NOT set init to NULL, because that'll
  10401.    tell the front end it is ok for more initialization to happen.  Instead,
  10402.    set init to an opANY expression or some such thing that you can use to
  10403.    tell that you've already initialized the object.
  10404.  
  10405.    27-Oct-91  JCB  1.1
  10406.       Support two-pass FFE.  */
  10407.  
  10408. void
  10409. ffecom_notify_init_symbol (ffesymbol s)
  10410. {
  10411.   ffebld init;            /* The initialization expression. */
  10412. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10413.   ffetargetOffset size;        /* The size of the entity. */
  10414. #endif
  10415.  
  10416.   if (ffesymbol_storage (s) == NULL)
  10417.     return;            /* Do nothing until COMMON/EQUIVALENCE
  10418.                    possibilities checked. */
  10419.  
  10420.   if (ffesymbol_init (s) == NULL)
  10421.     {
  10422.       init = ffesymbol_accretion (s);
  10423.       assert (init != NULL);
  10424.       ffesymbol_set_accretion (s, NULL);
  10425.       ffesymbol_set_accretes (s, 0);
  10426.  
  10427. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10428.       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
  10429.       size = ffebld_accter_size (init);
  10430.       ffebit_kill (ffebld_accter_bits (init));
  10431.       ffebld_set_op (init, FFEBLD_opARRTER);
  10432.       ffebld_set_arrter (init, ffebld_accter (init));
  10433.       ffebld_arrter_set_size (init, size);
  10434. #endif
  10435.  
  10436. #if FFECOM_TWOPASS
  10437.       ffesymbol_set_init (s, init);
  10438. #endif
  10439.     }
  10440. #if FFECOM_ONEPASS
  10441.   else
  10442.     init = ffesymbol_init (s);
  10443. #endif
  10444.  
  10445. #if FFECOM_ONEPASS
  10446.   ffesymbol_set_init (s, ffebld_new_any ());
  10447.  
  10448.   if (ffebld_op (init) == FFEBLD_opANY)
  10449.     return;            /* Oh, we already did this! */
  10450.  
  10451. #if FFECOM_targetCURRENT == FFECOM_targetFFE
  10452.   fprintf (stdout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
  10453.   ffebld_dump (init);
  10454.   fputc ('\n', stdout);
  10455. #endif
  10456.  
  10457. #endif /* if FFECOM_ONEPASS */
  10458. }
  10459.  
  10460. /* ffecom_notify_primary_entry -- Learn which is the primary entry point
  10461.  
  10462.    ffesymbol s;
  10463.    ffecom_notify_primary_entry(s);
  10464.  
  10465.    Gets called when implicit or explicit PROGRAM statement seen or when
  10466.    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
  10467.    global symbol that serves as the entry point.  */
  10468.  
  10469. void
  10470. ffecom_notify_primary_entry (ffesymbol s)
  10471. {
  10472.   ffecom_primary_entry_ = s;
  10473.   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
  10474.  
  10475.   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
  10476.       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
  10477.     ffecom_primary_entry_is_proc_ = TRUE;
  10478.   else
  10479.     ffecom_primary_entry_is_proc_ = FALSE;
  10480.  
  10481. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10482.   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
  10483.     {
  10484.       ffebld list;
  10485.       ffebld arg;
  10486.  
  10487.       for (list = ffesymbol_dummyargs (s);
  10488.        list != NULL;
  10489.        list = ffebld_trail (list))
  10490.     {
  10491.       arg = ffebld_head (list);
  10492.       if (ffebld_op (arg) == FFEBLD_opSTAR)
  10493.         {
  10494.           ffecom_is_altreturning_ = TRUE;
  10495.           break;
  10496.         }
  10497.     }
  10498.     }
  10499. #endif
  10500. }
  10501.  
  10502. FILE *
  10503. ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
  10504. {
  10505. #if FFECOM_GCC_INCLUDE
  10506.   return ffecom_open_include_ (name, l, c);
  10507. #else
  10508.   return fopen (name, "r");
  10509. #endif
  10510. }
  10511.  
  10512. /* Clean up after making automatically popped call-arg temps.
  10513.  
  10514.    Call this in pairs with push_calltemps around calls to
  10515.    ffecom_arg_ptr_to_expr if the latter might use temporaries.
  10516.    Any temporaries made within the outermost sequence of
  10517.    push_calltemps and pop_calltemps, that are marked as "auto-pop"
  10518.    meaning they won't be explicitly popped (freed), are popped
  10519.    at this point so they can be reused later.
  10520.  
  10521.    NOTE: when called by ffecom_gen_sfuncdef_, ffecom_pending_calls_
  10522.    should come in == 1, and all of the in-use auto-pop temps
  10523.    should have DECL_CONTEXT (temp->t) == current_function_decl.
  10524.    Moreover, these temps should _never_ be re-used in future
  10525.    calls to ffecom_push_tempvar -- since current_function_decl will
  10526.    never be the same again.
  10527.  
  10528.    SO, it could be a minor win in terms of compile time to just
  10529.    strip these temps off the list.  That is, if the above assumptions
  10530.    are correct, just remove from the list of temps any temp
  10531.    that is both in-use and has DECL_CONTEXT (temp->t)
  10532.    == current_function_decl, when called from ffecom_gen_sfuncdef_.  */
  10533.  
  10534. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10535. void
  10536. ffecom_pop_calltemps ()
  10537. {
  10538.   ffecomTemp_ temp;
  10539.  
  10540.   assert (ffecom_pending_calls_ > 0);
  10541.  
  10542.   if (--ffecom_pending_calls_ == 0)
  10543.     for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next)
  10544.       if (temp->auto_pop)
  10545.     temp->in_use = FALSE;
  10546. }
  10547.  
  10548. #endif
  10549. /* Mark latest temp with given tree as no longer in use.  */
  10550.  
  10551. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10552. void
  10553. ffecom_pop_tempvar (tree t)
  10554. {
  10555.   ffecomTemp_ temp;
  10556.  
  10557.   for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next)
  10558.     if (temp->in_use && (temp->t == t))
  10559.       {
  10560.     assert (!temp->auto_pop);
  10561.     temp->in_use = FALSE;
  10562.     return;
  10563.       }
  10564.     else
  10565.       assert (temp->t != t);
  10566.  
  10567.   assert ("couldn't ffecom_pop_tempvar!" != NULL);
  10568. }
  10569.  
  10570. #endif
  10571. /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
  10572.  
  10573.    tree t;
  10574.    ffebld expr;     // FFE expression.
  10575.    tree = ffecom_ptr_to_expr(expr);
  10576.  
  10577.    Like ffecom_expr, but sticks address-of in front of most things.  */
  10578.  
  10579. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10580. tree
  10581. ffecom_ptr_to_expr (ffebld expr)
  10582. {
  10583.   tree item;
  10584.   ffeinfoBasictype bt;
  10585.   ffeinfoKindtype kt;
  10586.   ffesymbol s;
  10587.  
  10588.   assert (expr != NULL);
  10589.  
  10590.   switch (ffebld_op (expr))
  10591.     {
  10592.     case FFEBLD_opSYMTER:
  10593.       s = ffebld_symter (expr);
  10594.       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
  10595.     {
  10596.       ffecomGfrt ix;
  10597.  
  10598.       ix = ffeintrin_gfrt (ffebld_symter_implementation (expr));
  10599.       assert (ix != FFECOM_gfrt);
  10600.       if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
  10601.         {
  10602.           ffecom_make_gfrt_ (ix);
  10603.           item = ffecom_gfrt_[ix];
  10604.         }
  10605.     }
  10606.       else
  10607.     {
  10608.       item = ffesymbol_hook (s).decl_tree;
  10609.       if (item == NULL_TREE)
  10610.         {
  10611.           s = ffecom_sym_transform_ (s);
  10612.           item = ffesymbol_hook (s).decl_tree;
  10613.         }
  10614.     }
  10615.       assert (item != NULL);
  10616.       if (item == error_mark_node)
  10617.     return item;
  10618.       if (!ffesymbol_hook (s).addr)
  10619.     item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
  10620.              item);
  10621.       return item;
  10622.  
  10623.     case FFEBLD_opARRAYREF:
  10624.       {
  10625.     ffebld dims[FFECOM_dimensionsMAX];
  10626.     tree array;
  10627.     int i;
  10628.  
  10629.     item = ffecom_ptr_to_expr (ffebld_left (expr));
  10630.  
  10631.     if (item == error_mark_node)
  10632.       return item;
  10633.  
  10634.     if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING)
  10635.         && !mark_addressable (item))
  10636.       return error_mark_node;    /* Make sure non-const ref is to
  10637.                        non-reg. */
  10638.  
  10639.     /* Build up ARRAY_REFs in reverse order (since we're column major
  10640.        here in Fortran land). */
  10641.  
  10642.     for (i = 0, expr = ffebld_right (expr);
  10643.          expr != NULL;
  10644.          expr = ffebld_trail (expr))
  10645.       dims[i++] = ffebld_head (expr);
  10646.  
  10647.     for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
  10648.          i >= 0;
  10649.          --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
  10650.       {
  10651.         item
  10652.           = ffecom_2 (PLUS_EXPR,
  10653.               build_pointer_type (TREE_TYPE (array)),
  10654.               item,
  10655.               size_binop (MULT_EXPR,
  10656.                       size_in_bytes (TREE_TYPE (array)),
  10657.                       size_binop (MINUS_EXPR,
  10658.                           ffecom_expr (dims[i]),
  10659.                           TYPE_MIN_VALUE (TYPE_DOMAIN (array)))));
  10660.       }
  10661.       }
  10662.       return item;
  10663.  
  10664.     case FFEBLD_opCONTER:
  10665.  
  10666.       bt = ffeinfo_basictype (ffebld_info (expr));
  10667.       kt = ffeinfo_kindtype (ffebld_info (expr));
  10668.  
  10669.       item = ffecom_constantunion (&ffebld_constant_union
  10670.                    (ffebld_conter (expr)), bt, kt,
  10671.                    ffecom_tree_type[bt][kt]);
  10672.       if (item == error_mark_node)
  10673.     return error_mark_node;
  10674.       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
  10675.                item);
  10676.       return item;
  10677.  
  10678.     case FFEBLD_opANY:
  10679.       return error_mark_node;
  10680.  
  10681.     default:
  10682.       assert (ffecom_pending_calls_ > 0);
  10683.  
  10684.       bt = ffeinfo_basictype (ffebld_info (expr));
  10685.       kt = ffeinfo_kindtype (ffebld_info (expr));
  10686.  
  10687.       item = ffecom_expr (expr);
  10688.       if (item == error_mark_node)
  10689.     return error_mark_node;
  10690.  
  10691.       /* The back end currently optimizes a bit too zealously for us, in that
  10692.          we fail JCB001 if the following block of code is omitted.  It checks
  10693.          to see if the transformed expression is a symbol or array reference,
  10694.          and encloses it in a SAVE_EXPR if that is the case.  */
  10695.  
  10696.       STRIP_NOPS (item);
  10697.       if ((TREE_CODE (item) == VAR_DECL)
  10698.       || (TREE_CODE (item) == PARM_DECL)
  10699.       || (TREE_CODE (item) == RESULT_DECL)
  10700.       || (TREE_CODE (item) == INDIRECT_REF)
  10701.       || (TREE_CODE (item) == ARRAY_REF)
  10702.       || (TREE_CODE (item) == COMPONENT_REF)
  10703.       || (TREE_CODE (item) == OFFSET_REF)
  10704.       || (TREE_CODE (item) == BUFFER_REF)
  10705.       || (TREE_CODE (item) == REALPART_EXPR)
  10706.       || (TREE_CODE (item) == IMAGPART_EXPR))
  10707.     {
  10708.       item = ffecom_save_tree (item);
  10709.     }
  10710.  
  10711.       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
  10712.                item);
  10713.       return item;
  10714.     }
  10715.  
  10716.   assert ("fall-through error" == NULL);
  10717.   return error_mark_node;
  10718. }
  10719.  
  10720. #endif
  10721. /* Prepare to make call-arg temps.
  10722.  
  10723.    Call this in pairs with pop_calltemps around calls to
  10724.    ffecom_arg_ptr_to_expr if the latter might use temporaries.  */
  10725.  
  10726. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10727. void
  10728. ffecom_push_calltemps ()
  10729. {
  10730.   ffecom_pending_calls_++;
  10731. }
  10732.  
  10733. #endif
  10734. /* Obtain a temp var with given data type.
  10735.  
  10736.    Returns a VAR_DECL tree of a currently (that is, at the current
  10737.    statement being compiled) not in use and having the given data type,
  10738.    making a new one if necessary.  size is FFETARGET_charactersizeNONE
  10739.    for a non-CHARACTER type or >= 0 for a CHARACTER type.  elements is
  10740.    -1 for a scalar or > 0 for an array of type.  auto_pop is TRUE if
  10741.    ffecom_pop_tempvar won't be called, meaning temp will be freed
  10742.    when #pending calls goes to zero.  */
  10743.  
  10744. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10745. tree
  10746. ffecom_push_tempvar (tree type, ffetargetCharacterSize size, int elements,
  10747.              bool auto_pop)
  10748. {
  10749.   ffecomTemp_ temp;
  10750.   int yes;
  10751.   tree t;
  10752.   static int mynumber;
  10753.  
  10754.   assert (!auto_pop || (ffecom_pending_calls_ > 0));
  10755.  
  10756.   if (type == error_mark_node)
  10757.     return error_mark_node;
  10758.  
  10759.   for (temp = ffecom_latest_temp_; temp != NULL; temp = temp->next)
  10760.     {
  10761.       if (temp->in_use
  10762.       || (temp->type != type)
  10763.       || (temp->size != size)
  10764.       || (temp->elements != elements)
  10765.       || (DECL_CONTEXT (temp->t) != current_function_decl))
  10766.     continue;
  10767.  
  10768.       temp->in_use = TRUE;
  10769.       temp->auto_pop = auto_pop;
  10770.       return temp->t;
  10771.     }
  10772.  
  10773.   assert (ffecom_no_new_tempvars_ == 0);
  10774.  
  10775.   /* Create a new temp. */
  10776.  
  10777.   yes = suspend_momentary ();
  10778.  
  10779.   if (size != FFETARGET_charactersizeNONE)
  10780.     type = build_array_type (type,
  10781.                  build_range_type (ffecom_f2c_ftnlen_type_node,
  10782.                            ffecom_f2c_ftnlen_one_node,
  10783.                            build_int_2 (size, 0)));
  10784.   if (elements != -1)
  10785.     type = build_array_type (type,
  10786.                  build_range_type (integer_type_node,
  10787.                            integer_zero_node,
  10788.                            build_int_2 (elements - 1,
  10789.                                 0)));
  10790.   t = build_decl (VAR_DECL,
  10791.           ffecom_get_invented_identifier ("__g77_expr_%d", NULL,
  10792.                           mynumber++),
  10793.           type);
  10794.   t = start_decl (t, FALSE);
  10795.   finish_decl (t, NULL_TREE, FALSE);
  10796.  
  10797.   resume_momentary (yes);
  10798.  
  10799.   temp = malloc_new_kp (ffe_pool_program_unit (), "ffecomTemp_",
  10800.             sizeof (*temp));
  10801.  
  10802.   temp->next = ffecom_latest_temp_;
  10803.   temp->type = type;
  10804.   temp->t = t;
  10805.   temp->size = size;
  10806.   temp->elements = elements;
  10807.   temp->in_use = TRUE;
  10808.   temp->auto_pop = auto_pop;
  10809.  
  10810.   ffecom_latest_temp_ = temp;
  10811.  
  10812.   return t;
  10813. }
  10814.  
  10815. #endif
  10816. /* ffecom_return_expr -- Returns return-value expr given alt return expr
  10817.  
  10818.    tree rtn;  // NULL_TREE means use expand_null_return()
  10819.    ffebld expr;     // NULL if no alt return expr to RETURN stmt
  10820.    rtn = ffecom_return_expr(expr);
  10821.  
  10822.    Based on the program unit type and other info (like return function
  10823.    type, return master function type when alternate ENTRY points,
  10824.    whether subroutine has any alternate RETURN points, etc), returns the
  10825.    appropriate expression to be returned to the caller, or NULL_TREE
  10826.    meaning no return value or the caller expects it to be returned somewhere
  10827.    else (which is handled by other parts of this module).  */
  10828.  
  10829. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10830. tree
  10831. ffecom_return_expr (ffebld expr)
  10832. {
  10833.   tree rtn;
  10834.  
  10835.   switch (ffecom_primary_entry_kind_)
  10836.     {
  10837.     case FFEINFO_kindPROGRAM:
  10838.     case FFEINFO_kindBLOCKDATA:
  10839.       rtn = NULL_TREE;
  10840.       break;
  10841.  
  10842.     case FFEINFO_kindSUBROUTINE:
  10843.       if (!ffecom_is_altreturning_)
  10844.     rtn = NULL_TREE;    /* No alt returns, never an expr. */
  10845.       else if (expr == NULL)
  10846.     rtn = integer_zero_node;
  10847.       else
  10848.     rtn = ffecom_expr (expr);
  10849.       break;
  10850.  
  10851.     case FFEINFO_kindFUNCTION:
  10852.       if ((ffecom_multi_retval_ != NULL_TREE)
  10853.       || (ffesymbol_basictype (ffecom_primary_entry_)
  10854.           == FFEINFO_basictypeCHARACTER)
  10855.       || ((ffesymbol_basictype (ffecom_primary_entry_)
  10856.            == FFEINFO_basictypeCOMPLEX)
  10857.           && (ffecom_num_entrypoints_ == 0)
  10858.           && ffesymbol_is_f2c (ffecom_primary_entry_)))
  10859.     {            /* Value is returned by direct assignment
  10860.                    into (implicit) dummy. */
  10861.       rtn = NULL_TREE;
  10862.       break;
  10863.     }
  10864.       rtn = ffecom_func_result_;
  10865.       /* used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
  10866.          situation; if the return value has never been referenced, it won't
  10867.          have a tree under 2pass mode. */
  10868.       if ((rtn == NULL_TREE)
  10869.       || !TREE_USED (rtn))
  10870.     {
  10871.       ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
  10872.       ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
  10873.                ffesymbol_where_column (ffecom_primary_entry_));
  10874.       ffebad_string (ffesymbol_text (ffesymbol_funcresult
  10875.                      (ffecom_primary_entry_)));
  10876.       ffebad_finish ();
  10877.     }
  10878.       break;
  10879.  
  10880.     default:
  10881.       assert ("bad unit kind" == NULL);
  10882.     case FFEINFO_kindANY:
  10883.       rtn = error_mark_node;
  10884.       break;
  10885.     }
  10886.  
  10887.   return rtn;
  10888. }
  10889.  
  10890. #endif
  10891. /* Do save_expr only if tree is not error_mark_node.  */
  10892.  
  10893. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10894. tree ffecom_save_tree (tree t)
  10895. {
  10896.   return save_expr (t);
  10897. }
  10898. #endif
  10899.  
  10900. /* Public entry point for front end to access start_decl.  */
  10901.  
  10902. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10903. tree
  10904. ffecom_start_decl (tree decl, bool is_initialized)
  10905. {
  10906.   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
  10907.   return start_decl (decl, FALSE);
  10908. }
  10909.  
  10910. #endif
  10911. /* ffecom_sym_commit -- Symbol's state being committed to reality
  10912.  
  10913.    ffesymbol s;
  10914.    ffecom_sym_commit(s);
  10915.  
  10916.    Does whatever the backend needs when a symbol is committed after having
  10917.    been backtrackable for a period of time.  */
  10918.  
  10919. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10920. void
  10921. ffecom_sym_commit (ffesymbol s)
  10922. {
  10923.   assert (!ffesymbol_retractable ());
  10924. }
  10925.  
  10926. #endif
  10927. /* ffecom_sym_end_transition -- Perform end transition on all symbols
  10928.  
  10929.    ffecom_sym_end_transition();
  10930.  
  10931.    Does backend-specific stuff and also calls ffest_sym_end_transition
  10932.    to do the necessary FFE stuff.
  10933.  
  10934.    Backtracking is never enabled when this fn is called, so don't worry
  10935.    about it.  */
  10936.  
  10937. ffesymbol
  10938. ffecom_sym_end_transition (ffesymbol s)
  10939. {
  10940.   ffestorag st;
  10941.  
  10942.   assert (!ffesymbol_retractable ());
  10943.  
  10944.   s = ffest_sym_end_transition (s);
  10945.  
  10946. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10947.   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
  10948.       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
  10949.     {
  10950.       ffecom_list_blockdata_
  10951.     = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
  10952.                           FFEINTRIN_specNONE,
  10953.                           FFEINTRIN_impNONE),
  10954.                ffecom_list_blockdata_);
  10955.     }
  10956. #endif
  10957.  
  10958.   /* This is where we finally notice that a symbol has partial initialization
  10959.      and finalize it. */
  10960.  
  10961.   if (ffesymbol_accretion (s) != NULL)
  10962.     {
  10963.       assert (ffesymbol_init (s) == NULL);
  10964.       ffecom_notify_init_symbol (s);
  10965.     }
  10966.   else if (((st = ffesymbol_storage (s)) != NULL)
  10967.        && ((st = ffestorag_parent (st)) != NULL)
  10968.        && (ffestorag_accretion (st) != NULL))
  10969.     {
  10970.       assert (ffestorag_init (st) == NULL);
  10971.       ffecom_notify_init_storage (st);
  10972.     }
  10973.  
  10974. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  10975.   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
  10976.       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
  10977.       && (ffesymbol_storage (s) != NULL))
  10978.     {
  10979.       ffecom_list_common_
  10980.     = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
  10981.                           FFEINTRIN_specNONE,
  10982.                           FFEINTRIN_impNONE),
  10983.                ffecom_list_common_);
  10984.     }
  10985. #endif
  10986.  
  10987.   return s;
  10988. }
  10989.  
  10990. /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
  10991.  
  10992.    ffecom_sym_exec_transition();
  10993.  
  10994.    Does backend-specific stuff and also calls ffest_sym_exec_transition
  10995.    to do the necessary FFE stuff.
  10996.  
  10997.    See the long-winded description in ffecom_sym_learned for info
  10998.    on handling the situation where backtracking is inhibited.  */
  10999.  
  11000. ffesymbol
  11001. ffecom_sym_exec_transition (ffesymbol s)
  11002. {
  11003.   s = ffest_sym_exec_transition (s);
  11004.  
  11005.   return s;
  11006. }
  11007.  
  11008. /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
  11009.  
  11010.    ffesymbol s;
  11011.    s = ffecom_sym_learned(s);
  11012.  
  11013.    Called when a new symbol is seen after the exec transition or when more
  11014.    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
  11015.    it arrives here is that all its latest info is updated already, so its
  11016.    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
  11017.    field filled in if its gone through here or exec_transition first, and
  11018.    so on.
  11019.  
  11020.    The backend probably wants to check ffesymbol_retractable() to see if
  11021.    backtracking is in effect.  If so, the FFE's changes to the symbol may
  11022.    be retracted (undone) or committed (ratified), at which time the
  11023.    appropriate ffecom_sym_retract or _commit function will be called
  11024.    for that function.
  11025.  
  11026.    If the backend has its own backtracking mechanism, great, use it so that
  11027.    committal is a simple operation.  Though it doesn't make much difference,
  11028.    I suppose: the reason for tentative symbol evolution in the FFE is to
  11029.    enable error detection in weird incorrect statements early and to disable
  11030.    incorrect error detection on a correct statement.  The backend is not
  11031.    likely to introduce any information that'll get involved in these
  11032.    considerations, so it is probably just fine that the implementation
  11033.    model for this fn and for _exec_transition is to not do anything
  11034.    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
  11035.    and instead wait until ffecom_sym_commit is called (which it never
  11036.    will be as long as we're using ambiguity-detecting statement analysis in
  11037.    the FFE, which we are initially to shake out the code, but don't depend
  11038.    on this), otherwise go ahead and do whatever is needed.
  11039.  
  11040.    In essence, then, when this fn and _exec_transition get called while
  11041.    backtracking is enabled, a general mechanism would be to flag which (or
  11042.    both) of these were called (and in what order? neat question as to what
  11043.    might happen that I'm too lame to think through right now) and then when
  11044.    _commit is called reproduce the original calling sequence, if any, for
  11045.    the two fns (at which point backtracking will, of course, be disabled).  */
  11046.  
  11047. ffesymbol
  11048. ffecom_sym_learned (ffesymbol s)
  11049. {
  11050.   ffestorag_exec_layout (s);
  11051.  
  11052.   return s;
  11053. }
  11054.  
  11055. /* ffecom_sym_retract -- Symbol's state being retracted from reality
  11056.  
  11057.    ffesymbol s;
  11058.    ffecom_sym_retract(s);
  11059.  
  11060.    Does whatever the backend needs when a symbol is retracted after having
  11061.    been backtrackable for a period of time.  */
  11062.  
  11063. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  11064. void
  11065. ffecom_sym_retract (ffesymbol s)
  11066. {
  11067.   assert (!ffesymbol_retractable ());
  11068.  
  11069. #if 0                /* GCC doesn't commit any backtrackable sins,
  11070.                    so nothing needed here. */
  11071.   switch (ffesymbol_hook (s).state)
  11072.     {
  11073.     case 0:            /* nothing happened yet. */
  11074.       break;
  11075.  
  11076.     case 1:            /* exec transition happened. */
  11077.       break;
  11078.  
  11079.     case 2:            /* learned happened. */
  11080.       break;
  11081.  
  11082.     case 3:            /* learned then exec. */
  11083.       break;
  11084.  
  11085.     case 4:            /* exec then learned. */
  11086.       break;
  11087.  
  11088.     default:
  11089.       assert ("bad hook state" == NULL);
  11090.       break;
  11091.     }
  11092. #endif
  11093. }
  11094.  
  11095. #endif
  11096. /* Create temporary gcc label.  */
  11097.  
  11098. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  11099. tree
  11100. ffecom_temp_label ()
  11101. {
  11102.   tree glabel;
  11103.   static int mynumber = 0;
  11104.  
  11105.   glabel = build_decl (LABEL_DECL,
  11106.                ffecom_get_invented_identifier ("__g77_label_%d",
  11107.                                NULL,
  11108.                                mynumber++),
  11109.                void_type_node);
  11110.   DECL_CONTEXT (glabel) = current_function_decl;
  11111.   DECL_MODE (glabel) = VOIDmode;
  11112.  
  11113.   return glabel;
  11114. }
  11115.  
  11116. #endif
  11117. /* Return an expression that is usable as an arg in a conditional context
  11118.    (IF, DO WHILE, .NOT., and so on).
  11119.  
  11120.    Use the one provided for the back end as of >2.6.0.  */
  11121.  
  11122. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  11123. tree
  11124. ffecom_truth_value (tree expr)
  11125. {
  11126.   return truthvalue_conversion (expr);
  11127. }
  11128.  
  11129. #endif
  11130. /* Return the inversion of a truth value (the inversion of what
  11131.    ffecom_truth_value builds).
  11132.  
  11133.    Apparently invert_truthvalue, which is properly in the back end, is
  11134.    enough for now, so just use it.  */
  11135.  
  11136. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  11137. tree
  11138. ffecom_truth_value_invert (tree expr)
  11139. {
  11140.   return invert_truthvalue (ffecom_truth_value (expr));
  11141. }
  11142.  
  11143. #endif
  11144. /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
  11145.  
  11146.    If the PARM_DECL already exists, return it, else create it.    It's an
  11147.    integer_type_node argument for the master function that implements a
  11148.    subroutine or function with more than one entrypoint and is bound at
  11149.    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
  11150.    first ENTRY statement, and so on).  */
  11151.  
  11152. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  11153. tree
  11154. ffecom_which_entrypoint_decl ()
  11155. {
  11156.   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
  11157.  
  11158.   return ffecom_which_entrypoint_decl_;
  11159. }
  11160.  
  11161. #endif
  11162.  
  11163. /* The following sections consists of private and public functions
  11164.    that have the same names and perform roughly the same functions
  11165.    as counterparts in the C front end.  Changes in the C front end
  11166.    might affect how things should be done here.  Only functions
  11167.    needed by the back end should be public here; the rest should
  11168.    be private (static in the C sense).  Functions needed by other
  11169.    g77 front-end modules should be accessed by them via public
  11170.    ffecom_* names, which should themselves call private versions
  11171.    in this section so the private versions are easy to recognize
  11172.    when upgrading to a new gcc and finding interesting changes
  11173.    in the front end.
  11174.  
  11175.    Functions named after rule "foo:" in c-parse.y are named
  11176.    "bison_rule_foo_" so they are easy to find.  */
  11177.  
  11178. #if FFECOM_targetCURRENT == FFECOM_targetGCC
  11179.  
  11180. static void
  11181. bison_rule_compstmt_ ()
  11182. {
  11183.   emit_line_note (input_filename, lineno);
  11184.   expand_end_bindings (getdecls (), 1, 1);
  11185.   poplevel (1, 1, 0);
  11186.   pop_momentary ();
  11187. }
  11188.  
  11189. static void
  11190. bison_rule_pushlevel_ ()
  11191. {
  11192.   emit_line_note (input_filename, lineno);
  11193.   pushlevel (0);
  11194.   clear_last_expr ();
  11195.   push_momentary ();
  11196.   expand_start_bindings (0);
  11197. }
  11198.  
  11199. /* Return a definition for a builtin function named NAME and whose data type
  11200.    is TYPE.  TYPE should be a function type with argument types.
  11201.    FUNCTION_CODE tells later passes how to compile calls to this function.
  11202.    See tree.h for its possible values.
  11203.  
  11204.    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
  11205.    the name to be called if we can't opencode the function.  */
  11206.  
  11207. static tree
  11208. builtin_function (char *name, tree type,
  11209.           enum built_in_function function_code, char *library_name)
  11210. {
  11211.   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
  11212.   DECL_EXTERNAL (decl) = 1;
  11213.   TREE_PUBLIC (decl) = 1;
  11214.   if (library_name)
  11215.     DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
  11216.   make_decl_rtl (decl, NULL_PTR, 1);
  11217.   pushdecl (decl);
  11218.   if (function_code != NOT_BUILT_IN)
  11219.     {
  11220.       DECL_BUILT_IN (decl) = 1;
  11221.       DECL_FUNCTION_CODE (decl) = function_code;
  11222.     }
  11223.  
  11224.   return decl;
  11225. }
  11226.  
  11227. /* Handle when a new declaration NEWDECL
  11228.    has the same name as an old one OLDDECL
  11229.    in the same binding contour.
  11230.    Prints an error message if appropriate.
  11231.  
  11232.    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
  11233.    Otherwise, return 0.  */
  11234.  
  11235. static int
  11236. duplicate_decls (tree newdecl, tree olddecl)
  11237. {
  11238.   int types_match = 1;
  11239.   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
  11240.                && DECL_INITIAL (newdecl) != 0);
  11241.   tree oldtype = TREE_TYPE (olddecl);
  11242.   tree newtype = TREE_TYPE (newdecl);
  11243.  
  11244.   if (TREE_CODE (newtype) == ERROR_MARK
  11245.       || TREE_CODE (oldtype) == ERROR_MARK)
  11246.     types_match = 0;
  11247.  
  11248.   /* New decl is completely inconsistent with the old one =>
  11249.      tell caller to replace the old one.
  11250.      This is always an error except in the case of shadowing a builtin.  */
  11251.   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
  11252.     return 0;
  11253.  
  11254.   /* For real parm decl following a forward decl,
  11255.      return 1 so old decl will be reused.  */
  11256.   if (types_match && TREE_CODE (newdecl) == PARM_DECL
  11257.       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
  11258.     return 1;
  11259.  
  11260.   /* The new declaration is the same kind of object as the old one.
  11261.      The declarations may partially match.  Print warnings if they don't
  11262.      match enough.  Ultimately, copy most of the information from the new
  11263.      decl to the old one, and keep using the old one.  */
  11264.  
  11265.   if (TREE_CODE (olddecl) == FUNCTION_DECL
  11266.       && DECL_BUILT_IN (olddecl))
  11267.     {
  11268.       /* A function declaration for a built-in function.  */
  11269.       if (!TREE_PUBLIC (newdecl))
  11270.     return 0;
  11271.       else if (!types_match)
  11272.     {
  11273.           /* Accept the return type of the new declaration if same modes.  */
  11274.       tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
  11275.       tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
  11276.           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
  11277.             {
  11278.           /* Function types may be shared, so we can't just modify
  11279.          the return type of olddecl's function type.  */
  11280.           tree newtype
  11281.         = build_function_type (newreturntype,
  11282.                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
  11283.           
  11284.               types_match = 1;
  11285.           if (types_match)
  11286.         TREE_TYPE (olddecl) = newtype;
  11287.         }
  11288.     }
  11289.       if (!types_match)
  11290.     return 0;
  11291.     }
  11292.   else if (TREE_CODE (olddecl) == FUNCTION_DECL
  11293.        && DECL_SOURCE_LINE (olddecl) == 0)
  11294.     {
  11295.       /* A function declaration for a predeclared function
  11296.      that isn't actually built in.  */
  11297.       if (!TREE_PUBLIC (newdecl))
  11298.     return 0;
  11299.       else if (!types_match)
  11300.     {
  11301.       /* If the types don't match, preserve volatility indication.
  11302.          Later on, we will discard everything else about the
  11303.          default declaration.  */
  11304.       TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
  11305.     }
  11306.     }
  11307.  
  11308.   /* Copy all the DECL_... slots specified in the new decl
  11309.      except for any that we copy here from the old type.
  11310.  
  11311.      Past this point, we don't change OLDTYPE and NEWTYPE
  11312.      even if we change the types of NEWDECL and OLDDECL.  */
  11313.  
  11314.   if (types_match)
  11315.     {
  11316.       /* Make sure we put the new type in the same obstack as the old ones.
  11317.      If the old types are not both in the same obstack, use the permanent
  11318.      one.  */
  11319.       if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
  11320.     push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
  11321.       else
  11322.     {
  11323.       push_obstacks_nochange ();
  11324.       end_temporary_allocation ();
  11325.     }
  11326.                
  11327.       /* Merge the data types specified in the two decls.  */
  11328.       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
  11329.     TREE_TYPE (newdecl)
  11330.       = TREE_TYPE (olddecl)
  11331.         = TREE_TYPE (newdecl);
  11332.  
  11333.       /* Lay the type out, unless already done.  */
  11334.       if (oldtype != TREE_TYPE (newdecl))
  11335.     {
  11336.       if (TREE_TYPE (newdecl) != error_mark_node)
  11337.         layout_type (TREE_TYPE (newdecl));
  11338.       if (TREE_CODE (newdecl) != FUNCTION_DECL
  11339.           && TREE_CODE (newdecl) != TYPE_DECL
  11340.           && TREE_CODE (newdecl) != CONST_DECL)
  11341.         layout_decl (newdecl, 0);
  11342.     }
  11343.       else
  11344.     {
  11345.       /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
  11346.       DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
  11347.       if (TREE_CODE (olddecl) != FUNCTION_DECL)
  11348.         if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
  11349.           DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
  11350.     }
  11351.  
  11352.       /* Keep the old rtl since we can safely use it.  */
  11353.       DECL_RTL (newdecl) = DECL_RTL (olddecl);
  11354.  
  11355.       /* Merge the type qualifiers.  */
  11356.       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
  11357.       && !TREE_THIS_VOLATILE (newdecl))
  11358.     TREE_THIS_VOLATILE (olddecl) = 0;
  11359.       if (TREE_READONLY (newdecl))
  11360.     TREE_READONLY (olddecl) = 1;
  11361.       if (TREE_THIS_VOLATILE (newdecl))
  11362.     {
  11363.       TREE_THIS_VOLATILE (olddecl) = 1;
  11364.       if (TREE_CODE (newdecl) == VAR_DECL)
  11365.         make_var_volatile (newdecl);
  11366.     }
  11367.  
  11368.       /* Keep source location of definition rather than declaration.
  11369.      Likewise, keep decl at outer scope.  */
  11370.       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
  11371.       || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
  11372.     {
  11373.       DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
  11374.       DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
  11375.  
  11376.       if (DECL_CONTEXT (olddecl) == 0)
  11377.         DECL_CONTEXT (newdecl) = 0;
  11378.     }
  11379.  
  11380.       /* Merge the unused-warning information.  */
  11381.       if (DECL_IN_SYSTEM_HEADER (olddecl))
  11382.     DECL_IN_SYSTEM_HEADER (newdecl) = 1;
  11383.       else if (DECL_IN_SYSTEM_HEADER (newdecl))
  11384.     DECL_IN_SYSTEM_HEADER (olddecl) = 1;
  11385.  
  11386.       /* Merge the initialization information.  */
  11387.       if (DECL_INITIAL (newdecl) == 0)
  11388.     DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
  11389.  
  11390.       /* Merge the section attribute.
  11391.          We want to issue an error if the sections conflict but that must be
  11392.      done later in decl_attributes since we are called before attributes
  11393.      are assigned.  */
  11394.       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
  11395.     DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
  11396.  
  11397.       pop_obstacks ();
  11398.     }
  11399.   /* If cannot merge, then use the new type and qualifiers,
  11400.      and don't preserve the old rtl.  */
  11401.   else
  11402.     {
  11403.       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
  11404.       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
  11405.       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
  11406.       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
  11407.     }
  11408.  
  11409.   /* Merge the storage class information.  */
  11410.   /* For functions, static overrides non-static.  */
  11411.   if (TREE_CODE (newdecl) == FUNCTION_DECL)
  11412.     {
  11413.       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
  11414.       /* This is since we don't automatically
  11415.      copy the attributes of NEWDECL into OLDDECL.  */
  11416.       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
  11417.       /* If this clears `static', clear it in the identifier too.  */
  11418.       if (! TREE_PUBLIC (olddecl))
  11419.     TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
  11420.     }
  11421.   if (DECL_EXTERNAL (newdecl))
  11422.     {
  11423.       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
  11424.       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
  11425.       /* An extern decl does not override previous storage class.  */
  11426.       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
  11427.     }
  11428.   else
  11429.     {
  11430.       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
  11431.       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
  11432.     }
  11433.  
  11434.   /* If either decl says `inline', this fn is inline,
  11435.      unless its definition was passed already.  */
  11436.   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
  11437.     DECL_INLINE (olddecl) = 1;
  11438.   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
  11439.  
  11440.   /* Get rid of any built-in function if new arg types don't match it
  11441.      or if we have a function definition.  */
  11442.   if (TREE_CODE (newdecl) == FUNCTION_DECL
  11443.       && DECL_BUILT_IN (olddecl)
  11444.       && (!types_match || new_is_definition))
  11445.     {
  11446.       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
  11447.       DECL_BUILT_IN (olddecl) = 0;
  11448.     }
  11449.  
  11450.   /* If redeclaring a builtin function, and not a definition,
  11451.      it stays built in.
  11452.      Also preserve various other info from the definition.  */
  11453.   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
  11454.     {
  11455.       if (DECL_BUILT_IN (olddecl))
  11456.     {
  11457.       DECL_BUILT_IN (newdecl) = 1;
  11458.       DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
  11459.     }
  11460.       else
  11461.     DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
  11462.  
  11463.       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
  11464.       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
  11465.       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
  11466.       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
  11467.     }
  11468.  
  11469.   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
  11470.      But preserve olddecl's DECL_UID.  */
  11471.   {
  11472.     register unsigned olddecl_uid = DECL_UID (olddecl);
  11473.  
  11474.     bcopy ((char *) newdecl + sizeof (struct tree_common),
  11475.        (char *) olddecl + sizeof (struct tree_common),
  11476.        sizeof (struct tree_decl) - sizeof (struct tree_common));
  11477.     DECL_UID (olddecl) = olddecl_uid;
  11478.   }
  11479.  
  11480.   return 1;
  11481. }
  11482.  
  11483. /* Finish processing of a declaration;
  11484.    install its initial value.
  11485.    If the length of an array type is not known before,
  11486.    it must be determined now, from the initial value, or it is an error.  */
  11487.  
  11488. static void
  11489. finish_decl (tree decl, tree init, bool is_top_level)
  11490. {
  11491.   register tree type = TREE_TYPE (decl);
  11492.   int was_incomplete = (DECL_SIZE (decl) == 0);
  11493.   int temporary = allocation_temporary_p ();
  11494.   bool at_top_level = (current_binding_level == global_binding_level);
  11495.   bool top_level = is_top_level || at_top_level;
  11496.  
  11497.   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
  11498.      level anyway.  */
  11499.   assert (!is_top_level || !at_top_level);
  11500.  
  11501.   if (TREE_CODE (decl) == PARM_DECL)
  11502.     assert (init == NULL_TREE);
  11503.   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
  11504.      overlaps DECL_ARG_TYPE.  */
  11505.   else if (init == NULL_TREE)
  11506.     assert (DECL_INITIAL (decl) == NULL_TREE);
  11507.   else
  11508.     assert (DECL_INITIAL (decl) == error_mark_node);
  11509.  
  11510.   if (init != NULL_TREE)
  11511.     {
  11512.       if (TREE_CODE (decl) != TYPE_DECL)
  11513.     DECL_INITIAL (decl) = init;
  11514.       else
  11515.     {
  11516.       /* typedef foo = bar; store the type of bar as the type of foo.  */
  11517.       TREE_TYPE (decl) = TREE_TYPE (init);
  11518.       DECL_INITIAL (decl) = init = 0;
  11519.     }
  11520.     }
  11521.  
  11522.   /* Pop back to the obstack that is current for this binding level. This is
  11523.      because MAXINDEX, rtl, etc. to be made below must go in the permanent
  11524.      obstack.  But don't discard the temporary data yet.  */
  11525.   pop_obstacks ();
  11526.  
  11527.   /* Deduce size of array from initialization, if not already known */
  11528.  
  11529.   if (TREE_CODE (type) == ARRAY_TYPE
  11530.       && TYPE_DOMAIN (type) == 0
  11531.       && TREE_CODE (decl) != TYPE_DECL)
  11532.     {
  11533.       assert (top_level);
  11534.       assert (was_incomplete);
  11535.  
  11536.       layout_decl (decl, 0);
  11537.     }
  11538.  
  11539.   if (TREE_CODE (decl) == VAR_DECL)
  11540.     {
  11541.       if (DECL_SIZE (decl) == NULL_TREE
  11542.       && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
  11543.     layout_decl (decl, 0);
  11544.  
  11545.       if (DECL_SIZE (decl) == NULL_TREE
  11546.       && (TREE_STATIC (decl)
  11547.           ?
  11548.       /* A static variable with an incomplete type is an error if it is
  11549.          initialized. Also if it is not file scope. Otherwise, let it
  11550.          through, but if it is not `extern' then it may cause an error
  11551.          message later.  */
  11552.           (DECL_INITIAL (decl) != NULL_TREE
  11553.            || !top_level)
  11554.           :
  11555.       /* An automatic variable with an incomplete type is an error.  */
  11556.           !DECL_EXTERNAL (decl)))
  11557.     {
  11558.       assert ("storage size not known" == NULL);
  11559.       abort ();
  11560.     }
  11561.  
  11562.       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
  11563.       && (DECL_SIZE (decl) != 0)
  11564.       && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
  11565.     {
  11566.       assert ("storage size not constant" == NULL);
  11567.       abort ();
  11568.     }
  11569.     }
  11570.  
  11571.   /* Output the assembler code and/or RTL code for variables and functions,
  11572.      unless the type is an undefined structure or union. If not, it will get
  11573.      done when the type is completed.  */
  11574.  
  11575.   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
  11576.     {
  11577.       rest_of_decl_compilation (decl, NULL,
  11578.                 is_top_level || at_top_level,
  11579.                 0);
  11580.  
  11581.       if (!top_level)
  11582.     {
  11583.       /* Recompute the RTL of a local array now if it used to be an
  11584.          incomplete type.  */
  11585.       if (was_incomplete
  11586.           && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
  11587.         {
  11588.           /* If we used it already as memory, it must stay in memory.  */
  11589.           TREE_ADDRESSABLE (decl) = TREE_USED (decl);
  11590.           /* If it's still incomplete now, no init will save it.  */
  11591.           if (DECL_SIZE (decl) == 0)
  11592.         DECL_INITIAL (decl) = 0;
  11593.           expand_decl (decl);
  11594.         }
  11595.       /* Compute and store the initial value.  */
  11596.       if (TREE_CODE (decl) != FUNCTION_DECL)
  11597.         expand_decl_init (decl);
  11598.     }
  11599.     }
  11600.   else if (TREE_CODE (decl) == TYPE_DECL)
  11601.     {
  11602.       rest_of_decl_compilation (decl, NULL_PTR,
  11603.                 is_top_level || at_top_level,
  11604.                 0);
  11605.     }
  11606.  
  11607.   /* This test used to include TREE_PERMANENT, however, we have the same
  11608.      problem with initializers at the function level.  Such initializers get
  11609.      saved until the end of the function on the momentary_obstack.  */
  11610.   if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
  11611.       && temporary
  11612.   /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
  11613.      DECL_ARG_TYPE.  */
  11614.       && TREE_CODE (decl) != PARM_DECL)
  11615.     {
  11616.       /* We need to remember that this array HAD an initialization, but
  11617.          discard the actual temporary nodes, since we can't have a permanent
  11618.          node keep pointing to them.  */
  11619.       /* We make an exception for inline functions, since it's normal for a
  11620.          local extern redeclaration of an inline function to have a copy of
  11621.          the top-level decl's DECL_INLINE.  */
  11622.       if ((DECL_INITIAL (decl) != 0)
  11623.       && (DECL_INITIAL (decl) != error_mark_node))
  11624.     {
  11625.       /* If this is a const variable, then preserve the
  11626.          initializer instead of discarding it so that we can optimize
  11627.          references to it.  */
  11628.       /* This test used to include TREE_STATIC, but this won't be set
  11629.          for function level initializers.  */
  11630.       if (TREE_READONLY (decl))
  11631.         {
  11632.           preserve_initializer ();
  11633.           /* Hack?  Set the permanent bit for something that is
  11634.              permanent, but not on the permenent obstack, so as to
  11635.              convince output_constant_def to make its rtl on the
  11636.              permanent obstack.  */
  11637.           TREE_PERMANENT (DECL_INITIAL (decl)) = 1;
  11638.  
  11639.           /* The initializer and DECL must have the same (or equivalent
  11640.          types), but if the initializer is a STRING_CST, its type
  11641.          might not be on the right obstack, so copy the type
  11642.          of DECL.  */
  11643.           TREE_TYPE (DECL_INITIAL (decl)) = type;
  11644.         }
  11645.       else
  11646.         DECL_INITIAL (decl) = error_mark_node;
  11647.     }
  11648.     }
  11649.  
  11650.   /* If requested, warn about definitions of large data objects.  */
  11651.  
  11652.   if (warn_larger_than
  11653.       && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL)
  11654.       && !DECL_EXTERNAL (decl))
  11655.     {
  11656.       register tree decl_size = DECL_SIZE (decl);
  11657.  
  11658.       if (decl_size && TREE_CODE (decl_size) == INTEGER_CST)
  11659.     {
  11660.        unsigned units = TREE_INT_CST_LOW (decl_size) / BITS_PER_UNIT;
  11661.  
  11662.       if (units > larger_than_size)
  11663.         warning_with_decl (decl, "size of `%s' is %u bytes", units);
  11664.     }
  11665.     }
  11666.  
  11667.   /* If we have gone back from temporary to permanent allocation, actually
  11668.      free the temporary space that we no longer need.  */
  11669.   if (temporary && !allocation_temporary_p ())
  11670.     permanent_allocation (0);
  11671.  
  11672.   /* At the end of a declaration, throw away any variable type sizes of types
  11673.      defined inside that declaration.  There is no use computing them in the
  11674.      following function definition.  */
  11675.   if (current_binding_level == global_binding_level)
  11676.     get_pending_sizes ();
  11677. }
  11678.  
  11679. /* Finish up a function declaration and compile that function
  11680.    all the way to assembler language output.  The free the storage
  11681.    for the function definition.
  11682.  
  11683.    This is called after parsing the body of the function definition.
  11684.  
  11685.    NESTED is nonzero if the function being finished is nested in another.  */
  11686.  
  11687. static void
  11688. finish_function (int nested)
  11689. {
  11690.   register tree fndecl = current_function_decl;
  11691.  
  11692.   assert (fndecl != NULL_TREE);
  11693.   if (nested)
  11694.     assert (DECL_CONTEXT (fndecl) != NULL_TREE);
  11695.   else
  11696.     assert (DECL_CONTEXT (fndecl) == NULL_TREE);
  11697.  
  11698. /*  TREE_READONLY (fndecl) = 1;
  11699.     This caused &foo to be of type ptr-to-const-function
  11700.     which then got a warning when stored in a ptr-to-function variable.  */
  11701.  
  11702.   poplevel (1, 0, 1);
  11703.   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
  11704.  
  11705.   /* Must mark the RESULT_DECL as being in this function.  */
  11706.  
  11707.   DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
  11708.  
  11709.   /* Obey `register' declarations if `setjmp' is called in this fn.  */
  11710.   /* Generate rtl for function exit.  */
  11711.   expand_function_end (input_filename, lineno, 0);
  11712.  
  11713.   /* So we can tell if jump_optimize sets it to 1.  */
  11714.   can_reach_end = 0;
  11715.  
  11716.   /* Run the optimizers and output the assembler code for this function.  */
  11717.   rest_of_compilation (fndecl);
  11718.  
  11719.   /* Free all the tree nodes making up this function.  */
  11720.   /* Switch back to allocating nodes permanently until we start another
  11721.      function.  */
  11722.   if (!nested)
  11723.     permanent_allocation (1);
  11724.  
  11725.   if (DECL_SAVED_INSNS (fndecl) == 0 && !nested)
  11726.     {
  11727.       /* Stop pointing to the local nodes about to be freed.  */
  11728.       /* But DECL_INITIAL must remain nonzero so we know this was an actual
  11729.          function definition.  */
  11730.       /* For a nested function, this is done in pop_f_function_context.  */
  11731.       /* If rest_of_compilation set this to 0, leave it 0.  */
  11732.       if (DECL_INITIAL (fndecl) != 0)
  11733.     DECL_INITIAL (fndecl) = error_mark_node;
  11734.       DECL_ARGUMENTS (fndecl) = 0;
  11735.     }
  11736.  
  11737.   if (!nested)
  11738.     {
  11739.       /* Let the error reporting routines know that we're outside a function.
  11740.          For a nested function, this value is used in pop_c_function_context
  11741.          and then reset via pop_function_context.  */
  11742.       ffecom_outer_function_decl_ = current_function_decl = NULL;
  11743.     }
  11744. }
  11745.  
  11746. /* Plug-in replacement for identifying the name of a decl and, for a
  11747.    function, what we call it in diagnostics.  For now, "program unit"
  11748.    should suffice, since it's a bit of a hassle to figure out which
  11749.    of several kinds of things it is.  Note that it could conceivably
  11750.    be a statement function, which probably isn't really a program unit
  11751.    per se, but if that comes up, it should be easy to check (being a
  11752.    nested function and all).  */
  11753.  
  11754. static char *
  11755. lang_printable_name (tree decl, char **kind)
  11756. {
  11757.   *kind = "program unit";
  11758.   return IDENTIFIER_POINTER (DECL_NAME (decl));
  11759. }
  11760.  
  11761. /* Similar to `lookup_name' but look only at current binding level.  */
  11762.  
  11763. static tree
  11764. lookup_name_current_level (tree name)
  11765. {
  11766.   register tree t;
  11767.  
  11768.   if (current_binding_level == global_binding_level)
  11769.     return IDENTIFIER_GLOBAL_VALUE (name);
  11770.  
  11771.   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
  11772.     return 0;
  11773.  
  11774.   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
  11775.     if (DECL_NAME (t) == name)
  11776.       break;
  11777.  
  11778.   return t;
  11779. }
  11780.  
  11781. /* Create a new `struct binding_level'.  */
  11782.  
  11783. static struct binding_level *
  11784. make_binding_level ()
  11785. {
  11786.   /* NOSTRICT */
  11787.   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
  11788. }
  11789.  
  11790. /* Save and restore the variables in this file and elsewhere
  11791.    that keep track of the progress of compilation of the current function.
  11792.    Used for nested functions.  */
  11793.  
  11794. struct f_function
  11795. {
  11796.   struct f_function *next;
  11797.   tree named_labels;
  11798.   tree shadowed_labels;
  11799.   struct binding_level *binding_level;
  11800. };
  11801.  
  11802. struct f_function *f_function_chain;
  11803.  
  11804. /* Restore the variables used during compilation of a C function.  */
  11805.  
  11806. static void
  11807. pop_f_function_context ()
  11808. {
  11809.   struct f_function *p = f_function_chain;
  11810.   tree link;
  11811.  
  11812.   /* Bring back all the labels that were shadowed.  */
  11813.   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
  11814.     if (DECL_NAME (TREE_VALUE (link)) != 0)
  11815.       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
  11816.     = TREE_VALUE (link);
  11817.  
  11818.   if (DECL_SAVED_INSNS (current_function_decl) == 0)
  11819.     {
  11820.       /* Stop pointing to the local nodes about to be freed.  */
  11821.       /* But DECL_INITIAL must remain nonzero so we know this was an actual
  11822.          function definition.  */
  11823.       DECL_INITIAL (current_function_decl) = error_mark_node;
  11824.       DECL_ARGUMENTS (current_function_decl) = 0;
  11825.     }
  11826.  
  11827.   pop_function_context ();
  11828.  
  11829.   f_function_chain = p->next;
  11830.  
  11831.   named_labels = p->named_labels;
  11832.   shadowed_labels = p->shadowed_labels;
  11833.   current_binding_level = p->binding_level;
  11834.  
  11835.   free (p);
  11836. }
  11837.  
  11838. /* Save and reinitialize the variables
  11839.    used during compilation of a C function.  */
  11840.  
  11841. static void
  11842. push_f_function_context ()
  11843. {
  11844.   struct f_function *p
  11845.   = (struct f_function *) xmalloc (sizeof (struct f_function));
  11846.  
  11847.   push_function_context ();
  11848.  
  11849.   p->next = f_function_chain;
  11850.   f_function_chain = p;
  11851.  
  11852.   p->named_labels = named_labels;
  11853.   p->shadowed_labels = shadowed_labels;
  11854.   p->binding_level = current_binding_level;
  11855. }
  11856.  
  11857. static void
  11858. push_parm_decl (tree parm)
  11859. {
  11860.   int old_immediate_size_expand = immediate_size_expand;
  11861.  
  11862.   /* Don't try computing parm sizes now -- wait till fn is called.  */
  11863.  
  11864.   immediate_size_expand = 0;
  11865.  
  11866.   push_obstacks_nochange ();
  11867.  
  11868.   /* Fill in arg stuff.  */
  11869.  
  11870.   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
  11871.   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
  11872.   TREE_READONLY (parm) = 1;    /* All implementation args are read-only. */
  11873.  
  11874.   parm = pushdecl (parm);
  11875.  
  11876.   immediate_size_expand = old_immediate_size_expand;
  11877.  
  11878.   finish_decl (parm, NULL_TREE, FALSE);
  11879. }
  11880.  
  11881. /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
  11882.  
  11883. static tree
  11884. pushdecl_top_level (x)
  11885.      tree x;
  11886. {
  11887.   register tree t;
  11888.   register struct binding_level *b = current_binding_level;
  11889.   register tree f = current_function_decl;
  11890.  
  11891.   current_binding_level = global_binding_level;
  11892.   current_function_decl = NULL_TREE;
  11893.   t = pushdecl (x);
  11894.   current_binding_level = b;
  11895.   current_function_decl = f;
  11896.   return t;
  11897. }
  11898.  
  11899. /* Store the list of declarations of the current level.
  11900.    This is done for the parameter declarations of a function being defined,
  11901.    after they are modified in the light of any missing parameters.  */
  11902.  
  11903. static tree
  11904. storedecls (decls)
  11905.      tree decls;
  11906. {
  11907.   return current_binding_level->names = decls;
  11908. }
  11909.  
  11910. /* Store the parameter declarations into the current function declaration.
  11911.    This is called after parsing the parameter declarations, before
  11912.    digesting the body of the function.
  11913.  
  11914.    For an old-style definition, modify the function's type
  11915.    to specify at least the number of arguments.  */
  11916.  
  11917. static void
  11918. store_parm_decls (int is_main_program)
  11919. {
  11920.   register tree fndecl = current_function_decl;
  11921.  
  11922.   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
  11923.   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
  11924.  
  11925.   /* Initialize the RTL code for the function.  */
  11926.  
  11927.   init_function_start (fndecl, input_filename, lineno);
  11928.  
  11929.   /* Set up parameters and prepare for return, for the function.  */
  11930.  
  11931.   expand_function_start (fndecl, 0);
  11932. }
  11933.  
  11934. static tree
  11935. start_decl (tree decl, bool is_top_level)
  11936. {
  11937.   register tree tem;
  11938.   bool at_top_level = (current_binding_level == global_binding_level);
  11939.   bool top_level = is_top_level || at_top_level;
  11940.  
  11941.   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
  11942.      level anyway.  */
  11943.   assert (!is_top_level || !at_top_level);
  11944.  
  11945.   /* The corresponding pop_obstacks is in finish_decl.  */
  11946.   push_obstacks_nochange ();
  11947.  
  11948.   if (DECL_INITIAL (decl) != NULL_TREE)
  11949.     {
  11950.       assert (DECL_INITIAL (decl) == error_mark_node);
  11951.       assert (!DECL_EXTERNAL (decl));
  11952.     }
  11953.   else if (top_level)
  11954.     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
  11955.  
  11956.   /* Add this decl to the current binding level. TEM may equal DECL or it may
  11957.      be a previous decl of the same name.  */
  11958.   if (is_top_level)
  11959.     tem = pushdecl_top_level (decl);
  11960.   else
  11961.     tem = pushdecl (decl);
  11962.  
  11963.   /* For Fortran, we by default put things in .common when possible.  */
  11964.   DECL_COMMON (tem) = 1;
  11965.  
  11966.   /* For a local variable, define the RTL now.  */
  11967.   if (!top_level
  11968.   /* But not if this is a duplicate decl and we preserved the rtl from the
  11969.      previous one (which may or may not happen).  */
  11970.       && DECL_RTL (tem) == 0)
  11971.     {
  11972.       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
  11973.     expand_decl (tem);
  11974.       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
  11975.            && DECL_INITIAL (tem) != 0)
  11976.     expand_decl (tem);
  11977.     }
  11978.  
  11979.   if (DECL_INITIAL (tem) != NULL_TREE)
  11980.     {
  11981.       /* When parsing and digesting the initializer, use temporary storage.
  11982.          Do this even if we will ignore the value.  */
  11983.       if (at_top_level)
  11984.     temporary_allocation ();
  11985.     }
  11986.  
  11987.   return tem;
  11988. }
  11989.  
  11990. /* Create the FUNCTION_DECL for a function definition.
  11991.    DECLSPECS and DECLARATOR are the parts of the declaration;
  11992.    they describe the function's name and the type it returns,
  11993.    but twisted together in a fashion that parallels the syntax of C.
  11994.  
  11995.    This function creates a binding context for the function body
  11996.    as well as setting up the FUNCTION_DECL in current_function_decl.
  11997.  
  11998.    Returns 1 on success.  If the DECLARATOR is not suitable for a function
  11999.    (it defines a datum instead), we return 0, which tells
  12000.    yyparse to report a parse error.
  12001.  
  12002.    NESTED is nonzero for a function nested within another function.  */
  12003.  
  12004. static void
  12005. start_function (tree name, tree type, int nested, int public)
  12006. {
  12007.   tree decl1;
  12008.   tree restype;
  12009.   int old_immediate_size_expand = immediate_size_expand;
  12010.  
  12011.   named_labels = 0;
  12012.   shadowed_labels = 0;
  12013.  
  12014.   /* Don't expand any sizes in the return type of the function.  */
  12015.   immediate_size_expand = 0;
  12016.  
  12017.   if (nested)
  12018.     {
  12019.       assert (!public);
  12020.       assert (current_function_decl != NULL_TREE);
  12021.       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
  12022.     }
  12023.   else
  12024.     {
  12025.       assert (current_function_decl == NULL_TREE);
  12026.     }
  12027.  
  12028.   decl1 = build_decl (FUNCTION_DECL,
  12029.               name,
  12030.               type);
  12031.   TREE_PUBLIC (decl1) = public ? 1 : 0;
  12032.   if (nested)
  12033.     DECL_INLINE (decl1) = 1;
  12034.   TREE_STATIC (decl1) = 1;
  12035.   DECL_EXTERNAL (decl1) = 0;
  12036.  
  12037.   announce_function (decl1);
  12038.  
  12039.   /* Make the init_value nonzero so pushdecl knows this is not tentative.
  12040.      error_mark_node is replaced below (in poplevel) with the BLOCK.  */
  12041.   DECL_INITIAL (decl1) = error_mark_node;
  12042.  
  12043.   /* Record the decl so that the function name is defined. If we already have
  12044.      a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
  12045.  
  12046.   current_function_decl = pushdecl (decl1);
  12047.   if (!nested)
  12048.     ffecom_outer_function_decl_ = current_function_decl;
  12049.  
  12050.   pushlevel (0);
  12051.  
  12052.   make_function_rtl (current_function_decl);
  12053.  
  12054.   restype = TREE_TYPE (TREE_TYPE (current_function_decl));
  12055.   DECL_RESULT (current_function_decl)
  12056.     = build_decl (RESULT_DECL, NULL_TREE, restype);
  12057.  
  12058.   if (!nested)
  12059.     /* Allocate further tree nodes temporarily during compilation of this
  12060.        function only.  */
  12061.     temporary_allocation ();
  12062.  
  12063.   if (!nested)
  12064.     TREE_ADDRESSABLE (current_function_decl) = 1;
  12065.  
  12066.   immediate_size_expand = old_immediate_size_expand;
  12067. }
  12068.  
  12069. /* Here are the public functions the GNU back end needs.  */
  12070.  
  12071. tree
  12072. convert (type, expr)
  12073.      tree type, expr;
  12074. {
  12075.   register tree e = expr;
  12076.   register enum tree_code code = TREE_CODE (type);
  12077.  
  12078.   if (type == TREE_TYPE (expr)
  12079.       || TREE_CODE (expr) == ERROR_MARK)
  12080.     return expr;
  12081.   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (expr)))
  12082.     return fold (build1 (NOP_EXPR, type, expr));
  12083.   if (TREE_CODE (TREE_TYPE (expr)) == ERROR_MARK
  12084.       || code == ERROR_MARK)
  12085.     return error_mark_node;
  12086.   if (TREE_CODE (TREE_TYPE (expr)) == VOID_TYPE)
  12087.     {
  12088.       assert ("void value not ignored as it ought to be" == NULL);
  12089.       return error_mark_node;
  12090.     }
  12091.   if (code == VOID_TYPE)
  12092.     return build1 (CONVERT_EXPR, type, e);
  12093.   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
  12094.     return fold (convert_to_integer (type, e));
  12095.   if (code == POINTER_TYPE)
  12096.     return fold (convert_to_pointer (type, e));
  12097.   if (code == REAL_TYPE)
  12098.     return fold (convert_to_real (type, e));
  12099.   if (code == COMPLEX_TYPE)
  12100.     return fold (convert_to_complex (type, e));
  12101.  
  12102.   assert ("conversion to non-scalar type requested" == NULL);
  12103.   return error_mark_node;
  12104. }
  12105.  
  12106. /* integrate_decl_tree calls this function, but since we don't use the
  12107.    DECL_LANG_SPECIFIC field, this is a no-op.  */
  12108.  
  12109. void
  12110. copy_lang_decl (node)
  12111.      tree node;
  12112. {
  12113. }
  12114.  
  12115. /* Return the list of declarations of the current level.
  12116.    Note that this list is in reverse order unless/until
  12117.    you nreverse it; and when you do nreverse it, you must
  12118.    store the result back using `storedecls' or you will lose.  */
  12119.  
  12120. tree
  12121. getdecls ()
  12122. {
  12123.   return current_binding_level->names;
  12124. }
  12125.  
  12126. /* Nonzero if we are currently in the global binding level.  */
  12127.  
  12128. int
  12129. global_bindings_p ()
  12130. {
  12131.   return current_binding_level == global_binding_level;
  12132. }
  12133.  
  12134. /* Insert BLOCK at the end of the list of subblocks of the
  12135.    current binding level.  This is used when a BIND_EXPR is expanded,
  12136.    to handle the BLOCK node inside the BIND_EXPR.  */
  12137.  
  12138. void
  12139. incomplete_type_error (value, type)
  12140.      tree value;
  12141.      tree type;
  12142. {
  12143.   if (TREE_CODE (type) == ERROR_MARK)
  12144.     return;
  12145.  
  12146.   assert ("incomplete type?!?" == NULL);
  12147. }
  12148.  
  12149. void
  12150. init_decl_processing ()
  12151. {
  12152.   malloc_init ();
  12153.   ffe_init_0 ();
  12154. }
  12155.  
  12156. void
  12157. init_lex ()
  12158. {
  12159.   extern char *(*decl_printable_name) ();
  12160.  
  12161.   /* Make identifier nodes long enough for the language-specific slots.  */
  12162.   set_identifier_size (sizeof (struct lang_identifier));
  12163.   decl_printable_name = lang_printable_name;
  12164. }
  12165.  
  12166. void
  12167. insert_block (block)
  12168.      tree block;
  12169. {
  12170.   TREE_USED (block) = 1;
  12171.   current_binding_level->blocks
  12172.     = chainon (current_binding_level->blocks, block);
  12173. }
  12174.  
  12175. int
  12176. lang_decode_option (p)
  12177.      char *p;
  12178. {
  12179.   return ffe_decode_option (p);
  12180. }
  12181.  
  12182. void
  12183. lang_finish ()
  12184. {
  12185.   ffe_terminate_0 ();
  12186.  
  12187.   if (ffe_is_ffedebug ())
  12188.     malloc_pool_display (malloc_pool_image ());
  12189. }
  12190.  
  12191. char *
  12192. lang_identify ()
  12193. {
  12194.   return "f77";
  12195. }
  12196.  
  12197. void
  12198. lang_init ()
  12199. {
  12200. }
  12201.  
  12202. int
  12203. mark_addressable (exp)
  12204.      tree exp;
  12205. {
  12206.   register tree x = exp;
  12207.   while (1)
  12208.     switch (TREE_CODE (x))
  12209.       {
  12210.       case ADDR_EXPR:
  12211.       case COMPONENT_REF:
  12212.       case ARRAY_REF:
  12213.     x = TREE_OPERAND (x, 0);
  12214.     break;
  12215.  
  12216.       case CONSTRUCTOR:
  12217.     TREE_ADDRESSABLE (x) = 1;
  12218.     return 1;
  12219.  
  12220.       case VAR_DECL:
  12221.       case CONST_DECL:
  12222.       case PARM_DECL:
  12223.       case RESULT_DECL:
  12224.     if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
  12225.         && DECL_NONLOCAL (x))
  12226.       {
  12227.         if (TREE_PUBLIC (x))
  12228.           {
  12229.         assert ("address of global register var requested" == NULL);
  12230.         return 0;
  12231.           }
  12232.         assert ("address of register variable requested" == NULL);
  12233.       }
  12234.     else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
  12235.       {
  12236.         if (TREE_PUBLIC (x))
  12237.           {
  12238.         assert ("address of global register var requested" == NULL);
  12239.         return 0;
  12240.           }
  12241.         assert ("address of register var requested" == NULL);
  12242.       }
  12243.     put_var_into_stack (x);
  12244.  
  12245.     /* drops in */
  12246.       case FUNCTION_DECL:
  12247.     TREE_ADDRESSABLE (x) = 1;
  12248. #if 0                /* poplevel deals with this now.  */
  12249.     if (DECL_CONTEXT (x) == 0)
  12250.       TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
  12251. #endif
  12252.  
  12253.       default:
  12254.     return 1;
  12255.       }
  12256. }
  12257.  
  12258. /* If DECL has a cleanup, build and return that cleanup here.
  12259.    This is a callback called by expand_expr.  */
  12260.  
  12261. tree
  12262. maybe_build_cleanup (decl)
  12263.      tree decl;
  12264. {
  12265.   /* There are no cleanups in Fortran.  */
  12266.   return NULL_TREE;
  12267. }
  12268.  
  12269. /* Exit a binding level.
  12270.    Pop the level off, and restore the state of the identifier-decl mappings
  12271.    that were in effect when this level was entered.
  12272.  
  12273.    If KEEP is nonzero, this level had explicit declarations, so
  12274.    and create a "block" (a BLOCK node) for the level
  12275.    to record its declarations and subblocks for symbol table output.
  12276.  
  12277.    If FUNCTIONBODY is nonzero, this level is the body of a function,
  12278.    so create a block as if KEEP were set and also clear out all
  12279.    label names.
  12280.  
  12281.    If REVERSE is nonzero, reverse the order of decls before putting
  12282.    them into the BLOCK.  */
  12283.  
  12284. tree
  12285. poplevel (keep, reverse, functionbody)
  12286.      int keep;
  12287.      int reverse;
  12288.      int functionbody;
  12289. {
  12290.   register tree link;
  12291.   /* The chain of decls was accumulated in reverse order. Put it into forward
  12292.      order, just for cleanliness.  */
  12293.   tree decls;
  12294.   tree subblocks = current_binding_level->blocks;
  12295.   tree block = 0;
  12296.   tree decl;
  12297.   int block_previously_created;
  12298.  
  12299.   /* Get the decls in the order they were written. Usually
  12300.      current_binding_level->names is in reverse order. But parameter decls
  12301.      were previously put in forward order.  */
  12302.  
  12303.   if (reverse)
  12304.     current_binding_level->names
  12305.       = decls = nreverse (current_binding_level->names);
  12306.   else
  12307.     decls = current_binding_level->names;
  12308.  
  12309.   /* Output any nested inline functions within this block if they weren't
  12310.      already output.  */
  12311.  
  12312.   for (decl = decls; decl; decl = TREE_CHAIN (decl))
  12313.     if (TREE_CODE (decl) == FUNCTION_DECL
  12314.     && !TREE_ASM_WRITTEN (decl)
  12315.     && DECL_INITIAL (decl) != 0
  12316.     && TREE_ADDRESSABLE (decl))
  12317.       {
  12318.     /* If this decl was copied from a file-scope decl on account of a
  12319.        block-scope extern decl, propagate TREE_ADDRESSABLE to the
  12320.        file-scope decl.  */
  12321.     if (DECL_ABSTRACT_ORIGIN (decl) != 0)
  12322.       TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
  12323.     else
  12324.       {
  12325.         push_function_context ();
  12326.         output_inline_function (decl);
  12327.         pop_function_context ();
  12328.       }
  12329.       }
  12330.  
  12331.   /* If there were any declarations or structure tags in that level, or if
  12332.      this level is a function body, create a BLOCK to record them for the
  12333.      life of this function.  */
  12334.  
  12335.   block = 0;
  12336.   block_previously_created = (current_binding_level->this_block != 0);
  12337.   if (block_previously_created)
  12338.     block = current_binding_level->this_block;
  12339.   else if (keep || functionbody)
  12340.     block = make_node (BLOCK);
  12341.   if (block != 0)
  12342.     {
  12343.       BLOCK_VARS (block) = decls;
  12344.       BLOCK_SUBBLOCKS (block) = subblocks;
  12345.       remember_end_note (block);
  12346.     }
  12347.  
  12348.   /* In each subblock, record that this is its superior.  */
  12349.  
  12350.   for (link = subblocks; link; link = TREE_CHAIN (link))
  12351.     BLOCK_SUPERCONTEXT (link) = block;
  12352.  
  12353.   /* Clear out the meanings of the local variables of this level.  */
  12354.  
  12355.   for (link = decls; link; link = TREE_CHAIN (link))
  12356.     {
  12357.       if (DECL_NAME (link) != 0)
  12358.     {
  12359.       /* If the ident. was used or addressed via a local extern decl,
  12360.          don't forget that fact.  */
  12361.       if (DECL_EXTERNAL (link))
  12362.         {
  12363.           if (TREE_USED (link))
  12364.         TREE_USED (DECL_NAME (link)) = 1;
  12365.           if (TREE_ADDRESSABLE (link))
  12366.         TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
  12367.         }
  12368.       IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
  12369.     }
  12370.     }
  12371.  
  12372.   /* If the level being exited is the top level of a function, check over all
  12373.      the labels, and clear out the current (function local) meanings of their
  12374.      names.  */
  12375.  
  12376.   if (functionbody)
  12377.     {
  12378.       /* If this is the top level block of a function, the vars are the
  12379.          function's parameters. Don't leave them in the BLOCK because they
  12380.          are found in the FUNCTION_DECL instead.  */
  12381.  
  12382.       BLOCK_VARS (block) = 0;
  12383.     }
  12384.  
  12385.   /* Pop the current level, and free the structure for reuse.  */
  12386.  
  12387.   {
  12388.     register struct binding_level *level = current_binding_level;
  12389.     current_binding_level = current_binding_level->level_chain;
  12390.  
  12391.     level->level_chain = free_binding_level;
  12392.     free_binding_level = level;
  12393.   }
  12394.  
  12395.   /* Dispose of the block that we just made inside some higher level.  */
  12396.   if (functionbody)
  12397.     DECL_INITIAL (current_function_decl) = block;
  12398.   else if (block)
  12399.     {
  12400.       if (!block_previously_created)
  12401.     current_binding_level->blocks
  12402.       = chainon (current_binding_level->blocks, block);
  12403.     }
  12404.   /* If we did not make a block for the level just exited, any blocks made
  12405.      for inner levels (since they cannot be recorded as subblocks in that
  12406.      level) must be carried forward so they will later become subblocks of
  12407.      something else.  */
  12408.   else if (subblocks)
  12409.     current_binding_level->blocks
  12410.       = chainon (current_binding_level->blocks, subblocks);
  12411.  
  12412.   /* Set the TYPE_CONTEXTs for all of the tagged types belonging to this
  12413.      binding contour so that they point to the appropriate construct, i.e.
  12414.      either to the current FUNCTION_DECL node, or else to the BLOCK node we
  12415.      just constructed.
  12416.  
  12417.      Note that for tagged types whose scope is just the formal parameter list
  12418.      for some function type specification, we can't properly set their
  12419.      TYPE_CONTEXTs here, because we don't have a pointer to the appropriate
  12420.      FUNCTION_TYPE node readily available to us.  For those cases, the
  12421.      TYPE_CONTEXTs of the relevant tagged type nodes get set in
  12422.      `grokdeclarator' as soon as we have created the FUNCTION_TYPE node which
  12423.      will represent the "scope" for these "parameter list local" tagged
  12424.      types. */
  12425.  
  12426.   if (block)
  12427.     TREE_USED (block) = 1;
  12428.   return block;
  12429. }
  12430.  
  12431. void
  12432. print_lang_decl (file, node, indent)
  12433.      FILE *file;
  12434.      tree node;
  12435.      int indent;
  12436. {
  12437. }
  12438.  
  12439. void
  12440. print_lang_identifier (file, node, indent)
  12441.      FILE *file;
  12442.      tree node;
  12443.      int indent;
  12444. {
  12445.   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
  12446.   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
  12447. }
  12448.  
  12449. void
  12450. print_lang_statistics ()
  12451. {
  12452. }
  12453.  
  12454. void
  12455. print_lang_type (file, node, indent)
  12456.      FILE *file;
  12457.      tree node;
  12458.      int indent;
  12459. {
  12460. }
  12461.  
  12462. /* Record a decl-node X as belonging to the current lexical scope.
  12463.    Check for errors (such as an incompatible declaration for the same
  12464.    name already seen in the same scope).
  12465.  
  12466.    Returns either X or an old decl for the same name.
  12467.    If an old decl is returned, it may have been smashed
  12468.    to agree with what X says.  */
  12469.  
  12470. tree
  12471. pushdecl (x)
  12472.      tree x;
  12473. {
  12474.   register tree t;
  12475.   register tree name = DECL_NAME (x);
  12476.   register struct binding_level *b = current_binding_level;
  12477.  
  12478.   if ((TREE_CODE (x) == FUNCTION_DECL)
  12479.       && (DECL_INITIAL (x) == 0)
  12480.       && DECL_EXTERNAL (x))
  12481.     DECL_CONTEXT (x) = NULL_TREE;
  12482.   else
  12483.     DECL_CONTEXT (x) = current_function_decl;
  12484.  
  12485.   if (name)
  12486.     {
  12487.       t = lookup_name_current_level (name);
  12488.  
  12489.       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
  12490.  
  12491.       if ((t != NULL_TREE) && duplicate_decls (x, t))
  12492.     return t;
  12493.  
  12494.       /* If we are processing a typedef statement, generate a whole new
  12495.          ..._TYPE node (which will be just an variant of the existing
  12496.          ..._TYPE node with identical properties) and then install the
  12497.          TYPE_DECL node generated to represent the typedef name as the
  12498.          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
  12499.  
  12500.      The whole point here is to end up with a situation where each and every
  12501.          ..._TYPE node the compiler creates will be uniquely associated with
  12502.          AT MOST one node representing a typedef name. This way, even though
  12503.          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
  12504.          (i.e. "typedef name") nodes very early on, later parts of the
  12505.          compiler can always do the reverse translation and get back the
  12506.          corresponding typedef name.  For example, given:
  12507.  
  12508.      typedef struct S MY_TYPE; MY_TYPE object;
  12509.  
  12510.      Later parts of the compiler might only know that `object' was of type
  12511.          `struct S' if if were not for code just below.  With this code
  12512.          however, later parts of the compiler see something like:
  12513.  
  12514.      struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
  12515.  
  12516.      And they can then deduce (from the node for type struct S') that the
  12517.          original object declaration was:
  12518.  
  12519.      MY_TYPE object;
  12520.  
  12521.      Being able to do this is important for proper support of protoize, and
  12522.          also for generating precise symbolic debugging information which
  12523.          takes full account of the programmer's (typedef) vocabulary.
  12524.  
  12525.      Obviously, we don't want to generate a duplicate ..._TYPE node if the
  12526.          TYPE_DECL node that we are now processing really represents a
  12527.          standard built-in type.
  12528.  
  12529.      Since all standard types are effectively declared at line zero in the
  12530.          source file, we can easily check to see if we are working on a
  12531.          standard type by checking the current value of lineno.  */
  12532.  
  12533.       if (TREE_CODE (x) == TYPE_DECL)
  12534.     {
  12535.       if (DECL_SOURCE_LINE (x) == 0)
  12536.         {
  12537.           if (TYPE_NAME (TREE_TYPE (x)) == 0)
  12538.         TYPE_NAME (TREE_TYPE (x)) = x;
  12539.         }
  12540.       else if (TREE_TYPE (x) != error_mark_node)
  12541.         {
  12542.           tree tt = TREE_TYPE (x);
  12543.  
  12544.           tt = build_type_copy (tt);
  12545.           TYPE_NAME (tt) = x;
  12546.           TREE_TYPE (x) = tt;
  12547.         }
  12548.     }
  12549.  
  12550.       /* This name is new in its binding level. Install the new declaration
  12551.          and return it.  */
  12552.       if (b == global_binding_level)
  12553.     IDENTIFIER_GLOBAL_VALUE (name) = x;
  12554.       else
  12555.     IDENTIFIER_LOCAL_VALUE (name) = x;
  12556.     }
  12557.  
  12558.   /* Put decls on list in reverse order. We will reverse them later if
  12559.      necessary.  */
  12560.   TREE_CHAIN (x) = b->names;
  12561.   b->names = x;
  12562.  
  12563.   return x;
  12564. }
  12565.  
  12566. /* Enter a new binding level.
  12567.    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
  12568.    not for that of tags.  */
  12569.  
  12570. void
  12571. pushlevel (tag_transparent)
  12572.      int tag_transparent;
  12573. {
  12574.   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
  12575.  
  12576.   assert (!tag_transparent);
  12577.  
  12578.   /* Reuse or create a struct for this binding level.  */
  12579.  
  12580.   if (free_binding_level)
  12581.     {
  12582.       newlevel = free_binding_level;
  12583.       free_binding_level = free_binding_level->level_chain;
  12584.     }
  12585.   else
  12586.     {
  12587.       newlevel = make_binding_level ();
  12588.     }
  12589.  
  12590.   /* Add this level to the front of the chain (stack) of levels that are
  12591.      active.  */
  12592.  
  12593.   *newlevel = clear_binding_level;
  12594.   newlevel->level_chain = current_binding_level;
  12595.   current_binding_level = newlevel;
  12596. }
  12597.  
  12598. /* Set the BLOCK node for the innermost scope
  12599.    (the one we are currently in).  */
  12600.  
  12601. void
  12602. set_block (block)
  12603.      register tree block;
  12604. {
  12605.   current_binding_level->this_block = block;
  12606. }
  12607.  
  12608. /* ~~tree.h SHOULD declare this, because toplev.c references it.  */
  12609.  
  12610. /* Can't 'yydebug' a front end not generated by yacc/bison!  */
  12611.  
  12612. void
  12613. set_yydebug (value)
  12614.      int value;
  12615. {
  12616.   if (value)
  12617.     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
  12618. }
  12619.  
  12620. tree
  12621. signed_or_unsigned_type (unsignedp, type)
  12622.      int unsignedp;
  12623.      tree type;
  12624. {
  12625.   tree type2;
  12626.  
  12627.   if (! INTEGRAL_TYPE_P (type))
  12628.     return type;
  12629.   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
  12630.     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
  12631.   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
  12632.     return unsignedp ? unsigned_type_node : integer_type_node;
  12633.   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
  12634.     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
  12635.   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
  12636.     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
  12637.   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
  12638.     return (unsignedp ? long_long_unsigned_type_node
  12639.         : long_long_integer_type_node);
  12640.  
  12641.   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
  12642.   if (type2 == NULL_TREE)
  12643.     return type;
  12644.  
  12645.   return type2;
  12646. }
  12647.  
  12648. tree
  12649. signed_type (type)
  12650.      tree type;
  12651. {
  12652.   tree type1 = TYPE_MAIN_VARIANT (type);
  12653.   ffeinfoKindtype kt;
  12654.   tree type2;
  12655.  
  12656.   if (type1 == unsigned_char_type_node || type1 == char_type_node)
  12657.     return signed_char_type_node;
  12658.   if (type1 == unsigned_type_node)
  12659.     return integer_type_node;
  12660.   if (type1 == short_unsigned_type_node)
  12661.     return short_integer_type_node;
  12662.   if (type1 == long_unsigned_type_node)
  12663.     return long_integer_type_node;
  12664.   if (type1 == long_long_unsigned_type_node)
  12665.     return long_long_integer_type_node;
  12666.  
  12667.   type2 = type_for_size (TYPE_PRECISION (type1), 0);
  12668.   if (type2 != NULL_TREE)
  12669.     return type2;
  12670.  
  12671.   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
  12672.     {
  12673.       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
  12674.  
  12675.       if (type1 == type2)
  12676.     return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
  12677.     }
  12678.  
  12679.   return type;
  12680. }
  12681.  
  12682. /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
  12683.    or validate its data type for an `if' or `while' statement or ?..: exp.
  12684.  
  12685.    This preparation consists of taking the ordinary
  12686.    representation of an expression expr and producing a valid tree
  12687.    boolean expression describing whether expr is nonzero.  We could
  12688.    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
  12689.    but we optimize comparisons, &&, ||, and !.
  12690.  
  12691.    The resulting type should always be `integer_type_node'.  */
  12692.  
  12693. tree
  12694. truthvalue_conversion (expr)
  12695.      tree expr;
  12696. {
  12697.   if (TREE_CODE (expr) == ERROR_MARK)
  12698.     return expr;
  12699.  
  12700. #if 0 /* This appears to be wrong for C++.  */
  12701.   /* These really should return error_mark_node after 2.4 is stable.
  12702.      But not all callers handle ERROR_MARK properly.  */
  12703.   switch (TREE_CODE (TREE_TYPE (expr)))
  12704.     {
  12705.     case RECORD_TYPE:
  12706.       error ("struct type value used where scalar is required");
  12707.       return integer_zero_node;
  12708.  
  12709.     case UNION_TYPE:
  12710.       error ("union type value used where scalar is required");
  12711.       return integer_zero_node;
  12712.  
  12713.     case ARRAY_TYPE:
  12714.       error ("array type value used where scalar is required");
  12715.       return integer_zero_node;
  12716.  
  12717.     default:
  12718.       break;
  12719.     }
  12720. #endif /* 0 */
  12721.  
  12722.   switch (TREE_CODE (expr))
  12723.     {
  12724.       /* It is simpler and generates better code to have only TRUTH_*_EXPR
  12725.      or comparison expressions as truth values at this level.  */
  12726. #if 0
  12727.     case COMPONENT_REF:
  12728.       /* A one-bit unsigned bit-field is already acceptable.  */
  12729.       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
  12730.       && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
  12731.     return expr;
  12732.       break;
  12733. #endif
  12734.  
  12735.     case EQ_EXPR:
  12736.       /* It is simpler and generates better code to have only TRUTH_*_EXPR
  12737.      or comparison expressions as truth values at this level.  */
  12738. #if 0
  12739.       if (integer_zerop (TREE_OPERAND (expr, 1)))
  12740.     return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
  12741. #endif
  12742.     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
  12743.     case TRUTH_ANDIF_EXPR:
  12744.     case TRUTH_ORIF_EXPR:
  12745.     case TRUTH_AND_EXPR:
  12746.     case TRUTH_OR_EXPR:
  12747.     case TRUTH_XOR_EXPR:
  12748.       return convert (integer_type_node, expr);
  12749.  
  12750.     case ERROR_MARK:
  12751.       return expr;
  12752.  
  12753.     case INTEGER_CST:
  12754.       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
  12755.  
  12756.     case REAL_CST:
  12757.       return real_zerop (expr) ? integer_zero_node : integer_one_node;
  12758.  
  12759.     case ADDR_EXPR:
  12760.       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
  12761.     return build (COMPOUND_EXPR, integer_type_node,
  12762.               TREE_OPERAND (expr, 0), integer_one_node);
  12763.       else
  12764.     return integer_one_node;
  12765.  
  12766.     case COMPLEX_EXPR:
  12767.       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
  12768.             ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
  12769.                integer_type_node,
  12770.                truthvalue_conversion (TREE_OPERAND (expr, 0)),
  12771.                truthvalue_conversion (TREE_OPERAND (expr, 1)));
  12772.  
  12773.     case NEGATE_EXPR:
  12774.     case ABS_EXPR:
  12775.     case FLOAT_EXPR:
  12776.     case FFS_EXPR:
  12777.       /* These don't change whether an object is non-zero or zero.  */
  12778.       return truthvalue_conversion (TREE_OPERAND (expr, 0));
  12779.  
  12780.     case LROTATE_EXPR:
  12781.     case RROTATE_EXPR:
  12782.       /* These don't change whether an object is zero or non-zero, but
  12783.      we can't ignore them if their second arg has side-effects.  */
  12784.       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
  12785.     return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
  12786.               truthvalue_conversion (TREE_OPERAND (expr, 0)));
  12787.       else
  12788.     return truthvalue_conversion (TREE_OPERAND (expr, 0));
  12789.       
  12790.     case COND_EXPR:
  12791.       /* Distribute the conversion into the arms of a COND_EXPR.  */
  12792.       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
  12793.               truthvalue_conversion (TREE_OPERAND (expr, 1)),
  12794.               truthvalue_conversion (TREE_OPERAND (expr, 2))));
  12795.  
  12796.     case CONVERT_EXPR:
  12797.       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
  12798.      since that affects how `default_conversion' will behave.  */
  12799.       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
  12800.       || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
  12801.     break;
  12802.       /* fall through... */
  12803.     case NOP_EXPR:
  12804.       /* If this is widening the argument, we can ignore it.  */
  12805.       if (TYPE_PRECISION (TREE_TYPE (expr))
  12806.       >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
  12807.     return truthvalue_conversion (TREE_OPERAND (expr, 0));
  12808.       break;
  12809.  
  12810.     case MINUS_EXPR:
  12811.       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
  12812.      this case.  */
  12813.       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
  12814.       && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
  12815.     break;
  12816.       /* fall through... */
  12817.     case BIT_XOR_EXPR:
  12818.       /* This and MINUS_EXPR can be changed into a comparison of the
  12819.      two objects.  */
  12820.       if (TREE_TYPE (TREE_OPERAND (expr, 0))
  12821.       == TREE_TYPE (TREE_OPERAND (expr, 1)))
  12822.     return ffecom_2 (NE_EXPR, integer_type_node,
  12823.              TREE_OPERAND (expr, 0),
  12824.              TREE_OPERAND (expr, 1));
  12825.       return ffecom_2 (NE_EXPR, integer_type_node,
  12826.                TREE_OPERAND (expr, 0),
  12827.                fold (build1 (NOP_EXPR,
  12828.                      TREE_TYPE (TREE_OPERAND (expr, 0)),
  12829.                      TREE_OPERAND (expr, 1))));
  12830.  
  12831.     case BIT_AND_EXPR:
  12832.       if (integer_onep (TREE_OPERAND (expr, 1)))
  12833.     return expr;
  12834.       break;
  12835.  
  12836.     case MODIFY_EXPR:
  12837. #if 0                /* No such thing in Fortran. */
  12838.       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
  12839.     warning ("suggest parentheses around assignment used as truth value");
  12840. #endif
  12841.       break;
  12842.  
  12843.     default:
  12844.       break;
  12845.     }
  12846.  
  12847.   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
  12848.     return (ffecom_2
  12849.         ((TREE_SIDE_EFFECTS (expr)
  12850.           ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
  12851.          integer_type_node,
  12852.          truthvalue_conversion (ffecom_1 (REALPART_EXPR,
  12853.                           TREE_TYPE (TREE_TYPE (expr)),
  12854.                           expr)),
  12855.          truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
  12856.                           TREE_TYPE (TREE_TYPE (expr)),
  12857.                           expr))));
  12858.  
  12859.   return ffecom_2 (NE_EXPR, integer_type_node,
  12860.            expr,
  12861.            convert (TREE_TYPE (expr), integer_zero_node));
  12862. }
  12863.  
  12864. tree
  12865. type_for_mode (mode, unsignedp)
  12866.      enum machine_mode mode;
  12867.      int unsignedp;
  12868. {
  12869.   int i;
  12870.   int j;
  12871.   tree t;
  12872.  
  12873.   if (mode == TYPE_MODE (signed_char_type_node))
  12874.     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
  12875.  
  12876.   if (mode == TYPE_MODE (short_integer_type_node))
  12877.     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
  12878.  
  12879.   if (mode == TYPE_MODE (integer_type_node))
  12880.     return unsignedp ? unsigned_type_node : integer_type_node;
  12881.  
  12882.   if (mode == TYPE_MODE (long_integer_type_node))
  12883.     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
  12884.  
  12885.   if (mode == TYPE_MODE (long_long_integer_type_node))
  12886.     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
  12887.  
  12888.   if (mode == TYPE_MODE (float_type_node))
  12889.     return float_type_node;
  12890.  
  12891.   if (mode == TYPE_MODE (double_type_node))
  12892.     return double_type_node;
  12893.  
  12894.   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
  12895.     return build_pointer_type (char_type_node);
  12896.  
  12897.   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
  12898.     return build_pointer_type (integer_type_node);
  12899.  
  12900.   for (i = 0; i < ARRAY_SIZE (ffecom_tree_type); ++i)
  12901.     for (j = 0; j < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
  12902.       {
  12903.     if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
  12904.         && (mode == TYPE_MODE (t)))
  12905.       if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
  12906.         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
  12907.       else
  12908.         return t;
  12909.       }
  12910.  
  12911.   return 0;
  12912. }
  12913.  
  12914. tree
  12915. type_for_size (bits, unsignedp)
  12916.      unsigned bits;
  12917.      int unsignedp;
  12918. {
  12919.   ffeinfoKindtype kt;
  12920.   tree type_node;
  12921.  
  12922.   if (bits == TYPE_PRECISION (signed_char_type_node))
  12923.     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
  12924.  
  12925.   if (bits == TYPE_PRECISION (short_integer_type_node))
  12926.     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
  12927.  
  12928.   if (bits == TYPE_PRECISION (integer_type_node))
  12929.     return unsignedp ? unsigned_type_node : integer_type_node;
  12930.  
  12931.   if (bits == TYPE_PRECISION (long_integer_type_node))
  12932.     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
  12933.  
  12934.   if (bits == TYPE_PRECISION (long_long_integer_type_node))
  12935.     return (unsignedp ? long_long_unsigned_type_node
  12936.         : long_long_integer_type_node);
  12937.  
  12938.   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
  12939.     {
  12940.       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
  12941.  
  12942.       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
  12943.     return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
  12944.       : type_node;
  12945.     }
  12946.  
  12947.   return 0;
  12948. }
  12949.  
  12950. tree
  12951. unsigned_type (type)
  12952.      tree type;
  12953. {
  12954.   tree type1 = TYPE_MAIN_VARIANT (type);
  12955.   ffeinfoKindtype kt;
  12956.   tree type2;
  12957.  
  12958.   if (type1 == signed_char_type_node || type1 == char_type_node)
  12959.     return unsigned_char_type_node;
  12960.   if (type1 == integer_type_node)
  12961.     return unsigned_type_node;
  12962.   if (type1 == short_integer_type_node)
  12963.     return short_unsigned_type_node;
  12964.   if (type1 == long_integer_type_node)
  12965.     return long_unsigned_type_node;
  12966.   if (type1 == long_long_integer_type_node)
  12967.     return long_long_unsigned_type_node;
  12968.  
  12969.   type2 = type_for_size (TYPE_PRECISION (type1), 1);
  12970.   if (type2 != NULL_TREE)
  12971.     return type2;
  12972.  
  12973.   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
  12974.     {
  12975.       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
  12976.  
  12977.       if (type1 == type2)
  12978.     return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
  12979.     }
  12980.  
  12981.   return type;
  12982. }
  12983.  
  12984. #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
  12985.  
  12986. #if FFECOM_GCC_INCLUDE
  12987.  
  12988. /* From gcc/cccp.c, the code to handle -I.  */
  12989.  
  12990. /* The file_name_map structure holds a mapping of file names for a
  12991.    particular directory.  This mapping is read from the file named
  12992.    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
  12993.    map filenames on a file system with severe filename restrictions,
  12994.    such as DOS.  The format of the file name map file is just a series
  12995.    of lines with two tokens on each line.  The first token is the name
  12996.    to map, and the second token is the actual name to use.  */
  12997.  
  12998. struct file_name_map
  12999. {
  13000.   struct file_name_map *map_next;
  13001.   char *map_from;
  13002.   char *map_to;
  13003. };
  13004.  
  13005. #define FILE_NAME_MAP_FILE "header.gcc"
  13006.  
  13007. /* Current maximum length of directory names in the search path
  13008.    for include files.  (Altered as we get more of them.)  */
  13009.  
  13010. static int max_include_len = 0;
  13011.  
  13012. struct file_name_list
  13013.   {
  13014.     struct file_name_list *next;
  13015.     char *fname;
  13016.     /* Mapping of file names for this directory.  */
  13017.     struct file_name_map *name_map;
  13018.     /* Non-zero if name_map is valid.  */
  13019.     int got_name_map;
  13020.   };
  13021.  
  13022. static struct file_name_list *include = NULL;    /* First dir to search */
  13023. static struct file_name_list *last_include = NULL;    /* Last in chain */
  13024.  
  13025. /* I/O buffer structure.
  13026.    The `fname' field is nonzero for source files and #include files
  13027.    and for the dummy text used for -D and -U.
  13028.    It is zero for rescanning results of macro expansion
  13029.    and for expanding macro arguments.  */
  13030. #define INPUT_STACK_MAX 400
  13031. static struct file_buf {
  13032.   char *fname;
  13033.   /* Filename specified with #line command.  */
  13034.   char *nominal_fname;
  13035.   /* Record where in the search path this file was found.
  13036.      For #include_next.  */
  13037.   struct file_name_list *dir;
  13038.   ffewhereLine line;
  13039.   ffewhereColumn column;
  13040. } instack[INPUT_STACK_MAX];
  13041.  
  13042. static int last_error_tick = 0;       /* Incremented each time we print it.  */
  13043. static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
  13044.  
  13045. /* Current nesting level of input sources.
  13046.    `instack[indepth]' is the level currently being read.  */
  13047. static int indepth = -1;
  13048.  
  13049. typedef struct file_buf FILE_BUF;
  13050.  
  13051. typedef unsigned char U_CHAR;
  13052.  
  13053. /* table to tell if char can be part of a C identifier. */
  13054. U_CHAR is_idchar[256];
  13055. /* table to tell if char can be first char of a c identifier. */
  13056. U_CHAR is_idstart[256];
  13057. /* table to tell if c is horizontal space.  */
  13058. U_CHAR is_hor_space[256];
  13059. /* table to tell if c is horizontal or vertical space.  */
  13060. static U_CHAR is_space[256];
  13061.  
  13062. #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
  13063. #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
  13064.  
  13065. /* Nonzero means -I- has been seen,
  13066.    so don't look for #include "foo" the source-file directory.  */
  13067. static int ignore_srcdir;
  13068.  
  13069. #ifndef INCLUDE_LEN_FUDGE
  13070. #define INCLUDE_LEN_FUDGE 0
  13071. #endif
  13072.  
  13073. static void append_include_chain (struct file_name_list *first,
  13074.                   struct file_name_list *last);
  13075. static FILE *open_include_file (char *filename,
  13076.                 struct file_name_list *searchptr);
  13077. static void print_containing_files (ffebadSeverity sev);
  13078. static char *read_filename_string (int ch, FILE *f);
  13079. static struct file_name_map *read_name_map (char *dirname);
  13080. static char *savestring (char *input);
  13081.  
  13082. /* Append a chain of `struct file_name_list's
  13083.    to the end of the main include chain.
  13084.    FIRST is the beginning of the chain to append, and LAST is the end.  */
  13085.  
  13086. static void
  13087. append_include_chain (first, last)
  13088.      struct file_name_list *first, *last;
  13089. {
  13090.   struct file_name_list *dir;
  13091.  
  13092.   if (!first || !last)
  13093.     return;
  13094.  
  13095.   if (include == 0)
  13096.     include = first;
  13097.   else
  13098.     last_include->next = first;
  13099.  
  13100.   for (dir = first; ; dir = dir->next) {
  13101.     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
  13102.     if (len > max_include_len)
  13103.       max_include_len = len;
  13104.     if (dir == last)
  13105.       break;
  13106.   }
  13107.  
  13108.   last->next = NULL;
  13109.   last_include = last;
  13110. }
  13111.  
  13112. /* Try to open include file FILENAME.  SEARCHPTR is the directory
  13113.    being tried from the include file search path.  This function maps
  13114.    filenames on file systems based on information read by
  13115.    read_name_map.  */
  13116.  
  13117. static FILE *
  13118. open_include_file (filename, searchptr)
  13119.      char *filename;
  13120.      struct file_name_list *searchptr;
  13121. {
  13122.   register struct file_name_map *map;
  13123.   register char *from;
  13124.   char *p, *dir;
  13125.  
  13126.   if (searchptr && ! searchptr->got_name_map)
  13127.     {
  13128.       searchptr->name_map = read_name_map (searchptr->fname
  13129.                        ? searchptr->fname : ".");
  13130.       searchptr->got_name_map = 1;
  13131.     }
  13132.  
  13133.   /* First check the mapping for the directory we are using.  */
  13134.   if (searchptr && searchptr->name_map)
  13135.     {
  13136.       from = filename;
  13137.       if (searchptr->fname)
  13138.     from += strlen (searchptr->fname) + 1;
  13139.       for (map = searchptr->name_map; map; map = map->map_next)
  13140.     {
  13141.       if (! strcmp (map->map_from, from))
  13142.         {
  13143.           /* Found a match.  */
  13144.           return fopen (map->map_to, "r");
  13145.         }
  13146.     }
  13147.     }
  13148.  
  13149.   /* Try to find a mapping file for the particular directory we are
  13150.      looking in.  Thus #include <sys/types.h> will look up sys/types.h
  13151.      in /usr/include/header.gcc and look up types.h in
  13152.      /usr/include/sys/header.gcc.  */
  13153.   p = rindex (filename, '/');
  13154.   if (! p)
  13155.     p = filename;
  13156.   if (searchptr
  13157.       && searchptr->fname
  13158.       && strlen (searchptr->fname) == p - filename
  13159.       && ! strncmp (searchptr->fname, filename, p - filename))
  13160.     {
  13161.       /* FILENAME is in SEARCHPTR, which we've already checked.  */
  13162.       return fopen (filename, "r");
  13163.     }
  13164.  
  13165.   if (p == filename)
  13166.     {
  13167.       from = filename;
  13168.       map = read_name_map (".");
  13169.     }
  13170.   else
  13171.     {
  13172.       dir = (char *) xmalloc (p - filename + 1);
  13173.       bcopy (filename, dir, p - filename);
  13174.       dir[p - filename] = '\0';
  13175.       from = p + 1;
  13176.       map = read_name_map (dir);
  13177.       free (dir);
  13178.     }
  13179.   for (; map; map = map->map_next)
  13180.     if (! strcmp (map->map_from, from))
  13181.       return fopen (map->map_to, "r");
  13182.  
  13183.   return fopen (filename, "r");
  13184. }
  13185.  
  13186. /* Print the file names and line numbers of the #include
  13187.    commands which led to the current file.  */
  13188.  
  13189. static void
  13190. print_containing_files (ffebadSeverity sev)
  13191. {
  13192.   FILE_BUF *ip = NULL;
  13193.   int i;
  13194.   int first = 1;
  13195.   char *str1;
  13196.   char *str2;
  13197.  
  13198.   /* If stack of files hasn't changed since we last printed
  13199.      this info, don't repeat it.  */
  13200.   if (last_error_tick == input_file_stack_tick)
  13201.     return;
  13202.  
  13203.   for (i = indepth; i >= 0; i--)
  13204.     if (instack[i].fname != NULL) {
  13205.       ip = &instack[i];
  13206.       break;
  13207.     }
  13208.  
  13209.   /* Give up if we don't find a source file.  */
  13210.   if (ip == NULL)
  13211.     return;
  13212.  
  13213.   /* Find the other, outer source files.  */
  13214.   for (i--; i >= 0; i--)
  13215.     if (instack[i].fname != NULL)
  13216.       {
  13217.     ip = &instack[i];
  13218.     if (first)
  13219.       {
  13220.         first = 0;
  13221.         str1 = "In file included";
  13222.       }
  13223.     else
  13224.       {
  13225.         str1 = "...          ...";
  13226.       }
  13227.  
  13228.     if (i == 1)
  13229.       str2 = ":";
  13230.     else
  13231.       str2 = "";
  13232.  
  13233.     ffebad_start_msg ("%A from %B at %0%C", sev);
  13234.     ffebad_here (0, ip->line, ip->column);
  13235.     ffebad_string (str1);
  13236.     ffebad_string (ip->nominal_fname);
  13237.     ffebad_string (str2);
  13238.     ffebad_finish ();
  13239.       }
  13240.  
  13241.   /* Record we have printed the status as of this time.  */
  13242.   last_error_tick = input_file_stack_tick;
  13243. }
  13244.  
  13245. /* Read a space delimited string of unlimited length from a stdio
  13246.    file.  */
  13247.  
  13248. static char *
  13249. read_filename_string (ch, f)
  13250.      int ch;
  13251.      FILE *f;
  13252. {
  13253.   char *alloc, *set;
  13254.   int len;
  13255.  
  13256.   len = 20;
  13257.   set = alloc = xmalloc (len + 1);
  13258.   if (! is_space[ch])
  13259.     {
  13260.       *set++ = ch;
  13261.       while ((ch = getc (f)) != EOF && ! is_space[ch])
  13262.     {
  13263.       if (set - alloc == len)
  13264.         {
  13265.           len *= 2;
  13266.           alloc = xrealloc (alloc, len + 1);
  13267.           set = alloc + len / 2;
  13268.         }
  13269.       *set++ = ch;
  13270.     }
  13271.     }
  13272.   *set = '\0';
  13273.   ungetc (ch, f);
  13274.   return alloc;
  13275. }
  13276.  
  13277. /* Read the file name map file for DIRNAME.  */
  13278.  
  13279. static struct file_name_map *
  13280. read_name_map (dirname)
  13281.      char *dirname;
  13282. {
  13283.   /* This structure holds a linked list of file name maps, one per
  13284.      directory.  */
  13285.   struct file_name_map_list
  13286.     {
  13287.       struct file_name_map_list *map_list_next;
  13288.       char *map_list_name;
  13289.       struct file_name_map *map_list_map;
  13290.     };
  13291.   static struct file_name_map_list *map_list;
  13292.   register struct file_name_map_list *map_list_ptr;
  13293.   char *name;
  13294.   FILE *f;
  13295.  
  13296.   for (map_list_ptr = map_list; map_list_ptr;
  13297.        map_list_ptr = map_list_ptr->map_list_next)
  13298.     if (! strcmp (map_list_ptr->map_list_name, dirname))
  13299.       return map_list_ptr->map_list_map;
  13300.  
  13301.   map_list_ptr = ((struct file_name_map_list *)
  13302.           xmalloc (sizeof (struct file_name_map_list)));
  13303.   map_list_ptr->map_list_name = savestring (dirname);
  13304.   map_list_ptr->map_list_map = NULL;
  13305.  
  13306.   name = (char *) xmalloc (strlen (dirname) + strlen (FILE_NAME_MAP_FILE) + 2);
  13307.   strcpy (name, dirname);
  13308.   if (*dirname)
  13309.     strcat (name, "/");
  13310.   strcat (name, FILE_NAME_MAP_FILE);
  13311.   f = fopen (name, "r");
  13312.   free (name);
  13313.   if (!f)
  13314.     map_list_ptr->map_list_map = NULL;
  13315.   else
  13316.     {
  13317.       int ch;
  13318.       int dirlen = strlen (dirname);
  13319.  
  13320.       while ((ch = getc (f)) != EOF)
  13321.     {
  13322.       char *from, *to;
  13323.       struct file_name_map *ptr;
  13324.  
  13325.       if (is_space[ch])
  13326.         continue;
  13327.       from = read_filename_string (ch, f);
  13328.       while ((ch = getc (f)) != EOF && is_hor_space[ch])
  13329.         ;
  13330.       to = read_filename_string (ch, f);
  13331.  
  13332.       ptr = ((struct file_name_map *)
  13333.          xmalloc (sizeof (struct file_name_map)));
  13334.       ptr->map_from = from;
  13335.  
  13336.       /* Make the real filename absolute.  */
  13337.       if (*to == '/')
  13338.         ptr->map_to = to;
  13339.       else
  13340.         {
  13341.           ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
  13342.           strcpy (ptr->map_to, dirname);
  13343.           ptr->map_to[dirlen] = '/';
  13344.           strcpy (ptr->map_to + dirlen + 1, to);
  13345.           free (to);
  13346.         }          
  13347.  
  13348.       ptr->map_next = map_list_ptr->map_list_map;
  13349.       map_list_ptr->map_list_map = ptr;
  13350.  
  13351.       while ((ch = getc (f)) != '\n')
  13352.         if (ch == EOF)
  13353.           break;
  13354.     }
  13355.       fclose (f);
  13356.     }
  13357.   
  13358.   map_list_ptr->map_list_next = map_list;
  13359.   map_list = map_list_ptr;
  13360.  
  13361.   return map_list_ptr->map_list_map;
  13362. }  
  13363.  
  13364. static char *
  13365. savestring (input)
  13366.      char *input;
  13367. {
  13368.   unsigned size = strlen (input);
  13369.   char *output = xmalloc (size + 1);
  13370.   strcpy (output, input);
  13371.   return output;
  13372. }
  13373.  
  13374. static void
  13375. ffecom_file_ (char *name)
  13376. {
  13377.   FILE_BUF *fp;
  13378.  
  13379.   /* Do partial setup of input buffer for the sake of generating
  13380.      early #line directives (when -g is in effect).  */
  13381.  
  13382.   fp = &instack[++indepth];
  13383.   bzero ((char *) fp, sizeof (FILE_BUF));
  13384.   if (name == NULL)
  13385.     name = "";
  13386.   fp->nominal_fname = fp->fname = name;
  13387. }
  13388.  
  13389. /* Initialize syntactic classifications of characters.  */
  13390.  
  13391. static void
  13392. ffecom_initialize_char_syntax_ ()
  13393. {
  13394.   register int i;
  13395.  
  13396.   /*
  13397.    * Set up is_idchar and is_idstart tables.  These should be
  13398.    * faster than saying (is_alpha (c) || c == '_'), etc.
  13399.    * Set up these things before calling any routines tthat
  13400.    * refer to them.
  13401.    */
  13402.   for (i = 'a'; i <= 'z'; i++) {
  13403.     is_idchar[i - 'a' + 'A'] = 1;
  13404.     is_idchar[i] = 1;
  13405.     is_idstart[i - 'a' + 'A'] = 1;
  13406.     is_idstart[i] = 1;
  13407.   }
  13408.   for (i = '0'; i <= '9'; i++)
  13409.     is_idchar[i] = 1;
  13410.   is_idchar['_'] = 1;
  13411.   is_idstart['_'] = 1;
  13412.  
  13413.   /* horizontal space table */
  13414.   is_hor_space[' '] = 1;
  13415.   is_hor_space['\t'] = 1;
  13416.   is_hor_space['\v'] = 1;
  13417.   is_hor_space['\f'] = 1;
  13418.   is_hor_space['\r'] = 1;
  13419.  
  13420.   is_space[' '] = 1;
  13421.   is_space['\t'] = 1;
  13422.   is_space['\v'] = 1;
  13423.   is_space['\f'] = 1;
  13424.   is_space['\n'] = 1;
  13425.   is_space['\r'] = 1;
  13426. }
  13427.  
  13428. static void
  13429. ffecom_close_include_ (FILE *f)
  13430. {
  13431.   indepth--;
  13432.   input_file_stack_tick++;
  13433.  
  13434.   ffewhere_line_kill (instack[indepth].line);
  13435.   ffewhere_column_kill (instack[indepth].column);
  13436. }
  13437.  
  13438. static int
  13439. ffecom_decode_include_option_ (char *spec)
  13440. {
  13441.   struct file_name_list *dirtmp;
  13442.   
  13443.   if (! ignore_srcdir && !strcmp (spec, "-"))
  13444.     ignore_srcdir = 1;
  13445.   else
  13446.     {
  13447.       dirtmp = (struct file_name_list *)
  13448.     xmalloc (sizeof (struct file_name_list));
  13449.       dirtmp->next = 0;        /* New one goes on the end */
  13450.       if (spec[0] != 0)
  13451.     dirtmp->fname = spec;
  13452.       else
  13453.     fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
  13454.       dirtmp->got_name_map = 0;
  13455.       append_include_chain (dirtmp, dirtmp);
  13456.     }
  13457.   return 1;
  13458. }
  13459.  
  13460. /* Open INCLUDEd file.  */
  13461.  
  13462. static FILE *
  13463. ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
  13464. {
  13465.   char *fbeg = name;
  13466.   int flen = strlen (fbeg);
  13467.   struct file_name_list *search_start = include; /* Chain of dirs to search */
  13468.   struct file_name_list dsp[1];    /* First in chain, if #include "..." */
  13469.   struct file_name_list *searchptr = 0;
  13470.   char *fname;        /* Dynamically allocated fname buffer */
  13471.   FILE *f;
  13472.   FILE_BUF *fp;
  13473.  
  13474.   if (flen == 0)
  13475.     return NULL;
  13476.  
  13477.   dsp[0].fname = NULL;
  13478.  
  13479.   /* If -I- was specified, don't search current dir, only spec'd ones. */
  13480.   if (!ignore_srcdir)
  13481.     {
  13482.       for (fp = &instack[indepth]; fp >= instack; fp--)
  13483.     {
  13484.       int n;
  13485.       char *ep;
  13486.       char *nam;
  13487.  
  13488.       if ((nam = fp->nominal_fname) != NULL)
  13489.         {
  13490.           /* Found a named file.  Figure out dir of the file,
  13491.          and put it in front of the search list.  */
  13492.           dsp[0].next = search_start;
  13493.           search_start = dsp;
  13494. #ifndef VMS
  13495.           ep = rindex (nam, '/');
  13496. #else                /* VMS */
  13497.           ep = rindex (nam, ']');
  13498.           if (ep == NULL) ep = rindex (nam, '>');
  13499.           if (ep == NULL) ep = rindex (nam, ':');
  13500.           if (ep != NULL) ep++;
  13501. #endif                /* VMS */
  13502.           if (ep != NULL)
  13503.         {
  13504.           n = ep - nam;
  13505.           dsp[0].fname = (char *) xmalloc (n + 1);
  13506.           strncpy (dsp[0].fname, nam, n);
  13507.           dsp[0].fname[n] = '\0';
  13508.           if (n + INCLUDE_LEN_FUDGE > max_include_len)
  13509.             max_include_len = n + INCLUDE_LEN_FUDGE;
  13510.         }
  13511.           else
  13512.         dsp[0].fname = NULL; /* Current directory */
  13513.           dsp[0].got_name_map = 0;
  13514.           break;
  13515.         }
  13516.     }
  13517.     }
  13518.  
  13519.   /* Allocate this permanently, because it gets stored in the definitions
  13520.      of macros.  */
  13521.   fname = (char *) xmalloc (max_include_len + flen + 4);
  13522.   /* + 2 above for slash and terminating null.  */
  13523.   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
  13524.      for g77 yet).  */
  13525.  
  13526.   /* If specified file name is absolute, just open it.  */
  13527.  
  13528.   if (*fbeg == '/')
  13529.     {
  13530.       strncpy (fname, fbeg, flen);
  13531.       fname[flen] = 0;
  13532.       f = open_include_file (fname, NULL_PTR);
  13533.     }
  13534.   else
  13535.     {
  13536.       f = NULL;
  13537.  
  13538.       /* Search directory path, trying to open the file.
  13539.      Copy each filename tried into FNAME.  */
  13540.  
  13541.       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
  13542.     {
  13543.       if (searchptr->fname)
  13544.         {
  13545.           /* The empty string in a search path is ignored.
  13546.          This makes it possible to turn off entirely
  13547.          a standard piece of the list.  */
  13548.           if (searchptr->fname[0] == 0)
  13549.         continue;
  13550.           strcpy (fname, searchptr->fname);
  13551.           strcat (fname, "/");
  13552.           fname[strlen (fname) + flen] = 0;
  13553.         }
  13554.       else
  13555.         fname[0] = 0;
  13556.  
  13557.       strncat (fname, fbeg, flen);
  13558. #ifdef VMS
  13559.       /* Change this 1/2 Unix 1/2 VMS file specification into a
  13560.          full VMS file specification */
  13561.       if (searchptr->fname && (searchptr->fname[0] != 0))
  13562.         {
  13563.           /* Fix up the filename */
  13564.           hack_vms_include_specification (fname);
  13565.         }
  13566.       else
  13567.         {
  13568.           /* This is a normal VMS filespec, so use it unchanged.  */
  13569.           strncpy (fname, fbeg, flen);
  13570.           fname[flen] = 0;
  13571. #if 0    /* Not for g77.  */
  13572.           /* if it's '#include filename', add the missing .h */
  13573.           if (index (fname, '.') == NULL)
  13574.         strcat (fname, ".h");
  13575. #endif
  13576.         }
  13577. #endif /* VMS */
  13578.       f = open_include_file (fname, searchptr);
  13579. #ifdef EACCES
  13580.       if (f == NULL && errno == EACCES)
  13581.         {
  13582.           print_containing_files (FFEBAD_severityWARNING);
  13583.           ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
  13584.                 FFEBAD_severityWARNING);
  13585.           ffebad_string (fname);
  13586.           ffebad_here (0, l, c);
  13587.           ffebad_finish ();
  13588.         }
  13589. #endif
  13590.       if (f != NULL)
  13591.         break;
  13592.     }
  13593.     }
  13594.  
  13595.   if (f == NULL)
  13596.     {
  13597.       /* A file that was not found.  */
  13598.  
  13599.       strncpy (fname, fbeg, flen);
  13600.       fname[flen] = 0;
  13601.       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
  13602.       ffebad_start (FFEBAD_OPEN_INCLUDE);
  13603.       ffebad_here (0, l, c);
  13604.       ffebad_string (fname);
  13605.       ffebad_finish ();
  13606.     }
  13607.  
  13608.   if (dsp[0].fname != NULL)
  13609.     free (dsp[0].fname);
  13610.  
  13611.   if (f == NULL)
  13612.     return NULL;
  13613.  
  13614.   if (indepth >= (INPUT_STACK_MAX - 1))
  13615.     {
  13616.       print_containing_files (FFEBAD_severityFATAL);
  13617.       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
  13618.             FFEBAD_severityFATAL);
  13619.       ffebad_string (fname);
  13620.       ffebad_here (0, l, c);
  13621.       ffebad_finish ();
  13622.       return NULL;
  13623.     }
  13624.  
  13625.   instack[indepth].line = ffewhere_line_use (l);
  13626.   instack[indepth].column = ffewhere_column_use (c);
  13627.  
  13628.   fp = &instack[indepth + 1];
  13629.   bzero ((char *) fp, sizeof (FILE_BUF));
  13630.   fp->nominal_fname = fp->fname = fname;
  13631.   fp->dir = searchptr;
  13632.  
  13633.   indepth++;
  13634.   input_file_stack_tick++;
  13635.  
  13636.   return f;
  13637. }
  13638. #endif    /* FFECOM_GCC_INCLUDE */
  13639.