xref: /openbsd/gnu/usr.bin/gcc/gcc/f/com.c (revision 4e43c760) 
1 /* com.c -- Implementation File (module.c template V1.0)
2    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
3    Free Software Foundation, Inc.
4    Contributed by James Craig Burley.
5 
6 This file is part of GNU Fortran.
7 
8 GNU Fortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
11 any later version.
12 
13 GNU Fortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 GNU General Public License for more details.
17 
18 You should have received a copy of the GNU General Public License
19 along with GNU Fortran; see the file COPYING.  If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
21 02111-1307, USA.
22 
23    Related Modules:
24       None
25 
26    Description:
27       Contains compiler-specific functions.
28 
29    Modifications:
30 */
31 
32 /* Understanding this module means understanding the interface between
33    the g77 front end and the gcc back end (or, perhaps, some other
34    back end).  In here are the functions called by the front end proper
35    to notify whatever back end is in place about certain things, and
36    also the back-end-specific functions.  It's a bear to deal with, so
37    lately I've been trying to simplify things, especially with regard
38    to the gcc-back-end-specific stuff.
39 
40    Building expressions generally seems quite easy, but building decls
41    has been challenging and is undergoing revision.  gcc has several
42    kinds of decls:
43 
44    TYPE_DECL -- a type (int, float, struct, function, etc.)
45    CONST_DECL -- a constant of some type other than function
46    LABEL_DECL -- a variable or a constant?
47    PARM_DECL -- an argument to a function (a variable that is a dummy)
48    RESULT_DECL -- the return value of a function (a variable)
49    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
50    FUNCTION_DECL -- a function (either the actual function or an extern ref)
51    FIELD_DECL -- a field in a struct or union (goes into types)
52 
53    g77 has a set of functions that somewhat parallels the gcc front end
54    when it comes to building decls:
55 
56    Internal Function (one we define, not just declare as extern):
57    if (is_nested) push_f_function_context ();
58    start_function (get_identifier ("function_name"), function_type,
59 		   is_nested, is_public);
60    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
61    store_parm_decls (is_main_program);
62    ffecom_start_compstmt ();
63    // for stmts and decls inside function, do appropriate things;
64    ffecom_end_compstmt ();
65    finish_function (is_nested);
66    if (is_nested) pop_f_function_context ();
67 
68    Everything Else:
69    tree d;
70    tree init;
71    // fill in external, public, static, &c for decl, and
72    // set DECL_INITIAL to error_mark_node if going to initialize
73    // set is_top_level TRUE only if not at top level and decl
74    // must go in top level (i.e. not within current function decl context)
75    d = start_decl (decl, is_top_level);
76    init = ...;	// if have initializer
77    finish_decl (d, init, is_top_level);
78 
79 */
80 
81 /* Include files. */
82 
83 #include "proj.h"
84 #include "flags.h"
85 #include "real.h"
86 #include "rtl.h"
87 #include "toplev.h"
88 #include "tree.h"
89 #include "output.h"  /* Must follow tree.h so TREE_CODE is defined! */
90 #include "convert.h"
91 #include "ggc.h"
92 #include "diagnostic.h"
93 #include "intl.h"
94 #include "langhooks.h"
95 #include "langhooks-def.h"
96 #include "debug.h"
97 
98 /* VMS-specific definitions */
99 #ifdef VMS
100 #include <descrip.h>
101 #define O_RDONLY	0	/* Open arg for Read/Only  */
102 #define O_WRONLY	1	/* Open arg for Write/Only */
103 #define read(fd,buf,size)	VMS_read (fd,buf,size)
104 #define write(fd,buf,size)	VMS_write (fd,buf,size)
105 #define open(fname,mode,prot)	VMS_open (fname,mode,prot)
106 #define fopen(fname,mode)	VMS_fopen (fname,mode)
107 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
108 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
109 #define fstat(fd,stbuf)		VMS_fstat (fd,stbuf)
110 static int VMS_fstat (), VMS_stat ();
111 static char * VMS_strncat ();
112 static int VMS_read ();
113 static int VMS_write ();
114 static int VMS_open ();
115 static FILE * VMS_fopen ();
116 static FILE * VMS_freopen ();
117 static void hack_vms_include_specification ();
118 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
119 #define ino_t vms_ino_t
120 #define INCLUDE_LEN_FUDGE 10	/* leave room for VMS syntax conversion */
121 #endif /* VMS */
122 
123 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
124 #include "com.h"
125 #include "bad.h"
126 #include "bld.h"
127 #include "equiv.h"
128 #include "expr.h"
129 #include "implic.h"
130 #include "info.h"
131 #include "malloc.h"
132 #include "src.h"
133 #include "st.h"
134 #include "storag.h"
135 #include "symbol.h"
136 #include "target.h"
137 #include "top.h"
138 #include "type.h"
139 
140 /* Externals defined here.  */
141 
142 /* Stream for reading from the input file.  */
143 FILE *finput;
144 
145 /* These definitions parallel those in c-decl.c so that code from that
146    module can be used pretty much as is.  Much of these defs aren't
147    otherwise used, i.e. by g77 code per se, except some of them are used
148    to build some of them that are.  The ones that are global (i.e. not
149    "static") are those that ste.c and such might use (directly
150    or by using com macros that reference them in their definitions).  */
151 
152 tree string_type_node;
153 
154 /* The rest of these are inventions for g77, though there might be
155    similar things in the C front end.  As they are found, these
156    inventions should be renamed to be canonical.  Note that only
157    the ones currently required to be global are so.  */
158 
159 static GTY(()) tree ffecom_tree_fun_type_void;
160 
161 tree ffecom_integer_type_node;	/* Abbrev for _tree_type[blah][blah]. */
162 tree ffecom_integer_zero_node;	/* Like *_*_* with g77's integer type. */
163 tree ffecom_integer_one_node;	/* " */
164 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
165 
166 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
167    just use build_function_type and build_pointer_type on the
168    appropriate _tree_type array element.  */
169 
170 static GTY(()) tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
171 static GTY(()) tree
172   ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
173 static GTY(()) tree ffecom_tree_subr_type;
174 static GTY(()) tree ffecom_tree_ptr_to_subr_type;
175 static GTY(()) tree ffecom_tree_blockdata_type;
176 
177 static GTY(()) tree ffecom_tree_xargc_;
178 
179 ffecomSymbol ffecom_symbol_null_
180 =
181 {
182   NULL_TREE,
183   NULL_TREE,
184   NULL_TREE,
185   NULL_TREE,
186   false
187 };
188 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
189 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
190 
191 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
192 tree ffecom_f2c_integer_type_node;
193 static GTY(()) tree ffecom_f2c_ptr_to_integer_type_node;
194 tree ffecom_f2c_address_type_node;
195 tree ffecom_f2c_real_type_node;
196 static GTY(()) tree ffecom_f2c_ptr_to_real_type_node;
197 tree ffecom_f2c_doublereal_type_node;
198 tree ffecom_f2c_complex_type_node;
199 tree ffecom_f2c_doublecomplex_type_node;
200 tree ffecom_f2c_longint_type_node;
201 tree ffecom_f2c_logical_type_node;
202 tree ffecom_f2c_flag_type_node;
203 tree ffecom_f2c_ftnlen_type_node;
204 tree ffecom_f2c_ftnlen_zero_node;
205 tree ffecom_f2c_ftnlen_one_node;
206 tree ffecom_f2c_ftnlen_two_node;
207 tree ffecom_f2c_ptr_to_ftnlen_type_node;
208 tree ffecom_f2c_ftnint_type_node;
209 tree ffecom_f2c_ptr_to_ftnint_type_node;
210 
211 /* Simple definitions and enumerations. */
212 
213 #ifndef FFECOM_sizeMAXSTACKITEM
214 #define FFECOM_sizeMAXSTACKITEM 32*1024	/* Keep user-declared things
215 					   larger than this # bytes
216 					   off stack if possible. */
217 #endif
218 
219 /* For systems that have large enough stacks, they should define
220    this to 0, and here, for ease of use later on, we just undefine
221    it if it is 0.  */
222 
223 #if FFECOM_sizeMAXSTACKITEM == 0
224 #undef FFECOM_sizeMAXSTACKITEM
225 #endif
226 
227 typedef enum
228   {
229     FFECOM_rttypeVOID_,
230     FFECOM_rttypeVOIDSTAR_,	/* C's `void *' type. */
231     FFECOM_rttypeFTNINT_,	/* f2c's `ftnint' type. */
232     FFECOM_rttypeINTEGER_,	/* f2c's `integer' type. */
233     FFECOM_rttypeLONGINT_,	/* f2c's `longint' type. */
234     FFECOM_rttypeLOGICAL_,	/* f2c's `logical' type. */
235     FFECOM_rttypeREAL_F2C_,	/* f2c's `real' returned as `double'. */
236     FFECOM_rttypeREAL_GNU_,	/* `real' returned as such. */
237     FFECOM_rttypeCOMPLEX_F2C_,	/* f2c's `complex' returned via 1st arg. */
238     FFECOM_rttypeCOMPLEX_GNU_,	/* f2c's `complex' returned directly. */
239     FFECOM_rttypeDOUBLE_,	/* C's `double' type. */
240     FFECOM_rttypeDOUBLEREAL_,	/* f2c's `doublereal' type. */
241     FFECOM_rttypeDBLCMPLX_F2C_,	/* f2c's `doublecomplex' returned via 1st arg. */
242     FFECOM_rttypeDBLCMPLX_GNU_,	/* f2c's `doublecomplex' returned directly. */
243     FFECOM_rttypeCHARACTER_,	/* f2c `char *'/`ftnlen' pair. */
244     FFECOM_rttype_
245   } ffecomRttype_;
246 
247 /* Internal typedefs. */
248 
249 typedef struct _ffecom_concat_list_ ffecomConcatList_;
250 
251 /* Private include files. */
252 
253 
254 /* Internal structure definitions. */
255 
256 struct _ffecom_concat_list_
257   {
258     ffebld *exprs;
259     int count;
260     int max;
261     ffetargetCharacterSize minlen;
262     ffetargetCharacterSize maxlen;
263   };
264 
265 /* Static functions (internal). */
266 
267 static tree ffe_type_for_mode PARAMS ((enum machine_mode, int));
268 static tree ffe_type_for_size PARAMS ((unsigned int, int));
269 static tree ffe_unsigned_type PARAMS ((tree));
270 static tree ffe_signed_type PARAMS ((tree));
271 static tree ffe_signed_or_unsigned_type PARAMS ((int, tree));
272 static bool ffe_mark_addressable PARAMS ((tree));
273 static tree ffe_truthvalue_conversion PARAMS ((tree));
274 static void ffecom_init_decl_processing PARAMS ((void));
275 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
276 static tree ffecom_widest_expr_type_ (ffebld list);
277 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
278 			     tree dest_size, tree source_tree,
279 			     ffebld source, bool scalar_arg);
280 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
281 				      tree args, tree callee_commons,
282 				      bool scalar_args);
283 static tree ffecom_build_f2c_string_ (int i, const char *s);
284 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
285 			  bool is_f2c_complex, tree type,
286 			  tree args, tree dest_tree,
287 			  ffebld dest, bool *dest_used,
288 			  tree callee_commons, bool scalar_args, tree hook);
289 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
290 				bool is_f2c_complex, tree type,
291 				ffebld left, ffebld right,
292 				tree dest_tree, ffebld dest,
293 				bool *dest_used, tree callee_commons,
294 				bool scalar_args, bool ref, tree hook);
295 static void ffecom_char_args_x_ (tree *xitem, tree *length,
296 				 ffebld expr, bool with_null);
297 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
298 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
299 static ffecomConcatList_
300   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
301 			      ffebld expr,
302 			      ffetargetCharacterSize max);
303 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
304 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
305 						ffetargetCharacterSize max);
306 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
307 				  ffesymbol member, tree member_type,
308 				  ffetargetOffset offset);
309 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
310 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
311 			  bool *dest_used, bool assignp, bool widenp);
312 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
313 				    ffebld dest, bool *dest_used);
314 static tree ffecom_expr_power_integer_ (ffebld expr);
315 static void ffecom_expr_transform_ (ffebld expr);
316 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
317 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
318 				      int code);
319 static ffeglobal ffecom_finish_global_ (ffeglobal global);
320 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
321 static tree ffecom_get_appended_identifier_ (char us, const char *text);
322 static tree ffecom_get_external_identifier_ (ffesymbol s);
323 static tree ffecom_get_identifier_ (const char *text);
324 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
325 				  ffeinfoBasictype bt,
326 				  ffeinfoKindtype kt);
327 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
328 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
329 static tree ffecom_init_zero_ (tree decl);
330 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
331 				     tree *maybe_tree);
332 static tree ffecom_intrinsic_len_ (ffebld expr);
333 static void ffecom_let_char_ (tree dest_tree,
334 			      tree dest_length,
335 			      ffetargetCharacterSize dest_size,
336 			      ffebld source);
337 static void ffecom_make_gfrt_ (ffecomGfrt ix);
338 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
339 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
340 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
341 				      ffebld source);
342 static void ffecom_push_dummy_decls_ (ffebld dumlist,
343 				      bool stmtfunc);
344 static void ffecom_start_progunit_ (void);
345 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
346 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
347 static void ffecom_transform_common_ (ffesymbol s);
348 static void ffecom_transform_equiv_ (ffestorag st);
349 static tree ffecom_transform_namelist_ (ffesymbol s);
350 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
351 				       tree t);
352 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
353 				       tree *size, tree tree);
354 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
355 				 tree dest_tree, ffebld dest,
356 				 bool *dest_used, tree hook);
357 static tree ffecom_type_localvar_ (ffesymbol s,
358 				   ffeinfoBasictype bt,
359 				   ffeinfoKindtype kt);
360 static tree ffecom_type_namelist_ (void);
361 static tree ffecom_type_vardesc_ (void);
362 static tree ffecom_vardesc_ (ffebld expr);
363 static tree ffecom_vardesc_array_ (ffesymbol s);
364 static tree ffecom_vardesc_dims_ (ffesymbol s);
365 static tree ffecom_convert_narrow_ (tree type, tree expr);
366 static tree ffecom_convert_widen_ (tree type, tree expr);
367 
368 /* These are static functions that parallel those found in the C front
369    end and thus have the same names.  */
370 
371 static tree bison_rule_compstmt_ (void);
372 static void bison_rule_pushlevel_ (void);
373 static void delete_block (tree block);
374 static int duplicate_decls (tree newdecl, tree olddecl);
375 static void finish_decl (tree decl, tree init, bool is_top_level);
376 static void finish_function (int nested);
377 static const char *ffe_printable_name (tree decl, int v);
378 static void ffe_print_error_function (diagnostic_context *, const char *);
379 static tree lookup_name_current_level (tree name);
380 static struct f_binding_level *make_binding_level (void);
381 static void pop_f_function_context (void);
382 static void push_f_function_context (void);
383 static void push_parm_decl (tree parm);
384 static tree pushdecl_top_level (tree decl);
385 static int kept_level_p (void);
386 static tree storedecls (tree decls);
387 static void store_parm_decls (int is_main_program);
388 static tree start_decl (tree decl, bool is_top_level);
389 static void start_function (tree name, tree type, int nested, int public);
390 static void ffecom_file_ (const char *name);
391 static void ffecom_close_include_ (FILE *f);
392 static int ffecom_decode_include_option_ (char *spec);
393 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
394 				   ffewhereColumn c);
395 
396 /* Static objects accessed by functions in this module. */
397 
398 static ffesymbol ffecom_primary_entry_ = NULL;
399 static ffesymbol ffecom_nested_entry_ = NULL;
400 static ffeinfoKind ffecom_primary_entry_kind_;
401 static bool ffecom_primary_entry_is_proc_;
402 static GTY(()) tree ffecom_outer_function_decl_;
403 static GTY(()) tree ffecom_previous_function_decl_;
404 static GTY(()) tree ffecom_which_entrypoint_decl_;
405 static GTY(()) tree ffecom_float_zero_;
406 static GTY(()) tree ffecom_float_half_;
407 static GTY(()) tree ffecom_double_zero_;
408 static GTY(()) tree ffecom_double_half_;
409 static GTY(()) tree ffecom_func_result_;/* For functions. */
410 static GTY(()) tree ffecom_func_length_;/* For CHARACTER fns. */
411 static ffebld ffecom_list_blockdata_;
412 static ffebld ffecom_list_common_;
413 static ffebld ffecom_master_arglist_;
414 static ffeinfoBasictype ffecom_master_bt_;
415 static ffeinfoKindtype ffecom_master_kt_;
416 static ffetargetCharacterSize ffecom_master_size_;
417 static int ffecom_num_fns_ = 0;
418 static int ffecom_num_entrypoints_ = 0;
419 static bool ffecom_is_altreturning_ = FALSE;
420 static GTY(()) tree ffecom_multi_type_node_;
421 static GTY(()) tree ffecom_multi_retval_;
422 static GTY(()) tree
423   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
424 static bool ffecom_member_namelisted_;	/* _member_phase1_ namelisted? */
425 static bool ffecom_doing_entry_ = FALSE;
426 static bool ffecom_transform_only_dummies_ = FALSE;
427 static int ffecom_typesize_pointer_;
428 static int ffecom_typesize_integer1_;
429 
430 /* Holds pointer-to-function expressions.  */
431 
432 static GTY(()) tree ffecom_gfrt_[FFECOM_gfrt];
433 
434 /* Holds the external names of the functions.  */
435 
436 static const char *const ffecom_gfrt_name_[FFECOM_gfrt]
437 =
438 {
439 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
440 #include "com-rt.def"
441 #undef DEFGFRT
442 };
443 
444 /* Whether the function returns.  */
445 
446 static const bool ffecom_gfrt_volatile_[FFECOM_gfrt]
447 =
448 {
449 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
450 #include "com-rt.def"
451 #undef DEFGFRT
452 };
453 
454 /* Whether the function returns type complex.  */
455 
456 static const bool ffecom_gfrt_complex_[FFECOM_gfrt]
457 =
458 {
459 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
460 #include "com-rt.def"
461 #undef DEFGFRT
462 };
463 
464 /* Whether the function is const
465    (i.e., has no side effects and only depends on its arguments).  */
466 
467 static const bool ffecom_gfrt_const_[FFECOM_gfrt]
468 =
469 {
470 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
471 #include "com-rt.def"
472 #undef DEFGFRT
473 };
474 
475 /* Type code for the function return value.  */
476 
477 static const ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
478 =
479 {
480 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
481 #include "com-rt.def"
482 #undef DEFGFRT
483 };
484 
485 /* String of codes for the function's arguments.  */
486 
487 static const char *const ffecom_gfrt_argstring_[FFECOM_gfrt]
488 =
489 {
490 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
491 #include "com-rt.def"
492 #undef DEFGFRT
493 };
494 
495 /* Internal macros. */
496 
497 /* We let tm.h override the types used here, to handle trivial differences
498    such as the choice of unsigned int or long unsigned int for size_t.
499    When machines start needing nontrivial differences in the size type,
500    it would be best to do something here to figure out automatically
501    from other information what type to use.  */
502 
503 #ifndef SIZE_TYPE
504 #define SIZE_TYPE "long unsigned int"
505 #endif
506 
507 #define ffecom_concat_list_count_(catlist) ((catlist).count)
508 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
509 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
510 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
511 
512 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
513 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
514 
515 /* For each binding contour we allocate a binding_level structure
516  * which records the names defined in that contour.
517  * Contours include:
518  *  0) the global one
519  *  1) one for each function definition,
520  *     where internal declarations of the parameters appear.
521  *
522  * The current meaning of a name can be found by searching the levels from
523  * the current one out to the global one.
524  */
525 
526 /* Note that the information in the `names' component of the global contour
527    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
528 
529 struct f_binding_level GTY(())
530   {
531     /* A chain of _DECL nodes for all variables, constants, functions,
532        and typedef types.  These are in the reverse of the order supplied.
533      */
534     tree names;
535 
536     /* For each level (except not the global one),
537        a chain of BLOCK nodes for all the levels
538        that were entered and exited one level down.  */
539     tree blocks;
540 
541     /* The BLOCK node for this level, if one has been preallocated.
542        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
543     tree this_block;
544 
545     /* The binding level which this one is contained in (inherits from).  */
546     struct f_binding_level *level_chain;
547 
548     /* 0: no ffecom_prepare_* functions called at this level yet;
549        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
550        2: ffecom_prepare_end called.  */
551     int prep_state;
552   };
553 
554 #define NULL_BINDING_LEVEL (struct f_binding_level *) NULL
555 
556 /* The binding level currently in effect.  */
557 
558 static GTY(()) struct f_binding_level *current_binding_level;
559 
560 /* A chain of binding_level structures awaiting reuse.  */
561 
562 static GTY((deletable (""))) struct f_binding_level *free_binding_level;
563 
564 /* The outermost binding level, for names of file scope.
565    This is created when the compiler is started and exists
566    through the entire run.  */
567 
568 static struct f_binding_level *global_binding_level;
569 
570 /* Binding level structures are initialized by copying this one.  */
571 
572 static const struct f_binding_level clear_binding_level
573 =
574 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
575 
576 /* Language-dependent contents of an identifier.  */
577 
578 struct lang_identifier GTY(())
579 {
580   struct tree_identifier common;
581   tree global_value;
582   tree local_value;
583   tree label_value;
584   bool invented;
585 };
586 
587 /* Macros for access to language-specific slots in an identifier.  */
588 /* Each of these slots contains a DECL node or null.  */
589 
590 /* This represents the value which the identifier has in the
591    file-scope namespace.  */
592 #define IDENTIFIER_GLOBAL_VALUE(NODE)	\
593   (((struct lang_identifier *)(NODE))->global_value)
594 /* This represents the value which the identifier has in the current
595    scope.  */
596 #define IDENTIFIER_LOCAL_VALUE(NODE)	\
597   (((struct lang_identifier *)(NODE))->local_value)
598 /* This represents the value which the identifier has as a label in
599    the current label scope.  */
600 #define IDENTIFIER_LABEL_VALUE(NODE)	\
601   (((struct lang_identifier *)(NODE))->label_value)
602 /* This is nonzero if the identifier was "made up" by g77 code.  */
603 #define IDENTIFIER_INVENTED(NODE)	\
604   (((struct lang_identifier *)(NODE))->invented)
605 
606 /* The resulting tree type.  */
607 union lang_tree_node
608   GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
609        chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)")))
610 {
611   union tree_node GTY ((tag ("0"),
612 			desc ("tree_node_structure (&%h)")))
613     generic;
614   struct lang_identifier GTY ((tag ("1"))) identifier;
615 };
616 
617 /* Fortran doesn't use either of these.  */
618 struct lang_decl GTY(())
619 {
620 };
621 struct lang_type GTY(())
622 {
623 };
624 
625 /* In identifiers, C uses the following fields in a special way:
626    TREE_PUBLIC	      to record that there was a previous local extern decl.
627    TREE_USED	      to record that such a decl was used.
628    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
629 
630 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
631    that have names.  Here so we can clear out their names' definitions
632    at the end of the function.  */
633 
634 static GTY(()) tree named_labels;
635 
636 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
637 
638 static GTY(()) tree shadowed_labels;
639 
640 /* Return the subscript expression, modified to do range-checking.
641 
642    `array' is the array type to be checked against.
643    `element' is the subscript expression to check.
644    `dim' is the dimension number (starting at 0).
645    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
646    `item' is the array decl or NULL_TREE.
647 */
648 
649 static tree
ffecom_subscript_check_(tree array,tree element,int dim,int total_dims,const char * array_name,tree item)650 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
651 			 const char *array_name, tree item)
652 {
653   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
654   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
655   tree cond;
656   tree die;
657   tree args;
658 
659   if (element == error_mark_node)
660     return element;
661 
662   if (TREE_TYPE (low) != TREE_TYPE (element))
663     {
664       if (TYPE_PRECISION (TREE_TYPE (low))
665 	  > TYPE_PRECISION (TREE_TYPE (element)))
666 	element = convert (TREE_TYPE (low), element);
667       else
668 	{
669 	  low = convert (TREE_TYPE (element), low);
670 	  if (high)
671 	    high = convert (TREE_TYPE (element), high);
672 	}
673     }
674 
675   element = ffecom_save_tree (element);
676   if (total_dims == 0)
677     {
678       /* Special handling for substring range checks.  Fortran allows the
679          end subscript < begin subscript, which means that expressions like
680        string(1:0) are valid (and yield a null string).  In view of this,
681        enforce two simpler conditions:
682           1) element<=high for end-substring;
683           2) element>=low for start-substring.
684        Run-time character movement will enforce remaining conditions.
685 
686        More complicated checks would be better, but present structure only
687        provides one index element at a time, so it is not possible to
688        enforce a check of both i and j in string(i:j).  If it were, the
689        complete set of rules would read,
690          if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
691               ((low<=i<=high) && (low<=j<=high)) )
692            ok ;
693          else
694            range error ;
695       */
696       if (dim)
697         cond = ffecom_2 (LE_EXPR, integer_type_node, element, high);
698       else
699         cond = ffecom_2 (LE_EXPR, integer_type_node, low, element);
700     }
701   else
702     {
703       /* Array reference substring range checking.  */
704 
705       cond = ffecom_2 (LE_EXPR, integer_type_node,
706                      low,
707                      element);
708       if (high)
709         {
710           cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
711                          cond,
712                          ffecom_2 (LE_EXPR, integer_type_node,
713                                    element,
714                                    high));
715         }
716     }
717 
718   /* If the array index is safe at compile-time, return element.  */
719   if (integer_nonzerop (cond))
720     return element;
721 
722   {
723     int len;
724     char *proc;
725     char *var;
726     tree arg3;
727     tree arg2;
728     tree arg1;
729     tree arg4;
730 
731     switch (total_dims)
732       {
733       case 0:
734 	var = concat (array_name, "[", (dim ? "end" : "start"),
735 		      "-substring]", NULL);
736 	len = strlen (var) + 1;
737 	arg1 = build_string (len, var);
738 	free (var);
739 	break;
740 
741       case 1:
742 	len = strlen (array_name) + 1;
743 	arg1 = build_string (len, array_name);
744 	break;
745 
746       default:
747 	var = xmalloc (strlen (array_name) + 40);
748 	sprintf (var, "%s[subscript-%d-of-%d]",
749 		 array_name,
750 		 dim + 1, total_dims);
751 	len = strlen (var) + 1;
752 	arg1 = build_string (len, var);
753 	free (var);
754 	break;
755       }
756 
757     TREE_TYPE (arg1)
758       = build_type_variant (build_array_type (char_type_node,
759 					      build_range_type
760 					      (integer_type_node,
761 					       integer_one_node,
762 					       build_int_2 (len, 0))),
763 			    1, 0);
764     TREE_CONSTANT (arg1) = 1;
765     TREE_STATIC (arg1) = 1;
766     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
767 		     arg1);
768 
769     /* s_rnge adds one to the element to print it, so bias against
770        that -- want to print a faithful *subscript* value.  */
771     arg2 = convert (ffecom_f2c_ftnint_type_node,
772 		    ffecom_2 (MINUS_EXPR,
773 			      TREE_TYPE (element),
774 			      element,
775 			      convert (TREE_TYPE (element),
776 				       integer_one_node)));
777 
778     proc = concat (input_filename, "/",
779 		   IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
780 		   NULL);
781     len = strlen (proc) + 1;
782     arg3 = build_string (len, proc);
783 
784     free (proc);
785 
786     TREE_TYPE (arg3)
787       = build_type_variant (build_array_type (char_type_node,
788 					      build_range_type
789 					      (integer_type_node,
790 					       integer_one_node,
791 					       build_int_2 (len, 0))),
792 			    1, 0);
793     TREE_CONSTANT (arg3) = 1;
794     TREE_STATIC (arg3) = 1;
795     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
796 		     arg3);
797 
798     arg4 = convert (ffecom_f2c_ftnint_type_node,
799 		    build_int_2 (lineno, 0));
800 
801     arg1 = build_tree_list (NULL_TREE, arg1);
802     arg2 = build_tree_list (NULL_TREE, arg2);
803     arg3 = build_tree_list (NULL_TREE, arg3);
804     arg4 = build_tree_list (NULL_TREE, arg4);
805     TREE_CHAIN (arg3) = arg4;
806     TREE_CHAIN (arg2) = arg3;
807     TREE_CHAIN (arg1) = arg2;
808 
809     args = arg1;
810   }
811   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
812 			  args, NULL_TREE);
813   TREE_SIDE_EFFECTS (die) = 1;
814   die = convert (void_type_node, die);
815 
816   if (integer_zerop (cond) && item)
817     ffe_mark_addressable (item);
818 
819   return ffecom_3 (COND_EXPR, TREE_TYPE (element), cond, element, die);
820 }
821 
822 /* Return the computed element of an array reference.
823 
824    `item' is NULL_TREE, or the transformed pointer to the array.
825    `expr' is the original opARRAYREF expression, which is transformed
826      if `item' is NULL_TREE.
827    `want_ptr' is nonzero if a pointer to the element, instead of
828      the element itself, is to be returned.  */
829 
830 static tree
ffecom_arrayref_(tree item,ffebld expr,int want_ptr)831 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
832 {
833   ffebld dims[FFECOM_dimensionsMAX];
834   int i;
835   int total_dims;
836   int flatten = ffe_is_flatten_arrays ();
837   int need_ptr;
838   tree array;
839   tree element;
840   tree tree_type;
841   tree tree_type_x;
842   const char *array_name;
843   ffetype type;
844   ffebld list;
845 
846   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
847     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
848   else
849     array_name = "[expr?]";
850 
851   /* Build up ARRAY_REFs in reverse order (since we're column major
852      here in Fortran land). */
853 
854   for (i = 0, list = ffebld_right (expr);
855        list != NULL;
856        ++i, list = ffebld_trail (list))
857     {
858       dims[i] = ffebld_head (list);
859       type = ffeinfo_type (ffebld_basictype (dims[i]),
860 			   ffebld_kindtype (dims[i]));
861       if (! flatten
862 	  && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
863 	  && ffetype_size (type) > ffecom_typesize_integer1_)
864 	/* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
865 	   pointers and 32-bit integers.  Do the full 64-bit pointer
866 	   arithmetic, for codes using arrays for nonstandard heap-like
867 	   work.  */
868 	flatten = 1;
869     }
870 
871   total_dims = i;
872 
873   need_ptr = want_ptr || flatten;
874 
875   if (! item)
876     {
877       if (need_ptr)
878 	item = ffecom_ptr_to_expr (ffebld_left (expr));
879       else
880 	item = ffecom_expr (ffebld_left (expr));
881 
882       if (item == error_mark_node)
883 	return item;
884 
885       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
886 	  && ! ffe_mark_addressable (item))
887 	return error_mark_node;
888     }
889 
890   if (item == error_mark_node)
891     return item;
892 
893   if (need_ptr)
894     {
895       tree min;
896 
897       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
898 	   i >= 0;
899 	   --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
900 	{
901 	  min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
902 	  element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
903 	  if (flag_bounds_check)
904 	    element = ffecom_subscript_check_ (array, element, i, total_dims,
905 					       array_name, item);
906 	  if (element == error_mark_node)
907 	    return element;
908 
909 	  /* Widen integral arithmetic as desired while preserving
910 	     signedness.  */
911 	  tree_type = TREE_TYPE (element);
912 	  tree_type_x = tree_type;
913 	  if (tree_type
914 	      && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
915 	      && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
916 	    tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
917 
918 	  if (TREE_TYPE (min) != tree_type_x)
919 	    min = convert (tree_type_x, min);
920 	  if (TREE_TYPE (element) != tree_type_x)
921 	    element = convert (tree_type_x, element);
922 
923 	  item = ffecom_2 (PLUS_EXPR,
924 			   build_pointer_type (TREE_TYPE (array)),
925 			   item,
926 			   size_binop (MULT_EXPR,
927 				       size_in_bytes (TREE_TYPE (array)),
928 				       convert (sizetype,
929 						fold (build (MINUS_EXPR,
930 							     tree_type_x,
931 							     element, min)))));
932 	}
933       if (! want_ptr)
934 	{
935 	  item = ffecom_1 (INDIRECT_REF,
936 			   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
937 			   item);
938 	}
939     }
940   else
941     {
942       for (--i;
943 	   i >= 0;
944 	   --i)
945 	{
946 	  array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
947 
948 	  element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
949 	  if (flag_bounds_check)
950 	    element = ffecom_subscript_check_ (array, element, i, total_dims,
951 					       array_name, item);
952 	  if (element == error_mark_node)
953 	    return element;
954 
955 	  /* Widen integral arithmetic as desired while preserving
956 	     signedness.  */
957 	  tree_type = TREE_TYPE (element);
958 	  tree_type_x = tree_type;
959 	  if (tree_type
960 	      && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
961 	      && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
962 	    tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
963 
964 	  element = convert (tree_type_x, element);
965 
966 	  item = ffecom_2 (ARRAY_REF,
967 			   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
968 			   item,
969 			   element);
970 	}
971     }
972 
973   return item;
974 }
975 
976 /* This is like gcc's stabilize_reference -- in fact, most of the code
977    comes from that -- but it handles the situation where the reference
978    is going to have its subparts picked at, and it shouldn't change
979    (or trigger extra invocations of functions in the subtrees) due to
980    this.  save_expr is a bit overzealous, because we don't need the
981    entire thing calculated and saved like a temp.  So, for DECLs, no
982    change is needed, because these are stable aggregates, and ARRAY_REF
983    and such might well be stable too, but for things like calculations,
984    we do need to calculate a snapshot of a value before picking at it.  */
985 
986 static tree
ffecom_stabilize_aggregate_(tree ref)987 ffecom_stabilize_aggregate_ (tree ref)
988 {
989   tree result;
990   enum tree_code code = TREE_CODE (ref);
991 
992   switch (code)
993     {
994     case VAR_DECL:
995     case PARM_DECL:
996     case RESULT_DECL:
997       /* No action is needed in this case.  */
998       return ref;
999 
1000     case NOP_EXPR:
1001     case CONVERT_EXPR:
1002     case FLOAT_EXPR:
1003     case FIX_TRUNC_EXPR:
1004     case FIX_FLOOR_EXPR:
1005     case FIX_ROUND_EXPR:
1006     case FIX_CEIL_EXPR:
1007       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1008       break;
1009 
1010     case INDIRECT_REF:
1011       result = build_nt (INDIRECT_REF,
1012 			 stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1013       break;
1014 
1015     case COMPONENT_REF:
1016       result = build_nt (COMPONENT_REF,
1017 			 stabilize_reference (TREE_OPERAND (ref, 0)),
1018 			 TREE_OPERAND (ref, 1));
1019       break;
1020 
1021     case BIT_FIELD_REF:
1022       result = build_nt (BIT_FIELD_REF,
1023 			 stabilize_reference (TREE_OPERAND (ref, 0)),
1024 			 stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1025 			 stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1026       break;
1027 
1028     case ARRAY_REF:
1029       result = build_nt (ARRAY_REF,
1030 			 stabilize_reference (TREE_OPERAND (ref, 0)),
1031 			 stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1032       break;
1033 
1034     case COMPOUND_EXPR:
1035       result = build_nt (COMPOUND_EXPR,
1036 			 stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1037 			 stabilize_reference (TREE_OPERAND (ref, 1)));
1038       break;
1039 
1040     case RTL_EXPR:
1041       abort ();
1042 
1043 
1044     default:
1045       return save_expr (ref);
1046 
1047     case ERROR_MARK:
1048       return error_mark_node;
1049     }
1050 
1051   TREE_TYPE (result) = TREE_TYPE (ref);
1052   TREE_READONLY (result) = TREE_READONLY (ref);
1053   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1054   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1055 
1056   return result;
1057 }
1058 
1059 /* A rip-off of gcc's convert.c convert_to_complex function,
1060    reworked to handle complex implemented as C structures
1061    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1062 
1063 static tree
ffecom_convert_to_complex_(tree type,tree expr)1064 ffecom_convert_to_complex_ (tree type, tree expr)
1065 {
1066   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1067   tree subtype;
1068 
1069   assert (TREE_CODE (type) == RECORD_TYPE);
1070 
1071   subtype = TREE_TYPE (TYPE_FIELDS (type));
1072 
1073   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1074     {
1075       expr = convert (subtype, expr);
1076       return ffecom_2 (COMPLEX_EXPR, type, expr,
1077 		       convert (subtype, integer_zero_node));
1078     }
1079 
1080   if (form == RECORD_TYPE)
1081     {
1082       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1083       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1084 	return expr;
1085       else
1086 	{
1087 	  expr = save_expr (expr);
1088 	  return ffecom_2 (COMPLEX_EXPR,
1089 			   type,
1090 			   convert (subtype,
1091 				    ffecom_1 (REALPART_EXPR,
1092 					      TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1093 					      expr)),
1094 			   convert (subtype,
1095 				    ffecom_1 (IMAGPART_EXPR,
1096 					      TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1097 					      expr)));
1098 	}
1099     }
1100 
1101   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1102     error ("pointer value used where a complex was expected");
1103   else
1104     error ("aggregate value used where a complex was expected");
1105 
1106   return ffecom_2 (COMPLEX_EXPR, type,
1107 		   convert (subtype, integer_zero_node),
1108 		   convert (subtype, integer_zero_node));
1109 }
1110 
1111 /* Like gcc's convert(), but crashes if widening might happen.  */
1112 
1113 static tree
ffecom_convert_narrow_(type,expr)1114 ffecom_convert_narrow_ (type, expr)
1115      tree type, expr;
1116 {
1117   register tree e = expr;
1118   register enum tree_code code = TREE_CODE (type);
1119 
1120   if (type == TREE_TYPE (e)
1121       || TREE_CODE (e) == ERROR_MARK)
1122     return e;
1123   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1124     return fold (build1 (NOP_EXPR, type, e));
1125   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1126       || code == ERROR_MARK)
1127     return error_mark_node;
1128   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1129     {
1130       assert ("void value not ignored as it ought to be" == NULL);
1131       return error_mark_node;
1132     }
1133   assert (code != VOID_TYPE);
1134   if ((code != RECORD_TYPE)
1135       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1136     assert ("converting COMPLEX to REAL" == NULL);
1137   assert (code != ENUMERAL_TYPE);
1138   if (code == INTEGER_TYPE)
1139     {
1140       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1141 	       && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1142 	      || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1143 		  && (TYPE_PRECISION (type)
1144 		      == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1145       return fold (convert_to_integer (type, e));
1146     }
1147   if (code == POINTER_TYPE)
1148     {
1149       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1150       return fold (convert_to_pointer (type, e));
1151     }
1152   if (code == REAL_TYPE)
1153     {
1154       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1155       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1156       return fold (convert_to_real (type, e));
1157     }
1158   if (code == COMPLEX_TYPE)
1159     {
1160       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1161       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1162       return fold (convert_to_complex (type, e));
1163     }
1164   if (code == RECORD_TYPE)
1165     {
1166       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1167       /* Check that at least the first field name agrees.  */
1168       assert (DECL_NAME (TYPE_FIELDS (type))
1169 	      == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1170       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1171 	      <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1172       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1173 	  == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1174 	return e;
1175       return fold (ffecom_convert_to_complex_ (type, e));
1176     }
1177 
1178   assert ("conversion to non-scalar type requested" == NULL);
1179   return error_mark_node;
1180 }
1181 
1182 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1183 
1184 static tree
ffecom_convert_widen_(type,expr)1185 ffecom_convert_widen_ (type, expr)
1186      tree type, expr;
1187 {
1188   register tree e = expr;
1189   register enum tree_code code = TREE_CODE (type);
1190 
1191   if (type == TREE_TYPE (e)
1192       || TREE_CODE (e) == ERROR_MARK)
1193     return e;
1194   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1195     return fold (build1 (NOP_EXPR, type, e));
1196   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1197       || code == ERROR_MARK)
1198     return error_mark_node;
1199   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1200     {
1201       assert ("void value not ignored as it ought to be" == NULL);
1202       return error_mark_node;
1203     }
1204   assert (code != VOID_TYPE);
1205   if ((code != RECORD_TYPE)
1206       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1207     assert ("narrowing COMPLEX to REAL" == NULL);
1208   assert (code != ENUMERAL_TYPE);
1209   if (code == INTEGER_TYPE)
1210     {
1211       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1212 	       && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1213 	      || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1214 		  && (TYPE_PRECISION (type)
1215 		      == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1216       return fold (convert_to_integer (type, e));
1217     }
1218   if (code == POINTER_TYPE)
1219     {
1220       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1221       return fold (convert_to_pointer (type, e));
1222     }
1223   if (code == REAL_TYPE)
1224     {
1225       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1226       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1227       return fold (convert_to_real (type, e));
1228     }
1229   if (code == COMPLEX_TYPE)
1230     {
1231       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1232       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1233       return fold (convert_to_complex (type, e));
1234     }
1235   if (code == RECORD_TYPE)
1236     {
1237       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1238       /* Check that at least the first field name agrees.  */
1239       assert (DECL_NAME (TYPE_FIELDS (type))
1240 	      == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1241       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1242 	      >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1243       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1244 	  == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1245 	return e;
1246       return fold (ffecom_convert_to_complex_ (type, e));
1247     }
1248 
1249   assert ("conversion to non-scalar type requested" == NULL);
1250   return error_mark_node;
1251 }
1252 
1253 /* Handles making a COMPLEX type, either the standard
1254    (but buggy?) gbe way, or the safer (but less elegant?)
1255    f2c way.  */
1256 
1257 static tree
ffecom_make_complex_type_(tree subtype)1258 ffecom_make_complex_type_ (tree subtype)
1259 {
1260   tree type;
1261   tree realfield;
1262   tree imagfield;
1263 
1264   if (ffe_is_emulate_complex ())
1265     {
1266       type = make_node (RECORD_TYPE);
1267       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1268       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1269       TYPE_FIELDS (type) = realfield;
1270       layout_type (type);
1271     }
1272   else
1273     {
1274       type = make_node (COMPLEX_TYPE);
1275       TREE_TYPE (type) = subtype;
1276       layout_type (type);
1277     }
1278 
1279   return type;
1280 }
1281 
1282 /* Chooses either the gbe or the f2c way to build a
1283    complex constant.  */
1284 
1285 static tree
ffecom_build_complex_constant_(tree type,tree realpart,tree imagpart)1286 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1287 {
1288   tree bothparts;
1289 
1290   if (ffe_is_emulate_complex ())
1291     {
1292       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1293       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1294       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1295     }
1296   else
1297     {
1298       bothparts = build_complex (type, realpart, imagpart);
1299     }
1300 
1301   return bothparts;
1302 }
1303 
1304 static tree
ffecom_arglist_expr_(const char * c,ffebld expr)1305 ffecom_arglist_expr_ (const char *c, ffebld expr)
1306 {
1307   tree list;
1308   tree *plist = &list;
1309   tree trail = NULL_TREE;	/* Append char length args here. */
1310   tree *ptrail = &trail;
1311   tree length;
1312   ffebld exprh;
1313   tree item;
1314   bool ptr = FALSE;
1315   tree wanted = NULL_TREE;
1316   static const char zed[] = "0";
1317 
1318   if (c == NULL)
1319     c = &zed[0];
1320 
1321   while (expr != NULL)
1322     {
1323       if (*c != '\0')
1324 	{
1325 	  ptr = FALSE;
1326 	  if (*c == '&')
1327 	    {
1328 	      ptr = TRUE;
1329 	      ++c;
1330 	    }
1331 	  switch (*(c++))
1332 	    {
1333 	    case '\0':
1334 	      ptr = TRUE;
1335 	      wanted = NULL_TREE;
1336 	      break;
1337 
1338 	    case 'a':
1339 	      assert (ptr);
1340 	      wanted = NULL_TREE;
1341 	      break;
1342 
1343 	    case 'c':
1344 	      wanted = ffecom_f2c_complex_type_node;
1345 	      break;
1346 
1347 	    case 'd':
1348 	      wanted = ffecom_f2c_doublereal_type_node;
1349 	      break;
1350 
1351 	    case 'e':
1352 	      wanted = ffecom_f2c_doublecomplex_type_node;
1353 	      break;
1354 
1355 	    case 'f':
1356 	      wanted = ffecom_f2c_real_type_node;
1357 	      break;
1358 
1359 	    case 'i':
1360 	      wanted = ffecom_f2c_integer_type_node;
1361 	      break;
1362 
1363 	    case 'j':
1364 	      wanted = ffecom_f2c_longint_type_node;
1365 	      break;
1366 
1367 	    default:
1368 	      assert ("bad argstring code" == NULL);
1369 	      wanted = NULL_TREE;
1370 	      break;
1371 	    }
1372 	}
1373 
1374       exprh = ffebld_head (expr);
1375       if (exprh == NULL)
1376 	wanted = NULL_TREE;
1377 
1378       if ((wanted == NULL_TREE)
1379 	  || (ptr
1380 	      && (TYPE_MODE
1381 		  (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1382 		   [ffeinfo_kindtype (ffebld_info (exprh))])
1383 		   == TYPE_MODE (wanted))))
1384 	*plist
1385 	  = build_tree_list (NULL_TREE,
1386 			     ffecom_arg_ptr_to_expr (exprh,
1387 						     &length));
1388       else
1389 	{
1390 	  item = ffecom_arg_expr (exprh, &length);
1391 	  item = ffecom_convert_widen_ (wanted, item);
1392 	  if (ptr)
1393 	    {
1394 	      item = ffecom_1 (ADDR_EXPR,
1395 			       build_pointer_type (TREE_TYPE (item)),
1396 			       item);
1397 	    }
1398 	  *plist
1399 	    = build_tree_list (NULL_TREE,
1400 			       item);
1401 	}
1402 
1403       plist = &TREE_CHAIN (*plist);
1404       expr = ffebld_trail (expr);
1405       if (length != NULL_TREE)
1406 	{
1407 	  *ptrail = build_tree_list (NULL_TREE, length);
1408 	  ptrail = &TREE_CHAIN (*ptrail);
1409 	}
1410     }
1411 
1412   /* We've run out of args in the call; if the implementation expects
1413      more, supply null pointers for them, which the implementation can
1414      check to see if an arg was omitted. */
1415 
1416   while (*c != '\0' && *c != '0')
1417     {
1418       if (*c == '&')
1419 	++c;
1420       else
1421 	assert ("missing arg to run-time routine!" == NULL);
1422 
1423       switch (*(c++))
1424 	{
1425 	case '\0':
1426 	case 'a':
1427 	case 'c':
1428 	case 'd':
1429 	case 'e':
1430 	case 'f':
1431 	case 'i':
1432 	case 'j':
1433 	  break;
1434 
1435 	default:
1436 	  assert ("bad arg string code" == NULL);
1437 	  break;
1438 	}
1439       *plist
1440 	= build_tree_list (NULL_TREE,
1441 			   null_pointer_node);
1442       plist = &TREE_CHAIN (*plist);
1443     }
1444 
1445   *plist = trail;
1446 
1447   return list;
1448 }
1449 
1450 static tree
ffecom_widest_expr_type_(ffebld list)1451 ffecom_widest_expr_type_ (ffebld list)
1452 {
1453   ffebld item;
1454   ffebld widest = NULL;
1455   ffetype type;
1456   ffetype widest_type = NULL;
1457   tree t;
1458 
1459   for (; list != NULL; list = ffebld_trail (list))
1460     {
1461       item = ffebld_head (list);
1462       if (item == NULL)
1463 	continue;
1464       if ((widest != NULL)
1465 	  && (ffeinfo_basictype (ffebld_info (item))
1466 	      != ffeinfo_basictype (ffebld_info (widest))))
1467 	continue;
1468       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1469 			   ffeinfo_kindtype (ffebld_info (item)));
1470       if ((widest == FFEINFO_kindtypeNONE)
1471 	  || (ffetype_size (type)
1472 	      > ffetype_size (widest_type)))
1473 	{
1474 	  widest = item;
1475 	  widest_type = type;
1476 	}
1477     }
1478 
1479   assert (widest != NULL);
1480   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1481     [ffeinfo_kindtype (ffebld_info (widest))];
1482   assert (t != NULL_TREE);
1483   return t;
1484 }
1485 
1486 /* Check whether a partial overlap between two expressions is possible.
1487 
1488    Can *starting* to write a portion of expr1 change the value
1489    computed (perhaps already, *partially*) by expr2?
1490 
1491    Currently, this is a concern only for a COMPLEX expr1.  But if it
1492    isn't in COMMON or local EQUIVALENCE, since we don't support
1493    aliasing of arguments, it isn't a concern.  */
1494 
1495 static bool
ffecom_possible_partial_overlap_(ffebld expr1,ffebld expr2 ATTRIBUTE_UNUSED)1496 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1497 {
1498   ffesymbol sym;
1499   ffestorag st;
1500 
1501   switch (ffebld_op (expr1))
1502     {
1503     case FFEBLD_opSYMTER:
1504       sym = ffebld_symter (expr1);
1505       break;
1506 
1507     case FFEBLD_opARRAYREF:
1508       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1509 	return FALSE;
1510       sym = ffebld_symter (ffebld_left (expr1));
1511       break;
1512 
1513     default:
1514       return FALSE;
1515     }
1516 
1517   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1518       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1519 	  || ! (st = ffesymbol_storage (sym))
1520 	  || ! ffestorag_parent (st)))
1521     return FALSE;
1522 
1523   /* It's in COMMON or local EQUIVALENCE.  */
1524 
1525   return TRUE;
1526 }
1527 
1528 /* Check whether dest and source might overlap.  ffebld versions of these
1529    might or might not be passed, will be NULL if not.
1530 
1531    The test is really whether source_tree is modifiable and, if modified,
1532    might overlap destination such that the value(s) in the destination might
1533    change before it is finally modified.  dest_* are the canonized
1534    destination itself.  */
1535 
1536 static bool
ffecom_overlap_(tree dest_decl,tree dest_offset,tree dest_size,tree source_tree,ffebld source UNUSED,bool scalar_arg)1537 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1538 		 tree source_tree, ffebld source UNUSED,
1539 		 bool scalar_arg)
1540 {
1541   tree source_decl;
1542   tree source_offset;
1543   tree source_size;
1544   tree t;
1545 
1546   if (source_tree == NULL_TREE)
1547     return FALSE;
1548 
1549   switch (TREE_CODE (source_tree))
1550     {
1551     case ERROR_MARK:
1552     case IDENTIFIER_NODE:
1553     case INTEGER_CST:
1554     case REAL_CST:
1555     case COMPLEX_CST:
1556     case STRING_CST:
1557     case CONST_DECL:
1558     case VAR_DECL:
1559     case RESULT_DECL:
1560     case FIELD_DECL:
1561     case MINUS_EXPR:
1562     case MULT_EXPR:
1563     case TRUNC_DIV_EXPR:
1564     case CEIL_DIV_EXPR:
1565     case FLOOR_DIV_EXPR:
1566     case ROUND_DIV_EXPR:
1567     case TRUNC_MOD_EXPR:
1568     case CEIL_MOD_EXPR:
1569     case FLOOR_MOD_EXPR:
1570     case ROUND_MOD_EXPR:
1571     case RDIV_EXPR:
1572     case EXACT_DIV_EXPR:
1573     case FIX_TRUNC_EXPR:
1574     case FIX_CEIL_EXPR:
1575     case FIX_FLOOR_EXPR:
1576     case FIX_ROUND_EXPR:
1577     case FLOAT_EXPR:
1578     case NEGATE_EXPR:
1579     case MIN_EXPR:
1580     case MAX_EXPR:
1581     case ABS_EXPR:
1582     case FFS_EXPR:
1583     case LSHIFT_EXPR:
1584     case RSHIFT_EXPR:
1585     case LROTATE_EXPR:
1586     case RROTATE_EXPR:
1587     case BIT_IOR_EXPR:
1588     case BIT_XOR_EXPR:
1589     case BIT_AND_EXPR:
1590     case BIT_ANDTC_EXPR:
1591     case BIT_NOT_EXPR:
1592     case TRUTH_ANDIF_EXPR:
1593     case TRUTH_ORIF_EXPR:
1594     case TRUTH_AND_EXPR:
1595     case TRUTH_OR_EXPR:
1596     case TRUTH_XOR_EXPR:
1597     case TRUTH_NOT_EXPR:
1598     case LT_EXPR:
1599     case LE_EXPR:
1600     case GT_EXPR:
1601     case GE_EXPR:
1602     case EQ_EXPR:
1603     case NE_EXPR:
1604     case COMPLEX_EXPR:
1605     case CONJ_EXPR:
1606     case REALPART_EXPR:
1607     case IMAGPART_EXPR:
1608     case LABEL_EXPR:
1609     case COMPONENT_REF:
1610       return FALSE;
1611 
1612     case COMPOUND_EXPR:
1613       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1614 			      TREE_OPERAND (source_tree, 1), NULL,
1615 			      scalar_arg);
1616 
1617     case MODIFY_EXPR:
1618       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1619 			      TREE_OPERAND (source_tree, 0), NULL,
1620 			      scalar_arg);
1621 
1622     case CONVERT_EXPR:
1623     case NOP_EXPR:
1624     case NON_LVALUE_EXPR:
1625     case PLUS_EXPR:
1626       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1627 	return TRUE;
1628 
1629       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1630 				 source_tree);
1631       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1632       break;
1633 
1634     case COND_EXPR:
1635       return
1636 	ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1637 			 TREE_OPERAND (source_tree, 1), NULL,
1638 			 scalar_arg)
1639 	  || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1640 			      TREE_OPERAND (source_tree, 2), NULL,
1641 			      scalar_arg);
1642 
1643 
1644     case ADDR_EXPR:
1645       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1646 				 &source_size,
1647 				 TREE_OPERAND (source_tree, 0));
1648       break;
1649 
1650     case PARM_DECL:
1651       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1652 	return TRUE;
1653 
1654       source_decl = source_tree;
1655       source_offset = bitsize_zero_node;
1656       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1657       break;
1658 
1659     case SAVE_EXPR:
1660     case REFERENCE_EXPR:
1661     case PREDECREMENT_EXPR:
1662     case PREINCREMENT_EXPR:
1663     case POSTDECREMENT_EXPR:
1664     case POSTINCREMENT_EXPR:
1665     case INDIRECT_REF:
1666     case ARRAY_REF:
1667     case CALL_EXPR:
1668     default:
1669       return TRUE;
1670     }
1671 
1672   /* Come here when source_decl, source_offset, and source_size filled
1673      in appropriately.  */
1674 
1675   if (source_decl == NULL_TREE)
1676     return FALSE;		/* No decl involved, so no overlap. */
1677 
1678   if (source_decl != dest_decl)
1679     return FALSE;		/* Different decl, no overlap. */
1680 
1681   if (TREE_CODE (dest_size) == ERROR_MARK)
1682     return TRUE;		/* Assignment into entire assumed-size
1683 				   array?  Shouldn't happen.... */
1684 
1685   t = ffecom_2 (LE_EXPR, integer_type_node,
1686 		ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1687 			  dest_offset,
1688 			  convert (TREE_TYPE (dest_offset),
1689 				   dest_size)),
1690 		convert (TREE_TYPE (dest_offset),
1691 			 source_offset));
1692 
1693   if (integer_onep (t))
1694     return FALSE;		/* Destination precedes source. */
1695 
1696   if (!scalar_arg
1697       || (source_size == NULL_TREE)
1698       || (TREE_CODE (source_size) == ERROR_MARK)
1699       || integer_zerop (source_size))
1700     return TRUE;		/* No way to tell if dest follows source. */
1701 
1702   t = ffecom_2 (LE_EXPR, integer_type_node,
1703 		ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1704 			  source_offset,
1705 			  convert (TREE_TYPE (source_offset),
1706 				   source_size)),
1707 		convert (TREE_TYPE (source_offset),
1708 			 dest_offset));
1709 
1710   if (integer_onep (t))
1711     return FALSE;		/* Destination follows source. */
1712 
1713   return TRUE;		/* Destination and source overlap. */
1714 }
1715 
1716 /* Check whether dest might overlap any of a list of arguments or is
1717    in a COMMON area the callee might know about (and thus modify).  */
1718 
1719 static bool
ffecom_args_overlapping_(tree dest_tree,ffebld dest UNUSED,tree args,tree callee_commons,bool scalar_args)1720 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1721 			  tree args, tree callee_commons,
1722 			  bool scalar_args)
1723 {
1724   tree arg;
1725   tree dest_decl;
1726   tree dest_offset;
1727   tree dest_size;
1728 
1729   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1730 			     dest_tree);
1731 
1732   if (dest_decl == NULL_TREE)
1733     return FALSE;		/* Seems unlikely! */
1734 
1735   /* If the decl cannot be determined reliably, or if its in COMMON
1736      and the callee isn't known to not futz with COMMON via other
1737      means, overlap might happen.  */
1738 
1739   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1740       || ((callee_commons != NULL_TREE)
1741 	  && TREE_PUBLIC (dest_decl)))
1742     return TRUE;
1743 
1744   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1745     {
1746       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1747 	  && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1748 			      arg, NULL, scalar_args))
1749 	return TRUE;
1750     }
1751 
1752   return FALSE;
1753 }
1754 
1755 /* Build a string for a variable name as used by NAMELIST.  This means that
1756    if we're using the f2c library, we build an uppercase string, since
1757    f2c does this.  */
1758 
1759 static tree
ffecom_build_f2c_string_(int i,const char * s)1760 ffecom_build_f2c_string_ (int i, const char *s)
1761 {
1762   if (!ffe_is_f2c_library ())
1763     return build_string (i, s);
1764 
1765   {
1766     char *tmp;
1767     const char *p;
1768     char *q;
1769     char space[34];
1770     tree t;
1771 
1772     if (((size_t) i) > ARRAY_SIZE (space))
1773       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1774     else
1775       tmp = &space[0];
1776 
1777     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1778       *q = TOUPPER (*p);
1779     *q = '\0';
1780 
1781     t = build_string (i, tmp);
1782 
1783     if (((size_t) i) > ARRAY_SIZE (space))
1784       malloc_kill_ks (malloc_pool_image (), tmp, i);
1785 
1786     return t;
1787   }
1788 }
1789 
1790 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1791    type to just get whatever the function returns), handling the
1792    f2c value-returning convention, if required, by prepending
1793    to the arglist a pointer to a temporary to receive the return value.	 */
1794 
1795 static tree
ffecom_call_(tree fn,ffeinfoKindtype kt,bool is_f2c_complex,tree type,tree args,tree dest_tree,ffebld dest,bool * dest_used,tree callee_commons,bool scalar_args,tree hook)1796 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1797 	      tree type, tree args, tree dest_tree,
1798 	      ffebld dest, bool *dest_used, tree callee_commons,
1799 	      bool scalar_args, tree hook)
1800 {
1801   tree item;
1802   tree tempvar;
1803 
1804   if (dest_used != NULL)
1805     *dest_used = FALSE;
1806 
1807   if (is_f2c_complex)
1808     {
1809       if ((dest_used == NULL)
1810 	  || (dest == NULL)
1811 	  || (ffeinfo_basictype (ffebld_info (dest))
1812 	      != FFEINFO_basictypeCOMPLEX)
1813 	  || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1814 	  || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1815 	  || ffecom_args_overlapping_ (dest_tree, dest, args,
1816 				       callee_commons,
1817 				       scalar_args))
1818 	{
1819 	  tempvar = hook;
1820 	  assert (tempvar);
1821 	}
1822       else
1823 	{
1824 	  *dest_used = TRUE;
1825 	  tempvar = dest_tree;
1826 	  type = NULL_TREE;
1827 	}
1828 
1829       item
1830 	= build_tree_list (NULL_TREE,
1831 			   ffecom_1 (ADDR_EXPR,
1832 				     build_pointer_type (TREE_TYPE (tempvar)),
1833 				     tempvar));
1834       TREE_CHAIN (item) = args;
1835 
1836       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1837 			item, NULL_TREE);
1838 
1839       if (tempvar != dest_tree)
1840 	item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1841     }
1842   else
1843     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1844 		      args, NULL_TREE);
1845 
1846   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1847     item = ffecom_convert_narrow_ (type, item);
1848 
1849   return item;
1850 }
1851 
1852 /* Given two arguments, transform them and make a call to the given
1853    function via ffecom_call_.  */
1854 
1855 static tree
ffecom_call_binop_(tree fn,ffeinfoKindtype kt,bool is_f2c_complex,tree type,ffebld left,ffebld right,tree dest_tree,ffebld dest,bool * dest_used,tree callee_commons,bool scalar_args,bool ref,tree hook)1856 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1857 		    tree type, ffebld left, ffebld right,
1858 		    tree dest_tree, ffebld dest, bool *dest_used,
1859 		    tree callee_commons, bool scalar_args, bool ref, tree hook)
1860 {
1861   tree left_tree;
1862   tree right_tree;
1863   tree left_length;
1864   tree right_length;
1865 
1866   if (ref)
1867     {
1868       /* Pass arguments by reference.  */
1869       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1870       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1871     }
1872   else
1873     {
1874       /* Pass arguments by value.  */
1875       left_tree = ffecom_arg_expr (left, &left_length);
1876       right_tree = ffecom_arg_expr (right, &right_length);
1877     }
1878 
1879 
1880   left_tree = build_tree_list (NULL_TREE, left_tree);
1881   right_tree = build_tree_list (NULL_TREE, right_tree);
1882   TREE_CHAIN (left_tree) = right_tree;
1883 
1884   if (left_length != NULL_TREE)
1885     {
1886       left_length = build_tree_list (NULL_TREE, left_length);
1887       TREE_CHAIN (right_tree) = left_length;
1888     }
1889 
1890   if (right_length != NULL_TREE)
1891     {
1892       right_length = build_tree_list (NULL_TREE, right_length);
1893       if (left_length != NULL_TREE)
1894 	TREE_CHAIN (left_length) = right_length;
1895       else
1896 	TREE_CHAIN (right_tree) = right_length;
1897     }
1898 
1899   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1900 		       dest_tree, dest, dest_used, callee_commons,
1901 		       scalar_args, hook);
1902 }
1903 
1904 /* Return ptr/length args for char subexpression
1905 
1906    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1907    subexpressions by constructing the appropriate trees for the ptr-to-
1908    character-text and length-of-character-text arguments in a calling
1909    sequence.
1910 
1911    Note that if with_null is TRUE, and the expression is an opCONTER,
1912    a null byte is appended to the string.  */
1913 
1914 static void
ffecom_char_args_x_(tree * xitem,tree * length,ffebld expr,bool with_null)1915 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1916 {
1917   tree item;
1918   tree high;
1919   ffetargetCharacter1 val;
1920   ffetargetCharacterSize newlen;
1921 
1922   switch (ffebld_op (expr))
1923     {
1924     case FFEBLD_opCONTER:
1925       val = ffebld_constant_character1 (ffebld_conter (expr));
1926       newlen = ffetarget_length_character1 (val);
1927       if (with_null)
1928 	{
1929 	  /* Begin FFETARGET-NULL-KLUDGE.  */
1930 	  if (newlen != 0)
1931 	    ++newlen;
1932 	}
1933       *length = build_int_2 (newlen, 0);
1934       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1935       high = build_int_2 (newlen, 0);
1936       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1937       item = build_string (newlen,
1938 			   ffetarget_text_character1 (val));
1939       /* End FFETARGET-NULL-KLUDGE.  */
1940       TREE_TYPE (item)
1941 	= build_type_variant
1942 	  (build_array_type
1943 	   (char_type_node,
1944 	    build_range_type
1945 	    (ffecom_f2c_ftnlen_type_node,
1946 	     ffecom_f2c_ftnlen_one_node,
1947 	     high)),
1948 	   1, 0);
1949       TREE_CONSTANT (item) = 1;
1950       TREE_STATIC (item) = 1;
1951       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1952 		       item);
1953       break;
1954 
1955     case FFEBLD_opSYMTER:
1956       {
1957 	ffesymbol s = ffebld_symter (expr);
1958 
1959 	item = ffesymbol_hook (s).decl_tree;
1960 	if (item == NULL_TREE)
1961 	  {
1962 	    s = ffecom_sym_transform_ (s);
1963 	    item = ffesymbol_hook (s).decl_tree;
1964 	  }
1965 	if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1966 	  {
1967 	    if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1968 	      *length = ffesymbol_hook (s).length_tree;
1969 	    else
1970 	      {
1971 		*length = build_int_2 (ffesymbol_size (s), 0);
1972 		TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1973 	      }
1974 	  }
1975 	else if (item == error_mark_node)
1976 	  *length = error_mark_node;
1977 	else
1978 	  /* FFEINFO_kindFUNCTION.  */
1979 	  *length = NULL_TREE;
1980 	if (!ffesymbol_hook (s).addr
1981 	    && (item != error_mark_node))
1982 	  item = ffecom_1 (ADDR_EXPR,
1983 			   build_pointer_type (TREE_TYPE (item)),
1984 			   item);
1985       }
1986       break;
1987 
1988     case FFEBLD_opARRAYREF:
1989       {
1990 	ffecom_char_args_ (&item, length, ffebld_left (expr));
1991 
1992 	if (item == error_mark_node || *length == error_mark_node)
1993 	  {
1994 	    item = *length = error_mark_node;
1995 	    break;
1996 	  }
1997 
1998 	item = ffecom_arrayref_ (item, expr, 1);
1999       }
2000       break;
2001 
2002     case FFEBLD_opSUBSTR:
2003       {
2004 	ffebld start;
2005 	ffebld end;
2006 	ffebld thing = ffebld_right (expr);
2007 	tree start_tree;
2008 	tree end_tree;
2009 	const char *char_name;
2010 	ffebld left_symter;
2011 	tree array;
2012 
2013 	assert (ffebld_op (thing) == FFEBLD_opITEM);
2014 	start = ffebld_head (thing);
2015 	thing = ffebld_trail (thing);
2016 	assert (ffebld_trail (thing) == NULL);
2017 	end = ffebld_head (thing);
2018 
2019 	/* Determine name for pretty-printing range-check errors.  */
2020 	for (left_symter = ffebld_left (expr);
2021 	     left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2022 	     left_symter = ffebld_left (left_symter))
2023 	  ;
2024 	if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2025 	  char_name = ffesymbol_text (ffebld_symter (left_symter));
2026 	else
2027 	  char_name = "[expr?]";
2028 
2029 	ffecom_char_args_ (&item, length, ffebld_left (expr));
2030 
2031 	if (item == error_mark_node || *length == error_mark_node)
2032 	  {
2033 	    item = *length = error_mark_node;
2034 	    break;
2035 	  }
2036 
2037 	array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2038 
2039 	/* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2040 
2041 	if (start == NULL)
2042 	  {
2043 	    if (end == NULL)
2044 	      ;
2045 	    else
2046 	      {
2047 		end_tree = ffecom_expr (end);
2048 		if (flag_bounds_check)
2049 		  end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2050 						      char_name, NULL_TREE);
2051 		end_tree = convert (ffecom_f2c_ftnlen_type_node,
2052 				    end_tree);
2053 
2054 		if (end_tree == error_mark_node)
2055 		  {
2056 		    item = *length = error_mark_node;
2057 		    break;
2058 		  }
2059 
2060 		*length = end_tree;
2061 	      }
2062 	  }
2063 	else
2064 	  {
2065 	    start_tree = ffecom_expr (start);
2066 	    if (flag_bounds_check)
2067 	      start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2068 						    char_name, NULL_TREE);
2069 	    start_tree = convert (ffecom_f2c_ftnlen_type_node,
2070 				  start_tree);
2071 
2072 	    if (start_tree == error_mark_node)
2073 	      {
2074 		item = *length = error_mark_node;
2075 		break;
2076 	      }
2077 
2078 	    start_tree = ffecom_save_tree (start_tree);
2079 
2080 	    item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2081 			     item,
2082 			     ffecom_2 (MINUS_EXPR,
2083 				       TREE_TYPE (start_tree),
2084 				       start_tree,
2085 				       ffecom_f2c_ftnlen_one_node));
2086 
2087 	    if (end == NULL)
2088 	      {
2089 		*length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2090 				    ffecom_f2c_ftnlen_one_node,
2091 				    ffecom_2 (MINUS_EXPR,
2092 					      ffecom_f2c_ftnlen_type_node,
2093 					      *length,
2094 					      start_tree));
2095 	      }
2096 	    else
2097 	      {
2098 		end_tree = ffecom_expr (end);
2099 		if (flag_bounds_check)
2100 		  end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2101 						      char_name, NULL_TREE);
2102 		end_tree = convert (ffecom_f2c_ftnlen_type_node,
2103 				    end_tree);
2104 
2105 		if (end_tree == error_mark_node)
2106 		  {
2107 		    item = *length = error_mark_node;
2108 		    break;
2109 		  }
2110 
2111 		*length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2112 				    ffecom_f2c_ftnlen_one_node,
2113 				    ffecom_2 (MINUS_EXPR,
2114 					      ffecom_f2c_ftnlen_type_node,
2115 					      end_tree, start_tree));
2116 	      }
2117 	  }
2118       }
2119       break;
2120 
2121     case FFEBLD_opFUNCREF:
2122       {
2123 	ffesymbol s = ffebld_symter (ffebld_left (expr));
2124 	tree tempvar;
2125 	tree args;
2126 	ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2127 	ffecomGfrt ix;
2128 
2129 	if (size == FFETARGET_charactersizeNONE)
2130 	  /* ~~Kludge alert!  This should someday be fixed. */
2131 	  size = 24;
2132 
2133 	*length = build_int_2 (size, 0);
2134 	TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2135 
2136 	if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2137 	    == FFEINFO_whereINTRINSIC)
2138 	  {
2139 	    if (size == 1)
2140 	      {
2141 		/* Invocation of an intrinsic returning CHARACTER*1.  */
2142 		item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2143 					       NULL, NULL);
2144 		break;
2145 	      }
2146 	    ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2147 	    assert (ix != FFECOM_gfrt);
2148 	    item = ffecom_gfrt_tree_ (ix);
2149 	  }
2150 	else
2151 	  {
2152 	    ix = FFECOM_gfrt;
2153 	    item = ffesymbol_hook (s).decl_tree;
2154 	    if (item == NULL_TREE)
2155 	      {
2156 		s = ffecom_sym_transform_ (s);
2157 		item = ffesymbol_hook (s).decl_tree;
2158 	      }
2159 	    if (item == error_mark_node)
2160 	      {
2161 		item = *length = error_mark_node;
2162 		break;
2163 	      }
2164 
2165 	    if (!ffesymbol_hook (s).addr)
2166 	      item = ffecom_1_fn (item);
2167 	  }
2168 	tempvar = ffebld_nonter_hook (expr);
2169 	assert (tempvar);
2170 	tempvar = ffecom_1 (ADDR_EXPR,
2171 			    build_pointer_type (TREE_TYPE (tempvar)),
2172 			    tempvar);
2173 
2174 	args = build_tree_list (NULL_TREE, tempvar);
2175 
2176 	if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)	/* Sfunc args by value. */
2177 	  TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2178 	else
2179 	  {
2180 	    TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2181 	    if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2182 	      {
2183 		TREE_CHAIN (TREE_CHAIN (args))
2184 		  = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2185 					  ffebld_right (expr));
2186 	      }
2187 	    else
2188 	      {
2189 		TREE_CHAIN (TREE_CHAIN (args))
2190 		  = ffecom_list_ptr_to_expr (ffebld_right (expr));
2191 	      }
2192 	  }
2193 
2194 	item = ffecom_3s (CALL_EXPR,
2195 			  TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2196 			  item, args, NULL_TREE);
2197 	item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2198 			 tempvar);
2199       }
2200       break;
2201 
2202     case FFEBLD_opCONVERT:
2203 
2204       ffecom_char_args_ (&item, length, ffebld_left (expr));
2205 
2206       if (item == error_mark_node || *length == error_mark_node)
2207 	{
2208 	  item = *length = error_mark_node;
2209 	  break;
2210 	}
2211 
2212       if ((ffebld_size_known (ffebld_left (expr))
2213 	   == FFETARGET_charactersizeNONE)
2214 	  || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2215 	{			/* Possible blank-padding needed, copy into
2216 				   temporary. */
2217 	  tree tempvar;
2218 	  tree args;
2219 	  tree newlen;
2220 
2221 	  tempvar = ffebld_nonter_hook (expr);
2222 	  assert (tempvar);
2223 	  tempvar = ffecom_1 (ADDR_EXPR,
2224 			      build_pointer_type (TREE_TYPE (tempvar)),
2225 			      tempvar);
2226 
2227 	  newlen = build_int_2 (ffebld_size (expr), 0);
2228 	  TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2229 
2230 	  args = build_tree_list (NULL_TREE, tempvar);
2231 	  TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2232 	  TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2233 	  TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2234 	    = build_tree_list (NULL_TREE, *length);
2235 
2236 	  item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2237 	  TREE_SIDE_EFFECTS (item) = 1;
2238 	  item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2239 			   tempvar);
2240 	  *length = newlen;
2241 	}
2242       else
2243 	{			/* Just truncate the length. */
2244 	  *length = build_int_2 (ffebld_size (expr), 0);
2245 	  TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2246 	}
2247       break;
2248 
2249     default:
2250       assert ("bad op for single char arg expr" == NULL);
2251       item = NULL_TREE;
2252       break;
2253     }
2254 
2255   *xitem = item;
2256 }
2257 
2258 /* Check the size of the type to be sure it doesn't overflow the
2259    "portable" capacities of the compiler back end.  `dummy' types
2260    can generally overflow the normal sizes as long as the computations
2261    themselves don't overflow.  A particular target of the back end
2262    must still enforce its size requirements, though, and the back
2263    end takes care of this in stor-layout.c.  */
2264 
2265 static tree
ffecom_check_size_overflow_(ffesymbol s,tree type,bool dummy)2266 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2267 {
2268   if (TREE_CODE (type) == ERROR_MARK)
2269     return type;
2270 
2271   if (TYPE_SIZE (type) == NULL_TREE)
2272     return type;
2273 
2274   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2275     return type;
2276 
2277   /* An array is too large if size is negative or the type_size overflows
2278      or its "upper half" is larger than 3 (which would make the signed
2279      byte size and offset computations overflow).  */
2280 
2281   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2282       || (!dummy && (TREE_INT_CST_HIGH (TYPE_SIZE (type)) > 3
2283 	             || TREE_OVERFLOW (TYPE_SIZE (type)))))
2284     {
2285       ffebad_start (FFEBAD_ARRAY_LARGE);
2286       ffebad_string (ffesymbol_text (s));
2287       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2288       ffebad_finish ();
2289 
2290       return error_mark_node;
2291     }
2292 
2293   return type;
2294 }
2295 
2296 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2297    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2298    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2299 
2300 static tree
ffecom_char_enhance_arg_(tree * xtype,ffesymbol s)2301 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2302 {
2303   ffetargetCharacterSize sz = ffesymbol_size (s);
2304   tree highval;
2305   tree tlen;
2306   tree type = *xtype;
2307 
2308   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2309     tlen = NULL_TREE;		/* A statement function, no length passed. */
2310   else
2311     {
2312       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2313 	tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2314 					       ffesymbol_text (s));
2315       else
2316 	tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2317       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2318       DECL_ARTIFICIAL (tlen) = 1;
2319     }
2320 
2321   if (sz == FFETARGET_charactersizeNONE)
2322     {
2323       assert (tlen != NULL_TREE);
2324       highval = variable_size (tlen);
2325     }
2326   else
2327     {
2328       highval = build_int_2 (sz, 0);
2329       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2330     }
2331 
2332   type = build_array_type (type,
2333 			   build_range_type (ffecom_f2c_ftnlen_type_node,
2334 					     ffecom_f2c_ftnlen_one_node,
2335 					     highval));
2336 
2337   *xtype = type;
2338   return tlen;
2339 }
2340 
2341 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2342 
2343    ffecomConcatList_ catlist;
2344    ffebld expr;	 // expr of CHARACTER basictype.
2345    ffetargetCharacterSize max;	// max chars to gather or _...NONE if no max
2346    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2347 
2348    Scans expr for character subexpressions, updates and returns catlist
2349    accordingly.	 */
2350 
2351 static ffecomConcatList_
ffecom_concat_list_gather_(ffecomConcatList_ catlist,ffebld expr,ffetargetCharacterSize max)2352 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2353 			    ffetargetCharacterSize max)
2354 {
2355   ffetargetCharacterSize sz;
2356 
2357  recurse:
2358 
2359   if (expr == NULL)
2360     return catlist;
2361 
2362   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2363     return catlist;		/* Don't append any more items. */
2364 
2365   switch (ffebld_op (expr))
2366     {
2367     case FFEBLD_opCONTER:
2368     case FFEBLD_opSYMTER:
2369     case FFEBLD_opARRAYREF:
2370     case FFEBLD_opFUNCREF:
2371     case FFEBLD_opSUBSTR:
2372     case FFEBLD_opCONVERT:	/* Callers should strip this off beforehand
2373 				   if they don't need to preserve it. */
2374       if (catlist.count == catlist.max)
2375 	{			/* Make a (larger) list. */
2376 	  ffebld *newx;
2377 	  int newmax;
2378 
2379 	  newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2380 	  newx = malloc_new_ks (malloc_pool_image (), "catlist",
2381 				newmax * sizeof (newx[0]));
2382 	  if (catlist.max != 0)
2383 	    {
2384 	      memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2385 	      malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2386 			      catlist.max * sizeof (newx[0]));
2387 	    }
2388 	  catlist.max = newmax;
2389 	  catlist.exprs = newx;
2390 	}
2391       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2392 	catlist.minlen += sz;
2393       else
2394 	++catlist.minlen;	/* Not true for F90; can be 0 length. */
2395       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2396 	catlist.maxlen = sz;
2397       else
2398 	catlist.maxlen += sz;
2399       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2400 	{			/* This item overlaps (or is beyond) the end
2401 				   of the destination. */
2402 	  switch (ffebld_op (expr))
2403 	    {
2404 	    case FFEBLD_opCONTER:
2405 	    case FFEBLD_opSYMTER:
2406 	    case FFEBLD_opARRAYREF:
2407 	    case FFEBLD_opFUNCREF:
2408 	    case FFEBLD_opSUBSTR:
2409 	      /* ~~Do useful truncations here. */
2410 	      break;
2411 
2412 	    default:
2413 	      assert ("op changed or inconsistent switches!" == NULL);
2414 	      break;
2415 	    }
2416 	}
2417       catlist.exprs[catlist.count++] = expr;
2418       return catlist;
2419 
2420     case FFEBLD_opPAREN:
2421       expr = ffebld_left (expr);
2422       goto recurse;		/* :::::::::::::::::::: */
2423 
2424     case FFEBLD_opCONCATENATE:
2425       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2426       expr = ffebld_right (expr);
2427       goto recurse;		/* :::::::::::::::::::: */
2428 
2429 #if 0				/* Breaks passing small actual arg to larger
2430 				   dummy arg of sfunc */
2431     case FFEBLD_opCONVERT:
2432       expr = ffebld_left (expr);
2433       {
2434 	ffetargetCharacterSize cmax;
2435 
2436 	cmax = catlist.len + ffebld_size_known (expr);
2437 
2438 	if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2439 	  max = cmax;
2440       }
2441       goto recurse;		/* :::::::::::::::::::: */
2442 #endif
2443 
2444     case FFEBLD_opANY:
2445       return catlist;
2446 
2447     default:
2448       assert ("bad op in _gather_" == NULL);
2449       return catlist;
2450     }
2451 }
2452 
2453 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2454 
2455    ffecomConcatList_ catlist;
2456    ffecom_concat_list_kill_(catlist);
2457 
2458    Anything allocated within the list info is deallocated.  */
2459 
2460 static void
ffecom_concat_list_kill_(ffecomConcatList_ catlist)2461 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2462 {
2463   if (catlist.max != 0)
2464     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2465 		    catlist.max * sizeof (catlist.exprs[0]));
2466 }
2467 
2468 /* Make list of concatenated string exprs.
2469 
2470    Returns a flattened list of concatenated subexpressions given a
2471    tree of such expressions.  */
2472 
2473 static ffecomConcatList_
ffecom_concat_list_new_(ffebld expr,ffetargetCharacterSize max)2474 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2475 {
2476   ffecomConcatList_ catlist;
2477 
2478   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2479   return ffecom_concat_list_gather_ (catlist, expr, max);
2480 }
2481 
2482 /* Provide some kind of useful info on member of aggregate area,
2483    since current g77/gcc technology does not provide debug info
2484    on these members.  */
2485 
2486 static void
ffecom_debug_kludge_(tree aggr,const char * aggr_type,ffesymbol member,tree member_type UNUSED,ffetargetOffset offset)2487 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2488 		      tree member_type UNUSED, ffetargetOffset offset)
2489 {
2490   tree value;
2491   tree decl;
2492   int len;
2493   char *buff;
2494   char space[120];
2495 #if 0
2496   tree type_id;
2497 
2498   for (type_id = member_type;
2499        TREE_CODE (type_id) != IDENTIFIER_NODE;
2500        )
2501     {
2502       switch (TREE_CODE (type_id))
2503 	{
2504 	case INTEGER_TYPE:
2505 	case REAL_TYPE:
2506 	  type_id = TYPE_NAME (type_id);
2507 	  break;
2508 
2509 	case ARRAY_TYPE:
2510 	case COMPLEX_TYPE:
2511 	  type_id = TREE_TYPE (type_id);
2512 	  break;
2513 
2514 	default:
2515 	  assert ("no IDENTIFIER_NODE for type!" == NULL);
2516 	  type_id = error_mark_node;
2517 	  break;
2518 	}
2519     }
2520 #endif
2521 
2522   if (ffecom_transform_only_dummies_
2523       || !ffe_is_debug_kludge ())
2524     return;	/* Can't do this yet, maybe later. */
2525 
2526   len = 60
2527     + strlen (aggr_type)
2528     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2529 #if 0
2530     + IDENTIFIER_LENGTH (type_id);
2531 #endif
2532 
2533   if (((size_t) len) >= ARRAY_SIZE (space))
2534     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2535   else
2536     buff = &space[0];
2537 
2538   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2539 	   aggr_type,
2540 	   IDENTIFIER_POINTER (DECL_NAME (aggr)),
2541 	   (long int) offset);
2542 
2543   value = build_string (len, buff);
2544   TREE_TYPE (value)
2545     = build_type_variant (build_array_type (char_type_node,
2546 					    build_range_type
2547 					    (integer_type_node,
2548 					     integer_one_node,
2549 					     build_int_2 (strlen (buff), 0))),
2550 			  1, 0);
2551   decl = build_decl (VAR_DECL,
2552 		     ffecom_get_identifier_ (ffesymbol_text (member)),
2553 		     TREE_TYPE (value));
2554   TREE_CONSTANT (decl) = 1;
2555   TREE_STATIC (decl) = 1;
2556   DECL_INITIAL (decl) = error_mark_node;
2557   DECL_IN_SYSTEM_HEADER (decl) = 1;	/* Don't let -Wunused complain. */
2558   decl = start_decl (decl, FALSE);
2559   finish_decl (decl, value, FALSE);
2560 
2561   if (buff != &space[0])
2562     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2563 }
2564 
2565 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2566 
2567    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2568    int i;  // entry# for this entrypoint (used by master fn)
2569    ffecom_do_entrypoint_(s,i);
2570 
2571    Makes a public entry point that calls our private master fn (already
2572    compiled).  */
2573 
2574 static void
ffecom_do_entry_(ffesymbol fn,int entrynum)2575 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2576 {
2577   ffebld item;
2578   tree type;			/* Type of function. */
2579   tree multi_retval;		/* Var holding return value (union). */
2580   tree result;			/* Var holding result. */
2581   ffeinfoBasictype bt;
2582   ffeinfoKindtype kt;
2583   ffeglobal g;
2584   ffeglobalType gt;
2585   bool charfunc;		/* All entry points return same type
2586 				   CHARACTER. */
2587   bool cmplxfunc;		/* Use f2c way of returning COMPLEX. */
2588   bool multi;			/* Master fn has multiple return types. */
2589   bool altreturning = FALSE;	/* This entry point has alternate returns. */
2590   int old_lineno = lineno;
2591   const char *old_input_filename = input_filename;
2592 
2593   input_filename = ffesymbol_where_filename (fn);
2594   lineno = ffesymbol_where_filelinenum (fn);
2595 
2596   ffecom_doing_entry_ = TRUE;	/* Don't bother with array dimensions. */
2597 
2598   switch (ffecom_primary_entry_kind_)
2599     {
2600     case FFEINFO_kindFUNCTION:
2601 
2602       /* Determine actual return type for function. */
2603 
2604       gt = FFEGLOBAL_typeFUNC;
2605       bt = ffesymbol_basictype (fn);
2606       kt = ffesymbol_kindtype (fn);
2607       if (bt == FFEINFO_basictypeNONE)
2608 	{
2609 	  ffeimplic_establish_symbol (fn);
2610 	  if (ffesymbol_funcresult (fn) != NULL)
2611 	    ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2612 	  bt = ffesymbol_basictype (fn);
2613 	  kt = ffesymbol_kindtype (fn);
2614 	}
2615 
2616       if (bt == FFEINFO_basictypeCHARACTER)
2617 	charfunc = TRUE, cmplxfunc = FALSE;
2618       else if ((bt == FFEINFO_basictypeCOMPLEX)
2619 	       && ffesymbol_is_f2c (fn))
2620 	charfunc = FALSE, cmplxfunc = TRUE;
2621       else
2622 	charfunc = cmplxfunc = FALSE;
2623 
2624       if (charfunc)
2625 	type = ffecom_tree_fun_type_void;
2626       else if (ffesymbol_is_f2c (fn))
2627 	type = ffecom_tree_fun_type[bt][kt];
2628       else
2629 	type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2630 
2631       if ((type == NULL_TREE)
2632 	  || (TREE_TYPE (type) == NULL_TREE))
2633 	type = ffecom_tree_fun_type_void;	/* _sym_exec_transition. */
2634 
2635       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2636       break;
2637 
2638     case FFEINFO_kindSUBROUTINE:
2639       gt = FFEGLOBAL_typeSUBR;
2640       bt = FFEINFO_basictypeNONE;
2641       kt = FFEINFO_kindtypeNONE;
2642       if (ffecom_is_altreturning_)
2643 	{			/* Am _I_ altreturning? */
2644 	  for (item = ffesymbol_dummyargs (fn);
2645 	       item != NULL;
2646 	       item = ffebld_trail (item))
2647 	    {
2648 	      if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2649 		{
2650 		  altreturning = TRUE;
2651 		  break;
2652 		}
2653 	    }
2654 	  if (altreturning)
2655 	    type = ffecom_tree_subr_type;
2656 	  else
2657 	    type = ffecom_tree_fun_type_void;
2658 	}
2659       else
2660 	type = ffecom_tree_fun_type_void;
2661       charfunc = FALSE;
2662       cmplxfunc = FALSE;
2663       multi = FALSE;
2664       break;
2665 
2666     default:
2667       assert ("say what??" == NULL);
2668       /* Fall through. */
2669     case FFEINFO_kindANY:
2670       gt = FFEGLOBAL_typeANY;
2671       bt = FFEINFO_basictypeNONE;
2672       kt = FFEINFO_kindtypeNONE;
2673       type = error_mark_node;
2674       charfunc = FALSE;
2675       cmplxfunc = FALSE;
2676       multi = FALSE;
2677       break;
2678     }
2679 
2680   /* build_decl uses the current lineno and input_filename to set the decl
2681      source info.  So, I've putzed with ffestd and ffeste code to update that
2682      source info to point to the appropriate statement just before calling
2683      ffecom_do_entrypoint (which calls this fn).  */
2684 
2685   start_function (ffecom_get_external_identifier_ (fn),
2686 		  type,
2687 		  0,		/* nested/inline */
2688 		  1);		/* TREE_PUBLIC */
2689 
2690   if (((g = ffesymbol_global (fn)) != NULL)
2691       && ((ffeglobal_type (g) == gt)
2692 	  || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2693     {
2694       ffeglobal_set_hook (g, current_function_decl);
2695     }
2696 
2697   /* Reset args in master arg list so they get retransitioned. */
2698 
2699   for (item = ffecom_master_arglist_;
2700        item != NULL;
2701        item = ffebld_trail (item))
2702     {
2703       ffebld arg;
2704       ffesymbol s;
2705 
2706       arg = ffebld_head (item);
2707       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2708 	continue;		/* Alternate return or some such thing. */
2709       s = ffebld_symter (arg);
2710       ffesymbol_hook (s).decl_tree = NULL_TREE;
2711       ffesymbol_hook (s).length_tree = NULL_TREE;
2712     }
2713 
2714   /* Build dummy arg list for this entry point. */
2715 
2716   if (charfunc || cmplxfunc)
2717     {				/* Prepend arg for where result goes. */
2718       tree type;
2719       tree length;
2720 
2721       if (charfunc)
2722 	type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2723       else
2724 	type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2725 
2726       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2727 
2728       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2729 
2730       if (charfunc)
2731 	length = ffecom_char_enhance_arg_ (&type, fn);
2732       else
2733 	length = NULL_TREE;	/* Not ref'd if !charfunc. */
2734 
2735       type = build_pointer_type (type);
2736       result = build_decl (PARM_DECL, result, type);
2737 
2738       push_parm_decl (result);
2739       ffecom_func_result_ = result;
2740 
2741       if (charfunc)
2742 	{
2743 	  push_parm_decl (length);
2744 	  ffecom_func_length_ = length;
2745 	}
2746     }
2747   else
2748     result = DECL_RESULT (current_function_decl);
2749 
2750   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2751 
2752   store_parm_decls (0);
2753 
2754   ffecom_start_compstmt ();
2755   /* Disallow temp vars at this level.  */
2756   current_binding_level->prep_state = 2;
2757 
2758   /* Make local var to hold return type for multi-type master fn. */
2759 
2760   if (multi)
2761     {
2762       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2763 						     "multi_retval");
2764       multi_retval = build_decl (VAR_DECL, multi_retval,
2765 				 ffecom_multi_type_node_);
2766       multi_retval = start_decl (multi_retval, FALSE);
2767       finish_decl (multi_retval, NULL_TREE, FALSE);
2768     }
2769   else
2770     multi_retval = NULL_TREE;	/* Not actually ref'd if !multi. */
2771 
2772   /* Here we emit the actual code for the entry point. */
2773 
2774   {
2775     ffebld list;
2776     ffebld arg;
2777     ffesymbol s;
2778     tree arglist = NULL_TREE;
2779     tree *plist = &arglist;
2780     tree prepend;
2781     tree call;
2782     tree actarg;
2783     tree master_fn;
2784 
2785     /* Prepare actual arg list based on master arg list. */
2786 
2787     for (list = ffecom_master_arglist_;
2788 	 list != NULL;
2789 	 list = ffebld_trail (list))
2790       {
2791 	arg = ffebld_head (list);
2792 	if (ffebld_op (arg) != FFEBLD_opSYMTER)
2793 	  continue;
2794 	s = ffebld_symter (arg);
2795 	if (ffesymbol_hook (s).decl_tree == NULL_TREE
2796 	    || ffesymbol_hook (s).decl_tree == error_mark_node)
2797 	  actarg = null_pointer_node;	/* We don't have this arg. */
2798 	else
2799 	  actarg = ffesymbol_hook (s).decl_tree;
2800 	*plist = build_tree_list (NULL_TREE, actarg);
2801 	plist = &TREE_CHAIN (*plist);
2802       }
2803 
2804     /* This code appends the length arguments for character
2805        variables/arrays.  */
2806 
2807     for (list = ffecom_master_arglist_;
2808 	 list != NULL;
2809 	 list = ffebld_trail (list))
2810       {
2811 	arg = ffebld_head (list);
2812 	if (ffebld_op (arg) != FFEBLD_opSYMTER)
2813 	  continue;
2814 	s = ffebld_symter (arg);
2815 	if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2816 	  continue;		/* Only looking for CHARACTER arguments. */
2817 	if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2818 	  continue;		/* Only looking for variables and arrays. */
2819 	if (ffesymbol_hook (s).length_tree == NULL_TREE
2820 	    || ffesymbol_hook (s).length_tree == error_mark_node)
2821 	  actarg = ffecom_f2c_ftnlen_zero_node;	/* We don't have this arg. */
2822 	else
2823 	  actarg = ffesymbol_hook (s).length_tree;
2824 	*plist = build_tree_list (NULL_TREE, actarg);
2825 	plist = &TREE_CHAIN (*plist);
2826       }
2827 
2828     /* Prepend character-value return info to actual arg list. */
2829 
2830     if (charfunc)
2831       {
2832 	prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2833 	TREE_CHAIN (prepend)
2834 	  = build_tree_list (NULL_TREE, ffecom_func_length_);
2835 	TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2836 	arglist = prepend;
2837       }
2838 
2839     /* Prepend multi-type return value to actual arg list. */
2840 
2841     if (multi)
2842       {
2843 	prepend
2844 	  = build_tree_list (NULL_TREE,
2845 			     ffecom_1 (ADDR_EXPR,
2846 			      build_pointer_type (TREE_TYPE (multi_retval)),
2847 				       multi_retval));
2848 	TREE_CHAIN (prepend) = arglist;
2849 	arglist = prepend;
2850       }
2851 
2852     /* Prepend my entry-point number to the actual arg list. */
2853 
2854     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2855     TREE_CHAIN (prepend) = arglist;
2856     arglist = prepend;
2857 
2858     /* Build the call to the master function. */
2859 
2860     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2861     call = ffecom_3s (CALL_EXPR,
2862 		      TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2863 		      master_fn, arglist, NULL_TREE);
2864 
2865     /* Decide whether the master function is a function or subroutine, and
2866        handle the return value for my entry point. */
2867 
2868     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2869 		     && !altreturning))
2870       {
2871 	expand_expr_stmt (call);
2872 	expand_null_return ();
2873       }
2874     else if (multi && cmplxfunc)
2875       {
2876 	expand_expr_stmt (call);
2877 	result
2878 	  = ffecom_1 (INDIRECT_REF,
2879 		      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2880 		      result);
2881 	result = ffecom_modify (NULL_TREE, result,
2882 				ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2883 					  multi_retval,
2884 					  ffecom_multi_fields_[bt][kt]));
2885 	expand_expr_stmt (result);
2886 	expand_null_return ();
2887       }
2888     else if (multi)
2889       {
2890 	expand_expr_stmt (call);
2891 	result
2892 	  = ffecom_modify (NULL_TREE, result,
2893 			   convert (TREE_TYPE (result),
2894 				    ffecom_2 (COMPONENT_REF,
2895 					      ffecom_tree_type[bt][kt],
2896 					      multi_retval,
2897 					      ffecom_multi_fields_[bt][kt])));
2898 	expand_return (result);
2899       }
2900     else if (cmplxfunc)
2901       {
2902 	result
2903 	  = ffecom_1 (INDIRECT_REF,
2904 		      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2905 		      result);
2906 	result = ffecom_modify (NULL_TREE, result, call);
2907 	expand_expr_stmt (result);
2908 	expand_null_return ();
2909       }
2910     else
2911       {
2912 	result = ffecom_modify (NULL_TREE,
2913 				result,
2914 				convert (TREE_TYPE (result),
2915 					 call));
2916 	expand_return (result);
2917       }
2918   }
2919 
2920   ffecom_end_compstmt ();
2921 
2922   finish_function (0);
2923 
2924   lineno = old_lineno;
2925   input_filename = old_input_filename;
2926 
2927   ffecom_doing_entry_ = FALSE;
2928 }
2929 
2930 /* Transform expr into gcc tree with possible destination
2931 
2932    Recursive descent on expr while making corresponding tree nodes and
2933    attaching type info and such.  If destination supplied and compatible
2934    with temporary that would be made in certain cases, temporary isn't
2935    made, destination used instead, and dest_used flag set TRUE.  */
2936 
2937 static tree
ffecom_expr_(ffebld expr,tree dest_tree,ffebld dest,bool * dest_used,bool assignp,bool widenp)2938 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2939 	      bool *dest_used, bool assignp, bool widenp)
2940 {
2941   tree item;
2942   tree list;
2943   tree args;
2944   ffeinfoBasictype bt;
2945   ffeinfoKindtype kt;
2946   tree t;
2947   tree dt;			/* decl_tree for an ffesymbol. */
2948   tree tree_type, tree_type_x;
2949   tree left, right;
2950   ffesymbol s;
2951   enum tree_code code;
2952 
2953   assert (expr != NULL);
2954 
2955   if (dest_used != NULL)
2956     *dest_used = FALSE;
2957 
2958   bt = ffeinfo_basictype (ffebld_info (expr));
2959   kt = ffeinfo_kindtype (ffebld_info (expr));
2960   tree_type = ffecom_tree_type[bt][kt];
2961 
2962   /* Widen integral arithmetic as desired while preserving signedness.  */
2963   tree_type_x = NULL_TREE;
2964   if (widenp && tree_type
2965       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2966       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2967     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2968 
2969   switch (ffebld_op (expr))
2970     {
2971     case FFEBLD_opACCTER:
2972       {
2973 	ffebitCount i;
2974 	ffebit bits = ffebld_accter_bits (expr);
2975 	ffetargetOffset source_offset = 0;
2976 	ffetargetOffset dest_offset = ffebld_accter_pad (expr);
2977 	tree purpose;
2978 
2979 	assert (dest_offset == 0
2980 		|| (bt == FFEINFO_basictypeCHARACTER
2981 		    && kt == FFEINFO_kindtypeCHARACTER1));
2982 
2983 	list = item = NULL;
2984 	for (;;)
2985 	  {
2986 	    ffebldConstantUnion cu;
2987 	    ffebitCount length;
2988 	    bool value;
2989 	    ffebldConstantArray ca = ffebld_accter (expr);
2990 
2991 	    ffebit_test (bits, source_offset, &value, &length);
2992 	    if (length == 0)
2993 	      break;
2994 
2995 	    if (value)
2996 	      {
2997 		for (i = 0; i < length; ++i)
2998 		  {
2999 		    cu = ffebld_constantarray_get (ca, bt, kt,
3000 						   source_offset + i);
3001 
3002 		    t = ffecom_constantunion (&cu, bt, kt, tree_type);
3003 
3004 		    if (i == 0
3005 			&& dest_offset != 0)
3006 		      purpose = build_int_2 (dest_offset, 0);
3007 		    else
3008 		      purpose = NULL_TREE;
3009 
3010 		    if (list == NULL_TREE)
3011 		      list = item = build_tree_list (purpose, t);
3012 		    else
3013 		      {
3014 			TREE_CHAIN (item) = build_tree_list (purpose, t);
3015 			item = TREE_CHAIN (item);
3016 		      }
3017 		  }
3018 	      }
3019 	    source_offset += length;
3020 	    dest_offset += length;
3021 	  }
3022       }
3023 
3024       item = build_int_2 ((ffebld_accter_size (expr)
3025 			   + ffebld_accter_pad (expr)) - 1, 0);
3026       ffebit_kill (ffebld_accter_bits (expr));
3027       TREE_TYPE (item) = ffecom_integer_type_node;
3028       item
3029 	= build_array_type
3030 	  (tree_type,
3031 	   build_range_type (ffecom_integer_type_node,
3032 			     ffecom_integer_zero_node,
3033 			     item));
3034       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3035       TREE_CONSTANT (list) = 1;
3036       TREE_STATIC (list) = 1;
3037       return list;
3038 
3039     case FFEBLD_opARRTER:
3040       {
3041 	ffetargetOffset i;
3042 
3043 	list = NULL_TREE;
3044 	if (ffebld_arrter_pad (expr) == 0)
3045 	  item = NULL_TREE;
3046 	else
3047 	  {
3048 	    assert (bt == FFEINFO_basictypeCHARACTER
3049 		    && kt == FFEINFO_kindtypeCHARACTER1);
3050 
3051 	    /* Becomes PURPOSE first time through loop.  */
3052 	    item = build_int_2 (ffebld_arrter_pad (expr), 0);
3053 	  }
3054 
3055 	for (i = 0; i < ffebld_arrter_size (expr); ++i)
3056 	  {
3057 	    ffebldConstantUnion cu
3058 	    = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3059 
3060 	    t = ffecom_constantunion (&cu, bt, kt, tree_type);
3061 
3062 	    if (list == NULL_TREE)
3063 	      /* Assume item is PURPOSE first time through loop.  */
3064 	      list = item = build_tree_list (item, t);
3065 	    else
3066 	      {
3067 		TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3068 		item = TREE_CHAIN (item);
3069 	      }
3070 	  }
3071       }
3072 
3073       item = build_int_2 ((ffebld_arrter_size (expr)
3074 			  + ffebld_arrter_pad (expr)) - 1, 0);
3075       TREE_TYPE (item) = ffecom_integer_type_node;
3076       item
3077 	= build_array_type
3078 	  (tree_type,
3079 	   build_range_type (ffecom_integer_type_node,
3080 			     ffecom_integer_zero_node,
3081 			     item));
3082       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3083       TREE_CONSTANT (list) = 1;
3084       TREE_STATIC (list) = 1;
3085       return list;
3086 
3087     case FFEBLD_opCONTER:
3088       assert (ffebld_conter_pad (expr) == 0);
3089       item
3090 	= ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3091 				bt, kt, tree_type);
3092       return item;
3093 
3094     case FFEBLD_opSYMTER:
3095       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3096 	  || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3097 	return ffecom_ptr_to_expr (expr);	/* Same as %REF(intrinsic). */
3098       s = ffebld_symter (expr);
3099       t = ffesymbol_hook (s).decl_tree;
3100 
3101       if (assignp)
3102 	{			/* ASSIGN'ed-label expr. */
3103 	  if (ffe_is_ugly_assign ())
3104 	    {
3105 	      /* User explicitly wants ASSIGN'ed variables to be at the same
3106 		 memory address as the variables when used in non-ASSIGN
3107 		 contexts.  That can make old, arcane, non-standard code
3108 		 work, but don't try to do it when a pointer wouldn't fit
3109 		 in the normal variable (take other approach, and warn,
3110 		 instead).  */
3111 
3112 	      if (t == NULL_TREE)
3113 		{
3114 		  s = ffecom_sym_transform_ (s);
3115 		  t = ffesymbol_hook (s).decl_tree;
3116 		  assert (t != NULL_TREE);
3117 		}
3118 
3119 	      if (t == error_mark_node)
3120 		return t;
3121 
3122 	      if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3123 		  >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3124 		{
3125 		  if (ffesymbol_hook (s).addr)
3126 		    t = ffecom_1 (INDIRECT_REF,
3127 				  TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3128 		  return t;
3129 		}
3130 
3131 	      if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3132 		{
3133 		  /* xgettext:no-c-format */
3134 		  ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3135 				    FFEBAD_severityWARNING);
3136 		  ffebad_string (ffesymbol_text (s));
3137 		  ffebad_here (0, ffesymbol_where_line (s),
3138 			       ffesymbol_where_column (s));
3139 		  ffebad_finish ();
3140 		}
3141 	    }
3142 
3143 	  /* Don't use the normal variable's tree for ASSIGN, though mark
3144 	     it as in the system header (housekeeping).  Use an explicit,
3145 	     specially created sibling that is known to be wide enough
3146 	     to hold pointers to labels.  */
3147 
3148 	  if (t != NULL_TREE
3149 	      && TREE_CODE (t) == VAR_DECL)
3150 	    DECL_IN_SYSTEM_HEADER (t) = 1;	/* Don't let -Wunused complain. */
3151 
3152 	  t = ffesymbol_hook (s).assign_tree;
3153 	  if (t == NULL_TREE)
3154 	    {
3155 	      s = ffecom_sym_transform_assign_ (s);
3156 	      t = ffesymbol_hook (s).assign_tree;
3157 	      assert (t != NULL_TREE);
3158 	    }
3159 	}
3160       else
3161 	{
3162 	  if (t == NULL_TREE)
3163 	    {
3164 	      s = ffecom_sym_transform_ (s);
3165 	      t = ffesymbol_hook (s).decl_tree;
3166 	      assert (t != NULL_TREE);
3167 	    }
3168 	  if (ffesymbol_hook (s).addr)
3169 	    t = ffecom_1 (INDIRECT_REF,
3170 			  TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3171 	}
3172       return t;
3173 
3174     case FFEBLD_opARRAYREF:
3175       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3176 
3177     case FFEBLD_opUPLUS:
3178       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3179       return ffecom_1 (NOP_EXPR, tree_type, left);
3180 
3181     case FFEBLD_opPAREN:
3182       /* ~~~Make sure Fortran rules respected here */
3183       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3184       return ffecom_1 (NOP_EXPR, tree_type, left);
3185 
3186     case FFEBLD_opUMINUS:
3187       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3188       if (tree_type_x)
3189 	{
3190 	  tree_type = tree_type_x;
3191 	  left = convert (tree_type, left);
3192 	}
3193       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3194 
3195     case FFEBLD_opADD:
3196       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3197       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3198       if (tree_type_x)
3199 	{
3200 	  tree_type = tree_type_x;
3201 	  left = convert (tree_type, left);
3202 	  right = convert (tree_type, right);
3203 	}
3204       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3205 
3206     case FFEBLD_opSUBTRACT:
3207       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3208       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3209       if (tree_type_x)
3210 	{
3211 	  tree_type = tree_type_x;
3212 	  left = convert (tree_type, left);
3213 	  right = convert (tree_type, right);
3214 	}
3215       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3216 
3217     case FFEBLD_opMULTIPLY:
3218       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3219       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3220       if (tree_type_x)
3221 	{
3222 	  tree_type = tree_type_x;
3223 	  left = convert (tree_type, left);
3224 	  right = convert (tree_type, right);
3225 	}
3226       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3227 
3228     case FFEBLD_opDIVIDE:
3229       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3230       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3231       if (tree_type_x)
3232 	{
3233 	  tree_type = tree_type_x;
3234 	  left = convert (tree_type, left);
3235 	  right = convert (tree_type, right);
3236 	}
3237       return ffecom_tree_divide_ (tree_type, left, right,
3238 			          dest_tree, dest, dest_used,
3239 				  ffebld_nonter_hook (expr));
3240 
3241     case FFEBLD_opPOWER:
3242       {
3243 	ffebld left = ffebld_left (expr);
3244 	ffebld right = ffebld_right (expr);
3245 	ffecomGfrt code;
3246 	ffeinfoKindtype rtkt;
3247 	ffeinfoKindtype ltkt;
3248 	bool ref = TRUE;
3249 
3250 	switch (ffeinfo_basictype (ffebld_info (right)))
3251 	  {
3252 
3253 	  case FFEINFO_basictypeINTEGER:
3254 	    if (1 || optimize)
3255 	      {
3256 		item = ffecom_expr_power_integer_ (expr);
3257 		if (item != NULL_TREE)
3258 		  return item;
3259 	      }
3260 
3261 	    rtkt = FFEINFO_kindtypeINTEGER1;
3262 	    switch (ffeinfo_basictype (ffebld_info (left)))
3263 	      {
3264 	      case FFEINFO_basictypeINTEGER:
3265 		if ((ffeinfo_kindtype (ffebld_info (left))
3266 		    == FFEINFO_kindtypeINTEGER4)
3267 		    || (ffeinfo_kindtype (ffebld_info (right))
3268 			== FFEINFO_kindtypeINTEGER4))
3269 		  {
3270 		    code = FFECOM_gfrtPOW_QQ;
3271 		    ltkt = FFEINFO_kindtypeINTEGER4;
3272 		    rtkt = FFEINFO_kindtypeINTEGER4;
3273 		  }
3274 		else
3275 		  {
3276 		    code = FFECOM_gfrtPOW_II;
3277 		    ltkt = FFEINFO_kindtypeINTEGER1;
3278 		  }
3279 		break;
3280 
3281 	      case FFEINFO_basictypeREAL:
3282 		if (ffeinfo_kindtype (ffebld_info (left))
3283 		    == FFEINFO_kindtypeREAL1)
3284 		  {
3285 		    code = FFECOM_gfrtPOW_RI;
3286 		    ltkt = FFEINFO_kindtypeREAL1;
3287 		  }
3288 		else
3289 		  {
3290 		    code = FFECOM_gfrtPOW_DI;
3291 		    ltkt = FFEINFO_kindtypeREAL2;
3292 		  }
3293 		break;
3294 
3295 	      case FFEINFO_basictypeCOMPLEX:
3296 		if (ffeinfo_kindtype (ffebld_info (left))
3297 		    == FFEINFO_kindtypeREAL1)
3298 		  {
3299 		    code = FFECOM_gfrtPOW_CI;	/* Overlapping result okay. */
3300 		    ltkt = FFEINFO_kindtypeREAL1;
3301 		  }
3302 		else
3303 		  {
3304 		    code = FFECOM_gfrtPOW_ZI;	/* Overlapping result okay. */
3305 		    ltkt = FFEINFO_kindtypeREAL2;
3306 		  }
3307 		break;
3308 
3309 	      default:
3310 		assert ("bad pow_*i" == NULL);
3311 		code = FFECOM_gfrtPOW_CI;	/* Overlapping result okay. */
3312 		ltkt = FFEINFO_kindtypeREAL1;
3313 		break;
3314 	      }
3315 	    if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3316 	      left = ffeexpr_convert (left, NULL, NULL,
3317 				      ffeinfo_basictype (ffebld_info (left)),
3318 				      ltkt, 0,
3319 				      FFETARGET_charactersizeNONE,
3320 				      FFEEXPR_contextLET);
3321 	    if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3322 	      right = ffeexpr_convert (right, NULL, NULL,
3323 				       FFEINFO_basictypeINTEGER,
3324 				       rtkt, 0,
3325 				       FFETARGET_charactersizeNONE,
3326 				       FFEEXPR_contextLET);
3327 	    break;
3328 
3329 	  case FFEINFO_basictypeREAL:
3330 	    if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3331 	      left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3332 				      FFEINFO_kindtypeREALDOUBLE, 0,
3333 				      FFETARGET_charactersizeNONE,
3334 				      FFEEXPR_contextLET);
3335 	    if (ffeinfo_kindtype (ffebld_info (right))
3336 		== FFEINFO_kindtypeREAL1)
3337 	      right = ffeexpr_convert (right, NULL, NULL,
3338 				       FFEINFO_basictypeREAL,
3339 				       FFEINFO_kindtypeREALDOUBLE, 0,
3340 				       FFETARGET_charactersizeNONE,
3341 				       FFEEXPR_contextLET);
3342 	    /* We used to call FFECOM_gfrtPOW_DD here,
3343 	       which passes arguments by reference.  */
3344 	    code = FFECOM_gfrtL_POW;
3345 	    /* Pass arguments by value. */
3346 	    ref  = FALSE;
3347 	    break;
3348 
3349 	  case FFEINFO_basictypeCOMPLEX:
3350 	    if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3351 	      left = ffeexpr_convert (left, NULL, NULL,
3352 				      FFEINFO_basictypeCOMPLEX,
3353 				      FFEINFO_kindtypeREALDOUBLE, 0,
3354 				      FFETARGET_charactersizeNONE,
3355 				      FFEEXPR_contextLET);
3356 	    if (ffeinfo_kindtype (ffebld_info (right))
3357 		== FFEINFO_kindtypeREAL1)
3358 	      right = ffeexpr_convert (right, NULL, NULL,
3359 				       FFEINFO_basictypeCOMPLEX,
3360 				       FFEINFO_kindtypeREALDOUBLE, 0,
3361 				       FFETARGET_charactersizeNONE,
3362 				       FFEEXPR_contextLET);
3363 	    code = FFECOM_gfrtPOW_ZZ;	/* Overlapping result okay. */
3364 	    ref = TRUE;			/* Pass arguments by reference. */
3365 	    break;
3366 
3367 	  default:
3368 	    assert ("bad pow_x*" == NULL);
3369 	    code = FFECOM_gfrtPOW_II;
3370 	    break;
3371 	  }
3372 	return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3373 				   ffecom_gfrt_kindtype (code),
3374 				   (ffe_is_f2c_library ()
3375 				    && ffecom_gfrt_complex_[code]),
3376 				   tree_type, left, right,
3377 				   dest_tree, dest, dest_used,
3378 				   NULL_TREE, FALSE, ref,
3379 				   ffebld_nonter_hook (expr));
3380       }
3381 
3382     case FFEBLD_opNOT:
3383       switch (bt)
3384 	{
3385 	case FFEINFO_basictypeLOGICAL:
3386 	  item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3387 	  return convert (tree_type, item);
3388 
3389 	case FFEINFO_basictypeINTEGER:
3390 	  return ffecom_1 (BIT_NOT_EXPR, tree_type,
3391 			   ffecom_expr (ffebld_left (expr)));
3392 
3393 	default:
3394 	  assert ("NOT bad basictype" == NULL);
3395 	  /* Fall through. */
3396 	case FFEINFO_basictypeANY:
3397 	  return error_mark_node;
3398 	}
3399       break;
3400 
3401     case FFEBLD_opFUNCREF:
3402       assert (ffeinfo_basictype (ffebld_info (expr))
3403 	      != FFEINFO_basictypeCHARACTER);
3404       /* Fall through.	 */
3405     case FFEBLD_opSUBRREF:
3406       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3407 	  == FFEINFO_whereINTRINSIC)
3408 	{			/* Invocation of an intrinsic. */
3409 	  item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3410 					 dest_used);
3411 	  return item;
3412 	}
3413       s = ffebld_symter (ffebld_left (expr));
3414       dt = ffesymbol_hook (s).decl_tree;
3415       if (dt == NULL_TREE)
3416 	{
3417 	  s = ffecom_sym_transform_ (s);
3418 	  dt = ffesymbol_hook (s).decl_tree;
3419 	}
3420       if (dt == error_mark_node)
3421 	return dt;
3422 
3423       if (ffesymbol_hook (s).addr)
3424 	item = dt;
3425       else
3426 	item = ffecom_1_fn (dt);
3427 
3428       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3429 	args = ffecom_list_expr (ffebld_right (expr));
3430       else
3431 	args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3432 
3433       if (args == error_mark_node)
3434 	return error_mark_node;
3435 
3436       item = ffecom_call_ (item, kt,
3437 			   ffesymbol_is_f2c (s)
3438 			   && (bt == FFEINFO_basictypeCOMPLEX)
3439 			   && (ffesymbol_where (s)
3440 			       != FFEINFO_whereCONSTANT),
3441 			   tree_type,
3442 			   args,
3443 			   dest_tree, dest, dest_used,
3444 			   error_mark_node, FALSE,
3445 			   ffebld_nonter_hook (expr));
3446       TREE_SIDE_EFFECTS (item) = 1;
3447       return item;
3448 
3449     case FFEBLD_opAND:
3450       switch (bt)
3451 	{
3452 	case FFEINFO_basictypeLOGICAL:
3453 	  item
3454 	    = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3455 		       ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3456 		     ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3457 	  return convert (tree_type, item);
3458 
3459 	case FFEINFO_basictypeINTEGER:
3460 	  return ffecom_2 (BIT_AND_EXPR, tree_type,
3461 			   ffecom_expr (ffebld_left (expr)),
3462 			   ffecom_expr (ffebld_right (expr)));
3463 
3464 	default:
3465 	  assert ("AND bad basictype" == NULL);
3466 	  /* Fall through. */
3467 	case FFEINFO_basictypeANY:
3468 	  return error_mark_node;
3469 	}
3470       break;
3471 
3472     case FFEBLD_opOR:
3473       switch (bt)
3474 	{
3475 	case FFEINFO_basictypeLOGICAL:
3476 	  item
3477 	    = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3478 		       ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3479 		     ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3480 	  return convert (tree_type, item);
3481 
3482 	case FFEINFO_basictypeINTEGER:
3483 	  return ffecom_2 (BIT_IOR_EXPR, tree_type,
3484 			   ffecom_expr (ffebld_left (expr)),
3485 			   ffecom_expr (ffebld_right (expr)));
3486 
3487 	default:
3488 	  assert ("OR bad basictype" == NULL);
3489 	  /* Fall through. */
3490 	case FFEINFO_basictypeANY:
3491 	  return error_mark_node;
3492 	}
3493       break;
3494 
3495     case FFEBLD_opXOR:
3496     case FFEBLD_opNEQV:
3497       switch (bt)
3498 	{
3499 	case FFEINFO_basictypeLOGICAL:
3500 	  item
3501 	    = ffecom_2 (NE_EXPR, integer_type_node,
3502 			ffecom_expr (ffebld_left (expr)),
3503 			ffecom_expr (ffebld_right (expr)));
3504 	  return convert (tree_type, ffecom_truth_value (item));
3505 
3506 	case FFEINFO_basictypeINTEGER:
3507 	  return ffecom_2 (BIT_XOR_EXPR, tree_type,
3508 			   ffecom_expr (ffebld_left (expr)),
3509 			   ffecom_expr (ffebld_right (expr)));
3510 
3511 	default:
3512 	  assert ("XOR/NEQV bad basictype" == NULL);
3513 	  /* Fall through. */
3514 	case FFEINFO_basictypeANY:
3515 	  return error_mark_node;
3516 	}
3517       break;
3518 
3519     case FFEBLD_opEQV:
3520       switch (bt)
3521 	{
3522 	case FFEINFO_basictypeLOGICAL:
3523 	  item
3524 	    = ffecom_2 (EQ_EXPR, integer_type_node,
3525 			ffecom_expr (ffebld_left (expr)),
3526 			ffecom_expr (ffebld_right (expr)));
3527 	  return convert (tree_type, ffecom_truth_value (item));
3528 
3529 	case FFEINFO_basictypeINTEGER:
3530 	  return
3531 	    ffecom_1 (BIT_NOT_EXPR, tree_type,
3532 		      ffecom_2 (BIT_XOR_EXPR, tree_type,
3533 				ffecom_expr (ffebld_left (expr)),
3534 				ffecom_expr (ffebld_right (expr))));
3535 
3536 	default:
3537 	  assert ("EQV bad basictype" == NULL);
3538 	  /* Fall through. */
3539 	case FFEINFO_basictypeANY:
3540 	  return error_mark_node;
3541 	}
3542       break;
3543 
3544     case FFEBLD_opCONVERT:
3545       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3546 	return error_mark_node;
3547 
3548       switch (bt)
3549 	{
3550 	case FFEINFO_basictypeLOGICAL:
3551 	case FFEINFO_basictypeINTEGER:
3552 	case FFEINFO_basictypeREAL:
3553 	  return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3554 
3555 	case FFEINFO_basictypeCOMPLEX:
3556 	  switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3557 	    {
3558 	    case FFEINFO_basictypeINTEGER:
3559 	    case FFEINFO_basictypeLOGICAL:
3560 	    case FFEINFO_basictypeREAL:
3561 	      item = ffecom_expr (ffebld_left (expr));
3562 	      if (item == error_mark_node)
3563 		return error_mark_node;
3564 	      /* convert() takes care of converting to the subtype first,
3565 		 at least in gcc-2.7.2. */
3566 	      item = convert (tree_type, item);
3567 	      return item;
3568 
3569 	    case FFEINFO_basictypeCOMPLEX:
3570 	      return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3571 
3572 	    default:
3573 	      assert ("CONVERT COMPLEX bad basictype" == NULL);
3574 	      /* Fall through. */
3575 	    case FFEINFO_basictypeANY:
3576 	      return error_mark_node;
3577 	    }
3578 	  break;
3579 
3580 	default:
3581 	  assert ("CONVERT bad basictype" == NULL);
3582 	  /* Fall through. */
3583 	case FFEINFO_basictypeANY:
3584 	  return error_mark_node;
3585 	}
3586       break;
3587 
3588     case FFEBLD_opLT:
3589       code = LT_EXPR;
3590       goto relational;		/* :::::::::::::::::::: */
3591 
3592     case FFEBLD_opLE:
3593       code = LE_EXPR;
3594       goto relational;		/* :::::::::::::::::::: */
3595 
3596     case FFEBLD_opEQ:
3597       code = EQ_EXPR;
3598       goto relational;		/* :::::::::::::::::::: */
3599 
3600     case FFEBLD_opNE:
3601       code = NE_EXPR;
3602       goto relational;		/* :::::::::::::::::::: */
3603 
3604     case FFEBLD_opGT:
3605       code = GT_EXPR;
3606       goto relational;		/* :::::::::::::::::::: */
3607 
3608     case FFEBLD_opGE:
3609       code = GE_EXPR;
3610 
3611     relational:		/* :::::::::::::::::::: */
3612       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3613 	{
3614 	case FFEINFO_basictypeLOGICAL:
3615 	case FFEINFO_basictypeINTEGER:
3616 	case FFEINFO_basictypeREAL:
3617 	  item = ffecom_2 (code, integer_type_node,
3618 			   ffecom_expr (ffebld_left (expr)),
3619 			   ffecom_expr (ffebld_right (expr)));
3620 	  return convert (tree_type, item);
3621 
3622 	case FFEINFO_basictypeCOMPLEX:
3623 	  assert (code == EQ_EXPR || code == NE_EXPR);
3624 	  {
3625 	    tree real_type;
3626 	    tree arg1 = ffecom_expr (ffebld_left (expr));
3627 	    tree arg2 = ffecom_expr (ffebld_right (expr));
3628 
3629 	    if (arg1 == error_mark_node || arg2 == error_mark_node)
3630 	      return error_mark_node;
3631 
3632 	    arg1 = ffecom_save_tree (arg1);
3633 	    arg2 = ffecom_save_tree (arg2);
3634 
3635 	    if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3636 	      {
3637 		real_type = TREE_TYPE (TREE_TYPE (arg1));
3638 		assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3639 	      }
3640 	    else
3641 	      {
3642 		real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3643 		assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3644 	      }
3645 
3646 	    item
3647 	      = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3648 			  ffecom_2 (EQ_EXPR, integer_type_node,
3649 				  ffecom_1 (REALPART_EXPR, real_type, arg1),
3650 				 ffecom_1 (REALPART_EXPR, real_type, arg2)),
3651 			  ffecom_2 (EQ_EXPR, integer_type_node,
3652 				  ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3653 				    ffecom_1 (IMAGPART_EXPR, real_type,
3654 					      arg2)));
3655 	    if (code == EQ_EXPR)
3656 	      item = ffecom_truth_value (item);
3657 	    else
3658 	      item = ffecom_truth_value_invert (item);
3659 	    return convert (tree_type, item);
3660 	  }
3661 
3662 	case FFEINFO_basictypeCHARACTER:
3663 	  {
3664 	    ffebld left = ffebld_left (expr);
3665 	    ffebld right = ffebld_right (expr);
3666 	    tree left_tree;
3667 	    tree right_tree;
3668 	    tree left_length;
3669 	    tree right_length;
3670 
3671 	    /* f2c run-time functions do the implicit blank-padding for us,
3672 	       so we don't usually have to implement blank-padding ourselves.
3673 	       (The exception is when we pass an argument to a separately
3674 	       compiled statement function -- if we know the arg is not the
3675 	       same length as the dummy, we must truncate or extend it.	 If
3676 	       we "inline" statement functions, that necessity goes away as
3677 	       well.)
3678 
3679 	       Strip off the CONVERT operators that blank-pad.  (Truncation by
3680 	       CONVERT shouldn't happen here, but it can happen in
3681 	       assignments.) */
3682 
3683 	    while (ffebld_op (left) == FFEBLD_opCONVERT)
3684 	      left = ffebld_left (left);
3685 	    while (ffebld_op (right) == FFEBLD_opCONVERT)
3686 	      right = ffebld_left (right);
3687 
3688 	    left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3689 	    right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3690 
3691 	    if (left_tree == error_mark_node || left_length == error_mark_node
3692 		|| right_tree == error_mark_node
3693 		|| right_length == error_mark_node)
3694 	      return error_mark_node;
3695 
3696 	    if ((ffebld_size_known (left) == 1)
3697 		&& (ffebld_size_known (right) == 1))
3698 	      {
3699 		left_tree
3700 		  = ffecom_1 (INDIRECT_REF,
3701 		      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3702 			      left_tree);
3703 		right_tree
3704 		  = ffecom_1 (INDIRECT_REF,
3705 		     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3706 			      right_tree);
3707 
3708 		item
3709 		  = ffecom_2 (code, integer_type_node,
3710 			      ffecom_2 (ARRAY_REF,
3711 		      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3712 					left_tree,
3713 					integer_one_node),
3714 			      ffecom_2 (ARRAY_REF,
3715 		     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3716 					right_tree,
3717 					integer_one_node));
3718 	      }
3719 	    else
3720 	      {
3721 		item = build_tree_list (NULL_TREE, left_tree);
3722 		TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3723 		TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3724 							       left_length);
3725 		TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3726 		  = build_tree_list (NULL_TREE, right_length);
3727 		item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3728 		item = ffecom_2 (code, integer_type_node,
3729 				 item,
3730 				 convert (TREE_TYPE (item),
3731 					  integer_zero_node));
3732 	      }
3733 	    item = convert (tree_type, item);
3734 	  }
3735 
3736 	  return item;
3737 
3738 	default:
3739 	  assert ("relational bad basictype" == NULL);
3740 	  /* Fall through. */
3741 	case FFEINFO_basictypeANY:
3742 	  return error_mark_node;
3743 	}
3744       break;
3745 
3746     case FFEBLD_opPERCENT_LOC:
3747       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3748       return convert (tree_type, item);
3749 
3750     case FFEBLD_opPERCENT_VAL:
3751       item = ffecom_arg_expr (ffebld_left (expr), &list);
3752       return convert (tree_type, item);
3753 
3754     case FFEBLD_opITEM:
3755     case FFEBLD_opSTAR:
3756     case FFEBLD_opBOUNDS:
3757     case FFEBLD_opREPEAT:
3758     case FFEBLD_opLABTER:
3759     case FFEBLD_opLABTOK:
3760     case FFEBLD_opIMPDO:
3761     case FFEBLD_opCONCATENATE:
3762     case FFEBLD_opSUBSTR:
3763     default:
3764       assert ("bad op" == NULL);
3765       /* Fall through. */
3766     case FFEBLD_opANY:
3767       return error_mark_node;
3768     }
3769 
3770 #if 1
3771   assert ("didn't think anything got here anymore!!" == NULL);
3772 #else
3773   switch (ffebld_arity (expr))
3774     {
3775     case 2:
3776       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3777       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3778       if (TREE_OPERAND (item, 0) == error_mark_node
3779 	  || TREE_OPERAND (item, 1) == error_mark_node)
3780 	return error_mark_node;
3781       break;
3782 
3783     case 1:
3784       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3785       if (TREE_OPERAND (item, 0) == error_mark_node)
3786 	return error_mark_node;
3787       break;
3788 
3789     default:
3790       break;
3791     }
3792 
3793   return fold (item);
3794 #endif
3795 }
3796 
3797 /* Returns the tree that does the intrinsic invocation.
3798 
3799    Note: this function applies only to intrinsics returning
3800    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3801    subroutines.  */
3802 
3803 static tree
ffecom_expr_intrinsic_(ffebld expr,tree dest_tree,ffebld dest,bool * dest_used)3804 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3805 			ffebld dest, bool *dest_used)
3806 {
3807   tree expr_tree;
3808   tree saved_expr1;		/* For those who need it. */
3809   tree saved_expr2;		/* For those who need it. */
3810   ffeinfoBasictype bt;
3811   ffeinfoKindtype kt;
3812   tree tree_type;
3813   tree arg1_type;
3814   tree real_type;		/* REAL type corresponding to COMPLEX. */
3815   tree tempvar;
3816   ffebld list = ffebld_right (expr);	/* List of (some) args. */
3817   ffebld arg1;			/* For handy reference. */
3818   ffebld arg2;
3819   ffebld arg3;
3820   ffeintrinImp codegen_imp;
3821   ffecomGfrt gfrt;
3822 
3823   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3824 
3825   if (dest_used != NULL)
3826     *dest_used = FALSE;
3827 
3828   bt = ffeinfo_basictype (ffebld_info (expr));
3829   kt = ffeinfo_kindtype (ffebld_info (expr));
3830   tree_type = ffecom_tree_type[bt][kt];
3831 
3832   if (list != NULL)
3833     {
3834       arg1 = ffebld_head (list);
3835       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3836 	return error_mark_node;
3837       if ((list = ffebld_trail (list)) != NULL)
3838 	{
3839 	  arg2 = ffebld_head (list);
3840 	  if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3841 	    return error_mark_node;
3842 	  if ((list = ffebld_trail (list)) != NULL)
3843 	    {
3844 	      arg3 = ffebld_head (list);
3845 	      if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3846 		return error_mark_node;
3847 	    }
3848 	  else
3849 	    arg3 = NULL;
3850 	}
3851       else
3852 	arg2 = arg3 = NULL;
3853     }
3854   else
3855     arg1 = arg2 = arg3 = NULL;
3856 
3857   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3858      args.  This is used by the MAX/MIN expansions. */
3859 
3860   if (arg1 != NULL)
3861     arg1_type = ffecom_tree_type
3862       [ffeinfo_basictype (ffebld_info (arg1))]
3863       [ffeinfo_kindtype (ffebld_info (arg1))];
3864   else
3865     arg1_type = NULL_TREE;	/* Really not needed, but might catch bugs
3866 				   here. */
3867 
3868   /* There are several ways for each of the cases in the following switch
3869      statements to exit (from simplest to use to most complicated):
3870 
3871      break;  (when expr_tree == NULL)
3872 
3873      A standard call is made to the specific intrinsic just as if it had been
3874      passed in as a dummy procedure and called as any old procedure.  This
3875      method can produce slower code but in some cases it's the easiest way for
3876      now.  However, if a (presumably faster) direct call is available,
3877      that is used, so this is the easiest way in many more cases now.
3878 
3879      gfrt = FFECOM_gfrtWHATEVER;
3880      break;
3881 
3882      gfrt contains the gfrt index of a library function to call, passing the
3883      argument(s) by value rather than by reference.  Used when a more
3884      careful choice of library function is needed than that provided
3885      by the vanilla `break;'.
3886 
3887      return expr_tree;
3888 
3889      The expr_tree has been completely set up and is ready to be returned
3890      as is.  No further actions are taken.  Use this when the tree is not
3891      in the simple form for one of the arity_n labels.	 */
3892 
3893   /* For info on how the switch statement cases were written, see the files
3894      enclosed in comments below the switch statement. */
3895 
3896   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3897   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3898   if (gfrt == FFECOM_gfrt)
3899     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3900 
3901   switch (codegen_imp)
3902     {
3903     case FFEINTRIN_impABS:
3904     case FFEINTRIN_impCABS:
3905     case FFEINTRIN_impCDABS:
3906     case FFEINTRIN_impDABS:
3907     case FFEINTRIN_impIABS:
3908       if (ffeinfo_basictype (ffebld_info (arg1))
3909 	  == FFEINFO_basictypeCOMPLEX)
3910 	{
3911 	  if (kt == FFEINFO_kindtypeREAL1)
3912 	    gfrt = FFECOM_gfrtCABS;
3913 	  else if (kt == FFEINFO_kindtypeREAL2)
3914 	    gfrt = FFECOM_gfrtCDABS;
3915 	  break;
3916 	}
3917       return ffecom_1 (ABS_EXPR, tree_type,
3918 		       convert (tree_type, ffecom_expr (arg1)));
3919 
3920     case FFEINTRIN_impACOS:
3921     case FFEINTRIN_impDACOS:
3922       break;
3923 
3924     case FFEINTRIN_impAIMAG:
3925     case FFEINTRIN_impDIMAG:
3926     case FFEINTRIN_impIMAGPART:
3927       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3928 	arg1_type = TREE_TYPE (arg1_type);
3929       else
3930 	arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3931 
3932       return
3933 	convert (tree_type,
3934 		 ffecom_1 (IMAGPART_EXPR, arg1_type,
3935 			   ffecom_expr (arg1)));
3936 
3937     case FFEINTRIN_impAINT:
3938     case FFEINTRIN_impDINT:
3939 #if 0
3940       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
3941       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3942 #else /* in the meantime, must use floor to avoid range problems with ints */
3943       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3944       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3945       return
3946 	convert (tree_type,
3947 		 ffecom_3 (COND_EXPR, double_type_node,
3948 			   ffecom_truth_value
3949 			   (ffecom_2 (GE_EXPR, integer_type_node,
3950 				      saved_expr1,
3951 				      convert (arg1_type,
3952 					       ffecom_float_zero_))),
3953 			   ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3954 					     build_tree_list (NULL_TREE,
3955 						  convert (double_type_node,
3956 							   saved_expr1)),
3957 					     NULL_TREE),
3958 			   ffecom_1 (NEGATE_EXPR, double_type_node,
3959 				     ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3960 						 build_tree_list (NULL_TREE,
3961 						  convert (double_type_node,
3962 						      ffecom_1 (NEGATE_EXPR,
3963 								arg1_type,
3964 							       saved_expr1))),
3965 						       NULL_TREE)
3966 				     ))
3967 		 );
3968 #endif
3969 
3970     case FFEINTRIN_impANINT:
3971     case FFEINTRIN_impDNINT:
3972 #if 0				/* This way of doing it won't handle real
3973 				   numbers of large magnitudes. */
3974       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3975       expr_tree = convert (tree_type,
3976 			   convert (integer_type_node,
3977 				    ffecom_3 (COND_EXPR, tree_type,
3978 					      ffecom_truth_value
3979 					      (ffecom_2 (GE_EXPR,
3980 							 integer_type_node,
3981 							 saved_expr1,
3982 						       ffecom_float_zero_)),
3983 					      ffecom_2 (PLUS_EXPR,
3984 							tree_type,
3985 							saved_expr1,
3986 							ffecom_float_half_),
3987 					      ffecom_2 (MINUS_EXPR,
3988 							tree_type,
3989 							saved_expr1,
3990 						     ffecom_float_half_))));
3991       return expr_tree;
3992 #else /* So we instead call floor. */
3993       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3994       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3995       return
3996 	convert (tree_type,
3997 		 ffecom_3 (COND_EXPR, double_type_node,
3998 			   ffecom_truth_value
3999 			   (ffecom_2 (GE_EXPR, integer_type_node,
4000 				      saved_expr1,
4001 				      convert (arg1_type,
4002 					       ffecom_float_zero_))),
4003 			   ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4004 					     build_tree_list (NULL_TREE,
4005 						  convert (double_type_node,
4006 							   ffecom_2 (PLUS_EXPR,
4007 								     arg1_type,
4008 								     saved_expr1,
4009 								     convert (arg1_type,
4010 									      ffecom_float_half_)))),
4011 					     NULL_TREE),
4012 			   ffecom_1 (NEGATE_EXPR, double_type_node,
4013 				     ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4014 						       build_tree_list (NULL_TREE,
4015 									convert (double_type_node,
4016 										 ffecom_2 (MINUS_EXPR,
4017 											   arg1_type,
4018 											   convert (arg1_type,
4019 												    ffecom_float_half_),
4020 											   saved_expr1))),
4021 						       NULL_TREE))
4022 			   )
4023 		 );
4024 #endif
4025 
4026     case FFEINTRIN_impASIN:
4027     case FFEINTRIN_impDASIN:
4028     case FFEINTRIN_impATAN:
4029     case FFEINTRIN_impDATAN:
4030     case FFEINTRIN_impATAN2:
4031     case FFEINTRIN_impDATAN2:
4032       break;
4033 
4034     case FFEINTRIN_impCHAR:
4035     case FFEINTRIN_impACHAR:
4036       tempvar = ffebld_nonter_hook (expr);
4037       assert (tempvar);
4038       {
4039 	tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4040 
4041 	expr_tree = ffecom_modify (tmv,
4042 				   ffecom_2 (ARRAY_REF, tmv, tempvar,
4043 					     integer_one_node),
4044 				   convert (tmv, ffecom_expr (arg1)));
4045       }
4046       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4047 			    expr_tree,
4048 			    tempvar);
4049       expr_tree = ffecom_1 (ADDR_EXPR,
4050 			    build_pointer_type (TREE_TYPE (expr_tree)),
4051 			    expr_tree);
4052       return expr_tree;
4053 
4054     case FFEINTRIN_impCMPLX:
4055     case FFEINTRIN_impDCMPLX:
4056       if (arg2 == NULL)
4057 	return
4058 	  convert (tree_type, ffecom_expr (arg1));
4059 
4060       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4061       return
4062 	ffecom_2 (COMPLEX_EXPR, tree_type,
4063 		  convert (real_type, ffecom_expr (arg1)),
4064 		  convert (real_type,
4065 			   ffecom_expr (arg2)));
4066 
4067     case FFEINTRIN_impCOMPLEX:
4068       return
4069 	ffecom_2 (COMPLEX_EXPR, tree_type,
4070 		  ffecom_expr (arg1),
4071 		  ffecom_expr (arg2));
4072 
4073     case FFEINTRIN_impCONJG:
4074     case FFEINTRIN_impDCONJG:
4075       {
4076 	tree arg1_tree;
4077 
4078 	real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4079 	arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4080 	return
4081 	  ffecom_2 (COMPLEX_EXPR, tree_type,
4082 		    ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4083 		    ffecom_1 (NEGATE_EXPR, real_type,
4084 			      ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4085       }
4086 
4087     case FFEINTRIN_impCOS:
4088     case FFEINTRIN_impCCOS:
4089     case FFEINTRIN_impCDCOS:
4090     case FFEINTRIN_impDCOS:
4091       if (bt == FFEINFO_basictypeCOMPLEX)
4092 	{
4093 	  if (kt == FFEINFO_kindtypeREAL1)
4094 	    gfrt = FFECOM_gfrtCCOS;	/* Overlapping result okay. */
4095 	  else if (kt == FFEINFO_kindtypeREAL2)
4096 	    gfrt = FFECOM_gfrtCDCOS;	/* Overlapping result okay. */
4097 	}
4098       break;
4099 
4100     case FFEINTRIN_impCOSH:
4101     case FFEINTRIN_impDCOSH:
4102       break;
4103 
4104     case FFEINTRIN_impDBLE:
4105     case FFEINTRIN_impDFLOAT:
4106     case FFEINTRIN_impDREAL:
4107     case FFEINTRIN_impFLOAT:
4108     case FFEINTRIN_impIDINT:
4109     case FFEINTRIN_impIFIX:
4110     case FFEINTRIN_impINT2:
4111     case FFEINTRIN_impINT8:
4112     case FFEINTRIN_impINT:
4113     case FFEINTRIN_impLONG:
4114     case FFEINTRIN_impREAL:
4115     case FFEINTRIN_impSHORT:
4116     case FFEINTRIN_impSNGL:
4117       return convert (tree_type, ffecom_expr (arg1));
4118 
4119     case FFEINTRIN_impDIM:
4120     case FFEINTRIN_impDDIM:
4121     case FFEINTRIN_impIDIM:
4122       saved_expr1 = ffecom_save_tree (convert (tree_type,
4123 					       ffecom_expr (arg1)));
4124       saved_expr2 = ffecom_save_tree (convert (tree_type,
4125 					       ffecom_expr (arg2)));
4126       return
4127 	ffecom_3 (COND_EXPR, tree_type,
4128 		  ffecom_truth_value
4129 		  (ffecom_2 (GT_EXPR, integer_type_node,
4130 			     saved_expr1,
4131 			     saved_expr2)),
4132 		  ffecom_2 (MINUS_EXPR, tree_type,
4133 			    saved_expr1,
4134 			    saved_expr2),
4135 		  convert (tree_type, ffecom_float_zero_));
4136 
4137     case FFEINTRIN_impDPROD:
4138       return
4139 	ffecom_2 (MULT_EXPR, tree_type,
4140 		  convert (tree_type, ffecom_expr (arg1)),
4141 		  convert (tree_type, ffecom_expr (arg2)));
4142 
4143     case FFEINTRIN_impEXP:
4144     case FFEINTRIN_impCDEXP:
4145     case FFEINTRIN_impCEXP:
4146     case FFEINTRIN_impDEXP:
4147       if (bt == FFEINFO_basictypeCOMPLEX)
4148 	{
4149 	  if (kt == FFEINFO_kindtypeREAL1)
4150 	    gfrt = FFECOM_gfrtCEXP;	/* Overlapping result okay. */
4151 	  else if (kt == FFEINFO_kindtypeREAL2)
4152 	    gfrt = FFECOM_gfrtCDEXP;	/* Overlapping result okay. */
4153 	}
4154       break;
4155 
4156     case FFEINTRIN_impICHAR:
4157     case FFEINTRIN_impIACHAR:
4158 #if 0				/* The simple approach. */
4159       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4160       expr_tree
4161 	= ffecom_1 (INDIRECT_REF,
4162 		    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4163 		    expr_tree);
4164       expr_tree
4165 	= ffecom_2 (ARRAY_REF,
4166 		    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4167 		    expr_tree,
4168 		    integer_one_node);
4169       return convert (tree_type, expr_tree);
4170 #else /* The more interesting (and more optimal) approach. */
4171       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4172       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4173 			    saved_expr1,
4174 			    expr_tree,
4175 			    convert (tree_type, integer_zero_node));
4176       return expr_tree;
4177 #endif
4178 
4179     case FFEINTRIN_impINDEX:
4180       break;
4181 
4182     case FFEINTRIN_impLEN:
4183 #if 0
4184       break;					/* The simple approach. */
4185 #else
4186       return ffecom_intrinsic_len_ (arg1);	/* The more optimal approach. */
4187 #endif
4188 
4189     case FFEINTRIN_impLGE:
4190     case FFEINTRIN_impLGT:
4191     case FFEINTRIN_impLLE:
4192     case FFEINTRIN_impLLT:
4193       break;
4194 
4195     case FFEINTRIN_impLOG:
4196     case FFEINTRIN_impALOG:
4197     case FFEINTRIN_impCDLOG:
4198     case FFEINTRIN_impCLOG:
4199     case FFEINTRIN_impDLOG:
4200       if (bt == FFEINFO_basictypeCOMPLEX)
4201 	{
4202 	  if (kt == FFEINFO_kindtypeREAL1)
4203 	    gfrt = FFECOM_gfrtCLOG;	/* Overlapping result okay. */
4204 	  else if (kt == FFEINFO_kindtypeREAL2)
4205 	    gfrt = FFECOM_gfrtCDLOG;	/* Overlapping result okay. */
4206 	}
4207       break;
4208 
4209     case FFEINTRIN_impLOG10:
4210     case FFEINTRIN_impALOG10:
4211     case FFEINTRIN_impDLOG10:
4212       if (gfrt != FFECOM_gfrt)
4213 	break;	/* Already picked one, stick with it. */
4214 
4215       if (kt == FFEINFO_kindtypeREAL1)
4216 	/* We used to call FFECOM_gfrtALOG10 here.  */
4217 	gfrt = FFECOM_gfrtL_LOG10;
4218       else if (kt == FFEINFO_kindtypeREAL2)
4219 	/* We used to call FFECOM_gfrtDLOG10 here.  */
4220 	gfrt = FFECOM_gfrtL_LOG10;
4221       break;
4222 
4223     case FFEINTRIN_impMAX:
4224     case FFEINTRIN_impAMAX0:
4225     case FFEINTRIN_impAMAX1:
4226     case FFEINTRIN_impDMAX1:
4227     case FFEINTRIN_impMAX0:
4228     case FFEINTRIN_impMAX1:
4229       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4230 	arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4231       else
4232 	arg1_type = tree_type;
4233       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4234 			    convert (arg1_type, ffecom_expr (arg1)),
4235 			    convert (arg1_type, ffecom_expr (arg2)));
4236       for (; list != NULL; list = ffebld_trail (list))
4237 	{
4238 	  if ((ffebld_head (list) == NULL)
4239 	      || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4240 	    continue;
4241 	  expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4242 				expr_tree,
4243 				convert (arg1_type,
4244 					 ffecom_expr (ffebld_head (list))));
4245 	}
4246       return convert (tree_type, expr_tree);
4247 
4248     case FFEINTRIN_impMIN:
4249     case FFEINTRIN_impAMIN0:
4250     case FFEINTRIN_impAMIN1:
4251     case FFEINTRIN_impDMIN1:
4252     case FFEINTRIN_impMIN0:
4253     case FFEINTRIN_impMIN1:
4254       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4255 	arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4256       else
4257 	arg1_type = tree_type;
4258       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4259 			    convert (arg1_type, ffecom_expr (arg1)),
4260 			    convert (arg1_type, ffecom_expr (arg2)));
4261       for (; list != NULL; list = ffebld_trail (list))
4262 	{
4263 	  if ((ffebld_head (list) == NULL)
4264 	      || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4265 	    continue;
4266 	  expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4267 				expr_tree,
4268 				convert (arg1_type,
4269 					 ffecom_expr (ffebld_head (list))));
4270 	}
4271       return convert (tree_type, expr_tree);
4272 
4273     case FFEINTRIN_impMOD:
4274     case FFEINTRIN_impAMOD:
4275     case FFEINTRIN_impDMOD:
4276       if (bt != FFEINFO_basictypeREAL)
4277 	return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4278 			 convert (tree_type, ffecom_expr (arg1)),
4279 			 convert (tree_type, ffecom_expr (arg2)));
4280 
4281       if (kt == FFEINFO_kindtypeREAL1)
4282 	/* We used to call FFECOM_gfrtAMOD here.  */
4283 	gfrt = FFECOM_gfrtL_FMOD;
4284       else if (kt == FFEINFO_kindtypeREAL2)
4285 	/* We used to call FFECOM_gfrtDMOD here.  */
4286 	gfrt = FFECOM_gfrtL_FMOD;
4287       break;
4288 
4289     case FFEINTRIN_impNINT:
4290     case FFEINTRIN_impIDNINT:
4291 #if 0
4292       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4293       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4294 #else
4295       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4296       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4297       return
4298 	convert (ffecom_integer_type_node,
4299 		 ffecom_3 (COND_EXPR, arg1_type,
4300 			   ffecom_truth_value
4301 			   (ffecom_2 (GE_EXPR, integer_type_node,
4302 				      saved_expr1,
4303 				      convert (arg1_type,
4304 					       ffecom_float_zero_))),
4305 			   ffecom_2 (PLUS_EXPR, arg1_type,
4306 				     saved_expr1,
4307 				     convert (arg1_type,
4308 					      ffecom_float_half_)),
4309 			   ffecom_2 (MINUS_EXPR, arg1_type,
4310 				     saved_expr1,
4311 				     convert (arg1_type,
4312 					      ffecom_float_half_))));
4313 #endif
4314 
4315     case FFEINTRIN_impSIGN:
4316     case FFEINTRIN_impDSIGN:
4317     case FFEINTRIN_impISIGN:
4318       {
4319 	tree arg2_tree = ffecom_expr (arg2);
4320 
4321 	saved_expr1
4322 	  = ffecom_save_tree
4323 	  (ffecom_1 (ABS_EXPR, tree_type,
4324 		     convert (tree_type,
4325 			      ffecom_expr (arg1))));
4326 	expr_tree
4327 	  = ffecom_3 (COND_EXPR, tree_type,
4328 		      ffecom_truth_value
4329 		      (ffecom_2 (GE_EXPR, integer_type_node,
4330 				 arg2_tree,
4331 				 convert (TREE_TYPE (arg2_tree),
4332 					  integer_zero_node))),
4333 		      saved_expr1,
4334 		      ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4335 	/* Make sure SAVE_EXPRs get referenced early enough. */
4336 	expr_tree
4337 	  = ffecom_2 (COMPOUND_EXPR, tree_type,
4338 		      convert (void_type_node, saved_expr1),
4339 		      expr_tree);
4340       }
4341       return expr_tree;
4342 
4343     case FFEINTRIN_impSIN:
4344     case FFEINTRIN_impCDSIN:
4345     case FFEINTRIN_impCSIN:
4346     case FFEINTRIN_impDSIN:
4347       if (bt == FFEINFO_basictypeCOMPLEX)
4348 	{
4349 	  if (kt == FFEINFO_kindtypeREAL1)
4350 	    gfrt = FFECOM_gfrtCSIN;	/* Overlapping result okay. */
4351 	  else if (kt == FFEINFO_kindtypeREAL2)
4352 	    gfrt = FFECOM_gfrtCDSIN;	/* Overlapping result okay. */
4353 	}
4354       break;
4355 
4356     case FFEINTRIN_impSINH:
4357     case FFEINTRIN_impDSINH:
4358       break;
4359 
4360     case FFEINTRIN_impSQRT:
4361     case FFEINTRIN_impCDSQRT:
4362     case FFEINTRIN_impCSQRT:
4363     case FFEINTRIN_impDSQRT:
4364       if (bt == FFEINFO_basictypeCOMPLEX)
4365 	{
4366 	  if (kt == FFEINFO_kindtypeREAL1)
4367 	    gfrt = FFECOM_gfrtCSQRT;	/* Overlapping result okay. */
4368 	  else if (kt == FFEINFO_kindtypeREAL2)
4369 	    gfrt = FFECOM_gfrtCDSQRT;	/* Overlapping result okay. */
4370 	}
4371       break;
4372 
4373     case FFEINTRIN_impTAN:
4374     case FFEINTRIN_impDTAN:
4375     case FFEINTRIN_impTANH:
4376     case FFEINTRIN_impDTANH:
4377       break;
4378 
4379     case FFEINTRIN_impREALPART:
4380       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4381 	arg1_type = TREE_TYPE (arg1_type);
4382       else
4383 	arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4384 
4385       return
4386 	convert (tree_type,
4387 		 ffecom_1 (REALPART_EXPR, arg1_type,
4388 			   ffecom_expr (arg1)));
4389 
4390     case FFEINTRIN_impIAND:
4391     case FFEINTRIN_impAND:
4392       return ffecom_2 (BIT_AND_EXPR, tree_type,
4393 		       convert (tree_type,
4394 				ffecom_expr (arg1)),
4395 		       convert (tree_type,
4396 				ffecom_expr (arg2)));
4397 
4398     case FFEINTRIN_impIOR:
4399     case FFEINTRIN_impOR:
4400       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4401 		       convert (tree_type,
4402 				ffecom_expr (arg1)),
4403 		       convert (tree_type,
4404 				ffecom_expr (arg2)));
4405 
4406     case FFEINTRIN_impIEOR:
4407     case FFEINTRIN_impXOR:
4408       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4409 		       convert (tree_type,
4410 				ffecom_expr (arg1)),
4411 		       convert (tree_type,
4412 				ffecom_expr (arg2)));
4413 
4414     case FFEINTRIN_impLSHIFT:
4415       return ffecom_2 (LSHIFT_EXPR, tree_type,
4416 		       ffecom_expr (arg1),
4417 		       convert (integer_type_node,
4418 				ffecom_expr (arg2)));
4419 
4420     case FFEINTRIN_impRSHIFT:
4421       return ffecom_2 (RSHIFT_EXPR, tree_type,
4422 		       ffecom_expr (arg1),
4423 		       convert (integer_type_node,
4424 				ffecom_expr (arg2)));
4425 
4426     case FFEINTRIN_impNOT:
4427       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4428 
4429     case FFEINTRIN_impBIT_SIZE:
4430       return convert (tree_type, TYPE_SIZE (arg1_type));
4431 
4432     case FFEINTRIN_impBTEST:
4433       {
4434 	ffetargetLogical1 target_true;
4435 	ffetargetLogical1 target_false;
4436 	tree true_tree;
4437 	tree false_tree;
4438 
4439 	ffetarget_logical1 (&target_true, TRUE);
4440 	ffetarget_logical1 (&target_false, FALSE);
4441 	if (target_true == 1)
4442 	  true_tree = convert (tree_type, integer_one_node);
4443 	else
4444 	  true_tree = convert (tree_type, build_int_2 (target_true, 0));
4445 	if (target_false == 0)
4446 	  false_tree = convert (tree_type, integer_zero_node);
4447 	else
4448 	  false_tree = convert (tree_type, build_int_2 (target_false, 0));
4449 
4450 	return
4451 	  ffecom_3 (COND_EXPR, tree_type,
4452 		    ffecom_truth_value
4453 		    (ffecom_2 (EQ_EXPR, integer_type_node,
4454 			       ffecom_2 (BIT_AND_EXPR, arg1_type,
4455 					 ffecom_expr (arg1),
4456 					 ffecom_2 (LSHIFT_EXPR, arg1_type,
4457 						   convert (arg1_type,
4458 							  integer_one_node),
4459 						   convert (integer_type_node,
4460 							    ffecom_expr (arg2)))),
4461 			       convert (arg1_type,
4462 					integer_zero_node))),
4463 		    false_tree,
4464 		    true_tree);
4465       }
4466 
4467     case FFEINTRIN_impIBCLR:
4468       return
4469 	ffecom_2 (BIT_AND_EXPR, tree_type,
4470 		  ffecom_expr (arg1),
4471 		  ffecom_1 (BIT_NOT_EXPR, tree_type,
4472 			    ffecom_2 (LSHIFT_EXPR, tree_type,
4473 				      convert (tree_type,
4474 					       integer_one_node),
4475 				      convert (integer_type_node,
4476 					       ffecom_expr (arg2)))));
4477 
4478     case FFEINTRIN_impIBITS:
4479       {
4480 	tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4481 						    ffecom_expr (arg3)));
4482 	tree uns_type
4483 	= ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4484 
4485 	expr_tree
4486 	  = ffecom_2 (BIT_AND_EXPR, tree_type,
4487 		      ffecom_2 (RSHIFT_EXPR, tree_type,
4488 				ffecom_expr (arg1),
4489 				convert (integer_type_node,
4490 					 ffecom_expr (arg2))),
4491 		      convert (tree_type,
4492 			       ffecom_2 (RSHIFT_EXPR, uns_type,
4493 					 ffecom_1 (BIT_NOT_EXPR,
4494 						   uns_type,
4495 						   convert (uns_type,
4496 							integer_zero_node)),
4497 					 ffecom_2 (MINUS_EXPR,
4498 						   integer_type_node,
4499 						   TYPE_SIZE (uns_type),
4500 						   arg3_tree))));
4501 	/* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4502 	expr_tree
4503 	  = ffecom_3 (COND_EXPR, tree_type,
4504 		      ffecom_truth_value
4505 		      (ffecom_2 (NE_EXPR, integer_type_node,
4506 				 arg3_tree,
4507 				 integer_zero_node)),
4508 		      expr_tree,
4509 		      convert (tree_type, integer_zero_node));
4510       }
4511       return expr_tree;
4512 
4513     case FFEINTRIN_impIBSET:
4514       return
4515 	ffecom_2 (BIT_IOR_EXPR, tree_type,
4516 		  ffecom_expr (arg1),
4517 		  ffecom_2 (LSHIFT_EXPR, tree_type,
4518 			    convert (tree_type, integer_one_node),
4519 			    convert (integer_type_node,
4520 				     ffecom_expr (arg2))));
4521 
4522     case FFEINTRIN_impISHFT:
4523       {
4524 	tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4525 	tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4526 						    ffecom_expr (arg2)));
4527 	tree uns_type
4528 	= ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4529 
4530 	expr_tree
4531 	  = ffecom_3 (COND_EXPR, tree_type,
4532 		      ffecom_truth_value
4533 		      (ffecom_2 (GE_EXPR, integer_type_node,
4534 				 arg2_tree,
4535 				 integer_zero_node)),
4536 		      ffecom_2 (LSHIFT_EXPR, tree_type,
4537 				arg1_tree,
4538 				arg2_tree),
4539 		      convert (tree_type,
4540 			       ffecom_2 (RSHIFT_EXPR, uns_type,
4541 					 convert (uns_type, arg1_tree),
4542 					 ffecom_1 (NEGATE_EXPR,
4543 						   integer_type_node,
4544 						   arg2_tree))));
4545 	/* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds.  */
4546 	expr_tree
4547 	  = ffecom_3 (COND_EXPR, tree_type,
4548 		      ffecom_truth_value
4549 		      (ffecom_2 (NE_EXPR, integer_type_node,
4550 				 ffecom_1 (ABS_EXPR,
4551 					   integer_type_node,
4552 					   arg2_tree),
4553 				 TYPE_SIZE (uns_type))),
4554 		      expr_tree,
4555 		      convert (tree_type, integer_zero_node));
4556 	/* Make sure SAVE_EXPRs get referenced early enough. */
4557 	expr_tree
4558 	  = ffecom_2 (COMPOUND_EXPR, tree_type,
4559 		      convert (void_type_node, arg1_tree),
4560 		      ffecom_2 (COMPOUND_EXPR, tree_type,
4561 				convert (void_type_node, arg2_tree),
4562 				expr_tree));
4563       }
4564       return expr_tree;
4565 
4566     case FFEINTRIN_impISHFTC:
4567       {
4568 	tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4569 	tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4570 						    ffecom_expr (arg2)));
4571 	tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4572 	: ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4573 	tree shift_neg;
4574 	tree shift_pos;
4575 	tree mask_arg1;
4576 	tree masked_arg1;
4577 	tree uns_type
4578 	= ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4579 
4580 	mask_arg1
4581 	  = ffecom_2 (LSHIFT_EXPR, tree_type,
4582 		      ffecom_1 (BIT_NOT_EXPR, tree_type,
4583 				convert (tree_type, integer_zero_node)),
4584 		      arg3_tree);
4585 	/* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4586 	mask_arg1
4587 	  = ffecom_3 (COND_EXPR, tree_type,
4588 		      ffecom_truth_value
4589 		      (ffecom_2 (NE_EXPR, integer_type_node,
4590 				 arg3_tree,
4591 				 TYPE_SIZE (uns_type))),
4592 		      mask_arg1,
4593 		      convert (tree_type, integer_zero_node));
4594 	mask_arg1 = ffecom_save_tree (mask_arg1);
4595 	masked_arg1
4596 	  = ffecom_2 (BIT_AND_EXPR, tree_type,
4597 		      arg1_tree,
4598 		      ffecom_1 (BIT_NOT_EXPR, tree_type,
4599 				mask_arg1));
4600 	masked_arg1 = ffecom_save_tree (masked_arg1);
4601 	shift_neg
4602 	  = ffecom_2 (BIT_IOR_EXPR, tree_type,
4603 		      convert (tree_type,
4604 			       ffecom_2 (RSHIFT_EXPR, uns_type,
4605 					 convert (uns_type, masked_arg1),
4606 					 ffecom_1 (NEGATE_EXPR,
4607 						   integer_type_node,
4608 						   arg2_tree))),
4609 		      ffecom_2 (LSHIFT_EXPR, tree_type,
4610 				arg1_tree,
4611 				ffecom_2 (PLUS_EXPR, integer_type_node,
4612 					  arg2_tree,
4613 					  arg3_tree)));
4614 	shift_pos
4615 	  = ffecom_2 (BIT_IOR_EXPR, tree_type,
4616 		      ffecom_2 (LSHIFT_EXPR, tree_type,
4617 				arg1_tree,
4618 				arg2_tree),
4619 		      convert (tree_type,
4620 			       ffecom_2 (RSHIFT_EXPR, uns_type,
4621 					 convert (uns_type, masked_arg1),
4622 					 ffecom_2 (MINUS_EXPR,
4623 						   integer_type_node,
4624 						   arg3_tree,
4625 						   arg2_tree))));
4626 	expr_tree
4627 	  = ffecom_3 (COND_EXPR, tree_type,
4628 		      ffecom_truth_value
4629 		      (ffecom_2 (LT_EXPR, integer_type_node,
4630 				 arg2_tree,
4631 				 integer_zero_node)),
4632 		      shift_neg,
4633 		      shift_pos);
4634 	expr_tree
4635 	  = ffecom_2 (BIT_IOR_EXPR, tree_type,
4636 		      ffecom_2 (BIT_AND_EXPR, tree_type,
4637 				mask_arg1,
4638 				arg1_tree),
4639 		      ffecom_2 (BIT_AND_EXPR, tree_type,
4640 				ffecom_1 (BIT_NOT_EXPR, tree_type,
4641 					  mask_arg1),
4642 				expr_tree));
4643 	expr_tree
4644 	  = ffecom_3 (COND_EXPR, tree_type,
4645 		      ffecom_truth_value
4646 		      (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4647 				 ffecom_2 (EQ_EXPR, integer_type_node,
4648 					   ffecom_1 (ABS_EXPR,
4649 						     integer_type_node,
4650 						     arg2_tree),
4651 					   arg3_tree),
4652 				 ffecom_2 (EQ_EXPR, integer_type_node,
4653 					   arg2_tree,
4654 					   integer_zero_node))),
4655 		      arg1_tree,
4656 		      expr_tree);
4657 	/* Make sure SAVE_EXPRs get referenced early enough. */
4658 	expr_tree
4659 	  = ffecom_2 (COMPOUND_EXPR, tree_type,
4660 		      convert (void_type_node, arg1_tree),
4661 		      ffecom_2 (COMPOUND_EXPR, tree_type,
4662 				convert (void_type_node, arg2_tree),
4663 				ffecom_2 (COMPOUND_EXPR, tree_type,
4664 					  convert (void_type_node,
4665 						   mask_arg1),
4666 					  ffecom_2 (COMPOUND_EXPR, tree_type,
4667 						    convert (void_type_node,
4668 							     masked_arg1),
4669 						    expr_tree))));
4670 	expr_tree
4671 	  = ffecom_2 (COMPOUND_EXPR, tree_type,
4672 		      convert (void_type_node,
4673 			       arg3_tree),
4674 		      expr_tree);
4675       }
4676       return expr_tree;
4677 
4678     case FFEINTRIN_impLOC:
4679       {
4680 	tree arg1_tree = ffecom_expr (arg1);
4681 
4682 	expr_tree
4683 	  = convert (tree_type,
4684 		     ffecom_1 (ADDR_EXPR,
4685 			       build_pointer_type (TREE_TYPE (arg1_tree)),
4686 			       arg1_tree));
4687       }
4688       return expr_tree;
4689 
4690     case FFEINTRIN_impMVBITS:
4691       {
4692 	tree arg1_tree;
4693 	tree arg2_tree;
4694 	tree arg3_tree;
4695 	ffebld arg4 = ffebld_head (ffebld_trail (list));
4696 	tree arg4_tree;
4697 	tree arg4_type;
4698 	ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4699 	tree arg5_tree;
4700 	tree prep_arg1;
4701 	tree prep_arg4;
4702 	tree arg5_plus_arg3;
4703 
4704 	arg2_tree = convert (integer_type_node,
4705 			     ffecom_expr (arg2));
4706 	arg3_tree = ffecom_save_tree (convert (integer_type_node,
4707 					       ffecom_expr (arg3)));
4708 	arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4709 	arg4_type = TREE_TYPE (arg4_tree);
4710 
4711 	arg1_tree = ffecom_save_tree (convert (arg4_type,
4712 					       ffecom_expr (arg1)));
4713 
4714 	arg5_tree = ffecom_save_tree (convert (integer_type_node,
4715 					       ffecom_expr (arg5)));
4716 
4717 	prep_arg1
4718 	  = ffecom_2 (LSHIFT_EXPR, arg4_type,
4719 		      ffecom_2 (BIT_AND_EXPR, arg4_type,
4720 				ffecom_2 (RSHIFT_EXPR, arg4_type,
4721 					  arg1_tree,
4722 					  arg2_tree),
4723 				ffecom_1 (BIT_NOT_EXPR, arg4_type,
4724 					  ffecom_2 (LSHIFT_EXPR, arg4_type,
4725 						    ffecom_1 (BIT_NOT_EXPR,
4726 							      arg4_type,
4727 							      convert
4728 							      (arg4_type,
4729 							integer_zero_node)),
4730 						    arg3_tree))),
4731 		      arg5_tree);
4732 	arg5_plus_arg3
4733 	  = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4734 					arg5_tree,
4735 					arg3_tree));
4736 	prep_arg4
4737 	  = ffecom_2 (LSHIFT_EXPR, arg4_type,
4738 		      ffecom_1 (BIT_NOT_EXPR, arg4_type,
4739 				convert (arg4_type,
4740 					 integer_zero_node)),
4741 		      arg5_plus_arg3);
4742 	/* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE.  */
4743 	prep_arg4
4744 	  = ffecom_3 (COND_EXPR, arg4_type,
4745 		      ffecom_truth_value
4746 		      (ffecom_2 (NE_EXPR, integer_type_node,
4747 				 arg5_plus_arg3,
4748 				 convert (TREE_TYPE (arg5_plus_arg3),
4749 					  TYPE_SIZE (arg4_type)))),
4750 		      prep_arg4,
4751 		      convert (arg4_type, integer_zero_node));
4752 	prep_arg4
4753 	  = ffecom_2 (BIT_AND_EXPR, arg4_type,
4754 		      arg4_tree,
4755 		      ffecom_2 (BIT_IOR_EXPR, arg4_type,
4756 				prep_arg4,
4757 				ffecom_1 (BIT_NOT_EXPR, arg4_type,
4758 					  ffecom_2 (LSHIFT_EXPR, arg4_type,
4759 						    ffecom_1 (BIT_NOT_EXPR,
4760 							      arg4_type,
4761 							      convert
4762 							      (arg4_type,
4763 							integer_zero_node)),
4764 						    arg5_tree))));
4765 	prep_arg1
4766 	  = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4767 		      prep_arg1,
4768 		      prep_arg4);
4769 	/* Fix up (twice), because LSHIFT_EXPR above
4770 	   can't shift over TYPE_SIZE.  */
4771 	prep_arg1
4772 	  = ffecom_3 (COND_EXPR, arg4_type,
4773 		      ffecom_truth_value
4774 		      (ffecom_2 (NE_EXPR, integer_type_node,
4775 				 arg3_tree,
4776 				 convert (TREE_TYPE (arg3_tree),
4777 					  integer_zero_node))),
4778 		      prep_arg1,
4779 		      arg4_tree);
4780 	prep_arg1
4781 	  = ffecom_3 (COND_EXPR, arg4_type,
4782 		      ffecom_truth_value
4783 		      (ffecom_2 (NE_EXPR, integer_type_node,
4784 				 arg3_tree,
4785 				 convert (TREE_TYPE (arg3_tree),
4786 					  TYPE_SIZE (arg4_type)))),
4787 		      prep_arg1,
4788 		      arg1_tree);
4789 	expr_tree
4790 	  = ffecom_2s (MODIFY_EXPR, void_type_node,
4791 		       arg4_tree,
4792 		       prep_arg1);
4793 	/* Make sure SAVE_EXPRs get referenced early enough. */
4794 	expr_tree
4795 	  = ffecom_2 (COMPOUND_EXPR, void_type_node,
4796 		      arg1_tree,
4797 		      ffecom_2 (COMPOUND_EXPR, void_type_node,
4798 				arg3_tree,
4799 				ffecom_2 (COMPOUND_EXPR, void_type_node,
4800 					  arg5_tree,
4801 					  ffecom_2 (COMPOUND_EXPR, void_type_node,
4802 						    arg5_plus_arg3,
4803 						    expr_tree))));
4804 	expr_tree
4805 	  = ffecom_2 (COMPOUND_EXPR, void_type_node,
4806 		      arg4_tree,
4807 		      expr_tree);
4808 
4809       }
4810       return expr_tree;
4811 
4812     case FFEINTRIN_impDERF:
4813     case FFEINTRIN_impERF:
4814     case FFEINTRIN_impDERFC:
4815     case FFEINTRIN_impERFC:
4816       break;
4817 
4818     case FFEINTRIN_impIARGC:
4819       /* extern int xargc; i__1 = xargc - 1; */
4820       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4821 			    ffecom_tree_xargc_,
4822 			    convert (TREE_TYPE (ffecom_tree_xargc_),
4823 				     integer_one_node));
4824       return expr_tree;
4825 
4826     case FFEINTRIN_impSIGNAL_func:
4827     case FFEINTRIN_impSIGNAL_subr:
4828       {
4829 	tree arg1_tree;
4830 	tree arg2_tree;
4831 	tree arg3_tree;
4832 
4833 	arg1_tree = convert (ffecom_f2c_integer_type_node,
4834 			     ffecom_expr (arg1));
4835 	arg1_tree = ffecom_1 (ADDR_EXPR,
4836 			      build_pointer_type (TREE_TYPE (arg1_tree)),
4837 			      arg1_tree);
4838 
4839 	/* Pass procedure as a pointer to it, anything else by value.  */
4840 	if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4841 	  arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4842 	else
4843 	  arg2_tree = ffecom_ptr_to_expr (arg2);
4844 	arg2_tree = convert (TREE_TYPE (null_pointer_node),
4845 			     arg2_tree);
4846 
4847 	if (arg3 != NULL)
4848 	  arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4849 	else
4850 	  arg3_tree = NULL_TREE;
4851 
4852 	arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4853 	arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4854 	TREE_CHAIN (arg1_tree) = arg2_tree;
4855 
4856 	expr_tree
4857 	  = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4858 			  ffecom_gfrt_kindtype (gfrt),
4859 			  FALSE,
4860 			  ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4861 			   NULL_TREE :
4862 			   tree_type),
4863 			  arg1_tree,
4864 			  NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4865 			  ffebld_nonter_hook (expr));
4866 
4867 	if (arg3_tree != NULL_TREE)
4868 	  expr_tree
4869 	    = ffecom_modify (NULL_TREE, arg3_tree,
4870 			     convert (TREE_TYPE (arg3_tree),
4871 				      expr_tree));
4872       }
4873       return expr_tree;
4874 
4875     case FFEINTRIN_impALARM:
4876       {
4877 	tree arg1_tree;
4878 	tree arg2_tree;
4879 	tree arg3_tree;
4880 
4881 	arg1_tree = convert (ffecom_f2c_integer_type_node,
4882 			     ffecom_expr (arg1));
4883 	arg1_tree = ffecom_1 (ADDR_EXPR,
4884 			      build_pointer_type (TREE_TYPE (arg1_tree)),
4885 			      arg1_tree);
4886 
4887 	/* Pass procedure as a pointer to it, anything else by value.  */
4888 	if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4889 	  arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4890 	else
4891 	  arg2_tree = ffecom_ptr_to_expr (arg2);
4892 	arg2_tree = convert (TREE_TYPE (null_pointer_node),
4893 			     arg2_tree);
4894 
4895 	if (arg3 != NULL)
4896 	  arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4897 	else
4898 	  arg3_tree = NULL_TREE;
4899 
4900 	arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4901 	arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4902 	TREE_CHAIN (arg1_tree) = arg2_tree;
4903 
4904 	expr_tree
4905 	  = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4906 			  ffecom_gfrt_kindtype (gfrt),
4907 			  FALSE,
4908 			  NULL_TREE,
4909 			  arg1_tree,
4910 			  NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4911 			  ffebld_nonter_hook (expr));
4912 
4913 	if (arg3_tree != NULL_TREE)
4914 	  expr_tree
4915 	    = ffecom_modify (NULL_TREE, arg3_tree,
4916 			     convert (TREE_TYPE (arg3_tree),
4917 				      expr_tree));
4918       }
4919       return expr_tree;
4920 
4921     case FFEINTRIN_impCHDIR_subr:
4922     case FFEINTRIN_impFDATE_subr:
4923     case FFEINTRIN_impFGET_subr:
4924     case FFEINTRIN_impFPUT_subr:
4925     case FFEINTRIN_impGETCWD_subr:
4926     case FFEINTRIN_impHOSTNM_subr:
4927     case FFEINTRIN_impSYSTEM_subr:
4928     case FFEINTRIN_impUNLINK_subr:
4929       {
4930 	tree arg1_len = integer_zero_node;
4931 	tree arg1_tree;
4932 	tree arg2_tree;
4933 
4934 	arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4935 
4936 	if (arg2 != NULL)
4937 	  arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4938 	else
4939 	  arg2_tree = NULL_TREE;
4940 
4941 	arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4942 	arg1_len = build_tree_list (NULL_TREE, arg1_len);
4943 	TREE_CHAIN (arg1_tree) = arg1_len;
4944 
4945 	expr_tree
4946 	  = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4947 			  ffecom_gfrt_kindtype (gfrt),
4948 			  FALSE,
4949 			  NULL_TREE,
4950 			  arg1_tree,
4951 			  NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4952 			  ffebld_nonter_hook (expr));
4953 
4954 	if (arg2_tree != NULL_TREE)
4955 	  expr_tree
4956 	    = ffecom_modify (NULL_TREE, arg2_tree,
4957 			     convert (TREE_TYPE (arg2_tree),
4958 				      expr_tree));
4959       }
4960       return expr_tree;
4961 
4962     case FFEINTRIN_impEXIT:
4963       if (arg1 != NULL)
4964 	break;
4965 
4966       expr_tree = build_tree_list (NULL_TREE,
4967 				   ffecom_1 (ADDR_EXPR,
4968 					     build_pointer_type
4969 					     (ffecom_integer_type_node),
4970 					     integer_zero_node));
4971 
4972       return
4973 	ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4974 		      ffecom_gfrt_kindtype (gfrt),
4975 		      FALSE,
4976 		      void_type_node,
4977 		      expr_tree,
4978 		      NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4979 		      ffebld_nonter_hook (expr));
4980 
4981     case FFEINTRIN_impFLUSH:
4982       if (arg1 == NULL)
4983 	gfrt = FFECOM_gfrtFLUSH;
4984       else
4985 	gfrt = FFECOM_gfrtFLUSH1;
4986       break;
4987 
4988     case FFEINTRIN_impCHMOD_subr:
4989     case FFEINTRIN_impLINK_subr:
4990     case FFEINTRIN_impRENAME_subr:
4991     case FFEINTRIN_impSYMLNK_subr:
4992       {
4993 	tree arg1_len = integer_zero_node;
4994 	tree arg1_tree;
4995 	tree arg2_len = integer_zero_node;
4996 	tree arg2_tree;
4997 	tree arg3_tree;
4998 
4999 	arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5000 	arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5001 	if (arg3 != NULL)
5002 	  arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5003 	else
5004 	  arg3_tree = NULL_TREE;
5005 
5006 	arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5007 	arg1_len = build_tree_list (NULL_TREE, arg1_len);
5008 	arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5009 	arg2_len = build_tree_list (NULL_TREE, arg2_len);
5010 	TREE_CHAIN (arg1_tree) = arg2_tree;
5011 	TREE_CHAIN (arg2_tree) = arg1_len;
5012 	TREE_CHAIN (arg1_len) = arg2_len;
5013 	expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5014 				  ffecom_gfrt_kindtype (gfrt),
5015 				  FALSE,
5016 				  NULL_TREE,
5017 				  arg1_tree,
5018 				  NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5019 				  ffebld_nonter_hook (expr));
5020 	if (arg3_tree != NULL_TREE)
5021 	  expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5022 				     convert (TREE_TYPE (arg3_tree),
5023 					      expr_tree));
5024       }
5025       return expr_tree;
5026 
5027     case FFEINTRIN_impLSTAT_subr:
5028     case FFEINTRIN_impSTAT_subr:
5029       {
5030 	tree arg1_len = integer_zero_node;
5031 	tree arg1_tree;
5032 	tree arg2_tree;
5033 	tree arg3_tree;
5034 
5035 	arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5036 
5037 	arg2_tree = ffecom_ptr_to_expr (arg2);
5038 
5039 	if (arg3 != NULL)
5040 	  arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5041 	else
5042 	  arg3_tree = NULL_TREE;
5043 
5044 	arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5045 	arg1_len = build_tree_list (NULL_TREE, arg1_len);
5046 	arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5047 	TREE_CHAIN (arg1_tree) = arg2_tree;
5048 	TREE_CHAIN (arg2_tree) = arg1_len;
5049 	expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5050 				  ffecom_gfrt_kindtype (gfrt),
5051 				  FALSE,
5052 				  NULL_TREE,
5053 				  arg1_tree,
5054 				  NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5055 				  ffebld_nonter_hook (expr));
5056 	if (arg3_tree != NULL_TREE)
5057 	  expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5058 				     convert (TREE_TYPE (arg3_tree),
5059 					      expr_tree));
5060       }
5061       return expr_tree;
5062 
5063     case FFEINTRIN_impFGETC_subr:
5064     case FFEINTRIN_impFPUTC_subr:
5065       {
5066 	tree arg1_tree;
5067 	tree arg2_tree;
5068 	tree arg2_len = integer_zero_node;
5069 	tree arg3_tree;
5070 
5071 	arg1_tree = convert (ffecom_f2c_integer_type_node,
5072 			     ffecom_expr (arg1));
5073 	arg1_tree = ffecom_1 (ADDR_EXPR,
5074 			      build_pointer_type (TREE_TYPE (arg1_tree)),
5075 			      arg1_tree);
5076 
5077 	arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5078 	if (arg3 != NULL)
5079 	  arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5080 	else
5081 	  arg3_tree = NULL_TREE;
5082 
5083 	arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5084 	arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5085 	arg2_len = build_tree_list (NULL_TREE, arg2_len);
5086 	TREE_CHAIN (arg1_tree) = arg2_tree;
5087 	TREE_CHAIN (arg2_tree) = arg2_len;
5088 
5089 	expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5090 				  ffecom_gfrt_kindtype (gfrt),
5091 				  FALSE,
5092 				  NULL_TREE,
5093 				  arg1_tree,
5094 				  NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5095 				  ffebld_nonter_hook (expr));
5096 	if (arg3_tree != NULL_TREE)
5097 	  expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5098 				     convert (TREE_TYPE (arg3_tree),
5099 					      expr_tree));
5100       }
5101       return expr_tree;
5102 
5103     case FFEINTRIN_impFSTAT_subr:
5104       {
5105 	tree arg1_tree;
5106 	tree arg2_tree;
5107 	tree arg3_tree;
5108 
5109 	arg1_tree = convert (ffecom_f2c_integer_type_node,
5110 			     ffecom_expr (arg1));
5111 	arg1_tree = ffecom_1 (ADDR_EXPR,
5112 			      build_pointer_type (TREE_TYPE (arg1_tree)),
5113 			      arg1_tree);
5114 
5115 	arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5116 			     ffecom_ptr_to_expr (arg2));
5117 
5118 	if (arg3 == NULL)
5119 	  arg3_tree = NULL_TREE;
5120 	else
5121 	  arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5122 
5123 	arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5124 	arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5125 	TREE_CHAIN (arg1_tree) = arg2_tree;
5126 	expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5127 				  ffecom_gfrt_kindtype (gfrt),
5128 				  FALSE,
5129 				  NULL_TREE,
5130 				  arg1_tree,
5131 				  NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5132 				  ffebld_nonter_hook (expr));
5133 	if (arg3_tree != NULL_TREE) {
5134 	  expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5135 				     convert (TREE_TYPE (arg3_tree),
5136 					      expr_tree));
5137 	}
5138       }
5139       return expr_tree;
5140 
5141     case FFEINTRIN_impKILL_subr:
5142       {
5143 	tree arg1_tree;
5144 	tree arg2_tree;
5145 	tree arg3_tree;
5146 
5147 	arg1_tree = convert (ffecom_f2c_integer_type_node,
5148 			     ffecom_expr (arg1));
5149 	arg1_tree = ffecom_1 (ADDR_EXPR,
5150 			      build_pointer_type (TREE_TYPE (arg1_tree)),
5151 			      arg1_tree);
5152 
5153 	arg2_tree = convert (ffecom_f2c_integer_type_node,
5154 			     ffecom_expr (arg2));
5155 	arg2_tree = ffecom_1 (ADDR_EXPR,
5156 			      build_pointer_type (TREE_TYPE (arg2_tree)),
5157 			      arg2_tree);
5158 
5159 	if (arg3 == NULL)
5160 	  arg3_tree = NULL_TREE;
5161 	else
5162 	  arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5163 
5164 	arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5165 	arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5166 	TREE_CHAIN (arg1_tree) = arg2_tree;
5167 	expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5168 				  ffecom_gfrt_kindtype (gfrt),
5169 				  FALSE,
5170 				  NULL_TREE,
5171 				  arg1_tree,
5172 				  NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5173 				  ffebld_nonter_hook (expr));
5174 	if (arg3_tree != NULL_TREE) {
5175 	  expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5176 				     convert (TREE_TYPE (arg3_tree),
5177 					      expr_tree));
5178 	}
5179       }
5180       return expr_tree;
5181 
5182     case FFEINTRIN_impCTIME_subr:
5183     case FFEINTRIN_impTTYNAM_subr:
5184       {
5185 	tree arg1_len = integer_zero_node;
5186 	tree arg1_tree;
5187 	tree arg2_tree;
5188 
5189 	arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5190 
5191 	arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5192 			      ffecom_f2c_longint_type_node :
5193 			      ffecom_f2c_integer_type_node),
5194 			     ffecom_expr (arg1));
5195 	arg2_tree = ffecom_1 (ADDR_EXPR,
5196 			      build_pointer_type (TREE_TYPE (arg2_tree)),
5197 			      arg2_tree);
5198 
5199 	arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5200 	arg1_len = build_tree_list (NULL_TREE, arg1_len);
5201 	arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5202 	TREE_CHAIN (arg1_len) = arg2_tree;
5203 	TREE_CHAIN (arg1_tree) = arg1_len;
5204 
5205 	expr_tree
5206 	  = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5207 			  ffecom_gfrt_kindtype (gfrt),
5208 			  FALSE,
5209 			  NULL_TREE,
5210 			  arg1_tree,
5211 			  NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5212 			  ffebld_nonter_hook (expr));
5213 	TREE_SIDE_EFFECTS (expr_tree) = 1;
5214       }
5215       return expr_tree;
5216 
5217     case FFEINTRIN_impIRAND:
5218     case FFEINTRIN_impRAND:
5219       /* Arg defaults to 0 (normal random case) */
5220       {
5221 	tree arg1_tree;
5222 
5223 	if (arg1 == NULL)
5224 	  arg1_tree = ffecom_integer_zero_node;
5225 	else
5226 	  arg1_tree = ffecom_expr (arg1);
5227 	arg1_tree = convert (ffecom_f2c_integer_type_node,
5228 			     arg1_tree);
5229 	arg1_tree = ffecom_1 (ADDR_EXPR,
5230 			      build_pointer_type (TREE_TYPE (arg1_tree)),
5231 			      arg1_tree);
5232 	arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5233 
5234 	expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5235 				  ffecom_gfrt_kindtype (gfrt),
5236 				  FALSE,
5237 				  ((codegen_imp == FFEINTRIN_impIRAND) ?
5238 				   ffecom_f2c_integer_type_node :
5239 				   ffecom_f2c_real_type_node),
5240 				  arg1_tree,
5241 				  dest_tree, dest, dest_used,
5242 				  NULL_TREE, TRUE,
5243 				  ffebld_nonter_hook (expr));
5244       }
5245       return expr_tree;
5246 
5247     case FFEINTRIN_impFTELL_subr:
5248     case FFEINTRIN_impUMASK_subr:
5249       {
5250 	tree arg1_tree;
5251 	tree arg2_tree;
5252 
5253 	arg1_tree = convert (ffecom_f2c_integer_type_node,
5254 			     ffecom_expr (arg1));
5255 	arg1_tree = ffecom_1 (ADDR_EXPR,
5256 			      build_pointer_type (TREE_TYPE (arg1_tree)),
5257 			      arg1_tree);
5258 
5259 	if (arg2 == NULL)
5260 	  arg2_tree = NULL_TREE;
5261 	else
5262 	  arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5263 
5264 	expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5265 				  ffecom_gfrt_kindtype (gfrt),
5266 				  FALSE,
5267 				  NULL_TREE,
5268 				  build_tree_list (NULL_TREE, arg1_tree),
5269 				  NULL_TREE, NULL, NULL, NULL_TREE,
5270 				  TRUE,
5271 				  ffebld_nonter_hook (expr));
5272 	if (arg2_tree != NULL_TREE) {
5273 	  expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5274 				     convert (TREE_TYPE (arg2_tree),
5275 					      expr_tree));
5276 	}
5277       }
5278       return expr_tree;
5279 
5280     case FFEINTRIN_impCPU_TIME:
5281     case FFEINTRIN_impSECOND_subr:
5282       {
5283 	tree arg1_tree;
5284 
5285 	arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5286 
5287 	expr_tree
5288 	  = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5289 			  ffecom_gfrt_kindtype (gfrt),
5290 			  FALSE,
5291 			  NULL_TREE,
5292 			  NULL_TREE,
5293 			  NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5294 			  ffebld_nonter_hook (expr));
5295 
5296 	expr_tree
5297 	  = ffecom_modify (NULL_TREE, arg1_tree,
5298 			   convert (TREE_TYPE (arg1_tree),
5299 				    expr_tree));
5300       }
5301       return expr_tree;
5302 
5303     case FFEINTRIN_impDTIME_subr:
5304     case FFEINTRIN_impETIME_subr:
5305       {
5306 	tree arg1_tree;
5307 	tree result_tree;
5308 
5309 	result_tree = ffecom_expr_w (NULL_TREE, arg2);
5310 
5311 	arg1_tree = ffecom_ptr_to_expr (arg1);
5312 
5313 	expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5314 				  ffecom_gfrt_kindtype (gfrt),
5315 				  FALSE,
5316 				  NULL_TREE,
5317 				  build_tree_list (NULL_TREE, arg1_tree),
5318 				  NULL_TREE, NULL, NULL, NULL_TREE,
5319 				  TRUE,
5320 				  ffebld_nonter_hook (expr));
5321 	expr_tree = ffecom_modify (NULL_TREE, result_tree,
5322 				   convert (TREE_TYPE (result_tree),
5323 					    expr_tree));
5324       }
5325       return expr_tree;
5326 
5327       /* Straightforward calls of libf2c routines: */
5328     case FFEINTRIN_impABORT:
5329     case FFEINTRIN_impACCESS:
5330     case FFEINTRIN_impBESJ0:
5331     case FFEINTRIN_impBESJ1:
5332     case FFEINTRIN_impBESJN:
5333     case FFEINTRIN_impBESY0:
5334     case FFEINTRIN_impBESY1:
5335     case FFEINTRIN_impBESYN:
5336     case FFEINTRIN_impCHDIR_func:
5337     case FFEINTRIN_impCHMOD_func:
5338     case FFEINTRIN_impDATE:
5339     case FFEINTRIN_impDATE_AND_TIME:
5340     case FFEINTRIN_impDBESJ0:
5341     case FFEINTRIN_impDBESJ1:
5342     case FFEINTRIN_impDBESJN:
5343     case FFEINTRIN_impDBESY0:
5344     case FFEINTRIN_impDBESY1:
5345     case FFEINTRIN_impDBESYN:
5346     case FFEINTRIN_impDTIME_func:
5347     case FFEINTRIN_impETIME_func:
5348     case FFEINTRIN_impFGETC_func:
5349     case FFEINTRIN_impFGET_func:
5350     case FFEINTRIN_impFNUM:
5351     case FFEINTRIN_impFPUTC_func:
5352     case FFEINTRIN_impFPUT_func:
5353     case FFEINTRIN_impFSEEK:
5354     case FFEINTRIN_impFSTAT_func:
5355     case FFEINTRIN_impFTELL_func:
5356     case FFEINTRIN_impGERROR:
5357     case FFEINTRIN_impGETARG:
5358     case FFEINTRIN_impGETCWD_func:
5359     case FFEINTRIN_impGETENV:
5360     case FFEINTRIN_impGETGID:
5361     case FFEINTRIN_impGETLOG:
5362     case FFEINTRIN_impGETPID:
5363     case FFEINTRIN_impGETUID:
5364     case FFEINTRIN_impGMTIME:
5365     case FFEINTRIN_impHOSTNM_func:
5366     case FFEINTRIN_impIDATE_unix:
5367     case FFEINTRIN_impIDATE_vxt:
5368     case FFEINTRIN_impIERRNO:
5369     case FFEINTRIN_impISATTY:
5370     case FFEINTRIN_impITIME:
5371     case FFEINTRIN_impKILL_func:
5372     case FFEINTRIN_impLINK_func:
5373     case FFEINTRIN_impLNBLNK:
5374     case FFEINTRIN_impLSTAT_func:
5375     case FFEINTRIN_impLTIME:
5376     case FFEINTRIN_impMCLOCK8:
5377     case FFEINTRIN_impMCLOCK:
5378     case FFEINTRIN_impPERROR:
5379     case FFEINTRIN_impRENAME_func:
5380     case FFEINTRIN_impSECNDS:
5381     case FFEINTRIN_impSECOND_func:
5382     case FFEINTRIN_impSLEEP:
5383     case FFEINTRIN_impSRAND:
5384     case FFEINTRIN_impSTAT_func:
5385     case FFEINTRIN_impSYMLNK_func:
5386     case FFEINTRIN_impSYSTEM_CLOCK:
5387     case FFEINTRIN_impSYSTEM_func:
5388     case FFEINTRIN_impTIME8:
5389     case FFEINTRIN_impTIME_unix:
5390     case FFEINTRIN_impTIME_vxt:
5391     case FFEINTRIN_impUMASK_func:
5392     case FFEINTRIN_impUNLINK_func:
5393       break;
5394 
5395     case FFEINTRIN_impCTIME_func:	/* CHARACTER functions not handled here. */
5396     case FFEINTRIN_impFDATE_func:	/* CHARACTER functions not handled here. */
5397     case FFEINTRIN_impTTYNAM_func:	/* CHARACTER functions not handled here. */
5398     case FFEINTRIN_impNONE:
5399     case FFEINTRIN_imp:		/* Hush up gcc warning. */
5400       fprintf (stderr, "No %s implementation.\n",
5401 	       ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5402       assert ("unimplemented intrinsic" == NULL);
5403       return error_mark_node;
5404     }
5405 
5406   assert (gfrt != FFECOM_gfrt);	/* Must have an implementation! */
5407 
5408   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5409 				    ffebld_right (expr));
5410 
5411   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5412 		       (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5413 		       tree_type,
5414 		       expr_tree, dest_tree, dest, dest_used,
5415 		       NULL_TREE, TRUE,
5416 		       ffebld_nonter_hook (expr));
5417 
5418   /* See bottom of this file for f2c transforms used to determine
5419      many of the above implementations.  The info seems to confuse
5420      Emacs's C mode indentation, which is why it's been moved to
5421      the bottom of this source file.  */
5422 }
5423 
5424 /* For power (exponentiation) where right-hand operand is type INTEGER,
5425    generate in-line code to do it the fast way (which, if the operand
5426    is a constant, might just mean a series of multiplies).  */
5427 
5428 static tree
ffecom_expr_power_integer_(ffebld expr)5429 ffecom_expr_power_integer_ (ffebld expr)
5430 {
5431   tree l = ffecom_expr (ffebld_left (expr));
5432   tree r = ffecom_expr (ffebld_right (expr));
5433   tree ltype = TREE_TYPE (l);
5434   tree rtype = TREE_TYPE (r);
5435   tree result = NULL_TREE;
5436 
5437   if (l == error_mark_node
5438       || r == error_mark_node)
5439     return error_mark_node;
5440 
5441   if (TREE_CODE (r) == INTEGER_CST)
5442     {
5443       int sgn = tree_int_cst_sgn (r);
5444 
5445       if (sgn == 0)
5446 	return convert (ltype, integer_one_node);
5447 
5448       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5449 	  && (sgn < 0))
5450 	{
5451 	  /* Reciprocal of integer is either 0, -1, or 1, so after
5452 	     calculating that (which we leave to the back end to do
5453 	     or not do optimally), don't bother with any multiplying.  */
5454 
5455 	  result = ffecom_tree_divide_ (ltype,
5456 					convert (ltype, integer_one_node),
5457 					l,
5458 					NULL_TREE, NULL, NULL, NULL_TREE);
5459 	  r = ffecom_1 (NEGATE_EXPR,
5460 			rtype,
5461 			r);
5462 	  if ((TREE_INT_CST_LOW (r) & 1) == 0)
5463 	    result = ffecom_1 (ABS_EXPR, rtype,
5464 			       result);
5465 	}
5466 
5467       /* Generate appropriate series of multiplies, preceded
5468 	 by divide if the exponent is negative.  */
5469 
5470       l = save_expr (l);
5471 
5472       if (sgn < 0)
5473 	{
5474 	  l = ffecom_tree_divide_ (ltype,
5475 				   convert (ltype, integer_one_node),
5476 				   l,
5477 				   NULL_TREE, NULL, NULL,
5478 				   ffebld_nonter_hook (expr));
5479 	  r = ffecom_1 (NEGATE_EXPR, rtype, r);
5480 	  assert (TREE_CODE (r) == INTEGER_CST);
5481 
5482 	  if (tree_int_cst_sgn (r) < 0)
5483 	    {			/* The "most negative" number.  */
5484 	      r = ffecom_1 (NEGATE_EXPR, rtype,
5485 			    ffecom_2 (RSHIFT_EXPR, rtype,
5486 				      r,
5487 				      integer_one_node));
5488 	      l = save_expr (l);
5489 	      l = ffecom_2 (MULT_EXPR, ltype,
5490 			    l,
5491 			    l);
5492 	    }
5493 	}
5494 
5495       for (;;)
5496 	{
5497 	  if (TREE_INT_CST_LOW (r) & 1)
5498 	    {
5499 	      if (result == NULL_TREE)
5500 		result = l;
5501 	      else
5502 		result = ffecom_2 (MULT_EXPR, ltype,
5503 				   result,
5504 				   l);
5505 	    }
5506 
5507 	  r = ffecom_2 (RSHIFT_EXPR, rtype,
5508 			r,
5509 			integer_one_node);
5510 	  if (integer_zerop (r))
5511 	    break;
5512 	  assert (TREE_CODE (r) == INTEGER_CST);
5513 
5514 	  l = save_expr (l);
5515 	  l = ffecom_2 (MULT_EXPR, ltype,
5516 			l,
5517 			l);
5518 	}
5519       return result;
5520     }
5521 
5522   /* Though rhs isn't a constant, in-line code cannot be expanded
5523      while transforming dummies
5524      because the back end cannot be easily convinced to generate
5525      stores (MODIFY_EXPR), handle temporaries, and so on before
5526      all the appropriate rtx's have been generated for things like
5527      dummy args referenced in rhs -- which doesn't happen until
5528      store_parm_decls() is called (expand_function_start, I believe,
5529      does the actual rtx-stuffing of PARM_DECLs).
5530 
5531      So, in this case, let the caller generate the call to the
5532      run-time-library function to evaluate the power for us.  */
5533 
5534   if (ffecom_transform_only_dummies_)
5535     return NULL_TREE;
5536 
5537   /* Right-hand operand not a constant, expand in-line code to figure
5538      out how to do the multiplies, &c.
5539 
5540      The returned expression is expressed this way in GNU C, where l and
5541      r are the "inputs":
5542 
5543      ({ typeof (r) rtmp = r;
5544 	typeof (l) ltmp = l;
5545 	typeof (l) result;
5546 
5547 	if (rtmp == 0)
5548 	  result = 1;
5549 	else
5550 	  {
5551 	    if ((basetypeof (l) == basetypeof (int))
5552 		&& (rtmp < 0))
5553 	      {
5554 	        result = ((typeof (l)) 1) / ltmp;
5555 	        if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5556 		  result = -result;
5557 	      }
5558 	    else
5559 	      {
5560 		result = 1;
5561 		if ((basetypeof (l) != basetypeof (int))
5562 		    && (rtmp < 0))
5563 		  {
5564 		    ltmp = ((typeof (l)) 1) / ltmp;
5565 		    rtmp = -rtmp;
5566 		    if (rtmp < 0)
5567 		      {
5568 		        rtmp = -(rtmp >> 1);
5569 		        ltmp *= ltmp;
5570 		      }
5571 		  }
5572 		for (;;)
5573 		  {
5574 		    if (rtmp & 1)
5575 		      result *= ltmp;
5576 		    if ((rtmp >>= 1) == 0)
5577 		      break;
5578 		    ltmp *= ltmp;
5579 		  }
5580 	      }
5581 	  }
5582 	result;
5583      })
5584 
5585      Note that some of the above is compile-time collapsable, such as
5586      the first part of the if statements that checks the base type of
5587      l against int.  The if statements are phrased that way to suggest
5588      an easy way to generate the if/else constructs here, knowing that
5589      the back end should (and probably does) eliminate the resulting
5590      dead code (either the int case or the non-int case), something
5591      it couldn't do without the redundant phrasing, requiring explicit
5592      dead-code elimination here, which would be kind of difficult to
5593      read.  */
5594 
5595   {
5596     tree rtmp;
5597     tree ltmp;
5598     tree divide;
5599     tree basetypeof_l_is_int;
5600     tree se;
5601     tree t;
5602 
5603     basetypeof_l_is_int
5604       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5605 
5606     se = expand_start_stmt_expr (/*has_scope=*/1);
5607 
5608     ffecom_start_compstmt ();
5609 
5610     rtmp = ffecom_make_tempvar ("power_r", rtype,
5611 				FFETARGET_charactersizeNONE, -1);
5612     ltmp = ffecom_make_tempvar ("power_l", ltype,
5613 				FFETARGET_charactersizeNONE, -1);
5614     result = ffecom_make_tempvar ("power_res", ltype,
5615 				  FFETARGET_charactersizeNONE, -1);
5616     if (TREE_CODE (ltype) == COMPLEX_TYPE
5617 	|| TREE_CODE (ltype) == RECORD_TYPE)
5618       divide = ffecom_make_tempvar ("power_div", ltype,
5619 				    FFETARGET_charactersizeNONE, -1);
5620     else
5621       divide = NULL_TREE;
5622 
5623     expand_expr_stmt (ffecom_modify (void_type_node,
5624 				     rtmp,
5625 				     r));
5626     expand_expr_stmt (ffecom_modify (void_type_node,
5627 				     ltmp,
5628 				     l));
5629     expand_start_cond (ffecom_truth_value
5630 		       (ffecom_2 (EQ_EXPR, integer_type_node,
5631 				  rtmp,
5632 				  convert (rtype, integer_zero_node))),
5633 		       0);
5634     expand_expr_stmt (ffecom_modify (void_type_node,
5635 				     result,
5636 				     convert (ltype, integer_one_node)));
5637     expand_start_else ();
5638     if (! integer_zerop (basetypeof_l_is_int))
5639       {
5640 	expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5641 				     rtmp,
5642 				     convert (rtype,
5643 					      integer_zero_node)),
5644 			   0);
5645 	expand_expr_stmt (ffecom_modify (void_type_node,
5646 					 result,
5647 					 ffecom_tree_divide_
5648 					 (ltype,
5649 					  convert (ltype, integer_one_node),
5650 					  ltmp,
5651 					  NULL_TREE, NULL, NULL,
5652 					  divide)));
5653 	expand_start_cond (ffecom_truth_value
5654 			   (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5655 				      ffecom_2 (LT_EXPR, integer_type_node,
5656 						ltmp,
5657 						convert (ltype,
5658 							 integer_zero_node)),
5659 				      ffecom_2 (EQ_EXPR, integer_type_node,
5660 						ffecom_2 (BIT_AND_EXPR,
5661 							  rtype,
5662 							  ffecom_1 (NEGATE_EXPR,
5663 								    rtype,
5664 								    rtmp),
5665 							  convert (rtype,
5666 								   integer_one_node)),
5667 						convert (rtype,
5668 							 integer_zero_node)))),
5669 			   0);
5670 	expand_expr_stmt (ffecom_modify (void_type_node,
5671 					 result,
5672 					 ffecom_1 (NEGATE_EXPR,
5673 						   ltype,
5674 						   result)));
5675 	expand_end_cond ();
5676 	expand_start_else ();
5677       }
5678     expand_expr_stmt (ffecom_modify (void_type_node,
5679 				     result,
5680 				     convert (ltype, integer_one_node)));
5681     expand_start_cond (ffecom_truth_value
5682 		       (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5683 				  ffecom_truth_value_invert
5684 				  (basetypeof_l_is_int),
5685 				  ffecom_2 (LT_EXPR, integer_type_node,
5686 					    rtmp,
5687 					    convert (rtype,
5688 						     integer_zero_node)))),
5689 		       0);
5690     expand_expr_stmt (ffecom_modify (void_type_node,
5691 				     ltmp,
5692 				     ffecom_tree_divide_
5693 				     (ltype,
5694 				      convert (ltype, integer_one_node),
5695 				      ltmp,
5696 				      NULL_TREE, NULL, NULL,
5697 				      divide)));
5698     expand_expr_stmt (ffecom_modify (void_type_node,
5699 				     rtmp,
5700 				     ffecom_1 (NEGATE_EXPR, rtype,
5701 					       rtmp)));
5702     expand_start_cond (ffecom_truth_value
5703 		       (ffecom_2 (LT_EXPR, integer_type_node,
5704 				  rtmp,
5705 				  convert (rtype, integer_zero_node))),
5706 		       0);
5707     expand_expr_stmt (ffecom_modify (void_type_node,
5708 				     rtmp,
5709 				     ffecom_1 (NEGATE_EXPR, rtype,
5710 					       ffecom_2 (RSHIFT_EXPR,
5711 							 rtype,
5712 							 rtmp,
5713 							 integer_one_node))));
5714     expand_expr_stmt (ffecom_modify (void_type_node,
5715 				     ltmp,
5716 				     ffecom_2 (MULT_EXPR, ltype,
5717 					       ltmp,
5718 					       ltmp)));
5719     expand_end_cond ();
5720     expand_end_cond ();
5721     expand_start_loop (1);
5722     expand_start_cond (ffecom_truth_value
5723 		       (ffecom_2 (BIT_AND_EXPR, rtype,
5724 				  rtmp,
5725 				  convert (rtype, integer_one_node))),
5726 		       0);
5727     expand_expr_stmt (ffecom_modify (void_type_node,
5728 				     result,
5729 				     ffecom_2 (MULT_EXPR, ltype,
5730 					       result,
5731 					       ltmp)));
5732     expand_end_cond ();
5733     expand_exit_loop_if_false (NULL,
5734 			       ffecom_truth_value
5735 			       (ffecom_modify (rtype,
5736 					       rtmp,
5737 					       ffecom_2 (RSHIFT_EXPR,
5738 							 rtype,
5739 							 rtmp,
5740 							 integer_one_node))));
5741     expand_expr_stmt (ffecom_modify (void_type_node,
5742 				     ltmp,
5743 				     ffecom_2 (MULT_EXPR, ltype,
5744 					       ltmp,
5745 					       ltmp)));
5746     expand_end_loop ();
5747     expand_end_cond ();
5748     if (!integer_zerop (basetypeof_l_is_int))
5749       expand_end_cond ();
5750     expand_expr_stmt (result);
5751 
5752     t = ffecom_end_compstmt ();
5753 
5754     result = expand_end_stmt_expr (se);
5755 
5756     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5757 
5758     if (TREE_CODE (t) == BLOCK)
5759       {
5760 	/* Make a BIND_EXPR for the BLOCK already made.  */
5761 	result = build (BIND_EXPR, TREE_TYPE (result),
5762 			NULL_TREE, result, t);
5763 	/* Remove the block from the tree at this point.
5764 	   It gets put back at the proper place
5765 	   when the BIND_EXPR is expanded.  */
5766 	delete_block (t);
5767       }
5768     else
5769       result = t;
5770   }
5771 
5772   return result;
5773 }
5774 
5775 /* ffecom_expr_transform_ -- Transform symbols in expr
5776 
5777    ffebld expr;	 // FFE expression.
5778    ffecom_expr_transform_ (expr);
5779 
5780    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5781 
5782 static void
ffecom_expr_transform_(ffebld expr)5783 ffecom_expr_transform_ (ffebld expr)
5784 {
5785   tree t;
5786   ffesymbol s;
5787 
5788  tail_recurse:
5789 
5790   if (expr == NULL)
5791     return;
5792 
5793   switch (ffebld_op (expr))
5794     {
5795     case FFEBLD_opSYMTER:
5796       s = ffebld_symter (expr);
5797       t = ffesymbol_hook (s).decl_tree;
5798       if ((t == NULL_TREE)
5799 	  && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5800 	      || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5801 		  && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5802 	{
5803 	  s = ffecom_sym_transform_ (s);
5804 	  t = ffesymbol_hook (s).decl_tree;	/* Sfunc expr non-dummy,
5805 						   DIMENSION expr? */
5806 	}
5807       break;			/* Ok if (t == NULL) here. */
5808 
5809     case FFEBLD_opITEM:
5810       ffecom_expr_transform_ (ffebld_head (expr));
5811       expr = ffebld_trail (expr);
5812       goto tail_recurse;	/* :::::::::::::::::::: */
5813 
5814     default:
5815       break;
5816     }
5817 
5818   switch (ffebld_arity (expr))
5819     {
5820     case 2:
5821       ffecom_expr_transform_ (ffebld_left (expr));
5822       expr = ffebld_right (expr);
5823       goto tail_recurse;	/* :::::::::::::::::::: */
5824 
5825     case 1:
5826       expr = ffebld_left (expr);
5827       goto tail_recurse;	/* :::::::::::::::::::: */
5828 
5829     default:
5830       break;
5831     }
5832 
5833   return;
5834 }
5835 
5836 /* Make a type based on info in live f2c.h file.  */
5837 
5838 static void
ffecom_f2c_make_type_(tree * type,int tcode,const char * name)5839 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5840 {
5841   switch (tcode)
5842     {
5843     case FFECOM_f2ccodeCHAR:
5844       *type = make_signed_type (CHAR_TYPE_SIZE);
5845       break;
5846 
5847     case FFECOM_f2ccodeSHORT:
5848       *type = make_signed_type (SHORT_TYPE_SIZE);
5849       break;
5850 
5851     case FFECOM_f2ccodeINT:
5852       *type = make_signed_type (INT_TYPE_SIZE);
5853       break;
5854 
5855     case FFECOM_f2ccodeLONG:
5856       *type = make_signed_type (LONG_TYPE_SIZE);
5857       break;
5858 
5859     case FFECOM_f2ccodeLONGLONG:
5860       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5861       break;
5862 
5863     case FFECOM_f2ccodeCHARPTR:
5864       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5865 				  ? signed_char_type_node
5866 				  : unsigned_char_type_node);
5867       break;
5868 
5869     case FFECOM_f2ccodeFLOAT:
5870       *type = make_node (REAL_TYPE);
5871       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5872       layout_type (*type);
5873       break;
5874 
5875     case FFECOM_f2ccodeDOUBLE:
5876       *type = make_node (REAL_TYPE);
5877       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5878       layout_type (*type);
5879       break;
5880 
5881     case FFECOM_f2ccodeLONGDOUBLE:
5882       *type = make_node (REAL_TYPE);
5883       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5884       layout_type (*type);
5885       break;
5886 
5887     case FFECOM_f2ccodeTWOREALS:
5888       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5889       break;
5890 
5891     case FFECOM_f2ccodeTWODOUBLEREALS:
5892       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5893       break;
5894 
5895     default:
5896       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5897       *type = error_mark_node;
5898       return;
5899     }
5900 
5901   pushdecl (build_decl (TYPE_DECL,
5902 			ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5903 			*type));
5904 }
5905 
5906 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5907    given size.  */
5908 
5909 static void
ffecom_f2c_set_lio_code_(ffeinfoBasictype bt,int size,int code)5910 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5911 			  int code)
5912 {
5913   int j;
5914   tree t;
5915 
5916   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5917     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5918 	&& compare_tree_int (TYPE_SIZE (t), size) == 0)
5919       {
5920 	assert (code != -1);
5921 	ffecom_f2c_typecode_[bt][j] = code;
5922 	code = -1;
5923       }
5924 }
5925 
5926 /* Finish up globals after doing all program units in file
5927 
5928    Need to handle only uninitialized COMMON areas.  */
5929 
5930 static ffeglobal
ffecom_finish_global_(ffeglobal global)5931 ffecom_finish_global_ (ffeglobal global)
5932 {
5933   tree cbtype;
5934   tree cbt;
5935   tree size;
5936 
5937   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5938       return global;
5939 
5940   if (ffeglobal_common_init (global))
5941       return global;
5942 
5943   cbt = ffeglobal_hook (global);
5944   if ((cbt == NULL_TREE)
5945       || !ffeglobal_common_have_size (global))
5946     return global;		/* No need to make common, never ref'd. */
5947 
5948   DECL_EXTERNAL (cbt) = 0;
5949 
5950   /* Give the array a size now.  */
5951 
5952   size = build_int_2 ((ffeglobal_common_size (global)
5953 		      + ffeglobal_common_pad (global)) - 1,
5954 		      0);
5955 
5956   cbtype = TREE_TYPE (cbt);
5957   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
5958 					   integer_zero_node,
5959 					   size);
5960   if (!TREE_TYPE (size))
5961     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
5962   layout_type (cbtype);
5963 
5964   cbt = start_decl (cbt, FALSE);
5965   assert (cbt == ffeglobal_hook (global));
5966 
5967   finish_decl (cbt, NULL_TREE, FALSE);
5968 
5969   return global;
5970 }
5971 
5972 /* Finish up any untransformed symbols.  */
5973 
5974 static ffesymbol
ffecom_finish_symbol_transform_(ffesymbol s)5975 ffecom_finish_symbol_transform_ (ffesymbol s)
5976 {
5977   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
5978     return s;
5979 
5980   /* It's easy to know to transform an untransformed symbol, to make sure
5981      we put out debugging info for it.  But COMMON variables, unlike
5982      EQUIVALENCE ones, aren't given declarations in addition to the
5983      tree expressions that specify offsets, because COMMON variables
5984      can be referenced in the outer scope where only dummy arguments
5985      (PARM_DECLs) should really be seen.  To be safe, just don't do any
5986      VAR_DECLs for COMMON variables when we transform them for real
5987      use, and therefore we do all the VAR_DECL creating here.  */
5988 
5989   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
5990     {
5991       if (ffesymbol_kind (s) != FFEINFO_kindNONE
5992 	  || (ffesymbol_where (s) != FFEINFO_whereNONE
5993 	      && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
5994 	      && ffesymbol_where (s) != FFEINFO_whereDUMMY))
5995 	/* Not transformed, and not CHARACTER*(*), and not a dummy
5996 	   argument, which can happen only if the entry point names
5997 	   it "rides in on" are all invalidated for other reasons.  */
5998 	s = ffecom_sym_transform_ (s);
5999     }
6000 
6001   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6002       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6003     {
6004       /* This isn't working, at least for dbxout.  The .s file looks
6005 	 okay to me (burley), but in gdb 4.9 at least, the variables
6006 	 appear to reside somewhere outside of the common area, so
6007 	 it doesn't make sense to mislead anyone by generating the info
6008 	 on those variables until this is fixed.  NOTE: Same problem
6009 	 with EQUIVALENCE, sadly...see similar #if later.  */
6010       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6011 			     ffesymbol_storage (s));
6012     }
6013 
6014   return s;
6015 }
6016 
6017 /* Append underscore(s) to name before calling get_identifier.  "us"
6018    is nonzero if the name already contains an underscore and thus
6019    needs two underscores appended.  */
6020 
6021 static tree
ffecom_get_appended_identifier_(char us,const char * name)6022 ffecom_get_appended_identifier_ (char us, const char *name)
6023 {
6024   int i;
6025   char *newname;
6026   tree id;
6027 
6028   newname = xmalloc ((i = strlen (name)) + 1
6029 		     + ffe_is_underscoring ()
6030 		     + us);
6031   memcpy (newname, name, i);
6032   newname[i] = '_';
6033   newname[i + us] = '_';
6034   newname[i + 1 + us] = '\0';
6035   id = get_identifier (newname);
6036 
6037   free (newname);
6038 
6039   return id;
6040 }
6041 
6042 /* Decide whether to append underscore to name before calling
6043    get_identifier.  */
6044 
6045 static tree
ffecom_get_external_identifier_(ffesymbol s)6046 ffecom_get_external_identifier_ (ffesymbol s)
6047 {
6048   char us;
6049   const char *name = ffesymbol_text (s);
6050 
6051   /* If name is a built-in name, just return it as is.  */
6052 
6053   if (!ffe_is_underscoring ()
6054       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6055 #if FFETARGET_isENFORCED_MAIN_NAME
6056       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6057 #else
6058       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6059 #endif
6060       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6061     return get_identifier (name);
6062 
6063   us = ffe_is_second_underscore ()
6064     ? (strchr (name, '_') != NULL)
6065       : 0;
6066 
6067   return ffecom_get_appended_identifier_ (us, name);
6068 }
6069 
6070 /* Decide whether to append underscore to internal name before calling
6071    get_identifier.
6072 
6073    This is for non-external, top-function-context names only.  Transform
6074    identifier so it doesn't conflict with the transformed result
6075    of using a _different_ external name.  E.g. if "CALL FOO" is
6076    transformed into "FOO_();", then the variable in "FOO_ = 3"
6077    must be transformed into something that does not conflict, since
6078    these two things should be independent.
6079 
6080    The transformation is as follows.  If the name does not contain
6081    an underscore, there is no possible conflict, so just return.
6082    If the name does contain an underscore, then transform it just
6083    like we transform an external identifier.  */
6084 
6085 static tree
ffecom_get_identifier_(const char * name)6086 ffecom_get_identifier_ (const char *name)
6087 {
6088   /* If name does not contain an underscore, just return it as is.  */
6089 
6090   if (!ffe_is_underscoring ()
6091       || (strchr (name, '_') == NULL))
6092     return get_identifier (name);
6093 
6094   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6095 					  name);
6096 }
6097 
6098 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6099 
6100    tree t;
6101    ffesymbol s;	 // kindFUNCTION, whereIMMEDIATE.
6102    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6103 	 ffesymbol_kindtype(s));
6104 
6105    Call after setting up containing function and getting trees for all
6106    other symbols.  */
6107 
6108 static tree
ffecom_gen_sfuncdef_(ffesymbol s,ffeinfoBasictype bt,ffeinfoKindtype kt)6109 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6110 {
6111   ffebld expr = ffesymbol_sfexpr (s);
6112   tree type;
6113   tree func;
6114   tree result;
6115   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6116   static bool recurse = FALSE;
6117   int old_lineno = lineno;
6118   const char *old_input_filename = input_filename;
6119 
6120   ffecom_nested_entry_ = s;
6121 
6122   /* For now, we don't have a handy pointer to where the sfunc is actually
6123      defined, though that should be easy to add to an ffesymbol. (The
6124      token/where info available might well point to the place where the type
6125      of the sfunc is declared, especially if that precedes the place where
6126      the sfunc itself is defined, which is typically the case.)  We should
6127      put out a null pointer rather than point somewhere wrong, but I want to
6128      see how it works at this point.  */
6129 
6130   input_filename = ffesymbol_where_filename (s);
6131   lineno = ffesymbol_where_filelinenum (s);
6132 
6133   /* Pretransform the expression so any newly discovered things belong to the
6134      outer program unit, not to the statement function. */
6135 
6136   ffecom_expr_transform_ (expr);
6137 
6138   /* Make sure no recursive invocation of this fn (a specific case of failing
6139      to pretransform an sfunc's expression, i.e. where its expression
6140      references another untransformed sfunc) happens. */
6141 
6142   assert (!recurse);
6143   recurse = TRUE;
6144 
6145   push_f_function_context ();
6146 
6147   if (charfunc)
6148     type = void_type_node;
6149   else
6150     {
6151       type = ffecom_tree_type[bt][kt];
6152       if (type == NULL_TREE)
6153 	type = integer_type_node;	/* _sym_exec_transition reports
6154 					   error. */
6155     }
6156 
6157   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6158 		  build_function_type (type, NULL_TREE),
6159 		  1,		/* nested/inline */
6160 		  0);		/* TREE_PUBLIC */
6161 
6162   /* We don't worry about COMPLEX return values here, because this is
6163      entirely internal to our code, and gcc has the ability to return COMPLEX
6164      directly as a value.  */
6165 
6166   if (charfunc)
6167     {				/* Prepend arg for where result goes. */
6168       tree type;
6169 
6170       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6171 
6172       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6173 
6174       ffecom_char_enhance_arg_ (&type, s);	/* Ignore returned length. */
6175 
6176       type = build_pointer_type (type);
6177       result = build_decl (PARM_DECL, result, type);
6178 
6179       push_parm_decl (result);
6180     }
6181   else
6182     result = NULL_TREE;		/* Not ref'd if !charfunc. */
6183 
6184   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6185 
6186   store_parm_decls (0);
6187 
6188   ffecom_start_compstmt ();
6189 
6190   if (expr != NULL)
6191     {
6192       if (charfunc)
6193 	{
6194 	  ffetargetCharacterSize sz = ffesymbol_size (s);
6195 	  tree result_length;
6196 
6197 	  result_length = build_int_2 (sz, 0);
6198 	  TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6199 
6200 	  ffecom_prepare_let_char_ (sz, expr);
6201 
6202 	  ffecom_prepare_end ();
6203 
6204 	  ffecom_let_char_ (result, result_length, sz, expr);
6205 	  expand_null_return ();
6206 	}
6207       else
6208 	{
6209 	  ffecom_prepare_expr (expr);
6210 
6211 	  ffecom_prepare_end ();
6212 
6213 	  expand_return (ffecom_modify (NULL_TREE,
6214 					DECL_RESULT (current_function_decl),
6215 					ffecom_expr (expr)));
6216 	}
6217     }
6218 
6219   ffecom_end_compstmt ();
6220 
6221   func = current_function_decl;
6222   finish_function (1);
6223 
6224   pop_f_function_context ();
6225 
6226   recurse = FALSE;
6227 
6228   lineno = old_lineno;
6229   input_filename = old_input_filename;
6230 
6231   ffecom_nested_entry_ = NULL;
6232 
6233   return func;
6234 }
6235 
6236 static const char *
ffecom_gfrt_args_(ffecomGfrt ix)6237 ffecom_gfrt_args_ (ffecomGfrt ix)
6238 {
6239   return ffecom_gfrt_argstring_[ix];
6240 }
6241 
6242 static tree
ffecom_gfrt_tree_(ffecomGfrt ix)6243 ffecom_gfrt_tree_ (ffecomGfrt ix)
6244 {
6245   if (ffecom_gfrt_[ix] == NULL_TREE)
6246     ffecom_make_gfrt_ (ix);
6247 
6248   return ffecom_1 (ADDR_EXPR,
6249 		   build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6250 		   ffecom_gfrt_[ix]);
6251 }
6252 
6253 /* Return initialize-to-zero expression for this VAR_DECL.  */
6254 
6255 /* A somewhat evil way to prevent the garbage collector
6256    from collecting 'tree' structures.  */
6257 #define NUM_TRACKED_CHUNK 63
6258 struct tree_ggc_tracker GTY(())
6259 {
6260   struct tree_ggc_tracker *next;
6261   tree trees[NUM_TRACKED_CHUNK];
6262 };
6263 static GTY(()) struct tree_ggc_tracker *tracker_head;
6264 
6265 void
ffecom_save_tree_forever(tree t)6266 ffecom_save_tree_forever (tree t)
6267 {
6268   int i;
6269   if (tracker_head != NULL)
6270     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6271       if (tracker_head->trees[i] == NULL)
6272 	{
6273 	  tracker_head->trees[i] = t;
6274 	  return;
6275 	}
6276 
6277   {
6278     /* Need to allocate a new block.  */
6279     struct tree_ggc_tracker *old_head = tracker_head;
6280 
6281     tracker_head = ggc_alloc (sizeof (*tracker_head));
6282     tracker_head->next = old_head;
6283     tracker_head->trees[0] = t;
6284     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6285       tracker_head->trees[i] = NULL;
6286   }
6287 }
6288 
6289 static tree
ffecom_init_zero_(tree decl)6290 ffecom_init_zero_ (tree decl)
6291 {
6292   tree init;
6293   int incremental = TREE_STATIC (decl);
6294   tree type = TREE_TYPE (decl);
6295 
6296   if (incremental)
6297     {
6298       make_decl_rtl (decl, NULL);
6299       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6300     }
6301 
6302   if ((TREE_CODE (type) != ARRAY_TYPE)
6303       && (TREE_CODE (type) != RECORD_TYPE)
6304       && (TREE_CODE (type) != UNION_TYPE)
6305       && !incremental)
6306     init = convert (type, integer_zero_node);
6307   else if (!incremental)
6308     {
6309       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6310       TREE_CONSTANT (init) = 1;
6311       TREE_STATIC (init) = 1;
6312     }
6313   else
6314     {
6315       assemble_zeros (int_size_in_bytes (type));
6316       init = error_mark_node;
6317     }
6318 
6319   return init;
6320 }
6321 
6322 static tree
ffecom_intrinsic_ichar_(tree tree_type,ffebld arg,tree * maybe_tree)6323 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6324 			 tree *maybe_tree)
6325 {
6326   tree expr_tree;
6327   tree length_tree;
6328 
6329   switch (ffebld_op (arg))
6330     {
6331     case FFEBLD_opCONTER:	/* For F90, check 0-length. */
6332       if (ffetarget_length_character1
6333 	  (ffebld_constant_character1
6334 	   (ffebld_conter (arg))) == 0)
6335 	{
6336 	  *maybe_tree = integer_zero_node;
6337 	  return convert (tree_type, integer_zero_node);
6338 	}
6339 
6340       *maybe_tree = integer_one_node;
6341       expr_tree = build_int_2 (*ffetarget_text_character1
6342 			       (ffebld_constant_character1
6343 				(ffebld_conter (arg))),
6344 			       0);
6345       TREE_TYPE (expr_tree) = tree_type;
6346       return expr_tree;
6347 
6348     case FFEBLD_opSYMTER:
6349     case FFEBLD_opARRAYREF:
6350     case FFEBLD_opFUNCREF:
6351     case FFEBLD_opSUBSTR:
6352       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6353 
6354       if ((expr_tree == error_mark_node)
6355 	  || (length_tree == error_mark_node))
6356 	{
6357 	  *maybe_tree = error_mark_node;
6358 	  return error_mark_node;
6359 	}
6360 
6361       if (integer_zerop (length_tree))
6362 	{
6363 	  *maybe_tree = integer_zero_node;
6364 	  return convert (tree_type, integer_zero_node);
6365 	}
6366 
6367       expr_tree
6368 	= ffecom_1 (INDIRECT_REF,
6369 		    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6370 		    expr_tree);
6371       expr_tree
6372 	= ffecom_2 (ARRAY_REF,
6373 		    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6374 		    expr_tree,
6375 		    integer_one_node);
6376       expr_tree = convert (tree_type, expr_tree);
6377 
6378       if (TREE_CODE (length_tree) == INTEGER_CST)
6379 	*maybe_tree = integer_one_node;
6380       else			/* Must check length at run time.  */
6381 	*maybe_tree
6382 	  = ffecom_truth_value
6383 	    (ffecom_2 (GT_EXPR, integer_type_node,
6384 		       length_tree,
6385 		       ffecom_f2c_ftnlen_zero_node));
6386       return expr_tree;
6387 
6388     case FFEBLD_opPAREN:
6389     case FFEBLD_opCONVERT:
6390       if (ffeinfo_size (ffebld_info (arg)) == 0)
6391 	{
6392 	  *maybe_tree = integer_zero_node;
6393 	  return convert (tree_type, integer_zero_node);
6394 	}
6395       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6396 				      maybe_tree);
6397 
6398     case FFEBLD_opCONCATENATE:
6399       {
6400 	tree maybe_left;
6401 	tree maybe_right;
6402 	tree expr_left;
6403 	tree expr_right;
6404 
6405 	expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6406 					     &maybe_left);
6407 	expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6408 					      &maybe_right);
6409 	*maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6410 				maybe_left,
6411 				maybe_right);
6412 	expr_tree = ffecom_3 (COND_EXPR, tree_type,
6413 			      maybe_left,
6414 			      expr_left,
6415 			      expr_right);
6416 	return expr_tree;
6417       }
6418 
6419     default:
6420       assert ("bad op in ICHAR" == NULL);
6421       return error_mark_node;
6422     }
6423 }
6424 
6425 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6426 
6427    tree length_arg;
6428    ffebld expr;
6429    length_arg = ffecom_intrinsic_len_ (expr);
6430 
6431    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6432    subexpressions by constructing the appropriate tree for the
6433    length-of-character-text argument in a calling sequence.  */
6434 
6435 static tree
ffecom_intrinsic_len_(ffebld expr)6436 ffecom_intrinsic_len_ (ffebld expr)
6437 {
6438   ffetargetCharacter1 val;
6439   tree length;
6440 
6441   switch (ffebld_op (expr))
6442     {
6443     case FFEBLD_opCONTER:
6444       val = ffebld_constant_character1 (ffebld_conter (expr));
6445       length = build_int_2 (ffetarget_length_character1 (val), 0);
6446       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6447       break;
6448 
6449     case FFEBLD_opSYMTER:
6450       {
6451 	ffesymbol s = ffebld_symter (expr);
6452 	tree item;
6453 
6454 	item = ffesymbol_hook (s).decl_tree;
6455 	if (item == NULL_TREE)
6456 	  {
6457 	    s = ffecom_sym_transform_ (s);
6458 	    item = ffesymbol_hook (s).decl_tree;
6459 	  }
6460 	if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6461 	  {
6462 	    if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6463 	      length = ffesymbol_hook (s).length_tree;
6464 	    else
6465 	      {
6466 		length = build_int_2 (ffesymbol_size (s), 0);
6467 		TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6468 	      }
6469 	  }
6470 	else if (item == error_mark_node)
6471 	  length = error_mark_node;
6472 	else			/* FFEINFO_kindFUNCTION: */
6473 	  length = NULL_TREE;
6474       }
6475       break;
6476 
6477     case FFEBLD_opARRAYREF:
6478       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6479       break;
6480 
6481     case FFEBLD_opSUBSTR:
6482       {
6483 	ffebld start;
6484 	ffebld end;
6485 	ffebld thing = ffebld_right (expr);
6486 	tree start_tree;
6487 	tree end_tree;
6488 
6489 	assert (ffebld_op (thing) == FFEBLD_opITEM);
6490 	start = ffebld_head (thing);
6491 	thing = ffebld_trail (thing);
6492 	assert (ffebld_trail (thing) == NULL);
6493 	end = ffebld_head (thing);
6494 
6495 	length = ffecom_intrinsic_len_ (ffebld_left (expr));
6496 
6497 	if (length == error_mark_node)
6498 	  break;
6499 
6500 	if (start == NULL)
6501 	  {
6502 	    if (end == NULL)
6503 	      ;
6504 	    else
6505 	      {
6506 		length = convert (ffecom_f2c_ftnlen_type_node,
6507 				  ffecom_expr (end));
6508 	      }
6509 	  }
6510 	else
6511 	  {
6512 	    start_tree = convert (ffecom_f2c_ftnlen_type_node,
6513 				  ffecom_expr (start));
6514 
6515 	    if (start_tree == error_mark_node)
6516 	      {
6517 		length = error_mark_node;
6518 		break;
6519 	      }
6520 
6521 	    if (end == NULL)
6522 	      {
6523 		length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6524 				   ffecom_f2c_ftnlen_one_node,
6525 				   ffecom_2 (MINUS_EXPR,
6526 					     ffecom_f2c_ftnlen_type_node,
6527 					     length,
6528 					     start_tree));
6529 	      }
6530 	    else
6531 	      {
6532 		end_tree = convert (ffecom_f2c_ftnlen_type_node,
6533 				    ffecom_expr (end));
6534 
6535 		if (end_tree == error_mark_node)
6536 		  {
6537 		    length = error_mark_node;
6538 		    break;
6539 		  }
6540 
6541 		length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6542 				   ffecom_f2c_ftnlen_one_node,
6543 				   ffecom_2 (MINUS_EXPR,
6544 					     ffecom_f2c_ftnlen_type_node,
6545 					     end_tree, start_tree));
6546 	      }
6547 	  }
6548       }
6549       break;
6550 
6551     case FFEBLD_opCONCATENATE:
6552       length
6553 	= ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6554 		    ffecom_intrinsic_len_ (ffebld_left (expr)),
6555 		    ffecom_intrinsic_len_ (ffebld_right (expr)));
6556       break;
6557 
6558     case FFEBLD_opFUNCREF:
6559     case FFEBLD_opCONVERT:
6560       length = build_int_2 (ffebld_size (expr), 0);
6561       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6562       break;
6563 
6564     default:
6565       assert ("bad op for single char arg expr" == NULL);
6566       length = ffecom_f2c_ftnlen_zero_node;
6567       break;
6568     }
6569 
6570   assert (length != NULL_TREE);
6571 
6572   return length;
6573 }
6574 
6575 /* Handle CHARACTER assignments.
6576 
6577    Generates code to do the assignment.	 Used by ordinary assignment
6578    statement handler ffecom_let_stmt and by statement-function
6579    handler to generate code for a statement function.  */
6580 
6581 static void
ffecom_let_char_(tree dest_tree,tree dest_length,ffetargetCharacterSize dest_size,ffebld source)6582 ffecom_let_char_ (tree dest_tree, tree dest_length,
6583 		  ffetargetCharacterSize dest_size, ffebld source)
6584 {
6585   ffecomConcatList_ catlist;
6586   tree source_length;
6587   tree source_tree;
6588   tree expr_tree;
6589 
6590   if ((dest_tree == error_mark_node)
6591       || (dest_length == error_mark_node))
6592     return;
6593 
6594   assert (dest_tree != NULL_TREE);
6595   assert (dest_length != NULL_TREE);
6596 
6597   /* Source might be an opCONVERT, which just means it is a different size
6598      than the destination.  Since the underlying implementation here handles
6599      that (directly or via the s_copy or s_cat run-time-library functions),
6600      we don't need the "convenience" of an opCONVERT that tells us to
6601      truncate or blank-pad, particularly since the resulting implementation
6602      would probably be slower than otherwise. */
6603 
6604   while (ffebld_op (source) == FFEBLD_opCONVERT)
6605     source = ffebld_left (source);
6606 
6607   catlist = ffecom_concat_list_new_ (source, dest_size);
6608   switch (ffecom_concat_list_count_ (catlist))
6609     {
6610     case 0:			/* Shouldn't happen, but in case it does... */
6611       ffecom_concat_list_kill_ (catlist);
6612       source_tree = null_pointer_node;
6613       source_length = ffecom_f2c_ftnlen_zero_node;
6614       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6615       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6616       TREE_CHAIN (TREE_CHAIN (expr_tree))
6617 	= build_tree_list (NULL_TREE, dest_length);
6618       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6619 	= build_tree_list (NULL_TREE, source_length);
6620 
6621       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6622       TREE_SIDE_EFFECTS (expr_tree) = 1;
6623 
6624       expand_expr_stmt (expr_tree);
6625 
6626       return;
6627 
6628     case 1:			/* The (fairly) easy case. */
6629       ffecom_char_args_ (&source_tree, &source_length,
6630 			 ffecom_concat_list_expr_ (catlist, 0));
6631       ffecom_concat_list_kill_ (catlist);
6632       assert (source_tree != NULL_TREE);
6633       assert (source_length != NULL_TREE);
6634 
6635       if ((source_tree == error_mark_node)
6636 	  || (source_length == error_mark_node))
6637 	return;
6638 
6639       if (dest_size == 1)
6640 	{
6641 	  dest_tree
6642 	    = ffecom_1 (INDIRECT_REF,
6643 			TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6644 						      (dest_tree))),
6645 			dest_tree);
6646 	  dest_tree
6647 	    = ffecom_2 (ARRAY_REF,
6648 			TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6649 						      (dest_tree))),
6650 			dest_tree,
6651 			integer_one_node);
6652 	  source_tree
6653 	    = ffecom_1 (INDIRECT_REF,
6654 			TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6655 						      (source_tree))),
6656 			source_tree);
6657 	  source_tree
6658 	    = ffecom_2 (ARRAY_REF,
6659 			TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6660 						      (source_tree))),
6661 			source_tree,
6662 			integer_one_node);
6663 
6664 	  expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6665 
6666 	  expand_expr_stmt (expr_tree);
6667 
6668 	  return;
6669 	}
6670 
6671       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6672       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6673       TREE_CHAIN (TREE_CHAIN (expr_tree))
6674 	= build_tree_list (NULL_TREE, dest_length);
6675       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6676 	= build_tree_list (NULL_TREE, source_length);
6677 
6678       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6679       TREE_SIDE_EFFECTS (expr_tree) = 1;
6680 
6681       expand_expr_stmt (expr_tree);
6682 
6683       return;
6684 
6685     default:			/* Must actually concatenate things. */
6686       break;
6687     }
6688 
6689   /* Heavy-duty concatenation. */
6690 
6691   {
6692     int count = ffecom_concat_list_count_ (catlist);
6693     int i;
6694     tree lengths;
6695     tree items;
6696     tree length_array;
6697     tree item_array;
6698     tree citem;
6699     tree clength;
6700 
6701     {
6702       tree hook;
6703 
6704       hook = ffebld_nonter_hook (source);
6705       assert (hook);
6706       assert (TREE_CODE (hook) == TREE_VEC);
6707       assert (TREE_VEC_LENGTH (hook) == 2);
6708       length_array = lengths = TREE_VEC_ELT (hook, 0);
6709       item_array = items = TREE_VEC_ELT (hook, 1);
6710     }
6711 
6712     for (i = 0; i < count; ++i)
6713       {
6714 	ffecom_char_args_ (&citem, &clength,
6715 			   ffecom_concat_list_expr_ (catlist, i));
6716 	if ((citem == error_mark_node)
6717 	    || (clength == error_mark_node))
6718 	  {
6719 	    ffecom_concat_list_kill_ (catlist);
6720 	    return;
6721 	  }
6722 
6723 	items
6724 	  = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6725 		      ffecom_modify (void_type_node,
6726 				     ffecom_2 (ARRAY_REF,
6727 		     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6728 					       item_array,
6729 					       build_int_2 (i, 0)),
6730 				     citem),
6731 		      items);
6732 	lengths
6733 	  = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6734 		      ffecom_modify (void_type_node,
6735 				     ffecom_2 (ARRAY_REF,
6736 		   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6737 					       length_array,
6738 					       build_int_2 (i, 0)),
6739 				     clength),
6740 		      lengths);
6741       }
6742 
6743     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6744     TREE_CHAIN (expr_tree)
6745       = build_tree_list (NULL_TREE,
6746 			 ffecom_1 (ADDR_EXPR,
6747 				   build_pointer_type (TREE_TYPE (items)),
6748 				   items));
6749     TREE_CHAIN (TREE_CHAIN (expr_tree))
6750       = build_tree_list (NULL_TREE,
6751 			 ffecom_1 (ADDR_EXPR,
6752 				   build_pointer_type (TREE_TYPE (lengths)),
6753 				   lengths));
6754     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6755       = build_tree_list
6756 	(NULL_TREE,
6757 	 ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6758 		   convert (ffecom_f2c_ftnlen_type_node,
6759 			    build_int_2 (count, 0))));
6760     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6761       = build_tree_list (NULL_TREE, dest_length);
6762 
6763     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6764     TREE_SIDE_EFFECTS (expr_tree) = 1;
6765 
6766     expand_expr_stmt (expr_tree);
6767   }
6768 
6769   ffecom_concat_list_kill_ (catlist);
6770 }
6771 
6772 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6773 
6774    ffecomGfrt ix;
6775    ffecom_make_gfrt_(ix);
6776 
6777    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6778    for the indicated run-time routine (ix).  */
6779 
6780 static void
ffecom_make_gfrt_(ffecomGfrt ix)6781 ffecom_make_gfrt_ (ffecomGfrt ix)
6782 {
6783   tree t;
6784   tree ttype;
6785 
6786   switch (ffecom_gfrt_type_[ix])
6787     {
6788     case FFECOM_rttypeVOID_:
6789       ttype = void_type_node;
6790       break;
6791 
6792     case FFECOM_rttypeVOIDSTAR_:
6793       ttype = TREE_TYPE (null_pointer_node);	/* `void *'. */
6794       break;
6795 
6796     case FFECOM_rttypeFTNINT_:
6797       ttype = ffecom_f2c_ftnint_type_node;
6798       break;
6799 
6800     case FFECOM_rttypeINTEGER_:
6801       ttype = ffecom_f2c_integer_type_node;
6802       break;
6803 
6804     case FFECOM_rttypeLONGINT_:
6805       ttype = ffecom_f2c_longint_type_node;
6806       break;
6807 
6808     case FFECOM_rttypeLOGICAL_:
6809       ttype = ffecom_f2c_logical_type_node;
6810       break;
6811 
6812     case FFECOM_rttypeREAL_F2C_:
6813       ttype = double_type_node;
6814       break;
6815 
6816     case FFECOM_rttypeREAL_GNU_:
6817       ttype = float_type_node;
6818       break;
6819 
6820     case FFECOM_rttypeCOMPLEX_F2C_:
6821       ttype = void_type_node;
6822       break;
6823 
6824     case FFECOM_rttypeCOMPLEX_GNU_:
6825       ttype = ffecom_f2c_complex_type_node;
6826       break;
6827 
6828     case FFECOM_rttypeDOUBLE_:
6829       ttype = double_type_node;
6830       break;
6831 
6832     case FFECOM_rttypeDOUBLEREAL_:
6833       ttype = ffecom_f2c_doublereal_type_node;
6834       break;
6835 
6836     case FFECOM_rttypeDBLCMPLX_F2C_:
6837       ttype = void_type_node;
6838       break;
6839 
6840     case FFECOM_rttypeDBLCMPLX_GNU_:
6841       ttype = ffecom_f2c_doublecomplex_type_node;
6842       break;
6843 
6844     case FFECOM_rttypeCHARACTER_:
6845       ttype = void_type_node;
6846       break;
6847 
6848     default:
6849       ttype = NULL;
6850       assert ("bad rttype" == NULL);
6851       break;
6852     }
6853 
6854   ttype = build_function_type (ttype, NULL_TREE);
6855   t = build_decl (FUNCTION_DECL,
6856 		  get_identifier (ffecom_gfrt_name_[ix]),
6857 		  ttype);
6858   DECL_EXTERNAL (t) = 1;
6859   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6860   TREE_PUBLIC (t) = 1;
6861   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6862 
6863   /* Sanity check:  A function that's const cannot be volatile.  */
6864 
6865   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6866 
6867   /* Sanity check: A function that's const cannot return complex.  */
6868 
6869   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6870 
6871   t = start_decl (t, TRUE);
6872 
6873   finish_decl (t, NULL_TREE, TRUE);
6874 
6875   ffecom_gfrt_[ix] = t;
6876 }
6877 
6878 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
6879 
6880 static void
ffecom_member_phase1_(ffestorag mst UNUSED,ffestorag st)6881 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6882 {
6883   ffesymbol s = ffestorag_symbol (st);
6884 
6885   if (ffesymbol_namelisted (s))
6886     ffecom_member_namelisted_ = TRUE;
6887 }
6888 
6889 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
6890    the member so debugger will see it.  Otherwise nobody should be
6891    referencing the member.  */
6892 
6893 static void
ffecom_member_phase2_(ffestorag mst,ffestorag st)6894 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
6895 {
6896   ffesymbol s;
6897   tree t;
6898   tree mt;
6899   tree type;
6900 
6901   if ((mst == NULL)
6902       || ((mt = ffestorag_hook (mst)) == NULL)
6903       || (mt == error_mark_node))
6904     return;
6905 
6906   if ((st == NULL)
6907       || ((s = ffestorag_symbol (st)) == NULL))
6908     return;
6909 
6910   type = ffecom_type_localvar_ (s,
6911 				ffesymbol_basictype (s),
6912 				ffesymbol_kindtype (s));
6913   if (type == error_mark_node)
6914     return;
6915 
6916   t = build_decl (VAR_DECL,
6917 		  ffecom_get_identifier_ (ffesymbol_text (s)),
6918 		  type);
6919 
6920   TREE_STATIC (t) = TREE_STATIC (mt);
6921   DECL_INITIAL (t) = NULL_TREE;
6922   TREE_ASM_WRITTEN (t) = 1;
6923   TREE_USED (t) = 1;
6924 
6925   SET_DECL_RTL (t,
6926 		gen_rtx (MEM, TYPE_MODE (type),
6927 			 plus_constant (XEXP (DECL_RTL (mt), 0),
6928 					ffestorag_modulo (mst)
6929 					+ ffestorag_offset (st)
6930 					- ffestorag_offset (mst))));
6931 
6932   t = start_decl (t, FALSE);
6933 
6934   finish_decl (t, NULL_TREE, FALSE);
6935 }
6936 
6937 /* Prepare source expression for assignment into a destination perhaps known
6938    to be of a specific size.  */
6939 
6940 static void
ffecom_prepare_let_char_(ffetargetCharacterSize dest_size,ffebld source)6941 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
6942 {
6943   ffecomConcatList_ catlist;
6944   int count;
6945   int i;
6946   tree ltmp;
6947   tree itmp;
6948   tree tempvar = NULL_TREE;
6949 
6950   while (ffebld_op (source) == FFEBLD_opCONVERT)
6951     source = ffebld_left (source);
6952 
6953   catlist = ffecom_concat_list_new_ (source, dest_size);
6954   count = ffecom_concat_list_count_ (catlist);
6955 
6956   if (count >= 2)
6957     {
6958       ltmp
6959 	= ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
6960 			       FFETARGET_charactersizeNONE, count);
6961       itmp
6962 	= ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
6963 			       FFETARGET_charactersizeNONE, count);
6964 
6965       tempvar = make_tree_vec (2);
6966       TREE_VEC_ELT (tempvar, 0) = ltmp;
6967       TREE_VEC_ELT (tempvar, 1) = itmp;
6968     }
6969 
6970   for (i = 0; i < count; ++i)
6971     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
6972 
6973   ffecom_concat_list_kill_ (catlist);
6974 
6975   if (tempvar)
6976     {
6977       ffebld_nonter_set_hook (source, tempvar);
6978       current_binding_level->prep_state = 1;
6979     }
6980 }
6981 
6982 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
6983 
6984    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
6985    (which generates their trees) and then their trees get push_parm_decl'd.
6986 
6987    The second arg is TRUE if the dummies are for a statement function, in
6988    which case lengths are not pushed for character arguments (since they are
6989    always known by both the caller and the callee, though the code allows
6990    for someday permitting CHAR*(*) stmtfunc dummies).  */
6991 
6992 static void
ffecom_push_dummy_decls_(ffebld dummy_list,bool stmtfunc)6993 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
6994 {
6995   ffebld dummy;
6996   ffebld dumlist;
6997   ffesymbol s;
6998   tree parm;
6999 
7000   ffecom_transform_only_dummies_ = TRUE;
7001 
7002   /* First push the parms corresponding to actual dummy "contents".  */
7003 
7004   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7005     {
7006       dummy = ffebld_head (dumlist);
7007       switch (ffebld_op (dummy))
7008 	{
7009 	case FFEBLD_opSTAR:
7010 	case FFEBLD_opANY:
7011 	  continue;		/* Forget alternate returns. */
7012 
7013 	default:
7014 	  break;
7015 	}
7016       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7017       s = ffebld_symter (dummy);
7018       parm = ffesymbol_hook (s).decl_tree;
7019       if (parm == NULL_TREE)
7020 	{
7021 	  s = ffecom_sym_transform_ (s);
7022 	  parm = ffesymbol_hook (s).decl_tree;
7023 	  assert (parm != NULL_TREE);
7024 	}
7025       if (parm != error_mark_node)
7026 	push_parm_decl (parm);
7027     }
7028 
7029   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7030 
7031   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7032     {
7033       dummy = ffebld_head (dumlist);
7034       switch (ffebld_op (dummy))
7035 	{
7036 	case FFEBLD_opSTAR:
7037 	case FFEBLD_opANY:
7038 	  continue;		/* Forget alternate returns, they mean
7039 				   NOTHING! */
7040 
7041 	default:
7042 	  break;
7043 	}
7044       s = ffebld_symter (dummy);
7045       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7046 	continue;		/* Only looking for CHARACTER arguments. */
7047       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7048 	continue;		/* Stmtfunc arg with known size needs no
7049 				   length param. */
7050       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7051 	continue;		/* Only looking for variables and arrays. */
7052       parm = ffesymbol_hook (s).length_tree;
7053       assert (parm != NULL_TREE);
7054       if (parm != error_mark_node)
7055 	push_parm_decl (parm);
7056     }
7057 
7058   ffecom_transform_only_dummies_ = FALSE;
7059 }
7060 
7061 /* ffecom_start_progunit_ -- Beginning of program unit
7062 
7063    Does GNU back end stuff necessary to teach it about the start of its
7064    equivalent of a Fortran program unit.  */
7065 
7066 static void
ffecom_start_progunit_()7067 ffecom_start_progunit_ ()
7068 {
7069   ffesymbol fn = ffecom_primary_entry_;
7070   ffebld arglist;
7071   tree id;			/* Identifier (name) of function. */
7072   tree type;			/* Type of function. */
7073   tree result;			/* Result of function. */
7074   ffeinfoBasictype bt;
7075   ffeinfoKindtype kt;
7076   ffeglobal g;
7077   ffeglobalType gt;
7078   ffeglobalType egt = FFEGLOBAL_type;
7079   bool charfunc;
7080   bool cmplxfunc;
7081   bool altentries = (ffecom_num_entrypoints_ != 0);
7082   bool multi
7083   = altentries
7084   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7085   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7086   bool main_program = FALSE;
7087   int old_lineno = lineno;
7088   const char *old_input_filename = input_filename;
7089 
7090   assert (fn != NULL);
7091   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7092 
7093   input_filename = ffesymbol_where_filename (fn);
7094   lineno = ffesymbol_where_filelinenum (fn);
7095 
7096   switch (ffecom_primary_entry_kind_)
7097     {
7098     case FFEINFO_kindPROGRAM:
7099       main_program = TRUE;
7100       gt = FFEGLOBAL_typeMAIN;
7101       bt = FFEINFO_basictypeNONE;
7102       kt = FFEINFO_kindtypeNONE;
7103       type = ffecom_tree_fun_type_void;
7104       charfunc = FALSE;
7105       cmplxfunc = FALSE;
7106       break;
7107 
7108     case FFEINFO_kindBLOCKDATA:
7109       gt = FFEGLOBAL_typeBDATA;
7110       bt = FFEINFO_basictypeNONE;
7111       kt = FFEINFO_kindtypeNONE;
7112       type = ffecom_tree_fun_type_void;
7113       charfunc = FALSE;
7114       cmplxfunc = FALSE;
7115       break;
7116 
7117     case FFEINFO_kindFUNCTION:
7118       gt = FFEGLOBAL_typeFUNC;
7119       egt = FFEGLOBAL_typeEXT;
7120       bt = ffesymbol_basictype (fn);
7121       kt = ffesymbol_kindtype (fn);
7122       if (bt == FFEINFO_basictypeNONE)
7123 	{
7124 	  ffeimplic_establish_symbol (fn);
7125 	  if (ffesymbol_funcresult (fn) != NULL)
7126 	    ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7127 	  bt = ffesymbol_basictype (fn);
7128 	  kt = ffesymbol_kindtype (fn);
7129 	}
7130 
7131       if (multi)
7132 	charfunc = cmplxfunc = FALSE;
7133       else if (bt == FFEINFO_basictypeCHARACTER)
7134 	charfunc = TRUE, cmplxfunc = FALSE;
7135       else if ((bt == FFEINFO_basictypeCOMPLEX)
7136 	       && ffesymbol_is_f2c (fn)
7137 	       && !altentries)
7138 	charfunc = FALSE, cmplxfunc = TRUE;
7139       else
7140 	charfunc = cmplxfunc = FALSE;
7141 
7142       if (multi || charfunc)
7143 	type = ffecom_tree_fun_type_void;
7144       else if (ffesymbol_is_f2c (fn) && !altentries)
7145 	type = ffecom_tree_fun_type[bt][kt];
7146       else
7147 	type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7148 
7149       if ((type == NULL_TREE)
7150 	  || (TREE_TYPE (type) == NULL_TREE))
7151 	type = ffecom_tree_fun_type_void;	/* _sym_exec_transition. */
7152       break;
7153 
7154     case FFEINFO_kindSUBROUTINE:
7155       gt = FFEGLOBAL_typeSUBR;
7156       egt = FFEGLOBAL_typeEXT;
7157       bt = FFEINFO_basictypeNONE;
7158       kt = FFEINFO_kindtypeNONE;
7159       if (ffecom_is_altreturning_)
7160 	type = ffecom_tree_subr_type;
7161       else
7162 	type = ffecom_tree_fun_type_void;
7163       charfunc = FALSE;
7164       cmplxfunc = FALSE;
7165       break;
7166 
7167     default:
7168       assert ("say what??" == NULL);
7169       /* Fall through. */
7170     case FFEINFO_kindANY:
7171       gt = FFEGLOBAL_typeANY;
7172       bt = FFEINFO_basictypeNONE;
7173       kt = FFEINFO_kindtypeNONE;
7174       type = error_mark_node;
7175       charfunc = FALSE;
7176       cmplxfunc = FALSE;
7177       break;
7178     }
7179 
7180   if (altentries)
7181     {
7182       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7183 					   ffesymbol_text (fn));
7184     }
7185 #if FFETARGET_isENFORCED_MAIN
7186   else if (main_program)
7187     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7188 #endif
7189   else
7190     id = ffecom_get_external_identifier_ (fn);
7191 
7192   start_function (id,
7193 		  type,
7194 		  0,		/* nested/inline */
7195 		  !altentries);	/* TREE_PUBLIC */
7196 
7197   TREE_USED (current_function_decl) = 1;	/* Avoid spurious warning if altentries. */
7198 
7199   if (!altentries
7200       && ((g = ffesymbol_global (fn)) != NULL)
7201       && ((ffeglobal_type (g) == gt)
7202 	  || (ffeglobal_type (g) == egt)))
7203     {
7204       ffeglobal_set_hook (g, current_function_decl);
7205     }
7206 
7207   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7208      exec-transitioning needs current_function_decl to be filled in.  So we
7209      do these things in two phases. */
7210 
7211   if (altentries)
7212     {				/* 1st arg identifies which entrypoint. */
7213       ffecom_which_entrypoint_decl_
7214 	= build_decl (PARM_DECL,
7215 		      ffecom_get_invented_identifier ("__g77_%s",
7216 						      "which_entrypoint"),
7217 		      integer_type_node);
7218       push_parm_decl (ffecom_which_entrypoint_decl_);
7219     }
7220 
7221   if (charfunc
7222       || cmplxfunc
7223       || multi)
7224     {				/* Arg for result (return value). */
7225       tree type;
7226       tree length;
7227 
7228       if (charfunc)
7229 	type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7230       else if (cmplxfunc)
7231 	type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7232       else
7233 	type = ffecom_multi_type_node_;
7234 
7235       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7236 
7237       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7238 
7239       if (charfunc)
7240 	length = ffecom_char_enhance_arg_ (&type, fn);
7241       else
7242 	length = NULL_TREE;	/* Not ref'd if !charfunc. */
7243 
7244       type = build_pointer_type (type);
7245       result = build_decl (PARM_DECL, result, type);
7246 
7247       push_parm_decl (result);
7248       if (multi)
7249 	ffecom_multi_retval_ = result;
7250       else
7251 	ffecom_func_result_ = result;
7252 
7253       if (charfunc)
7254 	{
7255 	  push_parm_decl (length);
7256 	  ffecom_func_length_ = length;
7257 	}
7258     }
7259 
7260   if (ffecom_primary_entry_is_proc_)
7261     {
7262       if (altentries)
7263 	arglist = ffecom_master_arglist_;
7264       else
7265 	arglist = ffesymbol_dummyargs (fn);
7266       ffecom_push_dummy_decls_ (arglist, FALSE);
7267     }
7268 
7269   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7270     store_parm_decls (main_program ? 1 : 0);
7271 
7272   ffecom_start_compstmt ();
7273   /* Disallow temp vars at this level.  */
7274   current_binding_level->prep_state = 2;
7275 
7276   lineno = old_lineno;
7277   input_filename = old_input_filename;
7278 
7279   /* This handles any symbols still untransformed, in case -g specified.
7280      This used to be done in ffecom_finish_progunit, but it turns out to
7281      be necessary to do it here so that statement functions are
7282      expanded before code.  But don't bother for BLOCK DATA.  */
7283 
7284   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7285     ffesymbol_drive (ffecom_finish_symbol_transform_);
7286 }
7287 
7288 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7289 
7290    ffesymbol s;
7291    ffecom_sym_transform_(s);
7292 
7293    The ffesymbol_hook info for s is updated with appropriate backend info
7294    on the symbol.  */
7295 
7296 static ffesymbol
ffecom_sym_transform_(ffesymbol s)7297 ffecom_sym_transform_ (ffesymbol s)
7298 {
7299   tree t;			/* Transformed thingy. */
7300   tree tlen;			/* Length if CHAR*(*). */
7301   bool addr;			/* Is t the address of the thingy? */
7302   ffeinfoBasictype bt;
7303   ffeinfoKindtype kt;
7304   ffeglobal g;
7305   int old_lineno = lineno;
7306   const char *old_input_filename = input_filename;
7307 
7308   /* Must ensure special ASSIGN variables are declared at top of outermost
7309      block, else they'll end up in the innermost block when their first
7310      ASSIGN is seen, which leaves them out of scope when they're the
7311      subject of a GOTO or I/O statement.
7312 
7313      We make this variable even if -fugly-assign.  Just let it go unused,
7314      in case it turns out there are cases where we really want to use this
7315      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7316 
7317   if (! ffecom_transform_only_dummies_
7318       && ffesymbol_assigned (s)
7319       && ! ffesymbol_hook (s).assign_tree)
7320     s = ffecom_sym_transform_assign_ (s);
7321 
7322   if (ffesymbol_sfdummyparent (s) == NULL)
7323     {
7324       input_filename = ffesymbol_where_filename (s);
7325       lineno = ffesymbol_where_filelinenum (s);
7326     }
7327   else
7328     {
7329       ffesymbol sf = ffesymbol_sfdummyparent (s);
7330 
7331       input_filename = ffesymbol_where_filename (sf);
7332       lineno = ffesymbol_where_filelinenum (sf);
7333     }
7334 
7335   bt = ffeinfo_basictype (ffebld_info (s));
7336   kt = ffeinfo_kindtype (ffebld_info (s));
7337 
7338   t = NULL_TREE;
7339   tlen = NULL_TREE;
7340   addr = FALSE;
7341 
7342   switch (ffesymbol_kind (s))
7343     {
7344     case FFEINFO_kindNONE:
7345       switch (ffesymbol_where (s))
7346 	{
7347 	case FFEINFO_whereDUMMY:	/* Subroutine or function. */
7348 	  assert (ffecom_transform_only_dummies_);
7349 
7350 	  /* Before 0.4, this could be ENTITY/DUMMY, but see
7351 	     ffestu_sym_end_transition -- no longer true (in particular, if
7352 	     it could be an ENTITY, it _will_ be made one, so that
7353 	     possibility won't come through here).  So we never make length
7354 	     arg for CHARACTER type.  */
7355 
7356 	  t = build_decl (PARM_DECL,
7357 			  ffecom_get_identifier_ (ffesymbol_text (s)),
7358 			  ffecom_tree_ptr_to_subr_type);
7359 	  DECL_ARTIFICIAL (t) = 1;
7360 	  addr = TRUE;
7361 	  break;
7362 
7363 	case FFEINFO_whereGLOBAL:	/* Subroutine or function. */
7364 	  assert (!ffecom_transform_only_dummies_);
7365 
7366 	  if (((g = ffesymbol_global (s)) != NULL)
7367 	      && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7368 		  || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7369 		  || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7370 	      && (ffeglobal_hook (g) != NULL_TREE)
7371 	      && ffe_is_globals ())
7372 	    {
7373 	      t = ffeglobal_hook (g);
7374 	      break;
7375 	    }
7376 
7377 	  t = build_decl (FUNCTION_DECL,
7378 			  ffecom_get_external_identifier_ (s),
7379 			  ffecom_tree_subr_type);	/* Assume subr. */
7380 	  DECL_EXTERNAL (t) = 1;
7381 	  TREE_PUBLIC (t) = 1;
7382 
7383 	  t = start_decl (t, FALSE);
7384 	  finish_decl (t, NULL_TREE, FALSE);
7385 
7386 	  if ((g != NULL)
7387 	      && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7388 		  || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7389 		  || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7390 	    ffeglobal_set_hook (g, t);
7391 
7392 	  ffecom_save_tree_forever (t);
7393 
7394 	  break;
7395 
7396 	default:
7397 	  assert ("NONE where unexpected" == NULL);
7398 	  /* Fall through. */
7399 	case FFEINFO_whereANY:
7400 	  break;
7401 	}
7402       break;
7403 
7404     case FFEINFO_kindENTITY:
7405       switch (ffeinfo_where (ffesymbol_info (s)))
7406 	{
7407 
7408 	case FFEINFO_whereCONSTANT:
7409 	  /* ~~Debugging info needed? */
7410 	  assert (!ffecom_transform_only_dummies_);
7411 	  t = error_mark_node;	/* Shouldn't ever see this in expr. */
7412 	  break;
7413 
7414 	case FFEINFO_whereLOCAL:
7415 	  assert (!ffecom_transform_only_dummies_);
7416 
7417 	  {
7418 	    ffestorag st = ffesymbol_storage (s);
7419 	    tree type;
7420 
7421 	    if ((st != NULL)
7422 		&& (ffestorag_size (st) == 0))
7423 	      {
7424 		t = error_mark_node;
7425 		break;
7426 	      }
7427 
7428 	    type = ffecom_type_localvar_ (s, bt, kt);
7429 
7430 	    if (type == error_mark_node)
7431 	      {
7432 		t = error_mark_node;
7433 		break;
7434 	      }
7435 
7436 	    if ((st != NULL)
7437 		&& (ffestorag_parent (st) != NULL))
7438 	      {			/* Child of EQUIVALENCE parent. */
7439 		ffestorag est;
7440 		tree et;
7441 		ffetargetOffset offset;
7442 
7443 		est = ffestorag_parent (st);
7444 		ffecom_transform_equiv_ (est);
7445 
7446 		et = ffestorag_hook (est);
7447 		assert (et != NULL_TREE);
7448 
7449 		if (! TREE_STATIC (et))
7450 		  put_var_into_stack (et, /*rescan=*/true);
7451 
7452 		offset = ffestorag_modulo (est)
7453 		  + ffestorag_offset (ffesymbol_storage (s))
7454 		  - ffestorag_offset (est);
7455 
7456 		ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7457 
7458 		/* (t_type *) (((char *) &et) + offset) */
7459 
7460 		t = convert (string_type_node,	/* (char *) */
7461 			     ffecom_1 (ADDR_EXPR,
7462 				       build_pointer_type (TREE_TYPE (et)),
7463 				       et));
7464 		t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7465 			      t,
7466 			      build_int_2 (offset, 0));
7467 		t = convert (build_pointer_type (type),
7468 			     t);
7469 		TREE_CONSTANT (t) = staticp (et);
7470 
7471 		addr = TRUE;
7472 	      }
7473 	    else
7474 	      {
7475 		tree initexpr;
7476 		bool init = ffesymbol_is_init (s);
7477 
7478 		t = build_decl (VAR_DECL,
7479 				ffecom_get_identifier_ (ffesymbol_text (s)),
7480 				type);
7481 
7482 		if (init
7483 		    || ffesymbol_namelisted (s)
7484 #ifdef FFECOM_sizeMAXSTACKITEM
7485 		    || ((st != NULL)
7486 			&& (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7487 #endif
7488 		    || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7489 			&& (ffecom_primary_entry_kind_
7490 			    != FFEINFO_kindBLOCKDATA)
7491 			&& (ffesymbol_is_save (s) || ffe_is_saveall ())))
7492 		  TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7493 		else
7494 		  TREE_STATIC (t) = 0;	/* No need to make static. */
7495 
7496 		if (init || ffe_is_init_local_zero ())
7497 		  DECL_INITIAL (t) = error_mark_node;
7498 
7499 		/* Keep -Wunused from complaining about var if it
7500 		   is used as sfunc arg or DATA implied-DO.  */
7501 		if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7502 		  DECL_IN_SYSTEM_HEADER (t) = 1;
7503 
7504 		t = start_decl (t, FALSE);
7505 
7506 		if (init)
7507 		  {
7508 		    if (ffesymbol_init (s) != NULL)
7509 		      initexpr = ffecom_expr (ffesymbol_init (s));
7510 		    else
7511 		      initexpr = ffecom_init_zero_ (t);
7512 		  }
7513 		else if (ffe_is_init_local_zero ())
7514 		  initexpr = ffecom_init_zero_ (t);
7515 		else
7516 		  initexpr = NULL_TREE;	/* Not ref'd if !init. */
7517 
7518 		finish_decl (t, initexpr, FALSE);
7519 
7520 		if (st != NULL && DECL_SIZE (t) != error_mark_node)
7521 		  {
7522 		    assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7523 		    assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7524 						   ffestorag_size (st)));
7525 		  }
7526 	      }
7527 	  }
7528 	  break;
7529 
7530 	case FFEINFO_whereRESULT:
7531 	  assert (!ffecom_transform_only_dummies_);
7532 
7533 	  if (bt == FFEINFO_basictypeCHARACTER)
7534 	    {			/* Result is already in list of dummies, use
7535 				   it (& length). */
7536 	      t = ffecom_func_result_;
7537 	      tlen = ffecom_func_length_;
7538 	      addr = TRUE;
7539 	      break;
7540 	    }
7541 	  if ((ffecom_num_entrypoints_ == 0)
7542 	      && (bt == FFEINFO_basictypeCOMPLEX)
7543 	      && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7544 	    {			/* Result is already in list of dummies, use
7545 				   it. */
7546 	      t = ffecom_func_result_;
7547 	      addr = TRUE;
7548 	      break;
7549 	    }
7550 	  if (ffecom_func_result_ != NULL_TREE)
7551 	    {
7552 	      t = ffecom_func_result_;
7553 	      break;
7554 	    }
7555 	  if ((ffecom_num_entrypoints_ != 0)
7556 	      && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7557 	    {
7558 	      assert (ffecom_multi_retval_ != NULL_TREE);
7559 	      t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7560 			    ffecom_multi_retval_);
7561 	      t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7562 			    t, ffecom_multi_fields_[bt][kt]);
7563 
7564 	      break;
7565 	    }
7566 
7567 	  t = build_decl (VAR_DECL,
7568 			  ffecom_get_identifier_ (ffesymbol_text (s)),
7569 			  ffecom_tree_type[bt][kt]);
7570 	  TREE_STATIC (t) = 0;	/* Put result on stack. */
7571 	  t = start_decl (t, FALSE);
7572 	  finish_decl (t, NULL_TREE, FALSE);
7573 
7574 	  ffecom_func_result_ = t;
7575 
7576 	  break;
7577 
7578 	case FFEINFO_whereDUMMY:
7579 	  {
7580 	    tree type;
7581 	    ffebld dl;
7582 	    ffebld dim;
7583 	    tree low;
7584 	    tree high;
7585 	    tree old_sizes;
7586 	    bool adjustable = FALSE;	/* Conditionally adjustable? */
7587 
7588 	    type = ffecom_tree_type[bt][kt];
7589 	    if (ffesymbol_sfdummyparent (s) != NULL)
7590 	      {
7591 		if (current_function_decl == ffecom_outer_function_decl_)
7592 		  {			/* Exec transition before sfunc
7593 					   context; get it later. */
7594 		    break;
7595 		  }
7596 		t = ffecom_get_identifier_ (ffesymbol_text
7597 					    (ffesymbol_sfdummyparent (s)));
7598 	      }
7599 	    else
7600 	      t = ffecom_get_identifier_ (ffesymbol_text (s));
7601 
7602 	    assert (ffecom_transform_only_dummies_);
7603 
7604 	    old_sizes = get_pending_sizes ();
7605 	    put_pending_sizes (old_sizes);
7606 
7607 	    if (bt == FFEINFO_basictypeCHARACTER)
7608 	      tlen = ffecom_char_enhance_arg_ (&type, s);
7609 	    type = ffecom_check_size_overflow_ (s, type, TRUE);
7610 
7611 	    for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7612 	      {
7613 		if (type == error_mark_node)
7614 		  break;
7615 
7616 		dim = ffebld_head (dl);
7617 		assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7618 		if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7619 		  low = ffecom_integer_one_node;
7620 		else
7621 		  low = ffecom_expr (ffebld_left (dim));
7622 		assert (ffebld_right (dim) != NULL);
7623 		if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7624 		    || ffecom_doing_entry_)
7625 		  {
7626 		    /* Used to just do high=low.  But for ffecom_tree_
7627 		       canonize_ref_, it probably is important to correctly
7628 		       assess the size.  E.g. given COMPLEX C(*),CFUNC and
7629 		       C(2)=CFUNC(C), overlap can happen, while it can't
7630 		       for, say, C(1)=CFUNC(C(2)).  */
7631 		    /* Even more recently used to set to INT_MAX, but that
7632 		       broke when some overflow checking went into the back
7633 		       end.  Now we just leave the upper bound unspecified.  */
7634 		    high = NULL;
7635 		  }
7636 		else
7637 		  high = ffecom_expr (ffebld_right (dim));
7638 
7639 		/* Determine whether array is conditionally adjustable,
7640 		   to decide whether back-end magic is needed.
7641 
7642 		   Normally the front end uses the back-end function
7643 		   variable_size to wrap SAVE_EXPR's around expressions
7644 		   affecting the size/shape of an array so that the
7645 		   size/shape info doesn't change during execution
7646 		   of the compiled code even though variables and
7647 		   functions referenced in those expressions might.
7648 
7649 		   variable_size also makes sure those saved expressions
7650 		   get evaluated immediately upon entry to the
7651 		   compiled procedure -- the front end normally doesn't
7652 		   have to worry about that.
7653 
7654 		   However, there is a problem with this that affects
7655 		   g77's implementation of entry points, and that is
7656 		   that it is _not_ true that each invocation of the
7657 		   compiled procedure is permitted to evaluate
7658 		   array size/shape info -- because it is possible
7659 		   that, for some invocations, that info is invalid (in
7660 		   which case it is "promised" -- i.e. a violation of
7661 		   the Fortran standard -- that the compiled code
7662 		   won't reference the array or its size/shape
7663 		   during that particular invocation).
7664 
7665 		   To phrase this in C terms, consider this gcc function:
7666 
7667 		     void foo (int *n, float (*a)[*n])
7668 		     {
7669 		       // a is "pointer to array ...", fyi.
7670 		     }
7671 
7672 		   Suppose that, for some invocations, it is permitted
7673 		   for a caller of foo to do this:
7674 
7675 		       foo (NULL, NULL);
7676 
7677 		   Now the _written_ code for foo can take such a call
7678 		   into account by either testing explicitly for whether
7679 		   (a == NULL) || (n == NULL) -- presumably it is
7680 		   not permitted to reference *a in various fashions
7681 		   if (n == NULL) I suppose -- or it can avoid it by
7682 		   looking at other info (other arguments, static/global
7683 		   data, etc.).
7684 
7685 		   However, this won't work in gcc 2.5.8 because it'll
7686 		   automatically emit the code to save the "*n"
7687 		   expression, which'll yield a NULL dereference for
7688 		   the "foo (NULL, NULL)" call, something the code
7689 		   for foo cannot prevent.
7690 
7691 		   g77 definitely needs to avoid executing such
7692 		   code anytime the pointer to the adjustable array
7693 		   is NULL, because even if its bounds expressions
7694 		   don't have any references to possible "absent"
7695 		   variables like "*n" -- say all variable references
7696 		   are to COMMON variables, i.e. global (though in C,
7697 		   local static could actually make sense) -- the
7698 		   expressions could yield other run-time problems
7699 		   for allowably "dead" values in those variables.
7700 
7701 		   For example, let's consider a more complicated
7702 		   version of foo:
7703 
7704 		     extern int i;
7705 		     extern int j;
7706 
7707 		     void foo (float (*a)[i/j])
7708 		     {
7709 		       ...
7710 		     }
7711 
7712 		   The above is (essentially) quite valid for Fortran
7713 		   but, again, for a call like "foo (NULL);", it is
7714 		   permitted for i and j to be undefined when the
7715 		   call is made.  If j happened to be zero, for
7716 		   example, emitting the code to evaluate "i/j"
7717 		   could result in a run-time error.
7718 
7719 		   Offhand, though I don't have my F77 or F90
7720 		   standards handy, it might even be valid for a
7721 		   bounds expression to contain a function reference,
7722 		   in which case I doubt it is permitted for an
7723 		   implementation to invoke that function in the
7724 		   Fortran case involved here (invocation of an
7725 		   alternate ENTRY point that doesn't have the adjustable
7726 		   array as one of its arguments).
7727 
7728 		   So, the code that the compiler would normally emit
7729 		   to preevaluate the size/shape info for an
7730 		   adjustable array _must not_ be executed at run time
7731 		   in certain cases.  Specifically, for Fortran,
7732 		   the case is when the pointer to the adjustable
7733 		   array == NULL.  (For gnu-ish C, it might be nice
7734 		   for the source code itself to specify an expression
7735 		   that, if TRUE, inhibits execution of the code.  Or
7736 		   reverse the sense for elegance.)
7737 
7738 		   (Note that g77 could use a different test than NULL,
7739 		   actually, since it happens to always pass an
7740 		   integer to the called function that specifies which
7741 		   entry point is being invoked.  Hmm, this might
7742 		   solve the next problem.)
7743 
7744 		   One way a user could, I suppose, write "foo" so
7745 		   it works is to insert COND_EXPR's for the
7746 		   size/shape info so the dangerous stuff isn't
7747 		   actually done, as in:
7748 
7749 		     void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7750 		     {
7751 		       ...
7752 		     }
7753 
7754 		   The next problem is that the front end needs to
7755 		   be able to tell the back end about the array's
7756 		   decl _before_ it tells it about the conditional
7757 		   expression to inhibit evaluation of size/shape info,
7758 		   as shown above.
7759 
7760 		   To solve this, the front end needs to be able
7761 		   to give the back end the expression to inhibit
7762 		   generation of the preevaluation code _after_
7763 		   it makes the decl for the adjustable array.
7764 
7765 		   Until then, the above example using the COND_EXPR
7766 		   doesn't pass muster with gcc because the "(a == NULL)"
7767 		   part has a reference to "a", which is still
7768 		   undefined at that point.
7769 
7770 		   g77 will therefore use a different mechanism in the
7771 		   meantime.  */
7772 
7773 		if (!adjustable
7774 		    && ((TREE_CODE (low) != INTEGER_CST)
7775 			|| (high && TREE_CODE (high) != INTEGER_CST)))
7776 		  adjustable = TRUE;
7777 
7778 #if 0				/* Old approach -- see below. */
7779 		if (TREE_CODE (low) != INTEGER_CST)
7780 		  low = ffecom_3 (COND_EXPR, integer_type_node,
7781 				  ffecom_adjarray_passed_ (s),
7782 				  low,
7783 				  ffecom_integer_zero_node);
7784 
7785 		if (high && TREE_CODE (high) != INTEGER_CST)
7786 		  high = ffecom_3 (COND_EXPR, integer_type_node,
7787 				   ffecom_adjarray_passed_ (s),
7788 				   high,
7789 				   ffecom_integer_zero_node);
7790 #endif
7791 
7792 		/* ~~~gcc/stor-layout.c (layout_type) should do this,
7793 		   probably.  Fixes 950302-1.f.  */
7794 
7795 		if (TREE_CODE (low) != INTEGER_CST)
7796 		  low = variable_size (low);
7797 
7798 		/* ~~~Similarly, this fixes dumb0.f.  The C front end
7799 		   does this, which is why dumb0.c would work.  */
7800 
7801 		if (high && TREE_CODE (high) != INTEGER_CST)
7802 		  high = variable_size (high);
7803 
7804 		type
7805 		  = build_array_type
7806 		    (type,
7807 		     build_range_type (ffecom_integer_type_node,
7808 				       low, high));
7809 		type = ffecom_check_size_overflow_ (s, type, TRUE);
7810 	      }
7811 
7812 	    if (type == error_mark_node)
7813 	      {
7814 		t = error_mark_node;
7815 		break;
7816 	      }
7817 
7818 	    if ((ffesymbol_sfdummyparent (s) == NULL)
7819 		 || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7820 	      {
7821 		type = build_pointer_type (type);
7822 		addr = TRUE;
7823 	      }
7824 
7825 	    t = build_decl (PARM_DECL, t, type);
7826 	    DECL_ARTIFICIAL (t) = 1;
7827 
7828 	    /* If this arg is present in every entry point's list of
7829 	       dummy args, then we're done.  */
7830 
7831 	    if (ffesymbol_numentries (s)
7832 		== (ffecom_num_entrypoints_ + 1))
7833 	      break;
7834 
7835 #if 1
7836 
7837 	    /* If variable_size in stor-layout has been called during
7838 	       the above, then get_pending_sizes should have the
7839 	       yet-to-be-evaluated saved expressions pending.
7840 	       Make the whole lot of them get emitted, conditionally
7841 	       on whether the array decl ("t" above) is not NULL.  */
7842 
7843 	    {
7844 	      tree sizes = get_pending_sizes ();
7845 	      tree tem;
7846 
7847 	      for (tem = sizes;
7848 		   tem != old_sizes;
7849 		   tem = TREE_CHAIN (tem))
7850 		{
7851 		  tree temv = TREE_VALUE (tem);
7852 
7853 		  if (sizes == tem)
7854 		    sizes = temv;
7855 		  else
7856 		    sizes
7857 		      = ffecom_2 (COMPOUND_EXPR,
7858 				  TREE_TYPE (sizes),
7859 				  temv,
7860 				  sizes);
7861 		}
7862 
7863 	      if (sizes != tem)
7864 		{
7865 		  sizes
7866 		    = ffecom_3 (COND_EXPR,
7867 				TREE_TYPE (sizes),
7868 				ffecom_2 (NE_EXPR,
7869 					  integer_type_node,
7870 					  t,
7871 					  null_pointer_node),
7872 				sizes,
7873 				convert (TREE_TYPE (sizes),
7874 					 integer_zero_node));
7875 		  sizes = ffecom_save_tree (sizes);
7876 
7877 		  sizes
7878 		    = tree_cons (NULL_TREE, sizes, tem);
7879 		}
7880 
7881 	      if (sizes)
7882 		put_pending_sizes (sizes);
7883 	    }
7884 
7885 #else
7886 #if 0
7887 	    if (adjustable
7888 		&& (ffesymbol_numentries (s)
7889 		    != ffecom_num_entrypoints_ + 1))
7890 	      DECL_SOMETHING (t)
7891 		= ffecom_2 (NE_EXPR, integer_type_node,
7892 			    t,
7893 			    null_pointer_node);
7894 #else
7895 #if 0
7896 	    if (adjustable
7897 		&& (ffesymbol_numentries (s)
7898 		    != ffecom_num_entrypoints_ + 1))
7899 	      {
7900 		ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
7901 		ffebad_here (0, ffesymbol_where_line (s),
7902 			     ffesymbol_where_column (s));
7903 		ffebad_string (ffesymbol_text (s));
7904 		ffebad_finish ();
7905 	      }
7906 #endif
7907 #endif
7908 #endif
7909 	  }
7910 	  break;
7911 
7912 	case FFEINFO_whereCOMMON:
7913 	  {
7914 	    ffesymbol cs;
7915 	    ffeglobal cg;
7916 	    tree ct;
7917 	    ffestorag st = ffesymbol_storage (s);
7918 	    tree type;
7919 
7920 	    cs = ffesymbol_common (s);	/* The COMMON area itself.  */
7921 	    if (st != NULL)	/* Else not laid out. */
7922 	      {
7923 		ffecom_transform_common_ (cs);
7924 		st = ffesymbol_storage (s);
7925 	      }
7926 
7927 	    type = ffecom_type_localvar_ (s, bt, kt);
7928 
7929 	    cg = ffesymbol_global (cs);	/* The global COMMON info.  */
7930 	    if ((cg == NULL)
7931 		|| (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
7932 	      ct = NULL_TREE;
7933 	    else
7934 	      ct = ffeglobal_hook (cg);	/* The common area's tree.  */
7935 
7936 	    if ((ct == NULL_TREE)
7937 		|| (st == NULL)
7938 		|| (type == error_mark_node))
7939 	      t = error_mark_node;
7940 	    else
7941 	      {
7942 		ffetargetOffset offset;
7943 		ffestorag cst;
7944 
7945 		cst = ffestorag_parent (st);
7946 		assert (cst == ffesymbol_storage (cs));
7947 
7948 		offset = ffestorag_modulo (cst)
7949 		  + ffestorag_offset (st)
7950 		  - ffestorag_offset (cst);
7951 
7952 		ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
7953 
7954 		/* (t_type *) (((char *) &ct) + offset) */
7955 
7956 		t = convert (string_type_node,	/* (char *) */
7957 			     ffecom_1 (ADDR_EXPR,
7958 				       build_pointer_type (TREE_TYPE (ct)),
7959 				       ct));
7960 		t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7961 			      t,
7962 			      build_int_2 (offset, 0));
7963 		t = convert (build_pointer_type (type),
7964 			     t);
7965 		TREE_CONSTANT (t) = 1;
7966 
7967 		addr = TRUE;
7968 	      }
7969 	  }
7970 	  break;
7971 
7972 	case FFEINFO_whereIMMEDIATE:
7973 	case FFEINFO_whereGLOBAL:
7974 	case FFEINFO_whereFLEETING:
7975 	case FFEINFO_whereFLEETING_CADDR:
7976 	case FFEINFO_whereFLEETING_IADDR:
7977 	case FFEINFO_whereINTRINSIC:
7978 	case FFEINFO_whereCONSTANT_SUBOBJECT:
7979 	default:
7980 	  assert ("ENTITY where unheard of" == NULL);
7981 	  /* Fall through. */
7982 	case FFEINFO_whereANY:
7983 	  t = error_mark_node;
7984 	  break;
7985 	}
7986       break;
7987 
7988     case FFEINFO_kindFUNCTION:
7989       switch (ffeinfo_where (ffesymbol_info (s)))
7990 	{
7991 	case FFEINFO_whereLOCAL:	/* Me. */
7992 	  assert (!ffecom_transform_only_dummies_);
7993 	  t = current_function_decl;
7994 	  break;
7995 
7996 	case FFEINFO_whereGLOBAL:
7997 	  assert (!ffecom_transform_only_dummies_);
7998 
7999 	  if (((g = ffesymbol_global (s)) != NULL)
8000 	      && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8001 		  || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8002 	      && (ffeglobal_hook (g) != NULL_TREE)
8003 	      && ffe_is_globals ())
8004 	    {
8005 	      t = ffeglobal_hook (g);
8006 	      break;
8007 	    }
8008 
8009 	  if (ffesymbol_is_f2c (s)
8010 	      && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8011 	    t = ffecom_tree_fun_type[bt][kt];
8012 	  else
8013 	    t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8014 
8015 	  t = build_decl (FUNCTION_DECL,
8016 			  ffecom_get_external_identifier_ (s),
8017 			  t);
8018 	  DECL_EXTERNAL (t) = 1;
8019 	  TREE_PUBLIC (t) = 1;
8020 
8021 	  t = start_decl (t, FALSE);
8022 	  finish_decl (t, NULL_TREE, FALSE);
8023 
8024 	  if ((g != NULL)
8025 	      && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8026 		  || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8027 	    ffeglobal_set_hook (g, t);
8028 
8029 	  ffecom_save_tree_forever (t);
8030 
8031 	  break;
8032 
8033 	case FFEINFO_whereDUMMY:
8034 	  assert (ffecom_transform_only_dummies_);
8035 
8036 	  if (ffesymbol_is_f2c (s)
8037 	      && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8038 	    t = ffecom_tree_ptr_to_fun_type[bt][kt];
8039 	  else
8040 	    t = build_pointer_type
8041 	      (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8042 
8043 	  t = build_decl (PARM_DECL,
8044 			  ffecom_get_identifier_ (ffesymbol_text (s)),
8045 			  t);
8046 	  DECL_ARTIFICIAL (t) = 1;
8047 	  addr = TRUE;
8048 	  break;
8049 
8050 	case FFEINFO_whereCONSTANT:	/* Statement function. */
8051 	  assert (!ffecom_transform_only_dummies_);
8052 	  t = ffecom_gen_sfuncdef_ (s, bt, kt);
8053 	  break;
8054 
8055 	case FFEINFO_whereINTRINSIC:
8056 	  assert (!ffecom_transform_only_dummies_);
8057 	  break;		/* Let actual references generate their
8058 				   decls. */
8059 
8060 	default:
8061 	  assert ("FUNCTION where unheard of" == NULL);
8062 	  /* Fall through. */
8063 	case FFEINFO_whereANY:
8064 	  t = error_mark_node;
8065 	  break;
8066 	}
8067       break;
8068 
8069     case FFEINFO_kindSUBROUTINE:
8070       switch (ffeinfo_where (ffesymbol_info (s)))
8071 	{
8072 	case FFEINFO_whereLOCAL:	/* Me. */
8073 	  assert (!ffecom_transform_only_dummies_);
8074 	  t = current_function_decl;
8075 	  break;
8076 
8077 	case FFEINFO_whereGLOBAL:
8078 	  assert (!ffecom_transform_only_dummies_);
8079 
8080 	  if (((g = ffesymbol_global (s)) != NULL)
8081 	      && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8082 		  || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8083 	      && (ffeglobal_hook (g) != NULL_TREE)
8084 	      && ffe_is_globals ())
8085 	    {
8086 	      t = ffeglobal_hook (g);
8087 	      break;
8088 	    }
8089 
8090 	  t = build_decl (FUNCTION_DECL,
8091 			  ffecom_get_external_identifier_ (s),
8092 			  ffecom_tree_subr_type);
8093 	  DECL_EXTERNAL (t) = 1;
8094 	  TREE_PUBLIC (t) = 1;
8095 
8096 	  t = start_decl (t, ffe_is_globals ());
8097 	  finish_decl (t, NULL_TREE, ffe_is_globals ());
8098 
8099 	  if ((g != NULL)
8100 	      && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8101 		  || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8102 	    ffeglobal_set_hook (g, t);
8103 
8104 	  ffecom_save_tree_forever (t);
8105 
8106 	  break;
8107 
8108 	case FFEINFO_whereDUMMY:
8109 	  assert (ffecom_transform_only_dummies_);
8110 
8111 	  t = build_decl (PARM_DECL,
8112 			  ffecom_get_identifier_ (ffesymbol_text (s)),
8113 			  ffecom_tree_ptr_to_subr_type);
8114 	  DECL_ARTIFICIAL (t) = 1;
8115 	  addr = TRUE;
8116 	  break;
8117 
8118 	case FFEINFO_whereINTRINSIC:
8119 	  assert (!ffecom_transform_only_dummies_);
8120 	  break;		/* Let actual references generate their
8121 				   decls. */
8122 
8123 	default:
8124 	  assert ("SUBROUTINE where unheard of" == NULL);
8125 	  /* Fall through. */
8126 	case FFEINFO_whereANY:
8127 	  t = error_mark_node;
8128 	  break;
8129 	}
8130       break;
8131 
8132     case FFEINFO_kindPROGRAM:
8133       switch (ffeinfo_where (ffesymbol_info (s)))
8134 	{
8135 	case FFEINFO_whereLOCAL:	/* Me. */
8136 	  assert (!ffecom_transform_only_dummies_);
8137 	  t = current_function_decl;
8138 	  break;
8139 
8140 	case FFEINFO_whereCOMMON:
8141 	case FFEINFO_whereDUMMY:
8142 	case FFEINFO_whereGLOBAL:
8143 	case FFEINFO_whereRESULT:
8144 	case FFEINFO_whereFLEETING:
8145 	case FFEINFO_whereFLEETING_CADDR:
8146 	case FFEINFO_whereFLEETING_IADDR:
8147 	case FFEINFO_whereIMMEDIATE:
8148 	case FFEINFO_whereINTRINSIC:
8149 	case FFEINFO_whereCONSTANT:
8150 	case FFEINFO_whereCONSTANT_SUBOBJECT:
8151 	default:
8152 	  assert ("PROGRAM where unheard of" == NULL);
8153 	  /* Fall through. */
8154 	case FFEINFO_whereANY:
8155 	  t = error_mark_node;
8156 	  break;
8157 	}
8158       break;
8159 
8160     case FFEINFO_kindBLOCKDATA:
8161       switch (ffeinfo_where (ffesymbol_info (s)))
8162 	{
8163 	case FFEINFO_whereLOCAL:	/* Me. */
8164 	  assert (!ffecom_transform_only_dummies_);
8165 	  t = current_function_decl;
8166 	  break;
8167 
8168 	case FFEINFO_whereGLOBAL:
8169 	  assert (!ffecom_transform_only_dummies_);
8170 
8171 	  t = build_decl (FUNCTION_DECL,
8172 			  ffecom_get_external_identifier_ (s),
8173 			  ffecom_tree_blockdata_type);
8174 	  DECL_EXTERNAL (t) = 1;
8175 	  TREE_PUBLIC (t) = 1;
8176 
8177 	  t = start_decl (t, FALSE);
8178 	  finish_decl (t, NULL_TREE, FALSE);
8179 
8180 	  ffecom_save_tree_forever (t);
8181 
8182 	  break;
8183 
8184 	case FFEINFO_whereCOMMON:
8185 	case FFEINFO_whereDUMMY:
8186 	case FFEINFO_whereRESULT:
8187 	case FFEINFO_whereFLEETING:
8188 	case FFEINFO_whereFLEETING_CADDR:
8189 	case FFEINFO_whereFLEETING_IADDR:
8190 	case FFEINFO_whereIMMEDIATE:
8191 	case FFEINFO_whereINTRINSIC:
8192 	case FFEINFO_whereCONSTANT:
8193 	case FFEINFO_whereCONSTANT_SUBOBJECT:
8194 	default:
8195 	  assert ("BLOCKDATA where unheard of" == NULL);
8196 	  /* Fall through. */
8197 	case FFEINFO_whereANY:
8198 	  t = error_mark_node;
8199 	  break;
8200 	}
8201       break;
8202 
8203     case FFEINFO_kindCOMMON:
8204       switch (ffeinfo_where (ffesymbol_info (s)))
8205 	{
8206 	case FFEINFO_whereLOCAL:
8207 	  assert (!ffecom_transform_only_dummies_);
8208 	  ffecom_transform_common_ (s);
8209 	  break;
8210 
8211 	case FFEINFO_whereNONE:
8212 	case FFEINFO_whereCOMMON:
8213 	case FFEINFO_whereDUMMY:
8214 	case FFEINFO_whereGLOBAL:
8215 	case FFEINFO_whereRESULT:
8216 	case FFEINFO_whereFLEETING:
8217 	case FFEINFO_whereFLEETING_CADDR:
8218 	case FFEINFO_whereFLEETING_IADDR:
8219 	case FFEINFO_whereIMMEDIATE:
8220 	case FFEINFO_whereINTRINSIC:
8221 	case FFEINFO_whereCONSTANT:
8222 	case FFEINFO_whereCONSTANT_SUBOBJECT:
8223 	default:
8224 	  assert ("COMMON where unheard of" == NULL);
8225 	  /* Fall through. */
8226 	case FFEINFO_whereANY:
8227 	  t = error_mark_node;
8228 	  break;
8229 	}
8230       break;
8231 
8232     case FFEINFO_kindCONSTRUCT:
8233       switch (ffeinfo_where (ffesymbol_info (s)))
8234 	{
8235 	case FFEINFO_whereLOCAL:
8236 	  assert (!ffecom_transform_only_dummies_);
8237 	  break;
8238 
8239 	case FFEINFO_whereNONE:
8240 	case FFEINFO_whereCOMMON:
8241 	case FFEINFO_whereDUMMY:
8242 	case FFEINFO_whereGLOBAL:
8243 	case FFEINFO_whereRESULT:
8244 	case FFEINFO_whereFLEETING:
8245 	case FFEINFO_whereFLEETING_CADDR:
8246 	case FFEINFO_whereFLEETING_IADDR:
8247 	case FFEINFO_whereIMMEDIATE:
8248 	case FFEINFO_whereINTRINSIC:
8249 	case FFEINFO_whereCONSTANT:
8250 	case FFEINFO_whereCONSTANT_SUBOBJECT:
8251 	default:
8252 	  assert ("CONSTRUCT where unheard of" == NULL);
8253 	  /* Fall through. */
8254 	case FFEINFO_whereANY:
8255 	  t = error_mark_node;
8256 	  break;
8257 	}
8258       break;
8259 
8260     case FFEINFO_kindNAMELIST:
8261       switch (ffeinfo_where (ffesymbol_info (s)))
8262 	{
8263 	case FFEINFO_whereLOCAL:
8264 	  assert (!ffecom_transform_only_dummies_);
8265 	  t = ffecom_transform_namelist_ (s);
8266 	  break;
8267 
8268 	case FFEINFO_whereNONE:
8269 	case FFEINFO_whereCOMMON:
8270 	case FFEINFO_whereDUMMY:
8271 	case FFEINFO_whereGLOBAL:
8272 	case FFEINFO_whereRESULT:
8273 	case FFEINFO_whereFLEETING:
8274 	case FFEINFO_whereFLEETING_CADDR:
8275 	case FFEINFO_whereFLEETING_IADDR:
8276 	case FFEINFO_whereIMMEDIATE:
8277 	case FFEINFO_whereINTRINSIC:
8278 	case FFEINFO_whereCONSTANT:
8279 	case FFEINFO_whereCONSTANT_SUBOBJECT:
8280 	default:
8281 	  assert ("NAMELIST where unheard of" == NULL);
8282 	  /* Fall through. */
8283 	case FFEINFO_whereANY:
8284 	  t = error_mark_node;
8285 	  break;
8286 	}
8287       break;
8288 
8289     default:
8290       assert ("kind unheard of" == NULL);
8291       /* Fall through. */
8292     case FFEINFO_kindANY:
8293       t = error_mark_node;
8294       break;
8295     }
8296 
8297   ffesymbol_hook (s).decl_tree = t;
8298   ffesymbol_hook (s).length_tree = tlen;
8299   ffesymbol_hook (s).addr = addr;
8300 
8301   lineno = old_lineno;
8302   input_filename = old_input_filename;
8303 
8304   return s;
8305 }
8306 
8307 /* Transform into ASSIGNable symbol.
8308 
8309    Symbol has already been transformed, but for whatever reason, the
8310    resulting decl_tree has been deemed not usable for an ASSIGN target.
8311    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8312    another local symbol of type void * and stuff that in the assign_tree
8313    argument.  The F77/F90 standards allow this implementation.  */
8314 
8315 static ffesymbol
ffecom_sym_transform_assign_(ffesymbol s)8316 ffecom_sym_transform_assign_ (ffesymbol s)
8317 {
8318   tree t;			/* Transformed thingy. */
8319   int old_lineno = lineno;
8320   const char *old_input_filename = input_filename;
8321 
8322   if (ffesymbol_sfdummyparent (s) == NULL)
8323     {
8324       input_filename = ffesymbol_where_filename (s);
8325       lineno = ffesymbol_where_filelinenum (s);
8326     }
8327   else
8328     {
8329       ffesymbol sf = ffesymbol_sfdummyparent (s);
8330 
8331       input_filename = ffesymbol_where_filename (sf);
8332       lineno = ffesymbol_where_filelinenum (sf);
8333     }
8334 
8335   assert (!ffecom_transform_only_dummies_);
8336 
8337   t = build_decl (VAR_DECL,
8338 		  ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8339 						   ffesymbol_text (s)),
8340 		  TREE_TYPE (null_pointer_node));
8341 
8342   switch (ffesymbol_where (s))
8343     {
8344     case FFEINFO_whereLOCAL:
8345       /* Unlike for regular vars, SAVE status is easy to determine for
8346 	 ASSIGNed vars, since there's no initialization, there's no
8347 	 effective storage association (so "SAVE J" does not apply to
8348 	 K even given "EQUIVALENCE (J,K)"), there's no size issue
8349 	 to worry about, etc.  */
8350       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8351 	  && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8352 	  && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8353 	TREE_STATIC (t) = 1;	/* SAVEd in proc, make static. */
8354       else
8355 	TREE_STATIC (t) = 0;	/* No need to make static. */
8356       break;
8357 
8358     case FFEINFO_whereCOMMON:
8359       TREE_STATIC (t) = 1;	/* Assume COMMONs always SAVEd. */
8360       break;
8361 
8362     case FFEINFO_whereDUMMY:
8363       /* Note that twinning a DUMMY means the caller won't see
8364 	 the ASSIGNed value.  But both F77 and F90 allow implementations
8365 	 to do this, i.e. disallow Fortran code that would try and
8366 	 take advantage of actually putting a label into a variable
8367 	 via a dummy argument (or any other storage association, for
8368 	 that matter).  */
8369       TREE_STATIC (t) = 0;
8370       break;
8371 
8372     default:
8373       TREE_STATIC (t) = 0;
8374       break;
8375     }
8376 
8377   t = start_decl (t, FALSE);
8378   finish_decl (t, NULL_TREE, FALSE);
8379 
8380   ffesymbol_hook (s).assign_tree = t;
8381 
8382   lineno = old_lineno;
8383   input_filename = old_input_filename;
8384 
8385   return s;
8386 }
8387 
8388 /* Implement COMMON area in back end.
8389 
8390    Because COMMON-based variables can be referenced in the dimension
8391    expressions of dummy (adjustable) arrays, and because dummies
8392    (in the gcc back end) need to be put in the outer binding level
8393    of a function (which has two binding levels, the outer holding
8394    the dummies and the inner holding the other vars), special care
8395    must be taken to handle COMMON areas.
8396 
8397    The current strategy is basically to always tell the back end about
8398    the COMMON area as a top-level external reference to just a block
8399    of storage of the master type of that area (e.g. integer, real,
8400    character, whatever -- not a structure).  As a distinct action,
8401    if initial values are provided, tell the back end about the area
8402    as a top-level non-external (initialized) area and remember not to
8403    allow further initialization or expansion of the area.  Meanwhile,
8404    if no initialization happens at all, tell the back end about
8405    the largest size we've seen declared so the space does get reserved.
8406    (This function doesn't handle all that stuff, but it does some
8407    of the important things.)
8408 
8409    Meanwhile, for COMMON variables themselves, just keep creating
8410    references like *((float *) (&common_area + offset)) each time
8411    we reference the variable.  In other words, don't make a VAR_DECL
8412    or any kind of component reference (like we used to do before 0.4),
8413    though we might do that as well just for debugging purposes (and
8414    stuff the rtl with the appropriate offset expression).  */
8415 
8416 static void
ffecom_transform_common_(ffesymbol s)8417 ffecom_transform_common_ (ffesymbol s)
8418 {
8419   ffestorag st = ffesymbol_storage (s);
8420   ffeglobal g = ffesymbol_global (s);
8421   tree cbt;
8422   tree cbtype;
8423   tree init;
8424   tree high;
8425   bool is_init = ffestorag_is_init (st);
8426 
8427   assert (st != NULL);
8428 
8429   if ((g == NULL)
8430       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8431     return;
8432 
8433   /* First update the size of the area in global terms.  */
8434 
8435   ffeglobal_size_common (s, ffestorag_size (st));
8436 
8437   if (!ffeglobal_common_init (g))
8438     is_init = FALSE;	/* No explicit init, don't let erroneous joins init. */
8439 
8440   cbt = ffeglobal_hook (g);
8441 
8442   /* If we already have declared this common block for a previous program
8443      unit, and either we already initialized it or we don't have new
8444      initialization for it, just return what we have without changing it.  */
8445 
8446   if ((cbt != NULL_TREE)
8447       && (!is_init
8448 	  || !DECL_EXTERNAL (cbt)))
8449     {
8450       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8451       return;
8452     }
8453 
8454   /* Process inits.  */
8455 
8456   if (is_init)
8457     {
8458       if (ffestorag_init (st) != NULL)
8459 	{
8460 	  ffebld sexp;
8461 
8462 	  /* Set the padding for the expression, so ffecom_expr
8463 	     knows to insert that many zeros.  */
8464 	  switch (ffebld_op (sexp = ffestorag_init (st)))
8465 	    {
8466 	    case FFEBLD_opCONTER:
8467 	      ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8468 	      break;
8469 
8470 	    case FFEBLD_opARRTER:
8471 	      ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8472 	      break;
8473 
8474 	    case FFEBLD_opACCTER:
8475 	      ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8476 	      break;
8477 
8478 	    default:
8479 	      assert ("bad op for cmn init (pad)" == NULL);
8480 	      break;
8481 	    }
8482 
8483 	  init = ffecom_expr (sexp);
8484 	  if (init == error_mark_node)
8485 	    {			/* Hopefully the back end complained! */
8486 	      init = NULL_TREE;
8487 	      if (cbt != NULL_TREE)
8488 		return;
8489 	    }
8490 	}
8491       else
8492 	init = error_mark_node;
8493     }
8494   else
8495     init = NULL_TREE;
8496 
8497   /* cbtype must be permanently allocated!  */
8498 
8499   /* Allocate the MAX of the areas so far, seen filewide.  */
8500   high = build_int_2 ((ffeglobal_common_size (g)
8501 		       + ffeglobal_common_pad (g)) - 1, 0);
8502   TREE_TYPE (high) = ffecom_integer_type_node;
8503 
8504   if (init)
8505     cbtype = build_array_type (char_type_node,
8506 			       build_range_type (integer_type_node,
8507 						 integer_zero_node,
8508 						 high));
8509   else
8510     cbtype = build_array_type (char_type_node, NULL_TREE);
8511 
8512   if (cbt == NULL_TREE)
8513     {
8514       cbt
8515 	= build_decl (VAR_DECL,
8516 		      ffecom_get_external_identifier_ (s),
8517 		      cbtype);
8518       TREE_STATIC (cbt) = 1;
8519       TREE_PUBLIC (cbt) = 1;
8520     }
8521   else
8522     {
8523       assert (is_init);
8524       TREE_TYPE (cbt) = cbtype;
8525     }
8526   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8527   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8528 
8529   cbt = start_decl (cbt, TRUE);
8530   if (ffeglobal_hook (g) != NULL)
8531     assert (cbt == ffeglobal_hook (g));
8532 
8533   assert (!init || !DECL_EXTERNAL (cbt));
8534 
8535   /* Make sure that any type can live in COMMON and be referenced
8536      without getting a bus error.  We could pick the most restrictive
8537      alignment of all entities actually placed in the COMMON, but
8538      this seems easy enough.  */
8539 
8540   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8541   DECL_USER_ALIGN (cbt) = 0;
8542 
8543   if (is_init && (ffestorag_init (st) == NULL))
8544     init = ffecom_init_zero_ (cbt);
8545 
8546   finish_decl (cbt, init, TRUE);
8547 
8548   if (is_init)
8549     ffestorag_set_init (st, ffebld_new_any ());
8550 
8551   if (init)
8552     {
8553       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8554       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8555       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8556 				     (ffeglobal_common_size (g)
8557 				      + ffeglobal_common_pad (g))));
8558     }
8559 
8560   ffeglobal_set_hook (g, cbt);
8561 
8562   ffestorag_set_hook (st, cbt);
8563 
8564   ffecom_save_tree_forever (cbt);
8565 }
8566 
8567 /* Make master area for local EQUIVALENCE.  */
8568 
8569 static void
ffecom_transform_equiv_(ffestorag eqst)8570 ffecom_transform_equiv_ (ffestorag eqst)
8571 {
8572   tree eqt;
8573   tree eqtype;
8574   tree init;
8575   tree high;
8576   bool is_init = ffestorag_is_init (eqst);
8577 
8578   assert (eqst != NULL);
8579 
8580   eqt = ffestorag_hook (eqst);
8581 
8582   if (eqt != NULL_TREE)
8583     return;
8584 
8585   /* Process inits.  */
8586 
8587   if (is_init)
8588     {
8589       if (ffestorag_init (eqst) != NULL)
8590 	{
8591 	  ffebld sexp;
8592 
8593 	  /* Set the padding for the expression, so ffecom_expr
8594 	     knows to insert that many zeros.  */
8595 	  switch (ffebld_op (sexp = ffestorag_init (eqst)))
8596 	    {
8597 	    case FFEBLD_opCONTER:
8598 	      ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8599 	      break;
8600 
8601 	    case FFEBLD_opARRTER:
8602 	      ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8603 	      break;
8604 
8605 	    case FFEBLD_opACCTER:
8606 	      ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8607 	      break;
8608 
8609 	    default:
8610 	      assert ("bad op for eqv init (pad)" == NULL);
8611 	      break;
8612 	    }
8613 
8614 	  init = ffecom_expr (sexp);
8615 	  if (init == error_mark_node)
8616 	    init = NULL_TREE;	/* Hopefully the back end complained! */
8617 	}
8618       else
8619 	init = error_mark_node;
8620     }
8621   else if (ffe_is_init_local_zero ())
8622     init = error_mark_node;
8623   else
8624     init = NULL_TREE;
8625 
8626   ffecom_member_namelisted_ = FALSE;
8627   ffestorag_drive (ffestorag_list_equivs (eqst),
8628 		   &ffecom_member_phase1_,
8629 		   eqst);
8630 
8631   high = build_int_2 ((ffestorag_size (eqst)
8632 		       + ffestorag_modulo (eqst)) - 1, 0);
8633   TREE_TYPE (high) = ffecom_integer_type_node;
8634 
8635   eqtype = build_array_type (char_type_node,
8636 			     build_range_type (ffecom_integer_type_node,
8637 					       ffecom_integer_zero_node,
8638 					       high));
8639 
8640   eqt = build_decl (VAR_DECL,
8641 		    ffecom_get_invented_identifier ("__g77_equiv_%s",
8642 						    ffesymbol_text
8643 						    (ffestorag_symbol (eqst))),
8644 		    eqtype);
8645   DECL_EXTERNAL (eqt) = 0;
8646   if (is_init
8647       || ffecom_member_namelisted_
8648 #ifdef FFECOM_sizeMAXSTACKITEM
8649       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8650 #endif
8651       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8652 	  && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8653 	  && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8654     TREE_STATIC (eqt) = 1;
8655   else
8656     TREE_STATIC (eqt) = 0;
8657   TREE_PUBLIC (eqt) = 0;
8658   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8659   DECL_CONTEXT (eqt) = current_function_decl;
8660   if (init)
8661     DECL_INITIAL (eqt) = error_mark_node;
8662   else
8663     DECL_INITIAL (eqt) = NULL_TREE;
8664 
8665   eqt = start_decl (eqt, FALSE);
8666 
8667   /* Make sure that any type can live in EQUIVALENCE and be referenced
8668      without getting a bus error.  We could pick the most restrictive
8669      alignment of all entities actually placed in the EQUIVALENCE, but
8670      this seems easy enough.  */
8671 
8672   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8673   DECL_USER_ALIGN (eqt) = 0;
8674 
8675   if ((!is_init && ffe_is_init_local_zero ())
8676       || (is_init && (ffestorag_init (eqst) == NULL)))
8677     init = ffecom_init_zero_ (eqt);
8678 
8679   finish_decl (eqt, init, FALSE);
8680 
8681   if (is_init)
8682     ffestorag_set_init (eqst, ffebld_new_any ());
8683 
8684   {
8685     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8686     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8687 				   (ffestorag_size (eqst)
8688 				    + ffestorag_modulo (eqst))));
8689   }
8690 
8691   ffestorag_set_hook (eqst, eqt);
8692 
8693   ffestorag_drive (ffestorag_list_equivs (eqst),
8694 		   &ffecom_member_phase2_,
8695 		   eqst);
8696 }
8697 
8698 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8699 
8700 static tree
ffecom_transform_namelist_(ffesymbol s)8701 ffecom_transform_namelist_ (ffesymbol s)
8702 {
8703   tree nmlt;
8704   tree nmltype = ffecom_type_namelist_ ();
8705   tree nmlinits;
8706   tree nameinit;
8707   tree varsinit;
8708   tree nvarsinit;
8709   tree field;
8710   tree high;
8711   int i;
8712   static int mynumber = 0;
8713 
8714   nmlt = build_decl (VAR_DECL,
8715 		     ffecom_get_invented_identifier ("__g77_namelist_%d",
8716 						     mynumber++),
8717 		     nmltype);
8718   TREE_STATIC (nmlt) = 1;
8719   DECL_INITIAL (nmlt) = error_mark_node;
8720 
8721   nmlt = start_decl (nmlt, FALSE);
8722 
8723   /* Process inits.  */
8724 
8725   i = strlen (ffesymbol_text (s));
8726 
8727   high = build_int_2 (i, 0);
8728   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8729 
8730   nameinit = ffecom_build_f2c_string_ (i + 1,
8731 				       ffesymbol_text (s));
8732   TREE_TYPE (nameinit)
8733     = build_type_variant
8734     (build_array_type
8735      (char_type_node,
8736       build_range_type (ffecom_f2c_ftnlen_type_node,
8737 			ffecom_f2c_ftnlen_one_node,
8738 			high)),
8739      1, 0);
8740   TREE_CONSTANT (nameinit) = 1;
8741   TREE_STATIC (nameinit) = 1;
8742   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8743 		       nameinit);
8744 
8745   varsinit = ffecom_vardesc_array_ (s);
8746   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8747 		       varsinit);
8748   TREE_CONSTANT (varsinit) = 1;
8749   TREE_STATIC (varsinit) = 1;
8750 
8751   {
8752     ffebld b;
8753 
8754     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8755       ++i;
8756   }
8757   nvarsinit = build_int_2 (i, 0);
8758   TREE_TYPE (nvarsinit) = integer_type_node;
8759   TREE_CONSTANT (nvarsinit) = 1;
8760   TREE_STATIC (nvarsinit) = 1;
8761 
8762   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8763   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8764 					   varsinit);
8765   TREE_CHAIN (TREE_CHAIN (nmlinits))
8766     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8767 
8768   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8769   TREE_CONSTANT (nmlinits) = 1;
8770   TREE_STATIC (nmlinits) = 1;
8771 
8772   finish_decl (nmlt, nmlinits, FALSE);
8773 
8774   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8775 
8776   return nmlt;
8777 }
8778 
8779 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8780    analyzed on the assumption it is calculating a pointer to be
8781    indirected through.  It must return the proper decl and offset,
8782    taking into account different units of measurements for offsets.  */
8783 
8784 static void
ffecom_tree_canonize_ptr_(tree * decl,tree * offset,tree t)8785 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8786 			   tree t)
8787 {
8788   switch (TREE_CODE (t))
8789     {
8790     case NOP_EXPR:
8791     case CONVERT_EXPR:
8792     case NON_LVALUE_EXPR:
8793       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8794       break;
8795 
8796     case PLUS_EXPR:
8797       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8798       if ((*decl == NULL_TREE)
8799 	  || (*decl == error_mark_node))
8800 	break;
8801 
8802       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8803 	{
8804 	  /* An offset into COMMON.  */
8805 	  *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8806 				 *offset, TREE_OPERAND (t, 1)));
8807 	  /* Convert offset (presumably in bytes) into canonical units
8808 	     (presumably bits).  */
8809 	  *offset = size_binop (MULT_EXPR,
8810 				convert (bitsizetype, *offset),
8811 				TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8812 	  break;
8813 	}
8814       /* Not a COMMON reference, so an unrecognized pattern.  */
8815       *decl = error_mark_node;
8816       break;
8817 
8818     case PARM_DECL:
8819       *decl = t;
8820       *offset = bitsize_zero_node;
8821       break;
8822 
8823     case ADDR_EXPR:
8824       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8825 	{
8826 	  /* A reference to COMMON.  */
8827 	  *decl = TREE_OPERAND (t, 0);
8828 	  *offset = bitsize_zero_node;
8829 	  break;
8830 	}
8831       /* Fall through.  */
8832     default:
8833       /* Not a COMMON reference, so an unrecognized pattern.  */
8834       *decl = error_mark_node;
8835       break;
8836     }
8837 }
8838 
8839 /* Given a tree that is possibly intended for use as an lvalue, return
8840    information representing a canonical view of that tree as a decl, an
8841    offset into that decl, and a size for the lvalue.
8842 
8843    If there's no applicable decl, NULL_TREE is returned for the decl,
8844    and the other fields are left undefined.
8845 
8846    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8847    is returned for the decl, and the other fields are left undefined.
8848 
8849    Otherwise, the decl returned currently is either a VAR_DECL or a
8850    PARM_DECL.
8851 
8852    The offset returned is always valid, but of course not necessarily
8853    a constant, and not necessarily converted into the appropriate
8854    type, leaving that up to the caller (so as to avoid that overhead
8855    if the decls being looked at are different anyway).
8856 
8857    If the size cannot be determined (e.g. an adjustable array),
8858    an ERROR_MARK node is returned for the size.  Otherwise, the
8859    size returned is valid, not necessarily a constant, and not
8860    necessarily converted into the appropriate type as with the
8861    offset.
8862 
8863    Note that the offset and size expressions are expressed in the
8864    base storage units (usually bits) rather than in the units of
8865    the type of the decl, because two decls with different types
8866    might overlap but with apparently non-overlapping array offsets,
8867    whereas converting the array offsets to consistant offsets will
8868    reveal the overlap.  */
8869 
8870 static void
ffecom_tree_canonize_ref_(tree * decl,tree * offset,tree * size,tree t)8871 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
8872 			   tree *size, tree t)
8873 {
8874   /* The default path is to report a nonexistant decl.  */
8875   *decl = NULL_TREE;
8876 
8877   if (t == NULL_TREE)
8878     return;
8879 
8880   switch (TREE_CODE (t))
8881     {
8882     case ERROR_MARK:
8883     case IDENTIFIER_NODE:
8884     case INTEGER_CST:
8885     case REAL_CST:
8886     case COMPLEX_CST:
8887     case STRING_CST:
8888     case CONST_DECL:
8889     case PLUS_EXPR:
8890     case MINUS_EXPR:
8891     case MULT_EXPR:
8892     case TRUNC_DIV_EXPR:
8893     case CEIL_DIV_EXPR:
8894     case FLOOR_DIV_EXPR:
8895     case ROUND_DIV_EXPR:
8896     case TRUNC_MOD_EXPR:
8897     case CEIL_MOD_EXPR:
8898     case FLOOR_MOD_EXPR:
8899     case ROUND_MOD_EXPR:
8900     case RDIV_EXPR:
8901     case EXACT_DIV_EXPR:
8902     case FIX_TRUNC_EXPR:
8903     case FIX_CEIL_EXPR:
8904     case FIX_FLOOR_EXPR:
8905     case FIX_ROUND_EXPR:
8906     case FLOAT_EXPR:
8907     case NEGATE_EXPR:
8908     case MIN_EXPR:
8909     case MAX_EXPR:
8910     case ABS_EXPR:
8911     case FFS_EXPR:
8912     case LSHIFT_EXPR:
8913     case RSHIFT_EXPR:
8914     case LROTATE_EXPR:
8915     case RROTATE_EXPR:
8916     case BIT_IOR_EXPR:
8917     case BIT_XOR_EXPR:
8918     case BIT_AND_EXPR:
8919     case BIT_ANDTC_EXPR:
8920     case BIT_NOT_EXPR:
8921     case TRUTH_ANDIF_EXPR:
8922     case TRUTH_ORIF_EXPR:
8923     case TRUTH_AND_EXPR:
8924     case TRUTH_OR_EXPR:
8925     case TRUTH_XOR_EXPR:
8926     case TRUTH_NOT_EXPR:
8927     case LT_EXPR:
8928     case LE_EXPR:
8929     case GT_EXPR:
8930     case GE_EXPR:
8931     case EQ_EXPR:
8932     case NE_EXPR:
8933     case COMPLEX_EXPR:
8934     case CONJ_EXPR:
8935     case REALPART_EXPR:
8936     case IMAGPART_EXPR:
8937     case LABEL_EXPR:
8938     case COMPONENT_REF:
8939     case COMPOUND_EXPR:
8940     case ADDR_EXPR:
8941       return;
8942 
8943     case VAR_DECL:
8944     case PARM_DECL:
8945       *decl = t;
8946       *offset = bitsize_zero_node;
8947       *size = TYPE_SIZE (TREE_TYPE (t));
8948       return;
8949 
8950     case ARRAY_REF:
8951       {
8952 	tree array = TREE_OPERAND (t, 0);
8953 	tree element = TREE_OPERAND (t, 1);
8954 	tree init_offset;
8955 
8956 	if ((array == NULL_TREE)
8957 	    || (element == NULL_TREE))
8958 	  {
8959 	    *decl = error_mark_node;
8960 	    return;
8961 	  }
8962 
8963 	ffecom_tree_canonize_ref_ (decl, &init_offset, size,
8964 				   array);
8965 	if ((*decl == NULL_TREE)
8966 	    || (*decl == error_mark_node))
8967 	  return;
8968 
8969 	/* Calculate ((element - base) * NBBY) + init_offset.  */
8970 	*offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
8971 			       element,
8972 			       TYPE_MIN_VALUE (TYPE_DOMAIN
8973 					       (TREE_TYPE (array)))));
8974 
8975 	*offset = size_binop (MULT_EXPR,
8976 			      convert (bitsizetype, *offset),
8977 			      TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
8978 
8979 	*offset = size_binop (PLUS_EXPR, init_offset, *offset);
8980 
8981 	*size = TYPE_SIZE (TREE_TYPE (t));
8982 	return;
8983       }
8984 
8985     case INDIRECT_REF:
8986 
8987       /* Most of this code is to handle references to COMMON.  And so
8988 	 far that is useful only for calling library functions, since
8989 	 external (user) functions might reference common areas.  But
8990 	 even calling an external function, it's worthwhile to decode
8991 	 COMMON references because if not storing into COMMON, we don't
8992 	 want COMMON-based arguments to gratuitously force use of a
8993 	 temporary.  */
8994 
8995       *size = TYPE_SIZE (TREE_TYPE (t));
8996 
8997       ffecom_tree_canonize_ptr_ (decl, offset,
8998 				 TREE_OPERAND (t, 0));
8999 
9000       return;
9001 
9002     case CONVERT_EXPR:
9003     case NOP_EXPR:
9004     case MODIFY_EXPR:
9005     case NON_LVALUE_EXPR:
9006     case RESULT_DECL:
9007     case FIELD_DECL:
9008     case COND_EXPR:		/* More cases than we can handle. */
9009     case SAVE_EXPR:
9010     case REFERENCE_EXPR:
9011     case PREDECREMENT_EXPR:
9012     case PREINCREMENT_EXPR:
9013     case POSTDECREMENT_EXPR:
9014     case POSTINCREMENT_EXPR:
9015     case CALL_EXPR:
9016     default:
9017       *decl = error_mark_node;
9018       return;
9019     }
9020 }
9021 
9022 /* Do divide operation appropriate to type of operands.  */
9023 
9024 static tree
ffecom_tree_divide_(tree tree_type,tree left,tree right,tree dest_tree,ffebld dest,bool * dest_used,tree hook)9025 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9026 		     tree dest_tree, ffebld dest, bool *dest_used,
9027 		     tree hook)
9028 {
9029   if ((left == error_mark_node)
9030       || (right == error_mark_node))
9031     return error_mark_node;
9032 
9033   switch (TREE_CODE (tree_type))
9034     {
9035     case INTEGER_TYPE:
9036       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9037 		       left,
9038 		       right);
9039 
9040     case COMPLEX_TYPE:
9041       if (! optimize_size)
9042 	return ffecom_2 (RDIV_EXPR, tree_type,
9043 			 left,
9044 			 right);
9045       {
9046 	ffecomGfrt ix;
9047 
9048 	if (TREE_TYPE (tree_type)
9049 	    == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9050 	  ix = FFECOM_gfrtDIV_CC;	/* Overlapping result okay. */
9051 	else
9052 	  ix = FFECOM_gfrtDIV_ZZ;	/* Overlapping result okay. */
9053 
9054 	left = ffecom_1 (ADDR_EXPR,
9055 			 build_pointer_type (TREE_TYPE (left)),
9056 			 left);
9057 	left = build_tree_list (NULL_TREE, left);
9058 	right = ffecom_1 (ADDR_EXPR,
9059 			  build_pointer_type (TREE_TYPE (right)),
9060 			  right);
9061 	right = build_tree_list (NULL_TREE, right);
9062 	TREE_CHAIN (left) = right;
9063 
9064 	return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9065 			     ffecom_gfrt_kindtype (ix),
9066 			     ffe_is_f2c_library (),
9067 			     tree_type,
9068 			     left,
9069 			     dest_tree, dest, dest_used,
9070 			     NULL_TREE, TRUE, hook);
9071       }
9072       break;
9073 
9074     case RECORD_TYPE:
9075       {
9076 	ffecomGfrt ix;
9077 
9078 	if (TREE_TYPE (TYPE_FIELDS (tree_type))
9079 	    == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9080 	  ix = FFECOM_gfrtDIV_CC;	/* Overlapping result okay. */
9081 	else
9082 	  ix = FFECOM_gfrtDIV_ZZ;	/* Overlapping result okay. */
9083 
9084 	left = ffecom_1 (ADDR_EXPR,
9085 			 build_pointer_type (TREE_TYPE (left)),
9086 			 left);
9087 	left = build_tree_list (NULL_TREE, left);
9088 	right = ffecom_1 (ADDR_EXPR,
9089 			  build_pointer_type (TREE_TYPE (right)),
9090 			  right);
9091 	right = build_tree_list (NULL_TREE, right);
9092 	TREE_CHAIN (left) = right;
9093 
9094 	return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9095 			     ffecom_gfrt_kindtype (ix),
9096 			     ffe_is_f2c_library (),
9097 			     tree_type,
9098 			     left,
9099 			     dest_tree, dest, dest_used,
9100 			     NULL_TREE, TRUE, hook);
9101       }
9102       break;
9103 
9104     default:
9105       return ffecom_2 (RDIV_EXPR, tree_type,
9106 		       left,
9107 		       right);
9108     }
9109 }
9110 
9111 /* Build type info for non-dummy variable.  */
9112 
9113 static tree
ffecom_type_localvar_(ffesymbol s,ffeinfoBasictype bt,ffeinfoKindtype kt)9114 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9115 		       ffeinfoKindtype kt)
9116 {
9117   tree type;
9118   ffebld dl;
9119   ffebld dim;
9120   tree lowt;
9121   tree hight;
9122 
9123   type = ffecom_tree_type[bt][kt];
9124   if (bt == FFEINFO_basictypeCHARACTER)
9125     {
9126       hight = build_int_2 (ffesymbol_size (s), 0);
9127       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9128 
9129       type
9130 	= build_array_type
9131 	  (type,
9132 	   build_range_type (ffecom_f2c_ftnlen_type_node,
9133 			     ffecom_f2c_ftnlen_one_node,
9134 			     hight));
9135       type = ffecom_check_size_overflow_ (s, type, FALSE);
9136     }
9137 
9138   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9139     {
9140       if (type == error_mark_node)
9141 	break;
9142 
9143       dim = ffebld_head (dl);
9144       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9145 
9146       if (ffebld_left (dim) == NULL)
9147 	lowt = integer_one_node;
9148       else
9149 	lowt = ffecom_expr (ffebld_left (dim));
9150 
9151       if (TREE_CODE (lowt) != INTEGER_CST)
9152 	lowt = variable_size (lowt);
9153 
9154       assert (ffebld_right (dim) != NULL);
9155       hight = ffecom_expr (ffebld_right (dim));
9156 
9157       if (TREE_CODE (hight) != INTEGER_CST)
9158 	hight = variable_size (hight);
9159 
9160       type = build_array_type (type,
9161 			       build_range_type (ffecom_integer_type_node,
9162 						 lowt, hight));
9163       type = ffecom_check_size_overflow_ (s, type, FALSE);
9164     }
9165 
9166   return type;
9167 }
9168 
9169 /* Build Namelist type.  */
9170 
9171 static GTY(()) tree ffecom_type_namelist_var;
9172 static tree
ffecom_type_namelist_()9173 ffecom_type_namelist_ ()
9174 {
9175   if (ffecom_type_namelist_var == NULL_TREE)
9176     {
9177       tree namefield, varsfield, nvarsfield, vardesctype, type;
9178 
9179       vardesctype = ffecom_type_vardesc_ ();
9180 
9181       type = make_node (RECORD_TYPE);
9182 
9183       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9184 
9185       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9186 				     string_type_node);
9187       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9188       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9189 				      integer_type_node);
9190 
9191       TYPE_FIELDS (type) = namefield;
9192       layout_type (type);
9193 
9194       ffecom_type_namelist_var = type;
9195     }
9196 
9197   return ffecom_type_namelist_var;
9198 }
9199 
9200 /* Build Vardesc type.  */
9201 
9202 static GTY(()) tree ffecom_type_vardesc_var;
9203 static tree
ffecom_type_vardesc_()9204 ffecom_type_vardesc_ ()
9205 {
9206   if (ffecom_type_vardesc_var == NULL_TREE)
9207     {
9208       tree namefield, addrfield, dimsfield, typefield, type;
9209       type = make_node (RECORD_TYPE);
9210 
9211       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9212 				     string_type_node);
9213       addrfield = ffecom_decl_field (type, namefield, "addr",
9214 				     string_type_node);
9215       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9216 				     ffecom_f2c_ptr_to_ftnlen_type_node);
9217       typefield = ffecom_decl_field (type, dimsfield, "type",
9218 				     integer_type_node);
9219 
9220       TYPE_FIELDS (type) = namefield;
9221       layout_type (type);
9222 
9223       ffecom_type_vardesc_var = type;
9224     }
9225 
9226   return ffecom_type_vardesc_var;
9227 }
9228 
9229 static tree
ffecom_vardesc_(ffebld expr)9230 ffecom_vardesc_ (ffebld expr)
9231 {
9232   ffesymbol s;
9233 
9234   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9235   s = ffebld_symter (expr);
9236 
9237   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9238     {
9239       int i;
9240       tree vardesctype = ffecom_type_vardesc_ ();
9241       tree var;
9242       tree nameinit;
9243       tree dimsinit;
9244       tree addrinit;
9245       tree typeinit;
9246       tree field;
9247       tree varinits;
9248       static int mynumber = 0;
9249 
9250       var = build_decl (VAR_DECL,
9251 			ffecom_get_invented_identifier ("__g77_vardesc_%d",
9252 							mynumber++),
9253 			vardesctype);
9254       TREE_STATIC (var) = 1;
9255       DECL_INITIAL (var) = error_mark_node;
9256 
9257       var = start_decl (var, FALSE);
9258 
9259       /* Process inits.  */
9260 
9261       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9262 					   + 1,
9263 					   ffesymbol_text (s));
9264       TREE_TYPE (nameinit)
9265 	= build_type_variant
9266 	(build_array_type
9267 	 (char_type_node,
9268 	  build_range_type (integer_type_node,
9269 			    integer_one_node,
9270 			    build_int_2 (i, 0))),
9271 	 1, 0);
9272       TREE_CONSTANT (nameinit) = 1;
9273       TREE_STATIC (nameinit) = 1;
9274       nameinit = ffecom_1 (ADDR_EXPR,
9275 			   build_pointer_type (TREE_TYPE (nameinit)),
9276 			   nameinit);
9277 
9278       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9279 
9280       dimsinit = ffecom_vardesc_dims_ (s);
9281 
9282       if (typeinit == NULL_TREE)
9283 	{
9284 	  ffeinfoBasictype bt = ffesymbol_basictype (s);
9285 	  ffeinfoKindtype kt = ffesymbol_kindtype (s);
9286 	  int tc = ffecom_f2c_typecode (bt, kt);
9287 
9288 	  assert (tc != -1);
9289 	  typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9290 	}
9291       else
9292 	typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9293 
9294       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9295 				  nameinit);
9296       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9297 					       addrinit);
9298       TREE_CHAIN (TREE_CHAIN (varinits))
9299 	= build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9300       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9301 	= build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9302 
9303       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9304       TREE_CONSTANT (varinits) = 1;
9305       TREE_STATIC (varinits) = 1;
9306 
9307       finish_decl (var, varinits, FALSE);
9308 
9309       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9310 
9311       ffesymbol_hook (s).vardesc_tree = var;
9312     }
9313 
9314   return ffesymbol_hook (s).vardesc_tree;
9315 }
9316 
9317 static tree
ffecom_vardesc_array_(ffesymbol s)9318 ffecom_vardesc_array_ (ffesymbol s)
9319 {
9320   ffebld b;
9321   tree list;
9322   tree item = NULL_TREE;
9323   tree var;
9324   int i;
9325   static int mynumber = 0;
9326 
9327   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9328        b != NULL;
9329        b = ffebld_trail (b), ++i)
9330     {
9331       tree t;
9332 
9333       t = ffecom_vardesc_ (ffebld_head (b));
9334 
9335       if (list == NULL_TREE)
9336 	list = item = build_tree_list (NULL_TREE, t);
9337       else
9338 	{
9339 	  TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9340 	  item = TREE_CHAIN (item);
9341 	}
9342     }
9343 
9344   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9345 			   build_range_type (integer_type_node,
9346 					     integer_one_node,
9347 					     build_int_2 (i, 0)));
9348   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9349   TREE_CONSTANT (list) = 1;
9350   TREE_STATIC (list) = 1;
9351 
9352   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9353   var = build_decl (VAR_DECL, var, item);
9354   TREE_STATIC (var) = 1;
9355   DECL_INITIAL (var) = error_mark_node;
9356   var = start_decl (var, FALSE);
9357   finish_decl (var, list, FALSE);
9358 
9359   return var;
9360 }
9361 
9362 static tree
ffecom_vardesc_dims_(ffesymbol s)9363 ffecom_vardesc_dims_ (ffesymbol s)
9364 {
9365   if (ffesymbol_dims (s) == NULL)
9366     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9367 		    integer_zero_node);
9368 
9369   {
9370     ffebld b;
9371     ffebld e;
9372     tree list;
9373     tree backlist;
9374     tree item = NULL_TREE;
9375     tree var;
9376     tree numdim;
9377     tree numelem;
9378     tree baseoff = NULL_TREE;
9379     static int mynumber = 0;
9380 
9381     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9382     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9383 
9384     numelem = ffecom_expr (ffesymbol_arraysize (s));
9385     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9386 
9387     list = NULL_TREE;
9388     backlist = NULL_TREE;
9389     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9390 	 b != NULL;
9391 	 b = ffebld_trail (b), e = ffebld_trail (e))
9392       {
9393 	tree t;
9394 	tree low;
9395 	tree back;
9396 
9397 	if (ffebld_trail (b) == NULL)
9398 	  t = NULL_TREE;
9399 	else
9400 	  {
9401 	    t = convert (ffecom_f2c_ftnlen_type_node,
9402 			 ffecom_expr (ffebld_head (e)));
9403 
9404 	    if (list == NULL_TREE)
9405 	      list = item = build_tree_list (NULL_TREE, t);
9406 	    else
9407 	      {
9408 		TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9409 		item = TREE_CHAIN (item);
9410 	      }
9411 	  }
9412 
9413 	if (ffebld_left (ffebld_head (b)) == NULL)
9414 	  low = ffecom_integer_one_node;
9415 	else
9416 	  low = ffecom_expr (ffebld_left (ffebld_head (b)));
9417 	low = convert (ffecom_f2c_ftnlen_type_node, low);
9418 
9419 	back = build_tree_list (low, t);
9420 	TREE_CHAIN (back) = backlist;
9421 	backlist = back;
9422       }
9423 
9424     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9425       {
9426 	if (TREE_VALUE (item) == NULL_TREE)
9427 	  baseoff = TREE_PURPOSE (item);
9428 	else
9429 	  baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9430 			      TREE_PURPOSE (item),
9431 			      ffecom_2 (MULT_EXPR,
9432 					ffecom_f2c_ftnlen_type_node,
9433 					TREE_VALUE (item),
9434 					baseoff));
9435       }
9436 
9437     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9438 
9439     baseoff = build_tree_list (NULL_TREE, baseoff);
9440     TREE_CHAIN (baseoff) = list;
9441 
9442     numelem = build_tree_list (NULL_TREE, numelem);
9443     TREE_CHAIN (numelem) = baseoff;
9444 
9445     numdim = build_tree_list (NULL_TREE, numdim);
9446     TREE_CHAIN (numdim) = numelem;
9447 
9448     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9449 			     build_range_type (integer_type_node,
9450 					       integer_zero_node,
9451 					       build_int_2
9452 					       ((int) ffesymbol_rank (s)
9453 						+ 2, 0)));
9454     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9455     TREE_CONSTANT (list) = 1;
9456     TREE_STATIC (list) = 1;
9457 
9458     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9459     var = build_decl (VAR_DECL, var, item);
9460     TREE_STATIC (var) = 1;
9461     DECL_INITIAL (var) = error_mark_node;
9462     var = start_decl (var, FALSE);
9463     finish_decl (var, list, FALSE);
9464 
9465     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9466 
9467     return var;
9468   }
9469 }
9470 
9471 /* Essentially does a "fold (build1 (code, type, node))" while checking
9472    for certain housekeeping things.
9473 
9474    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9475    ffecom_1_fn instead.  */
9476 
9477 tree
ffecom_1(enum tree_code code,tree type,tree node)9478 ffecom_1 (enum tree_code code, tree type, tree node)
9479 {
9480   tree item;
9481 
9482   if ((node == error_mark_node)
9483       || (type == error_mark_node))
9484     return error_mark_node;
9485 
9486   if (code == ADDR_EXPR)
9487     {
9488       if (!ffe_mark_addressable (node))
9489 	assert ("can't mark_addressable this node!" == NULL);
9490     }
9491 
9492   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9493     {
9494       tree realtype;
9495 
9496     case REALPART_EXPR:
9497       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9498       break;
9499 
9500     case IMAGPART_EXPR:
9501       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9502       break;
9503 
9504 
9505     case NEGATE_EXPR:
9506       if (TREE_CODE (type) != RECORD_TYPE)
9507 	{
9508 	  item = build1 (code, type, node);
9509 	  break;
9510 	}
9511       node = ffecom_stabilize_aggregate_ (node);
9512       realtype = TREE_TYPE (TYPE_FIELDS (type));
9513       item =
9514 	ffecom_2 (COMPLEX_EXPR, type,
9515 		  ffecom_1 (NEGATE_EXPR, realtype,
9516 			    ffecom_1 (REALPART_EXPR, realtype,
9517 				      node)),
9518 		  ffecom_1 (NEGATE_EXPR, realtype,
9519 			    ffecom_1 (IMAGPART_EXPR, realtype,
9520 				      node)));
9521       break;
9522 
9523     default:
9524       item = build1 (code, type, node);
9525       break;
9526     }
9527 
9528   if (TREE_SIDE_EFFECTS (node))
9529     TREE_SIDE_EFFECTS (item) = 1;
9530   if (code == ADDR_EXPR && staticp (node))
9531     TREE_CONSTANT (item) = 1;
9532   else if (code == INDIRECT_REF)
9533     TREE_READONLY (item) = TYPE_READONLY (type);
9534   return fold (item);
9535 }
9536 
9537 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9538    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9539    does not set TREE_ADDRESSABLE (because calling an inline
9540    function does not mean the function needs to be separately
9541    compiled).  */
9542 
9543 tree
ffecom_1_fn(tree node)9544 ffecom_1_fn (tree node)
9545 {
9546   tree item;
9547   tree type;
9548 
9549   if (node == error_mark_node)
9550     return error_mark_node;
9551 
9552   type = build_type_variant (TREE_TYPE (node),
9553 			     TREE_READONLY (node),
9554 			     TREE_THIS_VOLATILE (node));
9555   item = build1 (ADDR_EXPR,
9556 		 build_pointer_type (type), node);
9557   if (TREE_SIDE_EFFECTS (node))
9558     TREE_SIDE_EFFECTS (item) = 1;
9559   if (staticp (node))
9560     TREE_CONSTANT (item) = 1;
9561   return fold (item);
9562 }
9563 
9564 /* Essentially does a "fold (build (code, type, node1, node2))" while
9565    checking for certain housekeeping things.  */
9566 
9567 tree
ffecom_2(enum tree_code code,tree type,tree node1,tree node2)9568 ffecom_2 (enum tree_code code, tree type, tree node1,
9569 	  tree node2)
9570 {
9571   tree item;
9572 
9573   if ((node1 == error_mark_node)
9574       || (node2 == error_mark_node)
9575       || (type == error_mark_node))
9576     return error_mark_node;
9577 
9578   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9579     {
9580       tree a, b, c, d, realtype;
9581 
9582     case CONJ_EXPR:
9583       assert ("no CONJ_EXPR support yet" == NULL);
9584       return error_mark_node;
9585 
9586     case COMPLEX_EXPR:
9587       item = build_tree_list (TYPE_FIELDS (type), node1);
9588       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9589       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9590       break;
9591 
9592     case PLUS_EXPR:
9593       if (TREE_CODE (type) != RECORD_TYPE)
9594 	{
9595 	  item = build (code, type, node1, node2);
9596 	  break;
9597 	}
9598       node1 = ffecom_stabilize_aggregate_ (node1);
9599       node2 = ffecom_stabilize_aggregate_ (node2);
9600       realtype = TREE_TYPE (TYPE_FIELDS (type));
9601       item =
9602 	ffecom_2 (COMPLEX_EXPR, type,
9603 		  ffecom_2 (PLUS_EXPR, realtype,
9604 			    ffecom_1 (REALPART_EXPR, realtype,
9605 				      node1),
9606 			    ffecom_1 (REALPART_EXPR, realtype,
9607 				      node2)),
9608 		  ffecom_2 (PLUS_EXPR, realtype,
9609 			    ffecom_1 (IMAGPART_EXPR, realtype,
9610 				      node1),
9611 			    ffecom_1 (IMAGPART_EXPR, realtype,
9612 				      node2)));
9613       break;
9614 
9615     case MINUS_EXPR:
9616       if (TREE_CODE (type) != RECORD_TYPE)
9617 	{
9618 	  item = build (code, type, node1, node2);
9619 	  break;
9620 	}
9621       node1 = ffecom_stabilize_aggregate_ (node1);
9622       node2 = ffecom_stabilize_aggregate_ (node2);
9623       realtype = TREE_TYPE (TYPE_FIELDS (type));
9624       item =
9625 	ffecom_2 (COMPLEX_EXPR, type,
9626 		  ffecom_2 (MINUS_EXPR, realtype,
9627 			    ffecom_1 (REALPART_EXPR, realtype,
9628 				      node1),
9629 			    ffecom_1 (REALPART_EXPR, realtype,
9630 				      node2)),
9631 		  ffecom_2 (MINUS_EXPR, realtype,
9632 			    ffecom_1 (IMAGPART_EXPR, realtype,
9633 				      node1),
9634 			    ffecom_1 (IMAGPART_EXPR, realtype,
9635 				      node2)));
9636       break;
9637 
9638     case MULT_EXPR:
9639       if (TREE_CODE (type) != RECORD_TYPE)
9640 	{
9641 	  item = build (code, type, node1, node2);
9642 	  break;
9643 	}
9644       node1 = ffecom_stabilize_aggregate_ (node1);
9645       node2 = ffecom_stabilize_aggregate_ (node2);
9646       realtype = TREE_TYPE (TYPE_FIELDS (type));
9647       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9648 			       node1));
9649       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9650 			       node1));
9651       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9652 			       node2));
9653       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9654 			       node2));
9655       item =
9656 	ffecom_2 (COMPLEX_EXPR, type,
9657 		  ffecom_2 (MINUS_EXPR, realtype,
9658 			    ffecom_2 (MULT_EXPR, realtype,
9659 				      a,
9660 				      c),
9661 			    ffecom_2 (MULT_EXPR, realtype,
9662 				      b,
9663 				      d)),
9664 		  ffecom_2 (PLUS_EXPR, realtype,
9665 			    ffecom_2 (MULT_EXPR, realtype,
9666 				      a,
9667 				      d),
9668 			    ffecom_2 (MULT_EXPR, realtype,
9669 				      c,
9670 				      b)));
9671       break;
9672 
9673     case EQ_EXPR:
9674       if ((TREE_CODE (node1) != RECORD_TYPE)
9675 	  && (TREE_CODE (node2) != RECORD_TYPE))
9676 	{
9677 	  item = build (code, type, node1, node2);
9678 	  break;
9679 	}
9680       assert (TREE_CODE (node1) == RECORD_TYPE);
9681       assert (TREE_CODE (node2) == RECORD_TYPE);
9682       node1 = ffecom_stabilize_aggregate_ (node1);
9683       node2 = ffecom_stabilize_aggregate_ (node2);
9684       realtype = TREE_TYPE (TYPE_FIELDS (type));
9685       item =
9686 	ffecom_2 (TRUTH_ANDIF_EXPR, type,
9687 		  ffecom_2 (code, type,
9688 			    ffecom_1 (REALPART_EXPR, realtype,
9689 				      node1),
9690 			    ffecom_1 (REALPART_EXPR, realtype,
9691 				      node2)),
9692 		  ffecom_2 (code, type,
9693 			    ffecom_1 (IMAGPART_EXPR, realtype,
9694 				      node1),
9695 			    ffecom_1 (IMAGPART_EXPR, realtype,
9696 				      node2)));
9697       break;
9698 
9699     case NE_EXPR:
9700       if ((TREE_CODE (node1) != RECORD_TYPE)
9701 	  && (TREE_CODE (node2) != RECORD_TYPE))
9702 	{
9703 	  item = build (code, type, node1, node2);
9704 	  break;
9705 	}
9706       assert (TREE_CODE (node1) == RECORD_TYPE);
9707       assert (TREE_CODE (node2) == RECORD_TYPE);
9708       node1 = ffecom_stabilize_aggregate_ (node1);
9709       node2 = ffecom_stabilize_aggregate_ (node2);
9710       realtype = TREE_TYPE (TYPE_FIELDS (type));
9711       item =
9712 	ffecom_2 (TRUTH_ORIF_EXPR, type,
9713 		  ffecom_2 (code, type,
9714 			    ffecom_1 (REALPART_EXPR, realtype,
9715 				      node1),
9716 			    ffecom_1 (REALPART_EXPR, realtype,
9717 				      node2)),
9718 		  ffecom_2 (code, type,
9719 			    ffecom_1 (IMAGPART_EXPR, realtype,
9720 				      node1),
9721 			    ffecom_1 (IMAGPART_EXPR, realtype,
9722 				      node2)));
9723       break;
9724 
9725     default:
9726       item = build (code, type, node1, node2);
9727       break;
9728     }
9729 
9730   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9731     TREE_SIDE_EFFECTS (item) = 1;
9732   return fold (item);
9733 }
9734 
9735 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9736 
9737    ffesymbol s;	 // the ENTRY point itself
9738    if (ffecom_2pass_advise_entrypoint(s))
9739        // the ENTRY point has been accepted
9740 
9741    Does whatever compiler needs to do when it learns about the entrypoint,
9742    like determine the return type of the master function, count the
9743    number of entrypoints, etc.	Returns FALSE if the return type is
9744    not compatible with the return type(s) of other entrypoint(s).
9745 
9746    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9747    later (after _finish_progunit) be called with the same entrypoint(s)
9748    as passed to this fn for which TRUE was returned.
9749 
9750    03-Jan-92  JCB  2.0
9751       Return FALSE if the return type conflicts with previous entrypoints.  */
9752 
9753 bool
ffecom_2pass_advise_entrypoint(ffesymbol entry)9754 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9755 {
9756   ffebld list;			/* opITEM. */
9757   ffebld mlist;			/* opITEM. */
9758   ffebld plist;			/* opITEM. */
9759   ffebld arg;			/* ffebld_head(opITEM). */
9760   ffebld item;			/* opITEM. */
9761   ffesymbol s;			/* ffebld_symter(arg). */
9762   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9763   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9764   ffetargetCharacterSize size = ffesymbol_size (entry);
9765   bool ok;
9766 
9767   if (ffecom_num_entrypoints_ == 0)
9768     {				/* First entrypoint, make list of main
9769 				   arglist's dummies. */
9770       assert (ffecom_primary_entry_ != NULL);
9771 
9772       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9773       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9774       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9775 
9776       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9777 	   list != NULL;
9778 	   list = ffebld_trail (list))
9779 	{
9780 	  arg = ffebld_head (list);
9781 	  if (ffebld_op (arg) != FFEBLD_opSYMTER)
9782 	    continue;		/* Alternate return or some such thing. */
9783 	  item = ffebld_new_item (arg, NULL);
9784 	  if (plist == NULL)
9785 	    ffecom_master_arglist_ = item;
9786 	  else
9787 	    ffebld_set_trail (plist, item);
9788 	  plist = item;
9789 	}
9790     }
9791 
9792   /* If necessary, scan entry arglist for alternate returns.  Do this scan
9793      apparently redundantly (it's done below to UNIONize the arglists) so
9794      that we don't complain about RETURN 1 if an offending ENTRY is the only
9795      one with an alternate return.  */
9796 
9797   if (!ffecom_is_altreturning_)
9798     {
9799       for (list = ffesymbol_dummyargs (entry);
9800 	   list != NULL;
9801 	   list = ffebld_trail (list))
9802 	{
9803 	  arg = ffebld_head (list);
9804 	  if (ffebld_op (arg) == FFEBLD_opSTAR)
9805 	    {
9806 	      ffecom_is_altreturning_ = TRUE;
9807 	      break;
9808 	    }
9809 	}
9810     }
9811 
9812   /* Now check type compatibility. */
9813 
9814   switch (ffecom_master_bt_)
9815     {
9816     case FFEINFO_basictypeNONE:
9817       ok = (bt != FFEINFO_basictypeCHARACTER);
9818       break;
9819 
9820     case FFEINFO_basictypeCHARACTER:
9821       ok
9822 	= (bt == FFEINFO_basictypeCHARACTER)
9823 	&& (kt == ffecom_master_kt_)
9824 	&& (size == ffecom_master_size_);
9825       break;
9826 
9827     case FFEINFO_basictypeANY:
9828       return FALSE;		/* Just don't bother. */
9829 
9830     default:
9831       if (bt == FFEINFO_basictypeCHARACTER)
9832 	{
9833 	  ok = FALSE;
9834 	  break;
9835 	}
9836       ok = TRUE;
9837       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
9838 	{
9839 	  ffecom_master_bt_ = FFEINFO_basictypeNONE;
9840 	  ffecom_master_kt_ = FFEINFO_kindtypeNONE;
9841 	}
9842       break;
9843     }
9844 
9845   if (!ok)
9846     {
9847       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
9848       ffest_ffebad_here_current_stmt (0);
9849       ffebad_finish ();
9850       return FALSE;		/* Can't handle entrypoint. */
9851     }
9852 
9853   /* Entrypoint type compatible with previous types. */
9854 
9855   ++ffecom_num_entrypoints_;
9856 
9857   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9858 
9859   for (list = ffesymbol_dummyargs (entry);
9860        list != NULL;
9861        list = ffebld_trail (list))
9862     {
9863       arg = ffebld_head (list);
9864       if (ffebld_op (arg) != FFEBLD_opSYMTER)
9865 	continue;		/* Alternate return or some such thing. */
9866       s = ffebld_symter (arg);
9867       for (plist = NULL, mlist = ffecom_master_arglist_;
9868 	   mlist != NULL;
9869 	   plist = mlist, mlist = ffebld_trail (mlist))
9870 	{			/* plist points to previous item for easy
9871 				   appending of arg. */
9872 	  if (ffebld_symter (ffebld_head (mlist)) == s)
9873 	    break;		/* Already have this arg in the master list. */
9874 	}
9875       if (mlist != NULL)
9876 	continue;		/* Already have this arg in the master list. */
9877 
9878       /* Append this arg to the master list. */
9879 
9880       item = ffebld_new_item (arg, NULL);
9881       if (plist == NULL)
9882 	ffecom_master_arglist_ = item;
9883       else
9884 	ffebld_set_trail (plist, item);
9885     }
9886 
9887   return TRUE;
9888 }
9889 
9890 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9891 
9892    ffesymbol s;	 // the ENTRY point itself
9893    ffecom_2pass_do_entrypoint(s);
9894 
9895    Does whatever compiler needs to do to make the entrypoint actually
9896    happen.  Must be called for each entrypoint after
9897    ffecom_finish_progunit is called.  */
9898 
9899 void
ffecom_2pass_do_entrypoint(ffesymbol entry)9900 ffecom_2pass_do_entrypoint (ffesymbol entry)
9901 {
9902   static int mfn_num = 0;
9903   static int ent_num;
9904 
9905   if (mfn_num != ffecom_num_fns_)
9906     {				/* First entrypoint for this program unit. */
9907       ent_num = 1;
9908       mfn_num = ffecom_num_fns_;
9909       ffecom_do_entry_ (ffecom_primary_entry_, 0);
9910     }
9911   else
9912     ++ent_num;
9913 
9914   --ffecom_num_entrypoints_;
9915 
9916   ffecom_do_entry_ (entry, ent_num);
9917 }
9918 
9919 /* Essentially does a "fold (build (code, type, node1, node2))" while
9920    checking for certain housekeeping things.  Always sets
9921    TREE_SIDE_EFFECTS.  */
9922 
9923 tree
ffecom_2s(enum tree_code code,tree type,tree node1,tree node2)9924 ffecom_2s (enum tree_code code, tree type, tree node1,
9925 	   tree node2)
9926 {
9927   tree item;
9928 
9929   if ((node1 == error_mark_node)
9930       || (node2 == error_mark_node)
9931       || (type == error_mark_node))
9932     return error_mark_node;
9933 
9934   item = build (code, type, node1, node2);
9935   TREE_SIDE_EFFECTS (item) = 1;
9936   return fold (item);
9937 }
9938 
9939 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9940    checking for certain housekeeping things.  */
9941 
9942 tree
ffecom_3(enum tree_code code,tree type,tree node1,tree node2,tree node3)9943 ffecom_3 (enum tree_code code, tree type, tree node1,
9944 	  tree node2, tree node3)
9945 {
9946   tree item;
9947 
9948   if ((node1 == error_mark_node)
9949       || (node2 == error_mark_node)
9950       || (node3 == error_mark_node)
9951       || (type == error_mark_node))
9952     return error_mark_node;
9953 
9954   item = build (code, type, node1, node2, node3);
9955   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
9956       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
9957     TREE_SIDE_EFFECTS (item) = 1;
9958   return fold (item);
9959 }
9960 
9961 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9962    checking for certain housekeeping things.  Always sets
9963    TREE_SIDE_EFFECTS.  */
9964 
9965 tree
ffecom_3s(enum tree_code code,tree type,tree node1,tree node2,tree node3)9966 ffecom_3s (enum tree_code code, tree type, tree node1,
9967 	   tree node2, tree node3)
9968 {
9969   tree item;
9970 
9971   if ((node1 == error_mark_node)
9972       || (node2 == error_mark_node)
9973       || (node3 == error_mark_node)
9974       || (type == error_mark_node))
9975     return error_mark_node;
9976 
9977   item = build (code, type, node1, node2, node3);
9978   TREE_SIDE_EFFECTS (item) = 1;
9979   return fold (item);
9980 }
9981 
9982 /* ffecom_arg_expr -- Transform argument expr into gcc tree
9983 
9984    See use by ffecom_list_expr.
9985 
9986    If expression is NULL, returns an integer zero tree.	 If it is not
9987    a CHARACTER expression, returns whatever ffecom_expr
9988    returns and sets the length return value to NULL_TREE.  Otherwise
9989    generates code to evaluate the character expression, returns the proper
9990    pointer to the result, but does NOT set the length return value to a tree
9991    that specifies the length of the result.  (In other words, the length
9992    variable is always set to NULL_TREE, because a length is never passed.)
9993 
9994    21-Dec-91  JCB  1.1
9995       Don't set returned length, since nobody needs it (yet; someday if
9996       we allow CHARACTER*(*) dummies to statement functions, we'll need
9997       it).  */
9998 
9999 tree
ffecom_arg_expr(ffebld expr,tree * length)10000 ffecom_arg_expr (ffebld expr, tree *length)
10001 {
10002   tree ign;
10003 
10004   *length = NULL_TREE;
10005 
10006   if (expr == NULL)
10007     return integer_zero_node;
10008 
10009   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10010     return ffecom_expr (expr);
10011 
10012   return ffecom_arg_ptr_to_expr (expr, &ign);
10013 }
10014 
10015 /* Transform expression into constant argument-pointer-to-expression tree.
10016 
10017    If the expression can be transformed into a argument-pointer-to-expression
10018    tree that is constant, that is done, and the tree returned.  Else
10019    NULL_TREE is returned.
10020 
10021    That way, a caller can attempt to provide compile-time initialization
10022    of a variable and, if that fails, *then* choose to start a new block
10023    and resort to using temporaries, as appropriate.  */
10024 
10025 tree
ffecom_arg_ptr_to_const_expr(ffebld expr,tree * length)10026 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10027 {
10028   if (! expr)
10029     return integer_zero_node;
10030 
10031   if (ffebld_op (expr) == FFEBLD_opANY)
10032     {
10033       if (length)
10034 	*length = error_mark_node;
10035       return error_mark_node;
10036     }
10037 
10038   if (ffebld_arity (expr) == 0
10039       && (ffebld_op (expr) != FFEBLD_opSYMTER
10040 	  || ffebld_where (expr) == FFEINFO_whereCOMMON
10041 	  || ffebld_where (expr) == FFEINFO_whereGLOBAL
10042 	  || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10043     {
10044       tree t;
10045 
10046       t = ffecom_arg_ptr_to_expr (expr, length);
10047       assert (TREE_CONSTANT (t));
10048       assert (! length || TREE_CONSTANT (*length));
10049       return t;
10050     }
10051 
10052   if (length
10053       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10054     *length = build_int_2 (ffebld_size (expr), 0);
10055   else if (length)
10056     *length = NULL_TREE;
10057   return NULL_TREE;
10058 }
10059 
10060 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10061 
10062    See use by ffecom_list_ptr_to_expr.
10063 
10064    If expression is NULL, returns an integer zero tree.	 If it is not
10065    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10066    returns and sets the length return value to NULL_TREE.  Otherwise
10067    generates code to evaluate the character expression, returns the proper
10068    pointer to the result, AND sets the length return value to a tree that
10069    specifies the length of the result.
10070 
10071    If the length argument is NULL, this is a slightly special
10072    case of building a FORMAT expression, that is, an expression that
10073    will be used at run time without regard to length.  For the current
10074    implementation, which uses the libf2c library, this means it is nice
10075    to append a null byte to the end of the expression, where feasible,
10076    to make sure any diagnostic about the FORMAT string terminates at
10077    some useful point.
10078 
10079    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10080    length argument.  This might even be seen as a feature, if a null
10081    byte can always be appended.  */
10082 
10083 tree
ffecom_arg_ptr_to_expr(ffebld expr,tree * length)10084 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10085 {
10086   tree item;
10087   tree ign_length;
10088   ffecomConcatList_ catlist;
10089 
10090   if (length != NULL)
10091     *length = NULL_TREE;
10092 
10093   if (expr == NULL)
10094     return integer_zero_node;
10095 
10096   switch (ffebld_op (expr))
10097     {
10098     case FFEBLD_opPERCENT_VAL:
10099       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10100 	return ffecom_expr (ffebld_left (expr));
10101       {
10102 	tree temp_exp;
10103 	tree temp_length;
10104 
10105 	temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10106 	if (temp_exp == error_mark_node)
10107 	  return error_mark_node;
10108 
10109 	return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10110 			 temp_exp);
10111       }
10112 
10113     case FFEBLD_opPERCENT_REF:
10114       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10115 	return ffecom_ptr_to_expr (ffebld_left (expr));
10116       if (length != NULL)
10117 	{
10118 	  ign_length = NULL_TREE;
10119 	  length = &ign_length;
10120 	}
10121       expr = ffebld_left (expr);
10122       break;
10123 
10124     case FFEBLD_opPERCENT_DESCR:
10125       switch (ffeinfo_basictype (ffebld_info (expr)))
10126 	{
10127 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10128 	case FFEINFO_basictypeHOLLERITH:
10129 #endif
10130 	case FFEINFO_basictypeCHARACTER:
10131 	  break;		/* Passed by descriptor anyway. */
10132 
10133 	default:
10134 	  item = ffecom_ptr_to_expr (expr);
10135 	  if (item != error_mark_node)
10136 	    *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10137 	  break;
10138 	}
10139       break;
10140 
10141     default:
10142       break;
10143     }
10144 
10145 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10146   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10147       && (length != NULL))
10148     {				/* Pass Hollerith by descriptor. */
10149       ffetargetHollerith h;
10150 
10151       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10152       h = ffebld_cu_val_hollerith (ffebld_constant_union
10153 				   (ffebld_conter (expr)));
10154       *length
10155 	= build_int_2 (h.length, 0);
10156       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10157     }
10158 #endif
10159 
10160   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10161     return ffecom_ptr_to_expr (expr);
10162 
10163   assert (ffeinfo_kindtype (ffebld_info (expr))
10164 	  == FFEINFO_kindtypeCHARACTER1);
10165 
10166   while (ffebld_op (expr) == FFEBLD_opPAREN)
10167     expr = ffebld_left (expr);
10168 
10169   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10170   switch (ffecom_concat_list_count_ (catlist))
10171     {
10172     case 0:			/* Shouldn't happen, but in case it does... */
10173       if (length != NULL)
10174 	{
10175 	  *length = ffecom_f2c_ftnlen_zero_node;
10176 	  TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10177 	}
10178       ffecom_concat_list_kill_ (catlist);
10179       return null_pointer_node;
10180 
10181     case 1:			/* The (fairly) easy case. */
10182       if (length == NULL)
10183 	ffecom_char_args_with_null_ (&item, &ign_length,
10184 				     ffecom_concat_list_expr_ (catlist, 0));
10185       else
10186 	ffecom_char_args_ (&item, length,
10187 			   ffecom_concat_list_expr_ (catlist, 0));
10188       ffecom_concat_list_kill_ (catlist);
10189       assert (item != NULL_TREE);
10190       return item;
10191 
10192     default:			/* Must actually concatenate things. */
10193       break;
10194     }
10195 
10196   {
10197     int count = ffecom_concat_list_count_ (catlist);
10198     int i;
10199     tree lengths;
10200     tree items;
10201     tree length_array;
10202     tree item_array;
10203     tree citem;
10204     tree clength;
10205     tree temporary;
10206     tree num;
10207     tree known_length;
10208     ffetargetCharacterSize sz;
10209 
10210     sz = ffecom_concat_list_maxlen_ (catlist);
10211     /* ~~Kludge! */
10212     assert (sz != FFETARGET_charactersizeNONE);
10213 
10214     {
10215       tree hook;
10216 
10217       hook = ffebld_nonter_hook (expr);
10218       assert (hook);
10219       assert (TREE_CODE (hook) == TREE_VEC);
10220       assert (TREE_VEC_LENGTH (hook) == 3);
10221       length_array = lengths = TREE_VEC_ELT (hook, 0);
10222       item_array = items = TREE_VEC_ELT (hook, 1);
10223       temporary = TREE_VEC_ELT (hook, 2);
10224     }
10225 
10226     known_length = ffecom_f2c_ftnlen_zero_node;
10227 
10228     for (i = 0; i < count; ++i)
10229       {
10230 	if ((i == count)
10231 	    && (length == NULL))
10232 	  ffecom_char_args_with_null_ (&citem, &clength,
10233 				       ffecom_concat_list_expr_ (catlist, i));
10234 	else
10235 	  ffecom_char_args_ (&citem, &clength,
10236 			     ffecom_concat_list_expr_ (catlist, i));
10237 	if ((citem == error_mark_node)
10238 	    || (clength == error_mark_node))
10239 	  {
10240 	    ffecom_concat_list_kill_ (catlist);
10241 	    *length = error_mark_node;
10242 	    return error_mark_node;
10243 	  }
10244 
10245 	items
10246 	  = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10247 		      ffecom_modify (void_type_node,
10248 				     ffecom_2 (ARRAY_REF,
10249 		     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10250 					       item_array,
10251 					       build_int_2 (i, 0)),
10252 				     citem),
10253 		      items);
10254 	clength = ffecom_save_tree (clength);
10255 	if (length != NULL)
10256 	  known_length
10257 	    = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10258 			known_length,
10259 			clength);
10260 	lengths
10261 	  = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10262 		      ffecom_modify (void_type_node,
10263 				     ffecom_2 (ARRAY_REF,
10264 		   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10265 					       length_array,
10266 					       build_int_2 (i, 0)),
10267 				     clength),
10268 		      lengths);
10269       }
10270 
10271     temporary = ffecom_1 (ADDR_EXPR,
10272 			  build_pointer_type (TREE_TYPE (temporary)),
10273 			  temporary);
10274 
10275     item = build_tree_list (NULL_TREE, temporary);
10276     TREE_CHAIN (item)
10277       = build_tree_list (NULL_TREE,
10278 			 ffecom_1 (ADDR_EXPR,
10279 				   build_pointer_type (TREE_TYPE (items)),
10280 				   items));
10281     TREE_CHAIN (TREE_CHAIN (item))
10282       = build_tree_list (NULL_TREE,
10283 			 ffecom_1 (ADDR_EXPR,
10284 				   build_pointer_type (TREE_TYPE (lengths)),
10285 				   lengths));
10286     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10287       = build_tree_list
10288 	(NULL_TREE,
10289 	 ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10290 		   convert (ffecom_f2c_ftnlen_type_node,
10291 			    build_int_2 (count, 0))));
10292     num = build_int_2 (sz, 0);
10293     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10294     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10295       = build_tree_list (NULL_TREE, num);
10296 
10297     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10298     TREE_SIDE_EFFECTS (item) = 1;
10299     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10300 		     item,
10301 		     temporary);
10302 
10303     if (length != NULL)
10304       *length = known_length;
10305   }
10306 
10307   ffecom_concat_list_kill_ (catlist);
10308   assert (item != NULL_TREE);
10309   return item;
10310 }
10311 
10312 /* Generate call to run-time function.
10313 
10314    The first arg is the GNU Fortran Run-Time function index, the second
10315    arg is the list of arguments to pass to it.	Returned is the expression
10316    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10317    result (which may be void).	*/
10318 
10319 tree
ffecom_call_gfrt(ffecomGfrt ix,tree args,tree hook)10320 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10321 {
10322   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10323 		       ffecom_gfrt_kindtype (ix),
10324 		       ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10325 		       NULL_TREE, args, NULL_TREE, NULL,
10326 		       NULL, NULL_TREE, TRUE, hook);
10327 }
10328 
10329 /* Transform constant-union to tree.  */
10330 
10331 tree
ffecom_constantunion(ffebldConstantUnion * cu,ffeinfoBasictype bt,ffeinfoKindtype kt,tree tree_type)10332 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10333 		      ffeinfoKindtype kt, tree tree_type)
10334 {
10335   tree item;
10336 
10337   switch (bt)
10338     {
10339     case FFEINFO_basictypeINTEGER:
10340       {
10341 	int val;
10342 
10343 	switch (kt)
10344 	  {
10345 #if FFETARGET_okINTEGER1
10346 	  case FFEINFO_kindtypeINTEGER1:
10347 	    val = ffebld_cu_val_integer1 (*cu);
10348 	    break;
10349 #endif
10350 
10351 #if FFETARGET_okINTEGER2
10352 	  case FFEINFO_kindtypeINTEGER2:
10353 	    val = ffebld_cu_val_integer2 (*cu);
10354 	    break;
10355 #endif
10356 
10357 #if FFETARGET_okINTEGER3
10358 	  case FFEINFO_kindtypeINTEGER3:
10359 	    val = ffebld_cu_val_integer3 (*cu);
10360 	    break;
10361 #endif
10362 
10363 #if FFETARGET_okINTEGER4
10364 	  case FFEINFO_kindtypeINTEGER4:
10365 	    val = ffebld_cu_val_integer4 (*cu);
10366 	    break;
10367 #endif
10368 
10369 	  default:
10370 	    assert ("bad INTEGER constant kind type" == NULL);
10371 	    /* Fall through. */
10372 	  case FFEINFO_kindtypeANY:
10373 	    return error_mark_node;
10374 	  }
10375 	item = build_int_2 (val, (val < 0) ? -1 : 0);
10376 	TREE_TYPE (item) = tree_type;
10377       }
10378       break;
10379 
10380     case FFEINFO_basictypeLOGICAL:
10381       {
10382 	int val;
10383 
10384 	switch (kt)
10385 	  {
10386 #if FFETARGET_okLOGICAL1
10387 	  case FFEINFO_kindtypeLOGICAL1:
10388 	    val = ffebld_cu_val_logical1 (*cu);
10389 	    break;
10390 #endif
10391 
10392 #if FFETARGET_okLOGICAL2
10393 	  case FFEINFO_kindtypeLOGICAL2:
10394 	    val = ffebld_cu_val_logical2 (*cu);
10395 	    break;
10396 #endif
10397 
10398 #if FFETARGET_okLOGICAL3
10399 	  case FFEINFO_kindtypeLOGICAL3:
10400 	    val = ffebld_cu_val_logical3 (*cu);
10401 	    break;
10402 #endif
10403 
10404 #if FFETARGET_okLOGICAL4
10405 	  case FFEINFO_kindtypeLOGICAL4:
10406 	    val = ffebld_cu_val_logical4 (*cu);
10407 	    break;
10408 #endif
10409 
10410 	  default:
10411 	    assert ("bad LOGICAL constant kind type" == NULL);
10412 	    /* Fall through. */
10413 	  case FFEINFO_kindtypeANY:
10414 	    return error_mark_node;
10415 	  }
10416 	item = build_int_2 (val, (val < 0) ? -1 : 0);
10417 	TREE_TYPE (item) = tree_type;
10418       }
10419       break;
10420 
10421     case FFEINFO_basictypeREAL:
10422       {
10423 	REAL_VALUE_TYPE val;
10424 
10425 	switch (kt)
10426 	  {
10427 #if FFETARGET_okREAL1
10428 	  case FFEINFO_kindtypeREAL1:
10429 	    val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10430 	    break;
10431 #endif
10432 
10433 #if FFETARGET_okREAL2
10434 	  case FFEINFO_kindtypeREAL2:
10435 	    val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10436 	    break;
10437 #endif
10438 
10439 #if FFETARGET_okREAL3
10440 	  case FFEINFO_kindtypeREAL3:
10441 	    val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10442 	    break;
10443 #endif
10444 
10445 #if FFETARGET_okREAL4
10446 	  case FFEINFO_kindtypeREAL4:
10447 	    val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10448 	    break;
10449 #endif
10450 
10451 	  default:
10452 	    assert ("bad REAL constant kind type" == NULL);
10453 	    /* Fall through. */
10454 	  case FFEINFO_kindtypeANY:
10455 	    return error_mark_node;
10456 	  }
10457 	item = build_real (tree_type, val);
10458       }
10459       break;
10460 
10461     case FFEINFO_basictypeCOMPLEX:
10462       {
10463 	REAL_VALUE_TYPE real;
10464 	REAL_VALUE_TYPE imag;
10465 	tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10466 
10467 	switch (kt)
10468 	  {
10469 #if FFETARGET_okCOMPLEX1
10470 	  case FFEINFO_kindtypeREAL1:
10471 	    real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10472 	    imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10473 	    break;
10474 #endif
10475 
10476 #if FFETARGET_okCOMPLEX2
10477 	  case FFEINFO_kindtypeREAL2:
10478 	    real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10479 	    imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10480 	    break;
10481 #endif
10482 
10483 #if FFETARGET_okCOMPLEX3
10484 	  case FFEINFO_kindtypeREAL3:
10485 	    real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10486 	    imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10487 	    break;
10488 #endif
10489 
10490 #if FFETARGET_okCOMPLEX4
10491 	  case FFEINFO_kindtypeREAL4:
10492 	    real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10493 	    imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10494 	    break;
10495 #endif
10496 
10497 	  default:
10498 	    assert ("bad REAL constant kind type" == NULL);
10499 	    /* Fall through. */
10500 	  case FFEINFO_kindtypeANY:
10501 	    return error_mark_node;
10502 	  }
10503 	item = ffecom_build_complex_constant_ (tree_type,
10504 					       build_real (el_type, real),
10505 					       build_real (el_type, imag));
10506       }
10507       break;
10508 
10509     case FFEINFO_basictypeCHARACTER:
10510       {				/* Happens only in DATA and similar contexts. */
10511 	ffetargetCharacter1 val;
10512 
10513 	switch (kt)
10514 	  {
10515 #if FFETARGET_okCHARACTER1
10516 	  case FFEINFO_kindtypeLOGICAL1:
10517 	    val = ffebld_cu_val_character1 (*cu);
10518 	    break;
10519 #endif
10520 
10521 	  default:
10522 	    assert ("bad CHARACTER constant kind type" == NULL);
10523 	    /* Fall through. */
10524 	  case FFEINFO_kindtypeANY:
10525 	    return error_mark_node;
10526 	  }
10527 	item = build_string (ffetarget_length_character1 (val),
10528 			     ffetarget_text_character1 (val));
10529 	TREE_TYPE (item)
10530 	  = build_type_variant (build_array_type (char_type_node,
10531 						  build_range_type
10532 						  (integer_type_node,
10533 						   integer_one_node,
10534 						   build_int_2
10535 						(ffetarget_length_character1
10536 						 (val), 0))),
10537 				1, 0);
10538       }
10539       break;
10540 
10541     case FFEINFO_basictypeHOLLERITH:
10542       {
10543 	ffetargetHollerith h;
10544 
10545 	h = ffebld_cu_val_hollerith (*cu);
10546 
10547 	/* If not at least as wide as default INTEGER, widen it.  */
10548 	if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10549 	  item = build_string (h.length, h.text);
10550 	else
10551 	  {
10552 	    char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10553 
10554 	    memcpy (str, h.text, h.length);
10555 	    memset (&str[h.length], ' ',
10556 		    FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10557 		    - h.length);
10558 	    item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10559 				 str);
10560 	  }
10561 	TREE_TYPE (item)
10562 	  = build_type_variant (build_array_type (char_type_node,
10563 						  build_range_type
10564 						  (integer_type_node,
10565 						   integer_one_node,
10566 						   build_int_2
10567 						   (h.length, 0))),
10568 				1, 0);
10569       }
10570       break;
10571 
10572     case FFEINFO_basictypeTYPELESS:
10573       {
10574 	ffetargetInteger1 ival;
10575 	ffetargetTypeless tless;
10576 	ffebad error;
10577 
10578 	tless = ffebld_cu_val_typeless (*cu);
10579 	error = ffetarget_convert_integer1_typeless (&ival, tless);
10580 	assert (error == FFEBAD);
10581 
10582 	item = build_int_2 ((int) ival, 0);
10583       }
10584       break;
10585 
10586     default:
10587       assert ("not yet on constant type" == NULL);
10588       /* Fall through. */
10589     case FFEINFO_basictypeANY:
10590       return error_mark_node;
10591     }
10592 
10593   TREE_CONSTANT (item) = 1;
10594 
10595   return item;
10596 }
10597 
10598 /* Transform constant-union to tree, with the type known.  */
10599 
10600 tree
ffecom_constantunion_with_type(ffebldConstantUnion * cu,tree tree_type,ffebldConst ct)10601 ffecom_constantunion_with_type (ffebldConstantUnion *cu,
10602 		      tree tree_type, ffebldConst ct)
10603 {
10604   tree item;
10605 
10606   int val;
10607 
10608   switch (ct)
10609   {
10610 #if FFETARGET_okINTEGER1
10611 	  case  FFEBLD_constINTEGER1:
10612          	  val = ffebld_cu_val_integer1 (*cu);
10613 		  item = build_int_2 (val, (val < 0) ? -1 : 0);
10614 		  break;
10615 #endif
10616 #if FFETARGET_okINTEGER2
10617 	  case  FFEBLD_constINTEGER2:
10618 		  val = ffebld_cu_val_integer2 (*cu);
10619 		  item = build_int_2 (val, (val < 0) ? -1 : 0);
10620 		  break;
10621 #endif
10622 #if FFETARGET_okINTEGER3
10623 	  case  FFEBLD_constINTEGER3:
10624 		  val = ffebld_cu_val_integer3 (*cu);
10625 		  item = build_int_2 (val, (val < 0) ? -1 : 0);
10626 		  break;
10627 #endif
10628 #if FFETARGET_okINTEGER4
10629 	  case  FFEBLD_constINTEGER4:
10630 		  val = ffebld_cu_val_integer4 (*cu);
10631 		  item = build_int_2 (val, (val < 0) ? -1 : 0);
10632 		  break;
10633 #endif
10634 #if FFETARGET_okLOGICAL1
10635 	  case  FFEBLD_constLOGICAL1:
10636 		  val = ffebld_cu_val_logical1 (*cu);
10637 		  item = build_int_2 (val, (val < 0) ? -1 : 0);
10638 		  break;
10639 #endif
10640 #if FFETARGET_okLOGICAL2
10641           case  FFEBLD_constLOGICAL2:
10642 		  val = ffebld_cu_val_logical2 (*cu);
10643 		  item = build_int_2 (val, (val < 0) ? -1 : 0);
10644 		  break;
10645 #endif
10646 #if FFETARGET_okLOGICAL3
10647 	  case  FFEBLD_constLOGICAL3:
10648 		  val = ffebld_cu_val_logical3 (*cu);
10649 		  item = build_int_2 (val, (val < 0) ? -1 : 0);
10650 		  break;
10651 #endif
10652 #if FFETARGET_okLOGICAL4
10653 	  case  FFEBLD_constLOGICAL4:
10654 		  val = ffebld_cu_val_logical4 (*cu);
10655 		  item = build_int_2 (val, (val < 0) ? -1 : 0);
10656 		  break;
10657 #endif
10658 	  default:
10659 		  assert ("constant type not supported"==NULL);
10660 		  return error_mark_node;
10661 		  break;
10662   }
10663 
10664   TREE_TYPE (item) = tree_type;
10665 
10666   TREE_CONSTANT (item) = 1;
10667 
10668   return item;
10669 }
10670 /* Transform expression into constant tree.
10671 
10672    If the expression can be transformed into a tree that is constant,
10673    that is done, and the tree returned.  Else NULL_TREE is returned.
10674 
10675    That way, a caller can attempt to provide compile-time initialization
10676    of a variable and, if that fails, *then* choose to start a new block
10677    and resort to using temporaries, as appropriate.  */
10678 
10679 tree
ffecom_const_expr(ffebld expr)10680 ffecom_const_expr (ffebld expr)
10681 {
10682   if (! expr)
10683     return integer_zero_node;
10684 
10685   if (ffebld_op (expr) == FFEBLD_opANY)
10686     return error_mark_node;
10687 
10688   if (ffebld_arity (expr) == 0
10689       && (ffebld_op (expr) != FFEBLD_opSYMTER
10690 #if NEWCOMMON
10691 	  /* ~~Enable once common/equivalence is handled properly?  */
10692 	  || ffebld_where (expr) == FFEINFO_whereCOMMON
10693 #endif
10694 	  || ffebld_where (expr) == FFEINFO_whereGLOBAL
10695 	  || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10696     {
10697       tree t;
10698 
10699       t = ffecom_expr (expr);
10700       assert (TREE_CONSTANT (t));
10701       return t;
10702     }
10703 
10704   return NULL_TREE;
10705 }
10706 
10707 /* Handy way to make a field in a struct/union.  */
10708 
10709 tree
ffecom_decl_field(tree context,tree prevfield,const char * name,tree type)10710 ffecom_decl_field (tree context, tree prevfield,
10711 		   const char *name, tree type)
10712 {
10713   tree field;
10714 
10715   field = build_decl (FIELD_DECL, get_identifier (name), type);
10716   DECL_CONTEXT (field) = context;
10717   DECL_ALIGN (field) = 0;
10718   DECL_USER_ALIGN (field) = 0;
10719   if (prevfield != NULL_TREE)
10720     TREE_CHAIN (prevfield) = field;
10721 
10722   return field;
10723 }
10724 
10725 void
ffecom_close_include(FILE * f)10726 ffecom_close_include (FILE *f)
10727 {
10728   ffecom_close_include_ (f);
10729 }
10730 
10731 int
ffecom_decode_include_option(char * spec)10732 ffecom_decode_include_option (char *spec)
10733 {
10734   return ffecom_decode_include_option_ (spec);
10735 }
10736 
10737 /* End a compound statement (block).  */
10738 
10739 tree
ffecom_end_compstmt(void)10740 ffecom_end_compstmt (void)
10741 {
10742   return bison_rule_compstmt_ ();
10743 }
10744 
10745 /* ffecom_end_transition -- Perform end transition on all symbols
10746 
10747    ffecom_end_transition();
10748 
10749    Calls ffecom_sym_end_transition for each global and local symbol.  */
10750 
10751 void
ffecom_end_transition()10752 ffecom_end_transition ()
10753 {
10754   ffebld item;
10755 
10756   if (ffe_is_ffedebug ())
10757     fprintf (dmpout, "; end_stmt_transition\n");
10758 
10759   ffecom_list_blockdata_ = NULL;
10760   ffecom_list_common_ = NULL;
10761 
10762   ffesymbol_drive (ffecom_sym_end_transition);
10763   if (ffe_is_ffedebug ())
10764     {
10765       ffestorag_report ();
10766     }
10767 
10768   ffecom_start_progunit_ ();
10769 
10770   for (item = ffecom_list_blockdata_;
10771        item != NULL;
10772        item = ffebld_trail (item))
10773     {
10774       ffebld callee;
10775       ffesymbol s;
10776       tree dt;
10777       tree t;
10778       tree var;
10779       static int number = 0;
10780 
10781       callee = ffebld_head (item);
10782       s = ffebld_symter (callee);
10783       t = ffesymbol_hook (s).decl_tree;
10784       if (t == NULL_TREE)
10785 	{
10786 	  s = ffecom_sym_transform_ (s);
10787 	  t = ffesymbol_hook (s).decl_tree;
10788 	}
10789 
10790       dt = build_pointer_type (TREE_TYPE (t));
10791 
10792       var = build_decl (VAR_DECL,
10793 			ffecom_get_invented_identifier ("__g77_forceload_%d",
10794 							number++),
10795 			dt);
10796       DECL_EXTERNAL (var) = 0;
10797       TREE_STATIC (var) = 1;
10798       TREE_PUBLIC (var) = 0;
10799       DECL_INITIAL (var) = error_mark_node;
10800       TREE_USED (var) = 1;
10801 
10802       var = start_decl (var, FALSE);
10803 
10804       t = ffecom_1 (ADDR_EXPR, dt, t);
10805 
10806       finish_decl (var, t, FALSE);
10807     }
10808 
10809   /* This handles any COMMON areas that weren't referenced but have, for
10810      example, important initial data.  */
10811 
10812   for (item = ffecom_list_common_;
10813        item != NULL;
10814        item = ffebld_trail (item))
10815     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10816 
10817   ffecom_list_common_ = NULL;
10818 }
10819 
10820 /* ffecom_exec_transition -- Perform exec transition on all symbols
10821 
10822    ffecom_exec_transition();
10823 
10824    Calls ffecom_sym_exec_transition for each global and local symbol.
10825    Make sure error updating not inhibited.  */
10826 
10827 void
ffecom_exec_transition()10828 ffecom_exec_transition ()
10829 {
10830   bool inhibited;
10831 
10832   if (ffe_is_ffedebug ())
10833     fprintf (dmpout, "; exec_stmt_transition\n");
10834 
10835   inhibited = ffebad_inhibit ();
10836   ffebad_set_inhibit (FALSE);
10837 
10838   ffesymbol_drive (ffecom_sym_exec_transition);	/* Don't retract! */
10839   ffeequiv_exec_transition ();	/* Handle all pending EQUIVALENCEs. */
10840   if (ffe_is_ffedebug ())
10841     {
10842       ffestorag_report ();
10843     }
10844 
10845   if (inhibited)
10846     ffebad_set_inhibit (TRUE);
10847 }
10848 
10849 /* Handle assignment statement.
10850 
10851    Convert dest and source using ffecom_expr, then join them
10852    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
10853 
10854 void
ffecom_expand_let_stmt(ffebld dest,ffebld source)10855 ffecom_expand_let_stmt (ffebld dest, ffebld source)
10856 {
10857   tree dest_tree;
10858   tree dest_length;
10859   tree source_tree;
10860   tree expr_tree;
10861 
10862   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
10863     {
10864       bool dest_used;
10865       tree assign_temp;
10866 
10867       /* This attempts to replicate the test below, but must not be
10868 	 true when the test below is false.  (Always err on the side
10869 	 of creating unused temporaries, to avoid ICEs.)  */
10870       if (ffebld_op (dest) != FFEBLD_opSYMTER
10871 	  || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
10872 	      && (TREE_CODE (dest_tree) != VAR_DECL
10873 		  || TREE_ADDRESSABLE (dest_tree))))
10874 	{
10875 	  ffecom_prepare_expr_ (source, dest);
10876 	  dest_used = TRUE;
10877 	}
10878       else
10879 	{
10880 	  ffecom_prepare_expr_ (source, NULL);
10881 	  dest_used = FALSE;
10882 	}
10883 
10884       ffecom_prepare_expr_w (NULL_TREE, dest);
10885 
10886       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10887 	 create a temporary through which the assignment is to take place,
10888 	 since MODIFY_EXPR doesn't handle partial overlap properly.  */
10889       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
10890 	  && ffecom_possible_partial_overlap_ (dest, source))
10891 	{
10892 	  assign_temp = ffecom_make_tempvar ("complex_let",
10893 					     ffecom_tree_type
10894 					     [ffebld_basictype (dest)]
10895 					     [ffebld_kindtype (dest)],
10896 					     FFETARGET_charactersizeNONE,
10897 					     -1);
10898 	}
10899       else
10900 	assign_temp = NULL_TREE;
10901 
10902       ffecom_prepare_end ();
10903 
10904       dest_tree = ffecom_expr_w (NULL_TREE, dest);
10905       if (dest_tree == error_mark_node)
10906 	return;
10907 
10908       if ((TREE_CODE (dest_tree) != VAR_DECL)
10909 	  || TREE_ADDRESSABLE (dest_tree))
10910 	source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
10911 				    FALSE, FALSE);
10912       else
10913 	{
10914 	  assert (! dest_used);
10915 	  dest_used = FALSE;
10916 	  source_tree = ffecom_expr (source);
10917 	}
10918       if (source_tree == error_mark_node)
10919 	return;
10920 
10921       if (dest_used)
10922 	expr_tree = source_tree;
10923       else if (assign_temp)
10924 	{
10925 #ifdef MOVE_EXPR
10926 	  /* The back end understands a conceptual move (evaluate source;
10927 	     store into dest), so use that, in case it can determine
10928 	     that it is going to use, say, two registers as temporaries
10929 	     anyway.  So don't use the temp (and someday avoid generating
10930 	     it, once this code starts triggering regularly).  */
10931 	  expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
10932 				 dest_tree,
10933 				 source_tree);
10934 #else
10935 	  expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10936 				 assign_temp,
10937 				 source_tree);
10938 	  expand_expr_stmt (expr_tree);
10939 	  expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10940 				 dest_tree,
10941 				 assign_temp);
10942 #endif
10943 	}
10944       else
10945 	expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
10946 			       dest_tree,
10947 			       source_tree);
10948 
10949       expand_expr_stmt (expr_tree);
10950       return;
10951     }
10952 
10953   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
10954   ffecom_prepare_expr_w (NULL_TREE, dest);
10955 
10956   ffecom_prepare_end ();
10957 
10958   ffecom_char_args_ (&dest_tree, &dest_length, dest);
10959   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
10960 		    source);
10961 }
10962 
10963 /* ffecom_expr -- Transform expr into gcc tree
10964 
10965    tree t;
10966    ffebld expr;	 // FFE expression.
10967    tree = ffecom_expr(expr);
10968 
10969    Recursive descent on expr while making corresponding tree nodes and
10970    attaching type info and such.  */
10971 
10972 tree
ffecom_expr(ffebld expr)10973 ffecom_expr (ffebld expr)
10974 {
10975   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
10976 }
10977 
10978 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
10979 
10980 tree
ffecom_expr_assign(ffebld expr)10981 ffecom_expr_assign (ffebld expr)
10982 {
10983   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10984 }
10985 
10986 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
10987 
10988 tree
ffecom_expr_assign_w(ffebld expr)10989 ffecom_expr_assign_w (ffebld expr)
10990 {
10991   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
10992 }
10993 
10994 /* Transform expr for use as into read/write tree and stabilize the
10995    reference.  Not for use on CHARACTER expressions.
10996 
10997    Recursive descent on expr while making corresponding tree nodes and
10998    attaching type info and such.  */
10999 
11000 tree
ffecom_expr_rw(tree type,ffebld expr)11001 ffecom_expr_rw (tree type, ffebld expr)
11002 {
11003   assert (expr != NULL);
11004   /* Different target types not yet supported.  */
11005   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11006 
11007   return stabilize_reference (ffecom_expr (expr));
11008 }
11009 
11010 /* Transform expr for use as into write tree and stabilize the
11011    reference.  Not for use on CHARACTER expressions.
11012 
11013    Recursive descent on expr while making corresponding tree nodes and
11014    attaching type info and such.  */
11015 
11016 tree
ffecom_expr_w(tree type,ffebld expr)11017 ffecom_expr_w (tree type, ffebld expr)
11018 {
11019   assert (expr != NULL);
11020   /* Different target types not yet supported.  */
11021   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11022 
11023   return stabilize_reference (ffecom_expr (expr));
11024 }
11025 
11026 /* Do global stuff.  */
11027 
11028 void
ffecom_finish_compile()11029 ffecom_finish_compile ()
11030 {
11031   assert (ffecom_outer_function_decl_ == NULL_TREE);
11032   assert (current_function_decl == NULL_TREE);
11033 
11034   ffeglobal_drive (ffecom_finish_global_);
11035 }
11036 
11037 /* Public entry point for front end to access finish_decl.  */
11038 
11039 void
ffecom_finish_decl(tree decl,tree init,bool is_top_level)11040 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11041 {
11042   assert (!is_top_level);
11043   finish_decl (decl, init, FALSE);
11044 }
11045 
11046 /* Finish a program unit.  */
11047 
11048 void
ffecom_finish_progunit()11049 ffecom_finish_progunit ()
11050 {
11051   ffecom_end_compstmt ();
11052 
11053   ffecom_previous_function_decl_ = current_function_decl;
11054   ffecom_which_entrypoint_decl_ = NULL_TREE;
11055 
11056   finish_function (0);
11057 }
11058 
11059 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11060 
11061 tree
ffecom_get_invented_identifier(const char * pattern,...)11062 ffecom_get_invented_identifier (const char *pattern, ...)
11063 {
11064   tree decl;
11065   char *nam;
11066   va_list ap;
11067 
11068   va_start (ap, pattern);
11069   if (vasprintf (&nam, pattern, ap) == 0)
11070     abort ();
11071   va_end (ap);
11072   decl = get_identifier (nam);
11073   free (nam);
11074   IDENTIFIER_INVENTED (decl) = 1;
11075   return decl;
11076 }
11077 
11078 ffeinfoBasictype
ffecom_gfrt_basictype(ffecomGfrt gfrt)11079 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11080 {
11081   assert (gfrt < FFECOM_gfrt);
11082 
11083   switch (ffecom_gfrt_type_[gfrt])
11084     {
11085     case FFECOM_rttypeVOID_:
11086     case FFECOM_rttypeVOIDSTAR_:
11087       return FFEINFO_basictypeNONE;
11088 
11089     case FFECOM_rttypeFTNINT_:
11090       return FFEINFO_basictypeINTEGER;
11091 
11092     case FFECOM_rttypeINTEGER_:
11093       return FFEINFO_basictypeINTEGER;
11094 
11095     case FFECOM_rttypeLONGINT_:
11096       return FFEINFO_basictypeINTEGER;
11097 
11098     case FFECOM_rttypeLOGICAL_:
11099       return FFEINFO_basictypeLOGICAL;
11100 
11101     case FFECOM_rttypeREAL_F2C_:
11102     case FFECOM_rttypeREAL_GNU_:
11103       return FFEINFO_basictypeREAL;
11104 
11105     case FFECOM_rttypeCOMPLEX_F2C_:
11106     case FFECOM_rttypeCOMPLEX_GNU_:
11107       return FFEINFO_basictypeCOMPLEX;
11108 
11109     case FFECOM_rttypeDOUBLE_:
11110     case FFECOM_rttypeDOUBLEREAL_:
11111       return FFEINFO_basictypeREAL;
11112 
11113     case FFECOM_rttypeDBLCMPLX_F2C_:
11114     case FFECOM_rttypeDBLCMPLX_GNU_:
11115       return FFEINFO_basictypeCOMPLEX;
11116 
11117     case FFECOM_rttypeCHARACTER_:
11118       return FFEINFO_basictypeCHARACTER;
11119 
11120     default:
11121       return FFEINFO_basictypeANY;
11122     }
11123 }
11124 
11125 ffeinfoKindtype
ffecom_gfrt_kindtype(ffecomGfrt gfrt)11126 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11127 {
11128   assert (gfrt < FFECOM_gfrt);
11129 
11130   switch (ffecom_gfrt_type_[gfrt])
11131     {
11132     case FFECOM_rttypeVOID_:
11133     case FFECOM_rttypeVOIDSTAR_:
11134       return FFEINFO_kindtypeNONE;
11135 
11136     case FFECOM_rttypeFTNINT_:
11137       return FFEINFO_kindtypeINTEGER1;
11138 
11139     case FFECOM_rttypeINTEGER_:
11140       return FFEINFO_kindtypeINTEGER1;
11141 
11142     case FFECOM_rttypeLONGINT_:
11143       return FFEINFO_kindtypeINTEGER4;
11144 
11145     case FFECOM_rttypeLOGICAL_:
11146       return FFEINFO_kindtypeLOGICAL1;
11147 
11148     case FFECOM_rttypeREAL_F2C_:
11149     case FFECOM_rttypeREAL_GNU_:
11150       return FFEINFO_kindtypeREAL1;
11151 
11152     case FFECOM_rttypeCOMPLEX_F2C_:
11153     case FFECOM_rttypeCOMPLEX_GNU_:
11154       return FFEINFO_kindtypeREAL1;
11155 
11156     case FFECOM_rttypeDOUBLE_:
11157     case FFECOM_rttypeDOUBLEREAL_:
11158       return FFEINFO_kindtypeREAL2;
11159 
11160     case FFECOM_rttypeDBLCMPLX_F2C_:
11161     case FFECOM_rttypeDBLCMPLX_GNU_:
11162       return FFEINFO_kindtypeREAL2;
11163 
11164     case FFECOM_rttypeCHARACTER_:
11165       return FFEINFO_kindtypeCHARACTER1;
11166 
11167     default:
11168       return FFEINFO_kindtypeANY;
11169     }
11170 }
11171 
11172 void
ffecom_init_0()11173 ffecom_init_0 ()
11174 {
11175   tree endlink;
11176   int i;
11177   int j;
11178   tree t;
11179   tree field;
11180   ffetype type;
11181   ffetype base_type;
11182   tree double_ftype_double;
11183   tree float_ftype_float;
11184   tree ldouble_ftype_ldouble;
11185   tree ffecom_tree_ptr_to_fun_type_void;
11186 
11187   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11188      whether the compiler environment is buggy in known ways, some of which
11189      would, if not explicitly checked here, result in subtle bugs in g77.  */
11190 
11191   if (ffe_is_do_internal_checks ())
11192     {
11193       static const char names[][12]
11194 	=
11195       {"bar", "bletch", "foo", "foobar"};
11196       const char *name;
11197       unsigned long ul;
11198       double fl;
11199 
11200       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11201 		      (int (*)(const void *, const void *)) strcmp);
11202       if (name != &names[2][0])
11203 	{
11204 	  assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11205 		  == NULL);
11206 	  abort ();
11207 	}
11208 
11209       ul = strtoul ("123456789", NULL, 10);
11210       if (ul != 123456789L)
11211 	{
11212 	  assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11213  in proj.h" == NULL);
11214 	  abort ();
11215 	}
11216 
11217       fl = atof ("56.789");
11218       if ((fl < 56.788) || (fl > 56.79))
11219 	{
11220 	  assert ("atof not type double, fix your #include <stdio.h>"
11221 		  == NULL);
11222 	  abort ();
11223 	}
11224     }
11225 
11226   ffecom_outer_function_decl_ = NULL_TREE;
11227   current_function_decl = NULL_TREE;
11228   named_labels = NULL_TREE;
11229   current_binding_level = NULL_BINDING_LEVEL;
11230   free_binding_level = NULL_BINDING_LEVEL;
11231   /* Make the binding_level structure for global names.  */
11232   pushlevel (0);
11233   global_binding_level = current_binding_level;
11234   current_binding_level->prep_state = 2;
11235 
11236   build_common_tree_nodes (1);
11237 
11238   /* Define `int' and `char' first so that dbx will output them first.  */
11239   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11240 			integer_type_node));
11241   /* CHARACTER*1 is unsigned in ICHAR contexts.  */
11242   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11243   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11244 			char_type_node));
11245   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11246 			long_integer_type_node));
11247   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11248 			unsigned_type_node));
11249   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11250 			long_unsigned_type_node));
11251   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11252 			long_long_integer_type_node));
11253   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11254 			long_long_unsigned_type_node));
11255   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11256 			short_integer_type_node));
11257   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11258 			short_unsigned_type_node));
11259 
11260   /* Set the sizetype before we make other types.  This *should* be the
11261      first type we create.  */
11262 
11263   set_sizetype
11264     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11265   ffecom_typesize_pointer_
11266     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11267 
11268   build_common_tree_nodes_2 (0);
11269 
11270   /* Define both `signed char' and `unsigned char'.  */
11271   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11272 			signed_char_type_node));
11273 
11274   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11275 			unsigned_char_type_node));
11276 
11277   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11278 			float_type_node));
11279   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11280 			double_type_node));
11281   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11282 			long_double_type_node));
11283 
11284   /* For now, override what build_common_tree_nodes has done.  */
11285   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11286   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11287   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11288   complex_long_double_type_node
11289     = ffecom_make_complex_type_ (long_double_type_node);
11290 
11291   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11292 			complex_integer_type_node));
11293   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11294 			complex_float_type_node));
11295   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11296 			complex_double_type_node));
11297   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11298 			complex_long_double_type_node));
11299 
11300   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11301 			void_type_node));
11302   /* We are not going to have real types in C with less than byte alignment,
11303      so we might as well not have any types that claim to have it.  */
11304   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11305   TYPE_USER_ALIGN (void_type_node) = 0;
11306 
11307   string_type_node = build_pointer_type (char_type_node);
11308 
11309   ffecom_tree_fun_type_void
11310     = build_function_type (void_type_node, NULL_TREE);
11311 
11312   ffecom_tree_ptr_to_fun_type_void
11313     = build_pointer_type (ffecom_tree_fun_type_void);
11314 
11315   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11316 
11317   float_ftype_float
11318     = build_function_type (float_type_node,
11319 			   tree_cons (NULL_TREE, float_type_node, endlink));
11320 
11321   double_ftype_double
11322     = build_function_type (double_type_node,
11323 			   tree_cons (NULL_TREE, double_type_node, endlink));
11324 
11325   ldouble_ftype_ldouble
11326     = build_function_type (long_double_type_node,
11327 			   tree_cons (NULL_TREE, long_double_type_node,
11328 				      endlink));
11329 
11330   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11331     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11332       {
11333 	ffecom_tree_type[i][j] = NULL_TREE;
11334 	ffecom_tree_fun_type[i][j] = NULL_TREE;
11335 	ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11336 	ffecom_f2c_typecode_[i][j] = -1;
11337       }
11338 
11339   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11340      to size FLOAT_TYPE_SIZE because they have to be the same size as
11341      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11342      Compiler options and other such stuff that change the ways these
11343      types are set should not affect this particular setup.  */
11344 
11345   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11346     = t = make_signed_type (FLOAT_TYPE_SIZE);
11347   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11348 			t));
11349   type = ffetype_new ();
11350   base_type = type;
11351   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11352 		    type);
11353   ffetype_set_ams (type,
11354 		   TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11355 		   TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11356   ffetype_set_star (base_type,
11357 		    TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11358 		    type);
11359   ffetype_set_kind (base_type, 1, type);
11360   ffecom_typesize_integer1_ = ffetype_size (type);
11361   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11362 
11363   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11364     = t = make_unsigned_type (FLOAT_TYPE_SIZE);	/* HOLLERITH means unsigned. */
11365   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11366 			t));
11367 
11368   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11369     = t = make_signed_type (CHAR_TYPE_SIZE);
11370   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11371 			t));
11372   type = ffetype_new ();
11373   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11374 		    type);
11375   ffetype_set_ams (type,
11376 		   TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11377 		   TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11378   ffetype_set_star (base_type,
11379 		    TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11380 		    type);
11381   ffetype_set_kind (base_type, 3, type);
11382   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11383 
11384   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11385     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11386   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11387 			t));
11388 
11389   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11390     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11391   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11392 			t));
11393   type = ffetype_new ();
11394   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11395 		    type);
11396   ffetype_set_ams (type,
11397 		   TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11398 		   TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11399   ffetype_set_star (base_type,
11400 		    TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11401 		    type);
11402   ffetype_set_kind (base_type, 6, type);
11403   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11404 
11405   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11406     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11407   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11408 			t));
11409 
11410   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11411     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11412   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11413 			t));
11414   type = ffetype_new ();
11415   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11416 		    type);
11417   ffetype_set_ams (type,
11418 		   TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11419 		   TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11420   ffetype_set_star (base_type,
11421 		    TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11422 		    type);
11423   ffetype_set_kind (base_type, 2, type);
11424   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11425 
11426   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11427     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11428   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11429 			t));
11430 
11431 #if 0
11432   if (ffe_is_do_internal_checks ()
11433       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11434       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11435       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11436       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11437     {
11438       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11439 	       LONG_TYPE_SIZE);
11440     }
11441 #endif
11442 
11443   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11444     = t = make_signed_type (FLOAT_TYPE_SIZE);
11445   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11446 			t));
11447   type = ffetype_new ();
11448   base_type = type;
11449   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11450 		    type);
11451   ffetype_set_ams (type,
11452 		   TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11453 		   TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11454   ffetype_set_star (base_type,
11455 		    TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11456 		    type);
11457   ffetype_set_kind (base_type, 1, type);
11458   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11459 
11460   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11461     = t = make_signed_type (CHAR_TYPE_SIZE);
11462   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11463 			t));
11464   type = ffetype_new ();
11465   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11466 		    type);
11467   ffetype_set_ams (type,
11468 		   TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11469 		   TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11470   ffetype_set_star (base_type,
11471 		    TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11472 		    type);
11473   ffetype_set_kind (base_type, 3, type);
11474   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11475 
11476   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11477     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11478   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11479 			t));
11480   type = ffetype_new ();
11481   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11482 		    type);
11483   ffetype_set_ams (type,
11484 		   TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11485 		   TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11486   ffetype_set_star (base_type,
11487 		    TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11488 		    type);
11489   ffetype_set_kind (base_type, 6, type);
11490   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11491 
11492   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11493     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11494   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11495 			t));
11496   type = ffetype_new ();
11497   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11498 		    type);
11499   ffetype_set_ams (type,
11500 		   TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11501 		   TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11502   ffetype_set_star (base_type,
11503 		    TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11504 		    type);
11505   ffetype_set_kind (base_type, 2, type);
11506   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11507 
11508   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11509     = t = make_node (REAL_TYPE);
11510   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11511   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11512 			t));
11513   layout_type (t);
11514   type = ffetype_new ();
11515   base_type = type;
11516   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11517 		    type);
11518   ffetype_set_ams (type,
11519 		   TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11520 		   TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11521   ffetype_set_star (base_type,
11522 		    TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11523 		    type);
11524   ffetype_set_kind (base_type, 1, type);
11525   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11526     = FFETARGET_f2cTYREAL;
11527   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11528 
11529   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11530     = t = make_node (REAL_TYPE);
11531   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;	/* Always twice REAL. */
11532   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11533 			t));
11534   layout_type (t);
11535   type = ffetype_new ();
11536   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11537 		    type);
11538   ffetype_set_ams (type,
11539 		   TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11540 		   TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11541   ffetype_set_star (base_type,
11542 		    TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11543 		    type);
11544   ffetype_set_kind (base_type, 2, type);
11545   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11546     = FFETARGET_f2cTYDREAL;
11547   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11548 
11549   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11550     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11551   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11552 			t));
11553   type = ffetype_new ();
11554   base_type = type;
11555   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11556 		    type);
11557   ffetype_set_ams (type,
11558 		   TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11559 		   TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11560   ffetype_set_star (base_type,
11561 		    TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11562 		    type);
11563   ffetype_set_kind (base_type, 1, type);
11564   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11565     = FFETARGET_f2cTYCOMPLEX;
11566   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11567 
11568   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11569     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11570   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11571 			t));
11572   type = ffetype_new ();
11573   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11574 		    type);
11575   ffetype_set_ams (type,
11576 		   TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11577 		   TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11578   ffetype_set_star (base_type,
11579 		    TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11580 		    type);
11581   ffetype_set_kind (base_type, 2,
11582 		    type);
11583   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11584     = FFETARGET_f2cTYDCOMPLEX;
11585   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11586 
11587   /* Make function and ptr-to-function types for non-CHARACTER types. */
11588 
11589   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11590     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11591       {
11592 	if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11593 	  {
11594 	    if (i == FFEINFO_basictypeINTEGER)
11595 	      {
11596 		/* Figure out the smallest INTEGER type that can hold
11597 		   a pointer on this machine. */
11598 		if (GET_MODE_SIZE (TYPE_MODE (t))
11599 		    >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11600 		  {
11601 		    if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11602 			|| (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11603 			    > GET_MODE_SIZE (TYPE_MODE (t))))
11604 		      ffecom_pointer_kind_ = j;
11605 		  }
11606 	      }
11607 	    else if (i == FFEINFO_basictypeCOMPLEX)
11608 	      t = void_type_node;
11609 	    /* For f2c compatibility, REAL functions are really
11610 	       implemented as DOUBLE PRECISION.  */
11611 	    else if ((i == FFEINFO_basictypeREAL)
11612 		     && (j == FFEINFO_kindtypeREAL1))
11613 	      t = ffecom_tree_type
11614 		[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11615 
11616 	    t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11617 								  NULL_TREE);
11618 	    ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11619 	  }
11620       }
11621 
11622   /* Set up pointer types.  */
11623 
11624   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11625     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11626   else if (0 && ffe_is_do_internal_checks ())
11627     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11628   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11629 				  FFEINFO_kindtypeINTEGERDEFAULT),
11630 		    7,
11631 		    ffeinfo_type (FFEINFO_basictypeINTEGER,
11632 				  ffecom_pointer_kind_));
11633 
11634   if (ffe_is_ugly_assign ())
11635     ffecom_label_kind_ = ffecom_pointer_kind_;	/* Require ASSIGN etc to this. */
11636   else
11637     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11638   if (0 && ffe_is_do_internal_checks ())
11639     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11640 
11641   ffecom_integer_type_node
11642     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11643   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11644 				      integer_zero_node);
11645   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11646 				     integer_one_node);
11647 
11648   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11649      Turns out that by TYLONG, runtime/libI77/lio.h really means
11650      "whatever size an ftnint is".  For consistency and sanity,
11651      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11652      all are INTEGER, which we also make out of whatever back-end
11653      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11654      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11655      accommodate machines like the Alpha.  Note that this suggests
11656      f2c and libf2c are missing a distinction perhaps needed on
11657      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11658 
11659   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11660 			    FFETARGET_f2cTYLONG);
11661   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11662 			    FFETARGET_f2cTYSHORT);
11663   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11664 			    FFETARGET_f2cTYINT1);
11665   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11666 			    FFETARGET_f2cTYQUAD);
11667   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11668 			    FFETARGET_f2cTYLOGICAL);
11669   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11670 			    FFETARGET_f2cTYLOGICAL2);
11671   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11672 			    FFETARGET_f2cTYLOGICAL1);
11673   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11674   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11675 			    FFETARGET_f2cTYQUAD);
11676 
11677   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11678      loop.  CHARACTER items are built as arrays of unsigned char.  */
11679 
11680   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11681     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11682   type = ffetype_new ();
11683   base_type = type;
11684   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11685 		    FFEINFO_kindtypeCHARACTER1,
11686 		    type);
11687   ffetype_set_ams (type,
11688 		   TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11689 		   TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11690   ffetype_set_kind (base_type, 1, type);
11691   assert (ffetype_size (type)
11692 	  == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11693 
11694   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11695     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11696   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11697     [FFEINFO_kindtypeCHARACTER1]
11698     = ffecom_tree_ptr_to_fun_type_void;
11699   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11700     = FFETARGET_f2cTYCHAR;
11701 
11702   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11703     = 0;
11704 
11705   /* Make multi-return-value type and fields. */
11706 
11707   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11708 
11709   field = NULL_TREE;
11710 
11711   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11712     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11713       {
11714 	char name[30];
11715 
11716 	if (ffecom_tree_type[i][j] == NULL_TREE)
11717 	  continue;		/* Not supported. */
11718 	sprintf (&name[0], "bt_%s_kt_%s",
11719 		 ffeinfo_basictype_string ((ffeinfoBasictype) i),
11720 		 ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11721 	ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11722 						 get_identifier (name),
11723 						 ffecom_tree_type[i][j]);
11724 	DECL_CONTEXT (ffecom_multi_fields_[i][j])
11725 	  = ffecom_multi_type_node_;
11726 	DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11727 	DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11728 	TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11729 	field = ffecom_multi_fields_[i][j];
11730       }
11731 
11732   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11733   layout_type (ffecom_multi_type_node_);
11734 
11735   /* Subroutines usually return integer because they might have alternate
11736      returns. */
11737 
11738   ffecom_tree_subr_type
11739     = build_function_type (integer_type_node, NULL_TREE);
11740   ffecom_tree_ptr_to_subr_type
11741     = build_pointer_type (ffecom_tree_subr_type);
11742   ffecom_tree_blockdata_type
11743     = build_function_type (void_type_node, NULL_TREE);
11744 
11745   builtin_function ("__builtin_sqrtf", float_ftype_float,
11746 		    BUILT_IN_SQRTF, BUILT_IN_NORMAL, "sqrtf", NULL_TREE);
11747   builtin_function ("__builtin_sqrt", double_ftype_double,
11748 		    BUILT_IN_SQRT, BUILT_IN_NORMAL, "sqrt", NULL_TREE);
11749   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11750 		    BUILT_IN_SQRTL, BUILT_IN_NORMAL, "sqrtl", NULL_TREE);
11751   builtin_function ("__builtin_sinf", float_ftype_float,
11752 		    BUILT_IN_SINF, BUILT_IN_NORMAL, "sinf", NULL_TREE);
11753   builtin_function ("__builtin_sin", double_ftype_double,
11754 		    BUILT_IN_SIN, BUILT_IN_NORMAL, "sin", NULL_TREE);
11755   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11756 		    BUILT_IN_SINL, BUILT_IN_NORMAL, "sinl", NULL_TREE);
11757   builtin_function ("__builtin_cosf", float_ftype_float,
11758 		    BUILT_IN_COSF, BUILT_IN_NORMAL, "cosf", NULL_TREE);
11759   builtin_function ("__builtin_cos", double_ftype_double,
11760 		    BUILT_IN_COS, BUILT_IN_NORMAL, "cos", NULL_TREE);
11761   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11762 		    BUILT_IN_COSL, BUILT_IN_NORMAL, "cosl", NULL_TREE);
11763 
11764   pedantic_lvalues = FALSE;
11765 
11766   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11767 			 FFECOM_f2cINTEGER,
11768 			 "integer");
11769   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11770 			 FFECOM_f2cADDRESS,
11771 			 "address");
11772   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11773 			 FFECOM_f2cREAL,
11774 			 "real");
11775   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11776 			 FFECOM_f2cDOUBLEREAL,
11777 			 "doublereal");
11778   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11779 			 FFECOM_f2cCOMPLEX,
11780 			 "complex");
11781   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11782 			 FFECOM_f2cDOUBLECOMPLEX,
11783 			 "doublecomplex");
11784   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11785 			 FFECOM_f2cLONGINT,
11786 			 "longint");
11787   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11788 			 FFECOM_f2cLOGICAL,
11789 			 "logical");
11790   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11791 			 FFECOM_f2cFLAG,
11792 			 "flag");
11793   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11794 			 FFECOM_f2cFTNLEN,
11795 			 "ftnlen");
11796   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11797 			 FFECOM_f2cFTNINT,
11798 			 "ftnint");
11799 
11800   ffecom_f2c_ftnlen_zero_node
11801     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11802 
11803   ffecom_f2c_ftnlen_one_node
11804     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11805 
11806   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11807   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11808 
11809   ffecom_f2c_ptr_to_ftnlen_type_node
11810     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11811 
11812   ffecom_f2c_ptr_to_ftnint_type_node
11813     = build_pointer_type (ffecom_f2c_ftnint_type_node);
11814 
11815   ffecom_f2c_ptr_to_integer_type_node
11816     = build_pointer_type (ffecom_f2c_integer_type_node);
11817 
11818   ffecom_f2c_ptr_to_real_type_node
11819     = build_pointer_type (ffecom_f2c_real_type_node);
11820 
11821   ffecom_float_zero_ = build_real (float_type_node, dconst0);
11822   ffecom_double_zero_ = build_real (double_type_node, dconst0);
11823   {
11824     REAL_VALUE_TYPE point_5;
11825 
11826     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
11827     ffecom_float_half_ = build_real (float_type_node, point_5);
11828     ffecom_double_half_ = build_real (double_type_node, point_5);
11829   }
11830 
11831   /* Do "extern int xargc;".  */
11832 
11833   ffecom_tree_xargc_ = build_decl (VAR_DECL,
11834 				   get_identifier ("f__xargc"),
11835 				   integer_type_node);
11836   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
11837   TREE_STATIC (ffecom_tree_xargc_) = 1;
11838   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
11839   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
11840   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
11841 
11842 #if 0	/* This is being fixed, and seems to be working now. */
11843   if ((FLOAT_TYPE_SIZE != 32)
11844       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
11845     {
11846       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11847 	       (int) FLOAT_TYPE_SIZE);
11848       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11849 	  (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
11850       warning ("properly unless they all are 32 bits wide");
11851       warning ("Please keep this in mind before you report bugs.");
11852     }
11853 #endif
11854 
11855 #if 0	/* Code in ste.c that would crash has been commented out. */
11856   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
11857       < TYPE_PRECISION (string_type_node))
11858     /* I/O will probably crash.  */
11859     warning ("configuration: char * holds %d bits, but ftnlen only %d",
11860 	     TYPE_PRECISION (string_type_node),
11861 	     TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
11862 #endif
11863 
11864 #if 0	/* ASSIGN-related stuff has been changed to accommodate this. */
11865   if (TYPE_PRECISION (ffecom_integer_type_node)
11866       < TYPE_PRECISION (string_type_node))
11867     /* ASSIGN 10 TO I will crash.  */
11868     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11869  ASSIGN statement might fail",
11870 	     TYPE_PRECISION (string_type_node),
11871 	     TYPE_PRECISION (ffecom_integer_type_node));
11872 #endif
11873 }
11874 
11875 /* ffecom_init_2 -- Initialize
11876 
11877    ffecom_init_2();  */
11878 
11879 void
ffecom_init_2()11880 ffecom_init_2 ()
11881 {
11882   assert (ffecom_outer_function_decl_ == NULL_TREE);
11883   assert (current_function_decl == NULL_TREE);
11884   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
11885 
11886   ffecom_master_arglist_ = NULL;
11887   ++ffecom_num_fns_;
11888   ffecom_primary_entry_ = NULL;
11889   ffecom_is_altreturning_ = FALSE;
11890   ffecom_func_result_ = NULL_TREE;
11891   ffecom_multi_retval_ = NULL_TREE;
11892 }
11893 
11894 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11895 
11896    tree t;
11897    ffebld expr;	 // FFE opITEM list.
11898    tree = ffecom_list_expr(expr);
11899 
11900    List of actual args is transformed into corresponding gcc backend list.  */
11901 
11902 tree
ffecom_list_expr(ffebld expr)11903 ffecom_list_expr (ffebld expr)
11904 {
11905   tree list;
11906   tree *plist = &list;
11907   tree trail = NULL_TREE;	/* Append char length args here. */
11908   tree *ptrail = &trail;
11909   tree length;
11910 
11911   while (expr != NULL)
11912     {
11913       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
11914 
11915       if (texpr == error_mark_node)
11916 	return error_mark_node;
11917 
11918       *plist = build_tree_list (NULL_TREE, texpr);
11919       plist = &TREE_CHAIN (*plist);
11920       expr = ffebld_trail (expr);
11921       if (length != NULL_TREE)
11922 	{
11923 	  *ptrail = build_tree_list (NULL_TREE, length);
11924 	  ptrail = &TREE_CHAIN (*ptrail);
11925 	}
11926     }
11927 
11928   *plist = trail;
11929 
11930   return list;
11931 }
11932 
11933 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11934 
11935    tree t;
11936    ffebld expr;	 // FFE opITEM list.
11937    tree = ffecom_list_ptr_to_expr(expr);
11938 
11939    List of actual args is transformed into corresponding gcc backend list for
11940    use in calling an external procedure (vs. a statement function).  */
11941 
11942 tree
ffecom_list_ptr_to_expr(ffebld expr)11943 ffecom_list_ptr_to_expr (ffebld expr)
11944 {
11945   tree list;
11946   tree *plist = &list;
11947   tree trail = NULL_TREE;	/* Append char length args here. */
11948   tree *ptrail = &trail;
11949   tree length;
11950 
11951   while (expr != NULL)
11952     {
11953       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
11954 
11955       if (texpr == error_mark_node)
11956 	return error_mark_node;
11957 
11958       *plist = build_tree_list (NULL_TREE, texpr);
11959       plist = &TREE_CHAIN (*plist);
11960       expr = ffebld_trail (expr);
11961       if (length != NULL_TREE)
11962 	{
11963 	  *ptrail = build_tree_list (NULL_TREE, length);
11964 	  ptrail = &TREE_CHAIN (*ptrail);
11965 	}
11966     }
11967 
11968   *plist = trail;
11969 
11970   return list;
11971 }
11972 
11973 /* Obtain gcc's LABEL_DECL tree for label.  */
11974 
11975 tree
ffecom_lookup_label(ffelab label)11976 ffecom_lookup_label (ffelab label)
11977 {
11978   tree glabel;
11979 
11980   if (ffelab_hook (label) == NULL_TREE)
11981     {
11982       char labelname[16];
11983 
11984       switch (ffelab_type (label))
11985 	{
11986 	case FFELAB_typeLOOPEND:
11987 	case FFELAB_typeNOTLOOP:
11988 	case FFELAB_typeENDIF:
11989 	  sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
11990 	  glabel = build_decl (LABEL_DECL, get_identifier (labelname),
11991 			       void_type_node);
11992 	  DECL_CONTEXT (glabel) = current_function_decl;
11993 	  DECL_MODE (glabel) = VOIDmode;
11994 	  break;
11995 
11996 	case FFELAB_typeFORMAT:
11997 	  glabel = build_decl (VAR_DECL,
11998 			       ffecom_get_invented_identifier
11999 			       ("__g77_format_%d", (int) ffelab_value (label)),
12000 			       build_type_variant (build_array_type
12001 						   (char_type_node,
12002 						    NULL_TREE),
12003 						   1, 0));
12004 	  TREE_CONSTANT (glabel) = 1;
12005 	  TREE_STATIC (glabel) = 1;
12006 	  DECL_CONTEXT (glabel) = current_function_decl;
12007 	  DECL_INITIAL (glabel) = NULL;
12008 	  make_decl_rtl (glabel, NULL);
12009 	  expand_decl (glabel);
12010 
12011 	  ffecom_save_tree_forever (glabel);
12012 
12013 	  break;
12014 
12015 	case FFELAB_typeANY:
12016 	  glabel = error_mark_node;
12017 	  break;
12018 
12019 	default:
12020 	  assert ("bad label type" == NULL);
12021 	  glabel = NULL;
12022 	  break;
12023 	}
12024       ffelab_set_hook (label, glabel);
12025     }
12026   else
12027     {
12028       glabel = ffelab_hook (label);
12029     }
12030 
12031   return glabel;
12032 }
12033 
12034 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12035    a single source specification (as in the fourth argument of MVBITS).
12036    If the type is NULL_TREE, the type of lhs is used to make the type of
12037    the MODIFY_EXPR.  */
12038 
12039 tree
ffecom_modify(tree newtype,tree lhs,tree rhs)12040 ffecom_modify (tree newtype, tree lhs,
12041 	       tree rhs)
12042 {
12043   if (lhs == error_mark_node || rhs == error_mark_node)
12044     return error_mark_node;
12045 
12046   if (newtype == NULL_TREE)
12047     newtype = TREE_TYPE (lhs);
12048 
12049   if (TREE_SIDE_EFFECTS (lhs))
12050     lhs = stabilize_reference (lhs);
12051 
12052   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12053 }
12054 
12055 /* Register source file name.  */
12056 
12057 void
ffecom_file(const char * name)12058 ffecom_file (const char *name)
12059 {
12060   ffecom_file_ (name);
12061 }
12062 
12063 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12064 
12065    ffestorag st;
12066    ffecom_notify_init_storage(st);
12067 
12068    Gets called when all possible units in an aggregate storage area (a LOCAL
12069    with equivalences or a COMMON) have been initialized.  The initialization
12070    info either is in ffestorag_init or, if that is NULL,
12071    ffestorag_accretion:
12072 
12073    ffestorag_init may contain an opCONTER or opARRTER.	opCONTER may occur
12074    even for an array if the array is one element in length!
12075 
12076    ffestorag_accretion will contain an opACCTER.  It is much like an
12077    opARRTER except it has an ffebit object in it instead of just a size.
12078    The back end can use the info in the ffebit object, if it wants, to
12079    reduce the amount of actual initialization, but in any case it should
12080    kill the ffebit object when done.  Also, set accretion to NULL but
12081    init to a non-NULL value.
12082 
12083    After performing initialization, DO NOT set init to NULL, because that'll
12084    tell the front end it is ok for more initialization to happen.  Instead,
12085    set init to an opANY expression or some such thing that you can use to
12086    tell that you've already initialized the object.
12087 
12088    27-Oct-91  JCB  1.1
12089       Support two-pass FFE.  */
12090 
12091 void
ffecom_notify_init_storage(ffestorag st)12092 ffecom_notify_init_storage (ffestorag st)
12093 {
12094   ffebld init;			/* The initialization expression. */
12095 
12096   if (ffestorag_init (st) == NULL)
12097     {
12098       init = ffestorag_accretion (st);
12099       assert (init != NULL);
12100       ffestorag_set_accretion (st, NULL);
12101       ffestorag_set_accretes (st, 0);
12102       ffestorag_set_init (st, init);
12103     }
12104 }
12105 
12106 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12107 
12108    ffesymbol s;
12109    ffecom_notify_init_symbol(s);
12110 
12111    Gets called when all possible units in a symbol (not placed in COMMON
12112    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12113    have been initialized.  The initialization info either is in
12114    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12115 
12116    ffesymbol_init may contain an opCONTER or opARRTER.	opCONTER may occur
12117    even for an array if the array is one element in length!
12118 
12119    ffesymbol_accretion will contain an opACCTER.  It is much like an
12120    opARRTER except it has an ffebit object in it instead of just a size.
12121    The back end can use the info in the ffebit object, if it wants, to
12122    reduce the amount of actual initialization, but in any case it should
12123    kill the ffebit object when done.  Also, set accretion to NULL but
12124    init to a non-NULL value.
12125 
12126    After performing initialization, DO NOT set init to NULL, because that'll
12127    tell the front end it is ok for more initialization to happen.  Instead,
12128    set init to an opANY expression or some such thing that you can use to
12129    tell that you've already initialized the object.
12130 
12131    27-Oct-91  JCB  1.1
12132       Support two-pass FFE.  */
12133 
12134 void
ffecom_notify_init_symbol(ffesymbol s)12135 ffecom_notify_init_symbol (ffesymbol s)
12136 {
12137   ffebld init;			/* The initialization expression. */
12138 
12139   if (ffesymbol_storage (s) == NULL)
12140     return;			/* Do nothing until COMMON/EQUIVALENCE
12141 				   possibilities checked. */
12142 
12143   if ((ffesymbol_init (s) == NULL)
12144       && ((init = ffesymbol_accretion (s)) != NULL))
12145     {
12146       ffesymbol_set_accretion (s, NULL);
12147       ffesymbol_set_accretes (s, 0);
12148       ffesymbol_set_init (s, init);
12149     }
12150 }
12151 
12152 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12153 
12154    ffesymbol s;
12155    ffecom_notify_primary_entry(s);
12156 
12157    Gets called when implicit or explicit PROGRAM statement seen or when
12158    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12159    global symbol that serves as the entry point.  */
12160 
12161 void
ffecom_notify_primary_entry(ffesymbol s)12162 ffecom_notify_primary_entry (ffesymbol s)
12163 {
12164   ffecom_primary_entry_ = s;
12165   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12166 
12167   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12168       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12169     ffecom_primary_entry_is_proc_ = TRUE;
12170   else
12171     ffecom_primary_entry_is_proc_ = FALSE;
12172 
12173   if (!ffe_is_silent ())
12174     {
12175       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12176 	fprintf (stderr, "%s:\n", ffesymbol_text (s));
12177       else
12178 	fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12179     }
12180 
12181   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12182     {
12183       ffebld list;
12184       ffebld arg;
12185 
12186       for (list = ffesymbol_dummyargs (s);
12187 	   list != NULL;
12188 	   list = ffebld_trail (list))
12189 	{
12190 	  arg = ffebld_head (list);
12191 	  if (ffebld_op (arg) == FFEBLD_opSTAR)
12192 	    {
12193 	      ffecom_is_altreturning_ = TRUE;
12194 	      break;
12195 	    }
12196 	}
12197     }
12198 }
12199 
12200 FILE *
ffecom_open_include(char * name,ffewhereLine l,ffewhereColumn c)12201 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12202 {
12203   return ffecom_open_include_ (name, l, c);
12204 }
12205 
12206 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12207 
12208    tree t;
12209    ffebld expr;	 // FFE expression.
12210    tree = ffecom_ptr_to_expr(expr);
12211 
12212    Like ffecom_expr, but sticks address-of in front of most things.  */
12213 
12214 tree
ffecom_ptr_to_expr(ffebld expr)12215 ffecom_ptr_to_expr (ffebld expr)
12216 {
12217   tree item;
12218   ffeinfoBasictype bt;
12219   ffeinfoKindtype kt;
12220   ffesymbol s;
12221 
12222   assert (expr != NULL);
12223 
12224   switch (ffebld_op (expr))
12225     {
12226     case FFEBLD_opSYMTER:
12227       s = ffebld_symter (expr);
12228       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12229 	{
12230 	  ffecomGfrt ix;
12231 
12232 	  ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12233 	  assert (ix != FFECOM_gfrt);
12234 	  if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12235 	    {
12236 	      ffecom_make_gfrt_ (ix);
12237 	      item = ffecom_gfrt_[ix];
12238 	    }
12239 	}
12240       else
12241 	{
12242 	  item = ffesymbol_hook (s).decl_tree;
12243 	  if (item == NULL_TREE)
12244 	    {
12245 	      s = ffecom_sym_transform_ (s);
12246 	      item = ffesymbol_hook (s).decl_tree;
12247 	    }
12248 	}
12249       assert (item != NULL);
12250       if (item == error_mark_node)
12251 	return item;
12252       if (!ffesymbol_hook (s).addr)
12253 	item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12254 			 item);
12255       return item;
12256 
12257     case FFEBLD_opARRAYREF:
12258       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12259 
12260     case FFEBLD_opCONTER:
12261 
12262       bt = ffeinfo_basictype (ffebld_info (expr));
12263       kt = ffeinfo_kindtype (ffebld_info (expr));
12264 
12265       item = ffecom_constantunion (&ffebld_constant_union
12266 				   (ffebld_conter (expr)), bt, kt,
12267 				   ffecom_tree_type[bt][kt]);
12268       if (item == error_mark_node)
12269 	return error_mark_node;
12270       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12271 		       item);
12272       return item;
12273 
12274     case FFEBLD_opANY:
12275       return error_mark_node;
12276 
12277     default:
12278       bt = ffeinfo_basictype (ffebld_info (expr));
12279       kt = ffeinfo_kindtype (ffebld_info (expr));
12280 
12281       item = ffecom_expr (expr);
12282       if (item == error_mark_node)
12283 	return error_mark_node;
12284 
12285       /* The back end currently optimizes a bit too zealously for us, in that
12286 	 we fail JCB001 if the following block of code is omitted.  It checks
12287 	 to see if the transformed expression is a symbol or array reference,
12288 	 and encloses it in a SAVE_EXPR if that is the case.  */
12289 
12290       STRIP_NOPS (item);
12291       if ((TREE_CODE (item) == VAR_DECL)
12292 	  || (TREE_CODE (item) == PARM_DECL)
12293 	  || (TREE_CODE (item) == RESULT_DECL)
12294 	  || (TREE_CODE (item) == INDIRECT_REF)
12295 	  || (TREE_CODE (item) == ARRAY_REF)
12296 	  || (TREE_CODE (item) == COMPONENT_REF)
12297 #ifdef OFFSET_REF
12298 	  || (TREE_CODE (item) == OFFSET_REF)
12299 #endif
12300 	  || (TREE_CODE (item) == BUFFER_REF)
12301 	  || (TREE_CODE (item) == REALPART_EXPR)
12302 	  || (TREE_CODE (item) == IMAGPART_EXPR))
12303 	{
12304 	  item = ffecom_save_tree (item);
12305 	}
12306 
12307       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12308 		       item);
12309       return item;
12310     }
12311 
12312   assert ("fall-through error" == NULL);
12313   return error_mark_node;
12314 }
12315 
12316 /* Obtain a temp var with given data type.
12317 
12318    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12319    or >= 0 for a CHARACTER type.
12320 
12321    elements is -1 for a scalar or > 0 for an array of type.  */
12322 
12323 tree
ffecom_make_tempvar(const char * commentary,tree type,ffetargetCharacterSize size,int elements)12324 ffecom_make_tempvar (const char *commentary, tree type,
12325 		     ffetargetCharacterSize size, int elements)
12326 {
12327   tree t;
12328   static int mynumber;
12329 
12330   assert (current_binding_level->prep_state < 2);
12331 
12332   if (type == error_mark_node)
12333     return error_mark_node;
12334 
12335   if (size != FFETARGET_charactersizeNONE)
12336     type = build_array_type (type,
12337 			     build_range_type (ffecom_f2c_ftnlen_type_node,
12338 					       ffecom_f2c_ftnlen_one_node,
12339 					       build_int_2 (size, 0)));
12340   if (elements != -1)
12341     type = build_array_type (type,
12342 			     build_range_type (integer_type_node,
12343 					       integer_zero_node,
12344 					       build_int_2 (elements - 1,
12345 							    0)));
12346   t = build_decl (VAR_DECL,
12347 		  ffecom_get_invented_identifier ("__g77_%s_%d",
12348 						  commentary,
12349 						  mynumber++),
12350 		  type);
12351 
12352   t = start_decl (t, FALSE);
12353   finish_decl (t, NULL_TREE, FALSE);
12354 
12355   return t;
12356 }
12357 
12358 /* Prepare argument pointer to expression.
12359 
12360    Like ffecom_prepare_expr, except for expressions to be evaluated
12361    via ffecom_arg_ptr_to_expr.  */
12362 
12363 void
ffecom_prepare_arg_ptr_to_expr(ffebld expr)12364 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12365 {
12366   /* ~~For now, it seems to be the same thing.  */
12367   ffecom_prepare_expr (expr);
12368   return;
12369 }
12370 
12371 /* End of preparations.  */
12372 
12373 bool
ffecom_prepare_end(void)12374 ffecom_prepare_end (void)
12375 {
12376   int prep_state = current_binding_level->prep_state;
12377 
12378   assert (prep_state < 2);
12379   current_binding_level->prep_state = 2;
12380 
12381   return (prep_state == 1) ? TRUE : FALSE;
12382 }
12383 
12384 /* Prepare expression.
12385 
12386    This is called before any code is generated for the current block.
12387    It scans the expression, declares any temporaries that might be needed
12388    during evaluation of the expression, and stores those temporaries in
12389    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12390    specifies the destination that ffecom_expr_ will see, in case that
12391    helps avoid generating unused temporaries.
12392 
12393    ~~Improve to avoid allocating unused temporaries by taking `dest'
12394    into account vis-a-vis aliasing requirements of complex/character
12395    functions.  */
12396 
12397 void
ffecom_prepare_expr_(ffebld expr,ffebld dest UNUSED)12398 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12399 {
12400   ffeinfoBasictype bt;
12401   ffeinfoKindtype kt;
12402   ffetargetCharacterSize sz;
12403   tree tempvar = NULL_TREE;
12404 
12405   assert (current_binding_level->prep_state < 2);
12406 
12407   if (! expr)
12408     return;
12409 
12410   bt = ffeinfo_basictype (ffebld_info (expr));
12411   kt = ffeinfo_kindtype (ffebld_info (expr));
12412   sz = ffeinfo_size (ffebld_info (expr));
12413 
12414   /* Generate whatever temporaries are needed to represent the result
12415      of the expression.  */
12416 
12417   if (bt == FFEINFO_basictypeCHARACTER)
12418     {
12419       while (ffebld_op (expr) == FFEBLD_opPAREN)
12420 	expr = ffebld_left (expr);
12421     }
12422 
12423   switch (ffebld_op (expr))
12424     {
12425     default:
12426       /* Don't make temps for SYMTER, CONTER, etc.  */
12427       if (ffebld_arity (expr) == 0)
12428 	break;
12429 
12430       switch (bt)
12431 	{
12432 	case FFEINFO_basictypeCOMPLEX:
12433 	  if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12434 	    {
12435 	      ffesymbol s;
12436 
12437 	      if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12438 		break;
12439 
12440 	      s = ffebld_symter (ffebld_left (expr));
12441 	      if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12442 		  || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12443 		      && ! ffesymbol_is_f2c (s))
12444 		  || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12445 		      && ! ffe_is_f2c_library ()))
12446 		break;
12447 	    }
12448 	  else if (ffebld_op (expr) == FFEBLD_opPOWER)
12449 	    {
12450 	      /* Requires special treatment.  There's no POW_CC function
12451 		 in libg2c, so POW_ZZ is used, which means we always
12452 		 need a double-complex temp, not a single-complex.  */
12453 	      kt = FFEINFO_kindtypeREAL2;
12454 	    }
12455 	  else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12456 	    /* The other ops don't need temps for complex operands.  */
12457 	    break;
12458 
12459 	  /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12460 	     REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12461 	  tempvar = ffecom_make_tempvar ("complex",
12462 					 ffecom_tree_type
12463 					 [FFEINFO_basictypeCOMPLEX][kt],
12464 					 FFETARGET_charactersizeNONE,
12465 					 -1);
12466 	  break;
12467 
12468 	case FFEINFO_basictypeCHARACTER:
12469 	  if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12470 	    break;
12471 
12472 	  if (sz == FFETARGET_charactersizeNONE)
12473 	    /* ~~Kludge alert!  This should someday be fixed. */
12474 	    sz = 24;
12475 
12476 	  tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12477 	  break;
12478 
12479 	default:
12480 	  break;
12481 	}
12482       break;
12483 
12484     case FFEBLD_opCONCATENATE:
12485       {
12486 	/* This gets special handling, because only one set of temps
12487 	   is needed for a tree of these -- the tree is treated as
12488 	   a flattened list of concatenations when generating code.  */
12489 
12490 	ffecomConcatList_ catlist;
12491 	tree ltmp, itmp, result;
12492 	int count;
12493 	int i;
12494 
12495 	catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12496 	count = ffecom_concat_list_count_ (catlist);
12497 
12498 	if (count >= 2)
12499 	  {
12500 	    ltmp
12501 	      = ffecom_make_tempvar ("concat_len",
12502 				     ffecom_f2c_ftnlen_type_node,
12503 				     FFETARGET_charactersizeNONE, count);
12504 	    itmp
12505 	      = ffecom_make_tempvar ("concat_item",
12506 				     ffecom_f2c_address_type_node,
12507 				     FFETARGET_charactersizeNONE, count);
12508 	    result
12509 	      = ffecom_make_tempvar ("concat_res",
12510 				     char_type_node,
12511 				     ffecom_concat_list_maxlen_ (catlist),
12512 				     -1);
12513 
12514 	    tempvar = make_tree_vec (3);
12515 	    TREE_VEC_ELT (tempvar, 0) = ltmp;
12516 	    TREE_VEC_ELT (tempvar, 1) = itmp;
12517 	    TREE_VEC_ELT (tempvar, 2) = result;
12518 	  }
12519 
12520 	for (i = 0; i < count; ++i)
12521 	  ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12522 								    i));
12523 
12524 	ffecom_concat_list_kill_ (catlist);
12525 
12526 	if (tempvar)
12527 	  {
12528 	    ffebld_nonter_set_hook (expr, tempvar);
12529 	    current_binding_level->prep_state = 1;
12530 	  }
12531       }
12532       return;
12533 
12534     case FFEBLD_opCONVERT:
12535       if (bt == FFEINFO_basictypeCHARACTER
12536 	  && ((ffebld_size_known (ffebld_left (expr))
12537 	       == FFETARGET_charactersizeNONE)
12538 	      || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12539 	tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12540       break;
12541     }
12542 
12543   if (tempvar)
12544     {
12545       ffebld_nonter_set_hook (expr, tempvar);
12546       current_binding_level->prep_state = 1;
12547     }
12548 
12549   /* Prepare subexpressions for this expr.  */
12550 
12551   switch (ffebld_op (expr))
12552     {
12553     case FFEBLD_opPERCENT_LOC:
12554       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12555       break;
12556 
12557     case FFEBLD_opPERCENT_VAL:
12558     case FFEBLD_opPERCENT_REF:
12559       ffecom_prepare_expr (ffebld_left (expr));
12560       break;
12561 
12562     case FFEBLD_opPERCENT_DESCR:
12563       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12564       break;
12565 
12566     case FFEBLD_opITEM:
12567       {
12568 	ffebld item;
12569 
12570 	for (item = expr;
12571 	     item != NULL;
12572 	     item = ffebld_trail (item))
12573 	  if (ffebld_head (item) != NULL)
12574 	    ffecom_prepare_expr (ffebld_head (item));
12575       }
12576       break;
12577 
12578     default:
12579       /* Need to handle character conversion specially.  */
12580       switch (ffebld_arity (expr))
12581 	{
12582 	case 2:
12583 	  ffecom_prepare_expr (ffebld_left (expr));
12584 	  ffecom_prepare_expr (ffebld_right (expr));
12585 	  break;
12586 
12587 	case 1:
12588 	  ffecom_prepare_expr (ffebld_left (expr));
12589 	  break;
12590 
12591 	default:
12592 	  break;
12593 	}
12594     }
12595 
12596   return;
12597 }
12598 
12599 /* Prepare expression for reading and writing.
12600 
12601    Like ffecom_prepare_expr, except for expressions to be evaluated
12602    via ffecom_expr_rw.  */
12603 
12604 void
ffecom_prepare_expr_rw(tree type,ffebld expr)12605 ffecom_prepare_expr_rw (tree type, ffebld expr)
12606 {
12607   /* This is all we support for now.  */
12608   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12609 
12610   /* ~~For now, it seems to be the same thing.  */
12611   ffecom_prepare_expr (expr);
12612   return;
12613 }
12614 
12615 /* Prepare expression for writing.
12616 
12617    Like ffecom_prepare_expr, except for expressions to be evaluated
12618    via ffecom_expr_w.  */
12619 
12620 void
ffecom_prepare_expr_w(tree type,ffebld expr)12621 ffecom_prepare_expr_w (tree type, ffebld expr)
12622 {
12623   /* This is all we support for now.  */
12624   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12625 
12626   /* ~~For now, it seems to be the same thing.  */
12627   ffecom_prepare_expr (expr);
12628   return;
12629 }
12630 
12631 /* Prepare expression for returning.
12632 
12633    Like ffecom_prepare_expr, except for expressions to be evaluated
12634    via ffecom_return_expr.  */
12635 
12636 void
ffecom_prepare_return_expr(ffebld expr)12637 ffecom_prepare_return_expr (ffebld expr)
12638 {
12639   assert (current_binding_level->prep_state < 2);
12640 
12641   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12642       && ffecom_is_altreturning_
12643       && expr != NULL)
12644     ffecom_prepare_expr (expr);
12645 }
12646 
12647 /* Prepare pointer to expression.
12648 
12649    Like ffecom_prepare_expr, except for expressions to be evaluated
12650    via ffecom_ptr_to_expr.  */
12651 
12652 void
ffecom_prepare_ptr_to_expr(ffebld expr)12653 ffecom_prepare_ptr_to_expr (ffebld expr)
12654 {
12655   /* ~~For now, it seems to be the same thing.  */
12656   ffecom_prepare_expr (expr);
12657   return;
12658 }
12659 
12660 /* Transform expression into constant pointer-to-expression tree.
12661 
12662    If the expression can be transformed into a pointer-to-expression tree
12663    that is constant, that is done, and the tree returned.  Else NULL_TREE
12664    is returned.
12665 
12666    That way, a caller can attempt to provide compile-time initialization
12667    of a variable and, if that fails, *then* choose to start a new block
12668    and resort to using temporaries, as appropriate.  */
12669 
12670 tree
ffecom_ptr_to_const_expr(ffebld expr)12671 ffecom_ptr_to_const_expr (ffebld expr)
12672 {
12673   if (! expr)
12674     return integer_zero_node;
12675 
12676   if (ffebld_op (expr) == FFEBLD_opANY)
12677     return error_mark_node;
12678 
12679   if (ffebld_arity (expr) == 0
12680       && (ffebld_op (expr) != FFEBLD_opSYMTER
12681 	  || ffebld_where (expr) == FFEINFO_whereCOMMON
12682 	  || ffebld_where (expr) == FFEINFO_whereGLOBAL
12683 	  || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12684     {
12685       tree t;
12686 
12687       t = ffecom_ptr_to_expr (expr);
12688       assert (TREE_CONSTANT (t));
12689       return t;
12690     }
12691 
12692   return NULL_TREE;
12693 }
12694 
12695 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12696 
12697    tree rtn;  // NULL_TREE means use expand_null_return()
12698    ffebld expr;	 // NULL if no alt return expr to RETURN stmt
12699    rtn = ffecom_return_expr(expr);
12700 
12701    Based on the program unit type and other info (like return function
12702    type, return master function type when alternate ENTRY points,
12703    whether subroutine has any alternate RETURN points, etc), returns the
12704    appropriate expression to be returned to the caller, or NULL_TREE
12705    meaning no return value or the caller expects it to be returned somewhere
12706    else (which is handled by other parts of this module).  */
12707 
12708 tree
ffecom_return_expr(ffebld expr)12709 ffecom_return_expr (ffebld expr)
12710 {
12711   tree rtn;
12712 
12713   switch (ffecom_primary_entry_kind_)
12714     {
12715     case FFEINFO_kindPROGRAM:
12716     case FFEINFO_kindBLOCKDATA:
12717       rtn = NULL_TREE;
12718       break;
12719 
12720     case FFEINFO_kindSUBROUTINE:
12721       if (!ffecom_is_altreturning_)
12722 	rtn = NULL_TREE;	/* No alt returns, never an expr. */
12723       else if (expr == NULL)
12724 	rtn = integer_zero_node;
12725       else
12726 	rtn = ffecom_expr (expr);
12727       break;
12728 
12729     case FFEINFO_kindFUNCTION:
12730       if ((ffecom_multi_retval_ != NULL_TREE)
12731 	  || (ffesymbol_basictype (ffecom_primary_entry_)
12732 	      == FFEINFO_basictypeCHARACTER)
12733 	  || ((ffesymbol_basictype (ffecom_primary_entry_)
12734 	       == FFEINFO_basictypeCOMPLEX)
12735 	      && (ffecom_num_entrypoints_ == 0)
12736 	      && ffesymbol_is_f2c (ffecom_primary_entry_)))
12737 	{			/* Value is returned by direct assignment
12738 				   into (implicit) dummy. */
12739 	  rtn = NULL_TREE;
12740 	  break;
12741 	}
12742       rtn = ffecom_func_result_;
12743 #if 0
12744       /* Spurious error if RETURN happens before first reference!  So elide
12745 	 this code.  In particular, for debugging registry, rtn should always
12746 	 be non-null after all, but TREE_USED won't be set until we encounter
12747 	 a reference in the code.  Perfectly okay (but weird) code that,
12748 	 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12749 	 this diagnostic for no reason.  Have people use -O -Wuninitialized
12750 	 and leave it to the back end to find obviously weird cases.  */
12751 
12752       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12753 	 situation; if the return value has never been referenced, it won't
12754 	 have a tree under 2pass mode. */
12755       if ((rtn == NULL_TREE)
12756 	  || !TREE_USED (rtn))
12757 	{
12758 	  ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
12759 	  ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
12760 		       ffesymbol_where_column (ffecom_primary_entry_));
12761 	  ffebad_string (ffesymbol_text (ffesymbol_funcresult
12762 					 (ffecom_primary_entry_)));
12763 	  ffebad_finish ();
12764 	}
12765 #endif
12766       break;
12767 
12768     default:
12769       assert ("bad unit kind" == NULL);
12770     case FFEINFO_kindANY:
12771       rtn = error_mark_node;
12772       break;
12773     }
12774 
12775   return rtn;
12776 }
12777 
12778 /* Do save_expr only if tree is not error_mark_node.  */
12779 
12780 tree
ffecom_save_tree(tree t)12781 ffecom_save_tree (tree t)
12782 {
12783   return save_expr (t);
12784 }
12785 
12786 /* Start a compound statement (block).  */
12787 
12788 void
ffecom_start_compstmt(void)12789 ffecom_start_compstmt (void)
12790 {
12791   bison_rule_pushlevel_ ();
12792 }
12793 
12794 /* Public entry point for front end to access start_decl.  */
12795 
12796 tree
ffecom_start_decl(tree decl,bool is_initialized)12797 ffecom_start_decl (tree decl, bool is_initialized)
12798 {
12799   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
12800   return start_decl (decl, FALSE);
12801 }
12802 
12803 /* ffecom_sym_commit -- Symbol's state being committed to reality
12804 
12805    ffesymbol s;
12806    ffecom_sym_commit(s);
12807 
12808    Does whatever the backend needs when a symbol is committed after having
12809    been backtrackable for a period of time.  */
12810 
12811 void
ffecom_sym_commit(ffesymbol s UNUSED)12812 ffecom_sym_commit (ffesymbol s UNUSED)
12813 {
12814   assert (!ffesymbol_retractable ());
12815 }
12816 
12817 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12818 
12819    ffecom_sym_end_transition();
12820 
12821    Does backend-specific stuff and also calls ffest_sym_end_transition
12822    to do the necessary FFE stuff.
12823 
12824    Backtracking is never enabled when this fn is called, so don't worry
12825    about it.  */
12826 
12827 ffesymbol
ffecom_sym_end_transition(ffesymbol s)12828 ffecom_sym_end_transition (ffesymbol s)
12829 {
12830   ffestorag st;
12831 
12832   assert (!ffesymbol_retractable ());
12833 
12834   s = ffest_sym_end_transition (s);
12835 
12836   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
12837       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
12838     {
12839       ffecom_list_blockdata_
12840 	= ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12841 					      FFEINTRIN_specNONE,
12842 					      FFEINTRIN_impNONE),
12843 			   ffecom_list_blockdata_);
12844     }
12845 
12846   /* This is where we finally notice that a symbol has partial initialization
12847      and finalize it. */
12848 
12849   if (ffesymbol_accretion (s) != NULL)
12850     {
12851       assert (ffesymbol_init (s) == NULL);
12852       ffecom_notify_init_symbol (s);
12853     }
12854   else if (((st = ffesymbol_storage (s)) != NULL)
12855 	   && ((st = ffestorag_parent (st)) != NULL)
12856 	   && (ffestorag_accretion (st) != NULL))
12857     {
12858       assert (ffestorag_init (st) == NULL);
12859       ffecom_notify_init_storage (st);
12860     }
12861 
12862   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
12863       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
12864       && (ffesymbol_storage (s) != NULL))
12865     {
12866       ffecom_list_common_
12867 	= ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
12868 					      FFEINTRIN_specNONE,
12869 					      FFEINTRIN_impNONE),
12870 			   ffecom_list_common_);
12871     }
12872 
12873   return s;
12874 }
12875 
12876 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12877 
12878    ffecom_sym_exec_transition();
12879 
12880    Does backend-specific stuff and also calls ffest_sym_exec_transition
12881    to do the necessary FFE stuff.
12882 
12883    See the long-winded description in ffecom_sym_learned for info
12884    on handling the situation where backtracking is inhibited.  */
12885 
12886 ffesymbol
ffecom_sym_exec_transition(ffesymbol s)12887 ffecom_sym_exec_transition (ffesymbol s)
12888 {
12889   s = ffest_sym_exec_transition (s);
12890 
12891   return s;
12892 }
12893 
12894 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12895 
12896    ffesymbol s;
12897    s = ffecom_sym_learned(s);
12898 
12899    Called when a new symbol is seen after the exec transition or when more
12900    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
12901    it arrives here is that all its latest info is updated already, so its
12902    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12903    field filled in if its gone through here or exec_transition first, and
12904    so on.
12905 
12906    The backend probably wants to check ffesymbol_retractable() to see if
12907    backtracking is in effect.  If so, the FFE's changes to the symbol may
12908    be retracted (undone) or committed (ratified), at which time the
12909    appropriate ffecom_sym_retract or _commit function will be called
12910    for that function.
12911 
12912    If the backend has its own backtracking mechanism, great, use it so that
12913    committal is a simple operation.  Though it doesn't make much difference,
12914    I suppose: the reason for tentative symbol evolution in the FFE is to
12915    enable error detection in weird incorrect statements early and to disable
12916    incorrect error detection on a correct statement.  The backend is not
12917    likely to introduce any information that'll get involved in these
12918    considerations, so it is probably just fine that the implementation
12919    model for this fn and for _exec_transition is to not do anything
12920    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12921    and instead wait until ffecom_sym_commit is called (which it never
12922    will be as long as we're using ambiguity-detecting statement analysis in
12923    the FFE, which we are initially to shake out the code, but don't depend
12924    on this), otherwise go ahead and do whatever is needed.
12925 
12926    In essence, then, when this fn and _exec_transition get called while
12927    backtracking is enabled, a general mechanism would be to flag which (or
12928    both) of these were called (and in what order? neat question as to what
12929    might happen that I'm too lame to think through right now) and then when
12930    _commit is called reproduce the original calling sequence, if any, for
12931    the two fns (at which point backtracking will, of course, be disabled).  */
12932 
12933 ffesymbol
ffecom_sym_learned(ffesymbol s)12934 ffecom_sym_learned (ffesymbol s)
12935 {
12936   ffestorag_exec_layout (s);
12937 
12938   return s;
12939 }
12940 
12941 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12942 
12943    ffesymbol s;
12944    ffecom_sym_retract(s);
12945 
12946    Does whatever the backend needs when a symbol is retracted after having
12947    been backtrackable for a period of time.  */
12948 
12949 void
ffecom_sym_retract(ffesymbol s UNUSED)12950 ffecom_sym_retract (ffesymbol s UNUSED)
12951 {
12952   assert (!ffesymbol_retractable ());
12953 
12954 #if 0				/* GCC doesn't commit any backtrackable sins,
12955 				   so nothing needed here. */
12956   switch (ffesymbol_hook (s).state)
12957     {
12958     case 0:			/* nothing happened yet. */
12959       break;
12960 
12961     case 1:			/* exec transition happened. */
12962       break;
12963 
12964     case 2:			/* learned happened. */
12965       break;
12966 
12967     case 3:			/* learned then exec. */
12968       break;
12969 
12970     case 4:			/* exec then learned. */
12971       break;
12972 
12973     default:
12974       assert ("bad hook state" == NULL);
12975       break;
12976     }
12977 #endif
12978 }
12979 
12980 /* Create temporary gcc label.  */
12981 
12982 tree
ffecom_temp_label()12983 ffecom_temp_label ()
12984 {
12985   tree glabel;
12986   static int mynumber = 0;
12987 
12988   glabel = build_decl (LABEL_DECL,
12989 		       ffecom_get_invented_identifier ("__g77_label_%d",
12990 						       mynumber++),
12991 		       void_type_node);
12992   DECL_CONTEXT (glabel) = current_function_decl;
12993   DECL_MODE (glabel) = VOIDmode;
12994 
12995   return glabel;
12996 }
12997 
12998 /* Return an expression that is usable as an arg in a conditional context
12999    (IF, DO WHILE, .NOT., and so on).
13000 
13001    Use the one provided for the back end as of >2.6.0.  */
13002 
13003 tree
ffecom_truth_value(tree expr)13004 ffecom_truth_value (tree expr)
13005 {
13006   return ffe_truthvalue_conversion (expr);
13007 }
13008 
13009 /* Return the inversion of a truth value (the inversion of what
13010    ffecom_truth_value builds).
13011 
13012    Apparently invert_truthvalue, which is properly in the back end, is
13013    enough for now, so just use it.  */
13014 
13015 tree
ffecom_truth_value_invert(tree expr)13016 ffecom_truth_value_invert (tree expr)
13017 {
13018   return invert_truthvalue (ffecom_truth_value (expr));
13019 }
13020 
13021 /* Return the tree that is the type of the expression, as would be
13022    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13023    transforming the expression, generating temporaries, etc.  */
13024 
13025 tree
ffecom_type_expr(ffebld expr)13026 ffecom_type_expr (ffebld expr)
13027 {
13028   ffeinfoBasictype bt;
13029   ffeinfoKindtype kt;
13030   tree tree_type;
13031 
13032   assert (expr != NULL);
13033 
13034   bt = ffeinfo_basictype (ffebld_info (expr));
13035   kt = ffeinfo_kindtype (ffebld_info (expr));
13036   tree_type = ffecom_tree_type[bt][kt];
13037 
13038   switch (ffebld_op (expr))
13039     {
13040     case FFEBLD_opCONTER:
13041     case FFEBLD_opSYMTER:
13042     case FFEBLD_opARRAYREF:
13043     case FFEBLD_opUPLUS:
13044     case FFEBLD_opPAREN:
13045     case FFEBLD_opUMINUS:
13046     case FFEBLD_opADD:
13047     case FFEBLD_opSUBTRACT:
13048     case FFEBLD_opMULTIPLY:
13049     case FFEBLD_opDIVIDE:
13050     case FFEBLD_opPOWER:
13051     case FFEBLD_opNOT:
13052     case FFEBLD_opFUNCREF:
13053     case FFEBLD_opSUBRREF:
13054     case FFEBLD_opAND:
13055     case FFEBLD_opOR:
13056     case FFEBLD_opXOR:
13057     case FFEBLD_opNEQV:
13058     case FFEBLD_opEQV:
13059     case FFEBLD_opCONVERT:
13060     case FFEBLD_opLT:
13061     case FFEBLD_opLE:
13062     case FFEBLD_opEQ:
13063     case FFEBLD_opNE:
13064     case FFEBLD_opGT:
13065     case FFEBLD_opGE:
13066     case FFEBLD_opPERCENT_LOC:
13067       return tree_type;
13068 
13069     case FFEBLD_opACCTER:
13070     case FFEBLD_opARRTER:
13071     case FFEBLD_opITEM:
13072     case FFEBLD_opSTAR:
13073     case FFEBLD_opBOUNDS:
13074     case FFEBLD_opREPEAT:
13075     case FFEBLD_opLABTER:
13076     case FFEBLD_opLABTOK:
13077     case FFEBLD_opIMPDO:
13078     case FFEBLD_opCONCATENATE:
13079     case FFEBLD_opSUBSTR:
13080     default:
13081       assert ("bad op for ffecom_type_expr" == NULL);
13082       /* Fall through. */
13083     case FFEBLD_opANY:
13084       return error_mark_node;
13085     }
13086 }
13087 
13088 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13089 
13090    If the PARM_DECL already exists, return it, else create it.	It's an
13091    integer_type_node argument for the master function that implements a
13092    subroutine or function with more than one entrypoint and is bound at
13093    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13094    first ENTRY statement, and so on).  */
13095 
13096 tree
ffecom_which_entrypoint_decl()13097 ffecom_which_entrypoint_decl ()
13098 {
13099   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13100 
13101   return ffecom_which_entrypoint_decl_;
13102 }
13103 
13104 /* The following sections consists of private and public functions
13105    that have the same names and perform roughly the same functions
13106    as counterparts in the C front end.  Changes in the C front end
13107    might affect how things should be done here.  Only functions
13108    needed by the back end should be public here; the rest should
13109    be private (static in the C sense).  Functions needed by other
13110    g77 front-end modules should be accessed by them via public
13111    ffecom_* names, which should themselves call private versions
13112    in this section so the private versions are easy to recognize
13113    when upgrading to a new gcc and finding interesting changes
13114    in the front end.
13115 
13116    Functions named after rule "foo:" in c-parse.y are named
13117    "bison_rule_foo_" so they are easy to find.  */
13118 
13119 static void
bison_rule_pushlevel_()13120 bison_rule_pushlevel_ ()
13121 {
13122   emit_line_note (input_filename, lineno);
13123   pushlevel (0);
13124   clear_last_expr ();
13125   expand_start_bindings (0);
13126 }
13127 
13128 static tree
bison_rule_compstmt_()13129 bison_rule_compstmt_ ()
13130 {
13131   tree t;
13132   int keep = kept_level_p ();
13133 
13134   /* Make the temps go away.  */
13135   if (! keep)
13136     current_binding_level->names = NULL_TREE;
13137 
13138   emit_line_note (input_filename, lineno);
13139   expand_end_bindings (getdecls (), keep, 0);
13140   t = poplevel (keep, 1, 0);
13141 
13142   return t;
13143 }
13144 
13145 /* Return a definition for a builtin function named NAME and whose data type
13146    is TYPE.  TYPE should be a function type with argument types.
13147    FUNCTION_CODE tells later passes how to compile calls to this function.
13148    See tree.h for its possible values.
13149 
13150    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13151    the name to be called if we can't opencode the function.  If
13152    ATTRS is nonzero, use that for the function's attribute list.  */
13153 
13154 tree
builtin_function(const char * name,tree type,int function_code,enum built_in_class class,const char * library_name,tree attrs ATTRIBUTE_UNUSED)13155 builtin_function (const char *name, tree type, int function_code,
13156 		  enum built_in_class class,
13157 		  const char *library_name,
13158 		  tree attrs ATTRIBUTE_UNUSED)
13159 {
13160   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13161   DECL_EXTERNAL (decl) = 1;
13162   TREE_PUBLIC (decl) = 1;
13163   if (library_name)
13164     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13165   make_decl_rtl (decl, NULL);
13166   pushdecl (decl);
13167   DECL_BUILT_IN_CLASS (decl) = class;
13168   DECL_FUNCTION_CODE (decl) = function_code;
13169 
13170   return decl;
13171 }
13172 
13173 /* Handle when a new declaration NEWDECL
13174    has the same name as an old one OLDDECL
13175    in the same binding contour.
13176    Prints an error message if appropriate.
13177 
13178    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13179    Otherwise, return 0.  */
13180 
13181 static int
duplicate_decls(tree newdecl,tree olddecl)13182 duplicate_decls (tree newdecl, tree olddecl)
13183 {
13184   int types_match = 1;
13185   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13186 			   && DECL_INITIAL (newdecl) != 0);
13187   tree oldtype = TREE_TYPE (olddecl);
13188   tree newtype = TREE_TYPE (newdecl);
13189 
13190   if (olddecl == newdecl)
13191     return 1;
13192 
13193   if (TREE_CODE (newtype) == ERROR_MARK
13194       || TREE_CODE (oldtype) == ERROR_MARK)
13195     types_match = 0;
13196 
13197   /* New decl is completely inconsistent with the old one =>
13198      tell caller to replace the old one.
13199      This is always an error except in the case of shadowing a builtin.  */
13200   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13201     return 0;
13202 
13203   /* For real parm decl following a forward decl,
13204      return 1 so old decl will be reused.  */
13205   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13206       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13207     return 1;
13208 
13209   /* The new declaration is the same kind of object as the old one.
13210      The declarations may partially match.  Print warnings if they don't
13211      match enough.  Ultimately, copy most of the information from the new
13212      decl to the old one, and keep using the old one.  */
13213 
13214   if (TREE_CODE (olddecl) == FUNCTION_DECL
13215       && DECL_BUILT_IN (olddecl))
13216     {
13217       /* A function declaration for a built-in function.  */
13218       if (!TREE_PUBLIC (newdecl))
13219 	return 0;
13220       else if (!types_match)
13221 	{
13222 	  /* Accept the return type of the new declaration if same modes.  */
13223 	  tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13224 	  tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13225 
13226 	  if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13227 	    {
13228 	      /* Function types may be shared, so we can't just modify
13229 		 the return type of olddecl's function type.  */
13230 	      tree newtype
13231 		= build_function_type (newreturntype,
13232 				       TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13233 
13234 	      types_match = 1;
13235 	      if (types_match)
13236 		TREE_TYPE (olddecl) = newtype;
13237 	    }
13238 	}
13239       if (!types_match)
13240 	return 0;
13241     }
13242   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13243 	   && DECL_SOURCE_LINE (olddecl) == 0)
13244     {
13245       /* A function declaration for a predeclared function
13246 	 that isn't actually built in.  */
13247       if (!TREE_PUBLIC (newdecl))
13248 	return 0;
13249       else if (!types_match)
13250 	{
13251 	  /* If the types don't match, preserve volatility indication.
13252 	     Later on, we will discard everything else about the
13253 	     default declaration.  */
13254 	  TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13255 	}
13256     }
13257 
13258   /* Copy all the DECL_... slots specified in the new decl
13259      except for any that we copy here from the old type.
13260 
13261      Past this point, we don't change OLDTYPE and NEWTYPE
13262      even if we change the types of NEWDECL and OLDDECL.  */
13263 
13264   if (types_match)
13265     {
13266       /* Merge the data types specified in the two decls.  */
13267       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13268 	TREE_TYPE (newdecl)
13269 	  = TREE_TYPE (olddecl)
13270 	    = TREE_TYPE (newdecl);
13271 
13272       /* Lay the type out, unless already done.  */
13273       if (oldtype != TREE_TYPE (newdecl))
13274 	{
13275 	  if (TREE_TYPE (newdecl) != error_mark_node)
13276 	    layout_type (TREE_TYPE (newdecl));
13277 	  if (TREE_CODE (newdecl) != FUNCTION_DECL
13278 	      && TREE_CODE (newdecl) != TYPE_DECL
13279 	      && TREE_CODE (newdecl) != CONST_DECL)
13280 	    layout_decl (newdecl, 0);
13281 	}
13282       else
13283 	{
13284 	  /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13285 	  DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13286 	  DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13287 	  if (TREE_CODE (olddecl) != FUNCTION_DECL)
13288 	    if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13289 	      {
13290 		DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13291 		DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13292 	      }
13293 	}
13294 
13295       /* Keep the old rtl since we can safely use it.  */
13296       COPY_DECL_RTL (olddecl, newdecl);
13297 
13298       /* Merge the type qualifiers.  */
13299       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13300 	  && !TREE_THIS_VOLATILE (newdecl))
13301 	TREE_THIS_VOLATILE (olddecl) = 0;
13302       if (TREE_READONLY (newdecl))
13303 	TREE_READONLY (olddecl) = 1;
13304       if (TREE_THIS_VOLATILE (newdecl))
13305 	{
13306 	  TREE_THIS_VOLATILE (olddecl) = 1;
13307 	  if (TREE_CODE (newdecl) == VAR_DECL)
13308 	    make_var_volatile (newdecl);
13309 	}
13310 
13311       /* Keep source location of definition rather than declaration.
13312 	 Likewise, keep decl at outer scope.  */
13313       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13314 	  || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13315 	{
13316 	  DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13317 	  DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13318 
13319 	  if (DECL_CONTEXT (olddecl) == 0
13320 	      && TREE_CODE (newdecl) != FUNCTION_DECL)
13321 	    DECL_CONTEXT (newdecl) = 0;
13322 	}
13323 
13324       /* Merge the unused-warning information.  */
13325       if (DECL_IN_SYSTEM_HEADER (olddecl))
13326 	DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13327       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13328 	DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13329 
13330       /* Merge the initialization information.  */
13331       if (DECL_INITIAL (newdecl) == 0)
13332 	DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13333 
13334       /* Merge the section attribute.
13335 	 We want to issue an error if the sections conflict but that must be
13336 	 done later in decl_attributes since we are called before attributes
13337 	 are assigned.  */
13338       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13339 	DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13340 
13341       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13342 	{
13343 	  DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13344 	  DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13345 	}
13346     }
13347   /* If cannot merge, then use the new type and qualifiers,
13348      and don't preserve the old rtl.  */
13349   else
13350     {
13351       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13352       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13353       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13354       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13355     }
13356 
13357   /* Merge the storage class information.  */
13358   /* For functions, static overrides non-static.  */
13359   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13360     {
13361       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13362       /* This is since we don't automatically
13363 	 copy the attributes of NEWDECL into OLDDECL.  */
13364       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13365       /* If this clears `static', clear it in the identifier too.  */
13366       if (! TREE_PUBLIC (olddecl))
13367 	TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13368     }
13369   if (DECL_EXTERNAL (newdecl))
13370     {
13371       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13372       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13373       /* An extern decl does not override previous storage class.  */
13374       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13375     }
13376   else
13377     {
13378       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13379       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13380     }
13381 
13382   /* If either decl says `inline', this fn is inline,
13383      unless its definition was passed already.  */
13384   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13385     DECL_INLINE (olddecl) = 1;
13386   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13387 
13388   /* Get rid of any built-in function if new arg types don't match it
13389      or if we have a function definition.  */
13390   if (TREE_CODE (newdecl) == FUNCTION_DECL
13391       && DECL_BUILT_IN (olddecl)
13392       && (!types_match || new_is_definition))
13393     {
13394       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13395       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13396     }
13397 
13398   /* If redeclaring a builtin function, and not a definition,
13399      it stays built in.
13400      Also preserve various other info from the definition.  */
13401   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13402     {
13403       if (DECL_BUILT_IN (olddecl))
13404 	{
13405 	  DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13406 	  DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13407 	}
13408 
13409       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13410       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13411       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13412       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13413     }
13414 
13415   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13416      But preserve olddecl's DECL_UID.  */
13417   {
13418     register unsigned olddecl_uid = DECL_UID (olddecl);
13419 
13420     memcpy ((char *) olddecl + sizeof (struct tree_common),
13421 	    (char *) newdecl + sizeof (struct tree_common),
13422 	    sizeof (struct tree_decl) - sizeof (struct tree_common));
13423     DECL_UID (olddecl) = olddecl_uid;
13424   }
13425 
13426   return 1;
13427 }
13428 
13429 /* Finish processing of a declaration;
13430    install its initial value.
13431    If the length of an array type is not known before,
13432    it must be determined now, from the initial value, or it is an error.  */
13433 
13434 static void
finish_decl(tree decl,tree init,bool is_top_level)13435 finish_decl (tree decl, tree init, bool is_top_level)
13436 {
13437   register tree type = TREE_TYPE (decl);
13438   int was_incomplete = (DECL_SIZE (decl) == 0);
13439   bool at_top_level = (current_binding_level == global_binding_level);
13440   bool top_level = is_top_level || at_top_level;
13441 
13442   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13443      level anyway.  */
13444   assert (!is_top_level || !at_top_level);
13445 
13446   if (TREE_CODE (decl) == PARM_DECL)
13447     assert (init == NULL_TREE);
13448   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13449      overlaps DECL_ARG_TYPE.  */
13450   else if (init == NULL_TREE)
13451     assert (DECL_INITIAL (decl) == NULL_TREE);
13452   else
13453     assert (DECL_INITIAL (decl) == error_mark_node);
13454 
13455   if (init != NULL_TREE)
13456     {
13457       if (TREE_CODE (decl) != TYPE_DECL)
13458 	DECL_INITIAL (decl) = init;
13459       else
13460 	{
13461 	  /* typedef foo = bar; store the type of bar as the type of foo.  */
13462 	  TREE_TYPE (decl) = TREE_TYPE (init);
13463 	  DECL_INITIAL (decl) = init = 0;
13464 	}
13465     }
13466 
13467   /* Deduce size of array from initialization, if not already known */
13468 
13469   if (TREE_CODE (type) == ARRAY_TYPE
13470       && TYPE_DOMAIN (type) == 0
13471       && TREE_CODE (decl) != TYPE_DECL)
13472     {
13473       assert (top_level);
13474       assert (was_incomplete);
13475 
13476       layout_decl (decl, 0);
13477     }
13478 
13479   if (TREE_CODE (decl) == VAR_DECL)
13480     {
13481       if (DECL_SIZE (decl) == NULL_TREE
13482 	  && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13483 	layout_decl (decl, 0);
13484 
13485       if (DECL_SIZE (decl) == NULL_TREE
13486 	  && (TREE_STATIC (decl)
13487 	      ?
13488       /* A static variable with an incomplete type is an error if it is
13489 	 initialized. Also if it is not file scope. Otherwise, let it
13490 	 through, but if it is not `extern' then it may cause an error
13491 	 message later.  */
13492 	      (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13493 	      :
13494       /* An automatic variable with an incomplete type is an error.  */
13495 	      !DECL_EXTERNAL (decl)))
13496 	{
13497 	  assert ("storage size not known" == NULL);
13498 	  abort ();
13499 	}
13500 
13501       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13502 	  && (DECL_SIZE (decl) != 0)
13503 	  && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13504 	{
13505 	  assert ("storage size not constant" == NULL);
13506 	  abort ();
13507 	}
13508     }
13509 
13510   /* Output the assembler code and/or RTL code for variables and functions,
13511      unless the type is an undefined structure or union. If not, it will get
13512      done when the type is completed.  */
13513 
13514   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13515     {
13516       rest_of_decl_compilation (decl, NULL,
13517 				DECL_CONTEXT (decl) == 0,
13518 				0);
13519 
13520       if (DECL_CONTEXT (decl) != 0)
13521 	{
13522 	  /* Recompute the RTL of a local array now if it used to be an
13523 	     incomplete type.  */
13524 	  if (was_incomplete
13525 	      && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13526 	    {
13527 	      /* If we used it already as memory, it must stay in memory.  */
13528 	      TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13529 	      /* If it's still incomplete now, no init will save it.  */
13530 	      if (DECL_SIZE (decl) == 0)
13531 		DECL_INITIAL (decl) = 0;
13532 	      expand_decl (decl);
13533 	    }
13534 	  /* Compute and store the initial value.  */
13535 	  if (TREE_CODE (decl) != FUNCTION_DECL)
13536 	    expand_decl_init (decl);
13537 	}
13538     }
13539   else if (TREE_CODE (decl) == TYPE_DECL)
13540     {
13541       rest_of_decl_compilation (decl, NULL,
13542 				DECL_CONTEXT (decl) == 0,
13543 				0);
13544     }
13545 
13546   /* At the end of a declaration, throw away any variable type sizes of types
13547      defined inside that declaration.  There is no use computing them in the
13548      following function definition.  */
13549   if (current_binding_level == global_binding_level)
13550     get_pending_sizes ();
13551 }
13552 
13553 /* Finish up a function declaration and compile that function
13554    all the way to assembler language output.  The free the storage
13555    for the function definition.
13556 
13557    This is called after parsing the body of the function definition.
13558 
13559    NESTED is nonzero if the function being finished is nested in another.  */
13560 
13561 static void
finish_function(int nested)13562 finish_function (int nested)
13563 {
13564   register tree fndecl = current_function_decl;
13565 
13566   assert (fndecl != NULL_TREE);
13567   if (TREE_CODE (fndecl) != ERROR_MARK)
13568     {
13569       if (nested)
13570 	assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13571       else
13572 	assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13573     }
13574 
13575 /*  TREE_READONLY (fndecl) = 1;
13576     This caused &foo to be of type ptr-to-const-function
13577     which then got a warning when stored in a ptr-to-function variable.  */
13578 
13579   poplevel (1, 0, 1);
13580 
13581   if (TREE_CODE (fndecl) != ERROR_MARK)
13582     {
13583       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13584 
13585       /* Must mark the RESULT_DECL as being in this function.  */
13586 
13587       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13588 
13589       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13590       /* Generate rtl for function exit.  */
13591       expand_function_end (input_filename, lineno, 0);
13592 
13593       /* If this is a nested function, protect the local variables in the stack
13594 	 above us from being collected while we're compiling this function.  */
13595       if (nested)
13596 	ggc_push_context ();
13597 
13598       /* Run the optimizers and output the assembler code for this function.  */
13599       rest_of_compilation (fndecl);
13600 
13601       /* Undo the GC context switch.  */
13602       if (nested)
13603 	ggc_pop_context ();
13604     }
13605 
13606   if (TREE_CODE (fndecl) != ERROR_MARK
13607       && !nested
13608       && DECL_SAVED_INSNS (fndecl) == 0)
13609     {
13610       /* Stop pointing to the local nodes about to be freed.  */
13611       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13612 	 function definition.  */
13613       /* For a nested function, this is done in pop_f_function_context.  */
13614       /* If rest_of_compilation set this to 0, leave it 0.  */
13615       if (DECL_INITIAL (fndecl) != 0)
13616 	DECL_INITIAL (fndecl) = error_mark_node;
13617       DECL_ARGUMENTS (fndecl) = 0;
13618     }
13619 
13620   if (!nested)
13621     {
13622       /* Let the error reporting routines know that we're outside a function.
13623 	 For a nested function, this value is used in pop_c_function_context
13624 	 and then reset via pop_function_context.  */
13625       ffecom_outer_function_decl_ = current_function_decl = NULL;
13626     }
13627 }
13628 
13629 /* Plug-in replacement for identifying the name of a decl and, for a
13630    function, what we call it in diagnostics.  For now, "program unit"
13631    should suffice, since it's a bit of a hassle to figure out which
13632    of several kinds of things it is.  Note that it could conceivably
13633    be a statement function, which probably isn't really a program unit
13634    per se, but if that comes up, it should be easy to check (being a
13635    nested function and all).  */
13636 
13637 static const char *
ffe_printable_name(tree decl,int v)13638 ffe_printable_name (tree decl, int v)
13639 {
13640   /* Just to keep GCC quiet about the unused variable.
13641      In theory, differing values of V should produce different
13642      output.  */
13643   switch (v)
13644     {
13645     default:
13646       if (TREE_CODE (decl) == ERROR_MARK)
13647 	return "erroneous code";
13648       return IDENTIFIER_POINTER (DECL_NAME (decl));
13649     }
13650 }
13651 
13652 /* g77's function to print out name of current function that caused
13653    an error.  */
13654 
13655 static void
ffe_print_error_function(diagnostic_context * context,const char * file)13656 ffe_print_error_function (diagnostic_context *context __attribute__((unused)),
13657 			  const char *file)
13658 {
13659   static ffeglobal last_g = NULL;
13660   static ffesymbol last_s = NULL;
13661   ffeglobal g;
13662   ffesymbol s;
13663   const char *kind;
13664 
13665   if ((ffecom_primary_entry_ == NULL)
13666       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
13667     {
13668       g = NULL;
13669       s = NULL;
13670       kind = NULL;
13671     }
13672   else
13673     {
13674       g = ffesymbol_global (ffecom_primary_entry_);
13675       if (ffecom_nested_entry_ == NULL)
13676 	{
13677 	  s = ffecom_primary_entry_;
13678 	  kind = _(ffeinfo_kind_message (ffesymbol_kind (s)));
13679 	}
13680       else
13681 	{
13682 	  s = ffecom_nested_entry_;
13683 	  kind = _("In statement function");
13684 	}
13685     }
13686 
13687   if ((last_g != g) || (last_s != s))
13688     {
13689       if (file)
13690 	fprintf (stderr, "%s: ", file);
13691 
13692       if (s == NULL)
13693 	fprintf (stderr, _("Outside of any program unit:\n"));
13694       else
13695 	{
13696 	  const char *name = ffesymbol_text (s);
13697 
13698 	  fprintf (stderr, "%s `%s':\n", kind, name);
13699 	}
13700 
13701       last_g = g;
13702       last_s = s;
13703     }
13704 }
13705 
13706 /* Similar to `lookup_name' but look only at current binding level.  */
13707 
13708 static tree
lookup_name_current_level(tree name)13709 lookup_name_current_level (tree name)
13710 {
13711   register tree t;
13712 
13713   if (current_binding_level == global_binding_level)
13714     return IDENTIFIER_GLOBAL_VALUE (name);
13715 
13716   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
13717     return 0;
13718 
13719   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
13720     if (DECL_NAME (t) == name)
13721       break;
13722 
13723   return t;
13724 }
13725 
13726 /* Create a new `struct f_binding_level'.  */
13727 
13728 static struct f_binding_level *
make_binding_level()13729 make_binding_level ()
13730 {
13731   /* NOSTRICT */
13732   return ggc_alloc (sizeof (struct f_binding_level));
13733 }
13734 
13735 /* Save and restore the variables in this file and elsewhere
13736    that keep track of the progress of compilation of the current function.
13737    Used for nested functions.  */
13738 
13739 struct f_function
13740 {
13741   struct f_function *next;
13742   tree named_labels;
13743   tree shadowed_labels;
13744   struct f_binding_level *binding_level;
13745 };
13746 
13747 struct f_function *f_function_chain;
13748 
13749 /* Restore the variables used during compilation of a C function.  */
13750 
13751 static void
pop_f_function_context()13752 pop_f_function_context ()
13753 {
13754   struct f_function *p = f_function_chain;
13755   tree link;
13756 
13757   /* Bring back all the labels that were shadowed.  */
13758   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
13759     if (DECL_NAME (TREE_VALUE (link)) != 0)
13760       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
13761 	= TREE_VALUE (link);
13762 
13763   if (current_function_decl != error_mark_node
13764       && DECL_SAVED_INSNS (current_function_decl) == 0)
13765     {
13766       /* Stop pointing to the local nodes about to be freed.  */
13767       /* But DECL_INITIAL must remain nonzero so we know this was an actual
13768 	 function definition.  */
13769       DECL_INITIAL (current_function_decl) = error_mark_node;
13770       DECL_ARGUMENTS (current_function_decl) = 0;
13771     }
13772 
13773   pop_function_context ();
13774 
13775   f_function_chain = p->next;
13776 
13777   named_labels = p->named_labels;
13778   shadowed_labels = p->shadowed_labels;
13779   current_binding_level = p->binding_level;
13780 
13781   free (p);
13782 }
13783 
13784 /* Save and reinitialize the variables
13785    used during compilation of a C function.  */
13786 
13787 static void
push_f_function_context()13788 push_f_function_context ()
13789 {
13790   struct f_function *p
13791   = (struct f_function *) xmalloc (sizeof (struct f_function));
13792 
13793   push_function_context ();
13794 
13795   p->next = f_function_chain;
13796   f_function_chain = p;
13797 
13798   p->named_labels = named_labels;
13799   p->shadowed_labels = shadowed_labels;
13800   p->binding_level = current_binding_level;
13801 }
13802 
13803 static void
push_parm_decl(tree parm)13804 push_parm_decl (tree parm)
13805 {
13806   int old_immediate_size_expand = immediate_size_expand;
13807 
13808   /* Don't try computing parm sizes now -- wait till fn is called.  */
13809 
13810   immediate_size_expand = 0;
13811 
13812   /* Fill in arg stuff.  */
13813 
13814   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
13815   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
13816   TREE_READONLY (parm) = 1;	/* All implementation args are read-only. */
13817 
13818   parm = pushdecl (parm);
13819 
13820   immediate_size_expand = old_immediate_size_expand;
13821 
13822   finish_decl (parm, NULL_TREE, FALSE);
13823 }
13824 
13825 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
13826 
13827 static tree
pushdecl_top_level(x)13828 pushdecl_top_level (x)
13829      tree x;
13830 {
13831   register tree t;
13832   register struct f_binding_level *b = current_binding_level;
13833   register tree f = current_function_decl;
13834 
13835   current_binding_level = global_binding_level;
13836   current_function_decl = NULL_TREE;
13837   t = pushdecl (x);
13838   current_binding_level = b;
13839   current_function_decl = f;
13840   return t;
13841 }
13842 
13843 /* Store the list of declarations of the current level.
13844    This is done for the parameter declarations of a function being defined,
13845    after they are modified in the light of any missing parameters.  */
13846 
13847 static tree
storedecls(decls)13848 storedecls (decls)
13849      tree decls;
13850 {
13851   return current_binding_level->names = decls;
13852 }
13853 
13854 /* Store the parameter declarations into the current function declaration.
13855    This is called after parsing the parameter declarations, before
13856    digesting the body of the function.
13857 
13858    For an old-style definition, modify the function's type
13859    to specify at least the number of arguments.  */
13860 
13861 static void
store_parm_decls(int is_main_program UNUSED)13862 store_parm_decls (int is_main_program UNUSED)
13863 {
13864   register tree fndecl = current_function_decl;
13865 
13866   if (fndecl == error_mark_node)
13867     return;
13868 
13869   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
13870   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
13871 
13872   /* Initialize the RTL code for the function.  */
13873 
13874   init_function_start (fndecl, input_filename, lineno);
13875 
13876   /* Set up parameters and prepare for return, for the function.  */
13877 
13878   expand_function_start (fndecl, 0);
13879 }
13880 
13881 static tree
start_decl(tree decl,bool is_top_level)13882 start_decl (tree decl, bool is_top_level)
13883 {
13884   register tree tem;
13885   bool at_top_level = (current_binding_level == global_binding_level);
13886   bool top_level = is_top_level || at_top_level;
13887 
13888   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13889      level anyway.  */
13890   assert (!is_top_level || !at_top_level);
13891 
13892   if (DECL_INITIAL (decl) != NULL_TREE)
13893     {
13894       assert (DECL_INITIAL (decl) == error_mark_node);
13895       assert (!DECL_EXTERNAL (decl));
13896     }
13897   else if (top_level)
13898     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
13899 
13900   /* For Fortran, we by default put things in .common when possible.  */
13901   DECL_COMMON (decl) = 1;
13902 
13903   /* Add this decl to the current binding level. TEM may equal DECL or it may
13904      be a previous decl of the same name.  */
13905   if (is_top_level)
13906     tem = pushdecl_top_level (decl);
13907   else
13908     tem = pushdecl (decl);
13909 
13910   /* For a local variable, define the RTL now.  */
13911   if (!top_level
13912   /* But not if this is a duplicate decl and we preserved the rtl from the
13913      previous one (which may or may not happen).  */
13914       && !DECL_RTL_SET_P (tem))
13915     {
13916       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
13917 	expand_decl (tem);
13918       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
13919 	       && DECL_INITIAL (tem) != 0)
13920 	expand_decl (tem);
13921     }
13922 
13923   return tem;
13924 }
13925 
13926 /* Create the FUNCTION_DECL for a function definition.
13927    DECLSPECS and DECLARATOR are the parts of the declaration;
13928    they describe the function's name and the type it returns,
13929    but twisted together in a fashion that parallels the syntax of C.
13930 
13931    This function creates a binding context for the function body
13932    as well as setting up the FUNCTION_DECL in current_function_decl.
13933 
13934    Returns 1 on success.  If the DECLARATOR is not suitable for a function
13935    (it defines a datum instead), we return 0, which tells
13936    ffe_parse_file to report a parse error.
13937 
13938    NESTED is nonzero for a function nested within another function.  */
13939 
13940 static void
start_function(tree name,tree type,int nested,int public)13941 start_function (tree name, tree type, int nested, int public)
13942 {
13943   tree decl1;
13944   tree restype;
13945   int old_immediate_size_expand = immediate_size_expand;
13946 
13947   named_labels = 0;
13948   shadowed_labels = 0;
13949 
13950   /* Don't expand any sizes in the return type of the function.  */
13951   immediate_size_expand = 0;
13952 
13953   if (nested)
13954     {
13955       assert (!public);
13956       assert (current_function_decl != NULL_TREE);
13957       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
13958     }
13959   else
13960     {
13961       assert (current_function_decl == NULL_TREE);
13962     }
13963 
13964   if (TREE_CODE (type) == ERROR_MARK)
13965     decl1 = current_function_decl = error_mark_node;
13966   else
13967     {
13968       decl1 = build_decl (FUNCTION_DECL,
13969 			  name,
13970 			  type);
13971       TREE_PUBLIC (decl1) = public ? 1 : 0;
13972       if (nested)
13973 	DECL_INLINE (decl1) = 1;
13974       TREE_STATIC (decl1) = 1;
13975       DECL_EXTERNAL (decl1) = 0;
13976 
13977       announce_function (decl1);
13978 
13979       /* Make the init_value nonzero so pushdecl knows this is not tentative.
13980 	 error_mark_node is replaced below (in poplevel) with the BLOCK.  */
13981       DECL_INITIAL (decl1) = error_mark_node;
13982 
13983       /* Record the decl so that the function name is defined. If we already have
13984 	 a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
13985 
13986       current_function_decl = pushdecl (decl1);
13987     }
13988 
13989   if (!nested)
13990     ffecom_outer_function_decl_ = current_function_decl;
13991 
13992   pushlevel (0);
13993   current_binding_level->prep_state = 2;
13994 
13995   if (TREE_CODE (current_function_decl) != ERROR_MARK)
13996     {
13997       make_decl_rtl (current_function_decl, NULL);
13998 
13999       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14000       DECL_RESULT (current_function_decl)
14001 	= build_decl (RESULT_DECL, NULL_TREE, restype);
14002     }
14003 
14004   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14005     TREE_ADDRESSABLE (current_function_decl) = 1;
14006 
14007   immediate_size_expand = old_immediate_size_expand;
14008 }
14009 
14010 /* Here are the public functions the GNU back end needs.  */
14011 
14012 tree
convert(type,expr)14013 convert (type, expr)
14014      tree type, expr;
14015 {
14016   register tree e = expr;
14017   register enum tree_code code = TREE_CODE (type);
14018 
14019   if (type == TREE_TYPE (e)
14020       || TREE_CODE (e) == ERROR_MARK)
14021     return e;
14022   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14023     return fold (build1 (NOP_EXPR, type, e));
14024   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14025       || code == ERROR_MARK)
14026     return error_mark_node;
14027   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14028     {
14029       assert ("void value not ignored as it ought to be" == NULL);
14030       return error_mark_node;
14031     }
14032   if (code == VOID_TYPE)
14033     return build1 (CONVERT_EXPR, type, e);
14034   if ((code != RECORD_TYPE)
14035       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14036     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14037 		  e);
14038   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14039     return fold (convert_to_integer (type, e));
14040   if (code == POINTER_TYPE)
14041     return fold (convert_to_pointer (type, e));
14042   if (code == REAL_TYPE)
14043     return fold (convert_to_real (type, e));
14044   if (code == COMPLEX_TYPE)
14045     return fold (convert_to_complex (type, e));
14046   if (code == RECORD_TYPE)
14047     return fold (ffecom_convert_to_complex_ (type, e));
14048 
14049   assert ("conversion to non-scalar type requested" == NULL);
14050   return error_mark_node;
14051 }
14052 
14053 /* Return the list of declarations of the current level.
14054    Note that this list is in reverse order unless/until
14055    you nreverse it; and when you do nreverse it, you must
14056    store the result back using `storedecls' or you will lose.  */
14057 
14058 tree
getdecls()14059 getdecls ()
14060 {
14061   return current_binding_level->names;
14062 }
14063 
14064 /* Nonzero if we are currently in the global binding level.  */
14065 
14066 int
global_bindings_p()14067 global_bindings_p ()
14068 {
14069   return current_binding_level == global_binding_level;
14070 }
14071 
14072 static void
ffecom_init_decl_processing()14073 ffecom_init_decl_processing ()
14074 {
14075   malloc_init ();
14076 
14077   ffe_init_0 ();
14078 }
14079 
14080 /* Delete the node BLOCK from the current binding level.
14081    This is used for the block inside a stmt expr ({...})
14082    so that the block can be reinserted where appropriate.  */
14083 
14084 static void
delete_block(block)14085 delete_block (block)
14086      tree block;
14087 {
14088   tree t;
14089   if (current_binding_level->blocks == block)
14090     current_binding_level->blocks = TREE_CHAIN (block);
14091   for (t = current_binding_level->blocks; t;)
14092     {
14093       if (TREE_CHAIN (t) == block)
14094 	TREE_CHAIN (t) = TREE_CHAIN (block);
14095       else
14096 	t = TREE_CHAIN (t);
14097     }
14098   TREE_CHAIN (block) = NULL;
14099   /* Clear TREE_USED which is always set by poplevel.
14100      The flag is set again if insert_block is called.  */
14101   TREE_USED (block) = 0;
14102 }
14103 
14104 void
insert_block(block)14105 insert_block (block)
14106      tree block;
14107 {
14108   TREE_USED (block) = 1;
14109   current_binding_level->blocks
14110     = chainon (current_binding_level->blocks, block);
14111 }
14112 
14113 /* Each front end provides its own.  */
14114 static const char *ffe_init PARAMS ((const char *));
14115 static void ffe_finish PARAMS ((void));
14116 static void ffe_init_options PARAMS ((void));
14117 static void ffe_print_identifier PARAMS ((FILE *, tree, int));
14118 
14119 struct language_function GTY(())
14120 {
14121   int unused;
14122 };
14123 
14124 #undef  LANG_HOOKS_NAME
14125 #define LANG_HOOKS_NAME			"GNU F77"
14126 #undef  LANG_HOOKS_INIT
14127 #define LANG_HOOKS_INIT			ffe_init
14128 #undef  LANG_HOOKS_FINISH
14129 #define LANG_HOOKS_FINISH		ffe_finish
14130 #undef  LANG_HOOKS_INIT_OPTIONS
14131 #define LANG_HOOKS_INIT_OPTIONS		ffe_init_options
14132 #undef  LANG_HOOKS_DECODE_OPTION
14133 #define LANG_HOOKS_DECODE_OPTION	ffe_decode_option
14134 #undef  LANG_HOOKS_PARSE_FILE
14135 #define LANG_HOOKS_PARSE_FILE		ffe_parse_file
14136 #undef  LANG_HOOKS_MARK_ADDRESSABLE
14137 #define LANG_HOOKS_MARK_ADDRESSABLE	ffe_mark_addressable
14138 #undef  LANG_HOOKS_PRINT_IDENTIFIER
14139 #define LANG_HOOKS_PRINT_IDENTIFIER	ffe_print_identifier
14140 #undef  LANG_HOOKS_DECL_PRINTABLE_NAME
14141 #define LANG_HOOKS_DECL_PRINTABLE_NAME	ffe_printable_name
14142 #undef  LANG_HOOKS_PRINT_ERROR_FUNCTION
14143 #define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
14144 #undef  LANG_HOOKS_TRUTHVALUE_CONVERSION
14145 #define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
14146 
14147 #undef  LANG_HOOKS_TYPE_FOR_MODE
14148 #define LANG_HOOKS_TYPE_FOR_MODE	ffe_type_for_mode
14149 #undef  LANG_HOOKS_TYPE_FOR_SIZE
14150 #define LANG_HOOKS_TYPE_FOR_SIZE	ffe_type_for_size
14151 #undef  LANG_HOOKS_SIGNED_TYPE
14152 #define LANG_HOOKS_SIGNED_TYPE		ffe_signed_type
14153 #undef  LANG_HOOKS_UNSIGNED_TYPE
14154 #define LANG_HOOKS_UNSIGNED_TYPE	ffe_unsigned_type
14155 #undef  LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
14156 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
14157 
14158 /* We do not wish to use alias-set based aliasing at all.  Used in the
14159    extreme (every object with its own set, with equivalences recorded) it
14160    might be helpful, but there are problems when it comes to inlining.  We
14161    get on ok with flag_argument_noalias, and alias-set aliasing does
14162    currently limit how stack slots can be reused, which is a lose.  */
14163 #undef LANG_HOOKS_GET_ALIAS_SET
14164 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14165 
14166 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
14167 
14168 /* Table indexed by tree code giving a string containing a character
14169    classifying the tree code.  Possibilities are
14170    t, d, s, c, r, <, 1, 2 and e.  See tree.def for details.  */
14171 
14172 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14173 
14174 const char tree_code_type[] = {
14175 #include "tree.def"
14176 };
14177 #undef DEFTREECODE
14178 
14179 /* Table indexed by tree code giving number of expression
14180    operands beyond the fixed part of the node structure.
14181    Not used for types or decls.  */
14182 
14183 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14184 
14185 const unsigned char tree_code_length[] = {
14186 #include "tree.def"
14187 };
14188 #undef DEFTREECODE
14189 
14190 /* Names of tree components.
14191    Used for printing out the tree and error messages.  */
14192 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14193 
14194 const char *const tree_code_name[] = {
14195 #include "tree.def"
14196 };
14197 #undef DEFTREECODE
14198 
14199 static const char *
ffe_init(filename)14200 ffe_init (filename)
14201      const char *filename;
14202 {
14203   /* Open input file.  */
14204   if (filename == 0 || !strcmp (filename, "-"))
14205     {
14206       finput = stdin;
14207       filename = "stdin";
14208     }
14209   else
14210     finput = fopen (filename, "r");
14211   if (finput == 0)
14212     fatal_io_error ("can't open %s", filename);
14213 
14214 #ifdef IO_BUFFER_SIZE
14215   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14216 #endif
14217 
14218   ffecom_init_decl_processing ();
14219 
14220   /* If the file is output from cpp, it should contain a first line
14221      `# 1 "real-filename"', and the current design of gcc (toplev.c
14222      in particular and the way it sets up information relied on by
14223      INCLUDE) requires that we read this now, and store the
14224      "real-filename" info in master_input_filename.  Ask the lexer
14225      to try doing this.  */
14226   ffelex_hash_kludge (finput);
14227 
14228   /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14229      return the new file name.  */
14230   if (main_input_filename)
14231     filename = main_input_filename;
14232 
14233   return filename;
14234 }
14235 
14236 static void
ffe_finish()14237 ffe_finish ()
14238 {
14239   ffe_terminate_0 ();
14240 
14241   if (ffe_is_ffedebug ())
14242     malloc_pool_display (malloc_pool_image ());
14243 
14244   fclose (finput);
14245 }
14246 
14247 static void
ffe_init_options()14248 ffe_init_options ()
14249 {
14250   /* Set default options for Fortran.  */
14251   flag_move_all_movables = 1;
14252   flag_reduce_all_givs = 1;
14253   flag_argument_noalias = 2;
14254   flag_merge_constants = 2;
14255   flag_errno_math = 0;
14256   flag_complex_divide_method = 1;
14257 }
14258 
14259 static bool
ffe_mark_addressable(exp)14260 ffe_mark_addressable (exp)
14261      tree exp;
14262 {
14263   register tree x = exp;
14264   while (1)
14265     switch (TREE_CODE (x))
14266       {
14267       case ADDR_EXPR:
14268       case COMPONENT_REF:
14269       case ARRAY_REF:
14270 	x = TREE_OPERAND (x, 0);
14271 	break;
14272 
14273       case CONSTRUCTOR:
14274 	TREE_ADDRESSABLE (x) = 1;
14275 	return true;
14276 
14277       case VAR_DECL:
14278       case CONST_DECL:
14279       case PARM_DECL:
14280       case RESULT_DECL:
14281 	if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14282 	    && DECL_NONLOCAL (x))
14283 	  {
14284 	    if (TREE_PUBLIC (x))
14285 	      {
14286 		assert ("address of global register var requested" == NULL);
14287 		return false;
14288 	      }
14289 	    assert ("address of register variable requested" == NULL);
14290 	  }
14291 	else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14292 	  {
14293 	    if (TREE_PUBLIC (x))
14294 	      {
14295 		assert ("address of global register var requested" == NULL);
14296 		return false;
14297 	      }
14298 	    assert ("address of register var requested" == NULL);
14299 	  }
14300 	put_var_into_stack (x, /*rescan=*/true);
14301 
14302 	/* drops in */
14303       case FUNCTION_DECL:
14304 	TREE_ADDRESSABLE (x) = 1;
14305 #if 0				/* poplevel deals with this now.  */
14306 	if (DECL_CONTEXT (x) == 0)
14307 	  TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14308 #endif
14309 
14310       default:
14311 	return true;
14312       }
14313 }
14314 
14315 /* Exit a binding level.
14316    Pop the level off, and restore the state of the identifier-decl mappings
14317    that were in effect when this level was entered.
14318 
14319    If KEEP is nonzero, this level had explicit declarations, so
14320    and create a "block" (a BLOCK node) for the level
14321    to record its declarations and subblocks for symbol table output.
14322 
14323    If FUNCTIONBODY is nonzero, this level is the body of a function,
14324    so create a block as if KEEP were set and also clear out all
14325    label names.
14326 
14327    If REVERSE is nonzero, reverse the order of decls before putting
14328    them into the BLOCK.  */
14329 
14330 tree
poplevel(keep,reverse,functionbody)14331 poplevel (keep, reverse, functionbody)
14332      int keep;
14333      int reverse;
14334      int functionbody;
14335 {
14336   register tree link;
14337   /* The chain of decls was accumulated in reverse order.
14338      Put it into forward order, just for cleanliness.  */
14339   tree decls;
14340   tree subblocks = current_binding_level->blocks;
14341   tree block = 0;
14342   tree decl;
14343   int block_previously_created;
14344 
14345   /* Get the decls in the order they were written.
14346      Usually current_binding_level->names is in reverse order.
14347      But parameter decls were previously put in forward order.  */
14348 
14349   if (reverse)
14350     current_binding_level->names
14351       = decls = nreverse (current_binding_level->names);
14352   else
14353     decls = current_binding_level->names;
14354 
14355   /* Output any nested inline functions within this block
14356      if they weren't already output.  */
14357 
14358   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14359     if (TREE_CODE (decl) == FUNCTION_DECL
14360 	&& ! TREE_ASM_WRITTEN (decl)
14361 	&& DECL_INITIAL (decl) != 0
14362 	&& TREE_ADDRESSABLE (decl))
14363       {
14364 	/* If this decl was copied from a file-scope decl
14365 	   on account of a block-scope extern decl,
14366 	   propagate TREE_ADDRESSABLE to the file-scope decl.
14367 
14368 	   DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14369 	   true, since then the decl goes through save_for_inline_copying.  */
14370 	if (DECL_ABSTRACT_ORIGIN (decl) != 0
14371 	    && DECL_ABSTRACT_ORIGIN (decl) != decl)
14372 	  TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14373 	else if (DECL_SAVED_INSNS (decl) != 0)
14374 	  {
14375 	    push_function_context ();
14376 	    output_inline_function (decl);
14377 	    pop_function_context ();
14378 	  }
14379       }
14380 
14381   /* If there were any declarations or structure tags in that level,
14382      or if this level is a function body,
14383      create a BLOCK to record them for the life of this function.  */
14384 
14385   block = 0;
14386   block_previously_created = (current_binding_level->this_block != 0);
14387   if (block_previously_created)
14388     block = current_binding_level->this_block;
14389   else if (keep || functionbody)
14390     block = make_node (BLOCK);
14391   if (block != 0)
14392     {
14393       BLOCK_VARS (block) = decls;
14394       BLOCK_SUBBLOCKS (block) = subblocks;
14395     }
14396 
14397   /* In each subblock, record that this is its superior.  */
14398 
14399   for (link = subblocks; link; link = TREE_CHAIN (link))
14400     BLOCK_SUPERCONTEXT (link) = block;
14401 
14402   /* Clear out the meanings of the local variables of this level.  */
14403 
14404   for (link = decls; link; link = TREE_CHAIN (link))
14405     {
14406       if (DECL_NAME (link) != 0)
14407 	{
14408 	  /* If the ident. was used or addressed via a local extern decl,
14409 	     don't forget that fact.  */
14410 	  if (DECL_EXTERNAL (link))
14411 	    {
14412 	      if (TREE_USED (link))
14413 		TREE_USED (DECL_NAME (link)) = 1;
14414 	      if (TREE_ADDRESSABLE (link))
14415 		TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14416 	    }
14417 	  IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14418 	}
14419     }
14420 
14421   /* If the level being exited is the top level of a function,
14422      check over all the labels, and clear out the current
14423      (function local) meanings of their names.  */
14424 
14425   if (functionbody)
14426     {
14427       /* If this is the top level block of a function,
14428 	 the vars are the function's parameters.
14429 	 Don't leave them in the BLOCK because they are
14430 	 found in the FUNCTION_DECL instead.  */
14431 
14432       BLOCK_VARS (block) = 0;
14433     }
14434 
14435   /* Pop the current level, and free the structure for reuse.  */
14436 
14437   {
14438     register struct f_binding_level *level = current_binding_level;
14439     current_binding_level = current_binding_level->level_chain;
14440 
14441     level->level_chain = free_binding_level;
14442     free_binding_level = level;
14443   }
14444 
14445   /* Dispose of the block that we just made inside some higher level.  */
14446   if (functionbody
14447       && current_function_decl != error_mark_node)
14448     DECL_INITIAL (current_function_decl) = block;
14449   else if (block)
14450     {
14451       if (!block_previously_created)
14452 	current_binding_level->blocks
14453 	  = chainon (current_binding_level->blocks, block);
14454     }
14455   /* If we did not make a block for the level just exited,
14456      any blocks made for inner levels
14457      (since they cannot be recorded as subblocks in that level)
14458      must be carried forward so they will later become subblocks
14459      of something else.  */
14460   else if (subblocks)
14461     current_binding_level->blocks
14462       = chainon (current_binding_level->blocks, subblocks);
14463 
14464   if (block)
14465     TREE_USED (block) = 1;
14466   return block;
14467 }
14468 
14469 static void
ffe_print_identifier(file,node,indent)14470 ffe_print_identifier (file, node, indent)
14471      FILE *file;
14472      tree node;
14473      int indent;
14474 {
14475   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14476   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14477 }
14478 
14479 /* Record a decl-node X as belonging to the current lexical scope.
14480    Check for errors (such as an incompatible declaration for the same
14481    name already seen in the same scope).
14482 
14483    Returns either X or an old decl for the same name.
14484    If an old decl is returned, it may have been smashed
14485    to agree with what X says.  */
14486 
14487 tree
pushdecl(x)14488 pushdecl (x)
14489      tree x;
14490 {
14491   register tree t;
14492   register tree name = DECL_NAME (x);
14493   register struct f_binding_level *b = current_binding_level;
14494 
14495   if ((TREE_CODE (x) == FUNCTION_DECL)
14496       && (DECL_INITIAL (x) == 0)
14497       && DECL_EXTERNAL (x))
14498     DECL_CONTEXT (x) = NULL_TREE;
14499   else
14500     DECL_CONTEXT (x) = current_function_decl;
14501 
14502   if (name)
14503     {
14504       if (IDENTIFIER_INVENTED (name))
14505 	{
14506 	  DECL_ARTIFICIAL (x) = 1;
14507 	  DECL_IN_SYSTEM_HEADER (x) = 1;
14508 	}
14509 
14510       t = lookup_name_current_level (name);
14511 
14512       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14513 
14514       /* Don't push non-parms onto list for parms until we understand
14515 	 why we're doing this and whether it works.  */
14516 
14517       assert ((b == global_binding_level)
14518 	      || !ffecom_transform_only_dummies_
14519 	      || TREE_CODE (x) == PARM_DECL);
14520 
14521       if ((t != NULL_TREE) && duplicate_decls (x, t))
14522 	return t;
14523 
14524       /* If we are processing a typedef statement, generate a whole new
14525 	 ..._TYPE node (which will be just an variant of the existing
14526 	 ..._TYPE node with identical properties) and then install the
14527 	 TYPE_DECL node generated to represent the typedef name as the
14528 	 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14529 
14530 	 The whole point here is to end up with a situation where each and every
14531 	 ..._TYPE node the compiler creates will be uniquely associated with
14532 	 AT MOST one node representing a typedef name. This way, even though
14533 	 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14534 	 (i.e. "typedef name") nodes very early on, later parts of the
14535 	 compiler can always do the reverse translation and get back the
14536 	 corresponding typedef name.  For example, given:
14537 
14538 	 typedef struct S MY_TYPE; MY_TYPE object;
14539 
14540 	 Later parts of the compiler might only know that `object' was of type
14541 	 `struct S' if it were not for code just below.  With this code
14542 	 however, later parts of the compiler see something like:
14543 
14544 	 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14545 
14546 	 And they can then deduce (from the node for type struct S') that the
14547 	 original object declaration was:
14548 
14549 	 MY_TYPE object;
14550 
14551 	 Being able to do this is important for proper support of protoize, and
14552 	 also for generating precise symbolic debugging information which
14553 	 takes full account of the programmer's (typedef) vocabulary.
14554 
14555 	 Obviously, we don't want to generate a duplicate ..._TYPE node if the
14556 	 TYPE_DECL node that we are now processing really represents a
14557 	 standard built-in type.
14558 
14559 	 Since all standard types are effectively declared at line zero in the
14560 	 source file, we can easily check to see if we are working on a
14561 	 standard type by checking the current value of lineno.  */
14562 
14563       if (TREE_CODE (x) == TYPE_DECL)
14564 	{
14565 	  if (DECL_SOURCE_LINE (x) == 0)
14566 	    {
14567 	      if (TYPE_NAME (TREE_TYPE (x)) == 0)
14568 		TYPE_NAME (TREE_TYPE (x)) = x;
14569 	    }
14570 	  else if (TREE_TYPE (x) != error_mark_node)
14571 	    {
14572 	      tree tt = TREE_TYPE (x);
14573 
14574 	      tt = build_type_copy (tt);
14575 	      TYPE_NAME (tt) = x;
14576 	      TREE_TYPE (x) = tt;
14577 	    }
14578 	}
14579 
14580       /* This name is new in its binding level. Install the new declaration
14581 	 and return it.  */
14582       if (b == global_binding_level)
14583 	IDENTIFIER_GLOBAL_VALUE (name) = x;
14584       else
14585 	IDENTIFIER_LOCAL_VALUE (name) = x;
14586     }
14587 
14588   /* Put decls on list in reverse order. We will reverse them later if
14589      necessary.  */
14590   TREE_CHAIN (x) = b->names;
14591   b->names = x;
14592 
14593   return x;
14594 }
14595 
14596 /* Nonzero if the current level needs to have a BLOCK made.  */
14597 
14598 static int
kept_level_p()14599 kept_level_p ()
14600 {
14601   tree decl;
14602 
14603   for (decl = current_binding_level->names;
14604        decl;
14605        decl = TREE_CHAIN (decl))
14606     {
14607       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
14608 	  || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
14609 	/* Currently, there aren't supposed to be non-artificial names
14610 	   at other than the top block for a function -- they're
14611 	   believed to always be temps.  But it's wise to check anyway.  */
14612 	return 1;
14613     }
14614   return 0;
14615 }
14616 
14617 /* Enter a new binding level.
14618    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14619    not for that of tags.  */
14620 
14621 void
pushlevel(tag_transparent)14622 pushlevel (tag_transparent)
14623      int tag_transparent;
14624 {
14625   register struct f_binding_level *newlevel = NULL_BINDING_LEVEL;
14626 
14627   assert (! tag_transparent);
14628 
14629   if (current_binding_level == global_binding_level)
14630     {
14631       named_labels = 0;
14632     }
14633 
14634   /* Reuse or create a struct for this binding level.  */
14635 
14636   if (free_binding_level)
14637     {
14638       newlevel = free_binding_level;
14639       free_binding_level = free_binding_level->level_chain;
14640     }
14641   else
14642     {
14643       newlevel = make_binding_level ();
14644     }
14645 
14646   /* Add this level to the front of the chain (stack) of levels that
14647      are active.  */
14648 
14649   *newlevel = clear_binding_level;
14650   newlevel->level_chain = current_binding_level;
14651   current_binding_level = newlevel;
14652 }
14653 
14654 /* Set the BLOCK node for the innermost scope
14655    (the one we are currently in).  */
14656 
14657 void
set_block(block)14658 set_block (block)
14659      register tree block;
14660 {
14661   current_binding_level->this_block = block;
14662   current_binding_level->names = chainon (current_binding_level->names,
14663 					  BLOCK_VARS (block));
14664   current_binding_level->blocks = chainon (current_binding_level->blocks,
14665 					   BLOCK_SUBBLOCKS (block));
14666 }
14667 
14668 static tree
ffe_signed_or_unsigned_type(unsignedp,type)14669 ffe_signed_or_unsigned_type (unsignedp, type)
14670      int unsignedp;
14671      tree type;
14672 {
14673   tree type2;
14674 
14675   if (! INTEGRAL_TYPE_P (type))
14676     return type;
14677   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
14678     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14679   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
14680     return unsignedp ? unsigned_type_node : integer_type_node;
14681   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
14682     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14683   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
14684     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14685   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
14686     return (unsignedp ? long_long_unsigned_type_node
14687 	    : long_long_integer_type_node);
14688 
14689   type2 = ffe_type_for_size (TYPE_PRECISION (type), unsignedp);
14690   if (type2 == NULL_TREE)
14691     return type;
14692 
14693   return type2;
14694 }
14695 
14696 static tree
ffe_signed_type(type)14697 ffe_signed_type (type)
14698      tree type;
14699 {
14700   tree type1 = TYPE_MAIN_VARIANT (type);
14701   ffeinfoKindtype kt;
14702   tree type2;
14703 
14704   if (type1 == unsigned_char_type_node || type1 == char_type_node)
14705     return signed_char_type_node;
14706   if (type1 == unsigned_type_node)
14707     return integer_type_node;
14708   if (type1 == short_unsigned_type_node)
14709     return short_integer_type_node;
14710   if (type1 == long_unsigned_type_node)
14711     return long_integer_type_node;
14712   if (type1 == long_long_unsigned_type_node)
14713     return long_long_integer_type_node;
14714 #if 0	/* gcc/c-* files only */
14715   if (type1 == unsigned_intDI_type_node)
14716     return intDI_type_node;
14717   if (type1 == unsigned_intSI_type_node)
14718     return intSI_type_node;
14719   if (type1 == unsigned_intHI_type_node)
14720     return intHI_type_node;
14721   if (type1 == unsigned_intQI_type_node)
14722     return intQI_type_node;
14723 #endif
14724 
14725   type2 = ffe_type_for_size (TYPE_PRECISION (type1), 0);
14726   if (type2 != NULL_TREE)
14727     return type2;
14728 
14729   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
14730     {
14731       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
14732 
14733       if (type1 == type2)
14734 	return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
14735     }
14736 
14737   return type;
14738 }
14739 
14740 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14741    or validate its data type for an `if' or `while' statement or ?..: exp.
14742 
14743    This preparation consists of taking the ordinary
14744    representation of an expression expr and producing a valid tree
14745    boolean expression describing whether expr is nonzero.  We could
14746    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14747    but we optimize comparisons, &&, ||, and !.
14748 
14749    The resulting type should always be `integer_type_node'.  */
14750 
14751 static tree
ffe_truthvalue_conversion(expr)14752 ffe_truthvalue_conversion (expr)
14753      tree expr;
14754 {
14755   if (TREE_CODE (expr) == ERROR_MARK)
14756     return expr;
14757 
14758 #if 0 /* This appears to be wrong for C++.  */
14759   /* These really should return error_mark_node after 2.4 is stable.
14760      But not all callers handle ERROR_MARK properly.  */
14761   switch (TREE_CODE (TREE_TYPE (expr)))
14762     {
14763     case RECORD_TYPE:
14764       error ("struct type value used where scalar is required");
14765       return integer_zero_node;
14766 
14767     case UNION_TYPE:
14768       error ("union type value used where scalar is required");
14769       return integer_zero_node;
14770 
14771     case ARRAY_TYPE:
14772       error ("array type value used where scalar is required");
14773       return integer_zero_node;
14774 
14775     default:
14776       break;
14777     }
14778 #endif /* 0 */
14779 
14780   switch (TREE_CODE (expr))
14781     {
14782       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14783 	 or comparison expressions as truth values at this level.  */
14784 #if 0
14785     case COMPONENT_REF:
14786       /* A one-bit unsigned bit-field is already acceptable.  */
14787       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
14788 	  && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
14789 	return expr;
14790       break;
14791 #endif
14792 
14793     case EQ_EXPR:
14794       /* It is simpler and generates better code to have only TRUTH_*_EXPR
14795 	 or comparison expressions as truth values at this level.  */
14796 #if 0
14797       if (integer_zerop (TREE_OPERAND (expr, 1)))
14798 	return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
14799 #endif
14800     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
14801     case TRUTH_ANDIF_EXPR:
14802     case TRUTH_ORIF_EXPR:
14803     case TRUTH_AND_EXPR:
14804     case TRUTH_OR_EXPR:
14805     case TRUTH_XOR_EXPR:
14806       TREE_TYPE (expr) = integer_type_node;
14807       return expr;
14808 
14809     case ERROR_MARK:
14810       return expr;
14811 
14812     case INTEGER_CST:
14813       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
14814 
14815     case REAL_CST:
14816       return real_zerop (expr) ? integer_zero_node : integer_one_node;
14817 
14818     case ADDR_EXPR:
14819       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
14820 	return build (COMPOUND_EXPR, integer_type_node,
14821 		      TREE_OPERAND (expr, 0), integer_one_node);
14822       else
14823 	return integer_one_node;
14824 
14825     case COMPLEX_EXPR:
14826       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
14827 			? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14828 		       integer_type_node,
14829 		       ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)),
14830 		       ffe_truthvalue_conversion (TREE_OPERAND (expr, 1)));
14831 
14832     case NEGATE_EXPR:
14833     case ABS_EXPR:
14834     case FLOAT_EXPR:
14835     case FFS_EXPR:
14836       /* These don't change whether an object is nonzero or zero.  */
14837       return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14838 
14839     case LROTATE_EXPR:
14840     case RROTATE_EXPR:
14841       /* These don't change whether an object is zero or nonzero, but
14842 	 we can't ignore them if their second arg has side-effects.  */
14843       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
14844 	return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
14845 		      ffe_truthvalue_conversion (TREE_OPERAND (expr, 0)));
14846       else
14847 	return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14848 
14849     case COND_EXPR:
14850       {
14851 	/* Distribute the conversion into the arms of a COND_EXPR.  */
14852 	tree arg1 = TREE_OPERAND (expr, 1);
14853 	tree arg2 = TREE_OPERAND (expr, 2);
14854 	if (! VOID_TYPE_P (TREE_TYPE (arg1)))
14855 	  arg1 = ffe_truthvalue_conversion (arg1);
14856 	if (! VOID_TYPE_P (TREE_TYPE (arg2)))
14857 	  arg2 = ffe_truthvalue_conversion (arg2);
14858 	return fold (build (COND_EXPR, integer_type_node,
14859 			    TREE_OPERAND (expr, 0), arg1, arg2));
14860       }
14861 
14862     case CONVERT_EXPR:
14863       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14864 	 since that affects how `default_conversion' will behave.  */
14865       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
14866 	  || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
14867 	break;
14868       /* fall through... */
14869     case NOP_EXPR:
14870       /* If this is widening the argument, we can ignore it.  */
14871       if (TYPE_PRECISION (TREE_TYPE (expr))
14872 	  >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
14873 	return ffe_truthvalue_conversion (TREE_OPERAND (expr, 0));
14874       break;
14875 
14876     case MINUS_EXPR:
14877       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14878 	 this case.  */
14879       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
14880 	  && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
14881 	break;
14882       /* fall through... */
14883     case BIT_XOR_EXPR:
14884       /* This and MINUS_EXPR can be changed into a comparison of the
14885 	 two objects.  */
14886       if (TREE_TYPE (TREE_OPERAND (expr, 0))
14887 	  == TREE_TYPE (TREE_OPERAND (expr, 1)))
14888 	return ffecom_2 (NE_EXPR, integer_type_node,
14889 			 TREE_OPERAND (expr, 0),
14890 			 TREE_OPERAND (expr, 1));
14891       return ffecom_2 (NE_EXPR, integer_type_node,
14892 		       TREE_OPERAND (expr, 0),
14893 		       fold (build1 (NOP_EXPR,
14894 				     TREE_TYPE (TREE_OPERAND (expr, 0)),
14895 				     TREE_OPERAND (expr, 1))));
14896 
14897     case BIT_AND_EXPR:
14898       if (integer_onep (TREE_OPERAND (expr, 1)))
14899 	return expr;
14900       break;
14901 
14902     case MODIFY_EXPR:
14903 #if 0				/* No such thing in Fortran. */
14904       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
14905 	warning ("suggest parentheses around assignment used as truth value");
14906 #endif
14907       break;
14908 
14909     default:
14910       break;
14911     }
14912 
14913   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
14914     return (ffecom_2
14915 	    ((TREE_SIDE_EFFECTS (expr)
14916 	      ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
14917 	     integer_type_node,
14918 	     ffe_truthvalue_conversion (ffecom_1 (REALPART_EXPR,
14919 						  TREE_TYPE (TREE_TYPE (expr)),
14920 						  expr)),
14921 	     ffe_truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
14922 						  TREE_TYPE (TREE_TYPE (expr)),
14923 						  expr))));
14924 
14925   return ffecom_2 (NE_EXPR, integer_type_node,
14926 		   expr,
14927 		   convert (TREE_TYPE (expr), integer_zero_node));
14928 }
14929 
14930 static tree
ffe_type_for_mode(mode,unsignedp)14931 ffe_type_for_mode (mode, unsignedp)
14932      enum machine_mode mode;
14933      int unsignedp;
14934 {
14935   int i;
14936   int j;
14937   tree t;
14938 
14939   if (mode == TYPE_MODE (integer_type_node))
14940     return unsignedp ? unsigned_type_node : integer_type_node;
14941 
14942   if (mode == TYPE_MODE (signed_char_type_node))
14943     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
14944 
14945   if (mode == TYPE_MODE (short_integer_type_node))
14946     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
14947 
14948   if (mode == TYPE_MODE (long_integer_type_node))
14949     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
14950 
14951   if (mode == TYPE_MODE (long_long_integer_type_node))
14952     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
14953 
14954 #if HOST_BITS_PER_WIDE_INT >= 64
14955   if (mode == TYPE_MODE (intTI_type_node))
14956     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
14957 #endif
14958 
14959   if (mode == TYPE_MODE (float_type_node))
14960     return float_type_node;
14961 
14962   if (mode == TYPE_MODE (double_type_node))
14963     return double_type_node;
14964 
14965   if (mode == TYPE_MODE (long_double_type_node))
14966     return long_double_type_node;
14967 
14968  if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
14969     return build_pointer_type (char_type_node);
14970 
14971   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
14972     return build_pointer_type (integer_type_node);
14973 
14974   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
14975     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
14976       {
14977 	if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
14978 	    && (mode == TYPE_MODE (t)))
14979 	  {
14980 	    if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
14981 	      return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
14982 	    else
14983 	      return t;
14984 	  }
14985       }
14986 
14987   return 0;
14988 }
14989 
14990 static tree
ffe_type_for_size(bits,unsignedp)14991 ffe_type_for_size (bits, unsignedp)
14992      unsigned bits;
14993      int unsignedp;
14994 {
14995   ffeinfoKindtype kt;
14996   tree type_node;
14997 
14998   if (bits == TYPE_PRECISION (integer_type_node))
14999     return unsignedp ? unsigned_type_node : integer_type_node;
15000 
15001   if (bits == TYPE_PRECISION (signed_char_type_node))
15002     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15003 
15004   if (bits == TYPE_PRECISION (short_integer_type_node))
15005     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15006 
15007   if (bits == TYPE_PRECISION (long_integer_type_node))
15008     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15009 
15010   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15011     return (unsignedp ? long_long_unsigned_type_node
15012 	    : long_long_integer_type_node);
15013 
15014   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15015     {
15016       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15017 
15018       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15019 	return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15020 	  : type_node;
15021     }
15022 
15023   return 0;
15024 }
15025 
15026 static tree
ffe_unsigned_type(type)15027 ffe_unsigned_type (type)
15028      tree type;
15029 {
15030   tree type1 = TYPE_MAIN_VARIANT (type);
15031   ffeinfoKindtype kt;
15032   tree type2;
15033 
15034   if (type1 == signed_char_type_node || type1 == char_type_node)
15035     return unsigned_char_type_node;
15036   if (type1 == integer_type_node)
15037     return unsigned_type_node;
15038   if (type1 == short_integer_type_node)
15039     return short_unsigned_type_node;
15040   if (type1 == long_integer_type_node)
15041     return long_unsigned_type_node;
15042   if (type1 == long_long_integer_type_node)
15043     return long_long_unsigned_type_node;
15044 #if 0	/* gcc/c-* files only */
15045   if (type1 == intDI_type_node)
15046     return unsigned_intDI_type_node;
15047   if (type1 == intSI_type_node)
15048     return unsigned_intSI_type_node;
15049   if (type1 == intHI_type_node)
15050     return unsigned_intHI_type_node;
15051   if (type1 == intQI_type_node)
15052     return unsigned_intQI_type_node;
15053 #endif
15054 
15055   type2 = ffe_type_for_size (TYPE_PRECISION (type1), 1);
15056   if (type2 != NULL_TREE)
15057     return type2;
15058 
15059   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15060     {
15061       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15062 
15063       if (type1 == type2)
15064 	return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15065     }
15066 
15067   return type;
15068 }
15069 
15070 /* From gcc/cccp.c, the code to handle -I.  */
15071 
15072 /* Skip leading "./" from a directory name.
15073    This may yield the empty string, which represents the current directory.  */
15074 
15075 static const char *
skip_redundant_dir_prefix(const char * dir)15076 skip_redundant_dir_prefix (const char *dir)
15077 {
15078   while (dir[0] == '.' && dir[1] == '/')
15079     for (dir += 2; *dir == '/'; dir++)
15080       continue;
15081   if (dir[0] == '.' && !dir[1])
15082     dir++;
15083   return dir;
15084 }
15085 
15086 /* The file_name_map structure holds a mapping of file names for a
15087    particular directory.  This mapping is read from the file named
15088    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15089    map filenames on a file system with severe filename restrictions,
15090    such as DOS.  The format of the file name map file is just a series
15091    of lines with two tokens on each line.  The first token is the name
15092    to map, and the second token is the actual name to use.  */
15093 
15094 struct file_name_map
15095 {
15096   struct file_name_map *map_next;
15097   char *map_from;
15098   char *map_to;
15099 };
15100 
15101 #define FILE_NAME_MAP_FILE "header.gcc"
15102 
15103 /* Current maximum length of directory names in the search path
15104    for include files.  (Altered as we get more of them.)  */
15105 
15106 static int max_include_len = 0;
15107 
15108 struct file_name_list
15109   {
15110     struct file_name_list *next;
15111     char *fname;
15112     /* Mapping of file names for this directory.  */
15113     struct file_name_map *name_map;
15114     /* Nonzero if name_map is valid.  */
15115     int got_name_map;
15116   };
15117 
15118 static struct file_name_list *include = NULL;	/* First dir to search */
15119 static struct file_name_list *last_include = NULL;	/* Last in chain */
15120 
15121 /* I/O buffer structure.
15122    The `fname' field is nonzero for source files and #include files
15123    and for the dummy text used for -D and -U.
15124    It is zero for rescanning results of macro expansion
15125    and for expanding macro arguments.  */
15126 #define INPUT_STACK_MAX 400
15127 static struct file_buf {
15128   const char *fname;
15129   /* Filename specified with #line command.  */
15130   const char *nominal_fname;
15131   /* Record where in the search path this file was found.
15132      For #include_next.  */
15133   struct file_name_list *dir;
15134   ffewhereLine line;
15135   ffewhereColumn column;
15136 } instack[INPUT_STACK_MAX];
15137 
15138 static int last_error_tick = 0;	   /* Incremented each time we print it.  */
15139 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15140 
15141 /* Current nesting level of input sources.
15142    `instack[indepth]' is the level currently being read.  */
15143 static int indepth = -1;
15144 
15145 typedef struct file_buf FILE_BUF;
15146 
15147 /* Nonzero means -I- has been seen,
15148    so don't look for #include "foo" the source-file directory.  */
15149 static int ignore_srcdir;
15150 
15151 #ifndef INCLUDE_LEN_FUDGE
15152 #define INCLUDE_LEN_FUDGE 0
15153 #endif
15154 
15155 static void append_include_chain (struct file_name_list *first,
15156 				  struct file_name_list *last);
15157 static FILE *open_include_file (char *filename,
15158 				struct file_name_list *searchptr);
15159 static void print_containing_files (ffebadSeverity sev);
15160 static char *read_filename_string (int ch, FILE *f);
15161 static struct file_name_map *read_name_map (const char *dirname);
15162 
15163 /* Append a chain of `struct file_name_list's
15164    to the end of the main include chain.
15165    FIRST is the beginning of the chain to append, and LAST is the end.  */
15166 
15167 static void
append_include_chain(first,last)15168 append_include_chain (first, last)
15169      struct file_name_list *first, *last;
15170 {
15171   struct file_name_list *dir;
15172 
15173   if (!first || !last)
15174     return;
15175 
15176   if (include == 0)
15177     include = first;
15178   else
15179     last_include->next = first;
15180 
15181   for (dir = first; ; dir = dir->next) {
15182     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15183     if (len > max_include_len)
15184       max_include_len = len;
15185     if (dir == last)
15186       break;
15187   }
15188 
15189   last->next = NULL;
15190   last_include = last;
15191 }
15192 
15193 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15194    being tried from the include file search path.  This function maps
15195    filenames on file systems based on information read by
15196    read_name_map.  */
15197 
15198 static FILE *
open_include_file(filename,searchptr)15199 open_include_file (filename, searchptr)
15200      char *filename;
15201      struct file_name_list *searchptr;
15202 {
15203   register struct file_name_map *map;
15204   register char *from;
15205   char *p, *dir;
15206 
15207   if (searchptr && ! searchptr->got_name_map)
15208     {
15209       searchptr->name_map = read_name_map (searchptr->fname
15210 					   ? searchptr->fname : ".");
15211       searchptr->got_name_map = 1;
15212     }
15213 
15214   /* First check the mapping for the directory we are using.  */
15215   if (searchptr && searchptr->name_map)
15216     {
15217       from = filename;
15218       if (searchptr->fname)
15219 	from += strlen (searchptr->fname) + 1;
15220       for (map = searchptr->name_map; map; map = map->map_next)
15221 	{
15222 	  if (! strcmp (map->map_from, from))
15223 	    {
15224 	      /* Found a match.  */
15225 	      return fopen (map->map_to, "r");
15226 	    }
15227 	}
15228     }
15229 
15230   /* Try to find a mapping file for the particular directory we are
15231      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15232      in /usr/include/header.gcc and look up types.h in
15233      /usr/include/sys/header.gcc.  */
15234   p = strrchr (filename, '/');
15235 #ifdef DIR_SEPARATOR
15236   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15237   else {
15238     char *tmp = strrchr (filename, DIR_SEPARATOR);
15239     if (tmp != NULL && tmp > p) p = tmp;
15240   }
15241 #endif
15242   if (! p)
15243     p = filename;
15244   if (searchptr
15245       && searchptr->fname
15246       && strlen (searchptr->fname) == (size_t) (p - filename)
15247       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15248     {
15249       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15250       return fopen (filename, "r");
15251     }
15252 
15253   if (p == filename)
15254     {
15255       from = filename;
15256       map = read_name_map (".");
15257     }
15258   else
15259     {
15260       dir = (char *) xmalloc (p - filename + 1);
15261       memcpy (dir, filename, p - filename);
15262       dir[p - filename] = '\0';
15263       from = p + 1;
15264       map = read_name_map (dir);
15265       free (dir);
15266     }
15267   for (; map; map = map->map_next)
15268     if (! strcmp (map->map_from, from))
15269       return fopen (map->map_to, "r");
15270 
15271   return fopen (filename, "r");
15272 }
15273 
15274 /* Print the file names and line numbers of the #include
15275    commands which led to the current file.  */
15276 
15277 static void
print_containing_files(ffebadSeverity sev)15278 print_containing_files (ffebadSeverity sev)
15279 {
15280   FILE_BUF *ip = NULL;
15281   int i;
15282   int first = 1;
15283   const char *str1;
15284   const char *str2;
15285 
15286   /* If stack of files hasn't changed since we last printed
15287      this info, don't repeat it.  */
15288   if (last_error_tick == input_file_stack_tick)
15289     return;
15290 
15291   for (i = indepth; i >= 0; i--)
15292     if (instack[i].fname != NULL) {
15293       ip = &instack[i];
15294       break;
15295     }
15296 
15297   /* Give up if we don't find a source file.  */
15298   if (ip == NULL)
15299     return;
15300 
15301   /* Find the other, outer source files.  */
15302   for (i--; i >= 0; i--)
15303     if (instack[i].fname != NULL)
15304       {
15305 	ip = &instack[i];
15306 	if (first)
15307 	  {
15308 	    first = 0;
15309 	    str1 = "In file included";
15310 	  }
15311 	else
15312 	  {
15313 	    str1 = "...          ...";
15314 	  }
15315 
15316 	if (i == 1)
15317 	  str2 = ":";
15318 	else
15319 	  str2 = "";
15320 
15321 	/* xgettext:no-c-format */
15322 	ffebad_start_msg ("%A from %B at %0%C", sev);
15323 	ffebad_here (0, ip->line, ip->column);
15324 	ffebad_string (str1);
15325 	ffebad_string (ip->nominal_fname);
15326 	ffebad_string (str2);
15327 	ffebad_finish ();
15328       }
15329 
15330   /* Record we have printed the status as of this time.  */
15331   last_error_tick = input_file_stack_tick;
15332 }
15333 
15334 /* Read a space delimited string of unlimited length from a stdio
15335    file.  */
15336 
15337 static char *
read_filename_string(ch,f)15338 read_filename_string (ch, f)
15339      int ch;
15340      FILE *f;
15341 {
15342   char *alloc, *set;
15343   int len;
15344 
15345   len = 20;
15346   set = alloc = xmalloc (len + 1);
15347   if (! ISSPACE (ch))
15348     {
15349       *set++ = ch;
15350       while ((ch = getc (f)) != EOF && ! ISSPACE (ch))
15351 	{
15352 	  if (set - alloc == len)
15353 	    {
15354 	      len *= 2;
15355 	      alloc = xrealloc (alloc, len + 1);
15356 	      set = alloc + len / 2;
15357 	    }
15358 	  *set++ = ch;
15359 	}
15360     }
15361   *set = '\0';
15362   ungetc (ch, f);
15363   return alloc;
15364 }
15365 
15366 /* Read the file name map file for DIRNAME.  */
15367 
15368 static struct file_name_map *
read_name_map(dirname)15369 read_name_map (dirname)
15370      const char *dirname;
15371 {
15372   /* This structure holds a linked list of file name maps, one per
15373      directory.  */
15374   struct file_name_map_list
15375     {
15376       struct file_name_map_list *map_list_next;
15377       char *map_list_name;
15378       struct file_name_map *map_list_map;
15379     };
15380   static struct file_name_map_list *map_list;
15381   register struct file_name_map_list *map_list_ptr;
15382   char *name;
15383   FILE *f;
15384   size_t dirlen;
15385   int separator_needed;
15386 
15387   dirname = skip_redundant_dir_prefix (dirname);
15388 
15389   for (map_list_ptr = map_list; map_list_ptr;
15390        map_list_ptr = map_list_ptr->map_list_next)
15391     if (! strcmp (map_list_ptr->map_list_name, dirname))
15392       return map_list_ptr->map_list_map;
15393 
15394   map_list_ptr = ((struct file_name_map_list *)
15395 		  xmalloc (sizeof (struct file_name_map_list)));
15396   map_list_ptr->map_list_name = xstrdup (dirname);
15397   map_list_ptr->map_list_map = NULL;
15398 
15399   dirlen = strlen (dirname);
15400   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15401   if (separator_needed)
15402     name = concat (dirname, "/", FILE_NAME_MAP_FILE, NULL);
15403   else
15404     name = concat (dirname, FILE_NAME_MAP_FILE, NULL);
15405   f = fopen (name, "r");
15406   free (name);
15407   if (!f)
15408     map_list_ptr->map_list_map = NULL;
15409   else
15410     {
15411       int ch;
15412 
15413       while ((ch = getc (f)) != EOF)
15414 	{
15415 	  char *from, *to;
15416 	  struct file_name_map *ptr;
15417 
15418 	  if (ISSPACE (ch))
15419 	    continue;
15420 	  from = read_filename_string (ch, f);
15421 	  while ((ch = getc (f)) != EOF && ISSPACE (ch) && ch != '\n')
15422 	    ;
15423 	  to = read_filename_string (ch, f);
15424 
15425 	  ptr = ((struct file_name_map *)
15426 		 xmalloc (sizeof (struct file_name_map)));
15427 	  ptr->map_from = from;
15428 
15429 	  /* Make the real filename absolute.  */
15430 	  if (*to == '/')
15431 	    ptr->map_to = to;
15432 	  else
15433 	    {
15434 	      if (separator_needed)
15435 		ptr->map_to = concat (dirname, "/", to, NULL);
15436 	      else
15437 		ptr->map_to = concat (dirname, to, NULL);
15438 	      free (to);
15439 	    }
15440 
15441 	  ptr->map_next = map_list_ptr->map_list_map;
15442 	  map_list_ptr->map_list_map = ptr;
15443 
15444 	  while ((ch = getc (f)) != '\n')
15445 	    if (ch == EOF)
15446 	      break;
15447 	}
15448       fclose (f);
15449     }
15450 
15451   map_list_ptr->map_list_next = map_list;
15452   map_list = map_list_ptr;
15453 
15454   return map_list_ptr->map_list_map;
15455 }
15456 
15457 static void
ffecom_file_(const char * name)15458 ffecom_file_ (const char *name)
15459 {
15460   FILE_BUF *fp;
15461 
15462   /* Do partial setup of input buffer for the sake of generating
15463      early #line directives (when -g is in effect).  */
15464 
15465   fp = &instack[++indepth];
15466   memset ((char *) fp, 0, sizeof (FILE_BUF));
15467   if (name == NULL)
15468     name = "";
15469   fp->nominal_fname = fp->fname = name;
15470 }
15471 
15472 static void
ffecom_close_include_(FILE * f)15473 ffecom_close_include_ (FILE *f)
15474 {
15475   fclose (f);
15476 
15477   indepth--;
15478   input_file_stack_tick++;
15479 
15480   ffewhere_line_kill (instack[indepth].line);
15481   ffewhere_column_kill (instack[indepth].column);
15482 }
15483 
15484 static int
ffecom_decode_include_option_(char * spec)15485 ffecom_decode_include_option_ (char *spec)
15486 {
15487   struct file_name_list *dirtmp;
15488 
15489   if (! ignore_srcdir && !strcmp (spec, "-"))
15490     ignore_srcdir = 1;
15491   else
15492     {
15493       dirtmp = (struct file_name_list *)
15494 	xmalloc (sizeof (struct file_name_list));
15495       dirtmp->next = 0;		/* New one goes on the end */
15496       dirtmp->fname = spec;
15497       dirtmp->got_name_map = 0;
15498       if (spec[0] == 0)
15499 	error ("directory name must immediately follow -I");
15500       else
15501 	append_include_chain (dirtmp, dirtmp);
15502     }
15503   return 1;
15504 }
15505 
15506 /* Open INCLUDEd file.  */
15507 
15508 static FILE *
ffecom_open_include_(char * name,ffewhereLine l,ffewhereColumn c)15509 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
15510 {
15511   char *fbeg = name;
15512   size_t flen = strlen (fbeg);
15513   struct file_name_list *search_start = include; /* Chain of dirs to search */
15514   struct file_name_list dsp[1];	/* First in chain, if #include "..." */
15515   struct file_name_list *searchptr = 0;
15516   char *fname;		/* Dynamically allocated fname buffer */
15517   FILE *f;
15518   FILE_BUF *fp;
15519 
15520   if (flen == 0)
15521     return NULL;
15522 
15523   dsp[0].fname = NULL;
15524 
15525   /* If -I- was specified, don't search current dir, only spec'd ones. */
15526   if (!ignore_srcdir)
15527     {
15528       for (fp = &instack[indepth]; fp >= instack; fp--)
15529 	{
15530 	  int n;
15531 	  char *ep;
15532 	  const char *nam;
15533 
15534 	  if ((nam = fp->nominal_fname) != NULL)
15535 	    {
15536 	      /* Found a named file.  Figure out dir of the file,
15537 		 and put it in front of the search list.  */
15538 	      dsp[0].next = search_start;
15539 	      search_start = dsp;
15540 #ifndef VMS
15541 	      ep = strrchr (nam, '/');
15542 #ifdef DIR_SEPARATOR
15543 	    if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
15544 	    else {
15545 	      char *tmp = strrchr (nam, DIR_SEPARATOR);
15546 	      if (tmp != NULL && tmp > ep) ep = tmp;
15547 	    }
15548 #endif
15549 #else				/* VMS */
15550 	      ep = strrchr (nam, ']');
15551 	      if (ep == NULL) ep = strrchr (nam, '>');
15552 	      if (ep == NULL) ep = strrchr (nam, ':');
15553 	      if (ep != NULL) ep++;
15554 #endif				/* VMS */
15555 	      if (ep != NULL)
15556 		{
15557 		  n = ep - nam;
15558 		  dsp[0].fname = (char *) xmalloc (n + 1);
15559 		  strncpy (dsp[0].fname, nam, n);
15560 		  dsp[0].fname[n] = '\0';
15561 		  if (n + INCLUDE_LEN_FUDGE > max_include_len)
15562 		    max_include_len = n + INCLUDE_LEN_FUDGE;
15563 		}
15564 	      else
15565 		dsp[0].fname = NULL; /* Current directory */
15566 	      dsp[0].got_name_map = 0;
15567 	      break;
15568 	    }
15569 	}
15570     }
15571 
15572   /* Allocate this permanently, because it gets stored in the definitions
15573      of macros.  */
15574   fname = xmalloc (max_include_len + flen + 4);
15575   /* + 2 above for slash and terminating null.  */
15576   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15577      for g77 yet).  */
15578 
15579   /* If specified file name is absolute, just open it.  */
15580 
15581   if (*fbeg == '/'
15582 #ifdef DIR_SEPARATOR
15583       || *fbeg == DIR_SEPARATOR
15584 #endif
15585       )
15586     {
15587       strncpy (fname, (char *) fbeg, flen);
15588       fname[flen] = 0;
15589       f = open_include_file (fname, NULL);
15590     }
15591   else
15592     {
15593       f = NULL;
15594 
15595       /* Search directory path, trying to open the file.
15596 	 Copy each filename tried into FNAME.  */
15597 
15598       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
15599 	{
15600 	  if (searchptr->fname)
15601 	    {
15602 	      /* The empty string in a search path is ignored.
15603 		 This makes it possible to turn off entirely
15604 		 a standard piece of the list.  */
15605 	      if (searchptr->fname[0] == 0)
15606 		continue;
15607 	      strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
15608 	      if (fname[0] && fname[strlen (fname) - 1] != '/')
15609 		strcat (fname, "/");
15610 	      fname[strlen (fname) + flen] = 0;
15611 	    }
15612 	  else
15613 	    fname[0] = 0;
15614 
15615 	  strncat (fname, fbeg, flen);
15616 #ifdef VMS
15617 	  /* Change this 1/2 Unix 1/2 VMS file specification into a
15618 	     full VMS file specification */
15619 	  if (searchptr->fname && (searchptr->fname[0] != 0))
15620 	    {
15621 	      /* Fix up the filename */
15622 	      hack_vms_include_specification (fname);
15623 	    }
15624 	  else
15625 	    {
15626 	      /* This is a normal VMS filespec, so use it unchanged.  */
15627 	      strncpy (fname, (char *) fbeg, flen);
15628 	      fname[flen] = 0;
15629 #if 0	/* Not for g77.  */
15630 	      /* if it's '#include filename', add the missing .h */
15631 	      if (strchr (fname, '.') == NULL)
15632 		strcat (fname, ".h");
15633 #endif
15634 	    }
15635 #endif /* VMS */
15636 	  f = open_include_file (fname, searchptr);
15637 #ifdef EACCES
15638 	  if (f == NULL && errno == EACCES)
15639 	    {
15640 	      print_containing_files (FFEBAD_severityWARNING);
15641 	      /* xgettext:no-c-format */
15642 	      ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15643 				FFEBAD_severityWARNING);
15644 	      ffebad_string (fname);
15645 	      ffebad_here (0, l, c);
15646 	      ffebad_finish ();
15647 	    }
15648 #endif
15649 	  if (f != NULL)
15650 	    break;
15651 	}
15652     }
15653 
15654   if (f == NULL)
15655     {
15656       /* A file that was not found.  */
15657 
15658       strncpy (fname, (char *) fbeg, flen);
15659       fname[flen] = 0;
15660       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
15661       ffebad_start (FFEBAD_OPEN_INCLUDE);
15662       ffebad_here (0, l, c);
15663       ffebad_string (fname);
15664       ffebad_finish ();
15665     }
15666 
15667   if (dsp[0].fname != NULL)
15668     free (dsp[0].fname);
15669 
15670   if (f == NULL)
15671     return NULL;
15672 
15673   if (indepth >= (INPUT_STACK_MAX - 1))
15674     {
15675       print_containing_files (FFEBAD_severityFATAL);
15676       /* xgettext:no-c-format */
15677       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15678 			FFEBAD_severityFATAL);
15679       ffebad_string (fname);
15680       ffebad_here (0, l, c);
15681       ffebad_finish ();
15682       return NULL;
15683     }
15684 
15685   instack[indepth].line = ffewhere_line_use (l);
15686   instack[indepth].column = ffewhere_column_use (c);
15687 
15688   fp = &instack[indepth + 1];
15689   memset ((char *) fp, 0, sizeof (FILE_BUF));
15690   fp->nominal_fname = fp->fname = fname;
15691   fp->dir = searchptr;
15692 
15693   indepth++;
15694   input_file_stack_tick++;
15695 
15696   return f;
15697 }
15698 
15699 /**INDENT* (Do not reformat this comment even with -fca option.)
15700    Data-gathering files: Given the source file listed below, compiled with
15701    f2c I obtained the output file listed after that, and from the output
15702    file I derived the above code.
15703 
15704 -------- (begin input file to f2c)
15705 	implicit none
15706 	character*10 A1,A2
15707 	complex C1,C2
15708 	integer I1,I2
15709 	real R1,R2
15710 	double precision D1,D2
15711 C
15712 	call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15713 c /
15714 	call fooI(I1/I2)
15715 	call fooR(R1/I1)
15716 	call fooD(D1/I1)
15717 	call fooC(C1/I1)
15718 	call fooR(R1/R2)
15719 	call fooD(R1/D1)
15720 	call fooD(D1/D2)
15721 	call fooD(D1/R1)
15722 	call fooC(C1/C2)
15723 	call fooC(C1/R1)
15724 	call fooZ(C1/D1)
15725 c **
15726 	call fooI(I1**I2)
15727 	call fooR(R1**I1)
15728 	call fooD(D1**I1)
15729 	call fooC(C1**I1)
15730 	call fooR(R1**R2)
15731 	call fooD(R1**D1)
15732 	call fooD(D1**D2)
15733 	call fooD(D1**R1)
15734 	call fooC(C1**C2)
15735 	call fooC(C1**R1)
15736 	call fooZ(C1**D1)
15737 c FFEINTRIN_impABS
15738 	call fooR(ABS(R1))
15739 c FFEINTRIN_impACOS
15740 	call fooR(ACOS(R1))
15741 c FFEINTRIN_impAIMAG
15742 	call fooR(AIMAG(C1))
15743 c FFEINTRIN_impAINT
15744 	call fooR(AINT(R1))
15745 c FFEINTRIN_impALOG
15746 	call fooR(ALOG(R1))
15747 c FFEINTRIN_impALOG10
15748 	call fooR(ALOG10(R1))
15749 c FFEINTRIN_impAMAX0
15750 	call fooR(AMAX0(I1,I2))
15751 c FFEINTRIN_impAMAX1
15752 	call fooR(AMAX1(R1,R2))
15753 c FFEINTRIN_impAMIN0
15754 	call fooR(AMIN0(I1,I2))
15755 c FFEINTRIN_impAMIN1
15756 	call fooR(AMIN1(R1,R2))
15757 c FFEINTRIN_impAMOD
15758 	call fooR(AMOD(R1,R2))
15759 c FFEINTRIN_impANINT
15760 	call fooR(ANINT(R1))
15761 c FFEINTRIN_impASIN
15762 	call fooR(ASIN(R1))
15763 c FFEINTRIN_impATAN
15764 	call fooR(ATAN(R1))
15765 c FFEINTRIN_impATAN2
15766 	call fooR(ATAN2(R1,R2))
15767 c FFEINTRIN_impCABS
15768 	call fooR(CABS(C1))
15769 c FFEINTRIN_impCCOS
15770 	call fooC(CCOS(C1))
15771 c FFEINTRIN_impCEXP
15772 	call fooC(CEXP(C1))
15773 c FFEINTRIN_impCHAR
15774 	call fooA(CHAR(I1))
15775 c FFEINTRIN_impCLOG
15776 	call fooC(CLOG(C1))
15777 c FFEINTRIN_impCONJG
15778 	call fooC(CONJG(C1))
15779 c FFEINTRIN_impCOS
15780 	call fooR(COS(R1))
15781 c FFEINTRIN_impCOSH
15782 	call fooR(COSH(R1))
15783 c FFEINTRIN_impCSIN
15784 	call fooC(CSIN(C1))
15785 c FFEINTRIN_impCSQRT
15786 	call fooC(CSQRT(C1))
15787 c FFEINTRIN_impDABS
15788 	call fooD(DABS(D1))
15789 c FFEINTRIN_impDACOS
15790 	call fooD(DACOS(D1))
15791 c FFEINTRIN_impDASIN
15792 	call fooD(DASIN(D1))
15793 c FFEINTRIN_impDATAN
15794 	call fooD(DATAN(D1))
15795 c FFEINTRIN_impDATAN2
15796 	call fooD(DATAN2(D1,D2))
15797 c FFEINTRIN_impDCOS
15798 	call fooD(DCOS(D1))
15799 c FFEINTRIN_impDCOSH
15800 	call fooD(DCOSH(D1))
15801 c FFEINTRIN_impDDIM
15802 	call fooD(DDIM(D1,D2))
15803 c FFEINTRIN_impDEXP
15804 	call fooD(DEXP(D1))
15805 c FFEINTRIN_impDIM
15806 	call fooR(DIM(R1,R2))
15807 c FFEINTRIN_impDINT
15808 	call fooD(DINT(D1))
15809 c FFEINTRIN_impDLOG
15810 	call fooD(DLOG(D1))
15811 c FFEINTRIN_impDLOG10
15812 	call fooD(DLOG10(D1))
15813 c FFEINTRIN_impDMAX1
15814 	call fooD(DMAX1(D1,D2))
15815 c FFEINTRIN_impDMIN1
15816 	call fooD(DMIN1(D1,D2))
15817 c FFEINTRIN_impDMOD
15818 	call fooD(DMOD(D1,D2))
15819 c FFEINTRIN_impDNINT
15820 	call fooD(DNINT(D1))
15821 c FFEINTRIN_impDPROD
15822 	call fooD(DPROD(R1,R2))
15823 c FFEINTRIN_impDSIGN
15824 	call fooD(DSIGN(D1,D2))
15825 c FFEINTRIN_impDSIN
15826 	call fooD(DSIN(D1))
15827 c FFEINTRIN_impDSINH
15828 	call fooD(DSINH(D1))
15829 c FFEINTRIN_impDSQRT
15830 	call fooD(DSQRT(D1))
15831 c FFEINTRIN_impDTAN
15832 	call fooD(DTAN(D1))
15833 c FFEINTRIN_impDTANH
15834 	call fooD(DTANH(D1))
15835 c FFEINTRIN_impEXP
15836 	call fooR(EXP(R1))
15837 c FFEINTRIN_impIABS
15838 	call fooI(IABS(I1))
15839 c FFEINTRIN_impICHAR
15840 	call fooI(ICHAR(A1))
15841 c FFEINTRIN_impIDIM
15842 	call fooI(IDIM(I1,I2))
15843 c FFEINTRIN_impIDNINT
15844 	call fooI(IDNINT(D1))
15845 c FFEINTRIN_impINDEX
15846 	call fooI(INDEX(A1,A2))
15847 c FFEINTRIN_impISIGN
15848 	call fooI(ISIGN(I1,I2))
15849 c FFEINTRIN_impLEN
15850 	call fooI(LEN(A1))
15851 c FFEINTRIN_impLGE
15852 	call fooL(LGE(A1,A2))
15853 c FFEINTRIN_impLGT
15854 	call fooL(LGT(A1,A2))
15855 c FFEINTRIN_impLLE
15856 	call fooL(LLE(A1,A2))
15857 c FFEINTRIN_impLLT
15858 	call fooL(LLT(A1,A2))
15859 c FFEINTRIN_impMAX0
15860 	call fooI(MAX0(I1,I2))
15861 c FFEINTRIN_impMAX1
15862 	call fooI(MAX1(R1,R2))
15863 c FFEINTRIN_impMIN0
15864 	call fooI(MIN0(I1,I2))
15865 c FFEINTRIN_impMIN1
15866 	call fooI(MIN1(R1,R2))
15867 c FFEINTRIN_impMOD
15868 	call fooI(MOD(I1,I2))
15869 c FFEINTRIN_impNINT
15870 	call fooI(NINT(R1))
15871 c FFEINTRIN_impSIGN
15872 	call fooR(SIGN(R1,R2))
15873 c FFEINTRIN_impSIN
15874 	call fooR(SIN(R1))
15875 c FFEINTRIN_impSINH
15876 	call fooR(SINH(R1))
15877 c FFEINTRIN_impSQRT
15878 	call fooR(SQRT(R1))
15879 c FFEINTRIN_impTAN
15880 	call fooR(TAN(R1))
15881 c FFEINTRIN_impTANH
15882 	call fooR(TANH(R1))
15883 c FFEINTRIN_imp_CMPLX_C
15884 	call fooC(cmplx(C1,C2))
15885 c FFEINTRIN_imp_CMPLX_D
15886 	call fooZ(cmplx(D1,D2))
15887 c FFEINTRIN_imp_CMPLX_I
15888 	call fooC(cmplx(I1,I2))
15889 c FFEINTRIN_imp_CMPLX_R
15890 	call fooC(cmplx(R1,R2))
15891 c FFEINTRIN_imp_DBLE_C
15892 	call fooD(dble(C1))
15893 c FFEINTRIN_imp_DBLE_D
15894 	call fooD(dble(D1))
15895 c FFEINTRIN_imp_DBLE_I
15896 	call fooD(dble(I1))
15897 c FFEINTRIN_imp_DBLE_R
15898 	call fooD(dble(R1))
15899 c FFEINTRIN_imp_INT_C
15900 	call fooI(int(C1))
15901 c FFEINTRIN_imp_INT_D
15902 	call fooI(int(D1))
15903 c FFEINTRIN_imp_INT_I
15904 	call fooI(int(I1))
15905 c FFEINTRIN_imp_INT_R
15906 	call fooI(int(R1))
15907 c FFEINTRIN_imp_REAL_C
15908 	call fooR(real(C1))
15909 c FFEINTRIN_imp_REAL_D
15910 	call fooR(real(D1))
15911 c FFEINTRIN_imp_REAL_I
15912 	call fooR(real(I1))
15913 c FFEINTRIN_imp_REAL_R
15914 	call fooR(real(R1))
15915 c
15916 c FFEINTRIN_imp_INT_D:
15917 c
15918 c FFEINTRIN_specIDINT
15919 	call fooI(IDINT(D1))
15920 c
15921 c FFEINTRIN_imp_INT_R:
15922 c
15923 c FFEINTRIN_specIFIX
15924 	call fooI(IFIX(R1))
15925 c FFEINTRIN_specINT
15926 	call fooI(INT(R1))
15927 c
15928 c FFEINTRIN_imp_REAL_D:
15929 c
15930 c FFEINTRIN_specSNGL
15931 	call fooR(SNGL(D1))
15932 c
15933 c FFEINTRIN_imp_REAL_I:
15934 c
15935 c FFEINTRIN_specFLOAT
15936 	call fooR(FLOAT(I1))
15937 c FFEINTRIN_specREAL
15938 	call fooR(REAL(I1))
15939 c
15940 	end
15941 -------- (end input file to f2c)
15942 
15943 -------- (begin output from providing above input file as input to:
15944 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
15945 --------     -e "s:^#.*$::g"')
15946 
15947 //  -- translated by f2c (version 19950223).
15948    You must link the resulting object file with the libraries:
15949         -lf2c -lm   (in that order)
15950 //
15951 
15952 
15953 // f2c.h  --  Standard Fortran to C header file //
15954 
15955 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
15956 
15957         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
15958 
15959 
15960 
15961 
15962 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
15963 // we assume short, float are OK //
15964 typedef long int // long int // integer;
15965 typedef char *address;
15966 typedef short int shortint;
15967 typedef float real;
15968 typedef double doublereal;
15969 typedef struct { real r, i; } complex;
15970 typedef struct { doublereal r, i; } doublecomplex;
15971 typedef long int // long int // logical;
15972 typedef short int shortlogical;
15973 typedef char logical1;
15974 typedef char integer1;
15975 // typedef long long longint; // // system-dependent //
15976 
15977 
15978 
15979 
15980 // Extern is for use with -E //
15981 
15982 
15983 
15984 
15985 // I/O stuff //
15986 
15987 
15988 
15989 
15990 
15991 
15992 
15993 
15994 typedef long int // int or long int // flag;
15995 typedef long int // int or long int // ftnlen;
15996 typedef long int // int or long int // ftnint;
15997 
15998 
15999 //external read, write//
16000 typedef struct
16001 {       flag cierr;
16002         ftnint ciunit;
16003         flag ciend;
16004         char *cifmt;
16005         ftnint cirec;
16006 } cilist;
16007 
16008 //internal read, write//
16009 typedef struct
16010 {       flag icierr;
16011         char *iciunit;
16012         flag iciend;
16013         char *icifmt;
16014         ftnint icirlen;
16015         ftnint icirnum;
16016 } icilist;
16017 
16018 //open//
16019 typedef struct
16020 {       flag oerr;
16021         ftnint ounit;
16022         char *ofnm;
16023         ftnlen ofnmlen;
16024         char *osta;
16025         char *oacc;
16026         char *ofm;
16027         ftnint orl;
16028         char *oblnk;
16029 } olist;
16030 
16031 //close//
16032 typedef struct
16033 {       flag cerr;
16034         ftnint cunit;
16035         char *csta;
16036 } cllist;
16037 
16038 //rewind, backspace, endfile//
16039 typedef struct
16040 {       flag aerr;
16041         ftnint aunit;
16042 } alist;
16043 
16044 // inquire //
16045 typedef struct
16046 {       flag inerr;
16047         ftnint inunit;
16048         char *infile;
16049         ftnlen infilen;
16050         ftnint  *inex;  //parameters in standard's order//
16051         ftnint  *inopen;
16052         ftnint  *innum;
16053         ftnint  *innamed;
16054         char    *inname;
16055         ftnlen  innamlen;
16056         char    *inacc;
16057         ftnlen  inacclen;
16058         char    *inseq;
16059         ftnlen  inseqlen;
16060         char    *indir;
16061         ftnlen  indirlen;
16062         char    *infmt;
16063         ftnlen  infmtlen;
16064         char    *inform;
16065         ftnint  informlen;
16066         char    *inunf;
16067         ftnlen  inunflen;
16068         ftnint  *inrecl;
16069         ftnint  *innrec;
16070         char    *inblank;
16071         ftnlen  inblanklen;
16072 } inlist;
16073 
16074 
16075 
16076 union Multitype {       // for multiple entry points //
16077         integer1 g;
16078         shortint h;
16079         integer i;
16080         // longint j; //
16081         real r;
16082         doublereal d;
16083         complex c;
16084         doublecomplex z;
16085         };
16086 
16087 typedef union Multitype Multitype;
16088 
16089 typedef long Long;      // No longer used; formerly in Namelist //
16090 
16091 struct Vardesc {        // for Namelist //
16092         char *name;
16093         char *addr;
16094         ftnlen *dims;
16095         int  type;
16096         };
16097 typedef struct Vardesc Vardesc;
16098 
16099 struct Namelist {
16100         char *name;
16101         Vardesc **vars;
16102         int nvars;
16103         };
16104 typedef struct Namelist Namelist;
16105 
16106 
16107 
16108 
16109 
16110 
16111 
16112 
16113 // procedure parameter types for -A and -C++ //
16114 
16115 
16116 
16117 
16118 typedef int // Unknown procedure type // (*U_fp)();
16119 typedef shortint (*J_fp)();
16120 typedef integer (*I_fp)();
16121 typedef real (*R_fp)();
16122 typedef doublereal (*D_fp)(), (*E_fp)();
16123 typedef // Complex // void  (*C_fp)();
16124 typedef // Double Complex // void  (*Z_fp)();
16125 typedef logical (*L_fp)();
16126 typedef shortlogical (*K_fp)();
16127 typedef // Character // void  (*H_fp)();
16128 typedef // Subroutine // int (*S_fp)();
16129 
16130 // E_fp is for real functions when -R is not specified //
16131 typedef void  C_f;      // complex function //
16132 typedef void  H_f;      // character function //
16133 typedef void  Z_f;      // double complex function //
16134 typedef doublereal E_f; // real function with -R not specified //
16135 
16136 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16137 
16138 
16139 // (No such symbols should be defined in a strict ANSI C compiler.
16140    We can avoid trouble with f2c-translated code by using
16141    gcc -ansi.) //
16142 
16143 
16144 
16145 
16146 
16147 
16148 
16149 
16150 
16151 
16152 
16153 
16154 
16155 
16156 
16157 
16158 
16159 
16160 
16161 
16162 
16163 
16164 
16165 // Main program // MAIN__()
16166 {
16167     // System generated locals //
16168     integer i__1;
16169     real r__1, r__2;
16170     doublereal d__1, d__2;
16171     complex q__1;
16172     doublecomplex z__1, z__2, z__3;
16173     logical L__1;
16174     char ch__1[1];
16175 
16176     // Builtin functions //
16177     void c_div();
16178     integer pow_ii();
16179     double pow_ri(), pow_di();
16180     void pow_ci();
16181     double pow_dd();
16182     void pow_zz();
16183     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16184             asin(), atan(), atan2(), c_abs();
16185     void c_cos(), c_exp(), c_log(), r_cnjg();
16186     double cos(), cosh();
16187     void c_sin(), c_sqrt();
16188     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16189             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16190     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16191     logical l_ge(), l_gt(), l_le(), l_lt();
16192     integer i_nint();
16193     double r_sign();
16194 
16195     // Local variables //
16196     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16197             fool_(), fooz_(), getem_();
16198     static char a1[10], a2[10];
16199     static complex c1, c2;
16200     static doublereal d1, d2;
16201     static integer i1, i2;
16202     static real r1, r2;
16203 
16204 
16205     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16206 // / //
16207     i__1 = i1 / i2;
16208     fooi_(&i__1);
16209     r__1 = r1 / i1;
16210     foor_(&r__1);
16211     d__1 = d1 / i1;
16212     food_(&d__1);
16213     d__1 = (doublereal) i1;
16214     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16215     fooc_(&q__1);
16216     r__1 = r1 / r2;
16217     foor_(&r__1);
16218     d__1 = r1 / d1;
16219     food_(&d__1);
16220     d__1 = d1 / d2;
16221     food_(&d__1);
16222     d__1 = d1 / r1;
16223     food_(&d__1);
16224     c_div(&q__1, &c1, &c2);
16225     fooc_(&q__1);
16226     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16227     fooc_(&q__1);
16228     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16229     fooz_(&z__1);
16230 // ** //
16231     i__1 = pow_ii(&i1, &i2);
16232     fooi_(&i__1);
16233     r__1 = pow_ri(&r1, &i1);
16234     foor_(&r__1);
16235     d__1 = pow_di(&d1, &i1);
16236     food_(&d__1);
16237     pow_ci(&q__1, &c1, &i1);
16238     fooc_(&q__1);
16239     d__1 = (doublereal) r1;
16240     d__2 = (doublereal) r2;
16241     r__1 = pow_dd(&d__1, &d__2);
16242     foor_(&r__1);
16243     d__2 = (doublereal) r1;
16244     d__1 = pow_dd(&d__2, &d1);
16245     food_(&d__1);
16246     d__1 = pow_dd(&d1, &d2);
16247     food_(&d__1);
16248     d__2 = (doublereal) r1;
16249     d__1 = pow_dd(&d1, &d__2);
16250     food_(&d__1);
16251     z__2.r = c1.r, z__2.i = c1.i;
16252     z__3.r = c2.r, z__3.i = c2.i;
16253     pow_zz(&z__1, &z__2, &z__3);
16254     q__1.r = z__1.r, q__1.i = z__1.i;
16255     fooc_(&q__1);
16256     z__2.r = c1.r, z__2.i = c1.i;
16257     z__3.r = r1, z__3.i = 0.;
16258     pow_zz(&z__1, &z__2, &z__3);
16259     q__1.r = z__1.r, q__1.i = z__1.i;
16260     fooc_(&q__1);
16261     z__2.r = c1.r, z__2.i = c1.i;
16262     z__3.r = d1, z__3.i = 0.;
16263     pow_zz(&z__1, &z__2, &z__3);
16264     fooz_(&z__1);
16265 // FFEINTRIN_impABS //
16266     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16267     foor_(&r__1);
16268 // FFEINTRIN_impACOS //
16269     r__1 = acos(r1);
16270     foor_(&r__1);
16271 // FFEINTRIN_impAIMAG //
16272     r__1 = r_imag(&c1);
16273     foor_(&r__1);
16274 // FFEINTRIN_impAINT //
16275     r__1 = r_int(&r1);
16276     foor_(&r__1);
16277 // FFEINTRIN_impALOG //
16278     r__1 = log(r1);
16279     foor_(&r__1);
16280 // FFEINTRIN_impALOG10 //
16281     r__1 = r_lg10(&r1);
16282     foor_(&r__1);
16283 // FFEINTRIN_impAMAX0 //
16284     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16285     foor_(&r__1);
16286 // FFEINTRIN_impAMAX1 //
16287     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16288     foor_(&r__1);
16289 // FFEINTRIN_impAMIN0 //
16290     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16291     foor_(&r__1);
16292 // FFEINTRIN_impAMIN1 //
16293     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16294     foor_(&r__1);
16295 // FFEINTRIN_impAMOD //
16296     r__1 = r_mod(&r1, &r2);
16297     foor_(&r__1);
16298 // FFEINTRIN_impANINT //
16299     r__1 = r_nint(&r1);
16300     foor_(&r__1);
16301 // FFEINTRIN_impASIN //
16302     r__1 = asin(r1);
16303     foor_(&r__1);
16304 // FFEINTRIN_impATAN //
16305     r__1 = atan(r1);
16306     foor_(&r__1);
16307 // FFEINTRIN_impATAN2 //
16308     r__1 = atan2(r1, r2);
16309     foor_(&r__1);
16310 // FFEINTRIN_impCABS //
16311     r__1 = c_abs(&c1);
16312     foor_(&r__1);
16313 // FFEINTRIN_impCCOS //
16314     c_cos(&q__1, &c1);
16315     fooc_(&q__1);
16316 // FFEINTRIN_impCEXP //
16317     c_exp(&q__1, &c1);
16318     fooc_(&q__1);
16319 // FFEINTRIN_impCHAR //
16320     *(unsigned char *)&ch__1[0] = i1;
16321     fooa_(ch__1, 1L);
16322 // FFEINTRIN_impCLOG //
16323     c_log(&q__1, &c1);
16324     fooc_(&q__1);
16325 // FFEINTRIN_impCONJG //
16326     r_cnjg(&q__1, &c1);
16327     fooc_(&q__1);
16328 // FFEINTRIN_impCOS //
16329     r__1 = cos(r1);
16330     foor_(&r__1);
16331 // FFEINTRIN_impCOSH //
16332     r__1 = cosh(r1);
16333     foor_(&r__1);
16334 // FFEINTRIN_impCSIN //
16335     c_sin(&q__1, &c1);
16336     fooc_(&q__1);
16337 // FFEINTRIN_impCSQRT //
16338     c_sqrt(&q__1, &c1);
16339     fooc_(&q__1);
16340 // FFEINTRIN_impDABS //
16341     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16342     food_(&d__1);
16343 // FFEINTRIN_impDACOS //
16344     d__1 = acos(d1);
16345     food_(&d__1);
16346 // FFEINTRIN_impDASIN //
16347     d__1 = asin(d1);
16348     food_(&d__1);
16349 // FFEINTRIN_impDATAN //
16350     d__1 = atan(d1);
16351     food_(&d__1);
16352 // FFEINTRIN_impDATAN2 //
16353     d__1 = atan2(d1, d2);
16354     food_(&d__1);
16355 // FFEINTRIN_impDCOS //
16356     d__1 = cos(d1);
16357     food_(&d__1);
16358 // FFEINTRIN_impDCOSH //
16359     d__1 = cosh(d1);
16360     food_(&d__1);
16361 // FFEINTRIN_impDDIM //
16362     d__1 = d_dim(&d1, &d2);
16363     food_(&d__1);
16364 // FFEINTRIN_impDEXP //
16365     d__1 = exp(d1);
16366     food_(&d__1);
16367 // FFEINTRIN_impDIM //
16368     r__1 = r_dim(&r1, &r2);
16369     foor_(&r__1);
16370 // FFEINTRIN_impDINT //
16371     d__1 = d_int(&d1);
16372     food_(&d__1);
16373 // FFEINTRIN_impDLOG //
16374     d__1 = log(d1);
16375     food_(&d__1);
16376 // FFEINTRIN_impDLOG10 //
16377     d__1 = d_lg10(&d1);
16378     food_(&d__1);
16379 // FFEINTRIN_impDMAX1 //
16380     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16381     food_(&d__1);
16382 // FFEINTRIN_impDMIN1 //
16383     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16384     food_(&d__1);
16385 // FFEINTRIN_impDMOD //
16386     d__1 = d_mod(&d1, &d2);
16387     food_(&d__1);
16388 // FFEINTRIN_impDNINT //
16389     d__1 = d_nint(&d1);
16390     food_(&d__1);
16391 // FFEINTRIN_impDPROD //
16392     d__1 = (doublereal) r1 * r2;
16393     food_(&d__1);
16394 // FFEINTRIN_impDSIGN //
16395     d__1 = d_sign(&d1, &d2);
16396     food_(&d__1);
16397 // FFEINTRIN_impDSIN //
16398     d__1 = sin(d1);
16399     food_(&d__1);
16400 // FFEINTRIN_impDSINH //
16401     d__1 = sinh(d1);
16402     food_(&d__1);
16403 // FFEINTRIN_impDSQRT //
16404     d__1 = sqrt(d1);
16405     food_(&d__1);
16406 // FFEINTRIN_impDTAN //
16407     d__1 = tan(d1);
16408     food_(&d__1);
16409 // FFEINTRIN_impDTANH //
16410     d__1 = tanh(d1);
16411     food_(&d__1);
16412 // FFEINTRIN_impEXP //
16413     r__1 = exp(r1);
16414     foor_(&r__1);
16415 // FFEINTRIN_impIABS //
16416     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16417     fooi_(&i__1);
16418 // FFEINTRIN_impICHAR //
16419     i__1 = *(unsigned char *)a1;
16420     fooi_(&i__1);
16421 // FFEINTRIN_impIDIM //
16422     i__1 = i_dim(&i1, &i2);
16423     fooi_(&i__1);
16424 // FFEINTRIN_impIDNINT //
16425     i__1 = i_dnnt(&d1);
16426     fooi_(&i__1);
16427 // FFEINTRIN_impINDEX //
16428     i__1 = i_indx(a1, a2, 10L, 10L);
16429     fooi_(&i__1);
16430 // FFEINTRIN_impISIGN //
16431     i__1 = i_sign(&i1, &i2);
16432     fooi_(&i__1);
16433 // FFEINTRIN_impLEN //
16434     i__1 = i_len(a1, 10L);
16435     fooi_(&i__1);
16436 // FFEINTRIN_impLGE //
16437     L__1 = l_ge(a1, a2, 10L, 10L);
16438     fool_(&L__1);
16439 // FFEINTRIN_impLGT //
16440     L__1 = l_gt(a1, a2, 10L, 10L);
16441     fool_(&L__1);
16442 // FFEINTRIN_impLLE //
16443     L__1 = l_le(a1, a2, 10L, 10L);
16444     fool_(&L__1);
16445 // FFEINTRIN_impLLT //
16446     L__1 = l_lt(a1, a2, 10L, 10L);
16447     fool_(&L__1);
16448 // FFEINTRIN_impMAX0 //
16449     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16450     fooi_(&i__1);
16451 // FFEINTRIN_impMAX1 //
16452     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16453     fooi_(&i__1);
16454 // FFEINTRIN_impMIN0 //
16455     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16456     fooi_(&i__1);
16457 // FFEINTRIN_impMIN1 //
16458     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16459     fooi_(&i__1);
16460 // FFEINTRIN_impMOD //
16461     i__1 = i1 % i2;
16462     fooi_(&i__1);
16463 // FFEINTRIN_impNINT //
16464     i__1 = i_nint(&r1);
16465     fooi_(&i__1);
16466 // FFEINTRIN_impSIGN //
16467     r__1 = r_sign(&r1, &r2);
16468     foor_(&r__1);
16469 // FFEINTRIN_impSIN //
16470     r__1 = sin(r1);
16471     foor_(&r__1);
16472 // FFEINTRIN_impSINH //
16473     r__1 = sinh(r1);
16474     foor_(&r__1);
16475 // FFEINTRIN_impSQRT //
16476     r__1 = sqrt(r1);
16477     foor_(&r__1);
16478 // FFEINTRIN_impTAN //
16479     r__1 = tan(r1);
16480     foor_(&r__1);
16481 // FFEINTRIN_impTANH //
16482     r__1 = tanh(r1);
16483     foor_(&r__1);
16484 // FFEINTRIN_imp_CMPLX_C //
16485     r__1 = c1.r;
16486     r__2 = c2.r;
16487     q__1.r = r__1, q__1.i = r__2;
16488     fooc_(&q__1);
16489 // FFEINTRIN_imp_CMPLX_D //
16490     z__1.r = d1, z__1.i = d2;
16491     fooz_(&z__1);
16492 // FFEINTRIN_imp_CMPLX_I //
16493     r__1 = (real) i1;
16494     r__2 = (real) i2;
16495     q__1.r = r__1, q__1.i = r__2;
16496     fooc_(&q__1);
16497 // FFEINTRIN_imp_CMPLX_R //
16498     q__1.r = r1, q__1.i = r2;
16499     fooc_(&q__1);
16500 // FFEINTRIN_imp_DBLE_C //
16501     d__1 = (doublereal) c1.r;
16502     food_(&d__1);
16503 // FFEINTRIN_imp_DBLE_D //
16504     d__1 = d1;
16505     food_(&d__1);
16506 // FFEINTRIN_imp_DBLE_I //
16507     d__1 = (doublereal) i1;
16508     food_(&d__1);
16509 // FFEINTRIN_imp_DBLE_R //
16510     d__1 = (doublereal) r1;
16511     food_(&d__1);
16512 // FFEINTRIN_imp_INT_C //
16513     i__1 = (integer) c1.r;
16514     fooi_(&i__1);
16515 // FFEINTRIN_imp_INT_D //
16516     i__1 = (integer) d1;
16517     fooi_(&i__1);
16518 // FFEINTRIN_imp_INT_I //
16519     i__1 = i1;
16520     fooi_(&i__1);
16521 // FFEINTRIN_imp_INT_R //
16522     i__1 = (integer) r1;
16523     fooi_(&i__1);
16524 // FFEINTRIN_imp_REAL_C //
16525     r__1 = c1.r;
16526     foor_(&r__1);
16527 // FFEINTRIN_imp_REAL_D //
16528     r__1 = (real) d1;
16529     foor_(&r__1);
16530 // FFEINTRIN_imp_REAL_I //
16531     r__1 = (real) i1;
16532     foor_(&r__1);
16533 // FFEINTRIN_imp_REAL_R //
16534     r__1 = r1;
16535     foor_(&r__1);
16536 
16537 // FFEINTRIN_imp_INT_D: //
16538 
16539 // FFEINTRIN_specIDINT //
16540     i__1 = (integer) d1;
16541     fooi_(&i__1);
16542 
16543 // FFEINTRIN_imp_INT_R: //
16544 
16545 // FFEINTRIN_specIFIX //
16546     i__1 = (integer) r1;
16547     fooi_(&i__1);
16548 // FFEINTRIN_specINT //
16549     i__1 = (integer) r1;
16550     fooi_(&i__1);
16551 
16552 // FFEINTRIN_imp_REAL_D: //
16553 
16554 // FFEINTRIN_specSNGL //
16555     r__1 = (real) d1;
16556     foor_(&r__1);
16557 
16558 // FFEINTRIN_imp_REAL_I: //
16559 
16560 // FFEINTRIN_specFLOAT //
16561     r__1 = (real) i1;
16562     foor_(&r__1);
16563 // FFEINTRIN_specREAL //
16564     r__1 = (real) i1;
16565     foor_(&r__1);
16566 
16567 } // MAIN__ //
16568 
16569 -------- (end output file from f2c)
16570 
16571 */
16572 
16573 #include "gt-f-com.h"
16574 #include "gtype-f.h"
16575