]> gcc.gnu.org Git - gcc.git/blame - gcc/f/com.c
git://gcc.gnu.org / gcc.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
rewrite to use block/scope structure of GBE
[gcc.git] / gcc / f / com.c
CommitLineData
5ff904cd 1/* com.c -- Implementation File (module.c template V1.0)
44d2eabc 2 Copyright (C) 1995-1998 Free Software Foundation, Inc.
25d7717e 3 Contributed by James Craig Burley.
5ff904cd
JL		 4
5This file is part of GNU Fortran.
6
7GNU Fortran is free software; you can redistribute it and/or modify
8it under the terms of the GNU General Public License as published by
9the Free Software Foundation; either version 2, or (at your option)
10any later version.
11
12GNU Fortran is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15GNU General Public License for more details.
16
17You should have received a copy of the GNU General Public License
18along with GNU Fortran; see the file COPYING. If not, write to
19the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
2002111-1307, USA.
21
22 Related Modules:
23 None
24
25 Description:
26 Contains compiler-specific functions.
27
28 Modifications:
29*/
30
31/* Understanding this module means understanding the interface between
32 the g77 front end and the gcc back end (or, perhaps, some other
33 back end). In here are the functions called by the front end proper
34 to notify whatever back end is in place about certain things, and
35 also the back-end-specific functions. It's a bear to deal with, so
36 lately I've been trying to simplify things, especially with regard
37 to the gcc-back-end-specific stuff.
38
39 Building expressions generally seems quite easy, but building decls
40 has been challenging and is undergoing revision. gcc has several
41 kinds of decls:
42
43 TYPE_DECL -- a type (int, float, struct, function, etc.)
44 CONST_DECL -- a constant of some type other than function
45 LABEL_DECL -- a variable or a constant?
46 PARM_DECL -- an argument to a function (a variable that is a dummy)
47 RESULT_DECL -- the return value of a function (a variable)
48 VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
49 FUNCTION_DECL -- a function (either the actual function or an extern ref)
50 FIELD_DECL -- a field in a struct or union (goes into types)
51
52 g77 has a set of functions that somewhat parallels the gcc front end
53 when it comes to building decls:
54
55 Internal Function (one we define, not just declare as extern):
56 int yes;
57 yes = suspend_momentary ();
58 if (is_nested) push_f_function_context ();
59 start_function (get_identifier ("function_name"), function_type,
60 is_nested, is_public);
61 // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
62 store_parm_decls (is_main_program);
c7e4ee3a 63 ffecom_start_compstmt ();
5ff904cd 64 // for stmts and decls inside function, do appropriate things;
c7e4ee3a 65 ffecom_end_compstmt ();
5ff904cd
JL		 66 finish_function (is_nested);
67 if (is_nested) pop_f_function_context ();
68 if (is_nested) resume_momentary (yes);
69
70 Everything Else:
71 int yes;
72 tree d;
73 tree init;
74 yes = suspend_momentary ();
75 // fill in external, public, static, &c for decl, and
76 // set DECL_INITIAL to error_mark_node if going to initialize
77 // set is_top_level TRUE only if not at top level and decl
78 // must go in top level (i.e. not within current function decl context)
79 d = start_decl (decl, is_top_level);
80 init = ...; // if have initializer
81 finish_decl (d, init, is_top_level);
82 resume_momentary (yes);
83
84*/
85
86/* Include files. */
87
95a1b676 88#include "proj.h"
5ff904cd 89#if FFECOM_targetCURRENT == FFECOM_targetGCC
5ff904cd
JL		 90#include "flags.j"
91#include "rtl.j"
8b45da67 92#include "toplev.j"
5ff904cd 93#include "tree.j"
95a1b676 94#include "output.j" /* Must follow tree.j so TREE_CODE is defined! */
5ff904cd
JL		 95#include "convert.j"
96#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
97
98#define FFECOM_GCC_INCLUDE 1 /* Enable -I. */
99
100/* BEGIN stuff from gcc/cccp.c. */
101
102/* The following symbols should be autoconfigured:
103 HAVE_FCNTL_H
104 HAVE_STDLIB_H
105 HAVE_SYS_TIME_H
106 HAVE_UNISTD_H
107 STDC_HEADERS
108 TIME_WITH_SYS_TIME
109 In the mean time, we'll get by with approximations based
110 on existing GCC configuration symbols. */
111
112#ifdef POSIX
113# ifndef HAVE_STDLIB_H
114# define HAVE_STDLIB_H 1
115# endif
116# ifndef HAVE_UNISTD_H
117# define HAVE_UNISTD_H 1
118# endif
119# ifndef STDC_HEADERS
120# define STDC_HEADERS 1
121# endif
122#endif /* defined (POSIX) */
123
124#if defined (POSIX) || (defined (USG) && !defined (VMS))
125# ifndef HAVE_FCNTL_H
126# define HAVE_FCNTL_H 1
127# endif
128#endif
129
130#ifndef RLIMIT_STACK
131# include <time.h>
132#else
133# if TIME_WITH_SYS_TIME
134# include <sys/time.h>
135# include <time.h>
136# else
137# if HAVE_SYS_TIME_H
138# include <sys/time.h>
139# else
140# include <time.h>
141# endif
142# endif
143# include <sys/resource.h>
144#endif
145
146#if HAVE_FCNTL_H
147# include <fcntl.h>
148#endif
149
150/* This defines "errno" properly for VMS, and gives us EACCES. */
151#include <errno.h>
152
153#if HAVE_STDLIB_H
154# include <stdlib.h>
155#else
156char *getenv ();
157#endif
158
5ff904cd
JL		 159#if HAVE_UNISTD_H
160# include <unistd.h>
161#endif
162
163/* VMS-specific definitions */
164#ifdef VMS
165#include <descrip.h>
166#define O_RDONLY 0 /* Open arg for Read/Only */
167#define O_WRONLY 1 /* Open arg for Write/Only */
168#define read(fd,buf,size) VMS_read (fd,buf,size)
169#define write(fd,buf,size) VMS_write (fd,buf,size)
170#define open(fname,mode,prot) VMS_open (fname,mode,prot)
171#define fopen(fname,mode) VMS_fopen (fname,mode)
172#define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
173#define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
174#define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
175static int VMS_fstat (), VMS_stat ();
176static char * VMS_strncat ();
177static int VMS_read ();
178static int VMS_write ();
179static int VMS_open ();
180static FILE * VMS_fopen ();
181static FILE * VMS_freopen ();
182static void hack_vms_include_specification ();
183typedef struct { unsigned :16, :16, :16; } vms_ino_t;
184#define ino_t vms_ino_t
185#define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */
186#ifdef __GNUC__
187#define BSTRING /* VMS/GCC supplies the bstring routines */
188#endif /* __GNUC__ */
189#endif /* VMS */
190
191#ifndef O_RDONLY
192#define O_RDONLY 0
193#endif
194
195/* END stuff from gcc/cccp.c. */
196
5ff904cd
JL		 197#define FFECOM_DETERMINE_TYPES 1 /* for com.h */
198#include "com.h"
199#include "bad.h"
200#include "bld.h"
201#include "equiv.h"
202#include "expr.h"
203#include "implic.h"
204#include "info.h"
205#include "malloc.h"
206#include "src.h"
207#include "st.h"
208#include "storag.h"
209#include "symbol.h"
210#include "target.h"
211#include "top.h"
212#include "type.h"
213
214/* Externals defined here. */
215
216#define FFECOM_FASTER_ARRAY_REFS 0 /* Generates faster code? */
217
218#if FFECOM_targetCURRENT == FFECOM_targetGCC
219
220/* tree.h declares a bunch of stuff that it expects the front end to
221 define. Here are the definitions, which in the C front end are
222 found in the file c-decl.c. */
223
224tree integer_zero_node;
225tree integer_one_node;
226tree null_pointer_node;
227tree error_mark_node;
228tree void_type_node;
229tree integer_type_node;
230tree unsigned_type_node;
231tree char_type_node;
232tree current_function_decl;
233
c7e4ee3a
CB		 234/* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
235 reference it. */
5ff904cd
JL		 236
237char *language_string = "GNU F77";
238
77f77701
DB		 239/* Stream for reading from the input file. */
240FILE *finput;
241
5ff904cd
JL		 242/* These definitions parallel those in c-decl.c so that code from that
243 module can be used pretty much as is. Much of these defs aren't
244 otherwise used, i.e. by g77 code per se, except some of them are used
245 to build some of them that are. The ones that are global (i.e. not
246 "static") are those that ste.c and such might use (directly
247 or by using com macros that reference them in their definitions). */
248
249static tree short_integer_type_node;
250tree long_integer_type_node;
251static tree long_long_integer_type_node;
252
253static tree short_unsigned_type_node;
254static tree long_unsigned_type_node;
255static tree long_long_unsigned_type_node;
256
257static tree unsigned_char_type_node;
258static tree signed_char_type_node;
259
260static tree float_type_node;
261static tree double_type_node;
262static tree complex_float_type_node;
263tree complex_double_type_node;
264static tree long_double_type_node;
265static tree complex_integer_type_node;
266static tree complex_long_double_type_node;
267
268tree string_type_node;
269
270static tree double_ftype_double;
271static tree float_ftype_float;
272static tree ldouble_ftype_ldouble;
273
274/* The rest of these are inventions for g77, though there might be
275 similar things in the C front end. As they are found, these
276 inventions should be renamed to be canonical. Note that only
277 the ones currently required to be global are so. */
278
279static tree ffecom_tree_fun_type_void;
280static tree ffecom_tree_ptr_to_fun_type_void;
281
282tree ffecom_integer_type_node; /* Abbrev for _tree_type[blah][blah]. */
283tree ffecom_integer_zero_node; /* Like *_*_* with g77's integer type. */
284tree ffecom_integer_one_node; /* " */
285tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
286
287/* _fun_type things are the f2c-specific versions. For -fno-f2c,
288 just use build_function_type and build_pointer_type on the
289 appropriate _tree_type array element. */
290
291static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
292static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
293static tree ffecom_tree_subr_type;
294static tree ffecom_tree_ptr_to_subr_type;
295static tree ffecom_tree_blockdata_type;
296
297static tree ffecom_tree_xargc_;
298
299ffecomSymbol ffecom_symbol_null_
300=
301{
302 NULL_TREE,
303 NULL_TREE,
304 NULL_TREE,
0816ebdd
KG		 305 NULL_TREE,
306 false
5ff904cd
JL		 307};
308ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
309ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
310
311int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
312tree ffecom_f2c_integer_type_node;
313tree ffecom_f2c_ptr_to_integer_type_node;
314tree ffecom_f2c_address_type_node;
315tree ffecom_f2c_real_type_node;
316tree ffecom_f2c_ptr_to_real_type_node;
317tree ffecom_f2c_doublereal_type_node;
318tree ffecom_f2c_complex_type_node;
319tree ffecom_f2c_doublecomplex_type_node;
320tree ffecom_f2c_longint_type_node;
321tree ffecom_f2c_logical_type_node;
322tree ffecom_f2c_flag_type_node;
323tree ffecom_f2c_ftnlen_type_node;
324tree ffecom_f2c_ftnlen_zero_node;
325tree ffecom_f2c_ftnlen_one_node;
326tree ffecom_f2c_ftnlen_two_node;
327tree ffecom_f2c_ptr_to_ftnlen_type_node;
328tree ffecom_f2c_ftnint_type_node;
329tree ffecom_f2c_ptr_to_ftnint_type_node;
330#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
331
332/* Simple definitions and enumerations. */
333
334#ifndef FFECOM_sizeMAXSTACKITEM
335#define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
336 larger than this # bytes
337 off stack if possible. */
338#endif
339
340/* For systems that have large enough stacks, they should define
341 this to 0, and here, for ease of use later on, we just undefine
342 it if it is 0. */
343
344#if FFECOM_sizeMAXSTACKITEM == 0
345#undef FFECOM_sizeMAXSTACKITEM
346#endif
347
348typedef enum
349 {
350 FFECOM_rttypeVOID_,
6d433196 351 FFECOM_rttypeVOIDSTAR_, /* C's `void *' type. */
795232f7
JL		 352 FFECOM_rttypeFTNINT_, /* f2c's `ftnint' type. */
353 FFECOM_rttypeINTEGER_, /* f2c's `integer' type. */
354 FFECOM_rttypeLONGINT_, /* f2c's `longint' type. */
355 FFECOM_rttypeLOGICAL_, /* f2c's `logical' type. */
356 FFECOM_rttypeREAL_F2C_, /* f2c's `real' returned as `double'. */
357 FFECOM_rttypeREAL_GNU_, /* `real' returned as such. */
5ff904cd 358 FFECOM_rttypeCOMPLEX_F2C_, /* f2c's `complex' returned via 1st arg. */
795232f7 359 FFECOM_rttypeCOMPLEX_GNU_, /* f2c's `complex' returned directly. */
5ff904cd 360 FFECOM_rttypeDOUBLE_, /* C's `double' type. */
795232f7 361 FFECOM_rttypeDOUBLEREAL_, /* f2c's `doublereal' type. */
5ff904cd 362 FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
795232f7 363 FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
5ff904cd
JL		 364 FFECOM_rttypeCHARACTER_, /* f2c `char *'/`ftnlen' pair. */
365 FFECOM_rttype_
366 } ffecomRttype_;
367
368/* Internal typedefs. */
369
370#if FFECOM_targetCURRENT == FFECOM_targetGCC
371typedef struct _ffecom_concat_list_ ffecomConcatList_;
5ff904cd
JL		 372#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
373
374/* Private include files. */
375
376
377/* Internal structure definitions. */
378
379#if FFECOM_targetCURRENT == FFECOM_targetGCC
380struct _ffecom_concat_list_
381 {
382 ffebld *exprs;
383 int count;
384 int max;
385 ffetargetCharacterSize minlen;
386 ffetargetCharacterSize maxlen;
387 };
5ff904cd
JL		 388#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
389
390/* Static functions (internal). */
391
392#if FFECOM_targetCURRENT == FFECOM_targetGCC
26f096f9 393static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
5ff904cd
JL		 394static tree ffecom_widest_expr_type_ (ffebld list);
395static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
396 tree dest_size, tree source_tree,
397 ffebld source, bool scalar_arg);
398static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
399 tree args, tree callee_commons,
400 bool scalar_args);
26f096f9 401static tree ffecom_build_f2c_string_ (int i, const char *s);
5ff904cd
JL		 402static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
403 bool is_f2c_complex, tree type,
404 tree args, tree dest_tree,
405 ffebld dest, bool *dest_used,
c7e4ee3a 406 tree callee_commons, bool scalar_args, tree hook);
5ff904cd
JL		 407static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
408 bool is_f2c_complex, tree type,
409 ffebld left, ffebld right,
410 tree dest_tree, ffebld dest,
411 bool *dest_used, tree callee_commons,
c7e4ee3a 412 bool scalar_args, tree hook);
86fc7a6c
CB		 413static void ffecom_char_args_x_ (tree *xitem, tree *length,
414 ffebld expr, bool with_null);
5ff904cd
JL		 415static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
416static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
417static ffecomConcatList_
418 ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
419 ffebld expr,
420 ffetargetCharacterSize max);
421static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
422static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
423 ffetargetCharacterSize max);
26f096f9
KG		 424static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
425 ffesymbol member, tree member_type,
426 ffetargetOffset offset);
5ff904cd 427static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
092a4ef8
RH		 428static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
429 bool *dest_used, bool assignp, bool widenp);
5ff904cd
JL		 430static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
431 ffebld dest, bool *dest_used);
c7e4ee3a 432static tree ffecom_expr_power_integer_ (ffebld expr);
5ff904cd 433static void ffecom_expr_transform_ (ffebld expr);
26f096f9 434static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
5ff904cd
JL		 435static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
436 int code);
437static ffeglobal ffecom_finish_global_ (ffeglobal global);
438static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
26f096f9 439static tree ffecom_get_appended_identifier_ (char us, const char *text);
5ff904cd 440static tree ffecom_get_external_identifier_ (ffesymbol s);
26f096f9 441static tree ffecom_get_identifier_ (const char *text);
5ff904cd
JL		 442static tree ffecom_gen_sfuncdef_ (ffesymbol s,
443 ffeinfoBasictype bt,
444 ffeinfoKindtype kt);
26f096f9 445static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
5ff904cd
JL		 446static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
447static tree ffecom_init_zero_ (tree decl);
448static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
449 tree *maybe_tree);
450static tree ffecom_intrinsic_len_ (ffebld expr);
451static void ffecom_let_char_ (tree dest_tree,
452 tree dest_length,
453 ffetargetCharacterSize dest_size,
454 ffebld source);
455static void ffecom_make_gfrt_ (ffecomGfrt ix);
456static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
457#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
458static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
459#endif
c7e4ee3a
CB		 460static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
461 ffebld source);
5ff904cd
JL		 462static void ffecom_push_dummy_decls_ (ffebld dumlist,
463 bool stmtfunc);
464static void ffecom_start_progunit_ (void);
465static ffesymbol ffecom_sym_transform_ (ffesymbol s);
466static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
467static void ffecom_transform_common_ (ffesymbol s);
468static void ffecom_transform_equiv_ (ffestorag st);
469static tree ffecom_transform_namelist_ (ffesymbol s);
470static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
471 tree t);
472static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
473 tree *size, tree tree);
474static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
475 tree dest_tree, ffebld dest,
c7e4ee3a 476 bool *dest_used, tree hook);
5ff904cd
JL		 477static tree ffecom_type_localvar_ (ffesymbol s,
478 ffeinfoBasictype bt,
479 ffeinfoKindtype kt);
480static tree ffecom_type_namelist_ (void);
481#if 0
482static tree ffecom_type_permanent_copy_ (tree t);
483#endif
484static tree ffecom_type_vardesc_ (void);
485static tree ffecom_vardesc_ (ffebld expr);
486static tree ffecom_vardesc_array_ (ffesymbol s);
487static tree ffecom_vardesc_dims_ (ffesymbol s);
26f096f9
KG		 488static tree ffecom_convert_narrow_ (tree type, tree expr);
489static tree ffecom_convert_widen_ (tree type, tree expr);
5ff904cd
JL		 490#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
491
492/* These are static functions that parallel those found in the C front
493 end and thus have the same names. */
494
495#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a 496static tree bison_rule_compstmt_ (void);
5ff904cd 497static void bison_rule_pushlevel_ (void);
26f096f9 498static tree builtin_function (const char *name, tree type,
5ff904cd 499 enum built_in_function function_code,
26f096f9 500 const char *library_name);
c7e4ee3a 501static void delete_block (tree block);
5ff904cd
JL		 502static int duplicate_decls (tree newdecl, tree olddecl);
503static void finish_decl (tree decl, tree init, bool is_top_level);
504static void finish_function (int nested);
8f87a563 505static char *lang_printable_name (tree decl, int v);
5ff904cd
JL		 506static tree lookup_name_current_level (tree name);
507static struct binding_level *make_binding_level (void);
508static void pop_f_function_context (void);
509static void push_f_function_context (void);
510static void push_parm_decl (tree parm);
511static tree pushdecl_top_level (tree decl);
c7e4ee3a 512static int kept_level_p (void);
5ff904cd
JL		 513static tree storedecls (tree decls);
514static void store_parm_decls (int is_main_program);
515static tree start_decl (tree decl, bool is_top_level);
516static void start_function (tree name, tree type, int nested, int public);
517#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
518#if FFECOM_GCC_INCLUDE
519static void ffecom_file_ (char *name);
520static void ffecom_initialize_char_syntax_ (void);
521static void ffecom_close_include_ (FILE *f);
522static int ffecom_decode_include_option_ (char *spec);
523static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
524 ffewhereColumn c);
525#endif /* FFECOM_GCC_INCLUDE */
526
527/* Static objects accessed by functions in this module. */
528
529static ffesymbol ffecom_primary_entry_ = NULL;
530static ffesymbol ffecom_nested_entry_ = NULL;
531static ffeinfoKind ffecom_primary_entry_kind_;
532static bool ffecom_primary_entry_is_proc_;
533#if FFECOM_targetCURRENT == FFECOM_targetGCC
534static tree ffecom_outer_function_decl_;
535static tree ffecom_previous_function_decl_;
536static tree ffecom_which_entrypoint_decl_;
5ff904cd
JL		 537static tree ffecom_float_zero_ = NULL_TREE;
538static tree ffecom_float_half_ = NULL_TREE;
539static tree ffecom_double_zero_ = NULL_TREE;
540static tree ffecom_double_half_ = NULL_TREE;
541static tree ffecom_func_result_;/* For functions. */
542static tree ffecom_func_length_;/* For CHARACTER fns. */
543static ffebld ffecom_list_blockdata_;
544static ffebld ffecom_list_common_;
545static ffebld ffecom_master_arglist_;
546static ffeinfoBasictype ffecom_master_bt_;
547static ffeinfoKindtype ffecom_master_kt_;
548static ffetargetCharacterSize ffecom_master_size_;
549static int ffecom_num_fns_ = 0;
550static int ffecom_num_entrypoints_ = 0;
551static bool ffecom_is_altreturning_ = FALSE;
552static tree ffecom_multi_type_node_;
553static tree ffecom_multi_retval_;
554static tree
555 ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
556static bool ffecom_member_namelisted_; /* _member_phase1_ namelisted? */
557static bool ffecom_doing_entry_ = FALSE;
558static bool ffecom_transform_only_dummies_ = FALSE;
559
560/* Holds pointer-to-function expressions. */
561
562static tree ffecom_gfrt_[FFECOM_gfrt]
563=
564{
565#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE,
566#include "com-rt.def"
567#undef DEFGFRT
568};
569
570/* Holds the external names of the functions. */
571
26f096f9 572static const char *ffecom_gfrt_name_[FFECOM_gfrt]
5ff904cd
JL		 573=
574{
575#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME,
576#include "com-rt.def"
577#undef DEFGFRT
578};
579
580/* Whether the function returns. */
581
582static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
583=
584{
585#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE,
586#include "com-rt.def"
587#undef DEFGFRT
588};
589
590/* Whether the function returns type complex. */
591
592static bool ffecom_gfrt_complex_[FFECOM_gfrt]
593=
594{
595#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX,
596#include "com-rt.def"
597#undef DEFGFRT
598};
599
600/* Type code for the function return value. */
601
602static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
603=
604{
605#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE,
606#include "com-rt.def"
607#undef DEFGFRT
608};
609
610/* String of codes for the function's arguments. */
611
26f096f9 612static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
5ff904cd
JL		 613=
614{
615#define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS,
616#include "com-rt.def"
617#undef DEFGFRT
618};
619#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
620
621/* Internal macros. */
622
623#if FFECOM_targetCURRENT == FFECOM_targetGCC
624
625/* We let tm.h override the types used here, to handle trivial differences
626 such as the choice of unsigned int or long unsigned int for size_t.
627 When machines start needing nontrivial differences in the size type,
628 it would be best to do something here to figure out automatically
629 from other information what type to use. */
630
631/* NOTE: g77 currently doesn't use these; see setting of sizetype and
632 change that if you need to. -- jcb 09/01/91. */
633
5ff904cd
JL		 634#define ffecom_concat_list_count_(catlist) ((catlist).count)
635#define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
636#define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
637#define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
638
86fc7a6c
CB		 639#define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
640#define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
641
5ff904cd
JL		 642/* For each binding contour we allocate a binding_level structure
643 * which records the names defined in that contour.
644 * Contours include:
645 * 0) the global one
646 * 1) one for each function definition,
647 * where internal declarations of the parameters appear.
648 *
649 * The current meaning of a name can be found by searching the levels from
650 * the current one out to the global one.
651 */
652
653/* Note that the information in the `names' component of the global contour
654 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
655
656struct binding_level
657 {
c7e4ee3a
CB		 658 /* A chain of _DECL nodes for all variables, constants, functions,
659 and typedef types. These are in the reverse of the order supplied.
660 */
5ff904cd
JL		 661 tree names;
662
c7e4ee3a
CB		 663 /* For each level (except not the global one),
664 a chain of BLOCK nodes for all the levels
665 that were entered and exited one level down. */
5ff904cd
JL		 666 tree blocks;
667
c7e4ee3a
CB		 668 /* The BLOCK node for this level, if one has been preallocated.
669 If 0, the BLOCK is allocated (if needed) when the level is popped. */
5ff904cd
JL		 670 tree this_block;
671
672 /* The binding level which this one is contained in (inherits from). */
673 struct binding_level *level_chain;
c7e4ee3a
CB		 674
675 /* 0: no ffecom_prepare_* functions called at this level yet;
676 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
677 2: ffecom_prepare_end called. */
678 int prep_state;
5ff904cd
JL		 679 };
680
681#define NULL_BINDING_LEVEL (struct binding_level *) NULL
682
683/* The binding level currently in effect. */
684
685static struct binding_level *current_binding_level;
686
687/* A chain of binding_level structures awaiting reuse. */
688
689static struct binding_level *free_binding_level;
690
691/* The outermost binding level, for names of file scope.
692 This is created when the compiler is started and exists
693 through the entire run. */
694
695static struct binding_level *global_binding_level;
696
697/* Binding level structures are initialized by copying this one. */
698
699static struct binding_level clear_binding_level
700=
c7e4ee3a 701{NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
5ff904cd
JL		 702
703/* Language-dependent contents of an identifier. */
704
705struct lang_identifier
706 {
707 struct tree_identifier ignore;
708 tree global_value, local_value, label_value;
709 bool invented;
710 };
711
712/* Macros for access to language-specific slots in an identifier. */
713/* Each of these slots contains a DECL node or null. */
714
715/* This represents the value which the identifier has in the
716 file-scope namespace. */
717#define IDENTIFIER_GLOBAL_VALUE(NODE) \
718 (((struct lang_identifier *)(NODE))->global_value)
719/* This represents the value which the identifier has in the current
720 scope. */
721#define IDENTIFIER_LOCAL_VALUE(NODE) \
722 (((struct lang_identifier *)(NODE))->local_value)
723/* This represents the value which the identifier has as a label in
724 the current label scope. */
725#define IDENTIFIER_LABEL_VALUE(NODE) \
726 (((struct lang_identifier *)(NODE))->label_value)
727/* This is nonzero if the identifier was "made up" by g77 code. */
728#define IDENTIFIER_INVENTED(NODE) \
729 (((struct lang_identifier *)(NODE))->invented)
730
731/* In identifiers, C uses the following fields in a special way:
732 TREE_PUBLIC to record that there was a previous local extern decl.
733 TREE_USED to record that such a decl was used.
734 TREE_ADDRESSABLE to record that the address of such a decl was used. */
735
736/* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
737 that have names. Here so we can clear out their names' definitions
738 at the end of the function. */
739
740static tree named_labels;
741
742/* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
743
744static tree shadowed_labels;
745
746#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
747\f
5ff904cd
JL		 748/* This is like gcc's stabilize_reference -- in fact, most of the code
749 comes from that -- but it handles the situation where the reference
750 is going to have its subparts picked at, and it shouldn't change
751 (or trigger extra invocations of functions in the subtrees) due to
752 this. save_expr is a bit overzealous, because we don't need the
753 entire thing calculated and saved like a temp. So, for DECLs, no
754 change is needed, because these are stable aggregates, and ARRAY_REF
755 and such might well be stable too, but for things like calculations,
756 we do need to calculate a snapshot of a value before picking at it. */
757
758#if FFECOM_targetCURRENT == FFECOM_targetGCC
759static tree
760ffecom_stabilize_aggregate_ (tree ref)
761{
762 tree result;
763 enum tree_code code = TREE_CODE (ref);
764
765 switch (code)
766 {
767 case VAR_DECL:
768 case PARM_DECL:
769 case RESULT_DECL:
770 /* No action is needed in this case. */
771 return ref;
772
773 case NOP_EXPR:
774 case CONVERT_EXPR:
775 case FLOAT_EXPR:
776 case FIX_TRUNC_EXPR:
777 case FIX_FLOOR_EXPR:
778 case FIX_ROUND_EXPR:
779 case FIX_CEIL_EXPR:
780 result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
781 break;
782
783 case INDIRECT_REF:
784 result = build_nt (INDIRECT_REF,
785 stabilize_reference_1 (TREE_OPERAND (ref, 0)));
786 break;
787
788 case COMPONENT_REF:
789 result = build_nt (COMPONENT_REF,
790 stabilize_reference (TREE_OPERAND (ref, 0)),
791 TREE_OPERAND (ref, 1));
792 break;
793
794 case BIT_FIELD_REF:
795 result = build_nt (BIT_FIELD_REF,
796 stabilize_reference (TREE_OPERAND (ref, 0)),
797 stabilize_reference_1 (TREE_OPERAND (ref, 1)),
798 stabilize_reference_1 (TREE_OPERAND (ref, 2)));
799 break;
800
801 case ARRAY_REF:
802 result = build_nt (ARRAY_REF,
803 stabilize_reference (TREE_OPERAND (ref, 0)),
804 stabilize_reference_1 (TREE_OPERAND (ref, 1)));
805 break;
806
807 case COMPOUND_EXPR:
808 result = build_nt (COMPOUND_EXPR,
809 stabilize_reference_1 (TREE_OPERAND (ref, 0)),
810 stabilize_reference (TREE_OPERAND (ref, 1)));
811 break;
812
813 case RTL_EXPR:
814 result = build1 (INDIRECT_REF, TREE_TYPE (ref),
815 save_expr (build1 (ADDR_EXPR,
816 build_pointer_type (TREE_TYPE (ref)),
817 ref)));
818 break;
819
820
821 default:
822 return save_expr (ref);
823
824 case ERROR_MARK:
825 return error_mark_node;
826 }
827
828 TREE_TYPE (result) = TREE_TYPE (ref);
829 TREE_READONLY (result) = TREE_READONLY (ref);
830 TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
831 TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
832 TREE_RAISES (result) = TREE_RAISES (ref);
833
834 return result;
835}
836#endif
837
838/* A rip-off of gcc's convert.c convert_to_complex function,
839 reworked to handle complex implemented as C structures
840 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
841
842#if FFECOM_targetCURRENT == FFECOM_targetGCC
843static tree
844ffecom_convert_to_complex_ (tree type, tree expr)
845{
846 register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
847 tree subtype;
848
849 assert (TREE_CODE (type) == RECORD_TYPE);
850
851 subtype = TREE_TYPE (TYPE_FIELDS (type));
852
853 if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
854 {
855 expr = convert (subtype, expr);
856 return ffecom_2 (COMPLEX_EXPR, type, expr,
857 convert (subtype, integer_zero_node));
858 }
859
860 if (form == RECORD_TYPE)
861 {
862 tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
863 if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
864 return expr;
865 else
866 {
867 expr = save_expr (expr);
868 return ffecom_2 (COMPLEX_EXPR,
869 type,
870 convert (subtype,
871 ffecom_1 (REALPART_EXPR,
872 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
873 expr)),
874 convert (subtype,
875 ffecom_1 (IMAGPART_EXPR,
876 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
877 expr)));
878 }
879 }
880
881 if (form == POINTER_TYPE || form == REFERENCE_TYPE)
882 error ("pointer value used where a complex was expected");
883 else
884 error ("aggregate value used where a complex was expected");
885
886 return ffecom_2 (COMPLEX_EXPR, type,
887 convert (subtype, integer_zero_node),
888 convert (subtype, integer_zero_node));
889}
890#endif
891
892/* Like gcc's convert(), but crashes if widening might happen. */
893
894#if FFECOM_targetCURRENT == FFECOM_targetGCC
895static tree
896ffecom_convert_narrow_ (type, expr)
897 tree type, expr;
898{
899 register tree e = expr;
900 register enum tree_code code = TREE_CODE (type);
901
902 if (type == TREE_TYPE (e)
903 || TREE_CODE (e) == ERROR_MARK)
904 return e;
905 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
906 return fold (build1 (NOP_EXPR, type, e));
907 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
908 || code == ERROR_MARK)
909 return error_mark_node;
910 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
911 {
912 assert ("void value not ignored as it ought to be" == NULL);
913 return error_mark_node;
914 }
915 assert (code != VOID_TYPE);
916 if ((code != RECORD_TYPE)
917 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
918 assert ("converting COMPLEX to REAL" == NULL);
919 assert (code != ENUMERAL_TYPE);
920 if (code == INTEGER_TYPE)
921 {
a74de6ea
CB		 922 assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
923 && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
924 || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
925 && (TYPE_PRECISION (type)
926 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
5ff904cd
JL		 927 return fold (convert_to_integer (type, e));
928 }
929 if (code == POINTER_TYPE)
930 {
931 assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
932 return fold (convert_to_pointer (type, e));
933 }
934 if (code == REAL_TYPE)
935 {
936 assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
937 assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
938 return fold (convert_to_real (type, e));
939 }
940 if (code == COMPLEX_TYPE)
941 {
942 assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
943 assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
944 return fold (convert_to_complex (type, e));
945 }
946 if (code == RECORD_TYPE)
947 {
948 assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
270fc4e8
CB		 949 /* Check that at least the first field name agrees. */
950 assert (DECL_NAME (TYPE_FIELDS (type))
951 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
5ff904cd
JL		 952 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
953 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
270fc4e8
CB		 954 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
955 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
956 return e;
5ff904cd
JL		 957 return fold (ffecom_convert_to_complex_ (type, e));
958 }
959
960 assert ("conversion to non-scalar type requested" == NULL);
961 return error_mark_node;
962}
963#endif
964
965/* Like gcc's convert(), but crashes if narrowing might happen. */
966
967#if FFECOM_targetCURRENT == FFECOM_targetGCC
968static tree
969ffecom_convert_widen_ (type, expr)
970 tree type, expr;
971{
972 register tree e = expr;
973 register enum tree_code code = TREE_CODE (type);
974
975 if (type == TREE_TYPE (e)
976 || TREE_CODE (e) == ERROR_MARK)
977 return e;
978 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
979 return fold (build1 (NOP_EXPR, type, e));
980 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
981 || code == ERROR_MARK)
982 return error_mark_node;
983 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
984 {
985 assert ("void value not ignored as it ought to be" == NULL);
986 return error_mark_node;
987 }
988 assert (code != VOID_TYPE);
989 if ((code != RECORD_TYPE)
990 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
991 assert ("narrowing COMPLEX to REAL" == NULL);
992 assert (code != ENUMERAL_TYPE);
993 if (code == INTEGER_TYPE)
994 {
a74de6ea
CB		 995 assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
996 && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
997 || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
998 && (TYPE_PRECISION (type)
999 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
5ff904cd
JL		 1000 return fold (convert_to_integer (type, e));
1001 }
1002 if (code == POINTER_TYPE)
1003 {
1004 assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1005 return fold (convert_to_pointer (type, e));
1006 }
1007 if (code == REAL_TYPE)
1008 {
1009 assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1010 assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1011 return fold (convert_to_real (type, e));
1012 }
1013 if (code == COMPLEX_TYPE)
1014 {
1015 assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1016 assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1017 return fold (convert_to_complex (type, e));
1018 }
1019 if (code == RECORD_TYPE)
1020 {
1021 assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
270fc4e8
CB		 1022 /* Check that at least the first field name agrees. */
1023 assert (DECL_NAME (TYPE_FIELDS (type))
1024 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
5ff904cd
JL		 1025 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1026 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
270fc4e8
CB		 1027 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1028 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1029 return e;
5ff904cd
JL		 1030 return fold (ffecom_convert_to_complex_ (type, e));
1031 }
1032
1033 assert ("conversion to non-scalar type requested" == NULL);
1034 return error_mark_node;
1035}
1036#endif
1037
1038/* Handles making a COMPLEX type, either the standard
1039 (but buggy?) gbe way, or the safer (but less elegant?)
1040 f2c way. */
1041
1042#if FFECOM_targetCURRENT == FFECOM_targetGCC
1043static tree
1044ffecom_make_complex_type_ (tree subtype)
1045{
1046 tree type;
1047 tree realfield;
1048 tree imagfield;
1049
1050 if (ffe_is_emulate_complex ())
1051 {
1052 type = make_node (RECORD_TYPE);
1053 realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1054 imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1055 TYPE_FIELDS (type) = realfield;
1056 layout_type (type);
1057 }
1058 else
1059 {
1060 type = make_node (COMPLEX_TYPE);
1061 TREE_TYPE (type) = subtype;
1062 layout_type (type);
1063 }
1064
1065 return type;
1066}
1067#endif
1068
1069/* Chooses either the gbe or the f2c way to build a
1070 complex constant. */
1071
1072#if FFECOM_targetCURRENT == FFECOM_targetGCC
1073static tree
1074ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1075{
1076 tree bothparts;
1077
1078 if (ffe_is_emulate_complex ())
1079 {
1080 bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1081 TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1082 bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1083 }
1084 else
1085 {
1086 bothparts = build_complex (type, realpart, imagpart);
1087 }
1088
1089 return bothparts;
1090}
1091#endif
1092
1093#if FFECOM_targetCURRENT == FFECOM_targetGCC
1094static tree
26f096f9 1095ffecom_arglist_expr_ (const char *c, ffebld expr)
5ff904cd
JL		 1096{
1097 tree list;
1098 tree *plist = &list;
1099 tree trail = NULL_TREE; /* Append char length args here. */
1100 tree *ptrail = &trail;
1101 tree length;
1102 ffebld exprh;
1103 tree item;
1104 bool ptr = FALSE;
1105 tree wanted = NULL_TREE;
e2fa159e
JL		 1106 static char zed[] = "0";
1107
1108 if (c == NULL)
1109 c = &zed[0];
5ff904cd
JL		 1110
1111 while (expr != NULL)
1112 {
1113 if (*c != '\0')
1114 {
1115 ptr = FALSE;
1116 if (*c == '&')
1117 {
1118 ptr = TRUE;
1119 ++c;
1120 }
1121 switch (*(c++))
1122 {
1123 case '\0':
1124 ptr = TRUE;
1125 wanted = NULL_TREE;
1126 break;
1127
1128 case 'a':
1129 assert (ptr);
1130 wanted = NULL_TREE;
1131 break;
1132
1133 case 'c':
1134 wanted = ffecom_f2c_complex_type_node;
1135 break;
1136
1137 case 'd':
1138 wanted = ffecom_f2c_doublereal_type_node;
1139 break;
1140
1141 case 'e':
1142 wanted = ffecom_f2c_doublecomplex_type_node;
1143 break;
1144
1145 case 'f':
1146 wanted = ffecom_f2c_real_type_node;
1147 break;
1148
1149 case 'i':
1150 wanted = ffecom_f2c_integer_type_node;
1151 break;
1152
1153 case 'j':
1154 wanted = ffecom_f2c_longint_type_node;
1155 break;
1156
1157 default:
1158 assert ("bad argstring code" == NULL);
1159 wanted = NULL_TREE;
1160 break;
1161 }
1162 }
1163
1164 exprh = ffebld_head (expr);
1165 if (exprh == NULL)
1166 wanted = NULL_TREE;
1167
1168 if ((wanted == NULL_TREE)
1169 || (ptr
1170 && (TYPE_MODE
1171 (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1172 [ffeinfo_kindtype (ffebld_info (exprh))])
1173 == TYPE_MODE (wanted))))
1174 *plist
1175 = build_tree_list (NULL_TREE,
1176 ffecom_arg_ptr_to_expr (exprh,
1177 &length));
1178 else
1179 {
1180 item = ffecom_arg_expr (exprh, &length);
1181 item = ffecom_convert_widen_ (wanted, item);
1182 if (ptr)
1183 {
1184 item = ffecom_1 (ADDR_EXPR,
1185 build_pointer_type (TREE_TYPE (item)),
1186 item);
1187 }
1188 *plist
1189 = build_tree_list (NULL_TREE,
1190 item);
1191 }
1192
1193 plist = &TREE_CHAIN (*plist);
1194 expr = ffebld_trail (expr);
1195 if (length != NULL_TREE)
1196 {
1197 *ptrail = build_tree_list (NULL_TREE, length);
1198 ptrail = &TREE_CHAIN (*ptrail);
1199 }
1200 }
1201
e2fa159e
JL		 1202 /* We've run out of args in the call; if the implementation expects
1203 more, supply null pointers for them, which the implementation can
1204 check to see if an arg was omitted. */
1205
1206 while (*c != '\0' && *c != '0')
1207 {
1208 if (*c == '&')
1209 ++c;
1210 else
1211 assert ("missing arg to run-time routine!" == NULL);
1212
1213 switch (*(c++))
1214 {
1215 case '\0':
1216 case 'a':
1217 case 'c':
1218 case 'd':
1219 case 'e':
1220 case 'f':
1221 case 'i':
1222 case 'j':
1223 break;
1224
1225 default:
1226 assert ("bad arg string code" == NULL);
1227 break;
1228 }
1229 *plist
1230 = build_tree_list (NULL_TREE,
1231 null_pointer_node);
1232 plist = &TREE_CHAIN (*plist);
1233 }
1234
5ff904cd
JL		 1235 *plist = trail;
1236
1237 return list;
1238}
1239#endif
1240
1241#if FFECOM_targetCURRENT == FFECOM_targetGCC
1242static tree
1243ffecom_widest_expr_type_ (ffebld list)
1244{
1245 ffebld item;
1246 ffebld widest = NULL;
1247 ffetype type;
1248 ffetype widest_type = NULL;
1249 tree t;
1250
1251 for (; list != NULL; list = ffebld_trail (list))
1252 {
1253 item = ffebld_head (list);
1254 if (item == NULL)
1255 continue;
1256 if ((widest != NULL)
1257 && (ffeinfo_basictype (ffebld_info (item))
1258 != ffeinfo_basictype (ffebld_info (widest))))
1259 continue;
1260 type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1261 ffeinfo_kindtype (ffebld_info (item)));
1262 if ((widest == FFEINFO_kindtypeNONE)
1263 || (ffetype_size (type)
1264 > ffetype_size (widest_type)))
1265 {
1266 widest = item;
1267 widest_type = type;
1268 }
1269 }
1270
1271 assert (widest != NULL);
1272 t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1273 [ffeinfo_kindtype (ffebld_info (widest))];
1274 assert (t != NULL_TREE);
1275 return t;
1276}
1277#endif
1278
1279/* Check whether dest and source might overlap. ffebld versions of these
1280 might or might not be passed, will be NULL if not.
1281
1282 The test is really whether source_tree is modifiable and, if modified,
1283 might overlap destination such that the value(s) in the destination might
1284 change before it is finally modified. dest_* are the canonized
1285 destination itself. */
1286
1287#if FFECOM_targetCURRENT == FFECOM_targetGCC
1288static bool
1289ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1290 tree source_tree, ffebld source UNUSED,
1291 bool scalar_arg)
1292{
1293 tree source_decl;
1294 tree source_offset;
1295 tree source_size;
1296 tree t;
1297
1298 if (source_tree == NULL_TREE)
1299 return FALSE;
1300
1301 switch (TREE_CODE (source_tree))
1302 {
1303 case ERROR_MARK:
1304 case IDENTIFIER_NODE:
1305 case INTEGER_CST:
1306 case REAL_CST:
1307 case COMPLEX_CST:
1308 case STRING_CST:
1309 case CONST_DECL:
1310 case VAR_DECL:
1311 case RESULT_DECL:
1312 case FIELD_DECL:
1313 case MINUS_EXPR:
1314 case MULT_EXPR:
1315 case TRUNC_DIV_EXPR:
1316 case CEIL_DIV_EXPR:
1317 case FLOOR_DIV_EXPR:
1318 case ROUND_DIV_EXPR:
1319 case TRUNC_MOD_EXPR:
1320 case CEIL_MOD_EXPR:
1321 case FLOOR_MOD_EXPR:
1322 case ROUND_MOD_EXPR:
1323 case RDIV_EXPR:
1324 case EXACT_DIV_EXPR:
1325 case FIX_TRUNC_EXPR:
1326 case FIX_CEIL_EXPR:
1327 case FIX_FLOOR_EXPR:
1328 case FIX_ROUND_EXPR:
1329 case FLOAT_EXPR:
1330 case EXPON_EXPR:
1331 case NEGATE_EXPR:
1332 case MIN_EXPR:
1333 case MAX_EXPR:
1334 case ABS_EXPR:
1335 case FFS_EXPR:
1336 case LSHIFT_EXPR:
1337 case RSHIFT_EXPR:
1338 case LROTATE_EXPR:
1339 case RROTATE_EXPR:
1340 case BIT_IOR_EXPR:
1341 case BIT_XOR_EXPR:
1342 case BIT_AND_EXPR:
1343 case BIT_ANDTC_EXPR:
1344 case BIT_NOT_EXPR:
1345 case TRUTH_ANDIF_EXPR:
1346 case TRUTH_ORIF_EXPR:
1347 case TRUTH_AND_EXPR:
1348 case TRUTH_OR_EXPR:
1349 case TRUTH_XOR_EXPR:
1350 case TRUTH_NOT_EXPR:
1351 case LT_EXPR:
1352 case LE_EXPR:
1353 case GT_EXPR:
1354 case GE_EXPR:
1355 case EQ_EXPR:
1356 case NE_EXPR:
1357 case COMPLEX_EXPR:
1358 case CONJ_EXPR:
1359 case REALPART_EXPR:
1360 case IMAGPART_EXPR:
1361 case LABEL_EXPR:
1362 case COMPONENT_REF:
1363 return FALSE;
1364
1365 case COMPOUND_EXPR:
1366 return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1367 TREE_OPERAND (source_tree, 1), NULL,
1368 scalar_arg);
1369
1370 case MODIFY_EXPR:
1371 return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1372 TREE_OPERAND (source_tree, 0), NULL,
1373 scalar_arg);
1374
1375 case CONVERT_EXPR:
1376 case NOP_EXPR:
1377 case NON_LVALUE_EXPR:
1378 case PLUS_EXPR:
1379 if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1380 return TRUE;
1381
1382 ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1383 source_tree);
1384 source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1385 break;
1386
1387 case COND_EXPR:
1388 return
1389 ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1390 TREE_OPERAND (source_tree, 1), NULL,
1391 scalar_arg)
1392 || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1393 TREE_OPERAND (source_tree, 2), NULL,
1394 scalar_arg);
1395
1396
1397 case ADDR_EXPR:
1398 ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1399 &source_size,
1400 TREE_OPERAND (source_tree, 0));
1401 break;
1402
1403 case PARM_DECL:
1404 if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1405 return TRUE;
1406
1407 source_decl = source_tree;
1408 source_offset = size_zero_node;
1409 source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1410 break;
1411
1412 case SAVE_EXPR:
1413 case REFERENCE_EXPR:
1414 case PREDECREMENT_EXPR:
1415 case PREINCREMENT_EXPR:
1416 case POSTDECREMENT_EXPR:
1417 case POSTINCREMENT_EXPR:
1418 case INDIRECT_REF:
1419 case ARRAY_REF:
1420 case CALL_EXPR:
1421 default:
1422 return TRUE;
1423 }
1424
1425 /* Come here when source_decl, source_offset, and source_size filled
1426 in appropriately. */
1427
1428 if (source_decl == NULL_TREE)
1429 return FALSE; /* No decl involved, so no overlap. */
1430
1431 if (source_decl != dest_decl)
1432 return FALSE; /* Different decl, no overlap. */
1433
1434 if (TREE_CODE (dest_size) == ERROR_MARK)
1435 return TRUE; /* Assignment into entire assumed-size
1436 array? Shouldn't happen.... */
1437
1438 t = ffecom_2 (LE_EXPR, integer_type_node,
1439 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1440 dest_offset,
1441 convert (TREE_TYPE (dest_offset),
1442 dest_size)),
1443 convert (TREE_TYPE (dest_offset),
1444 source_offset));
1445
1446 if (integer_onep (t))
1447 return FALSE; /* Destination precedes source. */
1448
1449 if (!scalar_arg
1450 || (source_size == NULL_TREE)
1451 || (TREE_CODE (source_size) == ERROR_MARK)
1452 || integer_zerop (source_size))
1453 return TRUE; /* No way to tell if dest follows source. */
1454
1455 t = ffecom_2 (LE_EXPR, integer_type_node,
1456 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1457 source_offset,
1458 convert (TREE_TYPE (source_offset),
1459 source_size)),
1460 convert (TREE_TYPE (source_offset),
1461 dest_offset));
1462
1463 if (integer_onep (t))
1464 return FALSE; /* Destination follows source. */
1465
1466 return TRUE; /* Destination and source overlap. */
1467}
1468#endif
1469
1470/* Check whether dest might overlap any of a list of arguments or is
1471 in a COMMON area the callee might know about (and thus modify). */
1472
1473#if FFECOM_targetCURRENT == FFECOM_targetGCC
1474static bool
1475ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1476 tree args, tree callee_commons,
1477 bool scalar_args)
1478{
1479 tree arg;
1480 tree dest_decl;
1481 tree dest_offset;
1482 tree dest_size;
1483
1484 ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1485 dest_tree);
1486
1487 if (dest_decl == NULL_TREE)
1488 return FALSE; /* Seems unlikely! */
1489
1490 /* If the decl cannot be determined reliably, or if its in COMMON
1491 and the callee isn't known to not futz with COMMON via other
1492 means, overlap might happen. */
1493
1494 if ((TREE_CODE (dest_decl) == ERROR_MARK)
1495 || ((callee_commons != NULL_TREE)
1496 && TREE_PUBLIC (dest_decl)))
1497 return TRUE;
1498
1499 for (; args != NULL_TREE; args = TREE_CHAIN (args))
1500 {
1501 if (((arg = TREE_VALUE (args)) != NULL_TREE)
1502 && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1503 arg, NULL, scalar_args))
1504 return TRUE;
1505 }
1506
1507 return FALSE;
1508}
1509#endif
1510
1511/* Build a string for a variable name as used by NAMELIST. This means that
1512 if we're using the f2c library, we build an uppercase string, since
1513 f2c does this. */
1514
1515#if FFECOM_targetCURRENT == FFECOM_targetGCC
1516static tree
26f096f9 1517ffecom_build_f2c_string_ (int i, const char *s)
5ff904cd
JL		 1518{
1519 if (!ffe_is_f2c_library ())
1520 return build_string (i, s);
1521
1522 {
1523 char *tmp;
26f096f9 1524 const char *p;
5ff904cd
JL		 1525 char *q;
1526 char space[34];
1527 tree t;
1528
1529 if (((size_t) i) > ARRAY_SIZE (space))
1530 tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1531 else
1532 tmp = &space[0];
1533
1534 for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1535 *q = ffesrc_toupper (*p);
1536 *q = '\0';
1537
1538 t = build_string (i, tmp);
1539
1540 if (((size_t) i) > ARRAY_SIZE (space))
1541 malloc_kill_ks (malloc_pool_image (), tmp, i);
1542
1543 return t;
1544 }
1545}
1546
1547#endif
1548/* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1549 type to just get whatever the function returns), handling the
1550 f2c value-returning convention, if required, by prepending
1551 to the arglist a pointer to a temporary to receive the return value. */
1552
1553#if FFECOM_targetCURRENT == FFECOM_targetGCC
1554static tree
1555ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1556 tree type, tree args, tree dest_tree,
1557 ffebld dest, bool *dest_used, tree callee_commons,
c7e4ee3a 1558 bool scalar_args, tree hook)
5ff904cd
JL		 1559{
1560 tree item;
1561 tree tempvar;
1562
1563 if (dest_used != NULL)
1564 *dest_used = FALSE;
1565
1566 if (is_f2c_complex)
1567 {
1568 if ((dest_used == NULL)
1569 || (dest == NULL)
1570 || (ffeinfo_basictype (ffebld_info (dest))
1571 != FFEINFO_basictypeCOMPLEX)
1572 || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1573 || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1574 || ffecom_args_overlapping_ (dest_tree, dest, args,
1575 callee_commons,
1576 scalar_args))
1577 {
c7e4ee3a
CB		 1578#ifdef HOHO
1579 tempvar = ffecom_make_tempvar (ffecom_tree_type
5ff904cd
JL		 1580 [FFEINFO_basictypeCOMPLEX][kt],
1581 FFETARGET_charactersizeNONE,
c7e4ee3a
CB		 1582 -1);
1583#else
1584 tempvar = hook;
1585 assert (tempvar);
1586#endif
5ff904cd
JL		 1587 }
1588 else
1589 {
1590 *dest_used = TRUE;
1591 tempvar = dest_tree;
1592 type = NULL_TREE;
1593 }
1594
1595 item
1596 = build_tree_list (NULL_TREE,
1597 ffecom_1 (ADDR_EXPR,
c7e4ee3a 1598 build_pointer_type (TREE_TYPE (tempvar)),
5ff904cd
JL		 1599 tempvar));
1600 TREE_CHAIN (item) = args;
1601
1602 item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1603 item, NULL_TREE);
1604
1605 if (tempvar != dest_tree)
1606 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1607 }
1608 else
1609 item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1610 args, NULL_TREE);
1611
1612 if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1613 item = ffecom_convert_narrow_ (type, item);
1614
1615 return item;
1616}
1617#endif
1618
1619/* Given two arguments, transform them and make a call to the given
1620 function via ffecom_call_. */
1621
1622#if FFECOM_targetCURRENT == FFECOM_targetGCC
1623static tree
1624ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1625 tree type, ffebld left, ffebld right,
1626 tree dest_tree, ffebld dest, bool *dest_used,
c7e4ee3a 1627 tree callee_commons, bool scalar_args, tree hook)
5ff904cd
JL		 1628{
1629 tree left_tree;
1630 tree right_tree;
1631 tree left_length;
1632 tree right_length;
1633
5ff904cd
JL		 1634 left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1635 right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
5ff904cd
JL		 1636
1637 left_tree = build_tree_list (NULL_TREE, left_tree);
1638 right_tree = build_tree_list (NULL_TREE, right_tree);
1639 TREE_CHAIN (left_tree) = right_tree;
1640
1641 if (left_length != NULL_TREE)
1642 {
1643 left_length = build_tree_list (NULL_TREE, left_length);
1644 TREE_CHAIN (right_tree) = left_length;
1645 }
1646
1647 if (right_length != NULL_TREE)
1648 {
1649 right_length = build_tree_list (NULL_TREE, right_length);
1650 if (left_length != NULL_TREE)
1651 TREE_CHAIN (left_length) = right_length;
1652 else
1653 TREE_CHAIN (right_tree) = right_length;
1654 }
1655
1656 return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1657 dest_tree, dest, dest_used, callee_commons,
c7e4ee3a 1658 scalar_args, hook);
5ff904cd
JL		 1659}
1660#endif
1661
c7e4ee3a 1662/* Return ptr/length args for char subexpression
5ff904cd
JL		 1663
1664 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1665 subexpressions by constructing the appropriate trees for the ptr-to-
1666 character-text and length-of-character-text arguments in a calling
86fc7a6c
CB		 1667 sequence.
1668
1669 Note that if with_null is TRUE, and the expression is an opCONTER,
1670 a null byte is appended to the string. */
5ff904cd
JL		 1671
1672#if FFECOM_targetCURRENT == FFECOM_targetGCC
1673static void
86fc7a6c 1674ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
5ff904cd
JL		 1675{
1676 tree item;
1677 tree high;
1678 ffetargetCharacter1 val;
86fc7a6c 1679 ffetargetCharacterSize newlen;
5ff904cd
JL		 1680
1681 switch (ffebld_op (expr))
1682 {
1683 case FFEBLD_opCONTER:
1684 val = ffebld_constant_character1 (ffebld_conter (expr));
86fc7a6c
CB		 1685 newlen = ffetarget_length_character1 (val);
1686 if (with_null)
1687 {
c7e4ee3a 1688 /* Begin FFETARGET-NULL-KLUDGE. */
86fc7a6c 1689 if (newlen != 0)
c7e4ee3a 1690 ++newlen;
86fc7a6c
CB		 1691 }
1692 *length = build_int_2 (newlen, 0);
5ff904cd 1693 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
86fc7a6c 1694 high = build_int_2 (newlen, 0);
5ff904cd 1695 TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
c7e4ee3a 1696 item = build_string (newlen,
5ff904cd 1697 ffetarget_text_character1 (val));
c7e4ee3a 1698 /* End FFETARGET-NULL-KLUDGE. */
5ff904cd
JL		 1699 TREE_TYPE (item)
1700 = build_type_variant
1701 (build_array_type
1702 (char_type_node,
1703 build_range_type
1704 (ffecom_f2c_ftnlen_type_node,
1705 ffecom_f2c_ftnlen_one_node,
1706 high)),
1707 1, 0);
1708 TREE_CONSTANT (item) = 1;
1709 TREE_STATIC (item) = 1;
1710 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1711 item);
1712 break;
1713
1714 case FFEBLD_opSYMTER:
1715 {
1716 ffesymbol s = ffebld_symter (expr);
1717
1718 item = ffesymbol_hook (s).decl_tree;
1719 if (item == NULL_TREE)
1720 {
1721 s = ffecom_sym_transform_ (s);
1722 item = ffesymbol_hook (s).decl_tree;
1723 }
1724 if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1725 {
1726 if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1727 *length = ffesymbol_hook (s).length_tree;
1728 else
1729 {
1730 *length = build_int_2 (ffesymbol_size (s), 0);
1731 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1732 }
1733 }
1734 else if (item == error_mark_node)
1735 *length = error_mark_node;
c7e4ee3a
CB		 1736 else
1737 /* FFEINFO_kindFUNCTION. */
5ff904cd
JL		 1738 *length = NULL_TREE;
1739 if (!ffesymbol_hook (s).addr
1740 && (item != error_mark_node))
1741 item = ffecom_1 (ADDR_EXPR,
1742 build_pointer_type (TREE_TYPE (item)),
1743 item);
1744 }
1745 break;
1746
1747 case FFEBLD_opARRAYREF:
1748 {
1749 ffebld dims[FFECOM_dimensionsMAX];
1750 tree array;
1751 int i;
1752
5ff904cd 1753 ffecom_char_args_ (&item, length, ffebld_left (expr));
5ff904cd
JL		 1754
1755 if (item == error_mark_node || *length == error_mark_node)
1756 {
1757 item = *length = error_mark_node;
1758 break;
1759 }
1760
1761 /* Build up ARRAY_REFs in reverse order (since we're column major
1762 here in Fortran land). */
1763
1764 for (i = 0, expr = ffebld_right (expr);
1765 expr != NULL;
1766 expr = ffebld_trail (expr))
1767 dims[i++] = ffebld_head (expr);
1768
1769 for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
1770 i >= 0;
1771 --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
1772 {
1773 item = ffecom_2 (PLUS_EXPR, build_pointer_type (TREE_TYPE (array)),
1774 item,
1775 size_binop (MULT_EXPR,
1776 size_in_bytes (TREE_TYPE (array)),
1777 size_binop (MINUS_EXPR,
1778 ffecom_expr (dims[i]),
1779 TYPE_MIN_VALUE (TYPE_DOMAIN (array)))));
1780 }
1781 }
1782 break;
1783
1784 case FFEBLD_opSUBSTR:
1785 {
1786 ffebld start;
1787 ffebld end;
1788 ffebld thing = ffebld_right (expr);
1789 tree start_tree;
1790 tree end_tree;
1791
1792 assert (ffebld_op (thing) == FFEBLD_opITEM);
1793 start = ffebld_head (thing);
1794 thing = ffebld_trail (thing);
1795 assert (ffebld_trail (thing) == NULL);
1796 end = ffebld_head (thing);
1797
5ff904cd 1798 ffecom_char_args_ (&item, length, ffebld_left (expr));
5ff904cd
JL		 1799
1800 if (item == error_mark_node || *length == error_mark_node)
1801 {
1802 item = *length = error_mark_node;
1803 break;
1804 }
1805
1806 if (start == NULL)
1807 {
1808 if (end == NULL)
1809 ;
1810 else
1811 {
1812 end_tree = convert (ffecom_f2c_ftnlen_type_node,
1813 ffecom_expr (end));
1814
1815 if (end_tree == error_mark_node)
1816 {
1817 item = *length = error_mark_node;
1818 break;
1819 }
1820
1821 *length = end_tree;
1822 }
1823 }
1824 else
1825 {
1826 start_tree = convert (ffecom_f2c_ftnlen_type_node,
1827 ffecom_expr (start));
1828
1829 if (start_tree == error_mark_node)
1830 {
1831 item = *length = error_mark_node;
1832 break;
1833 }
1834
1835 start_tree = ffecom_save_tree (start_tree);
1836
1837 item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
1838 item,
1839 ffecom_2 (MINUS_EXPR,
1840 TREE_TYPE (start_tree),
1841 start_tree,
1842 ffecom_f2c_ftnlen_one_node));
1843
1844 if (end == NULL)
1845 {
1846 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
1847 ffecom_f2c_ftnlen_one_node,
1848 ffecom_2 (MINUS_EXPR,
1849 ffecom_f2c_ftnlen_type_node,
1850 *length,
1851 start_tree));
1852 }
1853 else
1854 {
1855 end_tree = convert (ffecom_f2c_ftnlen_type_node,
1856 ffecom_expr (end));
1857
1858 if (end_tree == error_mark_node)
1859 {
1860 item = *length = error_mark_node;
1861 break;
1862 }
1863
1864 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
1865 ffecom_f2c_ftnlen_one_node,
1866 ffecom_2 (MINUS_EXPR,
1867 ffecom_f2c_ftnlen_type_node,
1868 end_tree, start_tree));
1869 }
1870 }
1871 }
1872 break;
1873
1874 case FFEBLD_opFUNCREF:
1875 {
1876 ffesymbol s = ffebld_symter (ffebld_left (expr));
1877 tree tempvar;
1878 tree args;
1879 ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
1880 ffecomGfrt ix;
1881
1882 if (size == FFETARGET_charactersizeNONE)
c7e4ee3a
CB		 1883 /* ~~Kludge alert! This should someday be fixed. */
1884 size = 24;
5ff904cd
JL		 1885
1886 *length = build_int_2 (size, 0);
1887 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1888
1889 if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
1890 == FFEINFO_whereINTRINSIC)
1891 {
1892 if (size == 1)
c7e4ee3a
CB		 1893 {
1894 /* Invocation of an intrinsic returning CHARACTER*1. */
5ff904cd
JL		 1895 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
1896 NULL, NULL);
1897 break;
1898 }
1899 ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
1900 assert (ix != FFECOM_gfrt);
1901 item = ffecom_gfrt_tree_ (ix);
1902 }
1903 else
1904 {
1905 ix = FFECOM_gfrt;
1906 item = ffesymbol_hook (s).decl_tree;
1907 if (item == NULL_TREE)
1908 {
1909 s = ffecom_sym_transform_ (s);
1910 item = ffesymbol_hook (s).decl_tree;
1911 }
1912 if (item == error_mark_node)
1913 {
1914 item = *length = error_mark_node;
1915 break;
1916 }
1917
1918 if (!ffesymbol_hook (s).addr)
1919 item = ffecom_1_fn (item);
1920 }
1921
c7e4ee3a 1922#ifdef HOHO
5ff904cd 1923 tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
c7e4ee3a
CB		 1924#else
1925 tempvar = ffebld_nonter_hook (expr);
1926 assert (tempvar);
1927#endif
5ff904cd
JL		 1928 tempvar = ffecom_1 (ADDR_EXPR,
1929 build_pointer_type (TREE_TYPE (tempvar)),
1930 tempvar);
1931
5ff904cd
JL		 1932 args = build_tree_list (NULL_TREE, tempvar);
1933
1934 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) /* Sfunc args by value. */
1935 TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
1936 else
1937 {
1938 TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
1939 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
1940 {
1941 TREE_CHAIN (TREE_CHAIN (args))
1942 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
1943 ffebld_right (expr));
1944 }
1945 else
1946 {
1947 TREE_CHAIN (TREE_CHAIN (args))
1948 = ffecom_list_ptr_to_expr (ffebld_right (expr));
1949 }
1950 }
1951
1952 item = ffecom_3s (CALL_EXPR,
1953 TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
1954 item, args, NULL_TREE);
1955 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
1956 tempvar);
5ff904cd
JL		 1957 }
1958 break;
1959
1960 case FFEBLD_opCONVERT:
1961
5ff904cd 1962 ffecom_char_args_ (&item, length, ffebld_left (expr));
5ff904cd
JL		 1963
1964 if (item == error_mark_node || *length == error_mark_node)
1965 {
1966 item = *length = error_mark_node;
1967 break;
1968 }
1969
1970 if ((ffebld_size_known (ffebld_left (expr))
1971 == FFETARGET_charactersizeNONE)
1972 || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
1973 { /* Possible blank-padding needed, copy into
1974 temporary. */
1975 tree tempvar;
1976 tree args;
1977 tree newlen;
1978
c7e4ee3a
CB		 1979#ifdef HOHO
1980 tempvar = ffecom_make_tempvar (char_type_node,
1981 ffebld_size (expr), -1);
1982#else
1983 tempvar = ffebld_nonter_hook (expr);
1984 assert (tempvar);
1985#endif
5ff904cd
JL		 1986 tempvar = ffecom_1 (ADDR_EXPR,
1987 build_pointer_type (TREE_TYPE (tempvar)),
1988 tempvar);
1989
1990 newlen = build_int_2 (ffebld_size (expr), 0);
1991 TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
1992
1993 args = build_tree_list (NULL_TREE, tempvar);
1994 TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
1995 TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
1996 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
1997 = build_tree_list (NULL_TREE, *length);
1998
c7e4ee3a 1999 item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
5ff904cd
JL		 2000 TREE_SIDE_EFFECTS (item) = 1;
2001 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2002 tempvar);
2003 *length = newlen;
2004 }
2005 else
2006 { /* Just truncate the length. */
2007 *length = build_int_2 (ffebld_size (expr), 0);
2008 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2009 }
2010 break;
2011
2012 default:
2013 assert ("bad op for single char arg expr" == NULL);
2014 item = NULL_TREE;
2015 break;
2016 }
2017
2018 *xitem = item;
2019}
2020#endif
2021
2022/* Check the size of the type to be sure it doesn't overflow the
2023 "portable" capacities of the compiler back end. `dummy' types
2024 can generally overflow the normal sizes as long as the computations
2025 themselves don't overflow. A particular target of the back end
2026 must still enforce its size requirements, though, and the back
2027 end takes care of this in stor-layout.c. */
2028
2029#if FFECOM_targetCURRENT == FFECOM_targetGCC
2030static tree
2031ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2032{
2033 if (TREE_CODE (type) == ERROR_MARK)
2034 return type;
2035
2036 if (TYPE_SIZE (type) == NULL_TREE)
2037 return type;
2038
2039 if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2040 return type;
2041
2042 if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2b0c2df0
CB		 2043 || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2044 || TREE_OVERFLOW (TYPE_SIZE (type)))))
5ff904cd
JL		 2045 {
2046 ffebad_start (FFEBAD_ARRAY_LARGE);
2047 ffebad_string (ffesymbol_text (s));
2048 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2049 ffebad_finish ();
2050
2051 return error_mark_node;
2052 }
2053
2054 return type;
2055}
2056#endif
2057
2058/* Builds a length argument (PARM_DECL). Also wraps type in an array type
2059 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2060 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2061
2062#if FFECOM_targetCURRENT == FFECOM_targetGCC
2063static tree
2064ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2065{
2066 ffetargetCharacterSize sz = ffesymbol_size (s);
2067 tree highval;
2068 tree tlen;
2069 tree type = *xtype;
2070
2071 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2072 tlen = NULL_TREE; /* A statement function, no length passed. */
2073 else
2074 {
2075 if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2076 tlen = ffecom_get_invented_identifier ("__g77_length_%s",
c7e4ee3a 2077 ffesymbol_text (s), -1);
5ff904cd
JL		 2078 else
2079 tlen = ffecom_get_invented_identifier ("__g77_%s",
c7e4ee3a 2080 "length", -1);
5ff904cd
JL		 2081 tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2082#if BUILT_FOR_270
2083 DECL_ARTIFICIAL (tlen) = 1;
2084#endif
2085 }
2086
2087 if (sz == FFETARGET_charactersizeNONE)
2088 {
2089 assert (tlen != NULL_TREE);
2b0c2df0 2090 highval = variable_size (tlen);
5ff904cd
JL		 2091 }
2092 else
2093 {
2094 highval = build_int_2 (sz, 0);
2095 TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2096 }
2097
2098 type = build_array_type (type,
2099 build_range_type (ffecom_f2c_ftnlen_type_node,
2100 ffecom_f2c_ftnlen_one_node,
2101 highval));
2102
2103 *xtype = type;
2104 return tlen;
2105}
2106
2107#endif
2108/* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2109
2110 ffecomConcatList_ catlist;
2111 ffebld expr; // expr of CHARACTER basictype.
2112 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2113 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2114
2115 Scans expr for character subexpressions, updates and returns catlist
2116 accordingly. */
2117
2118#if FFECOM_targetCURRENT == FFECOM_targetGCC
2119static ffecomConcatList_
2120ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2121 ffetargetCharacterSize max)
2122{
2123 ffetargetCharacterSize sz;
2124
2125recurse: /* :::::::::::::::::::: */
2126
2127 if (expr == NULL)
2128 return catlist;
2129
2130 if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2131 return catlist; /* Don't append any more items. */
2132
2133 switch (ffebld_op (expr))
2134 {
2135 case FFEBLD_opCONTER:
2136 case FFEBLD_opSYMTER:
2137 case FFEBLD_opARRAYREF:
2138 case FFEBLD_opFUNCREF:
2139 case FFEBLD_opSUBSTR:
2140 case FFEBLD_opCONVERT: /* Callers should strip this off beforehand
2141 if they don't need to preserve it. */
2142 if (catlist.count == catlist.max)
2143 { /* Make a (larger) list. */
2144 ffebld *newx;
2145 int newmax;
2146
2147 newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2148 newx = malloc_new_ks (malloc_pool_image (), "catlist",
2149 newmax * sizeof (newx[0]));
2150 if (catlist.max != 0)
2151 {
2152 memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2153 malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2154 catlist.max * sizeof (newx[0]));
2155 }
2156 catlist.max = newmax;
2157 catlist.exprs = newx;
2158 }
2159 if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2160 catlist.minlen += sz;
2161 else
2162 ++catlist.minlen; /* Not true for F90; can be 0 length. */
2163 if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2164 catlist.maxlen = sz;
2165 else
2166 catlist.maxlen += sz;
2167 if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2168 { /* This item overlaps (or is beyond) the end
2169 of the destination. */
2170 switch (ffebld_op (expr))
2171 {
2172 case FFEBLD_opCONTER:
2173 case FFEBLD_opSYMTER:
2174 case FFEBLD_opARRAYREF:
2175 case FFEBLD_opFUNCREF:
2176 case FFEBLD_opSUBSTR:
c7e4ee3a
CB		 2177 /* ~~Do useful truncations here. */
2178 break;
5ff904cd
JL		 2179
2180 default:
2181 assert ("op changed or inconsistent switches!" == NULL);
2182 break;
2183 }
2184 }
2185 catlist.exprs[catlist.count++] = expr;
2186 return catlist;
2187
2188 case FFEBLD_opPAREN:
2189 expr = ffebld_left (expr);
2190 goto recurse; /* :::::::::::::::::::: */
2191
2192 case FFEBLD_opCONCATENATE:
2193 catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2194 expr = ffebld_right (expr);
2195 goto recurse; /* :::::::::::::::::::: */
2196
2197#if 0 /* Breaks passing small actual arg to larger
2198 dummy arg of sfunc */
2199 case FFEBLD_opCONVERT:
2200 expr = ffebld_left (expr);
2201 {
2202 ffetargetCharacterSize cmax;
2203
2204 cmax = catlist.len + ffebld_size_known (expr);
2205
2206 if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2207 max = cmax;
2208 }
2209 goto recurse; /* :::::::::::::::::::: */
2210#endif
2211
2212 case FFEBLD_opANY:
2213 return catlist;
2214
2215 default:
2216 assert ("bad op in _gather_" == NULL);
2217 return catlist;
2218 }
2219}
2220
2221#endif
2222/* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2223
2224 ffecomConcatList_ catlist;
2225 ffecom_concat_list_kill_(catlist);
2226
2227 Anything allocated within the list info is deallocated. */
2228
2229#if FFECOM_targetCURRENT == FFECOM_targetGCC
2230static void
2231ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2232{
2233 if (catlist.max != 0)
2234 malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2235 catlist.max * sizeof (catlist.exprs[0]));
2236}
2237
2238#endif
c7e4ee3a 2239/* Make list of concatenated string exprs.
5ff904cd
JL		 2240
2241 Returns a flattened list of concatenated subexpressions given a
2242 tree of such expressions. */
2243
2244#if FFECOM_targetCURRENT == FFECOM_targetGCC
2245static ffecomConcatList_
2246ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2247{
2248 ffecomConcatList_ catlist;
2249
2250 catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2251 return ffecom_concat_list_gather_ (catlist, expr, max);
2252}
2253
2254#endif
2255
2256/* Provide some kind of useful info on member of aggregate area,
2257 since current g77/gcc technology does not provide debug info
2258 on these members. */
2259
2260#if FFECOM_targetCURRENT == FFECOM_targetGCC
2261static void
26f096f9 2262ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
5ff904cd
JL		 2263 tree member_type UNUSED, ffetargetOffset offset)
2264{
2265 tree value;
2266 tree decl;
2267 int len;
2268 char *buff;
2269 char space[120];
2270#if 0
2271 tree type_id;
2272
2273 for (type_id = member_type;
2274 TREE_CODE (type_id) != IDENTIFIER_NODE;
2275 )
2276 {
2277 switch (TREE_CODE (type_id))
2278 {
2279 case INTEGER_TYPE:
2280 case REAL_TYPE:
2281 type_id = TYPE_NAME (type_id);
2282 break;
2283
2284 case ARRAY_TYPE:
2285 case COMPLEX_TYPE:
2286 type_id = TREE_TYPE (type_id);
2287 break;
2288
2289 default:
2290 assert ("no IDENTIFIER_NODE for type!" == NULL);
2291 type_id = error_mark_node;
2292 break;
2293 }
2294 }
2295#endif
2296
2297 if (ffecom_transform_only_dummies_
2298 || !ffe_is_debug_kludge ())
2299 return; /* Can't do this yet, maybe later. */
2300
2301 len = 60
2302 + strlen (aggr_type)
2303 + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2304#if 0
2305 + IDENTIFIER_LENGTH (type_id);
2306#endif
2307
2308 if (((size_t) len) >= ARRAY_SIZE (space))
2309 buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2310 else
2311 buff = &space[0];
2312
2313 sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2314 aggr_type,
2315 IDENTIFIER_POINTER (DECL_NAME (aggr)),
2316 (long int) offset);
2317
2318 value = build_string (len, buff);
2319 TREE_TYPE (value)
2320 = build_type_variant (build_array_type (char_type_node,
2321 build_range_type
2322 (integer_type_node,
2323 integer_one_node,
2324 build_int_2 (strlen (buff), 0))),
2325 1, 0);
2326 decl = build_decl (VAR_DECL,
2327 ffecom_get_identifier_ (ffesymbol_text (member)),
2328 TREE_TYPE (value));
2329 TREE_CONSTANT (decl) = 1;
2330 TREE_STATIC (decl) = 1;
2331 DECL_INITIAL (decl) = error_mark_node;
2332 DECL_IN_SYSTEM_HEADER (decl) = 1; /* Don't let -Wunused complain. */
2333 decl = start_decl (decl, FALSE);
2334 finish_decl (decl, value, FALSE);
2335
2336 if (buff != &space[0])
2337 malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2338}
2339#endif
2340
2341/* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2342
2343 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2344 int i; // entry# for this entrypoint (used by master fn)
2345 ffecom_do_entrypoint_(s,i);
2346
2347 Makes a public entry point that calls our private master fn (already
2348 compiled). */
2349
2350#if FFECOM_targetCURRENT == FFECOM_targetGCC
2351static void
2352ffecom_do_entry_ (ffesymbol fn, int entrynum)
2353{
2354 ffebld item;
2355 tree type; /* Type of function. */
2356 tree multi_retval; /* Var holding return value (union). */
2357 tree result; /* Var holding result. */
2358 ffeinfoBasictype bt;
2359 ffeinfoKindtype kt;
2360 ffeglobal g;
2361 ffeglobalType gt;
2362 bool charfunc; /* All entry points return same type
2363 CHARACTER. */
2364 bool cmplxfunc; /* Use f2c way of returning COMPLEX. */
2365 bool multi; /* Master fn has multiple return types. */
2366 bool altreturning = FALSE; /* This entry point has alternate returns. */
2367 int yes;
44d2eabc
JL		 2368 int old_lineno = lineno;
2369 char *old_input_filename = input_filename;
2370
2371 input_filename = ffesymbol_where_filename (fn);
2372 lineno = ffesymbol_where_filelinenum (fn);
5ff904cd
JL		 2373
2374 /* c-parse.y indeed does call suspend_momentary and not only ignores the
2375 return value, but also never calls resume_momentary, when starting an
2376 outer function (see "fndef:", "setspecs:", and so on). So g77 does the
2377 same thing. It shouldn't be a problem since start_function calls
2378 temporary_allocation, but it might be necessary. If it causes a problem
2379 here, then maybe there's a bug lurking in gcc. NOTE: This identical
2380 comment appears twice in thist file. */
2381
2382 suspend_momentary ();
2383
2384 ffecom_doing_entry_ = TRUE; /* Don't bother with array dimensions. */
2385
2386 switch (ffecom_primary_entry_kind_)
2387 {
2388 case FFEINFO_kindFUNCTION:
2389
2390 /* Determine actual return type for function. */
2391
2392 gt = FFEGLOBAL_typeFUNC;
2393 bt = ffesymbol_basictype (fn);
2394 kt = ffesymbol_kindtype (fn);
2395 if (bt == FFEINFO_basictypeNONE)
2396 {
2397 ffeimplic_establish_symbol (fn);
2398 if (ffesymbol_funcresult (fn) != NULL)
2399 ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2400 bt = ffesymbol_basictype (fn);
2401 kt = ffesymbol_kindtype (fn);
2402 }
2403
2404 if (bt == FFEINFO_basictypeCHARACTER)
2405 charfunc = TRUE, cmplxfunc = FALSE;
2406 else if ((bt == FFEINFO_basictypeCOMPLEX)
2407 && ffesymbol_is_f2c (fn))
2408 charfunc = FALSE, cmplxfunc = TRUE;
2409 else
2410 charfunc = cmplxfunc = FALSE;
2411
2412 if (charfunc)
2413 type = ffecom_tree_fun_type_void;
2414 else if (ffesymbol_is_f2c (fn))
2415 type = ffecom_tree_fun_type[bt][kt];
2416 else
2417 type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2418
2419 if ((type == NULL_TREE)
2420 || (TREE_TYPE (type) == NULL_TREE))
2421 type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
2422
2423 multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2424 break;
2425
2426 case FFEINFO_kindSUBROUTINE:
2427 gt = FFEGLOBAL_typeSUBR;
2428 bt = FFEINFO_basictypeNONE;
2429 kt = FFEINFO_kindtypeNONE;
2430 if (ffecom_is_altreturning_)
2431 { /* Am _I_ altreturning? */
2432 for (item = ffesymbol_dummyargs (fn);
2433 item != NULL;
2434 item = ffebld_trail (item))
2435 {
2436 if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2437 {
2438 altreturning = TRUE;
2439 break;
2440 }
2441 }
2442 if (altreturning)
2443 type = ffecom_tree_subr_type;
2444 else
2445 type = ffecom_tree_fun_type_void;
2446 }
2447 else
2448 type = ffecom_tree_fun_type_void;
2449 charfunc = FALSE;
2450 cmplxfunc = FALSE;
2451 multi = FALSE;
2452 break;
2453
2454 default:
2455 assert ("say what??" == NULL);
2456 /* Fall through. */
2457 case FFEINFO_kindANY:
2458 gt = FFEGLOBAL_typeANY;
2459 bt = FFEINFO_basictypeNONE;
2460 kt = FFEINFO_kindtypeNONE;
2461 type = error_mark_node;
2462 charfunc = FALSE;
2463 cmplxfunc = FALSE;
2464 multi = FALSE;
2465 break;
2466 }
2467
2468 /* build_decl uses the current lineno and input_filename to set the decl
2469 source info. So, I've putzed with ffestd and ffeste code to update that
2470 source info to point to the appropriate statement just before calling
2471 ffecom_do_entrypoint (which calls this fn). */
2472
2473 start_function (ffecom_get_external_identifier_ (fn),
2474 type,
2475 0, /* nested/inline */
2476 1); /* TREE_PUBLIC */
2477
2478 if (((g = ffesymbol_global (fn)) != NULL)
2479 && ((ffeglobal_type (g) == gt)
2480 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2481 {
2482 ffeglobal_set_hook (g, current_function_decl);
2483 }
2484
2485 /* Reset args in master arg list so they get retransitioned. */
2486
2487 for (item = ffecom_master_arglist_;
2488 item != NULL;
2489 item = ffebld_trail (item))
2490 {
2491 ffebld arg;
2492 ffesymbol s;
2493
2494 arg = ffebld_head (item);
2495 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2496 continue; /* Alternate return or some such thing. */
2497 s = ffebld_symter (arg);
2498 ffesymbol_hook (s).decl_tree = NULL_TREE;
2499 ffesymbol_hook (s).length_tree = NULL_TREE;
2500 }
2501
2502 /* Build dummy arg list for this entry point. */
2503
2504 yes = suspend_momentary ();
2505
2506 if (charfunc || cmplxfunc)
2507 { /* Prepend arg for where result goes. */
2508 tree type;
2509 tree length;
2510
2511 if (charfunc)
2512 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2513 else
2514 type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2515
2516 result = ffecom_get_invented_identifier ("__g77_%s",
c7e4ee3a 2517 "result", -1);
5ff904cd
JL		 2518
2519 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2520
2521 if (charfunc)
2522 length = ffecom_char_enhance_arg_ (&type, fn);
2523 else
2524 length = NULL_TREE; /* Not ref'd if !charfunc. */
2525
2526 type = build_pointer_type (type);
2527 result = build_decl (PARM_DECL, result, type);
2528
2529 push_parm_decl (result);
2530 ffecom_func_result_ = result;
2531
2532 if (charfunc)
2533 {
2534 push_parm_decl (length);
2535 ffecom_func_length_ = length;
2536 }
2537 }
2538 else
2539 result = DECL_RESULT (current_function_decl);
2540
2541 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2542
2543 resume_momentary (yes);
2544
2545 store_parm_decls (0);
2546
c7e4ee3a
CB		 2547 ffecom_start_compstmt ();
2548 /* Disallow temp vars at this level. */
2549 current_binding_level->prep_state = 2;
5ff904cd
JL		 2550
2551 /* Make local var to hold return type for multi-type master fn. */
2552
2553 if (multi)
2554 {
2555 yes = suspend_momentary ();
2556
2557 multi_retval = ffecom_get_invented_identifier ("__g77_%s",
c7e4ee3a 2558 "multi_retval", -1);
5ff904cd
JL		 2559 multi_retval = build_decl (VAR_DECL, multi_retval,
2560 ffecom_multi_type_node_);
2561 multi_retval = start_decl (multi_retval, FALSE);
2562 finish_decl (multi_retval, NULL_TREE, FALSE);
2563
2564 resume_momentary (yes);
2565 }
2566 else
2567 multi_retval = NULL_TREE; /* Not actually ref'd if !multi. */
2568
2569 /* Here we emit the actual code for the entry point. */
2570
2571 {
2572 ffebld list;
2573 ffebld arg;
2574 ffesymbol s;
2575 tree arglist = NULL_TREE;
2576 tree *plist = &arglist;
2577 tree prepend;
2578 tree call;
2579 tree actarg;
2580 tree master_fn;
2581
2582 /* Prepare actual arg list based on master arg list. */
2583
2584 for (list = ffecom_master_arglist_;
2585 list != NULL;
2586 list = ffebld_trail (list))
2587 {
2588 arg = ffebld_head (list);
2589 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2590 continue;
2591 s = ffebld_symter (arg);
702edf1d
CB		 2592 if (ffesymbol_hook (s).decl_tree == NULL_TREE
2593 || ffesymbol_hook (s).decl_tree == error_mark_node)
5ff904cd
JL		 2594 actarg = null_pointer_node; /* We don't have this arg. */
2595 else
2596 actarg = ffesymbol_hook (s).decl_tree;
2597 *plist = build_tree_list (NULL_TREE, actarg);
2598 plist = &TREE_CHAIN (*plist);
2599 }
2600
2601 /* This code appends the length arguments for character
2602 variables/arrays. */
2603
2604 for (list = ffecom_master_arglist_;
2605 list != NULL;
2606 list = ffebld_trail (list))
2607 {
2608 arg = ffebld_head (list);
2609 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2610 continue;
2611 s = ffebld_symter (arg);
2612 if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2613 continue; /* Only looking for CHARACTER arguments. */
2614 if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2615 continue; /* Only looking for variables and arrays. */
702edf1d
CB		 2616 if (ffesymbol_hook (s).length_tree == NULL_TREE
2617 || ffesymbol_hook (s).length_tree == error_mark_node)
5ff904cd
JL		 2618 actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2619 else
2620 actarg = ffesymbol_hook (s).length_tree;
2621 *plist = build_tree_list (NULL_TREE, actarg);
2622 plist = &TREE_CHAIN (*plist);
2623 }
2624
2625 /* Prepend character-value return info to actual arg list. */
2626
2627 if (charfunc)
2628 {
2629 prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2630 TREE_CHAIN (prepend)
2631 = build_tree_list (NULL_TREE, ffecom_func_length_);
2632 TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2633 arglist = prepend;
2634 }
2635
2636 /* Prepend multi-type return value to actual arg list. */
2637
2638 if (multi)
2639 {
2640 prepend
2641 = build_tree_list (NULL_TREE,
2642 ffecom_1 (ADDR_EXPR,
2643 build_pointer_type (TREE_TYPE (multi_retval)),
2644 multi_retval));
2645 TREE_CHAIN (prepend) = arglist;
2646 arglist = prepend;
2647 }
2648
2649 /* Prepend my entry-point number to the actual arg list. */
2650
2651 prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2652 TREE_CHAIN (prepend) = arglist;
2653 arglist = prepend;
2654
2655 /* Build the call to the master function. */
2656
2657 master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2658 call = ffecom_3s (CALL_EXPR,
2659 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2660 master_fn, arglist, NULL_TREE);
2661
2662 /* Decide whether the master function is a function or subroutine, and
2663 handle the return value for my entry point. */
2664
2665 if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2666 && !altreturning))
2667 {
2668 expand_expr_stmt (call);
2669 expand_null_return ();
2670 }
2671 else if (multi && cmplxfunc)
2672 {
2673 expand_expr_stmt (call);
2674 result
2675 = ffecom_1 (INDIRECT_REF,
2676 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2677 result);
2678 result = ffecom_modify (NULL_TREE, result,
2679 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2680 multi_retval,
2681 ffecom_multi_fields_[bt][kt]));
2682 expand_expr_stmt (result);
2683 expand_null_return ();
2684 }
2685 else if (multi)
2686 {
2687 expand_expr_stmt (call);
2688 result
2689 = ffecom_modify (NULL_TREE, result,
2690 convert (TREE_TYPE (result),
2691 ffecom_2 (COMPONENT_REF,
2692 ffecom_tree_type[bt][kt],
2693 multi_retval,
2694 ffecom_multi_fields_[bt][kt])));
2695 expand_return (result);
2696 }
2697 else if (cmplxfunc)
2698 {
2699 result
2700 = ffecom_1 (INDIRECT_REF,
2701 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2702 result);
2703 result = ffecom_modify (NULL_TREE, result, call);
2704 expand_expr_stmt (result);
2705 expand_null_return ();
2706 }
2707 else
2708 {
2709 result = ffecom_modify (NULL_TREE,
2710 result,
2711 convert (TREE_TYPE (result),
2712 call));
2713 expand_return (result);
2714 }
2715
2716 clear_momentary ();
2717 }
2718
c7e4ee3a 2719 ffecom_end_compstmt ();
5ff904cd
JL		 2720
2721 finish_function (0);
2722
44d2eabc
JL		 2723 lineno = old_lineno;
2724 input_filename = old_input_filename;
2725
5ff904cd
JL		 2726 ffecom_doing_entry_ = FALSE;
2727}
2728
2729#endif
2730/* Transform expr into gcc tree with possible destination
2731
2732 Recursive descent on expr while making corresponding tree nodes and
2733 attaching type info and such. If destination supplied and compatible
2734 with temporary that would be made in certain cases, temporary isn't
092a4ef8 2735 made, destination used instead, and dest_used flag set TRUE. */
5ff904cd
JL		 2736
2737#if FFECOM_targetCURRENT == FFECOM_targetGCC
2738static tree
092a4ef8
RH		 2739ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2740 bool *dest_used, bool assignp, bool widenp)
5ff904cd
JL		 2741{
2742 tree item;
2743 tree list;
2744 tree args;
2745 ffeinfoBasictype bt;
2746 ffeinfoKindtype kt;
2747 tree t;
5ff904cd 2748 tree dt; /* decl_tree for an ffesymbol. */
092a4ef8 2749 tree tree_type, tree_type_x;
af752698 2750 tree left, right;
5ff904cd
JL		 2751 ffesymbol s;
2752 enum tree_code code;
2753
2754 assert (expr != NULL);
2755
2756 if (dest_used != NULL)
2757 *dest_used = FALSE;
2758
2759 bt = ffeinfo_basictype (ffebld_info (expr));
2760 kt = ffeinfo_kindtype (ffebld_info (expr));
af752698 2761 tree_type = ffecom_tree_type[bt][kt];
5ff904cd 2762
092a4ef8
RH		 2763 /* Widen integral arithmetic as desired while preserving signedness. */
2764 tree_type_x = NULL_TREE;
2765 if (widenp && tree_type
2766 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2767 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2768 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2769
5ff904cd
JL		 2770 switch (ffebld_op (expr))
2771 {
2772 case FFEBLD_opACCTER:
5ff904cd
JL		 2773 {
2774 ffebitCount i;
2775 ffebit bits = ffebld_accter_bits (expr);
2776 ffetargetOffset source_offset = 0;
a6fa6420 2777 ffetargetOffset dest_offset = ffebld_accter_pad (expr);
5ff904cd
JL		 2778 tree purpose;
2779
a6fa6420
CB		 2780 assert (dest_offset == 0
2781 || (bt == FFEINFO_basictypeCHARACTER
2782 && kt == FFEINFO_kindtypeCHARACTER1));
5ff904cd
JL		 2783
2784 list = item = NULL;
2785 for (;;)
2786 {
2787 ffebldConstantUnion cu;
2788 ffebitCount length;
2789 bool value;
2790 ffebldConstantArray ca = ffebld_accter (expr);
2791
2792 ffebit_test (bits, source_offset, &value, &length);
2793 if (length == 0)
2794 break;
2795
2796 if (value)
2797 {
2798 for (i = 0; i < length; ++i)
2799 {
2800 cu = ffebld_constantarray_get (ca, bt, kt,
2801 source_offset + i);
2802
2803 t = ffecom_constantunion (&cu, bt, kt, tree_type);
2804
a6fa6420
CB		 2805 if (i == 0
2806 && dest_offset != 0)
2807 purpose = build_int_2 (dest_offset, 0);
5ff904cd
JL		 2808 else
2809 purpose = NULL_TREE;
2810
2811 if (list == NULL_TREE)
2812 list = item = build_tree_list (purpose, t);
2813 else
2814 {
2815 TREE_CHAIN (item) = build_tree_list (purpose, t);
2816 item = TREE_CHAIN (item);
2817 }
2818 }
2819 }
2820 source_offset += length;
a6fa6420 2821 dest_offset += length;
5ff904cd
JL		 2822 }
2823 }
2824
a6fa6420
CB		 2825 item = build_int_2 ((ffebld_accter_size (expr)
2826 + ffebld_accter_pad (expr)) - 1, 0);
5ff904cd
JL		 2827 ffebit_kill (ffebld_accter_bits (expr));
2828 TREE_TYPE (item) = ffecom_integer_type_node;
2829 item
2830 = build_array_type
2831 (tree_type,
2832 build_range_type (ffecom_integer_type_node,
2833 ffecom_integer_zero_node,
2834 item));
2835 list = build (CONSTRUCTOR, item, NULL_TREE, list);
2836 TREE_CONSTANT (list) = 1;
2837 TREE_STATIC (list) = 1;
2838 return list;
2839
2840 case FFEBLD_opARRTER:
5ff904cd
JL		 2841 {
2842 ffetargetOffset i;
2843
a6fa6420
CB		 2844 list = NULL_TREE;
2845 if (ffebld_arrter_pad (expr) == 0)
2846 item = NULL_TREE;
2847 else
2848 {
2849 assert (bt == FFEINFO_basictypeCHARACTER
2850 && kt == FFEINFO_kindtypeCHARACTER1);
2851
2852 /* Becomes PURPOSE first time through loop. */
2853 item = build_int_2 (ffebld_arrter_pad (expr), 0);
2854 }
2855
5ff904cd
JL		 2856 for (i = 0; i < ffebld_arrter_size (expr); ++i)
2857 {
2858 ffebldConstantUnion cu
2859 = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
2860
2861 t = ffecom_constantunion (&cu, bt, kt, tree_type);
2862
2863 if (list == NULL_TREE)
a6fa6420
CB		 2864 /* Assume item is PURPOSE first time through loop. */
2865 list = item = build_tree_list (item, t);
5ff904cd
JL		 2866 else
2867 {
2868 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
2869 item = TREE_CHAIN (item);
2870 }
2871 }
2872 }
2873
a6fa6420
CB		 2874 item = build_int_2 ((ffebld_arrter_size (expr)
2875 + ffebld_arrter_pad (expr)) - 1, 0);
5ff904cd
JL		 2876 TREE_TYPE (item) = ffecom_integer_type_node;
2877 item
2878 = build_array_type
2879 (tree_type,
2880 build_range_type (ffecom_integer_type_node,
a6fa6420 2881 ffecom_integer_zero_node,
5ff904cd
JL		 2882 item));
2883 list = build (CONSTRUCTOR, item, NULL_TREE, list);
2884 TREE_CONSTANT (list) = 1;
2885 TREE_STATIC (list) = 1;
2886 return list;
2887
2888 case FFEBLD_opCONTER:
c264f113 2889 assert (ffebld_conter_pad (expr) == 0);
5ff904cd
JL		 2890 item
2891 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
2892 bt, kt, tree_type);
2893 return item;
2894
2895 case FFEBLD_opSYMTER:
2896 if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
2897 || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
2898 return ffecom_ptr_to_expr (expr); /* Same as %REF(intrinsic). */
2899 s = ffebld_symter (expr);
2900 t = ffesymbol_hook (s).decl_tree;
2901
2902 if (assignp)
2903 { /* ASSIGN'ed-label expr. */
2904 if (ffe_is_ugly_assign ())
2905 {
2906 /* User explicitly wants ASSIGN'ed variables to be at the same
2907 memory address as the variables when used in non-ASSIGN
2908 contexts. That can make old, arcane, non-standard code
2909 work, but don't try to do it when a pointer wouldn't fit
2910 in the normal variable (take other approach, and warn,
2911 instead). */
2912
2913 if (t == NULL_TREE)
2914 {
2915 s = ffecom_sym_transform_ (s);
2916 t = ffesymbol_hook (s).decl_tree;
2917 assert (t != NULL_TREE);
2918 }
2919
2920 if (t == error_mark_node)
2921 return t;
2922
2923 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
2924 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
2925 {
2926 if (ffesymbol_hook (s).addr)
2927 t = ffecom_1 (INDIRECT_REF,
2928 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
2929 return t;
2930 }
2931
2932 if (ffesymbol_hook (s).assign_tree == NULL_TREE)
2933 {
2934 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
2935 FFEBAD_severityWARNING);
2936 ffebad_string (ffesymbol_text (s));
2937 ffebad_here (0, ffesymbol_where_line (s),
2938 ffesymbol_where_column (s));
2939 ffebad_finish ();
2940 }
2941 }
2942
2943 /* Don't use the normal variable's tree for ASSIGN, though mark
2944 it as in the system header (housekeeping). Use an explicit,
2945 specially created sibling that is known to be wide enough
2946 to hold pointers to labels. */
2947
2948 if (t != NULL_TREE
2949 && TREE_CODE (t) == VAR_DECL)
2950 DECL_IN_SYSTEM_HEADER (t) = 1; /* Don't let -Wunused complain. */
2951
2952 t = ffesymbol_hook (s).assign_tree;
2953 if (t == NULL_TREE)
2954 {
2955 s = ffecom_sym_transform_assign_ (s);
2956 t = ffesymbol_hook (s).assign_tree;
2957 assert (t != NULL_TREE);
2958 }
2959 }
2960 else
2961 {
2962 if (t == NULL_TREE)
2963 {
2964 s = ffecom_sym_transform_ (s);
2965 t = ffesymbol_hook (s).decl_tree;
2966 assert (t != NULL_TREE);
2967 }
2968 if (ffesymbol_hook (s).addr)
2969 t = ffecom_1 (INDIRECT_REF,
2970 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
2971 }
2972 return t;
2973
2974 case FFEBLD_opARRAYREF:
2975 {
2976 ffebld dims[FFECOM_dimensionsMAX];
2977#if FFECOM_FASTER_ARRAY_REFS
2978 tree array;
2979#endif
2980 int i;
2981
2982#if FFECOM_FASTER_ARRAY_REFS
2983 t = ffecom_ptr_to_expr (ffebld_left (expr));
2984#else
2985 t = ffecom_expr (ffebld_left (expr));
2986#endif
2987 if (t == error_mark_node)
2988 return t;
2989
2990 if ((ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING)
2991 && !mark_addressable (t))
2992 return error_mark_node; /* Make sure non-const ref is to
2993 non-reg. */
2994
2995 /* Build up ARRAY_REFs in reverse order (since we're column major
2996 here in Fortran land). */
2997
2998 for (i = 0, expr = ffebld_right (expr);
2999 expr != NULL;
3000 expr = ffebld_trail (expr))
3001 dims[i++] = ffebld_head (expr);
3002
3003#if FFECOM_FASTER_ARRAY_REFS
3004 for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t)));
3005 i >= 0;
3006 --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
3007 t = ffecom_2 (PLUS_EXPR,
3008 build_pointer_type (TREE_TYPE (array)),
3009 t,
3010 size_binop (MULT_EXPR,
3011 size_in_bytes (TREE_TYPE (array)),
3012 size_binop (MINUS_EXPR,
3013 ffecom_expr (dims[i]),
3014 TYPE_MIN_VALUE (TYPE_DOMAIN (array)))));
3015 t = ffecom_1 (INDIRECT_REF,
3016 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))),
3017 t);
3018#else
3019 while (i > 0)
3020 t = ffecom_2 (ARRAY_REF,
3021 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))),
3022 t,
092a4ef8 3023 ffecom_expr_ (dims[--i], NULL, NULL, NULL, FALSE, TRUE));
5ff904cd
JL		 3024#endif
3025
3026 return t;
3027 }
3028
3029 case FFEBLD_opUPLUS:
092a4ef8 3030 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
af752698 3031 return ffecom_1 (NOP_EXPR, tree_type, left);
5ff904cd 3032
c7e4ee3a
CB		 3033 case FFEBLD_opPAREN:
3034 /* ~~~Make sure Fortran rules respected here */
092a4ef8 3035 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
af752698 3036 return ffecom_1 (NOP_EXPR, tree_type, left);
5ff904cd
JL		 3037
3038 case FFEBLD_opUMINUS:
092a4ef8 3039 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
af752698
RH		 3040 if (tree_type_x)
3041 {
3042 tree_type = tree_type_x;
3043 left = convert (tree_type, left);
3044 }
3045 return ffecom_1 (NEGATE_EXPR, tree_type, left);
5ff904cd
JL		 3046
3047 case FFEBLD_opADD:
092a4ef8
RH		 3048 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3049 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
af752698
RH		 3050 if (tree_type_x)
3051 {
3052 tree_type = tree_type_x;
3053 left = convert (tree_type, left);
3054 right = convert (tree_type, right);
3055 }
3056 return ffecom_2 (PLUS_EXPR, tree_type, left, right);
5ff904cd
JL		 3057
3058 case FFEBLD_opSUBTRACT:
092a4ef8
RH		 3059 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3060 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
af752698
RH		 3061 if (tree_type_x)
3062 {
3063 tree_type = tree_type_x;
3064 left = convert (tree_type, left);
3065 right = convert (tree_type, right);
3066 }
3067 return ffecom_2 (MINUS_EXPR, tree_type, left, right);
5ff904cd
JL		 3068
3069 case FFEBLD_opMULTIPLY:
092a4ef8
RH		 3070 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3071 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
af752698
RH		 3072 if (tree_type_x)
3073 {
3074 tree_type = tree_type_x;
3075 left = convert (tree_type, left);
3076 right = convert (tree_type, right);
3077 }
3078 return ffecom_2 (MULT_EXPR, tree_type, left, right);
5ff904cd
JL		 3079
3080 case FFEBLD_opDIVIDE:
092a4ef8
RH		 3081 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3082 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
af752698
RH		 3083 if (tree_type_x)
3084 {
3085 tree_type = tree_type_x;
3086 left = convert (tree_type, left);
3087 right = convert (tree_type, right);
3088 }
3089 return ffecom_tree_divide_ (tree_type, left, right,
c7e4ee3a
CB		 3090 dest_tree, dest, dest_used,
3091 ffebld_nonter_hook (expr));
5ff904cd
JL		 3092
3093 case FFEBLD_opPOWER:
5ff904cd
JL		 3094 {
3095 ffebld left = ffebld_left (expr);
3096 ffebld right = ffebld_right (expr);
3097 ffecomGfrt code;
3098 ffeinfoKindtype rtkt;
270fc4e8 3099 ffeinfoKindtype ltkt;
5ff904cd
JL		 3100
3101 switch (ffeinfo_basictype (ffebld_info (right)))
3102 {
3103 case FFEINFO_basictypeINTEGER:
3104 if (1 || optimize)
3105 {
c7e4ee3a 3106 item = ffecom_expr_power_integer_ (expr);
5ff904cd
JL		 3107 if (item != NULL_TREE)
3108 return item;
3109 }
3110
3111 rtkt = FFEINFO_kindtypeINTEGER1;
3112 switch (ffeinfo_basictype (ffebld_info (left)))
3113 {
3114 case FFEINFO_basictypeINTEGER:
3115 if ((ffeinfo_kindtype (ffebld_info (left))
3116 == FFEINFO_kindtypeINTEGER4)
3117 || (ffeinfo_kindtype (ffebld_info (right))
3118 == FFEINFO_kindtypeINTEGER4))
3119 {
3120 code = FFECOM_gfrtPOW_QQ;
270fc4e8 3121 ltkt = FFEINFO_kindtypeINTEGER4;
5ff904cd
JL		 3122 rtkt = FFEINFO_kindtypeINTEGER4;
3123 }
3124 else
6a047254
CB		 3125 {
3126 code = FFECOM_gfrtPOW_II;
3127 ltkt = FFEINFO_kindtypeINTEGER1;
3128 }
5ff904cd
JL		 3129 break;
3130
3131 case FFEINFO_basictypeREAL:
3132 if (ffeinfo_kindtype (ffebld_info (left))
3133 == FFEINFO_kindtypeREAL1)
6a047254
CB		 3134 {
3135 code = FFECOM_gfrtPOW_RI;
3136 ltkt = FFEINFO_kindtypeREAL1;
3137 }
5ff904cd 3138 else
6a047254
CB		 3139 {
3140 code = FFECOM_gfrtPOW_DI;
3141 ltkt = FFEINFO_kindtypeREAL2;
3142 }
5ff904cd
JL		 3143 break;
3144
3145 case FFEINFO_basictypeCOMPLEX:
3146 if (ffeinfo_kindtype (ffebld_info (left))
3147 == FFEINFO_kindtypeREAL1)
6a047254
CB		 3148 {
3149 code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
3150 ltkt = FFEINFO_kindtypeREAL1;
3151 }
5ff904cd 3152 else
6a047254
CB		 3153 {
3154 code = FFECOM_gfrtPOW_ZI; /* Overlapping result okay. */
3155 ltkt = FFEINFO_kindtypeREAL2;
3156 }
5ff904cd
JL		 3157 break;
3158
3159 default:
3160 assert ("bad pow_*i" == NULL);
3161 code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
6a047254 3162 ltkt = FFEINFO_kindtypeREAL1;
5ff904cd
JL		 3163 break;
3164 }
270fc4e8 3165 if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
5ff904cd 3166 left = ffeexpr_convert (left, NULL, NULL,
6a047254 3167 ffeinfo_basictype (ffebld_info (left)),
270fc4e8 3168 ltkt, 0,
5ff904cd
JL		 3169 FFETARGET_charactersizeNONE,
3170 FFEEXPR_contextLET);
3171 if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3172 right = ffeexpr_convert (right, NULL, NULL,
3173 FFEINFO_basictypeINTEGER,
3174 rtkt, 0,
3175 FFETARGET_charactersizeNONE,
3176 FFEEXPR_contextLET);
3177 break;
3178
3179 case FFEINFO_basictypeREAL:
3180 if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3181 left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3182 FFEINFO_kindtypeREALDOUBLE, 0,
3183 FFETARGET_charactersizeNONE,
3184 FFEEXPR_contextLET);
3185 if (ffeinfo_kindtype (ffebld_info (right))
3186 == FFEINFO_kindtypeREAL1)
3187 right = ffeexpr_convert (right, NULL, NULL,
3188 FFEINFO_basictypeREAL,
3189 FFEINFO_kindtypeREALDOUBLE, 0,
3190 FFETARGET_charactersizeNONE,
3191 FFEEXPR_contextLET);
3192 code = FFECOM_gfrtPOW_DD;
3193 break;
3194
3195 case FFEINFO_basictypeCOMPLEX:
3196 if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3197 left = ffeexpr_convert (left, NULL, NULL,
3198 FFEINFO_basictypeCOMPLEX,
3199 FFEINFO_kindtypeREALDOUBLE, 0,
3200 FFETARGET_charactersizeNONE,
3201 FFEEXPR_contextLET);
3202 if (ffeinfo_kindtype (ffebld_info (right))
3203 == FFEINFO_kindtypeREAL1)
3204 right = ffeexpr_convert (right, NULL, NULL,
3205 FFEINFO_basictypeCOMPLEX,
3206 FFEINFO_kindtypeREALDOUBLE, 0,
3207 FFETARGET_charactersizeNONE,
3208 FFEEXPR_contextLET);
3209 code = FFECOM_gfrtPOW_ZZ; /* Overlapping result okay. */
3210 break;
3211
3212 default:
3213 assert ("bad pow_x*" == NULL);
3214 code = FFECOM_gfrtPOW_II;
3215 break;
3216 }
3217 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3218 ffecom_gfrt_kindtype (code),
3219 (ffe_is_f2c_library ()
3220 && ffecom_gfrt_complex_[code]),
3221 tree_type, left, right,
3222 dest_tree, dest, dest_used,
c7e4ee3a
CB		 3223 NULL_TREE, FALSE,
3224 ffebld_nonter_hook (expr));
5ff904cd
JL		 3225 }
3226
3227 case FFEBLD_opNOT:
5ff904cd
JL		 3228 switch (bt)
3229 {
3230 case FFEINFO_basictypeLOGICAL:
83ffecd2 3231 item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
5ff904cd
JL		 3232 return convert (tree_type, item);
3233
3234 case FFEINFO_basictypeINTEGER:
3235 return ffecom_1 (BIT_NOT_EXPR, tree_type,
3236 ffecom_expr (ffebld_left (expr)));
3237
3238 default:
3239 assert ("NOT bad basictype" == NULL);
3240 /* Fall through. */
3241 case FFEINFO_basictypeANY:
3242 return error_mark_node;
3243 }
3244 break;
3245
3246 case FFEBLD_opFUNCREF:
3247 assert (ffeinfo_basictype (ffebld_info (expr))
3248 != FFEINFO_basictypeCHARACTER);
3249 /* Fall through. */
3250 case FFEBLD_opSUBRREF:
5ff904cd
JL		 3251 if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3252 == FFEINFO_whereINTRINSIC)
3253 { /* Invocation of an intrinsic. */
3254 item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3255 dest_used);
3256 return item;
3257 }
3258 s = ffebld_symter (ffebld_left (expr));
3259 dt = ffesymbol_hook (s).decl_tree;
3260 if (dt == NULL_TREE)
3261 {
3262 s = ffecom_sym_transform_ (s);
3263 dt = ffesymbol_hook (s).decl_tree;
3264 }
3265 if (dt == error_mark_node)
3266 return dt;
3267
3268 if (ffesymbol_hook (s).addr)
3269 item = dt;
3270 else
3271 item = ffecom_1_fn (dt);
3272
5ff904cd
JL		 3273 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3274 args = ffecom_list_expr (ffebld_right (expr));
3275 else
3276 args = ffecom_list_ptr_to_expr (ffebld_right (expr));
5ff904cd 3277
702edf1d
CB		 3278 if (args == error_mark_node)
3279 return error_mark_node;
3280
5ff904cd
JL		 3281 item = ffecom_call_ (item, kt,
3282 ffesymbol_is_f2c (s)
3283 && (bt == FFEINFO_basictypeCOMPLEX)
3284 && (ffesymbol_where (s)
3285 != FFEINFO_whereCONSTANT),
3286 tree_type,
3287 args,
3288 dest_tree, dest, dest_used,
c7e4ee3a
CB		 3289 error_mark_node, FALSE,
3290 ffebld_nonter_hook (expr));
5ff904cd
JL		 3291 TREE_SIDE_EFFECTS (item) = 1;
3292 return item;
3293
3294 case FFEBLD_opAND:
5ff904cd
JL		 3295 switch (bt)
3296 {
3297 case FFEINFO_basictypeLOGICAL:
3298 item
3299 = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3300 ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3301 ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3302 return convert (tree_type, item);
3303
3304 case FFEINFO_basictypeINTEGER:
3305 return ffecom_2 (BIT_AND_EXPR, tree_type,
3306 ffecom_expr (ffebld_left (expr)),
3307 ffecom_expr (ffebld_right (expr)));
3308
3309 default:
3310 assert ("AND bad basictype" == NULL);
3311 /* Fall through. */
3312 case FFEINFO_basictypeANY:
3313 return error_mark_node;
3314 }
3315 break;
3316
3317 case FFEBLD_opOR:
5ff904cd
JL		 3318 switch (bt)
3319 {
3320 case FFEINFO_basictypeLOGICAL:
3321 item
3322 = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3323 ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3324 ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3325 return convert (tree_type, item);
3326
3327 case FFEINFO_basictypeINTEGER:
3328 return ffecom_2 (BIT_IOR_EXPR, tree_type,
3329 ffecom_expr (ffebld_left (expr)),
3330 ffecom_expr (ffebld_right (expr)));
3331
3332 default:
3333 assert ("OR bad basictype" == NULL);
3334 /* Fall through. */
3335 case FFEINFO_basictypeANY:
3336 return error_mark_node;
3337 }
3338 break;
3339
3340 case FFEBLD_opXOR:
3341 case FFEBLD_opNEQV:
5ff904cd
JL		 3342 switch (bt)
3343 {
3344 case FFEINFO_basictypeLOGICAL:
3345 item
3346 = ffecom_2 (NE_EXPR, integer_type_node,
3347 ffecom_expr (ffebld_left (expr)),
3348 ffecom_expr (ffebld_right (expr)));
3349 return convert (tree_type, ffecom_truth_value (item));
3350
3351 case FFEINFO_basictypeINTEGER:
3352 return ffecom_2 (BIT_XOR_EXPR, tree_type,
3353 ffecom_expr (ffebld_left (expr)),
3354 ffecom_expr (ffebld_right (expr)));
3355
3356 default:
3357 assert ("XOR/NEQV bad basictype" == NULL);
3358 /* Fall through. */
3359 case FFEINFO_basictypeANY:
3360 return error_mark_node;
3361 }
3362 break;
3363
3364 case FFEBLD_opEQV:
5ff904cd
JL		 3365 switch (bt)
3366 {
3367 case FFEINFO_basictypeLOGICAL:
3368 item
3369 = ffecom_2 (EQ_EXPR, integer_type_node,
3370 ffecom_expr (ffebld_left (expr)),
3371 ffecom_expr (ffebld_right (expr)));
3372 return convert (tree_type, ffecom_truth_value (item));
3373
3374 case FFEINFO_basictypeINTEGER:
3375 return
3376 ffecom_1 (BIT_NOT_EXPR, tree_type,
3377 ffecom_2 (BIT_XOR_EXPR, tree_type,
3378 ffecom_expr (ffebld_left (expr)),
3379 ffecom_expr (ffebld_right (expr))));
3380
3381 default:
3382 assert ("EQV bad basictype" == NULL);
3383 /* Fall through. */
3384 case FFEINFO_basictypeANY:
3385 return error_mark_node;
3386 }
3387 break;
3388
3389 case FFEBLD_opCONVERT:
3390 if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3391 return error_mark_node;
3392
5ff904cd
JL		 3393 switch (bt)
3394 {
3395 case FFEINFO_basictypeLOGICAL:
3396 case FFEINFO_basictypeINTEGER:
3397 case FFEINFO_basictypeREAL:
3398 return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3399
3400 case FFEINFO_basictypeCOMPLEX:
3401 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3402 {
3403 case FFEINFO_basictypeINTEGER:
3404 case FFEINFO_basictypeLOGICAL:
3405 case FFEINFO_basictypeREAL:
3406 item = ffecom_expr (ffebld_left (expr));
3407 if (item == error_mark_node)
3408 return error_mark_node;
3409 /* convert() takes care of converting to the subtype first,
3410 at least in gcc-2.7.2. */
3411 item = convert (tree_type, item);
3412 return item;
3413
3414 case FFEINFO_basictypeCOMPLEX:
3415 return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3416
3417 default:
3418 assert ("CONVERT COMPLEX bad basictype" == NULL);
3419 /* Fall through. */
3420 case FFEINFO_basictypeANY:
3421 return error_mark_node;
3422 }
3423 break;
3424
3425 default:
3426 assert ("CONVERT bad basictype" == NULL);
3427 /* Fall through. */
3428 case FFEINFO_basictypeANY:
3429 return error_mark_node;
3430 }
3431 break;
3432
3433 case FFEBLD_opLT:
3434 code = LT_EXPR;
3435 goto relational; /* :::::::::::::::::::: */
3436
3437 case FFEBLD_opLE:
3438 code = LE_EXPR;
3439 goto relational; /* :::::::::::::::::::: */
3440
3441 case FFEBLD_opEQ:
3442 code = EQ_EXPR;
3443 goto relational; /* :::::::::::::::::::: */
3444
3445 case FFEBLD_opNE:
3446 code = NE_EXPR;
3447 goto relational; /* :::::::::::::::::::: */
3448
3449 case FFEBLD_opGT:
3450 code = GT_EXPR;
3451 goto relational; /* :::::::::::::::::::: */
3452
3453 case FFEBLD_opGE:
3454 code = GE_EXPR;
3455
3456 relational: /* :::::::::::::::::::: */
5ff904cd
JL		 3457 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3458 {
3459 case FFEINFO_basictypeLOGICAL:
3460 case FFEINFO_basictypeINTEGER:
3461 case FFEINFO_basictypeREAL:
3462 item = ffecom_2 (code, integer_type_node,
3463 ffecom_expr (ffebld_left (expr)),
3464 ffecom_expr (ffebld_right (expr)));
3465 return convert (tree_type, item);
3466
3467 case FFEINFO_basictypeCOMPLEX:
3468 assert (code == EQ_EXPR || code == NE_EXPR);
3469 {
3470 tree real_type;
3471 tree arg1 = ffecom_expr (ffebld_left (expr));
3472 tree arg2 = ffecom_expr (ffebld_right (expr));
3473
3474 if (arg1 == error_mark_node || arg2 == error_mark_node)
3475 return error_mark_node;
3476
3477 arg1 = ffecom_save_tree (arg1);
3478 arg2 = ffecom_save_tree (arg2);
3479
3480 if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3481 {
3482 real_type = TREE_TYPE (TREE_TYPE (arg1));
3483 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3484 }
3485 else
3486 {
3487 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3488 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3489 }
3490
3491 item
3492 = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3493 ffecom_2 (EQ_EXPR, integer_type_node,
3494 ffecom_1 (REALPART_EXPR, real_type, arg1),
3495 ffecom_1 (REALPART_EXPR, real_type, arg2)),
3496 ffecom_2 (EQ_EXPR, integer_type_node,
3497 ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3498 ffecom_1 (IMAGPART_EXPR, real_type,
3499 arg2)));
3500 if (code == EQ_EXPR)
3501 item = ffecom_truth_value (item);
3502 else
3503 item = ffecom_truth_value_invert (item);
3504 return convert (tree_type, item);
3505 }
3506
3507 case FFEINFO_basictypeCHARACTER:
5ff904cd
JL		 3508 {
3509 ffebld left = ffebld_left (expr);
3510 ffebld right = ffebld_right (expr);
3511 tree left_tree;
3512 tree right_tree;
3513 tree left_length;
3514 tree right_length;
3515
3516 /* f2c run-time functions do the implicit blank-padding for us,
3517 so we don't usually have to implement blank-padding ourselves.
3518 (The exception is when we pass an argument to a separately
3519 compiled statement function -- if we know the arg is not the
3520 same length as the dummy, we must truncate or extend it. If
3521 we "inline" statement functions, that necessity goes away as
3522 well.)
3523
3524 Strip off the CONVERT operators that blank-pad. (Truncation by
3525 CONVERT shouldn't happen here, but it can happen in
3526 assignments.) */
3527
3528 while (ffebld_op (left) == FFEBLD_opCONVERT)
3529 left = ffebld_left (left);
3530 while (ffebld_op (right) == FFEBLD_opCONVERT)
3531 right = ffebld_left (right);
3532
3533 left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3534 right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3535
3536 if (left_tree == error_mark_node || left_length == error_mark_node
3537 || right_tree == error_mark_node
3538 || right_length == error_mark_node)
c7e4ee3a 3539 return error_mark_node;
5ff904cd
JL		 3540
3541 if ((ffebld_size_known (left) == 1)
3542 && (ffebld_size_known (right) == 1))
3543 {
3544 left_tree
3545 = ffecom_1 (INDIRECT_REF,
3546 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3547 left_tree);
3548 right_tree
3549 = ffecom_1 (INDIRECT_REF,
3550 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3551 right_tree);
3552
3553 item
3554 = ffecom_2 (code, integer_type_node,
3555 ffecom_2 (ARRAY_REF,
3556 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3557 left_tree,
3558 integer_one_node),
3559 ffecom_2 (ARRAY_REF,
3560 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3561 right_tree,
3562 integer_one_node));
3563 }
3564 else
3565 {
3566 item = build_tree_list (NULL_TREE, left_tree);
3567 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3568 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3569 left_length);
3570 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3571 = build_tree_list (NULL_TREE, right_length);
c7e4ee3a 3572 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
5ff904cd
JL		 3573 item = ffecom_2 (code, integer_type_node,
3574 item,
3575 convert (TREE_TYPE (item),
3576 integer_zero_node));
3577 }
3578 item = convert (tree_type, item);
3579 }
3580
5ff904cd
JL		 3581 return item;
3582
3583 default:
3584 assert ("relational bad basictype" == NULL);
3585 /* Fall through. */
3586 case FFEINFO_basictypeANY:
3587 return error_mark_node;
3588 }
3589 break;
3590
3591 case FFEBLD_opPERCENT_LOC:
5ff904cd
JL		 3592 item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3593 return convert (tree_type, item);
3594
3595 case FFEBLD_opITEM:
3596 case FFEBLD_opSTAR:
3597 case FFEBLD_opBOUNDS:
3598 case FFEBLD_opREPEAT:
3599 case FFEBLD_opLABTER:
3600 case FFEBLD_opLABTOK:
3601 case FFEBLD_opIMPDO:
3602 case FFEBLD_opCONCATENATE:
3603 case FFEBLD_opSUBSTR:
3604 default:
3605 assert ("bad op" == NULL);
3606 /* Fall through. */
3607 case FFEBLD_opANY:
3608 return error_mark_node;
3609 }
3610
3611#if 1
3612 assert ("didn't think anything got here anymore!!" == NULL);
3613#else
3614 switch (ffebld_arity (expr))
3615 {
3616 case 2:
3617 TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3618 TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3619 if (TREE_OPERAND (item, 0) == error_mark_node
3620 || TREE_OPERAND (item, 1) == error_mark_node)
3621 return error_mark_node;
3622 break;
3623
3624 case 1:
3625 TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3626 if (TREE_OPERAND (item, 0) == error_mark_node)
3627 return error_mark_node;
3628 break;
3629
3630 default:
3631 break;
3632 }
3633
3634 return fold (item);
3635#endif
3636}
3637
3638#endif
3639/* Returns the tree that does the intrinsic invocation.
3640
3641 Note: this function applies only to intrinsics returning
3642 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3643 subroutines. */
3644
3645#if FFECOM_targetCURRENT == FFECOM_targetGCC
3646static tree
3647ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3648 ffebld dest, bool *dest_used)
3649{
3650 tree expr_tree;
3651 tree saved_expr1; /* For those who need it. */
3652 tree saved_expr2; /* For those who need it. */
3653 ffeinfoBasictype bt;
3654 ffeinfoKindtype kt;
3655 tree tree_type;
3656 tree arg1_type;
3657 tree real_type; /* REAL type corresponding to COMPLEX. */
3658 tree tempvar;
3659 ffebld list = ffebld_right (expr); /* List of (some) args. */
3660 ffebld arg1; /* For handy reference. */
3661 ffebld arg2;
3662 ffebld arg3;
3663 ffeintrinImp codegen_imp;
3664 ffecomGfrt gfrt;
3665
3666 assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3667
3668 if (dest_used != NULL)
3669 *dest_used = FALSE;
3670
3671 bt = ffeinfo_basictype (ffebld_info (expr));
3672 kt = ffeinfo_kindtype (ffebld_info (expr));
3673 tree_type = ffecom_tree_type[bt][kt];
3674
3675 if (list != NULL)
3676 {
3677 arg1 = ffebld_head (list);
3678 if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3679 return error_mark_node;
3680 if ((list = ffebld_trail (list)) != NULL)
3681 {
3682 arg2 = ffebld_head (list);
3683 if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3684 return error_mark_node;
3685 if ((list = ffebld_trail (list)) != NULL)
3686 {
3687 arg3 = ffebld_head (list);
3688 if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3689 return error_mark_node;
3690 }
3691 else
3692 arg3 = NULL;
3693 }
3694 else
3695 arg2 = arg3 = NULL;
3696 }
3697 else
3698 arg1 = arg2 = arg3 = NULL;
3699
3700 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3701 args. This is used by the MAX/MIN expansions. */
3702
3703 if (arg1 != NULL)
3704 arg1_type = ffecom_tree_type
3705 [ffeinfo_basictype (ffebld_info (arg1))]
3706 [ffeinfo_kindtype (ffebld_info (arg1))];
3707 else
3708 arg1_type = NULL_TREE; /* Really not needed, but might catch bugs
3709 here. */
3710
3711 /* There are several ways for each of the cases in the following switch
3712 statements to exit (from simplest to use to most complicated):
3713
3714 break; (when expr_tree == NULL)
3715
3716 A standard call is made to the specific intrinsic just as if it had been
3717 passed in as a dummy procedure and called as any old procedure. This
3718 method can produce slower code but in some cases it's the easiest way for
3719 now. However, if a (presumably faster) direct call is available,
3720 that is used, so this is the easiest way in many more cases now.
3721
3722 gfrt = FFECOM_gfrtWHATEVER;
3723 break;
3724
3725 gfrt contains the gfrt index of a library function to call, passing the
3726 argument(s) by value rather than by reference. Used when a more
3727 careful choice of library function is needed than that provided
3728 by the vanilla `break;'.
3729
3730 return expr_tree;
3731
3732 The expr_tree has been completely set up and is ready to be returned
3733 as is. No further actions are taken. Use this when the tree is not
3734 in the simple form for one of the arity_n labels. */
3735
3736 /* For info on how the switch statement cases were written, see the files
3737 enclosed in comments below the switch statement. */
3738
3739 codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3740 gfrt = ffeintrin_gfrt_direct (codegen_imp);
3741 if (gfrt == FFECOM_gfrt)
3742 gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3743
3744 switch (codegen_imp)
3745 {
3746 case FFEINTRIN_impABS:
3747 case FFEINTRIN_impCABS:
3748 case FFEINTRIN_impCDABS:
3749 case FFEINTRIN_impDABS:
3750 case FFEINTRIN_impIABS:
3751 if (ffeinfo_basictype (ffebld_info (arg1))
3752 == FFEINFO_basictypeCOMPLEX)
3753 {
3754 if (kt == FFEINFO_kindtypeREAL1)
3755 gfrt = FFECOM_gfrtCABS;
3756 else if (kt == FFEINFO_kindtypeREAL2)
3757 gfrt = FFECOM_gfrtCDABS;
3758 break;
3759 }
3760 return ffecom_1 (ABS_EXPR, tree_type,
3761 convert (tree_type, ffecom_expr (arg1)));
3762
3763 case FFEINTRIN_impACOS:
3764 case FFEINTRIN_impDACOS:
3765 break;
3766
3767 case FFEINTRIN_impAIMAG:
3768 case FFEINTRIN_impDIMAG:
3769 case FFEINTRIN_impIMAGPART:
3770 if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3771 arg1_type = TREE_TYPE (arg1_type);
3772 else
3773 arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3774
3775 return
3776 convert (tree_type,
3777 ffecom_1 (IMAGPART_EXPR, arg1_type,
3778 ffecom_expr (arg1)));
3779
3780 case FFEINTRIN_impAINT:
3781 case FFEINTRIN_impDINT:
c7e4ee3a
CB		 3782#if 0
3783 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
5ff904cd
JL		 3784 return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3785#else /* in the meantime, must use floor to avoid range problems with ints */
3786 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3787 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3788 return
3789 convert (tree_type,
3790 ffecom_3 (COND_EXPR, double_type_node,
3791 ffecom_truth_value
3792 (ffecom_2 (GE_EXPR, integer_type_node,
3793 saved_expr1,
3794 convert (arg1_type,
3795 ffecom_float_zero_))),
3796 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3797 build_tree_list (NULL_TREE,
3798 convert (double_type_node,
c7e4ee3a
CB		 3799 saved_expr1)),
3800 NULL_TREE),
5ff904cd
JL		 3801 ffecom_1 (NEGATE_EXPR, double_type_node,
3802 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3803 build_tree_list (NULL_TREE,
3804 convert (double_type_node,
3805 ffecom_1 (NEGATE_EXPR,
3806 arg1_type,
c7e4ee3a
CB		 3807 saved_expr1))),
3808 NULL_TREE)
5ff904cd
JL		 3809 ))
3810 );
3811#endif
3812
3813 case FFEINTRIN_impANINT:
3814 case FFEINTRIN_impDNINT:
3815#if 0 /* This way of doing it won't handle real
3816 numbers of large magnitudes. */
3817 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3818 expr_tree = convert (tree_type,
3819 convert (integer_type_node,
3820 ffecom_3 (COND_EXPR, tree_type,
3821 ffecom_truth_value
3822 (ffecom_2 (GE_EXPR,
3823 integer_type_node,
3824 saved_expr1,
3825 ffecom_float_zero_)),
3826 ffecom_2 (PLUS_EXPR,
3827 tree_type,
3828 saved_expr1,
3829 ffecom_float_half_),
3830 ffecom_2 (MINUS_EXPR,
3831 tree_type,
3832 saved_expr1,
3833 ffecom_float_half_))));
3834 return expr_tree;
3835#else /* So we instead call floor. */
3836 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3837 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3838 return
3839 convert (tree_type,
3840 ffecom_3 (COND_EXPR, double_type_node,
3841 ffecom_truth_value
3842 (ffecom_2 (GE_EXPR, integer_type_node,
3843 saved_expr1,
3844 convert (arg1_type,
3845 ffecom_float_zero_))),
3846 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3847 build_tree_list (NULL_TREE,
3848 convert (double_type_node,
3849 ffecom_2 (PLUS_EXPR,
3850 arg1_type,
3851 saved_expr1,
3852 convert (arg1_type,
c7e4ee3a
CB		 3853 ffecom_float_half_)))),
3854 NULL_TREE),
5ff904cd
JL		 3855 ffecom_1 (NEGATE_EXPR, double_type_node,
3856 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3857 build_tree_list (NULL_TREE,
3858 convert (double_type_node,
3859 ffecom_2 (MINUS_EXPR,
3860 arg1_type,
3861 convert (arg1_type,
3862 ffecom_float_half_),
c7e4ee3a
CB		 3863 saved_expr1))),
3864 NULL_TREE))
5ff904cd
JL		 3865 )
3866 );
3867#endif
3868
3869 case FFEINTRIN_impASIN:
3870 case FFEINTRIN_impDASIN:
3871 case FFEINTRIN_impATAN:
3872 case FFEINTRIN_impDATAN:
3873 case FFEINTRIN_impATAN2:
3874 case FFEINTRIN_impDATAN2:
3875 break;
3876
3877 case FFEINTRIN_impCHAR:
3878 case FFEINTRIN_impACHAR:
c7e4ee3a
CB		 3879#ifdef HOHO
3880 tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
3881#else
3882 tempvar = ffebld_nonter_hook (expr);
3883 assert (tempvar);
3884#endif
5ff904cd
JL		 3885 {
3886 tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
3887
3888 expr_tree = ffecom_modify (tmv,
3889 ffecom_2 (ARRAY_REF, tmv, tempvar,
3890 integer_one_node),
3891 convert (tmv, ffecom_expr (arg1)));
3892 }
3893 expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
3894 expr_tree,
3895 tempvar);
3896 expr_tree = ffecom_1 (ADDR_EXPR,
3897 build_pointer_type (TREE_TYPE (expr_tree)),
3898 expr_tree);
3899 return expr_tree;
3900
3901 case FFEINTRIN_impCMPLX:
3902 case FFEINTRIN_impDCMPLX:
3903 if (arg2 == NULL)
3904 return
3905 convert (tree_type, ffecom_expr (arg1));
3906
3907 real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
3908 return
3909 ffecom_2 (COMPLEX_EXPR, tree_type,
3910 convert (real_type, ffecom_expr (arg1)),
3911 convert (real_type,
3912 ffecom_expr (arg2)));
3913
3914 case FFEINTRIN_impCOMPLEX:
3915 return
3916 ffecom_2 (COMPLEX_EXPR, tree_type,
3917 ffecom_expr (arg1),
3918 ffecom_expr (arg2));
3919
3920 case FFEINTRIN_impCONJG:
3921 case FFEINTRIN_impDCONJG:
3922 {
3923 tree arg1_tree;
3924
3925 real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
3926 arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
3927 return
3928 ffecom_2 (COMPLEX_EXPR, tree_type,
3929 ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
3930 ffecom_1 (NEGATE_EXPR, real_type,
3931 ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
3932 }
3933
3934 case FFEINTRIN_impCOS:
3935 case FFEINTRIN_impCCOS:
3936 case FFEINTRIN_impCDCOS:
3937 case FFEINTRIN_impDCOS:
3938 if (bt == FFEINFO_basictypeCOMPLEX)
3939 {
3940 if (kt == FFEINFO_kindtypeREAL1)
3941 gfrt = FFECOM_gfrtCCOS; /* Overlapping result okay. */
3942 else if (kt == FFEINFO_kindtypeREAL2)
3943 gfrt = FFECOM_gfrtCDCOS; /* Overlapping result okay. */
3944 }
3945 break;
3946
3947 case FFEINTRIN_impCOSH:
3948 case FFEINTRIN_impDCOSH:
3949 break;
3950
3951 case FFEINTRIN_impDBLE:
3952 case FFEINTRIN_impDFLOAT:
3953 case FFEINTRIN_impDREAL:
3954 case FFEINTRIN_impFLOAT:
3955 case FFEINTRIN_impIDINT:
3956 case FFEINTRIN_impIFIX:
3957 case FFEINTRIN_impINT2:
3958 case FFEINTRIN_impINT8:
3959 case FFEINTRIN_impINT:
3960 case FFEINTRIN_impLONG:
3961 case FFEINTRIN_impREAL:
3962 case FFEINTRIN_impSHORT:
3963 case FFEINTRIN_impSNGL:
3964 return convert (tree_type, ffecom_expr (arg1));
3965
3966 case FFEINTRIN_impDIM:
3967 case FFEINTRIN_impDDIM:
3968 case FFEINTRIN_impIDIM:
3969 saved_expr1 = ffecom_save_tree (convert (tree_type,
3970 ffecom_expr (arg1)));
3971 saved_expr2 = ffecom_save_tree (convert (tree_type,
3972 ffecom_expr (arg2)));
3973 return
3974 ffecom_3 (COND_EXPR, tree_type,
3975 ffecom_truth_value
3976 (ffecom_2 (GT_EXPR, integer_type_node,
3977 saved_expr1,
3978 saved_expr2)),
3979 ffecom_2 (MINUS_EXPR, tree_type,
3980 saved_expr1,
3981 saved_expr2),
3982 convert (tree_type, ffecom_float_zero_));
3983
3984 case FFEINTRIN_impDPROD:
3985 return
3986 ffecom_2 (MULT_EXPR, tree_type,
3987 convert (tree_type, ffecom_expr (arg1)),
3988 convert (tree_type, ffecom_expr (arg2)));
3989
3990 case FFEINTRIN_impEXP:
3991 case FFEINTRIN_impCDEXP:
3992 case FFEINTRIN_impCEXP:
3993 case FFEINTRIN_impDEXP:
3994 if (bt == FFEINFO_basictypeCOMPLEX)
3995 {
3996 if (kt == FFEINFO_kindtypeREAL1)
3997 gfrt = FFECOM_gfrtCEXP; /* Overlapping result okay. */
3998 else if (kt == FFEINFO_kindtypeREAL2)
3999 gfrt = FFECOM_gfrtCDEXP; /* Overlapping result okay. */
4000 }
4001 break;
4002
4003 case FFEINTRIN_impICHAR:
4004 case FFEINTRIN_impIACHAR:
4005#if 0 /* The simple approach. */
4006 ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4007 expr_tree
4008 = ffecom_1 (INDIRECT_REF,
4009 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4010 expr_tree);
4011 expr_tree
4012 = ffecom_2 (ARRAY_REF,
4013 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4014 expr_tree,
4015 integer_one_node);
4016 return convert (tree_type, expr_tree);
4017#else /* The more interesting (and more optimal) approach. */
4018 expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4019 expr_tree = ffecom_3 (COND_EXPR, tree_type,
4020 saved_expr1,
4021 expr_tree,
4022 convert (tree_type, integer_zero_node));
4023 return expr_tree;
4024#endif
4025
4026 case FFEINTRIN_impINDEX:
4027 break;
4028
4029 case FFEINTRIN_impLEN:
4030#if 0
4031 break; /* The simple approach. */
4032#else
4033 return ffecom_intrinsic_len_ (arg1); /* The more optimal approach. */
4034#endif
4035
4036 case FFEINTRIN_impLGE:
4037 case FFEINTRIN_impLGT:
4038 case FFEINTRIN_impLLE:
4039 case FFEINTRIN_impLLT:
4040 break;
4041
4042 case FFEINTRIN_impLOG:
4043 case FFEINTRIN_impALOG:
4044 case FFEINTRIN_impCDLOG:
4045 case FFEINTRIN_impCLOG:
4046 case FFEINTRIN_impDLOG:
4047 if (bt == FFEINFO_basictypeCOMPLEX)
4048 {
4049 if (kt == FFEINFO_kindtypeREAL1)
4050 gfrt = FFECOM_gfrtCLOG; /* Overlapping result okay. */
4051 else if (kt == FFEINFO_kindtypeREAL2)
4052 gfrt = FFECOM_gfrtCDLOG; /* Overlapping result okay. */
4053 }
4054 break;
4055
4056 case FFEINTRIN_impLOG10:
4057 case FFEINTRIN_impALOG10:
4058 case FFEINTRIN_impDLOG10:
4059 if (gfrt != FFECOM_gfrt)
4060 break; /* Already picked one, stick with it. */
4061
4062 if (kt == FFEINFO_kindtypeREAL1)
4063 gfrt = FFECOM_gfrtALOG10;
4064 else if (kt == FFEINFO_kindtypeREAL2)
4065 gfrt = FFECOM_gfrtDLOG10;
4066 break;
4067
4068 case FFEINTRIN_impMAX:
4069 case FFEINTRIN_impAMAX0:
4070 case FFEINTRIN_impAMAX1:
4071 case FFEINTRIN_impDMAX1:
4072 case FFEINTRIN_impMAX0:
4073 case FFEINTRIN_impMAX1:
4074 if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4075 arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4076 else
4077 arg1_type = tree_type;
4078 expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4079 convert (arg1_type, ffecom_expr (arg1)),
4080 convert (arg1_type, ffecom_expr (arg2)));
4081 for (; list != NULL; list = ffebld_trail (list))
4082 {
4083 if ((ffebld_head (list) == NULL)
4084 || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4085 continue;
4086 expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4087 expr_tree,
4088 convert (arg1_type,
4089 ffecom_expr (ffebld_head (list))));
4090 }
4091 return convert (tree_type, expr_tree);
4092
4093 case FFEINTRIN_impMIN:
4094 case FFEINTRIN_impAMIN0:
4095 case FFEINTRIN_impAMIN1:
4096 case FFEINTRIN_impDMIN1:
4097 case FFEINTRIN_impMIN0:
4098 case FFEINTRIN_impMIN1:
4099 if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4100 arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4101 else
4102 arg1_type = tree_type;
4103 expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4104 convert (arg1_type, ffecom_expr (arg1)),
4105 convert (arg1_type, ffecom_expr (arg2)));
4106 for (; list != NULL; list = ffebld_trail (list))
4107 {
4108 if ((ffebld_head (list) == NULL)
4109 || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4110 continue;
4111 expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4112 expr_tree,
4113 convert (arg1_type,
4114 ffecom_expr (ffebld_head (list))));
4115 }
4116 return convert (tree_type, expr_tree);
4117
4118 case FFEINTRIN_impMOD:
4119 case FFEINTRIN_impAMOD:
4120 case FFEINTRIN_impDMOD:
4121 if (bt != FFEINFO_basictypeREAL)
4122 return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4123 convert (tree_type, ffecom_expr (arg1)),
4124 convert (tree_type, ffecom_expr (arg2)));
4125
4126 if (kt == FFEINFO_kindtypeREAL1)
4127 gfrt = FFECOM_gfrtAMOD;
4128 else if (kt == FFEINFO_kindtypeREAL2)
4129 gfrt = FFECOM_gfrtDMOD;
4130 break;
4131
4132 case FFEINTRIN_impNINT:
4133 case FFEINTRIN_impIDNINT:
c7e4ee3a
CB		 4134#if 0
4135 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
5ff904cd
JL		 4136 return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4137#else
4138 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4139 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4140 return
4141 convert (ffecom_integer_type_node,
4142 ffecom_3 (COND_EXPR, arg1_type,
4143 ffecom_truth_value
4144 (ffecom_2 (GE_EXPR, integer_type_node,
4145 saved_expr1,
4146 convert (arg1_type,
4147 ffecom_float_zero_))),
4148 ffecom_2 (PLUS_EXPR, arg1_type,
4149 saved_expr1,
4150 convert (arg1_type,
4151 ffecom_float_half_)),
4152 ffecom_2 (MINUS_EXPR, arg1_type,
4153 saved_expr1,
4154 convert (arg1_type,
4155 ffecom_float_half_))));
4156#endif
4157
4158 case FFEINTRIN_impSIGN:
4159 case FFEINTRIN_impDSIGN:
4160 case FFEINTRIN_impISIGN:
4161 {
4162 tree arg2_tree = ffecom_expr (arg2);
4163
4164 saved_expr1
4165 = ffecom_save_tree
4166 (ffecom_1 (ABS_EXPR, tree_type,
4167 convert (tree_type,
4168 ffecom_expr (arg1))));
4169 expr_tree
4170 = ffecom_3 (COND_EXPR, tree_type,
4171 ffecom_truth_value
4172 (ffecom_2 (GE_EXPR, integer_type_node,
4173 arg2_tree,
4174 convert (TREE_TYPE (arg2_tree),
4175 integer_zero_node))),
4176 saved_expr1,
4177 ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4178 /* Make sure SAVE_EXPRs get referenced early enough. */
4179 expr_tree
4180 = ffecom_2 (COMPOUND_EXPR, tree_type,
4181 convert (void_type_node, saved_expr1),
4182 expr_tree);
4183 }
4184 return expr_tree;
4185
4186 case FFEINTRIN_impSIN:
4187 case FFEINTRIN_impCDSIN:
4188 case FFEINTRIN_impCSIN:
4189 case FFEINTRIN_impDSIN:
4190 if (bt == FFEINFO_basictypeCOMPLEX)
4191 {
4192 if (kt == FFEINFO_kindtypeREAL1)
4193 gfrt = FFECOM_gfrtCSIN; /* Overlapping result okay. */
4194 else if (kt == FFEINFO_kindtypeREAL2)
4195 gfrt = FFECOM_gfrtCDSIN; /* Overlapping result okay. */
4196 }
4197 break;
4198
4199 case FFEINTRIN_impSINH:
4200 case FFEINTRIN_impDSINH:
4201 break;
4202
4203 case FFEINTRIN_impSQRT:
4204 case FFEINTRIN_impCDSQRT:
4205 case FFEINTRIN_impCSQRT:
4206 case FFEINTRIN_impDSQRT:
4207 if (bt == FFEINFO_basictypeCOMPLEX)
4208 {
4209 if (kt == FFEINFO_kindtypeREAL1)
4210 gfrt = FFECOM_gfrtCSQRT; /* Overlapping result okay. */
4211 else if (kt == FFEINFO_kindtypeREAL2)
4212 gfrt = FFECOM_gfrtCDSQRT; /* Overlapping result okay. */
4213 }
4214 break;
4215
4216 case FFEINTRIN_impTAN:
4217 case FFEINTRIN_impDTAN:
4218 case FFEINTRIN_impTANH:
4219 case FFEINTRIN_impDTANH:
4220 break;
4221
4222 case FFEINTRIN_impREALPART:
4223 if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4224 arg1_type = TREE_TYPE (arg1_type);
4225 else
4226 arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4227
4228 return
4229 convert (tree_type,
4230 ffecom_1 (REALPART_EXPR, arg1_type,
4231 ffecom_expr (arg1)));
4232
4233 case FFEINTRIN_impIAND:
4234 case FFEINTRIN_impAND:
4235 return ffecom_2 (BIT_AND_EXPR, tree_type,
4236 convert (tree_type,
4237 ffecom_expr (arg1)),
4238 convert (tree_type,
4239 ffecom_expr (arg2)));
4240
4241 case FFEINTRIN_impIOR:
4242 case FFEINTRIN_impOR:
4243 return ffecom_2 (BIT_IOR_EXPR, tree_type,
4244 convert (tree_type,
4245 ffecom_expr (arg1)),
4246 convert (tree_type,
4247 ffecom_expr (arg2)));
4248
4249 case FFEINTRIN_impIEOR:
4250 case FFEINTRIN_impXOR:
4251 return ffecom_2 (BIT_XOR_EXPR, tree_type,
4252 convert (tree_type,
4253 ffecom_expr (arg1)),
4254 convert (tree_type,
4255 ffecom_expr (arg2)));
4256
4257 case FFEINTRIN_impLSHIFT:
4258 return ffecom_2 (LSHIFT_EXPR, tree_type,
4259 ffecom_expr (arg1),
4260 convert (integer_type_node,
4261 ffecom_expr (arg2)));
4262
4263 case FFEINTRIN_impRSHIFT:
4264 return ffecom_2 (RSHIFT_EXPR, tree_type,
4265 ffecom_expr (arg1),
4266 convert (integer_type_node,
4267 ffecom_expr (arg2)));
4268
4269 case FFEINTRIN_impNOT:
4270 return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4271
4272 case FFEINTRIN_impBIT_SIZE:
4273 return convert (tree_type, TYPE_SIZE (arg1_type));
4274
4275 case FFEINTRIN_impBTEST:
4276 {
4277 ffetargetLogical1 true;
4278 ffetargetLogical1 false;
4279 tree true_tree;
4280 tree false_tree;
4281
4282 ffetarget_logical1 (&true, TRUE);
4283 ffetarget_logical1 (&false, FALSE);
4284 if (true == 1)
4285 true_tree = convert (tree_type, integer_one_node);
4286 else
4287 true_tree = convert (tree_type, build_int_2 (true, 0));
4288 if (false == 0)
4289 false_tree = convert (tree_type, integer_zero_node);
4290 else
4291 false_tree = convert (tree_type, build_int_2 (false, 0));
4292
4293 return
4294 ffecom_3 (COND_EXPR, tree_type,
4295 ffecom_truth_value
4296 (ffecom_2 (EQ_EXPR, integer_type_node,
4297 ffecom_2 (BIT_AND_EXPR, arg1_type,
4298 ffecom_expr (arg1),
4299 ffecom_2 (LSHIFT_EXPR, arg1_type,
4300 convert (arg1_type,
4301 integer_one_node),
4302 convert (integer_type_node,
4303 ffecom_expr (arg2)))),
4304 convert (arg1_type,
4305 integer_zero_node))),
4306 false_tree,
4307 true_tree);
4308 }
4309
4310 case FFEINTRIN_impIBCLR:
4311 return
4312 ffecom_2 (BIT_AND_EXPR, tree_type,
4313 ffecom_expr (arg1),
4314 ffecom_1 (BIT_NOT_EXPR, tree_type,
4315 ffecom_2 (LSHIFT_EXPR, tree_type,
4316 convert (tree_type,
4317 integer_one_node),
4318 convert (integer_type_node,
4319 ffecom_expr (arg2)))));
4320
4321 case FFEINTRIN_impIBITS:
4322 {
4323 tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4324 ffecom_expr (arg3)));
4325 tree uns_type
4326 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4327
4328 expr_tree
4329 = ffecom_2 (BIT_AND_EXPR, tree_type,
4330 ffecom_2 (RSHIFT_EXPR, tree_type,
4331 ffecom_expr (arg1),
4332 convert (integer_type_node,
4333 ffecom_expr (arg2))),
4334 convert (tree_type,
4335 ffecom_2 (RSHIFT_EXPR, uns_type,
4336 ffecom_1 (BIT_NOT_EXPR,
4337 uns_type,
4338 convert (uns_type,
4339 integer_zero_node)),
4340 ffecom_2 (MINUS_EXPR,
4341 integer_type_node,
4342 TYPE_SIZE (uns_type),
4343 arg3_tree))));
4344#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4345 expr_tree
4346 = ffecom_3 (COND_EXPR, tree_type,
4347 ffecom_truth_value
4348 (ffecom_2 (NE_EXPR, integer_type_node,
4349 arg3_tree,
4350 integer_zero_node)),
4351 expr_tree,
4352 convert (tree_type, integer_zero_node));
4353#endif
4354 }
4355 return expr_tree;
4356
4357 case FFEINTRIN_impIBSET:
4358 return
4359 ffecom_2 (BIT_IOR_EXPR, tree_type,
4360 ffecom_expr (arg1),
4361 ffecom_2 (LSHIFT_EXPR, tree_type,
4362 convert (tree_type, integer_one_node),
4363 convert (integer_type_node,
4364 ffecom_expr (arg2))));
4365
4366 case FFEINTRIN_impISHFT:
4367 {
4368 tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4369 tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4370 ffecom_expr (arg2)));
4371 tree uns_type
4372 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4373
4374 expr_tree
4375 = ffecom_3 (COND_EXPR, tree_type,
4376 ffecom_truth_value
4377 (ffecom_2 (GE_EXPR, integer_type_node,
4378 arg2_tree,
4379 integer_zero_node)),
4380 ffecom_2 (LSHIFT_EXPR, tree_type,
4381 arg1_tree,
4382 arg2_tree),
4383 convert (tree_type,
4384 ffecom_2 (RSHIFT_EXPR, uns_type,
4385 convert (uns_type, arg1_tree),
4386 ffecom_1 (NEGATE_EXPR,
4387 integer_type_node,
4388 arg2_tree))));
4389#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4390 expr_tree
4391 = ffecom_3 (COND_EXPR, tree_type,
4392 ffecom_truth_value
4393 (ffecom_2 (NE_EXPR, integer_type_node,
4394 arg2_tree,
4395 TYPE_SIZE (uns_type))),
4396 expr_tree,
4397 convert (tree_type, integer_zero_node));
4398#endif
4399 /* Make sure SAVE_EXPRs get referenced early enough. */
4400 expr_tree
4401 = ffecom_2 (COMPOUND_EXPR, tree_type,
4402 convert (void_type_node, arg1_tree),
4403 ffecom_2 (COMPOUND_EXPR, tree_type,
4404 convert (void_type_node, arg2_tree),
4405 expr_tree));
4406 }
4407 return expr_tree;
4408
4409 case FFEINTRIN_impISHFTC:
4410 {
4411 tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4412 tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4413 ffecom_expr (arg2)));
4414 tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4415 : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4416 tree shift_neg;
4417 tree shift_pos;
4418 tree mask_arg1;
4419 tree masked_arg1;
4420 tree uns_type
4421 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4422
4423 mask_arg1
4424 = ffecom_2 (LSHIFT_EXPR, tree_type,
4425 ffecom_1 (BIT_NOT_EXPR, tree_type,
4426 convert (tree_type, integer_zero_node)),
4427 arg3_tree);
4428#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4429 mask_arg1
4430 = ffecom_3 (COND_EXPR, tree_type,
4431 ffecom_truth_value
4432 (ffecom_2 (NE_EXPR, integer_type_node,
4433 arg3_tree,
4434 TYPE_SIZE (uns_type))),
4435 mask_arg1,
4436 convert (tree_type, integer_zero_node));
4437#endif
4438 mask_arg1 = ffecom_save_tree (mask_arg1);
4439 masked_arg1
4440 = ffecom_2 (BIT_AND_EXPR, tree_type,
4441 arg1_tree,
4442 ffecom_1 (BIT_NOT_EXPR, tree_type,
4443 mask_arg1));
4444 masked_arg1 = ffecom_save_tree (masked_arg1);
4445 shift_neg
4446 = ffecom_2 (BIT_IOR_EXPR, tree_type,
4447 convert (tree_type,
4448 ffecom_2 (RSHIFT_EXPR, uns_type,
4449 convert (uns_type, masked_arg1),
4450 ffecom_1 (NEGATE_EXPR,
4451 integer_type_node,
4452 arg2_tree))),
4453 ffecom_2 (LSHIFT_EXPR, tree_type,
4454 arg1_tree,
4455 ffecom_2 (PLUS_EXPR, integer_type_node,
4456 arg2_tree,
4457 arg3_tree)));
4458 shift_pos
4459 = ffecom_2 (BIT_IOR_EXPR, tree_type,
4460 ffecom_2 (LSHIFT_EXPR, tree_type,
4461 arg1_tree,
4462 arg2_tree),
4463 convert (tree_type,
4464 ffecom_2 (RSHIFT_EXPR, uns_type,
4465 convert (uns_type, masked_arg1),
4466 ffecom_2 (MINUS_EXPR,
4467 integer_type_node,
4468 arg3_tree,
4469 arg2_tree))));
4470 expr_tree
4471 = ffecom_3 (COND_EXPR, tree_type,
4472 ffecom_truth_value
4473 (ffecom_2 (LT_EXPR, integer_type_node,
4474 arg2_tree,
4475 integer_zero_node)),
4476 shift_neg,
4477 shift_pos);
4478 expr_tree
4479 = ffecom_2 (BIT_IOR_EXPR, tree_type,
4480 ffecom_2 (BIT_AND_EXPR, tree_type,
4481 mask_arg1,
4482 arg1_tree),
4483 ffecom_2 (BIT_AND_EXPR, tree_type,
4484 ffecom_1 (BIT_NOT_EXPR, tree_type,
4485 mask_arg1),
4486 expr_tree));
4487 expr_tree
4488 = ffecom_3 (COND_EXPR, tree_type,
4489 ffecom_truth_value
4490 (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4491 ffecom_2 (EQ_EXPR, integer_type_node,
4492 ffecom_1 (ABS_EXPR,
4493 integer_type_node,
4494 arg2_tree),
4495 arg3_tree),
4496 ffecom_2 (EQ_EXPR, integer_type_node,
4497 arg2_tree,
4498 integer_zero_node))),
4499 arg1_tree,
4500 expr_tree);
4501 /* Make sure SAVE_EXPRs get referenced early enough. */
4502 expr_tree
4503 = ffecom_2 (COMPOUND_EXPR, tree_type,
4504 convert (void_type_node, arg1_tree),
4505 ffecom_2 (COMPOUND_EXPR, tree_type,
4506 convert (void_type_node, arg2_tree),
4507 ffecom_2 (COMPOUND_EXPR, tree_type,
4508 convert (void_type_node,
4509 mask_arg1),
4510 ffecom_2 (COMPOUND_EXPR, tree_type,
4511 convert (void_type_node,
4512 masked_arg1),
4513 expr_tree))));
4514 expr_tree
4515 = ffecom_2 (COMPOUND_EXPR, tree_type,
4516 convert (void_type_node,
4517 arg3_tree),
4518 expr_tree);
4519 }
4520 return expr_tree;
4521
4522 case FFEINTRIN_impLOC:
4523 {
4524 tree arg1_tree = ffecom_expr (arg1);
4525
4526 expr_tree
4527 = convert (tree_type,
4528 ffecom_1 (ADDR_EXPR,
4529 build_pointer_type (TREE_TYPE (arg1_tree)),
4530 arg1_tree));
4531 }
4532 return expr_tree;
4533
4534 case FFEINTRIN_impMVBITS:
4535 {
4536 tree arg1_tree;
4537 tree arg2_tree;
4538 tree arg3_tree;
4539 ffebld arg4 = ffebld_head (ffebld_trail (list));
4540 tree arg4_tree;
4541 tree arg4_type;
4542 ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4543 tree arg5_tree;
4544 tree prep_arg1;
4545 tree prep_arg4;
4546 tree arg5_plus_arg3;
4547
5ff904cd
JL		 4548 arg2_tree = convert (integer_type_node,
4549 ffecom_expr (arg2));
4550 arg3_tree = ffecom_save_tree (convert (integer_type_node,
4551 ffecom_expr (arg3)));
c7e4ee3a 4552 arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
5ff904cd
JL		 4553 arg4_type = TREE_TYPE (arg4_tree);
4554
4555 arg1_tree = ffecom_save_tree (convert (arg4_type,
4556 ffecom_expr (arg1)));
4557
4558 arg5_tree = ffecom_save_tree (convert (integer_type_node,
4559 ffecom_expr (arg5)));
4560
5ff904cd
JL		 4561 prep_arg1
4562 = ffecom_2 (LSHIFT_EXPR, arg4_type,
4563 ffecom_2 (BIT_AND_EXPR, arg4_type,
4564 ffecom_2 (RSHIFT_EXPR, arg4_type,
4565 arg1_tree,
4566 arg2_tree),
4567 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4568 ffecom_2 (LSHIFT_EXPR, arg4_type,
4569 ffecom_1 (BIT_NOT_EXPR,
4570 arg4_type,
4571 convert
4572 (arg4_type,
4573 integer_zero_node)),
4574 arg3_tree))),
4575 arg5_tree);
4576 arg5_plus_arg3
4577 = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4578 arg5_tree,
4579 arg3_tree));
4580 prep_arg4
4581 = ffecom_2 (LSHIFT_EXPR, arg4_type,
4582 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4583 convert (arg4_type,
4584 integer_zero_node)),
4585 arg5_plus_arg3);
4586#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4587 prep_arg4
4588 = ffecom_3 (COND_EXPR, arg4_type,
4589 ffecom_truth_value
4590 (ffecom_2 (NE_EXPR, integer_type_node,
4591 arg5_plus_arg3,
4592 convert (TREE_TYPE (arg5_plus_arg3),
4593 TYPE_SIZE (arg4_type)))),
4594 prep_arg4,
4595 convert (arg4_type, integer_zero_node));
4596#endif
4597 prep_arg4
4598 = ffecom_2 (BIT_AND_EXPR, arg4_type,
4599 arg4_tree,
4600 ffecom_2 (BIT_IOR_EXPR, arg4_type,
4601 prep_arg4,
4602 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4603 ffecom_2 (LSHIFT_EXPR, arg4_type,
4604 ffecom_1 (BIT_NOT_EXPR,
4605 arg4_type,
4606 convert
4607 (arg4_type,
4608 integer_zero_node)),
4609 arg5_tree))));
4610 prep_arg1
4611 = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4612 prep_arg1,
4613 prep_arg4);
4614#if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4615 prep_arg1
4616 = ffecom_3 (COND_EXPR, arg4_type,
4617 ffecom_truth_value
4618 (ffecom_2 (NE_EXPR, integer_type_node,
4619 arg3_tree,
4620 convert (TREE_TYPE (arg3_tree),
4621 integer_zero_node))),
4622 prep_arg1,
4623 arg4_tree);
4624 prep_arg1
4625 = ffecom_3 (COND_EXPR, arg4_type,
4626 ffecom_truth_value
4627 (ffecom_2 (NE_EXPR, integer_type_node,
4628 arg3_tree,
4629 convert (TREE_TYPE (arg3_tree),
4630 TYPE_SIZE (arg4_type)))),
4631 prep_arg1,
4632 arg1_tree);
4633#endif
4634 expr_tree
4635 = ffecom_2s (MODIFY_EXPR, void_type_node,
4636 arg4_tree,
4637 prep_arg1);
4638 /* Make sure SAVE_EXPRs get referenced early enough. */
4639 expr_tree
4640 = ffecom_2 (COMPOUND_EXPR, void_type_node,
4641 arg1_tree,
4642 ffecom_2 (COMPOUND_EXPR, void_type_node,
4643 arg3_tree,
4644 ffecom_2 (COMPOUND_EXPR, void_type_node,
4645 arg5_tree,
4646 ffecom_2 (COMPOUND_EXPR, void_type_node,
4647 arg5_plus_arg3,
4648 expr_tree))));
4649 expr_tree
4650 = ffecom_2 (COMPOUND_EXPR, void_type_node,
4651 arg4_tree,
4652 expr_tree);
4653
4654 }
4655 return expr_tree;
4656
4657 case FFEINTRIN_impDERF:
4658 case FFEINTRIN_impERF:
4659 case FFEINTRIN_impDERFC:
4660 case FFEINTRIN_impERFC:
4661 break;
4662
4663 case FFEINTRIN_impIARGC:
4664 /* extern int xargc; i__1 = xargc - 1; */
4665 expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4666 ffecom_tree_xargc_,
4667 convert (TREE_TYPE (ffecom_tree_xargc_),
4668 integer_one_node));
4669 return expr_tree;
4670
4671 case FFEINTRIN_impSIGNAL_func:
4672 case FFEINTRIN_impSIGNAL_subr:
4673 {
4674 tree arg1_tree;
4675 tree arg2_tree;
4676 tree arg3_tree;
4677
5ff904cd
JL		 4678 arg1_tree = convert (ffecom_f2c_integer_type_node,
4679 ffecom_expr (arg1));
4680 arg1_tree = ffecom_1 (ADDR_EXPR,
4681 build_pointer_type (TREE_TYPE (arg1_tree)),
4682 arg1_tree);
4683
4684 /* Pass procedure as a pointer to it, anything else by value. */
4685 if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4686 arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4687 else
4688 arg2_tree = ffecom_ptr_to_expr (arg2);
4689 arg2_tree = convert (TREE_TYPE (null_pointer_node),
4690 arg2_tree);
4691
4692 if (arg3 != NULL)
c7e4ee3a 4693 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5ff904cd
JL		 4694 else
4695 arg3_tree = NULL_TREE;
4696
5ff904cd
JL		 4697 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4698 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4699 TREE_CHAIN (arg1_tree) = arg2_tree;
4700
4701 expr_tree
4702 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4703 ffecom_gfrt_kindtype (gfrt),
4704 FALSE,
4705 ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4706 NULL_TREE :
4707 tree_type),
4708 arg1_tree,
c7e4ee3a
CB		 4709 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4710 ffebld_nonter_hook (expr));
5ff904cd
JL		 4711
4712 if (arg3_tree != NULL_TREE)
4713 expr_tree
4714 = ffecom_modify (NULL_TREE, arg3_tree,
4715 convert (TREE_TYPE (arg3_tree),
4716 expr_tree));
4717 }
4718 return expr_tree;
4719
4720 case FFEINTRIN_impALARM:
4721 {
4722 tree arg1_tree;
4723 tree arg2_tree;
4724 tree arg3_tree;
4725
5ff904cd
JL		 4726 arg1_tree = convert (ffecom_f2c_integer_type_node,
4727 ffecom_expr (arg1));
4728 arg1_tree = ffecom_1 (ADDR_EXPR,
4729 build_pointer_type (TREE_TYPE (arg1_tree)),
4730 arg1_tree);
4731
4732 /* Pass procedure as a pointer to it, anything else by value. */
4733 if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4734 arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4735 else
4736 arg2_tree = ffecom_ptr_to_expr (arg2);
4737 arg2_tree = convert (TREE_TYPE (null_pointer_node),
4738 arg2_tree);
4739
4740 if (arg3 != NULL)
c7e4ee3a 4741 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5ff904cd
JL		 4742 else
4743 arg3_tree = NULL_TREE;
4744
5ff904cd
JL		 4745 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4746 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4747 TREE_CHAIN (arg1_tree) = arg2_tree;
4748
4749 expr_tree
4750 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4751 ffecom_gfrt_kindtype (gfrt),
4752 FALSE,
4753 NULL_TREE,
4754 arg1_tree,
c7e4ee3a
CB		 4755 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4756 ffebld_nonter_hook (expr));
5ff904cd
JL		 4757
4758 if (arg3_tree != NULL_TREE)
4759 expr_tree
4760 = ffecom_modify (NULL_TREE, arg3_tree,
4761 convert (TREE_TYPE (arg3_tree),
4762 expr_tree));
4763 }
4764 return expr_tree;
4765
4766 case FFEINTRIN_impCHDIR_subr:
4767 case FFEINTRIN_impFDATE_subr:
4768 case FFEINTRIN_impFGET_subr:
4769 case FFEINTRIN_impFPUT_subr:
4770 case FFEINTRIN_impGETCWD_subr:
4771 case FFEINTRIN_impHOSTNM_subr:
4772 case FFEINTRIN_impSYSTEM_subr:
4773 case FFEINTRIN_impUNLINK_subr:
4774 {
4775 tree arg1_len = integer_zero_node;
4776 tree arg1_tree;
4777 tree arg2_tree;
4778
5ff904cd
JL		 4779 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4780
4781 if (arg2 != NULL)
c7e4ee3a 4782 arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5ff904cd
JL		 4783 else
4784 arg2_tree = NULL_TREE;
4785
5ff904cd
JL		 4786 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4787 arg1_len = build_tree_list (NULL_TREE, arg1_len);
4788 TREE_CHAIN (arg1_tree) = arg1_len;
4789
4790 expr_tree
4791 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4792 ffecom_gfrt_kindtype (gfrt),
4793 FALSE,
4794 NULL_TREE,
4795 arg1_tree,
c7e4ee3a
CB		 4796 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4797 ffebld_nonter_hook (expr));
5ff904cd
JL		 4798
4799 if (arg2_tree != NULL_TREE)
4800 expr_tree
4801 = ffecom_modify (NULL_TREE, arg2_tree,
4802 convert (TREE_TYPE (arg2_tree),
4803 expr_tree));
4804 }
4805 return expr_tree;
4806
4807 case FFEINTRIN_impEXIT:
4808 if (arg1 != NULL)
4809 break;
4810
4811 expr_tree = build_tree_list (NULL_TREE,
4812 ffecom_1 (ADDR_EXPR,
4813 build_pointer_type
4814 (ffecom_integer_type_node),
4815 integer_zero_node));
4816
4817 return
4818 ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4819 ffecom_gfrt_kindtype (gfrt),
4820 FALSE,
4821 void_type_node,
4822 expr_tree,
c7e4ee3a
CB		 4823 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4824 ffebld_nonter_hook (expr));
5ff904cd
JL		 4825
4826 case FFEINTRIN_impFLUSH:
4827 if (arg1 == NULL)
4828 gfrt = FFECOM_gfrtFLUSH;
4829 else
4830 gfrt = FFECOM_gfrtFLUSH1;
4831 break;
4832
4833 case FFEINTRIN_impCHMOD_subr:
4834 case FFEINTRIN_impLINK_subr:
4835 case FFEINTRIN_impRENAME_subr:
4836 case FFEINTRIN_impSYMLNK_subr:
4837 {
4838 tree arg1_len = integer_zero_node;
4839 tree arg1_tree;
4840 tree arg2_len = integer_zero_node;
4841 tree arg2_tree;
4842 tree arg3_tree;
4843
5ff904cd
JL		 4844 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4845 arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
4846 if (arg3 != NULL)
c7e4ee3a 4847 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5ff904cd
JL		 4848 else
4849 arg3_tree = NULL_TREE;
4850
5ff904cd
JL		 4851 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4852 arg1_len = build_tree_list (NULL_TREE, arg1_len);
4853 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4854 arg2_len = build_tree_list (NULL_TREE, arg2_len);
4855 TREE_CHAIN (arg1_tree) = arg2_tree;
4856 TREE_CHAIN (arg2_tree) = arg1_len;
4857 TREE_CHAIN (arg1_len) = arg2_len;
4858 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4859 ffecom_gfrt_kindtype (gfrt),
4860 FALSE,
4861 NULL_TREE,
4862 arg1_tree,
c7e4ee3a
CB		 4863 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4864 ffebld_nonter_hook (expr));
5ff904cd
JL		 4865 if (arg3_tree != NULL_TREE)
4866 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
4867 convert (TREE_TYPE (arg3_tree),
4868 expr_tree));
4869 }
4870 return expr_tree;
4871
4872 case FFEINTRIN_impLSTAT_subr:
4873 case FFEINTRIN_impSTAT_subr:
4874 {
4875 tree arg1_len = integer_zero_node;
4876 tree arg1_tree;
4877 tree arg2_tree;
4878 tree arg3_tree;
4879
5ff904cd
JL		 4880 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4881
4882 arg2_tree = ffecom_ptr_to_expr (arg2);
4883
4884 if (arg3 != NULL)
c7e4ee3a 4885 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5ff904cd
JL		 4886 else
4887 arg3_tree = NULL_TREE;
4888
5ff904cd
JL		 4889 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4890 arg1_len = build_tree_list (NULL_TREE, arg1_len);
4891 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4892 TREE_CHAIN (arg1_tree) = arg2_tree;
4893 TREE_CHAIN (arg2_tree) = arg1_len;
4894 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4895 ffecom_gfrt_kindtype (gfrt),
4896 FALSE,
4897 NULL_TREE,
4898 arg1_tree,
c7e4ee3a
CB		 4899 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4900 ffebld_nonter_hook (expr));
5ff904cd
JL		 4901 if (arg3_tree != NULL_TREE)
4902 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
4903 convert (TREE_TYPE (arg3_tree),
4904 expr_tree));
4905 }
4906 return expr_tree;
4907
4908 case FFEINTRIN_impFGETC_subr:
4909 case FFEINTRIN_impFPUTC_subr:
4910 {
4911 tree arg1_tree;
4912 tree arg2_tree;
4913 tree arg2_len = integer_zero_node;
4914 tree arg3_tree;
4915
5ff904cd
JL		 4916 arg1_tree = convert (ffecom_f2c_integer_type_node,
4917 ffecom_expr (arg1));
4918 arg1_tree = ffecom_1 (ADDR_EXPR,
4919 build_pointer_type (TREE_TYPE (arg1_tree)),
4920 arg1_tree);
4921
4922 arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
c7e4ee3a 4923 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5ff904cd
JL		 4924
4925 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4926 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4927 arg2_len = build_tree_list (NULL_TREE, arg2_len);
4928 TREE_CHAIN (arg1_tree) = arg2_tree;
4929 TREE_CHAIN (arg2_tree) = arg2_len;
4930
4931 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4932 ffecom_gfrt_kindtype (gfrt),
4933 FALSE,
4934 NULL_TREE,
4935 arg1_tree,
c7e4ee3a
CB		 4936 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4937 ffebld_nonter_hook (expr));
5ff904cd
JL		 4938 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
4939 convert (TREE_TYPE (arg3_tree),
4940 expr_tree));
4941 }
4942 return expr_tree;
4943
4944 case FFEINTRIN_impFSTAT_subr:
4945 {
4946 tree arg1_tree;
4947 tree arg2_tree;
4948 tree arg3_tree;
4949
5ff904cd
JL		 4950 arg1_tree = convert (ffecom_f2c_integer_type_node,
4951 ffecom_expr (arg1));
4952 arg1_tree = ffecom_1 (ADDR_EXPR,
4953 build_pointer_type (TREE_TYPE (arg1_tree)),
4954 arg1_tree);
4955
4956 arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
4957 ffecom_ptr_to_expr (arg2));
4958
4959 if (arg3 == NULL)
4960 arg3_tree = NULL_TREE;
4961 else
c7e4ee3a 4962 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5ff904cd
JL		 4963
4964 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4965 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4966 TREE_CHAIN (arg1_tree) = arg2_tree;
4967 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4968 ffecom_gfrt_kindtype (gfrt),
4969 FALSE,
4970 NULL_TREE,
4971 arg1_tree,
c7e4ee3a
CB		 4972 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4973 ffebld_nonter_hook (expr));
5ff904cd
JL		 4974 if (arg3_tree != NULL_TREE) {
4975 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
4976 convert (TREE_TYPE (arg3_tree),
4977 expr_tree));
4978 }
4979 }
4980 return expr_tree;
4981
4982 case FFEINTRIN_impKILL_subr:
4983 {
4984 tree arg1_tree;
4985 tree arg2_tree;
4986 tree arg3_tree;
4987
5ff904cd
JL		 4988 arg1_tree = convert (ffecom_f2c_integer_type_node,
4989 ffecom_expr (arg1));
4990 arg1_tree = ffecom_1 (ADDR_EXPR,
4991 build_pointer_type (TREE_TYPE (arg1_tree)),
4992 arg1_tree);
4993
4994 arg2_tree = convert (ffecom_f2c_integer_type_node,
4995 ffecom_expr (arg2));
4996 arg2_tree = ffecom_1 (ADDR_EXPR,
4997 build_pointer_type (TREE_TYPE (arg2_tree)),
4998 arg2_tree);
4999
5000 if (arg3 == NULL)
5001 arg3_tree = NULL_TREE;
5002 else
c7e4ee3a 5003 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5ff904cd
JL		 5004
5005 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5006 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5007 TREE_CHAIN (arg1_tree) = arg2_tree;
5008 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5009 ffecom_gfrt_kindtype (gfrt),
5010 FALSE,
5011 NULL_TREE,
5012 arg1_tree,
c7e4ee3a
CB		 5013 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5014 ffebld_nonter_hook (expr));
5ff904cd
JL		 5015 if (arg3_tree != NULL_TREE) {
5016 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5017 convert (TREE_TYPE (arg3_tree),
5018 expr_tree));
5019 }
5020 }
5021 return expr_tree;
5022
5023 case FFEINTRIN_impCTIME_subr:
5024 case FFEINTRIN_impTTYNAM_subr:
5025 {
5026 tree arg1_len = integer_zero_node;
5027 tree arg1_tree;
5028 tree arg2_tree;
5029
5ff904cd
JL		 5030 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5031
5032 arg2_tree = convert (((gfrt == FFEINTRIN_impCTIME_subr) ?
5033 ffecom_f2c_longint_type_node :
5034 ffecom_f2c_integer_type_node),
5035 ffecom_expr (arg2));
5036 arg2_tree = ffecom_1 (ADDR_EXPR,
5037 build_pointer_type (TREE_TYPE (arg2_tree)),
5038 arg2_tree);
5039
5ff904cd
JL		 5040 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5041 arg1_len = build_tree_list (NULL_TREE, arg1_len);
5042 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5043 TREE_CHAIN (arg1_len) = arg2_tree;
5044 TREE_CHAIN (arg1_tree) = arg1_len;
5045
5046 expr_tree
5047 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5048 ffecom_gfrt_kindtype (gfrt),
5049 FALSE,
5050 NULL_TREE,
5051 arg1_tree,
c7e4ee3a
CB		 5052 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5053 ffebld_nonter_hook (expr));
5ff904cd
JL		 5054 }
5055 return expr_tree;
5056
5057 case FFEINTRIN_impIRAND:
5058 case FFEINTRIN_impRAND:
5059 /* Arg defaults to 0 (normal random case) */
5060 {
5061 tree arg1_tree;
5062
5063 if (arg1 == NULL)
5064 arg1_tree = ffecom_integer_zero_node;
5065 else
5066 arg1_tree = ffecom_expr (arg1);
5067 arg1_tree = convert (ffecom_f2c_integer_type_node,
5068 arg1_tree);
5069 arg1_tree = ffecom_1 (ADDR_EXPR,
5070 build_pointer_type (TREE_TYPE (arg1_tree)),
5071 arg1_tree);
5072 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5073
5074 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5075 ffecom_gfrt_kindtype (gfrt),
5076 FALSE,
5077 ((codegen_imp == FFEINTRIN_impIRAND) ?
5078 ffecom_f2c_integer_type_node :
de7f278a 5079 ffecom_f2c_real_type_node),
5ff904cd
JL		 5080 arg1_tree,
5081 dest_tree, dest, dest_used,
c7e4ee3a
CB		 5082 NULL_TREE, TRUE,
5083 ffebld_nonter_hook (expr));
5ff904cd
JL		 5084 }
5085 return expr_tree;
5086
5087 case FFEINTRIN_impFTELL_subr:
5088 case FFEINTRIN_impUMASK_subr:
5089 {
5090 tree arg1_tree;
5091 tree arg2_tree;
5092
5ff904cd
JL		 5093 arg1_tree = convert (ffecom_f2c_integer_type_node,
5094 ffecom_expr (arg1));
5095 arg1_tree = ffecom_1 (ADDR_EXPR,
5096 build_pointer_type (TREE_TYPE (arg1_tree)),
5097 arg1_tree);
5098
5099 if (arg2 == NULL)
5100 arg2_tree = NULL_TREE;
5101 else
c7e4ee3a 5102 arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5ff904cd
JL		 5103
5104 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5105 ffecom_gfrt_kindtype (gfrt),
5106 FALSE,
5107 NULL_TREE,
5108 build_tree_list (NULL_TREE, arg1_tree),
5109 NULL_TREE, NULL, NULL, NULL_TREE,
c7e4ee3a
CB		 5110 TRUE,
5111 ffebld_nonter_hook (expr));
5ff904cd
JL		 5112 if (arg2_tree != NULL_TREE) {
5113 expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5114 convert (TREE_TYPE (arg2_tree),
5115 expr_tree));
5116 }
5117 }
5118 return expr_tree;
5119
5120 case FFEINTRIN_impCPU_TIME:
5121 case FFEINTRIN_impSECOND_subr:
5122 {
5123 tree arg1_tree;
5124
c7e4ee3a 5125 arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5ff904cd
JL		 5126
5127 expr_tree
5128 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5129 ffecom_gfrt_kindtype (gfrt),
5130 FALSE,
5131 NULL_TREE,
5132 NULL_TREE,
c7e4ee3a
CB		 5133 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5134 ffebld_nonter_hook (expr));
5ff904cd
JL		 5135
5136 expr_tree
5137 = ffecom_modify (NULL_TREE, arg1_tree,
5138 convert (TREE_TYPE (arg1_tree),
5139 expr_tree));
5140 }
5141 return expr_tree;
5142
5143 case FFEINTRIN_impDTIME_subr:
5144 case FFEINTRIN_impETIME_subr:
5145 {
5146 tree arg1_tree;
5147 tree arg2_tree;
5148
c7e4ee3a 5149 arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5ff904cd
JL		 5150
5151 arg2_tree = ffecom_ptr_to_expr (arg2);
5152
5ff904cd
JL		 5153 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5154 ffecom_gfrt_kindtype (gfrt),
5155 FALSE,
5156 NULL_TREE,
5157 build_tree_list (NULL_TREE, arg2_tree),
5158 NULL_TREE, NULL, NULL, NULL_TREE,
c7e4ee3a
CB		 5159 TRUE,
5160 ffebld_nonter_hook (expr));
5ff904cd
JL		 5161 expr_tree = ffecom_modify (NULL_TREE, arg1_tree,
5162 convert (TREE_TYPE (arg1_tree),
5163 expr_tree));
5164 }
5165 return expr_tree;
5166
c7e4ee3a 5167 /* Straightforward calls of libf2c routines: */
5ff904cd
JL		 5168 case FFEINTRIN_impABORT:
5169 case FFEINTRIN_impACCESS:
5170 case FFEINTRIN_impBESJ0:
5171 case FFEINTRIN_impBESJ1:
5172 case FFEINTRIN_impBESJN:
5173 case FFEINTRIN_impBESY0:
5174 case FFEINTRIN_impBESY1:
5175 case FFEINTRIN_impBESYN:
5176 case FFEINTRIN_impCHDIR_func:
5177 case FFEINTRIN_impCHMOD_func:
5178 case FFEINTRIN_impDATE:
9e8e701d 5179 case FFEINTRIN_impDATE_AND_TIME:
5ff904cd
JL		 5180 case FFEINTRIN_impDBESJ0:
5181 case FFEINTRIN_impDBESJ1:
5182 case FFEINTRIN_impDBESJN:
5183 case FFEINTRIN_impDBESY0:
5184 case FFEINTRIN_impDBESY1:
5185 case FFEINTRIN_impDBESYN:
5186 case FFEINTRIN_impDTIME_func:
5187 case FFEINTRIN_impETIME_func:
5188 case FFEINTRIN_impFGETC_func:
5189 case FFEINTRIN_impFGET_func:
5190 case FFEINTRIN_impFNUM:
5191 case FFEINTRIN_impFPUTC_func:
5192 case FFEINTRIN_impFPUT_func:
5193 case FFEINTRIN_impFSEEK:
5194 case FFEINTRIN_impFSTAT_func:
5195 case FFEINTRIN_impFTELL_func:
5196 case FFEINTRIN_impGERROR:
5197 case FFEINTRIN_impGETARG:
5198 case FFEINTRIN_impGETCWD_func:
5199 case FFEINTRIN_impGETENV:
5200 case FFEINTRIN_impGETGID:
5201 case FFEINTRIN_impGETLOG:
5202 case FFEINTRIN_impGETPID:
5203 case FFEINTRIN_impGETUID:
5204 case FFEINTRIN_impGMTIME:
5205 case FFEINTRIN_impHOSTNM_func:
5206 case FFEINTRIN_impIDATE_unix:
5207 case FFEINTRIN_impIDATE_vxt:
5208 case FFEINTRIN_impIERRNO:
5209 case FFEINTRIN_impISATTY:
5210 case FFEINTRIN_impITIME:
5211 case FFEINTRIN_impKILL_func:
5212 case FFEINTRIN_impLINK_func:
5213 case FFEINTRIN_impLNBLNK:
5214 case FFEINTRIN_impLSTAT_func:
5215 case FFEINTRIN_impLTIME:
5216 case FFEINTRIN_impMCLOCK8:
5217 case FFEINTRIN_impMCLOCK:
5218 case FFEINTRIN_impPERROR:
5219 case FFEINTRIN_impRENAME_func:
5220 case FFEINTRIN_impSECNDS:
5221 case FFEINTRIN_impSECOND_func:
5222 case FFEINTRIN_impSLEEP:
5223 case FFEINTRIN_impSRAND:
5224 case FFEINTRIN_impSTAT_func:
5225 case FFEINTRIN_impSYMLNK_func:
5226 case FFEINTRIN_impSYSTEM_CLOCK:
5227 case FFEINTRIN_impSYSTEM_func:
5228 case FFEINTRIN_impTIME8:
5229 case FFEINTRIN_impTIME_unix:
5230 case FFEINTRIN_impTIME_vxt:
5231 case FFEINTRIN_impUMASK_func:
5232 case FFEINTRIN_impUNLINK_func:
5233 break;
5234
5235 case FFEINTRIN_impCTIME_func: /* CHARACTER functions not handled here. */
5236 case FFEINTRIN_impFDATE_func: /* CHARACTER functions not handled here. */
5237 case FFEINTRIN_impTTYNAM_func: /* CHARACTER functions not handled here. */
5238 case FFEINTRIN_impNONE:
5239 case FFEINTRIN_imp: /* Hush up gcc warning. */
5240 fprintf (stderr, "No %s implementation.\n",
5241 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5242 assert ("unimplemented intrinsic" == NULL);
5243 return error_mark_node;
5244 }
5245
5246 assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5247
5ff904cd
JL		 5248 expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5249 ffebld_right (expr));
5ff904cd
JL		 5250
5251 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5252 (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5253 tree_type,
5254 expr_tree, dest_tree, dest, dest_used,
c7e4ee3a
CB		 5255 NULL_TREE, TRUE,
5256 ffebld_nonter_hook (expr));
5ff904cd 5257
c7e4ee3a
CB		 5258 /* See bottom of this file for f2c transforms used to determine
5259 many of the above implementations. The info seems to confuse
5260 Emacs's C mode indentation, which is why it's been moved to
5261 the bottom of this source file. */
5262}
5ff904cd 5263
c7e4ee3a
CB		 5264#endif
5265/* For power (exponentiation) where right-hand operand is type INTEGER,
5266 generate in-line code to do it the fast way (which, if the operand
5267 is a constant, might just mean a series of multiplies). */
5ff904cd 5268
c7e4ee3a
CB		 5269#if FFECOM_targetCURRENT == FFECOM_targetGCC
5270static tree
5271ffecom_expr_power_integer_ (ffebld expr)
5272{
5273 tree l = ffecom_expr (ffebld_left (expr));
5274 tree r = ffecom_expr (ffebld_right (expr));
5275 tree ltype = TREE_TYPE (l);
5276 tree rtype = TREE_TYPE (r);
5277 tree result = NULL_TREE;
5ff904cd 5278
c7e4ee3a
CB		 5279 if (l == error_mark_node
5280 || r == error_mark_node)
5281 return error_mark_node;
5ff904cd 5282
c7e4ee3a
CB		 5283 if (TREE_CODE (r) == INTEGER_CST)
5284 {
5285 int sgn = tree_int_cst_sgn (r);
5ff904cd 5286
c7e4ee3a
CB		 5287 if (sgn == 0)
5288 return convert (ltype, integer_one_node);
5ff904cd 5289
c7e4ee3a
CB		 5290 if ((TREE_CODE (ltype) == INTEGER_TYPE)
5291 && (sgn < 0))
5292 {
5293 /* Reciprocal of integer is either 0, -1, or 1, so after
5294 calculating that (which we leave to the back end to do
5295 or not do optimally), don't bother with any multiplying. */
5ff904cd 5296
c7e4ee3a
CB		 5297 result = ffecom_tree_divide_ (ltype,
5298 convert (ltype, integer_one_node),
5299 l,
5300 NULL_TREE, NULL, NULL, NULL_TREE);
5301 r = ffecom_1 (NEGATE_EXPR,
5302 rtype,
5303 r);
5304 if ((TREE_INT_CST_LOW (r) & 1) == 0)
5305 result = ffecom_1 (ABS_EXPR, rtype,
5306 result);
5307 }
5ff904cd 5308
c7e4ee3a
CB		 5309 /* Generate appropriate series of multiplies, preceded
5310 by divide if the exponent is negative. */
5ff904cd 5311
c7e4ee3a 5312 l = save_expr (l);
5ff904cd 5313
c7e4ee3a
CB		 5314 if (sgn < 0)
5315 {
5316 l = ffecom_tree_divide_ (ltype,
5317 convert (ltype, integer_one_node),
5318 l,
5319 NULL_TREE, NULL, NULL,
5320 ffebld_nonter_hook (expr));
5321 r = ffecom_1 (NEGATE_EXPR, rtype, r);
5322 assert (TREE_CODE (r) == INTEGER_CST);
5ff904cd 5323
c7e4ee3a
CB		 5324 if (tree_int_cst_sgn (r) < 0)
5325 { /* The "most negative" number. */
5326 r = ffecom_1 (NEGATE_EXPR, rtype,
5327 ffecom_2 (RSHIFT_EXPR, rtype,
5328 r,
5329 integer_one_node));
5330 l = save_expr (l);
5331 l = ffecom_2 (MULT_EXPR, ltype,
5332 l,
5333 l);
5334 }
5335 }
5ff904cd 5336
c7e4ee3a
CB		 5337 for (;;)
5338 {
5339 if (TREE_INT_CST_LOW (r) & 1)
5340 {
5341 if (result == NULL_TREE)
5342 result = l;
5343 else
5344 result = ffecom_2 (MULT_EXPR, ltype,
5345 result,
5346 l);
5347 }
5ff904cd 5348
c7e4ee3a
CB		 5349 r = ffecom_2 (RSHIFT_EXPR, rtype,
5350 r,
5351 integer_one_node);
5352 if (integer_zerop (r))
5353 break;
5354 assert (TREE_CODE (r) == INTEGER_CST);
5ff904cd 5355
c7e4ee3a
CB		 5356 l = save_expr (l);
5357 l = ffecom_2 (MULT_EXPR, ltype,
5358 l,
5359 l);
5360 }
5361 return result;
5362 }
5ff904cd 5363
c7e4ee3a
CB		 5364 /* Though rhs isn't a constant, in-line code cannot be expanded
5365 while transforming dummies
5366 because the back end cannot be easily convinced to generate
5367 stores (MODIFY_EXPR), handle temporaries, and so on before
5368 all the appropriate rtx's have been generated for things like
5369 dummy args referenced in rhs -- which doesn't happen until
5370 store_parm_decls() is called (expand_function_start, I believe,
5371 does the actual rtx-stuffing of PARM_DECLs).
5ff904cd 5372
c7e4ee3a
CB		 5373 So, in this case, let the caller generate the call to the
5374 run-time-library function to evaluate the power for us. */
5ff904cd 5375
c7e4ee3a
CB		 5376 if (ffecom_transform_only_dummies_)
5377 return NULL_TREE;
5ff904cd 5378
c7e4ee3a
CB		 5379 /* Right-hand operand not a constant, expand in-line code to figure
5380 out how to do the multiplies, &c.
5ff904cd 5381
c7e4ee3a
CB		 5382 The returned expression is expressed this way in GNU C, where l and
5383 r are the "inputs":
5ff904cd 5384
c7e4ee3a
CB		 5385 ({ typeof (r) rtmp = r;
5386 typeof (l) ltmp = l;
5387 typeof (l) result;
5ff904cd 5388
c7e4ee3a
CB		 5389 if (rtmp == 0)
5390 result = 1;
5391 else
5392 {
5393 if ((basetypeof (l) == basetypeof (int))
5394 && (rtmp < 0))
5395 {
5396 result = ((typeof (l)) 1) / ltmp;
5397 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5398 result = -result;
5399 }
5400 else
5401 {
5402 result = 1;
5403 if ((basetypeof (l) != basetypeof (int))
5404 && (rtmp < 0))
5405 {
5406 ltmp = ((typeof (l)) 1) / ltmp;
5407 rtmp = -rtmp;
5408 if (rtmp < 0)
5409 {
5410 rtmp = -(rtmp >> 1);
5411 ltmp *= ltmp;
5412 }
5413 }
5414 for (;;)
5415 {
5416 if (rtmp & 1)
5417 result *= ltmp;
5418 if ((rtmp >>= 1) == 0)
5419 break;
5420 ltmp *= ltmp;
5421 }
5422 }
5423 }
5424 result;
5425 })
5ff904cd 5426
c7e4ee3a
CB		 5427 Note that some of the above is compile-time collapsable, such as
5428 the first part of the if statements that checks the base type of
5429 l against int. The if statements are phrased that way to suggest
5430 an easy way to generate the if/else constructs here, knowing that
5431 the back end should (and probably does) eliminate the resulting
5432 dead code (either the int case or the non-int case), something
5433 it couldn't do without the redundant phrasing, requiring explicit
5434 dead-code elimination here, which would be kind of difficult to
5435 read. */
5ff904cd 5436
c7e4ee3a
CB		 5437 {
5438 tree rtmp;
5439 tree ltmp;
5440 tree divide;
5441 tree basetypeof_l_is_int;
5442 tree se;
5443 tree t;
5ff904cd 5444
c7e4ee3a
CB		 5445 basetypeof_l_is_int
5446 = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5ff904cd 5447
c7e4ee3a 5448 se = expand_start_stmt_expr ();
5ff904cd 5449
c7e4ee3a
CB		 5450 ffecom_start_compstmt ();
5451
5452#ifndef HAHA
5453 rtmp = ffecom_make_tempvar ("power_r", rtype,
5454 FFETARGET_charactersizeNONE, -1);
5455 ltmp = ffecom_make_tempvar ("power_l", ltype,
5456 FFETARGET_charactersizeNONE, -1);
5457 result = ffecom_make_tempvar ("power_res", ltype,
5458 FFETARGET_charactersizeNONE, -1);
5459 if (TREE_CODE (ltype) == COMPLEX_TYPE
5460 || TREE_CODE (ltype) == RECORD_TYPE)
5461 divide = ffecom_make_tempvar ("power_div", ltype,
5462 FFETARGET_charactersizeNONE, -1);
5463 else
5464 divide = NULL_TREE;
5465#else /* HAHA */
5466 {
5467 tree hook;
5468
5469 hook = ffebld_nonter_hook (expr);
5470 assert (hook);
5471 assert (TREE_CODE (hook) == TREE_VEC);
5472 assert (TREE_VEC_LENGTH (hook) == 4);
5473 rtmp = TREE_VEC_ELT (hook, 0);
5474 ltmp = TREE_VEC_ELT (hook, 1);
5475 result = TREE_VEC_ELT (hook, 2);
5476 divide = TREE_VEC_ELT (hook, 3);
5477 if (TREE_CODE (ltype) == COMPLEX_TYPE
5478 || TREE_CODE (ltype) == RECORD_TYPE)
5479 assert (divide);
5480 else
5481 assert (! divide);
5482 }
5483#endif /* HAHA */
5ff904cd 5484
c7e4ee3a
CB		 5485 expand_expr_stmt (ffecom_modify (void_type_node,
5486 rtmp,
5487 r));
5488 expand_expr_stmt (ffecom_modify (void_type_node,
5489 ltmp,
5490 l));
5491 expand_start_cond (ffecom_truth_value
5492 (ffecom_2 (EQ_EXPR, integer_type_node,
5493 rtmp,
5494 convert (rtype, integer_zero_node))),
5495 0);
5496 expand_expr_stmt (ffecom_modify (void_type_node,
5497 result,
5498 convert (ltype, integer_one_node)));
5499 expand_start_else ();
5500 if (! integer_zerop (basetypeof_l_is_int))
5501 {
5502 expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5503 rtmp,
5504 convert (rtype,
5505 integer_zero_node)),
5506 0);
5507 expand_expr_stmt (ffecom_modify (void_type_node,
5508 result,
5509 ffecom_tree_divide_
5510 (ltype,
5511 convert (ltype, integer_one_node),
5512 ltmp,
5513 NULL_TREE, NULL, NULL,
5514 divide)));
5515 expand_start_cond (ffecom_truth_value
5516 (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5517 ffecom_2 (LT_EXPR, integer_type_node,
5518 ltmp,
5519 convert (ltype,
5520 integer_zero_node)),
5521 ffecom_2 (EQ_EXPR, integer_type_node,
5522 ffecom_2 (BIT_AND_EXPR,
5523 rtype,
5524 ffecom_1 (NEGATE_EXPR,
5525 rtype,
5526 rtmp),
5527 convert (rtype,
5528 integer_one_node)),
5529 convert (rtype,
5530 integer_zero_node)))),
5531 0);
5532 expand_expr_stmt (ffecom_modify (void_type_node,
5533 result,
5534 ffecom_1 (NEGATE_EXPR,
5535 ltype,
5536 result)));
5537 expand_end_cond ();
5538 expand_start_else ();
5539 }
5540 expand_expr_stmt (ffecom_modify (void_type_node,
5541 result,
5542 convert (ltype, integer_one_node)));
5543 expand_start_cond (ffecom_truth_value
5544 (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5545 ffecom_truth_value_invert
5546 (basetypeof_l_is_int),
5547 ffecom_2 (LT_EXPR, integer_type_node,
5548 rtmp,
5549 convert (rtype,
5550 integer_zero_node)))),
5551 0);
5552 expand_expr_stmt (ffecom_modify (void_type_node,
5553 ltmp,
5554 ffecom_tree_divide_
5555 (ltype,
5556 convert (ltype, integer_one_node),
5557 ltmp,
5558 NULL_TREE, NULL, NULL,
5559 divide)));
5560 expand_expr_stmt (ffecom_modify (void_type_node,
5561 rtmp,
5562 ffecom_1 (NEGATE_EXPR, rtype,
5563 rtmp)));
5564 expand_start_cond (ffecom_truth_value
5565 (ffecom_2 (LT_EXPR, integer_type_node,
5566 rtmp,
5567 convert (rtype, integer_zero_node))),
5568 0);
5569 expand_expr_stmt (ffecom_modify (void_type_node,
5570 rtmp,
5571 ffecom_1 (NEGATE_EXPR, rtype,
5572 ffecom_2 (RSHIFT_EXPR,
5573 rtype,
5574 rtmp,
5575 integer_one_node))));
5576 expand_expr_stmt (ffecom_modify (void_type_node,
5577 ltmp,
5578 ffecom_2 (MULT_EXPR, ltype,
5579 ltmp,
5580 ltmp)));
5581 expand_end_cond ();
5582 expand_end_cond ();
5583 expand_start_loop (1);
5584 expand_start_cond (ffecom_truth_value
5585 (ffecom_2 (BIT_AND_EXPR, rtype,
5586 rtmp,
5587 convert (rtype, integer_one_node))),
5588 0);
5589 expand_expr_stmt (ffecom_modify (void_type_node,
5590 result,
5591 ffecom_2 (MULT_EXPR, ltype,
5592 result,
5593 ltmp)));
5594 expand_end_cond ();
5595 expand_exit_loop_if_false (NULL,
5596 ffecom_truth_value
5597 (ffecom_modify (rtype,
5598 rtmp,
5599 ffecom_2 (RSHIFT_EXPR,
5600 rtype,
5601 rtmp,
5602 integer_one_node))));
5603 expand_expr_stmt (ffecom_modify (void_type_node,
5604 ltmp,
5605 ffecom_2 (MULT_EXPR, ltype,
5606 ltmp,
5607 ltmp)));
5608 expand_end_loop ();
5609 expand_end_cond ();
5610 if (!integer_zerop (basetypeof_l_is_int))
5611 expand_end_cond ();
5612 expand_expr_stmt (result);
5ff904cd 5613
c7e4ee3a 5614 t = ffecom_end_compstmt ();
5ff904cd 5615
c7e4ee3a 5616 result = expand_end_stmt_expr (se);
5ff904cd 5617
c7e4ee3a 5618 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5ff904cd 5619
c7e4ee3a
CB		 5620 if (TREE_CODE (t) == BLOCK)
5621 {
5622 /* Make a BIND_EXPR for the BLOCK already made. */
5623 result = build (BIND_EXPR, TREE_TYPE (result),
5624 NULL_TREE, result, t);
5625 /* Remove the block from the tree at this point.
5626 It gets put back at the proper place
5627 when the BIND_EXPR is expanded. */
5628 delete_block (t);
5629 }
5630 else
5631 result = t;
5632 }
5ff904cd 5633
c7e4ee3a
CB		 5634 return result;
5635}
5ff904cd 5636
c7e4ee3a
CB		 5637#endif
5638/* ffecom_expr_transform_ -- Transform symbols in expr
5ff904cd 5639
c7e4ee3a
CB		 5640 ffebld expr; // FFE expression.
5641 ffecom_expr_transform_ (expr);
5ff904cd 5642
c7e4ee3a 5643 Recursive descent on expr while transforming any untransformed SYMTERs. */
5ff904cd 5644
c7e4ee3a
CB		 5645#if FFECOM_targetCURRENT == FFECOM_targetGCC
5646static void
5647ffecom_expr_transform_ (ffebld expr)
5648{
5649 tree t;
5650 ffesymbol s;
5ff904cd 5651
c7e4ee3a 5652tail_recurse: /* :::::::::::::::::::: */
5ff904cd 5653
c7e4ee3a
CB		 5654 if (expr == NULL)
5655 return;
5ff904cd 5656
c7e4ee3a
CB		 5657 switch (ffebld_op (expr))
5658 {
5659 case FFEBLD_opSYMTER:
5660 s = ffebld_symter (expr);
5661 t = ffesymbol_hook (s).decl_tree;
5662 if ((t == NULL_TREE)
5663 && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5664 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5665 && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5666 {
5667 s = ffecom_sym_transform_ (s);
5668 t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy,
5669 DIMENSION expr? */
5670 }
5671 break; /* Ok if (t == NULL) here. */
5ff904cd 5672
c7e4ee3a
CB		 5673 case FFEBLD_opITEM:
5674 ffecom_expr_transform_ (ffebld_head (expr));
5675 expr = ffebld_trail (expr);
5676 goto tail_recurse; /* :::::::::::::::::::: */
5ff904cd 5677
c7e4ee3a
CB		 5678 default:
5679 break;
5680 }
5ff904cd 5681
c7e4ee3a
CB		 5682 switch (ffebld_arity (expr))
5683 {
5684 case 2:
5685 ffecom_expr_transform_ (ffebld_left (expr));
5686 expr = ffebld_right (expr);
5687 goto tail_recurse; /* :::::::::::::::::::: */
5ff904cd 5688
c7e4ee3a
CB		 5689 case 1:
5690 expr = ffebld_left (expr);
5691 goto tail_recurse; /* :::::::::::::::::::: */
5ff904cd 5692
c7e4ee3a
CB		 5693 default:
5694 break;
5695 }
5ff904cd 5696
c7e4ee3a
CB		 5697 return;
5698}
5ff904cd 5699
c7e4ee3a
CB		 5700#endif
5701/* Make a type based on info in live f2c.h file. */
5ff904cd 5702
c7e4ee3a
CB		 5703#if FFECOM_targetCURRENT == FFECOM_targetGCC
5704static void
5705ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5706{
5707 switch (tcode)
5708 {
5709 case FFECOM_f2ccodeCHAR:
5710 *type = make_signed_type (CHAR_TYPE_SIZE);
5711 break;
5ff904cd 5712
c7e4ee3a
CB		 5713 case FFECOM_f2ccodeSHORT:
5714 *type = make_signed_type (SHORT_TYPE_SIZE);
5715 break;
5ff904cd 5716
c7e4ee3a
CB		 5717 case FFECOM_f2ccodeINT:
5718 *type = make_signed_type (INT_TYPE_SIZE);
5719 break;
5ff904cd 5720
c7e4ee3a
CB		 5721 case FFECOM_f2ccodeLONG:
5722 *type = make_signed_type (LONG_TYPE_SIZE);
5723 break;
5ff904cd 5724
c7e4ee3a
CB		 5725 case FFECOM_f2ccodeLONGLONG:
5726 *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5727 break;
5ff904cd 5728
c7e4ee3a
CB		 5729 case FFECOM_f2ccodeCHARPTR:
5730 *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5731 ? signed_char_type_node
5732 : unsigned_char_type_node);
5733 break;
5ff904cd 5734
c7e4ee3a
CB		 5735 case FFECOM_f2ccodeFLOAT:
5736 *type = make_node (REAL_TYPE);
5737 TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5738 layout_type (*type);
5739 break;
5740
5741 case FFECOM_f2ccodeDOUBLE:
5742 *type = make_node (REAL_TYPE);
5743 TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5744 layout_type (*type);
5745 break;
5746
5747 case FFECOM_f2ccodeLONGDOUBLE:
5748 *type = make_node (REAL_TYPE);
5749 TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5750 layout_type (*type);
5751 break;
5ff904cd 5752
c7e4ee3a
CB		 5753 case FFECOM_f2ccodeTWOREALS:
5754 *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5755 break;
5ff904cd 5756
c7e4ee3a
CB		 5757 case FFECOM_f2ccodeTWODOUBLEREALS:
5758 *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5759 break;
5ff904cd 5760
c7e4ee3a
CB		 5761 default:
5762 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5763 *type = error_mark_node;
5764 return;
5765 }
5ff904cd 5766
c7e4ee3a
CB		 5767 pushdecl (build_decl (TYPE_DECL,
5768 ffecom_get_invented_identifier ("__g77_f2c_%s",
5769 name, -1),
5770 *type));
5771}
5ff904cd 5772
c7e4ee3a
CB		 5773#endif
5774#if FFECOM_targetCURRENT == FFECOM_targetGCC
5775/* Set the f2c list-directed-I/O code for whatever (integral) type has the
5776 given size. */
5ff904cd 5777
c7e4ee3a
CB		 5778static void
5779ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5780 int code)
5781{
5782 int j;
5783 tree t;
5ff904cd 5784
c7e4ee3a
CB		 5785 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5786 if (((t = ffecom_tree_type[bt][j]) != NULL_TREE)
5787 && (TREE_INT_CST_LOW (TYPE_SIZE (t)) == size))
5788 {
5789 assert (code != -1);
5790 ffecom_f2c_typecode_[bt][j] = code;
5791 code = -1;
5792 }
5793}
5ff904cd 5794
c7e4ee3a
CB		 5795#endif
5796/* Finish up globals after doing all program units in file
5ff904cd 5797
c7e4ee3a 5798 Need to handle only uninitialized COMMON areas. */
5ff904cd 5799
c7e4ee3a
CB		 5800#if FFECOM_targetCURRENT == FFECOM_targetGCC
5801static ffeglobal
5802ffecom_finish_global_ (ffeglobal global)
5803{
5804 tree cbtype;
5805 tree cbt;
5806 tree size;
5ff904cd 5807
c7e4ee3a
CB		 5808 if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5809 return global;
5ff904cd 5810
c7e4ee3a
CB		 5811 if (ffeglobal_common_init (global))
5812 return global;
5ff904cd 5813
c7e4ee3a
CB		 5814 cbt = ffeglobal_hook (global);
5815 if ((cbt == NULL_TREE)
5816 || !ffeglobal_common_have_size (global))
5817 return global; /* No need to make common, never ref'd. */
5ff904cd 5818
c7e4ee3a 5819 suspend_momentary ();
5ff904cd 5820
c7e4ee3a 5821 DECL_EXTERNAL (cbt) = 0;
5ff904cd 5822
c7e4ee3a 5823 /* Give the array a size now. */
5ff904cd 5824
c7e4ee3a
CB		 5825 size = build_int_2 ((ffeglobal_common_size (global)
5826 + ffeglobal_common_pad (global)) - 1,
5827 0);
5ff904cd 5828
c7e4ee3a
CB		 5829 cbtype = TREE_TYPE (cbt);
5830 TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
5831 integer_zero_node,
5832 size);
5833 if (!TREE_TYPE (size))
5834 TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
5835 layout_type (cbtype);
5ff904cd 5836
c7e4ee3a
CB		 5837 cbt = start_decl (cbt, FALSE);
5838 assert (cbt == ffeglobal_hook (global));
5ff904cd 5839
c7e4ee3a 5840 finish_decl (cbt, NULL_TREE, FALSE);
5ff904cd 5841
c7e4ee3a
CB		 5842 return global;
5843}
5ff904cd 5844
c7e4ee3a
CB		 5845#endif
5846/* Finish up any untransformed symbols. */
5ff904cd 5847
c7e4ee3a
CB		 5848#if FFECOM_targetCURRENT == FFECOM_targetGCC
5849static ffesymbol
5850ffecom_finish_symbol_transform_ (ffesymbol s)
5ff904cd 5851{
c7e4ee3a
CB		 5852 if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
5853 return s;
5ff904cd 5854
c7e4ee3a
CB		 5855 /* It's easy to know to transform an untransformed symbol, to make sure
5856 we put out debugging info for it. But COMMON variables, unlike
5857 EQUIVALENCE ones, aren't given declarations in addition to the
5858 tree expressions that specify offsets, because COMMON variables
5859 can be referenced in the outer scope where only dummy arguments
5860 (PARM_DECLs) should really be seen. To be safe, just don't do any
5861 VAR_DECLs for COMMON variables when we transform them for real
5862 use, and therefore we do all the VAR_DECL creating here. */
5ff904cd 5863
c7e4ee3a
CB		 5864 if (ffesymbol_hook (s).decl_tree == NULL_TREE)
5865 {
5866 if (ffesymbol_kind (s) != FFEINFO_kindNONE
5867 || (ffesymbol_where (s) != FFEINFO_whereNONE
5868 && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
5869 && ffesymbol_where (s) != FFEINFO_whereDUMMY))
5870 /* Not transformed, and not CHARACTER*(*), and not a dummy
5871 argument, which can happen only if the entry point names
5872 it "rides in on" are all invalidated for other reasons. */
5873 s = ffecom_sym_transform_ (s);
5874 }
5ff904cd 5875
c7e4ee3a
CB		 5876 if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
5877 && (ffesymbol_hook (s).decl_tree != error_mark_node))
5878 {
5879#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
5880 int yes = suspend_momentary ();
5ff904cd 5881
c7e4ee3a
CB		 5882 /* This isn't working, at least for dbxout. The .s file looks
5883 okay to me (burley), but in gdb 4.9 at least, the variables
5884 appear to reside somewhere outside of the common area, so
5885 it doesn't make sense to mislead anyone by generating the info
5886 on those variables until this is fixed. NOTE: Same problem
5887 with EQUIVALENCE, sadly...see similar #if later. */
5888 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
5889 ffesymbol_storage (s));
5ff904cd 5890
c7e4ee3a
CB		 5891 resume_momentary (yes);
5892#endif
5ff904cd
JL		 5893 }
5894
c7e4ee3a
CB		 5895 return s;
5896}
5ff904cd 5897
c7e4ee3a
CB		 5898#endif
5899/* Append underscore(s) to name before calling get_identifier. "us"
5900 is nonzero if the name already contains an underscore and thus
5901 needs two underscores appended. */
5ff904cd 5902
c7e4ee3a
CB		 5903#if FFECOM_targetCURRENT == FFECOM_targetGCC
5904static tree
5905ffecom_get_appended_identifier_ (char us, const char *name)
5906{
5907 int i;
5908 char *newname;
5909 tree id;
5ff904cd 5910
c7e4ee3a
CB		 5911 newname = xmalloc ((i = strlen (name)) + 1
5912 + ffe_is_underscoring ()
5913 + us);
5914 memcpy (newname, name, i);
5915 newname[i] = '_';
5916 newname[i + us] = '_';
5917 newname[i + 1 + us] = '\0';
5918 id = get_identifier (newname);
5ff904cd 5919
c7e4ee3a 5920 free (newname);
5ff904cd 5921
c7e4ee3a
CB		 5922 return id;
5923}
5ff904cd 5924
c7e4ee3a
CB		 5925#endif
5926/* Decide whether to append underscore to name before calling
5927 get_identifier. */
5ff904cd 5928
c7e4ee3a
CB		 5929#if FFECOM_targetCURRENT == FFECOM_targetGCC
5930static tree
5931ffecom_get_external_identifier_ (ffesymbol s)
5932{
5933 char us;
5934 const char *name = ffesymbol_text (s);
5ff904cd 5935
c7e4ee3a 5936 /* If name is a built-in name, just return it as is. */
5ff904cd 5937
c7e4ee3a
CB		 5938 if (!ffe_is_underscoring ()
5939 || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
5940#if FFETARGET_isENFORCED_MAIN_NAME
5941 || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
5942#else
5943 || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
5944#endif
5945 || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
5946 return get_identifier (name);
5ff904cd 5947
c7e4ee3a
CB		 5948 us = ffe_is_second_underscore ()
5949 ? (strchr (name, '_') != NULL)
5950 : 0;
5ff904cd 5951
c7e4ee3a
CB		 5952 return ffecom_get_appended_identifier_ (us, name);
5953}
5ff904cd 5954
c7e4ee3a
CB		 5955#endif
5956/* Decide whether to append underscore to internal name before calling
5957 get_identifier.
5958
5959 This is for non-external, top-function-context names only. Transform
5960 identifier so it doesn't conflict with the transformed result
5961 of using a _different_ external name. E.g. if "CALL FOO" is
5962 transformed into "FOO_();", then the variable in "FOO_ = 3"
5963 must be transformed into something that does not conflict, since
5964 these two things should be independent.
5ff904cd 5965
c7e4ee3a
CB		 5966 The transformation is as follows. If the name does not contain
5967 an underscore, there is no possible conflict, so just return.
5968 If the name does contain an underscore, then transform it just
5969 like we transform an external identifier. */
5ff904cd 5970
c7e4ee3a
CB		 5971#if FFECOM_targetCURRENT == FFECOM_targetGCC
5972static tree
5973ffecom_get_identifier_ (const char *name)
5974{
5975 /* If name does not contain an underscore, just return it as is. */
5976
5977 if (!ffe_is_underscoring ()
5978 || (strchr (name, '_') == NULL))
5979 return get_identifier (name);
5980
5981 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
5982 name);
5ff904cd
JL		 5983}
5984
5985#endif
c7e4ee3a 5986/* ffecom_gen_sfuncdef_ -- Generate definition of statement function
5ff904cd 5987
c7e4ee3a
CB		 5988 tree t;
5989 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
5990 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
5991 ffesymbol_kindtype(s));
5ff904cd 5992
c7e4ee3a
CB		 5993 Call after setting up containing function and getting trees for all
5994 other symbols. */
5ff904cd
JL		 5995
5996#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 5997static tree
5998ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
5ff904cd 5999{
c7e4ee3a
CB		 6000 ffebld expr = ffesymbol_sfexpr (s);
6001 tree type;
6002 tree func;
6003 tree result;
6004 bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6005 static bool recurse = FALSE;
6006 int yes;
6007 int old_lineno = lineno;
6008 char *old_input_filename = input_filename;
5ff904cd 6009
c7e4ee3a 6010 ffecom_nested_entry_ = s;
5ff904cd 6011
c7e4ee3a
CB		 6012 /* For now, we don't have a handy pointer to where the sfunc is actually
6013 defined, though that should be easy to add to an ffesymbol. (The
6014 token/where info available might well point to the place where the type
6015 of the sfunc is declared, especially if that precedes the place where
6016 the sfunc itself is defined, which is typically the case.) We should
6017 put out a null pointer rather than point somewhere wrong, but I want to
6018 see how it works at this point. */
5ff904cd 6019
c7e4ee3a
CB		 6020 input_filename = ffesymbol_where_filename (s);
6021 lineno = ffesymbol_where_filelinenum (s);
5ff904cd 6022
c7e4ee3a
CB		 6023 /* Pretransform the expression so any newly discovered things belong to the
6024 outer program unit, not to the statement function. */
5ff904cd 6025
c7e4ee3a 6026 ffecom_expr_transform_ (expr);
5ff904cd 6027
c7e4ee3a
CB		 6028 /* Make sure no recursive invocation of this fn (a specific case of failing
6029 to pretransform an sfunc's expression, i.e. where its expression
6030 references another untransformed sfunc) happens. */
6031
6032 assert (!recurse);
6033 recurse = TRUE;
6034
6035 yes = suspend_momentary ();
6036
6037 push_f_function_context ();
6038
6039 if (charfunc)
6040 type = void_type_node;
6041 else
5ff904cd 6042 {
c7e4ee3a
CB		 6043 type = ffecom_tree_type[bt][kt];
6044 if (type == NULL_TREE)
6045 type = integer_type_node; /* _sym_exec_transition reports
6046 error. */
6047 }
5ff904cd 6048
c7e4ee3a
CB		 6049 start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6050 build_function_type (type, NULL_TREE),
6051 1, /* nested/inline */
6052 0); /* TREE_PUBLIC */
5ff904cd 6053
c7e4ee3a
CB		 6054 /* We don't worry about COMPLEX return values here, because this is
6055 entirely internal to our code, and gcc has the ability to return COMPLEX
6056 directly as a value. */
6057
6058 yes = suspend_momentary ();
6059
6060 if (charfunc)
6061 { /* Prepend arg for where result goes. */
6062 tree type;
6063
6064 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6065
6066 result = ffecom_get_invented_identifier ("__g77_%s",
6067 "result", -1);
6068
6069 ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */
6070
6071 type = build_pointer_type (type);
6072 result = build_decl (PARM_DECL, result, type);
6073
6074 push_parm_decl (result);
5ff904cd 6075 }
c7e4ee3a
CB		 6076 else
6077 result = NULL_TREE; /* Not ref'd if !charfunc. */
5ff904cd 6078
c7e4ee3a 6079 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
5ff904cd 6080
c7e4ee3a 6081 resume_momentary (yes);
5ff904cd 6082
c7e4ee3a
CB		 6083 store_parm_decls (0);
6084
6085 ffecom_start_compstmt ();
6086
6087 if (expr != NULL)
5ff904cd 6088 {
c7e4ee3a
CB		 6089 if (charfunc)
6090 {
6091 ffetargetCharacterSize sz = ffesymbol_size (s);
6092 tree result_length;
5ff904cd 6093
c7e4ee3a
CB		 6094 result_length = build_int_2 (sz, 0);
6095 TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
5ff904cd 6096
c7e4ee3a 6097 ffecom_prepare_let_char_ (sz, expr);
5ff904cd 6098
c7e4ee3a 6099 ffecom_prepare_end ();
5ff904cd 6100
c7e4ee3a
CB		 6101 ffecom_let_char_ (result, result_length, sz, expr);
6102 expand_null_return ();
6103 }
6104 else
6105 {
6106 ffecom_prepare_expr (expr);
5ff904cd 6107
c7e4ee3a 6108 ffecom_prepare_end ();
5ff904cd 6109
c7e4ee3a
CB		 6110 expand_return (ffecom_modify (NULL_TREE,
6111 DECL_RESULT (current_function_decl),
6112 ffecom_expr (expr)));
6113 }
5ff904cd 6114
c7e4ee3a
CB		 6115 clear_momentary ();
6116 }
5ff904cd 6117
c7e4ee3a 6118 ffecom_end_compstmt ();
5ff904cd 6119
c7e4ee3a
CB		 6120 func = current_function_decl;
6121 finish_function (1);
5ff904cd 6122
c7e4ee3a 6123 pop_f_function_context ();
5ff904cd 6124
c7e4ee3a 6125 resume_momentary (yes);
5ff904cd 6126
c7e4ee3a
CB		 6127 recurse = FALSE;
6128
6129 lineno = old_lineno;
6130 input_filename = old_input_filename;
6131
6132 ffecom_nested_entry_ = NULL;
6133
6134 return func;
5ff904cd
JL		 6135}
6136
6137#endif
5ff904cd 6138
c7e4ee3a
CB		 6139#if FFECOM_targetCURRENT == FFECOM_targetGCC
6140static const char *
6141ffecom_gfrt_args_ (ffecomGfrt ix)
5ff904cd 6142{
c7e4ee3a
CB		 6143 return ffecom_gfrt_argstring_[ix];
6144}
5ff904cd 6145
c7e4ee3a
CB		 6146#endif
6147#if FFECOM_targetCURRENT == FFECOM_targetGCC
6148static tree
6149ffecom_gfrt_tree_ (ffecomGfrt ix)
6150{
6151 if (ffecom_gfrt_[ix] == NULL_TREE)
6152 ffecom_make_gfrt_ (ix);
6153
6154 return ffecom_1 (ADDR_EXPR,
6155 build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6156 ffecom_gfrt_[ix]);
5ff904cd
JL		 6157}
6158
6159#endif
c7e4ee3a 6160/* Return initialize-to-zero expression for this VAR_DECL. */
5ff904cd
JL		 6161
6162#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 6163static tree
6164ffecom_init_zero_ (tree decl)
5ff904cd 6165{
c7e4ee3a
CB		 6166 tree init;
6167 int incremental = TREE_STATIC (decl);
6168 tree type = TREE_TYPE (decl);
5ff904cd 6169
c7e4ee3a
CB		 6170 if (incremental)
6171 {
6172 int momentary = suspend_momentary ();
6173 push_obstacks_nochange ();
6174 if (TREE_PERMANENT (decl))
6175 end_temporary_allocation ();
6176 make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
6177 assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6178 pop_obstacks ();
6179 resume_momentary (momentary);
6180 }
5ff904cd 6181
c7e4ee3a 6182 push_momentary ();
5ff904cd 6183
c7e4ee3a
CB		 6184 if ((TREE_CODE (type) != ARRAY_TYPE)
6185 && (TREE_CODE (type) != RECORD_TYPE)
6186 && (TREE_CODE (type) != UNION_TYPE)
6187 && !incremental)
6188 init = convert (type, integer_zero_node);
6189 else if (!incremental)
6190 {
6191 int momentary = suspend_momentary ();
5ff904cd 6192
c7e4ee3a
CB		 6193 init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6194 TREE_CONSTANT (init) = 1;
6195 TREE_STATIC (init) = 1;
5ff904cd 6196
c7e4ee3a
CB		 6197 resume_momentary (momentary);
6198 }
6199 else
6200 {
6201 int momentary = suspend_momentary ();
5ff904cd 6202
c7e4ee3a
CB		 6203 assemble_zeros (int_size_in_bytes (type));
6204 init = error_mark_node;
5ff904cd 6205
c7e4ee3a
CB		 6206 resume_momentary (momentary);
6207 }
5ff904cd 6208
c7e4ee3a 6209 pop_momentary_nofree ();
5ff904cd 6210
c7e4ee3a 6211 return init;
5ff904cd
JL		 6212}
6213
6214#endif
5ff904cd 6215#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 6216static tree
6217ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6218 tree *maybe_tree)
5ff904cd 6219{
c7e4ee3a
CB		 6220 tree expr_tree;
6221 tree length_tree;
5ff904cd 6222
c7e4ee3a 6223 switch (ffebld_op (arg))
6829256f 6224 {
c7e4ee3a
CB		 6225 case FFEBLD_opCONTER: /* For F90, check 0-length. */
6226 if (ffetarget_length_character1
6227 (ffebld_constant_character1
6228 (ffebld_conter (arg))) == 0)
6229 {
6230 *maybe_tree = integer_zero_node;
6231 return convert (tree_type, integer_zero_node);
6232 }
5ff904cd 6233
c7e4ee3a
CB		 6234 *maybe_tree = integer_one_node;
6235 expr_tree = build_int_2 (*ffetarget_text_character1
6236 (ffebld_constant_character1
6237 (ffebld_conter (arg))),
6238 0);
6239 TREE_TYPE (expr_tree) = tree_type;
6240 return expr_tree;
5ff904cd 6241
c7e4ee3a
CB		 6242 case FFEBLD_opSYMTER:
6243 case FFEBLD_opARRAYREF:
6244 case FFEBLD_opFUNCREF:
6245 case FFEBLD_opSUBSTR:
6246 ffecom_char_args_ (&expr_tree, &length_tree, arg);
5ff904cd 6247
c7e4ee3a
CB		 6248 if ((expr_tree == error_mark_node)
6249 || (length_tree == error_mark_node))
6250 {
6251 *maybe_tree = error_mark_node;
6252 return error_mark_node;
6253 }
5ff904cd 6254
c7e4ee3a
CB		 6255 if (integer_zerop (length_tree))
6256 {
6257 *maybe_tree = integer_zero_node;
6258 return convert (tree_type, integer_zero_node);
6259 }
6260
6261 expr_tree
6262 = ffecom_1 (INDIRECT_REF,
6263 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6264 expr_tree);
6265 expr_tree
6266 = ffecom_2 (ARRAY_REF,
6267 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6268 expr_tree,
6269 integer_one_node);
6270 expr_tree = convert (tree_type, expr_tree);
6271
6272 if (TREE_CODE (length_tree) == INTEGER_CST)
6273 *maybe_tree = integer_one_node;
6274 else /* Must check length at run time. */
6275 *maybe_tree
6276 = ffecom_truth_value
6277 (ffecom_2 (GT_EXPR, integer_type_node,
6278 length_tree,
6279 ffecom_f2c_ftnlen_zero_node));
6280 return expr_tree;
6281
6282 case FFEBLD_opPAREN:
6283 case FFEBLD_opCONVERT:
6284 if (ffeinfo_size (ffebld_info (arg)) == 0)
6285 {
6286 *maybe_tree = integer_zero_node;
6287 return convert (tree_type, integer_zero_node);
6288 }
6289 return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6290 maybe_tree);
6291
6292 case FFEBLD_opCONCATENATE:
6293 {
6294 tree maybe_left;
6295 tree maybe_right;
6296 tree expr_left;
6297 tree expr_right;
6298
6299 expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6300 &maybe_left);
6301 expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6302 &maybe_right);
6303 *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6304 maybe_left,
6305 maybe_right);
6306 expr_tree = ffecom_3 (COND_EXPR, tree_type,
6307 maybe_left,
6308 expr_left,
6309 expr_right);
6310 return expr_tree;
6311 }
6312
6313 default:
6314 assert ("bad op in ICHAR" == NULL);
6315 return error_mark_node;
6316 }
5ff904cd
JL		 6317}
6318
6319#endif
c7e4ee3a
CB		 6320/* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6321
6322 tree length_arg;
6323 ffebld expr;
6324 length_arg = ffecom_intrinsic_len_ (expr);
6325
6326 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6327 subexpressions by constructing the appropriate tree for the
6328 length-of-character-text argument in a calling sequence. */
5ff904cd
JL		 6329
6330#if FFECOM_targetCURRENT == FFECOM_targetGCC
6331static tree
c7e4ee3a 6332ffecom_intrinsic_len_ (ffebld expr)
5ff904cd 6333{
c7e4ee3a
CB		 6334 ffetargetCharacter1 val;
6335 tree length;
6336
6337 switch (ffebld_op (expr))
6338 {
6339 case FFEBLD_opCONTER:
6340 val = ffebld_constant_character1 (ffebld_conter (expr));
6341 length = build_int_2 (ffetarget_length_character1 (val), 0);
6342 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6343 break;
6344
6345 case FFEBLD_opSYMTER:
6346 {
6347 ffesymbol s = ffebld_symter (expr);
6348 tree item;
6349
6350 item = ffesymbol_hook (s).decl_tree;
6351 if (item == NULL_TREE)
6352 {
6353 s = ffecom_sym_transform_ (s);
6354 item = ffesymbol_hook (s).decl_tree;
6355 }
6356 if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6357 {
6358 if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6359 length = ffesymbol_hook (s).length_tree;
6360 else
6361 {
6362 length = build_int_2 (ffesymbol_size (s), 0);
6363 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6364 }
6365 }
6366 else if (item == error_mark_node)
6367 length = error_mark_node;
6368 else /* FFEINFO_kindFUNCTION: */
6369 length = NULL_TREE;
6370 }
6371 break;
5ff904cd 6372
c7e4ee3a
CB		 6373 case FFEBLD_opARRAYREF:
6374 length = ffecom_intrinsic_len_ (ffebld_left (expr));
6375 break;
5ff904cd 6376
c7e4ee3a
CB		 6377 case FFEBLD_opSUBSTR:
6378 {
6379 ffebld start;
6380 ffebld end;
6381 ffebld thing = ffebld_right (expr);
6382 tree start_tree;
6383 tree end_tree;
5ff904cd 6384
c7e4ee3a
CB		 6385 assert (ffebld_op (thing) == FFEBLD_opITEM);
6386 start = ffebld_head (thing);
6387 thing = ffebld_trail (thing);
6388 assert (ffebld_trail (thing) == NULL);
6389 end = ffebld_head (thing);
5ff904cd 6390
c7e4ee3a 6391 length = ffecom_intrinsic_len_ (ffebld_left (expr));
5ff904cd 6392
c7e4ee3a
CB		 6393 if (length == error_mark_node)
6394 break;
5ff904cd 6395
c7e4ee3a
CB		 6396 if (start == NULL)
6397 {
6398 if (end == NULL)
6399 ;
6400 else
6401 {
6402 length = convert (ffecom_f2c_ftnlen_type_node,
6403 ffecom_expr (end));
6404 }
6405 }
6406 else
6407 {
6408 start_tree = convert (ffecom_f2c_ftnlen_type_node,
6409 ffecom_expr (start));
5ff904cd 6410
c7e4ee3a
CB		 6411 if (start_tree == error_mark_node)
6412 {
6413 length = error_mark_node;
6414 break;
6415 }
5ff904cd 6416
c7e4ee3a
CB		 6417 if (end == NULL)
6418 {
6419 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6420 ffecom_f2c_ftnlen_one_node,
6421 ffecom_2 (MINUS_EXPR,
6422 ffecom_f2c_ftnlen_type_node,
6423 length,
6424 start_tree));
6425 }
6426 else
6427 {
6428 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6429 ffecom_expr (end));
5ff904cd 6430
c7e4ee3a
CB		 6431 if (end_tree == error_mark_node)
6432 {
6433 length = error_mark_node;
6434 break;
6435 }
5ff904cd 6436
c7e4ee3a
CB		 6437 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6438 ffecom_f2c_ftnlen_one_node,
6439 ffecom_2 (MINUS_EXPR,
6440 ffecom_f2c_ftnlen_type_node,
6441 end_tree, start_tree));
6442 }
6443 }
6444 }
6445 break;
5ff904cd 6446
c7e4ee3a
CB		 6447 case FFEBLD_opCONCATENATE:
6448 length
6449 = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6450 ffecom_intrinsic_len_ (ffebld_left (expr)),
6451 ffecom_intrinsic_len_ (ffebld_right (expr)));
6452 break;
5ff904cd 6453
c7e4ee3a
CB		 6454 case FFEBLD_opFUNCREF:
6455 case FFEBLD_opCONVERT:
6456 length = build_int_2 (ffebld_size (expr), 0);
6457 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6458 break;
5ff904cd 6459
c7e4ee3a
CB		 6460 default:
6461 assert ("bad op for single char arg expr" == NULL);
6462 length = ffecom_f2c_ftnlen_zero_node;
6463 break;
6464 }
5ff904cd 6465
c7e4ee3a 6466 assert (length != NULL_TREE);
5ff904cd 6467
c7e4ee3a 6468 return length;
5ff904cd
JL		 6469}
6470
6471#endif
c7e4ee3a 6472/* Handle CHARACTER assignments.
5ff904cd 6473
c7e4ee3a
CB		 6474 Generates code to do the assignment. Used by ordinary assignment
6475 statement handler ffecom_let_stmt and by statement-function
6476 handler to generate code for a statement function. */
5ff904cd
JL		 6477
6478#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 6479static void
6480ffecom_let_char_ (tree dest_tree, tree dest_length,
6481 ffetargetCharacterSize dest_size, ffebld source)
5ff904cd 6482{
c7e4ee3a
CB		 6483 ffecomConcatList_ catlist;
6484 tree source_length;
6485 tree source_tree;
6486 tree expr_tree;
5ff904cd 6487
c7e4ee3a
CB		 6488 if ((dest_tree == error_mark_node)
6489 || (dest_length == error_mark_node))
6490 return;
5ff904cd 6491
c7e4ee3a
CB		 6492 assert (dest_tree != NULL_TREE);
6493 assert (dest_length != NULL_TREE);
5ff904cd 6494
c7e4ee3a
CB		 6495 /* Source might be an opCONVERT, which just means it is a different size
6496 than the destination. Since the underlying implementation here handles
6497 that (directly or via the s_copy or s_cat run-time-library functions),
6498 we don't need the "convenience" of an opCONVERT that tells us to
6499 truncate or blank-pad, particularly since the resulting implementation
6500 would probably be slower than otherwise. */
5ff904cd 6501
c7e4ee3a
CB		 6502 while (ffebld_op (source) == FFEBLD_opCONVERT)
6503 source = ffebld_left (source);
5ff904cd 6504
c7e4ee3a
CB		 6505 catlist = ffecom_concat_list_new_ (source, dest_size);
6506 switch (ffecom_concat_list_count_ (catlist))
6507 {
6508 case 0: /* Shouldn't happen, but in case it does... */
6509 ffecom_concat_list_kill_ (catlist);
6510 source_tree = null_pointer_node;
6511 source_length = ffecom_f2c_ftnlen_zero_node;
6512 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6513 TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6514 TREE_CHAIN (TREE_CHAIN (expr_tree))
6515 = build_tree_list (NULL_TREE, dest_length);
6516 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6517 = build_tree_list (NULL_TREE, source_length);
5ff904cd 6518
c7e4ee3a
CB		 6519 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6520 TREE_SIDE_EFFECTS (expr_tree) = 1;
5ff904cd 6521
c7e4ee3a 6522 expand_expr_stmt (expr_tree);
5ff904cd 6523
c7e4ee3a 6524 return;
5ff904cd 6525
c7e4ee3a
CB		 6526 case 1: /* The (fairly) easy case. */
6527 ffecom_char_args_ (&source_tree, &source_length,
6528 ffecom_concat_list_expr_ (catlist, 0));
6529 ffecom_concat_list_kill_ (catlist);
6530 assert (source_tree != NULL_TREE);
6531 assert (source_length != NULL_TREE);
6532
6533 if ((source_tree == error_mark_node)
6534 || (source_length == error_mark_node))
6535 return;
6536
6537 if (dest_size == 1)
6538 {
6539 dest_tree
6540 = ffecom_1 (INDIRECT_REF,
6541 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6542 (dest_tree))),
6543 dest_tree);
6544 dest_tree
6545 = ffecom_2 (ARRAY_REF,
6546 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6547 (dest_tree))),
6548 dest_tree,
6549 integer_one_node);
6550 source_tree
6551 = ffecom_1 (INDIRECT_REF,
6552 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6553 (source_tree))),
6554 source_tree);
6555 source_tree
6556 = ffecom_2 (ARRAY_REF,
6557 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6558 (source_tree))),
6559 source_tree,
6560 integer_one_node);
5ff904cd 6561
c7e4ee3a 6562 expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
5ff904cd 6563
c7e4ee3a 6564 expand_expr_stmt (expr_tree);
5ff904cd 6565
c7e4ee3a
CB		 6566 return;
6567 }
5ff904cd 6568
c7e4ee3a
CB		 6569 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6570 TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6571 TREE_CHAIN (TREE_CHAIN (expr_tree))
6572 = build_tree_list (NULL_TREE, dest_length);
6573 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6574 = build_tree_list (NULL_TREE, source_length);
5ff904cd 6575
c7e4ee3a
CB		 6576 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6577 TREE_SIDE_EFFECTS (expr_tree) = 1;
5ff904cd 6578
c7e4ee3a 6579 expand_expr_stmt (expr_tree);
5ff904cd 6580
c7e4ee3a 6581 return;
5ff904cd 6582
c7e4ee3a
CB		 6583 default: /* Must actually concatenate things. */
6584 break;
6585 }
5ff904cd 6586
c7e4ee3a 6587 /* Heavy-duty concatenation. */
5ff904cd 6588
c7e4ee3a
CB		 6589 {
6590 int count = ffecom_concat_list_count_ (catlist);
6591 int i;
6592 tree lengths;
6593 tree items;
6594 tree length_array;
6595 tree item_array;
6596 tree citem;
6597 tree clength;
5ff904cd 6598
c7e4ee3a
CB		 6599#ifdef HOHO
6600 length_array
6601 = lengths
6602 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6603 FFETARGET_charactersizeNONE, count, TRUE);
6604 item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6605 FFETARGET_charactersizeNONE,
6606 count, TRUE);
6607#else
6608 {
6609 tree hook;
6610
6611 hook = ffebld_nonter_hook (source);
6612 assert (hook);
6613 assert (TREE_CODE (hook) == TREE_VEC);
6614 assert (TREE_VEC_LENGTH (hook) == 2);
6615 length_array = lengths = TREE_VEC_ELT (hook, 0);
6616 item_array = items = TREE_VEC_ELT (hook, 1);
5ff904cd 6617 }
c7e4ee3a 6618#endif
5ff904cd 6619
c7e4ee3a
CB		 6620 for (i = 0; i < count; ++i)
6621 {
6622 ffecom_char_args_ (&citem, &clength,
6623 ffecom_concat_list_expr_ (catlist, i));
6624 if ((citem == error_mark_node)
6625 || (clength == error_mark_node))
6626 {
6627 ffecom_concat_list_kill_ (catlist);
6628 return;
6629 }
5ff904cd 6630
c7e4ee3a
CB		 6631 items
6632 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6633 ffecom_modify (void_type_node,
6634 ffecom_2 (ARRAY_REF,
6635 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6636 item_array,
6637 build_int_2 (i, 0)),
6638 citem),
6639 items);
6640 lengths
6641 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6642 ffecom_modify (void_type_node,
6643 ffecom_2 (ARRAY_REF,
6644 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6645 length_array,
6646 build_int_2 (i, 0)),
6647 clength),
6648 lengths);
6649 }
5ff904cd 6650
c7e4ee3a
CB		 6651 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6652 TREE_CHAIN (expr_tree)
6653 = build_tree_list (NULL_TREE,
6654 ffecom_1 (ADDR_EXPR,
6655 build_pointer_type (TREE_TYPE (items)),
6656 items));
6657 TREE_CHAIN (TREE_CHAIN (expr_tree))
6658 = build_tree_list (NULL_TREE,
6659 ffecom_1 (ADDR_EXPR,
6660 build_pointer_type (TREE_TYPE (lengths)),
6661 lengths));
6662 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6663 = build_tree_list
6664 (NULL_TREE,
6665 ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6666 convert (ffecom_f2c_ftnlen_type_node,
6667 build_int_2 (count, 0))));
6668 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6669 = build_tree_list (NULL_TREE, dest_length);
5ff904cd 6670
c7e4ee3a
CB		 6671 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6672 TREE_SIDE_EFFECTS (expr_tree) = 1;
5ff904cd 6673
c7e4ee3a
CB		 6674 expand_expr_stmt (expr_tree);
6675 }
5ff904cd 6676
c7e4ee3a
CB		 6677 ffecom_concat_list_kill_ (catlist);
6678}
5ff904cd 6679
c7e4ee3a
CB		 6680#endif
6681/* ffecom_make_gfrt_ -- Make initial info for run-time routine
5ff904cd 6682
c7e4ee3a
CB		 6683 ffecomGfrt ix;
6684 ffecom_make_gfrt_(ix);
5ff904cd 6685
c7e4ee3a
CB		 6686 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6687 for the indicated run-time routine (ix). */
5ff904cd 6688
c7e4ee3a
CB		 6689#if FFECOM_targetCURRENT == FFECOM_targetGCC
6690static void
6691ffecom_make_gfrt_ (ffecomGfrt ix)
6692{
6693 tree t;
6694 tree ttype;
5ff904cd 6695
c7e4ee3a
CB		 6696 push_obstacks_nochange ();
6697 end_temporary_allocation ();
5ff904cd 6698
c7e4ee3a
CB		 6699 switch (ffecom_gfrt_type_[ix])
6700 {
6701 case FFECOM_rttypeVOID_:
6702 ttype = void_type_node;
6703 break;
5ff904cd 6704
c7e4ee3a
CB		 6705 case FFECOM_rttypeVOIDSTAR_:
6706 ttype = TREE_TYPE (null_pointer_node); /* `void *'. */
6707 break;
5ff904cd 6708
c7e4ee3a
CB		 6709 case FFECOM_rttypeFTNINT_:
6710 ttype = ffecom_f2c_ftnint_type_node;
6711 break;
5ff904cd 6712
c7e4ee3a
CB		 6713 case FFECOM_rttypeINTEGER_:
6714 ttype = ffecom_f2c_integer_type_node;
6715 break;
5ff904cd 6716
c7e4ee3a
CB		 6717 case FFECOM_rttypeLONGINT_:
6718 ttype = ffecom_f2c_longint_type_node;
6719 break;
5ff904cd 6720
c7e4ee3a
CB		 6721 case FFECOM_rttypeLOGICAL_:
6722 ttype = ffecom_f2c_logical_type_node;
6723 break;
5ff904cd 6724
c7e4ee3a
CB		 6725 case FFECOM_rttypeREAL_F2C_:
6726 ttype = double_type_node;
6727 break;
5ff904cd 6728
c7e4ee3a
CB		 6729 case FFECOM_rttypeREAL_GNU_:
6730 ttype = float_type_node;
6731 break;
5ff904cd 6732
c7e4ee3a
CB		 6733 case FFECOM_rttypeCOMPLEX_F2C_:
6734 ttype = void_type_node;
6735 break;
5ff904cd 6736
c7e4ee3a
CB		 6737 case FFECOM_rttypeCOMPLEX_GNU_:
6738 ttype = ffecom_f2c_complex_type_node;
6739 break;
5ff904cd 6740
c7e4ee3a
CB		 6741 case FFECOM_rttypeDOUBLE_:
6742 ttype = double_type_node;
6743 break;
5ff904cd 6744
c7e4ee3a
CB		 6745 case FFECOM_rttypeDOUBLEREAL_:
6746 ttype = ffecom_f2c_doublereal_type_node;
6747 break;
5ff904cd 6748
c7e4ee3a
CB		 6749 case FFECOM_rttypeDBLCMPLX_F2C_:
6750 ttype = void_type_node;
6751 break;
5ff904cd 6752
c7e4ee3a
CB		 6753 case FFECOM_rttypeDBLCMPLX_GNU_:
6754 ttype = ffecom_f2c_doublecomplex_type_node;
6755 break;
5ff904cd 6756
c7e4ee3a
CB		 6757 case FFECOM_rttypeCHARACTER_:
6758 ttype = void_type_node;
6759 break;
6760
6761 default:
6762 ttype = NULL;
6763 assert ("bad rttype" == NULL);
6764 break;
5ff904cd 6765 }
5ff904cd 6766
c7e4ee3a
CB		 6767 ttype = build_function_type (ttype, NULL_TREE);
6768 t = build_decl (FUNCTION_DECL,
6769 get_identifier (ffecom_gfrt_name_[ix]),
6770 ttype);
6771 DECL_EXTERNAL (t) = 1;
6772 TREE_PUBLIC (t) = 1;
6773 TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
5ff904cd 6774
c7e4ee3a 6775 t = start_decl (t, TRUE);
5ff904cd 6776
c7e4ee3a 6777 finish_decl (t, NULL_TREE, TRUE);
5ff904cd 6778
c7e4ee3a
CB		 6779 resume_temporary_allocation ();
6780 pop_obstacks ();
6781
6782 ffecom_gfrt_[ix] = t;
5ff904cd
JL		 6783}
6784
6785#endif
c7e4ee3a
CB		 6786/* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
6787
5ff904cd 6788#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 6789static void
6790ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
5ff904cd 6791{
c7e4ee3a 6792 ffesymbol s = ffestorag_symbol (st);
5ff904cd 6793
c7e4ee3a
CB		 6794 if (ffesymbol_namelisted (s))
6795 ffecom_member_namelisted_ = TRUE;
6796}
5ff904cd 6797
c7e4ee3a
CB		 6798#endif
6799/* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
6800 the member so debugger will see it. Otherwise nobody should be
6801 referencing the member. */
5ff904cd 6802
c7e4ee3a
CB		 6803#if FFECOM_targetCURRENT == FFECOM_targetGCC
6804#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
6805static void
6806ffecom_member_phase2_ (ffestorag mst, ffestorag st)
6807{
6808 ffesymbol s;
6809 tree t;
6810 tree mt;
6811 tree type;
5ff904cd 6812
c7e4ee3a
CB		 6813 if ((mst == NULL)
6814 || ((mt = ffestorag_hook (mst)) == NULL)
6815 || (mt == error_mark_node))
6816 return;
5ff904cd 6817
c7e4ee3a
CB		 6818 if ((st == NULL)
6819 || ((s = ffestorag_symbol (st)) == NULL))
6820 return;
5ff904cd 6821
c7e4ee3a
CB		 6822 type = ffecom_type_localvar_ (s,
6823 ffesymbol_basictype (s),
6824 ffesymbol_kindtype (s));
6825 if (type == error_mark_node)
6826 return;
5ff904cd 6827
c7e4ee3a
CB		 6828 t = build_decl (VAR_DECL,
6829 ffecom_get_identifier_ (ffesymbol_text (s)),
6830 type);
5ff904cd 6831
c7e4ee3a
CB		 6832 TREE_STATIC (t) = TREE_STATIC (mt);
6833 DECL_INITIAL (t) = NULL_TREE;
6834 TREE_ASM_WRITTEN (t) = 1;
5ff904cd 6835
c7e4ee3a
CB		 6836 DECL_RTL (t)
6837 = gen_rtx (MEM, TYPE_MODE (type),
6838 plus_constant (XEXP (DECL_RTL (mt), 0),
6839 ffestorag_modulo (mst)
6840 + ffestorag_offset (st)
6841 - ffestorag_offset (mst)));
5ff904cd 6842
c7e4ee3a 6843 t = start_decl (t, FALSE);
5ff904cd 6844
c7e4ee3a 6845 finish_decl (t, NULL_TREE, FALSE);
5ff904cd
JL		 6846}
6847
6848#endif
c7e4ee3a
CB		 6849#endif
6850/* Prepare source expression for assignment into a destination perhaps known
6851 to be of a specific size. */
5ff904cd 6852
c7e4ee3a
CB		 6853static void
6854ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
5ff904cd 6855{
c7e4ee3a
CB		 6856 ffecomConcatList_ catlist;
6857 int count;
6858 int i;
6859 tree ltmp;
6860 tree itmp;
6861 tree tempvar = NULL_TREE;
5ff904cd 6862
c7e4ee3a
CB		 6863 while (ffebld_op (source) == FFEBLD_opCONVERT)
6864 source = ffebld_left (source);
5ff904cd 6865
c7e4ee3a
CB		 6866 catlist = ffecom_concat_list_new_ (source, dest_size);
6867 count = ffecom_concat_list_count_ (catlist);
5ff904cd 6868
c7e4ee3a
CB		 6869 if (count >= 2)
6870 {
6871 ltmp
6872 = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
6873 FFETARGET_charactersizeNONE, count);
6874 itmp
6875 = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
6876 FFETARGET_charactersizeNONE, count);
6877
6878 tempvar = make_tree_vec (2);
6879 TREE_VEC_ELT (tempvar, 0) = ltmp;
6880 TREE_VEC_ELT (tempvar, 1) = itmp;
6881 }
5ff904cd 6882
c7e4ee3a
CB		 6883 for (i = 0; i < count; ++i)
6884 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
5ff904cd 6885
c7e4ee3a 6886 ffecom_concat_list_kill_ (catlist);
5ff904cd 6887
c7e4ee3a
CB		 6888 if (tempvar)
6889 {
6890 ffebld_nonter_set_hook (source, tempvar);
6891 current_binding_level->prep_state = 1;
6892 }
6893}
5ff904cd 6894
c7e4ee3a 6895/* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
5ff904cd 6896
c7e4ee3a
CB		 6897 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
6898 (which generates their trees) and then their trees get push_parm_decl'd.
5ff904cd 6899
c7e4ee3a
CB		 6900 The second arg is TRUE if the dummies are for a statement function, in
6901 which case lengths are not pushed for character arguments (since they are
6902 always known by both the caller and the callee, though the code allows
6903 for someday permitting CHAR*(*) stmtfunc dummies). */
5ff904cd 6904
c7e4ee3a
CB		 6905#if FFECOM_targetCURRENT == FFECOM_targetGCC
6906static void
6907ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
6908{
6909 ffebld dummy;
6910 ffebld dumlist;
6911 ffesymbol s;
6912 tree parm;
5ff904cd 6913
c7e4ee3a 6914 ffecom_transform_only_dummies_ = TRUE;
5ff904cd 6915
c7e4ee3a 6916 /* First push the parms corresponding to actual dummy "contents". */
5ff904cd 6917
c7e4ee3a
CB		 6918 for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
6919 {
6920 dummy = ffebld_head (dumlist);
6921 switch (ffebld_op (dummy))
6922 {
6923 case FFEBLD_opSTAR:
6924 case FFEBLD_opANY:
6925 continue; /* Forget alternate returns. */
5ff904cd 6926
c7e4ee3a
CB		 6927 default:
6928 break;
6929 }
6930 assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
6931 s = ffebld_symter (dummy);
6932 parm = ffesymbol_hook (s).decl_tree;
6933 if (parm == NULL_TREE)
6934 {
6935 s = ffecom_sym_transform_ (s);
6936 parm = ffesymbol_hook (s).decl_tree;
6937 assert (parm != NULL_TREE);
6938 }
6939 if (parm != error_mark_node)
6940 push_parm_decl (parm);
5ff904cd
JL		 6941 }
6942
c7e4ee3a 6943 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
5ff904cd 6944
c7e4ee3a
CB		 6945 for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
6946 {
6947 dummy = ffebld_head (dumlist);
6948 switch (ffebld_op (dummy))
6949 {
6950 case FFEBLD_opSTAR:
6951 case FFEBLD_opANY:
6952 continue; /* Forget alternate returns, they mean
6953 NOTHING! */
6954
6955 default:
6956 break;
6957 }
6958 s = ffebld_symter (dummy);
6959 if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
6960 continue; /* Only looking for CHARACTER arguments. */
6961 if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
6962 continue; /* Stmtfunc arg with known size needs no
6963 length param. */
6964 if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
6965 continue; /* Only looking for variables and arrays. */
6966 parm = ffesymbol_hook (s).length_tree;
6967 assert (parm != NULL_TREE);
6968 if (parm != error_mark_node)
6969 push_parm_decl (parm);
6970 }
6971
6972 ffecom_transform_only_dummies_ = FALSE;
5ff904cd
JL		 6973}
6974
6975#endif
c7e4ee3a 6976/* ffecom_start_progunit_ -- Beginning of program unit
5ff904cd 6977
c7e4ee3a
CB		 6978 Does GNU back end stuff necessary to teach it about the start of its
6979 equivalent of a Fortran program unit. */
5ff904cd
JL		 6980
6981#if FFECOM_targetCURRENT == FFECOM_targetGCC
6982static void
c7e4ee3a 6983ffecom_start_progunit_ ()
5ff904cd 6984{
c7e4ee3a
CB		 6985 ffesymbol fn = ffecom_primary_entry_;
6986 ffebld arglist;
6987 tree id; /* Identifier (name) of function. */
6988 tree type; /* Type of function. */
6989 tree result; /* Result of function. */
6990 ffeinfoBasictype bt;
6991 ffeinfoKindtype kt;
6992 ffeglobal g;
6993 ffeglobalType gt;
6994 ffeglobalType egt = FFEGLOBAL_type;
6995 bool charfunc;
6996 bool cmplxfunc;
6997 bool altentries = (ffecom_num_entrypoints_ != 0);
6998 bool multi
6999 = altentries
7000 && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7001 && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7002 bool main_program = FALSE;
7003 int old_lineno = lineno;
7004 char *old_input_filename = input_filename;
7005 int yes;
5ff904cd 7006
c7e4ee3a
CB		 7007 assert (fn != NULL);
7008 assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
5ff904cd 7009
c7e4ee3a
CB		 7010 input_filename = ffesymbol_where_filename (fn);
7011 lineno = ffesymbol_where_filelinenum (fn);
5ff904cd 7012
c7e4ee3a
CB		 7013 /* c-parse.y indeed does call suspend_momentary and not only ignores the
7014 return value, but also never calls resume_momentary, when starting an
7015 outer function (see "fndef:", "setspecs:", and so on). So g77 does the
7016 same thing. It shouldn't be a problem since start_function calls
7017 temporary_allocation, but it might be necessary. If it causes a problem
7018 here, then maybe there's a bug lurking in gcc. NOTE: This identical
7019 comment appears twice in thist file. */
7020
7021 suspend_momentary ();
7022
7023 switch (ffecom_primary_entry_kind_)
7024 {
7025 case FFEINFO_kindPROGRAM:
7026 main_program = TRUE;
7027 gt = FFEGLOBAL_typeMAIN;
7028 bt = FFEINFO_basictypeNONE;
7029 kt = FFEINFO_kindtypeNONE;
7030 type = ffecom_tree_fun_type_void;
7031 charfunc = FALSE;
7032 cmplxfunc = FALSE;
7033 break;
7034
7035 case FFEINFO_kindBLOCKDATA:
7036 gt = FFEGLOBAL_typeBDATA;
7037 bt = FFEINFO_basictypeNONE;
7038 kt = FFEINFO_kindtypeNONE;
7039 type = ffecom_tree_fun_type_void;
7040 charfunc = FALSE;
7041 cmplxfunc = FALSE;
7042 break;
7043
7044 case FFEINFO_kindFUNCTION:
7045 gt = FFEGLOBAL_typeFUNC;
7046 egt = FFEGLOBAL_typeEXT;
7047 bt = ffesymbol_basictype (fn);
7048 kt = ffesymbol_kindtype (fn);
7049 if (bt == FFEINFO_basictypeNONE)
7050 {
7051 ffeimplic_establish_symbol (fn);
7052 if (ffesymbol_funcresult (fn) != NULL)
7053 ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7054 bt = ffesymbol_basictype (fn);
7055 kt = ffesymbol_kindtype (fn);
7056 }
7057
7058 if (multi)
7059 charfunc = cmplxfunc = FALSE;
7060 else if (bt == FFEINFO_basictypeCHARACTER)
7061 charfunc = TRUE, cmplxfunc = FALSE;
7062 else if ((bt == FFEINFO_basictypeCOMPLEX)
7063 && ffesymbol_is_f2c (fn)
7064 && !altentries)
7065 charfunc = FALSE, cmplxfunc = TRUE;
7066 else
7067 charfunc = cmplxfunc = FALSE;
7068
7069 if (multi || charfunc)
7070 type = ffecom_tree_fun_type_void;
7071 else if (ffesymbol_is_f2c (fn) && !altentries)
7072 type = ffecom_tree_fun_type[bt][kt];
7073 else
7074 type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7075
7076 if ((type == NULL_TREE)
7077 || (TREE_TYPE (type) == NULL_TREE))
7078 type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
7079 break;
7080
7081 case FFEINFO_kindSUBROUTINE:
7082 gt = FFEGLOBAL_typeSUBR;
7083 egt = FFEGLOBAL_typeEXT;
7084 bt = FFEINFO_basictypeNONE;
7085 kt = FFEINFO_kindtypeNONE;
7086 if (ffecom_is_altreturning_)
7087 type = ffecom_tree_subr_type;
7088 else
7089 type = ffecom_tree_fun_type_void;
7090 charfunc = FALSE;
7091 cmplxfunc = FALSE;
7092 break;
5ff904cd 7093
c7e4ee3a
CB		 7094 default:
7095 assert ("say what??" == NULL);
7096 /* Fall through. */
7097 case FFEINFO_kindANY:
7098 gt = FFEGLOBAL_typeANY;
7099 bt = FFEINFO_basictypeNONE;
7100 kt = FFEINFO_kindtypeNONE;
7101 type = error_mark_node;
7102 charfunc = FALSE;
7103 cmplxfunc = FALSE;
7104 break;
7105 }
5ff904cd 7106
c7e4ee3a 7107 if (altentries)
5ff904cd 7108 {
c7e4ee3a
CB		 7109 id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7110 ffesymbol_text (fn),
7111 -1);
7112 }
7113#if FFETARGET_isENFORCED_MAIN
7114 else if (main_program)
7115 id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7116#endif
7117 else
7118 id = ffecom_get_external_identifier_ (fn);
5ff904cd 7119
c7e4ee3a
CB		 7120 start_function (id,
7121 type,
7122 0, /* nested/inline */
7123 !altentries); /* TREE_PUBLIC */
5ff904cd 7124
c7e4ee3a 7125 TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */
5ff904cd 7126
c7e4ee3a
CB		 7127 if (!altentries
7128 && ((g = ffesymbol_global (fn)) != NULL)
7129 && ((ffeglobal_type (g) == gt)
7130 || (ffeglobal_type (g) == egt)))
7131 {
7132 ffeglobal_set_hook (g, current_function_decl);
7133 }
5ff904cd 7134
c7e4ee3a 7135 yes = suspend_momentary ();
5ff904cd 7136
c7e4ee3a
CB		 7137 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7138 exec-transitioning needs current_function_decl to be filled in. So we
7139 do these things in two phases. */
5ff904cd 7140
c7e4ee3a
CB		 7141 if (altentries)
7142 { /* 1st arg identifies which entrypoint. */
7143 ffecom_which_entrypoint_decl_
7144 = build_decl (PARM_DECL,
7145 ffecom_get_invented_identifier ("__g77_%s",
7146 "which_entrypoint",
7147 -1),
7148 integer_type_node);
7149 push_parm_decl (ffecom_which_entrypoint_decl_);
7150 }
5ff904cd 7151
c7e4ee3a
CB		 7152 if (charfunc
7153 || cmplxfunc
7154 || multi)
7155 { /* Arg for result (return value). */
7156 tree type;
7157 tree length;
5ff904cd 7158
c7e4ee3a
CB		 7159 if (charfunc)
7160 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7161 else if (cmplxfunc)
7162 type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7163 else
7164 type = ffecom_multi_type_node_;
5ff904cd 7165
c7e4ee3a
CB		 7166 result = ffecom_get_invented_identifier ("__g77_%s",
7167 "result", -1);
5ff904cd 7168
c7e4ee3a 7169 /* Make length arg _and_ enhance type info for CHAR arg itself. */
5ff904cd 7170
c7e4ee3a
CB		 7171 if (charfunc)
7172 length = ffecom_char_enhance_arg_ (&type, fn);
7173 else
7174 length = NULL_TREE; /* Not ref'd if !charfunc. */
5ff904cd 7175
c7e4ee3a
CB		 7176 type = build_pointer_type (type);
7177 result = build_decl (PARM_DECL, result, type);
5ff904cd 7178
c7e4ee3a
CB		 7179 push_parm_decl (result);
7180 if (multi)
7181 ffecom_multi_retval_ = result;
7182 else
7183 ffecom_func_result_ = result;
5ff904cd 7184
c7e4ee3a
CB		 7185 if (charfunc)
7186 {
7187 push_parm_decl (length);
7188 ffecom_func_length_ = length;
7189 }
5ff904cd
JL		 7190 }
7191
c7e4ee3a
CB		 7192 if (ffecom_primary_entry_is_proc_)
7193 {
7194 if (altentries)
7195 arglist = ffecom_master_arglist_;
7196 else
7197 arglist = ffesymbol_dummyargs (fn);
7198 ffecom_push_dummy_decls_ (arglist, FALSE);
7199 }
5ff904cd 7200
c7e4ee3a 7201 resume_momentary (yes);
5ff904cd 7202
c7e4ee3a
CB		 7203 if (TREE_CODE (current_function_decl) != ERROR_MARK)
7204 store_parm_decls (main_program ? 1 : 0);
5ff904cd 7205
c7e4ee3a
CB		 7206 ffecom_start_compstmt ();
7207 /* Disallow temp vars at this level. */
7208 current_binding_level->prep_state = 2;
5ff904cd 7209
c7e4ee3a
CB		 7210 lineno = old_lineno;
7211 input_filename = old_input_filename;
5ff904cd 7212
c7e4ee3a
CB		 7213 /* This handles any symbols still untransformed, in case -g specified.
7214 This used to be done in ffecom_finish_progunit, but it turns out to
7215 be necessary to do it here so that statement functions are
7216 expanded before code. But don't bother for BLOCK DATA. */
5ff904cd 7217
c7e4ee3a
CB		 7218 if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7219 ffesymbol_drive (ffecom_finish_symbol_transform_);
5ff904cd
JL		 7220}
7221
7222#endif
c7e4ee3a 7223/* ffecom_sym_transform_ -- Transform FFE sym into backend sym
5ff904cd 7224
c7e4ee3a
CB		 7225 ffesymbol s;
7226 ffecom_sym_transform_(s);
7227
7228 The ffesymbol_hook info for s is updated with appropriate backend info
7229 on the symbol. */
7230
7231#if FFECOM_targetCURRENT == FFECOM_targetGCC
7232static ffesymbol
7233ffecom_sym_transform_ (ffesymbol s)
7234{
7235 tree t; /* Transformed thingy. */
7236 tree tlen; /* Length if CHAR*(*). */
7237 bool addr; /* Is t the address of the thingy? */
7238 ffeinfoBasictype bt;
7239 ffeinfoKindtype kt;
7240 ffeglobal g;
7241 int yes;
7242 int old_lineno = lineno;
7243 char *old_input_filename = input_filename;
5ff904cd 7244
c7e4ee3a
CB		 7245 /* Must ensure special ASSIGN variables are declared at top of outermost
7246 block, else they'll end up in the innermost block when their first
7247 ASSIGN is seen, which leaves them out of scope when they're the
7248 subject of a GOTO or I/O statement.
5ff904cd 7249
c7e4ee3a
CB		 7250 We make this variable even if -fugly-assign. Just let it go unused,
7251 in case it turns out there are cases where we really want to use this
7252 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
5ff904cd 7253
c7e4ee3a
CB		 7254 if (! ffecom_transform_only_dummies_
7255 && ffesymbol_assigned (s)
7256 && ! ffesymbol_hook (s).assign_tree)
7257 s = ffecom_sym_transform_assign_ (s);
5ff904cd 7258
c7e4ee3a 7259 if (ffesymbol_sfdummyparent (s) == NULL)
5ff904cd 7260 {
c7e4ee3a
CB		 7261 input_filename = ffesymbol_where_filename (s);
7262 lineno = ffesymbol_where_filelinenum (s);
7263 }
7264 else
7265 {
7266 ffesymbol sf = ffesymbol_sfdummyparent (s);
5ff904cd 7267
c7e4ee3a
CB		 7268 input_filename = ffesymbol_where_filename (sf);
7269 lineno = ffesymbol_where_filelinenum (sf);
7270 }
6d433196 7271
c7e4ee3a
CB		 7272 bt = ffeinfo_basictype (ffebld_info (s));
7273 kt = ffeinfo_kindtype (ffebld_info (s));
5ff904cd 7274
c7e4ee3a
CB		 7275 t = NULL_TREE;
7276 tlen = NULL_TREE;
7277 addr = FALSE;
5ff904cd 7278
c7e4ee3a
CB		 7279 switch (ffesymbol_kind (s))
7280 {
7281 case FFEINFO_kindNONE:
7282 switch (ffesymbol_where (s))
7283 {
7284 case FFEINFO_whereDUMMY: /* Subroutine or function. */
7285 assert (ffecom_transform_only_dummies_);
5ff904cd 7286
c7e4ee3a
CB		 7287 /* Before 0.4, this could be ENTITY/DUMMY, but see
7288 ffestu_sym_end_transition -- no longer true (in particular, if
7289 it could be an ENTITY, it _will_ be made one, so that
7290 possibility won't come through here). So we never make length
7291 arg for CHARACTER type. */
5ff904cd 7292
c7e4ee3a
CB		 7293 t = build_decl (PARM_DECL,
7294 ffecom_get_identifier_ (ffesymbol_text (s)),
7295 ffecom_tree_ptr_to_subr_type);
7296#if BUILT_FOR_270
7297 DECL_ARTIFICIAL (t) = 1;
7298#endif
7299 addr = TRUE;
7300 break;
5ff904cd 7301
c7e4ee3a
CB		 7302 case FFEINFO_whereGLOBAL: /* Subroutine or function. */
7303 assert (!ffecom_transform_only_dummies_);
5ff904cd 7304
c7e4ee3a
CB		 7305 if (((g = ffesymbol_global (s)) != NULL)
7306 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7307 || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7308 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7309 && (ffeglobal_hook (g) != NULL_TREE)
7310 && ffe_is_globals ())
7311 {
7312 t = ffeglobal_hook (g);
7313 break;
7314 }
5ff904cd 7315
c7e4ee3a
CB		 7316 push_obstacks_nochange ();
7317 end_temporary_allocation ();
5ff904cd 7318
c7e4ee3a
CB		 7319 t = build_decl (FUNCTION_DECL,
7320 ffecom_get_external_identifier_ (s),
7321 ffecom_tree_subr_type); /* Assume subr. */
7322 DECL_EXTERNAL (t) = 1;
7323 TREE_PUBLIC (t) = 1;
5ff904cd 7324
c7e4ee3a
CB		 7325 t = start_decl (t, FALSE);
7326 finish_decl (t, NULL_TREE, FALSE);
795232f7 7327
c7e4ee3a
CB		 7328 if ((g != NULL)
7329 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7330 || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7331 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7332 ffeglobal_set_hook (g, t);
5ff904cd 7333
c7e4ee3a
CB		 7334 resume_temporary_allocation ();
7335 pop_obstacks ();
5ff904cd 7336
c7e4ee3a 7337 break;
5ff904cd 7338
c7e4ee3a
CB		 7339 default:
7340 assert ("NONE where unexpected" == NULL);
7341 /* Fall through. */
7342 case FFEINFO_whereANY:
7343 break;
7344 }
5ff904cd 7345 break;
5ff904cd 7346
c7e4ee3a
CB		 7347 case FFEINFO_kindENTITY:
7348 switch (ffeinfo_where (ffesymbol_info (s)))
7349 {
5ff904cd 7350
c7e4ee3a
CB		 7351 case FFEINFO_whereCONSTANT:
7352 /* ~~Debugging info needed? */
7353 assert (!ffecom_transform_only_dummies_);
7354 t = error_mark_node; /* Shouldn't ever see this in expr. */
7355 break;
5ff904cd 7356
c7e4ee3a
CB		 7357 case FFEINFO_whereLOCAL:
7358 assert (!ffecom_transform_only_dummies_);
5ff904cd 7359
c7e4ee3a
CB		 7360 {
7361 ffestorag st = ffesymbol_storage (s);
7362 tree type;
5ff904cd 7363
c7e4ee3a
CB		 7364 if ((st != NULL)
7365 && (ffestorag_size (st) == 0))
7366 {
7367 t = error_mark_node;
7368 break;
7369 }
5ff904cd 7370
c7e4ee3a
CB		 7371 yes = suspend_momentary ();
7372 type = ffecom_type_localvar_ (s, bt, kt);
7373 resume_momentary (yes);
5ff904cd 7374
c7e4ee3a
CB		 7375 if (type == error_mark_node)
7376 {
7377 t = error_mark_node;
7378 break;
7379 }
5ff904cd 7380
c7e4ee3a
CB		 7381 if ((st != NULL)
7382 && (ffestorag_parent (st) != NULL))
7383 { /* Child of EQUIVALENCE parent. */
7384 ffestorag est;
7385 tree et;
7386 int yes;
7387 ffetargetOffset offset;
5ff904cd 7388
c7e4ee3a
CB		 7389 est = ffestorag_parent (st);
7390 ffecom_transform_equiv_ (est);
5ff904cd 7391
c7e4ee3a
CB		 7392 et = ffestorag_hook (est);
7393 assert (et != NULL_TREE);
5ff904cd 7394
c7e4ee3a
CB		 7395 if (! TREE_STATIC (et))
7396 put_var_into_stack (et);
5ff904cd 7397
c7e4ee3a 7398 yes = suspend_momentary ();
5ff904cd 7399
c7e4ee3a
CB		 7400 offset = ffestorag_modulo (est)
7401 + ffestorag_offset (ffesymbol_storage (s))
7402 - ffestorag_offset (est);
5ff904cd 7403
c7e4ee3a 7404 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
5ff904cd 7405
c7e4ee3a 7406 /* (t_type *) (((char *) &et) + offset) */
5ff904cd 7407
c7e4ee3a
CB		 7408 t = convert (string_type_node, /* (char *) */
7409 ffecom_1 (ADDR_EXPR,
7410 build_pointer_type (TREE_TYPE (et)),
7411 et));
7412 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7413 t,
7414 build_int_2 (offset, 0));
7415 t = convert (build_pointer_type (type),
7416 t);
5ff904cd 7417
c7e4ee3a 7418 addr = TRUE;
5ff904cd 7419
c7e4ee3a
CB		 7420 resume_momentary (yes);
7421 }
7422 else
7423 {
7424 tree initexpr;
7425 bool init = ffesymbol_is_init (s);
5ff904cd 7426
c7e4ee3a 7427 yes = suspend_momentary ();
5ff904cd 7428
c7e4ee3a
CB		 7429 t = build_decl (VAR_DECL,
7430 ffecom_get_identifier_ (ffesymbol_text (s)),
7431 type);
5ff904cd 7432
c7e4ee3a
CB		 7433 if (init
7434 || ffesymbol_namelisted (s)
7435#ifdef FFECOM_sizeMAXSTACKITEM
7436 || ((st != NULL)
7437 && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7438#endif
7439 || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7440 && (ffecom_primary_entry_kind_
7441 != FFEINFO_kindBLOCKDATA)
7442 && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7443 TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7444 else
7445 TREE_STATIC (t) = 0; /* No need to make static. */
5ff904cd 7446
c7e4ee3a
CB		 7447 if (init || ffe_is_init_local_zero ())
7448 DECL_INITIAL (t) = error_mark_node;
5ff904cd 7449
c7e4ee3a
CB		 7450 /* Keep -Wunused from complaining about var if it
7451 is used as sfunc arg or DATA implied-DO. */
7452 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7453 DECL_IN_SYSTEM_HEADER (t) = 1;
5ff904cd 7454
c7e4ee3a 7455 t = start_decl (t, FALSE);
5ff904cd 7456
c7e4ee3a
CB		 7457 if (init)
7458 {
7459 if (ffesymbol_init (s) != NULL)
7460 initexpr = ffecom_expr (ffesymbol_init (s));
7461 else
7462 initexpr = ffecom_init_zero_ (t);
7463 }
7464 else if (ffe_is_init_local_zero ())
7465 initexpr = ffecom_init_zero_ (t);
7466 else
7467 initexpr = NULL_TREE; /* Not ref'd if !init. */
5ff904cd 7468
c7e4ee3a 7469 finish_decl (t, initexpr, FALSE);
5ff904cd 7470
c7e4ee3a
CB		 7471 if ((st != NULL) && (DECL_SIZE (t) != error_mark_node))
7472 {
7473 tree size_tree;
5ff904cd 7474
c7e4ee3a
CB		 7475 size_tree = size_binop (CEIL_DIV_EXPR,
7476 DECL_SIZE (t),
7477 size_int (BITS_PER_UNIT));
7478 assert (TREE_INT_CST_HIGH (size_tree) == 0);
7479 assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (st));
7480 }
5ff904cd 7481
c7e4ee3a
CB		 7482 resume_momentary (yes);
7483 }
7484 }
5ff904cd 7485 break;
5ff904cd 7486
c7e4ee3a
CB		 7487 case FFEINFO_whereRESULT:
7488 assert (!ffecom_transform_only_dummies_);
5ff904cd 7489
c7e4ee3a
CB		 7490 if (bt == FFEINFO_basictypeCHARACTER)
7491 { /* Result is already in list of dummies, use
7492 it (& length). */
7493 t = ffecom_func_result_;
7494 tlen = ffecom_func_length_;
7495 addr = TRUE;
7496 break;
7497 }
7498 if ((ffecom_num_entrypoints_ == 0)
7499 && (bt == FFEINFO_basictypeCOMPLEX)
7500 && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7501 { /* Result is already in list of dummies, use
7502 it. */
7503 t = ffecom_func_result_;
7504 addr = TRUE;
7505 break;
7506 }
7507 if (ffecom_func_result_ != NULL_TREE)
7508 {
7509 t = ffecom_func_result_;
7510 break;
7511 }
7512 if ((ffecom_num_entrypoints_ != 0)
7513 && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7514 {
7515 yes = suspend_momentary ();
5ff904cd 7516
c7e4ee3a
CB		 7517 assert (ffecom_multi_retval_ != NULL_TREE);
7518 t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7519 ffecom_multi_retval_);
7520 t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7521 t, ffecom_multi_fields_[bt][kt]);
5ff904cd 7522
c7e4ee3a
CB		 7523 resume_momentary (yes);
7524 break;
7525 }
5ff904cd 7526
c7e4ee3a 7527 yes = suspend_momentary ();
5ff904cd 7528
c7e4ee3a
CB		 7529 t = build_decl (VAR_DECL,
7530 ffecom_get_identifier_ (ffesymbol_text (s)),
7531 ffecom_tree_type[bt][kt]);
7532 TREE_STATIC (t) = 0; /* Put result on stack. */
7533 t = start_decl (t, FALSE);
7534 finish_decl (t, NULL_TREE, FALSE);
5ff904cd 7535
c7e4ee3a 7536 ffecom_func_result_ = t;
5ff904cd 7537
c7e4ee3a
CB		 7538 resume_momentary (yes);
7539 break;
5ff904cd 7540
c7e4ee3a
CB		 7541 case FFEINFO_whereDUMMY:
7542 {
7543 tree type;
7544 ffebld dl;
7545 ffebld dim;
7546 tree low;
7547 tree high;
7548 tree old_sizes;
7549 bool adjustable = FALSE; /* Conditionally adjustable? */
5ff904cd 7550
c7e4ee3a
CB		 7551 type = ffecom_tree_type[bt][kt];
7552 if (ffesymbol_sfdummyparent (s) != NULL)
7553 {
7554 if (current_function_decl == ffecom_outer_function_decl_)
7555 { /* Exec transition before sfunc
7556 context; get it later. */
7557 break;
7558 }
7559 t = ffecom_get_identifier_ (ffesymbol_text
7560 (ffesymbol_sfdummyparent (s)));
7561 }
7562 else
7563 t = ffecom_get_identifier_ (ffesymbol_text (s));
5ff904cd 7564
c7e4ee3a 7565 assert (ffecom_transform_only_dummies_);
5ff904cd 7566
c7e4ee3a
CB		 7567 old_sizes = get_pending_sizes ();
7568 put_pending_sizes (old_sizes);
5ff904cd 7569
c7e4ee3a
CB		 7570 if (bt == FFEINFO_basictypeCHARACTER)
7571 tlen = ffecom_char_enhance_arg_ (&type, s);
7572 type = ffecom_check_size_overflow_ (s, type, TRUE);
5ff904cd 7573
c7e4ee3a
CB		 7574 for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7575 {
7576 if (type == error_mark_node)
7577 break;
5ff904cd 7578
c7e4ee3a
CB		 7579 dim = ffebld_head (dl);
7580 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7581 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7582 low = ffecom_integer_one_node;
7583 else
7584 low = ffecom_expr (ffebld_left (dim));
7585 assert (ffebld_right (dim) != NULL);
7586 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7587 || ffecom_doing_entry_)
7588 {
7589 /* Used to just do high=low. But for ffecom_tree_
7590 canonize_ref_, it probably is important to correctly
7591 assess the size. E.g. given COMPLEX C(*),CFUNC and
7592 C(2)=CFUNC(C), overlap can happen, while it can't
7593 for, say, C(1)=CFUNC(C(2)). */
7594 /* Even more recently used to set to INT_MAX, but that
7595 broke when some overflow checking went into the back
7596 end. Now we just leave the upper bound unspecified. */
7597 high = NULL;
7598 }
7599 else
7600 high = ffecom_expr (ffebld_right (dim));
5ff904cd 7601
c7e4ee3a
CB		 7602 /* Determine whether array is conditionally adjustable,
7603 to decide whether back-end magic is needed.
5ff904cd 7604
c7e4ee3a
CB		 7605 Normally the front end uses the back-end function
7606 variable_size to wrap SAVE_EXPR's around expressions
7607 affecting the size/shape of an array so that the
7608 size/shape info doesn't change during execution
7609 of the compiled code even though variables and
7610 functions referenced in those expressions might.
5ff904cd 7611
c7e4ee3a
CB		 7612 variable_size also makes sure those saved expressions
7613 get evaluated immediately upon entry to the
7614 compiled procedure -- the front end normally doesn't
7615 have to worry about that.
3cf0cea4 7616
c7e4ee3a
CB		 7617 However, there is a problem with this that affects
7618 g77's implementation of entry points, and that is
7619 that it is _not_ true that each invocation of the
7620 compiled procedure is permitted to evaluate
7621 array size/shape info -- because it is possible
7622 that, for some invocations, that info is invalid (in
7623 which case it is "promised" -- i.e. a violation of
7624 the Fortran standard -- that the compiled code
7625 won't reference the array or its size/shape
7626 during that particular invocation).
5ff904cd 7627
c7e4ee3a 7628 To phrase this in C terms, consider this gcc function:
5ff904cd 7629
c7e4ee3a
CB		 7630 void foo (int *n, float (*a)[*n])
7631 {
7632 // a is "pointer to array ...", fyi.
7633 }
5ff904cd 7634
c7e4ee3a
CB		 7635 Suppose that, for some invocations, it is permitted
7636 for a caller of foo to do this:
5ff904cd 7637
c7e4ee3a 7638 foo (NULL, NULL);
5ff904cd 7639
c7e4ee3a
CB		 7640 Now the _written_ code for foo can take such a call
7641 into account by either testing explicitly for whether
7642 (a == NULL) || (n == NULL) -- presumably it is
7643 not permitted to reference *a in various fashions
7644 if (n == NULL) I suppose -- or it can avoid it by
7645 looking at other info (other arguments, static/global
7646 data, etc.).
5ff904cd 7647
c7e4ee3a
CB		 7648 However, this won't work in gcc 2.5.8 because it'll
7649 automatically emit the code to save the "*n"
7650 expression, which'll yield a NULL dereference for
7651 the "foo (NULL, NULL)" call, something the code
7652 for foo cannot prevent.
5ff904cd 7653
c7e4ee3a
CB		 7654 g77 definitely needs to avoid executing such
7655 code anytime the pointer to the adjustable array
7656 is NULL, because even if its bounds expressions
7657 don't have any references to possible "absent"
7658 variables like "*n" -- say all variable references
7659 are to COMMON variables, i.e. global (though in C,
7660 local static could actually make sense) -- the
7661 expressions could yield other run-time problems
7662 for allowably "dead" values in those variables.
5ff904cd 7663
c7e4ee3a
CB		 7664 For example, let's consider a more complicated
7665 version of foo:
5ff904cd 7666
c7e4ee3a
CB		 7667 extern int i;
7668 extern int j;
5ff904cd 7669
c7e4ee3a
CB		 7670 void foo (float (*a)[i/j])
7671 {
7672 ...
7673 }
5ff904cd 7674
c7e4ee3a
CB		 7675 The above is (essentially) quite valid for Fortran
7676 but, again, for a call like "foo (NULL);", it is
7677 permitted for i and j to be undefined when the
7678 call is made. If j happened to be zero, for
7679 example, emitting the code to evaluate "i/j"
7680 could result in a run-time error.
5ff904cd 7681
c7e4ee3a
CB		 7682 Offhand, though I don't have my F77 or F90
7683 standards handy, it might even be valid for a
7684 bounds expression to contain a function reference,
7685 in which case I doubt it is permitted for an
7686 implementation to invoke that function in the
7687 Fortran case involved here (invocation of an
7688 alternate ENTRY point that doesn't have the adjustable
7689 array as one of its arguments).
5ff904cd 7690
c7e4ee3a
CB		 7691 So, the code that the compiler would normally emit
7692 to preevaluate the size/shape info for an
7693 adjustable array _must not_ be executed at run time
7694 in certain cases. Specifically, for Fortran,
7695 the case is when the pointer to the adjustable
7696 array == NULL. (For gnu-ish C, it might be nice
7697 for the source code itself to specify an expression
7698 that, if TRUE, inhibits execution of the code. Or
7699 reverse the sense for elegance.)
5ff904cd 7700
c7e4ee3a
CB		 7701 (Note that g77 could use a different test than NULL,
7702 actually, since it happens to always pass an
7703 integer to the called function that specifies which
7704 entry point is being invoked. Hmm, this might
7705 solve the next problem.)
7706
7707 One way a user could, I suppose, write "foo" so
7708 it works is to insert COND_EXPR's for the
7709 size/shape info so the dangerous stuff isn't
7710 actually done, as in:
7711
7712 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7713 {
7714 ...
7715 }
5ff904cd 7716
c7e4ee3a
CB		 7717 The next problem is that the front end needs to
7718 be able to tell the back end about the array's
7719 decl _before_ it tells it about the conditional
7720 expression to inhibit evaluation of size/shape info,
7721 as shown above.
5ff904cd 7722
c7e4ee3a
CB		 7723 To solve this, the front end needs to be able
7724 to give the back end the expression to inhibit
7725 generation of the preevaluation code _after_
7726 it makes the decl for the adjustable array.
5ff904cd 7727
c7e4ee3a
CB		 7728 Until then, the above example using the COND_EXPR
7729 doesn't pass muster with gcc because the "(a == NULL)"
7730 part has a reference to "a", which is still
7731 undefined at that point.
5ff904cd 7732
c7e4ee3a
CB		 7733 g77 will therefore use a different mechanism in the
7734 meantime. */
5ff904cd 7735
c7e4ee3a
CB		 7736 if (!adjustable
7737 && ((TREE_CODE (low) != INTEGER_CST)
7738 || (high && TREE_CODE (high) != INTEGER_CST)))
7739 adjustable = TRUE;
5ff904cd 7740
c7e4ee3a
CB		 7741#if 0 /* Old approach -- see below. */
7742 if (TREE_CODE (low) != INTEGER_CST)
7743 low = ffecom_3 (COND_EXPR, integer_type_node,
7744 ffecom_adjarray_passed_ (s),
7745 low,
7746 ffecom_integer_zero_node);
5ff904cd 7747
c7e4ee3a
CB		 7748 if (high && TREE_CODE (high) != INTEGER_CST)
7749 high = ffecom_3 (COND_EXPR, integer_type_node,
7750 ffecom_adjarray_passed_ (s),
7751 high,
7752 ffecom_integer_zero_node);
7753#endif
5ff904cd 7754
c7e4ee3a
CB		 7755 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7756 probably. Fixes 950302-1.f. */
5ff904cd 7757
c7e4ee3a
CB		 7758 if (TREE_CODE (low) != INTEGER_CST)
7759 low = variable_size (low);
5ff904cd 7760
c7e4ee3a
CB		 7761 /* ~~~Similarly, this fixes dumb0.f. The C front end
7762 does this, which is why dumb0.c would work. */
5ff904cd 7763
c7e4ee3a
CB		 7764 if (high && TREE_CODE (high) != INTEGER_CST)
7765 high = variable_size (high);
5ff904cd 7766
c7e4ee3a
CB		 7767 type
7768 = build_array_type
7769 (type,
7770 build_range_type (ffecom_integer_type_node,
7771 low, high));
7772 type = ffecom_check_size_overflow_ (s, type, TRUE);
7773 }
5ff904cd 7774
c7e4ee3a
CB		 7775 if (type == error_mark_node)
7776 {
7777 t = error_mark_node;
7778 break;
7779 }
5ff904cd 7780
c7e4ee3a
CB		 7781 if ((ffesymbol_sfdummyparent (s) == NULL)
7782 || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7783 {
7784 type = build_pointer_type (type);
7785 addr = TRUE;
7786 }
5ff904cd 7787
c7e4ee3a 7788 t = build_decl (PARM_DECL, t, type);
5ff904cd 7789#if BUILT_FOR_270
c7e4ee3a 7790 DECL_ARTIFICIAL (t) = 1;
5ff904cd 7791#endif
5ff904cd 7792
c7e4ee3a
CB		 7793 /* If this arg is present in every entry point's list of
7794 dummy args, then we're done. */
5ff904cd 7795
c7e4ee3a
CB		 7796 if (ffesymbol_numentries (s)
7797 == (ffecom_num_entrypoints_ + 1))
5ff904cd 7798 break;
5ff904cd 7799
c7e4ee3a 7800#if 1
5ff904cd 7801
c7e4ee3a
CB		 7802 /* If variable_size in stor-layout has been called during
7803 the above, then get_pending_sizes should have the
7804 yet-to-be-evaluated saved expressions pending.
7805 Make the whole lot of them get emitted, conditionally
7806 on whether the array decl ("t" above) is not NULL. */
5ff904cd 7807
c7e4ee3a
CB		 7808 {
7809 tree sizes = get_pending_sizes ();
7810 tree tem;
5ff904cd 7811
c7e4ee3a
CB		 7812 for (tem = sizes;
7813 tem != old_sizes;
7814 tem = TREE_CHAIN (tem))
7815 {
7816 tree temv = TREE_VALUE (tem);
5ff904cd 7817
c7e4ee3a
CB		 7818 if (sizes == tem)
7819 sizes = temv;
7820 else
7821 sizes
7822 = ffecom_2 (COMPOUND_EXPR,
7823 TREE_TYPE (sizes),
7824 temv,
7825 sizes);
7826 }
5ff904cd 7827
c7e4ee3a
CB		 7828 if (sizes != tem)
7829 {
7830 sizes
7831 = ffecom_3 (COND_EXPR,
7832 TREE_TYPE (sizes),
7833 ffecom_2 (NE_EXPR,
7834 integer_type_node,
7835 t,
7836 null_pointer_node),
7837 sizes,
7838 convert (TREE_TYPE (sizes),
7839 integer_zero_node));
7840 sizes = ffecom_save_tree (sizes);
5ff904cd 7841
c7e4ee3a
CB		 7842 sizes
7843 = tree_cons (NULL_TREE, sizes, tem);
7844 }
5ff904cd 7845
c7e4ee3a
CB		 7846 if (sizes)
7847 put_pending_sizes (sizes);
7848 }
5ff904cd 7849
c7e4ee3a
CB		 7850#else
7851#if 0
7852 if (adjustable
7853 && (ffesymbol_numentries (s)
7854 != ffecom_num_entrypoints_ + 1))
7855 DECL_SOMETHING (t)
7856 = ffecom_2 (NE_EXPR, integer_type_node,
7857 t,
7858 null_pointer_node);
7859#else
7860#if 0
7861 if (adjustable
7862 && (ffesymbol_numentries (s)
7863 != ffecom_num_entrypoints_ + 1))
7864 {
7865 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
7866 ffebad_here (0, ffesymbol_where_line (s),
7867 ffesymbol_where_column (s));
7868 ffebad_string (ffesymbol_text (s));
7869 ffebad_finish ();
7870 }
7871#endif
7872#endif
7873#endif
7874 }
5ff904cd
JL		 7875 break;
7876
c7e4ee3a 7877 case FFEINFO_whereCOMMON:
5ff904cd 7878 {
c7e4ee3a
CB		 7879 ffesymbol cs;
7880 ffeglobal cg;
7881 tree ct;
5ff904cd
JL		 7882 ffestorag st = ffesymbol_storage (s);
7883 tree type;
c7e4ee3a 7884 int yes;
5ff904cd 7885
c7e4ee3a
CB		 7886 cs = ffesymbol_common (s); /* The COMMON area itself. */
7887 if (st != NULL) /* Else not laid out. */
5ff904cd 7888 {
c7e4ee3a
CB		 7889 ffecom_transform_common_ (cs);
7890 st = ffesymbol_storage (s);
5ff904cd
JL		 7891 }
7892
c7e4ee3a 7893 yes = suspend_momentary ();
5ff904cd 7894
c7e4ee3a 7895 type = ffecom_type_localvar_ (s, bt, kt);
5ff904cd 7896
c7e4ee3a
CB		 7897 cg = ffesymbol_global (cs); /* The global COMMON info. */
7898 if ((cg == NULL)
7899 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
7900 ct = NULL_TREE;
7901 else
7902 ct = ffeglobal_hook (cg); /* The common area's tree. */
5ff904cd 7903
c7e4ee3a
CB		 7904 if ((ct == NULL_TREE)
7905 || (st == NULL)
7906 || (type == error_mark_node))
7907 t = error_mark_node;
7908 else
7909 {
7910 ffetargetOffset offset;
7911 ffestorag cst;
5ff904cd 7912
c7e4ee3a
CB		 7913 cst = ffestorag_parent (st);
7914 assert (cst == ffesymbol_storage (cs));
5ff904cd 7915
c7e4ee3a
CB		 7916 offset = ffestorag_modulo (cst)
7917 + ffestorag_offset (st)
7918 - ffestorag_offset (cst);
5ff904cd 7919
c7e4ee3a 7920 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
5ff904cd 7921
c7e4ee3a 7922 /* (t_type *) (((char *) &ct) + offset) */
5ff904cd
JL		 7923
7924 t = convert (string_type_node, /* (char *) */
7925 ffecom_1 (ADDR_EXPR,
c7e4ee3a
CB		 7926 build_pointer_type (TREE_TYPE (ct)),
7927 ct));
5ff904cd
JL		 7928 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7929 t,
7930 build_int_2 (offset, 0));
7931 t = convert (build_pointer_type (type),
7932 t);
7933
7934 addr = TRUE;
5ff904cd 7935 }
5ff904cd 7936
c7e4ee3a
CB		 7937 resume_momentary (yes);
7938 }
7939 break;
5ff904cd 7940
c7e4ee3a
CB		 7941 case FFEINFO_whereIMMEDIATE:
7942 case FFEINFO_whereGLOBAL:
7943 case FFEINFO_whereFLEETING:
7944 case FFEINFO_whereFLEETING_CADDR:
7945 case FFEINFO_whereFLEETING_IADDR:
7946 case FFEINFO_whereINTRINSIC:
7947 case FFEINFO_whereCONSTANT_SUBOBJECT:
7948 default:
7949 assert ("ENTITY where unheard of" == NULL);
7950 /* Fall through. */
7951 case FFEINFO_whereANY:
7952 t = error_mark_node;
7953 break;
7954 }
7955 break;
5ff904cd 7956
c7e4ee3a
CB		 7957 case FFEINFO_kindFUNCTION:
7958 switch (ffeinfo_where (ffesymbol_info (s)))
7959 {
7960 case FFEINFO_whereLOCAL: /* Me. */
7961 assert (!ffecom_transform_only_dummies_);
7962 t = current_function_decl;
5ff904cd
JL		 7963 break;
7964
c7e4ee3a 7965 case FFEINFO_whereGLOBAL:
5ff904cd
JL		 7966 assert (!ffecom_transform_only_dummies_);
7967
c7e4ee3a
CB		 7968 if (((g = ffesymbol_global (s)) != NULL)
7969 && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7970 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7971 && (ffeglobal_hook (g) != NULL_TREE)
7972 && ffe_is_globals ())
5ff904cd 7973 {
c7e4ee3a 7974 t = ffeglobal_hook (g);
5ff904cd
JL		 7975 break;
7976 }
5ff904cd 7977
c7e4ee3a
CB		 7978 push_obstacks_nochange ();
7979 end_temporary_allocation ();
5ff904cd 7980
c7e4ee3a
CB		 7981 if (ffesymbol_is_f2c (s)
7982 && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
7983 t = ffecom_tree_fun_type[bt][kt];
7984 else
7985 t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
5ff904cd 7986
c7e4ee3a
CB		 7987 t = build_decl (FUNCTION_DECL,
7988 ffecom_get_external_identifier_ (s),
7989 t);
7990 DECL_EXTERNAL (t) = 1;
7991 TREE_PUBLIC (t) = 1;
5ff904cd 7992
5ff904cd
JL		 7993 t = start_decl (t, FALSE);
7994 finish_decl (t, NULL_TREE, FALSE);
7995
c7e4ee3a
CB		 7996 if ((g != NULL)
7997 && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7998 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7999 ffeglobal_set_hook (g, t);
8000
8001 resume_temporary_allocation ();
8002 pop_obstacks ();
5ff904cd 8003
5ff904cd
JL		 8004 break;
8005
8006 case FFEINFO_whereDUMMY:
c7e4ee3a 8007 assert (ffecom_transform_only_dummies_);
5ff904cd 8008
c7e4ee3a
CB		 8009 if (ffesymbol_is_f2c (s)
8010 && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8011 t = ffecom_tree_ptr_to_fun_type[bt][kt];
8012 else
8013 t = build_pointer_type
8014 (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8015
8016 t = build_decl (PARM_DECL,
8017 ffecom_get_identifier_ (ffesymbol_text (s)),
8018 t);
8019#if BUILT_FOR_270
8020 DECL_ARTIFICIAL (t) = 1;
8021#endif
8022 addr = TRUE;
8023 break;
8024
8025 case FFEINFO_whereCONSTANT: /* Statement function. */
8026 assert (!ffecom_transform_only_dummies_);
8027 t = ffecom_gen_sfuncdef_ (s, bt, kt);
8028 break;
8029
8030 case FFEINFO_whereINTRINSIC:
8031 assert (!ffecom_transform_only_dummies_);
8032 break; /* Let actual references generate their
8033 decls. */
8034
8035 default:
8036 assert ("FUNCTION where unheard of" == NULL);
8037 /* Fall through. */
8038 case FFEINFO_whereANY:
8039 t = error_mark_node;
8040 break;
8041 }
8042 break;
8043
8044 case FFEINFO_kindSUBROUTINE:
8045 switch (ffeinfo_where (ffesymbol_info (s)))
8046 {
8047 case FFEINFO_whereLOCAL: /* Me. */
8048 assert (!ffecom_transform_only_dummies_);
8049 t = current_function_decl;
8050 break;
5ff904cd 8051
c7e4ee3a
CB		 8052 case FFEINFO_whereGLOBAL:
8053 assert (!ffecom_transform_only_dummies_);
5ff904cd 8054
c7e4ee3a
CB		 8055 if (((g = ffesymbol_global (s)) != NULL)
8056 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8057 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8058 && (ffeglobal_hook (g) != NULL_TREE)
8059 && ffe_is_globals ())
8060 {
8061 t = ffeglobal_hook (g);
8062 break;
8063 }
5ff904cd 8064
c7e4ee3a
CB		 8065 push_obstacks_nochange ();
8066 end_temporary_allocation ();
5ff904cd 8067
c7e4ee3a
CB		 8068 t = build_decl (FUNCTION_DECL,
8069 ffecom_get_external_identifier_ (s),
8070 ffecom_tree_subr_type);
8071 DECL_EXTERNAL (t) = 1;
8072 TREE_PUBLIC (t) = 1;
5ff904cd 8073
c7e4ee3a
CB		 8074 t = start_decl (t, FALSE);
8075 finish_decl (t, NULL_TREE, FALSE);
5ff904cd 8076
c7e4ee3a
CB		 8077 if ((g != NULL)
8078 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8079 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8080 ffeglobal_set_hook (g, t);
5ff904cd 8081
c7e4ee3a
CB		 8082 resume_temporary_allocation ();
8083 pop_obstacks ();
5ff904cd 8084
c7e4ee3a 8085 break;
5ff904cd 8086
c7e4ee3a
CB		 8087 case FFEINFO_whereDUMMY:
8088 assert (ffecom_transform_only_dummies_);
5ff904cd 8089
c7e4ee3a
CB		 8090 t = build_decl (PARM_DECL,
8091 ffecom_get_identifier_ (ffesymbol_text (s)),
8092 ffecom_tree_ptr_to_subr_type);
8093#if BUILT_FOR_270
8094 DECL_ARTIFICIAL (t) = 1;
8095#endif
8096 addr = TRUE;
8097 break;
5ff904cd 8098
c7e4ee3a
CB		 8099 case FFEINFO_whereINTRINSIC:
8100 assert (!ffecom_transform_only_dummies_);
8101 break; /* Let actual references generate their
8102 decls. */
5ff904cd 8103
c7e4ee3a
CB		 8104 default:
8105 assert ("SUBROUTINE where unheard of" == NULL);
8106 /* Fall through. */
8107 case FFEINFO_whereANY:
8108 t = error_mark_node;
8109 break;
8110 }
8111 break;
5ff904cd 8112
c7e4ee3a
CB		 8113 case FFEINFO_kindPROGRAM:
8114 switch (ffeinfo_where (ffesymbol_info (s)))
8115 {
8116 case FFEINFO_whereLOCAL: /* Me. */
8117 assert (!ffecom_transform_only_dummies_);
8118 t = current_function_decl;
8119 break;
5ff904cd 8120
c7e4ee3a
CB		 8121 case FFEINFO_whereCOMMON:
8122 case FFEINFO_whereDUMMY:
8123 case FFEINFO_whereGLOBAL:
8124 case FFEINFO_whereRESULT:
8125 case FFEINFO_whereFLEETING:
8126 case FFEINFO_whereFLEETING_CADDR:
8127 case FFEINFO_whereFLEETING_IADDR:
8128 case FFEINFO_whereIMMEDIATE:
8129 case FFEINFO_whereINTRINSIC:
8130 case FFEINFO_whereCONSTANT:
8131 case FFEINFO_whereCONSTANT_SUBOBJECT:
8132 default:
8133 assert ("PROGRAM where unheard of" == NULL);
8134 /* Fall through. */
8135 case FFEINFO_whereANY:
8136 t = error_mark_node;
8137 break;
8138 }
8139 break;
5ff904cd 8140
c7e4ee3a
CB		 8141 case FFEINFO_kindBLOCKDATA:
8142 switch (ffeinfo_where (ffesymbol_info (s)))
8143 {
8144 case FFEINFO_whereLOCAL: /* Me. */
8145 assert (!ffecom_transform_only_dummies_);
8146 t = current_function_decl;
8147 break;
5ff904cd 8148
c7e4ee3a
CB		 8149 case FFEINFO_whereGLOBAL:
8150 assert (!ffecom_transform_only_dummies_);
5ff904cd 8151
c7e4ee3a
CB		 8152 push_obstacks_nochange ();
8153 end_temporary_allocation ();
5ff904cd 8154
c7e4ee3a
CB		 8155 t = build_decl (FUNCTION_DECL,
8156 ffecom_get_external_identifier_ (s),
8157 ffecom_tree_blockdata_type);
8158 DECL_EXTERNAL (t) = 1;
8159 TREE_PUBLIC (t) = 1;
5ff904cd 8160
c7e4ee3a
CB		 8161 t = start_decl (t, FALSE);
8162 finish_decl (t, NULL_TREE, FALSE);
5ff904cd 8163
c7e4ee3a
CB		 8164 resume_temporary_allocation ();
8165 pop_obstacks ();
5ff904cd 8166
c7e4ee3a 8167 break;
5ff904cd 8168
c7e4ee3a
CB		 8169 case FFEINFO_whereCOMMON:
8170 case FFEINFO_whereDUMMY:
8171 case FFEINFO_whereRESULT:
8172 case FFEINFO_whereFLEETING:
8173 case FFEINFO_whereFLEETING_CADDR:
8174 case FFEINFO_whereFLEETING_IADDR:
8175 case FFEINFO_whereIMMEDIATE:
8176 case FFEINFO_whereINTRINSIC:
8177 case FFEINFO_whereCONSTANT:
8178 case FFEINFO_whereCONSTANT_SUBOBJECT:
8179 default:
8180 assert ("BLOCKDATA where unheard of" == NULL);
8181 /* Fall through. */
8182 case FFEINFO_whereANY:
8183 t = error_mark_node;
8184 break;
8185 }
8186 break;
5ff904cd 8187
c7e4ee3a
CB		 8188 case FFEINFO_kindCOMMON:
8189 switch (ffeinfo_where (ffesymbol_info (s)))
8190 {
8191 case FFEINFO_whereLOCAL:
8192 assert (!ffecom_transform_only_dummies_);
8193 ffecom_transform_common_ (s);
8194 break;
8195
8196 case FFEINFO_whereNONE:
8197 case FFEINFO_whereCOMMON:
8198 case FFEINFO_whereDUMMY:
8199 case FFEINFO_whereGLOBAL:
8200 case FFEINFO_whereRESULT:
8201 case FFEINFO_whereFLEETING:
8202 case FFEINFO_whereFLEETING_CADDR:
8203 case FFEINFO_whereFLEETING_IADDR:
8204 case FFEINFO_whereIMMEDIATE:
8205 case FFEINFO_whereINTRINSIC:
8206 case FFEINFO_whereCONSTANT:
8207 case FFEINFO_whereCONSTANT_SUBOBJECT:
8208 default:
8209 assert ("COMMON where unheard of" == NULL);
8210 /* Fall through. */
8211 case FFEINFO_whereANY:
8212 t = error_mark_node;
8213 break;
8214 }
8215 break;
5ff904cd 8216
c7e4ee3a
CB		 8217 case FFEINFO_kindCONSTRUCT:
8218 switch (ffeinfo_where (ffesymbol_info (s)))
8219 {
8220 case FFEINFO_whereLOCAL:
8221 assert (!ffecom_transform_only_dummies_);
8222 break;
5ff904cd 8223
c7e4ee3a
CB		 8224 case FFEINFO_whereNONE:
8225 case FFEINFO_whereCOMMON:
8226 case FFEINFO_whereDUMMY:
8227 case FFEINFO_whereGLOBAL:
8228 case FFEINFO_whereRESULT:
8229 case FFEINFO_whereFLEETING:
8230 case FFEINFO_whereFLEETING_CADDR:
8231 case FFEINFO_whereFLEETING_IADDR:
8232 case FFEINFO_whereIMMEDIATE:
8233 case FFEINFO_whereINTRINSIC:
8234 case FFEINFO_whereCONSTANT:
8235 case FFEINFO_whereCONSTANT_SUBOBJECT:
8236 default:
8237 assert ("CONSTRUCT where unheard of" == NULL);
8238 /* Fall through. */
8239 case FFEINFO_whereANY:
8240 t = error_mark_node;
8241 break;
8242 }
8243 break;
5ff904cd 8244
c7e4ee3a
CB		 8245 case FFEINFO_kindNAMELIST:
8246 switch (ffeinfo_where (ffesymbol_info (s)))
8247 {
8248 case FFEINFO_whereLOCAL:
8249 assert (!ffecom_transform_only_dummies_);
8250 t = ffecom_transform_namelist_ (s);
8251 break;
5ff904cd 8252
c7e4ee3a
CB		 8253 case FFEINFO_whereNONE:
8254 case FFEINFO_whereCOMMON:
8255 case FFEINFO_whereDUMMY:
8256 case FFEINFO_whereGLOBAL:
8257 case FFEINFO_whereRESULT:
8258 case FFEINFO_whereFLEETING:
8259 case FFEINFO_whereFLEETING_CADDR:
8260 case FFEINFO_whereFLEETING_IADDR:
8261 case FFEINFO_whereIMMEDIATE:
8262 case FFEINFO_whereINTRINSIC:
8263 case FFEINFO_whereCONSTANT:
8264 case FFEINFO_whereCONSTANT_SUBOBJECT:
8265 default:
8266 assert ("NAMELIST where unheard of" == NULL);
8267 /* Fall through. */
8268 case FFEINFO_whereANY:
8269 t = error_mark_node;
8270 break;
8271 }
8272 break;
5ff904cd 8273
c7e4ee3a
CB		 8274 default:
8275 assert ("kind unheard of" == NULL);
8276 /* Fall through. */
8277 case FFEINFO_kindANY:
8278 t = error_mark_node;
8279 break;
8280 }
5ff904cd 8281
c7e4ee3a
CB		 8282 ffesymbol_hook (s).decl_tree = t;
8283 ffesymbol_hook (s).length_tree = tlen;
8284 ffesymbol_hook (s).addr = addr;
5ff904cd 8285
c7e4ee3a
CB		 8286 lineno = old_lineno;
8287 input_filename = old_input_filename;
5ff904cd 8288
c7e4ee3a
CB		 8289 return s;
8290}
5ff904cd 8291
5ff904cd 8292#endif
c7e4ee3a 8293/* Transform into ASSIGNable symbol.
5ff904cd 8294
c7e4ee3a
CB		 8295 Symbol has already been transformed, but for whatever reason, the
8296 resulting decl_tree has been deemed not usable for an ASSIGN target.
8297 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8298 another local symbol of type void * and stuff that in the assign_tree
8299 argument. The F77/F90 standards allow this implementation. */
5ff904cd 8300
c7e4ee3a
CB		 8301#if FFECOM_targetCURRENT == FFECOM_targetGCC
8302static ffesymbol
8303ffecom_sym_transform_assign_ (ffesymbol s)
8304{
8305 tree t; /* Transformed thingy. */
8306 int yes;
8307 int old_lineno = lineno;
8308 char *old_input_filename = input_filename;
5ff904cd 8309
c7e4ee3a
CB		 8310 if (ffesymbol_sfdummyparent (s) == NULL)
8311 {
8312 input_filename = ffesymbol_where_filename (s);
8313 lineno = ffesymbol_where_filelinenum (s);
8314 }
8315 else
8316 {
8317 ffesymbol sf = ffesymbol_sfdummyparent (s);
5ff904cd 8318
c7e4ee3a
CB		 8319 input_filename = ffesymbol_where_filename (sf);
8320 lineno = ffesymbol_where_filelinenum (sf);
8321 }
5ff904cd 8322
c7e4ee3a 8323 assert (!ffecom_transform_only_dummies_);
5ff904cd 8324
c7e4ee3a 8325 yes = suspend_momentary ();
5ff904cd 8326
c7e4ee3a
CB		 8327 t = build_decl (VAR_DECL,
8328 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8329 ffesymbol_text (s),
8330 -1),
8331 TREE_TYPE (null_pointer_node));
5ff904cd 8332
c7e4ee3a
CB		 8333 switch (ffesymbol_where (s))
8334 {
8335 case FFEINFO_whereLOCAL:
8336 /* Unlike for regular vars, SAVE status is easy to determine for
8337 ASSIGNed vars, since there's no initialization, there's no
8338 effective storage association (so "SAVE J" does not apply to
8339 K even given "EQUIVALENCE (J,K)"), there's no size issue
8340 to worry about, etc. */
8341 if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8342 && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8343 && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8344 TREE_STATIC (t) = 1; /* SAVEd in proc, make static. */
8345 else
8346 TREE_STATIC (t) = 0; /* No need to make static. */
8347 break;
5ff904cd 8348
c7e4ee3a
CB		 8349 case FFEINFO_whereCOMMON:
8350 TREE_STATIC (t) = 1; /* Assume COMMONs always SAVEd. */
8351 break;
5ff904cd 8352
c7e4ee3a
CB		 8353 case FFEINFO_whereDUMMY:
8354 /* Note that twinning a DUMMY means the caller won't see
8355 the ASSIGNed value. But both F77 and F90 allow implementations
8356 to do this, i.e. disallow Fortran code that would try and
8357 take advantage of actually putting a label into a variable
8358 via a dummy argument (or any other storage association, for
8359 that matter). */
8360 TREE_STATIC (t) = 0;
8361 break;
5ff904cd 8362
c7e4ee3a
CB		 8363 default:
8364 TREE_STATIC (t) = 0;
8365 break;
8366 }
5ff904cd 8367
c7e4ee3a
CB		 8368 t = start_decl (t, FALSE);
8369 finish_decl (t, NULL_TREE, FALSE);
5ff904cd 8370
c7e4ee3a 8371 resume_momentary (yes);
5ff904cd 8372
c7e4ee3a 8373 ffesymbol_hook (s).assign_tree = t;
5ff904cd 8374
c7e4ee3a
CB		 8375 lineno = old_lineno;
8376 input_filename = old_input_filename;
5ff904cd 8377
c7e4ee3a
CB		 8378 return s;
8379}
5ff904cd 8380
c7e4ee3a
CB		 8381#endif
8382/* Implement COMMON area in back end.
5ff904cd 8383
c7e4ee3a
CB		 8384 Because COMMON-based variables can be referenced in the dimension
8385 expressions of dummy (adjustable) arrays, and because dummies
8386 (in the gcc back end) need to be put in the outer binding level
8387 of a function (which has two binding levels, the outer holding
8388 the dummies and the inner holding the other vars), special care
8389 must be taken to handle COMMON areas.
5ff904cd 8390
c7e4ee3a
CB		 8391 The current strategy is basically to always tell the back end about
8392 the COMMON area as a top-level external reference to just a block
8393 of storage of the master type of that area (e.g. integer, real,
8394 character, whatever -- not a structure). As a distinct action,
8395 if initial values are provided, tell the back end about the area
8396 as a top-level non-external (initialized) area and remember not to
8397 allow further initialization or expansion of the area. Meanwhile,
8398 if no initialization happens at all, tell the back end about
8399 the largest size we've seen declared so the space does get reserved.
8400 (This function doesn't handle all that stuff, but it does some
8401 of the important things.)
5ff904cd 8402
c7e4ee3a
CB		 8403 Meanwhile, for COMMON variables themselves, just keep creating
8404 references like *((float *) (&common_area + offset)) each time
8405 we reference the variable. In other words, don't make a VAR_DECL
8406 or any kind of component reference (like we used to do before 0.4),
8407 though we might do that as well just for debugging purposes (and
8408 stuff the rtl with the appropriate offset expression). */
5ff904cd 8409
c7e4ee3a
CB		 8410#if FFECOM_targetCURRENT == FFECOM_targetGCC
8411static void
8412ffecom_transform_common_ (ffesymbol s)
8413{
8414 ffestorag st = ffesymbol_storage (s);
8415 ffeglobal g = ffesymbol_global (s);
8416 tree cbt;
8417 tree cbtype;
8418 tree init;
8419 tree high;
8420 bool is_init = ffestorag_is_init (st);
5ff904cd 8421
c7e4ee3a 8422 assert (st != NULL);
5ff904cd 8423
c7e4ee3a
CB		 8424 if ((g == NULL)
8425 || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8426 return;
5ff904cd 8427
c7e4ee3a 8428 /* First update the size of the area in global terms. */
5ff904cd 8429
c7e4ee3a 8430 ffeglobal_size_common (s, ffestorag_size (st));
5ff904cd 8431
c7e4ee3a
CB		 8432 if (!ffeglobal_common_init (g))
8433 is_init = FALSE; /* No explicit init, don't let erroneous joins init. */
5ff904cd 8434
c7e4ee3a 8435 cbt = ffeglobal_hook (g);
5ff904cd 8436
c7e4ee3a
CB		 8437 /* If we already have declared this common block for a previous program
8438 unit, and either we already initialized it or we don't have new
8439 initialization for it, just return what we have without changing it. */
5ff904cd 8440
c7e4ee3a
CB		 8441 if ((cbt != NULL_TREE)
8442 && (!is_init
8443 || !DECL_EXTERNAL (cbt)))
8444 return;
5ff904cd 8445
c7e4ee3a 8446 /* Process inits. */
5ff904cd 8447
c7e4ee3a
CB		 8448 if (is_init)
8449 {
8450 if (ffestorag_init (st) != NULL)
5ff904cd 8451 {
c7e4ee3a 8452 ffebld sexp;
5ff904cd 8453
c7e4ee3a
CB		 8454 /* Set the padding for the expression, so ffecom_expr
8455 knows to insert that many zeros. */
8456 switch (ffebld_op (sexp = ffestorag_init (st)))
5ff904cd 8457 {
c7e4ee3a
CB		 8458 case FFEBLD_opCONTER:
8459 ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
5ff904cd 8460 break;
5ff904cd 8461
c7e4ee3a
CB		 8462 case FFEBLD_opARRTER:
8463 ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8464 break;
5ff904cd 8465
c7e4ee3a
CB		 8466 case FFEBLD_opACCTER:
8467 ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8468 break;
5ff904cd 8469
c7e4ee3a
CB		 8470 default:
8471 assert ("bad op for cmn init (pad)" == NULL);
8472 break;
8473 }
5ff904cd 8474
c7e4ee3a
CB		 8475 init = ffecom_expr (sexp);
8476 if (init == error_mark_node)
8477 { /* Hopefully the back end complained! */
8478 init = NULL_TREE;
8479 if (cbt != NULL_TREE)
8480 return;
8481 }
8482 }
8483 else
8484 init = error_mark_node;
8485 }
8486 else
8487 init = NULL_TREE;
5ff904cd 8488
c7e4ee3a
CB		 8489 push_obstacks_nochange ();
8490 end_temporary_allocation ();
5ff904cd 8491
c7e4ee3a 8492 /* cbtype must be permanently allocated! */
5ff904cd 8493
c7e4ee3a
CB		 8494 /* Allocate the MAX of the areas so far, seen filewide. */
8495 high = build_int_2 ((ffeglobal_common_size (g)
8496 + ffeglobal_common_pad (g)) - 1, 0);
8497 TREE_TYPE (high) = ffecom_integer_type_node;
5ff904cd 8498
c7e4ee3a
CB		 8499 if (init)
8500 cbtype = build_array_type (char_type_node,
8501 build_range_type (integer_type_node,
8502 integer_zero_node,
8503 high));
8504 else
8505 cbtype = build_array_type (char_type_node, NULL_TREE);
5ff904cd 8506
c7e4ee3a
CB		 8507 if (cbt == NULL_TREE)
8508 {
8509 cbt
8510 = build_decl (VAR_DECL,
8511 ffecom_get_external_identifier_ (s),
8512 cbtype);
8513 TREE_STATIC (cbt) = 1;
8514 TREE_PUBLIC (cbt) = 1;
8515 }
8516 else
8517 {
8518 assert (is_init);
8519 TREE_TYPE (cbt) = cbtype;
8520 }
8521 DECL_EXTERNAL (cbt) = init ? 0 : 1;
8522 DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
5ff904cd 8523
c7e4ee3a
CB		 8524 cbt = start_decl (cbt, TRUE);
8525 if (ffeglobal_hook (g) != NULL)
8526 assert (cbt == ffeglobal_hook (g));
5ff904cd 8527
c7e4ee3a 8528 assert (!init || !DECL_EXTERNAL (cbt));
5ff904cd 8529
c7e4ee3a
CB		 8530 /* Make sure that any type can live in COMMON and be referenced
8531 without getting a bus error. We could pick the most restrictive
8532 alignment of all entities actually placed in the COMMON, but
8533 this seems easy enough. */
5ff904cd 8534
c7e4ee3a 8535 DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
5ff904cd 8536
c7e4ee3a
CB		 8537 if (is_init && (ffestorag_init (st) == NULL))
8538 init = ffecom_init_zero_ (cbt);
5ff904cd 8539
c7e4ee3a 8540 finish_decl (cbt, init, TRUE);
5ff904cd 8541
c7e4ee3a
CB		 8542 if (is_init)
8543 ffestorag_set_init (st, ffebld_new_any ());
5ff904cd 8544
c7e4ee3a
CB		 8545 if (init)
8546 {
8547 tree size_tree;
5ff904cd 8548
c7e4ee3a
CB		 8549 assert (DECL_SIZE (cbt) != NULL_TREE);
8550 assert (TREE_CODE (DECL_SIZE (cbt)) == INTEGER_CST);
8551 size_tree = size_binop (CEIL_DIV_EXPR,
8552 DECL_SIZE (cbt),
8553 size_int (BITS_PER_UNIT));
8554 assert (TREE_INT_CST_HIGH (size_tree) == 0);
8555 assert (TREE_INT_CST_LOW (size_tree)
8556 == ffeglobal_common_size (g) + ffeglobal_common_pad (g));
8557 }
5ff904cd 8558
c7e4ee3a 8559 ffeglobal_set_hook (g, cbt);
5ff904cd 8560
c7e4ee3a 8561 ffestorag_set_hook (st, cbt);
5ff904cd 8562
c7e4ee3a
CB		 8563 resume_temporary_allocation ();
8564 pop_obstacks ();
8565}
5ff904cd 8566
c7e4ee3a
CB		 8567#endif
8568/* Make master area for local EQUIVALENCE. */
5ff904cd 8569
c7e4ee3a
CB		 8570#if FFECOM_targetCURRENT == FFECOM_targetGCC
8571static void
8572ffecom_transform_equiv_ (ffestorag eqst)
8573{
8574 tree eqt;
8575 tree eqtype;
8576 tree init;
8577 tree high;
8578 bool is_init = ffestorag_is_init (eqst);
8579 int yes;
5ff904cd 8580
c7e4ee3a 8581 assert (eqst != NULL);
5ff904cd 8582
c7e4ee3a 8583 eqt = ffestorag_hook (eqst);
5ff904cd 8584
c7e4ee3a
CB		 8585 if (eqt != NULL_TREE)
8586 return;
5ff904cd 8587
c7e4ee3a
CB		 8588 /* Process inits. */
8589
8590 if (is_init)
8591 {
8592 if (ffestorag_init (eqst) != NULL)
5ff904cd 8593 {
c7e4ee3a 8594 ffebld sexp;
5ff904cd 8595
c7e4ee3a
CB		 8596 /* Set the padding for the expression, so ffecom_expr
8597 knows to insert that many zeros. */
8598 switch (ffebld_op (sexp = ffestorag_init (eqst)))
8599 {
8600 case FFEBLD_opCONTER:
8601 ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8602 break;
5ff904cd 8603
c7e4ee3a
CB		 8604 case FFEBLD_opARRTER:
8605 ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8606 break;
5ff904cd 8607
c7e4ee3a
CB		 8608 case FFEBLD_opACCTER:
8609 ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8610 break;
5ff904cd 8611
c7e4ee3a
CB		 8612 default:
8613 assert ("bad op for eqv init (pad)" == NULL);
8614 break;
8615 }
5ff904cd 8616
c7e4ee3a
CB		 8617 init = ffecom_expr (sexp);
8618 if (init == error_mark_node)
8619 init = NULL_TREE; /* Hopefully the back end complained! */
8620 }
8621 else
8622 init = error_mark_node;
8623 }
8624 else if (ffe_is_init_local_zero ())
8625 init = error_mark_node;
8626 else
8627 init = NULL_TREE;
5ff904cd 8628
c7e4ee3a
CB		 8629 ffecom_member_namelisted_ = FALSE;
8630 ffestorag_drive (ffestorag_list_equivs (eqst),
8631 &ffecom_member_phase1_,
8632 eqst);
5ff904cd 8633
c7e4ee3a 8634 yes = suspend_momentary ();
5ff904cd 8635
c7e4ee3a
CB		 8636 high = build_int_2 ((ffestorag_size (eqst)
8637 + ffestorag_modulo (eqst)) - 1, 0);
8638 TREE_TYPE (high) = ffecom_integer_type_node;
5ff904cd 8639
c7e4ee3a
CB		 8640 eqtype = build_array_type (char_type_node,
8641 build_range_type (ffecom_integer_type_node,
8642 ffecom_integer_zero_node,
8643 high));
8644
8645 eqt = build_decl (VAR_DECL,
8646 ffecom_get_invented_identifier ("__g77_equiv_%s",
8647 ffesymbol_text
8648 (ffestorag_symbol
8649 (eqst)),
8650 -1),
8651 eqtype);
8652 DECL_EXTERNAL (eqt) = 0;
8653 if (is_init
8654 || ffecom_member_namelisted_
8655#ifdef FFECOM_sizeMAXSTACKITEM
8656 || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8657#endif
8658 || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8659 && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8660 && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8661 TREE_STATIC (eqt) = 1;
8662 else
8663 TREE_STATIC (eqt) = 0;
8664 TREE_PUBLIC (eqt) = 0;
8665 DECL_CONTEXT (eqt) = current_function_decl;
8666 if (init)
8667 DECL_INITIAL (eqt) = error_mark_node;
8668 else
8669 DECL_INITIAL (eqt) = NULL_TREE;
5ff904cd 8670
c7e4ee3a 8671 eqt = start_decl (eqt, FALSE);
5ff904cd 8672
c7e4ee3a
CB		 8673 /* Make sure that any type can live in EQUIVALENCE and be referenced
8674 without getting a bus error. We could pick the most restrictive
8675 alignment of all entities actually placed in the EQUIVALENCE, but
8676 this seems easy enough. */
5ff904cd 8677
c7e4ee3a 8678 DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
5ff904cd 8679
c7e4ee3a
CB		 8680 if ((!is_init && ffe_is_init_local_zero ())
8681 || (is_init && (ffestorag_init (eqst) == NULL)))
8682 init = ffecom_init_zero_ (eqt);
5ff904cd 8683
c7e4ee3a 8684 finish_decl (eqt, init, FALSE);
5ff904cd 8685
c7e4ee3a
CB		 8686 if (is_init)
8687 ffestorag_set_init (eqst, ffebld_new_any ());
5ff904cd 8688
c7e4ee3a
CB		 8689 {
8690 tree size_tree;
5ff904cd 8691
c7e4ee3a
CB		 8692 size_tree = size_binop (CEIL_DIV_EXPR,
8693 DECL_SIZE (eqt),
8694 size_int (BITS_PER_UNIT));
8695 assert (TREE_INT_CST_HIGH (size_tree) == 0);
8696 assert (TREE_INT_CST_LOW (size_tree)
8697 == ffestorag_size (eqst) + ffestorag_modulo (eqst));
8698 }
5ff904cd 8699
c7e4ee3a 8700 ffestorag_set_hook (eqst, eqt);
5ff904cd 8701
c7e4ee3a
CB		 8702#ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
8703 ffestorag_drive (ffestorag_list_equivs (eqst),
8704 &ffecom_member_phase2_,
8705 eqst);
8706#endif
8707
8708 resume_momentary (yes);
5ff904cd
JL		 8709}
8710
8711#endif
c7e4ee3a 8712/* Implement NAMELIST in back end. See f2c/format.c for more info. */
5ff904cd
JL		 8713
8714#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 8715static tree
8716ffecom_transform_namelist_ (ffesymbol s)
5ff904cd 8717{
c7e4ee3a
CB		 8718 tree nmlt;
8719 tree nmltype = ffecom_type_namelist_ ();
8720 tree nmlinits;
8721 tree nameinit;
8722 tree varsinit;
8723 tree nvarsinit;
8724 tree field;
8725 tree high;
5ff904cd 8726 int yes;
c7e4ee3a
CB		 8727 int i;
8728 static int mynumber = 0;
5ff904cd 8729
c7e4ee3a 8730 yes = suspend_momentary ();
5ff904cd 8731
c7e4ee3a
CB		 8732 nmlt = build_decl (VAR_DECL,
8733 ffecom_get_invented_identifier ("__g77_namelist_%d",
8734 NULL, mynumber++),
8735 nmltype);
8736 TREE_STATIC (nmlt) = 1;
8737 DECL_INITIAL (nmlt) = error_mark_node;
5ff904cd 8738
c7e4ee3a 8739 nmlt = start_decl (nmlt, FALSE);
5ff904cd 8740
c7e4ee3a 8741 /* Process inits. */
5ff904cd 8742
c7e4ee3a 8743 i = strlen (ffesymbol_text (s));
5ff904cd 8744
c7e4ee3a
CB		 8745 high = build_int_2 (i, 0);
8746 TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8747
8748 nameinit = ffecom_build_f2c_string_ (i + 1,
8749 ffesymbol_text (s));
8750 TREE_TYPE (nameinit)
8751 = build_type_variant
8752 (build_array_type
8753 (char_type_node,
8754 build_range_type (ffecom_f2c_ftnlen_type_node,
8755 ffecom_f2c_ftnlen_one_node,
8756 high)),
8757 1, 0);
8758 TREE_CONSTANT (nameinit) = 1;
8759 TREE_STATIC (nameinit) = 1;
8760 nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8761 nameinit);
8762
8763 varsinit = ffecom_vardesc_array_ (s);
8764 varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8765 varsinit);
8766 TREE_CONSTANT (varsinit) = 1;
8767 TREE_STATIC (varsinit) = 1;
8768
8769 {
8770 ffebld b;
8771
8772 for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8773 ++i;
8774 }
8775 nvarsinit = build_int_2 (i, 0);
8776 TREE_TYPE (nvarsinit) = integer_type_node;
8777 TREE_CONSTANT (nvarsinit) = 1;
8778 TREE_STATIC (nvarsinit) = 1;
8779
8780 nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8781 TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8782 varsinit);
8783 TREE_CHAIN (TREE_CHAIN (nmlinits))
8784 = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8785
8786 nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8787 TREE_CONSTANT (nmlinits) = 1;
8788 TREE_STATIC (nmlinits) = 1;
8789
8790 finish_decl (nmlt, nmlinits, FALSE);
8791
8792 nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8793
8794 resume_momentary (yes);
8795
8796 return nmlt;
8797}
8798
8799#endif
8800
8801/* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8802 analyzed on the assumption it is calculating a pointer to be
8803 indirected through. It must return the proper decl and offset,
8804 taking into account different units of measurements for offsets. */
8805
8806#if FFECOM_targetCURRENT == FFECOM_targetGCC
8807static void
8808ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8809 tree t)
8810{
8811 switch (TREE_CODE (t))
8812 {
8813 case NOP_EXPR:
8814 case CONVERT_EXPR:
8815 case NON_LVALUE_EXPR:
8816 ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
5ff904cd
JL		 8817 break;
8818
c7e4ee3a
CB		 8819 case PLUS_EXPR:
8820 ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8821 if ((*decl == NULL_TREE)
8822 || (*decl == error_mark_node))
8823 break;
8824
8825 if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8826 {
8827 /* An offset into COMMON. */
8828 *offset = size_binop (PLUS_EXPR,
8829 *offset,
8830 TREE_OPERAND (t, 1));
8831 /* Convert offset (presumably in bytes) into canonical units
8832 (presumably bits). */
8833 *offset = size_binop (MULT_EXPR,
8834 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))),
8835 *offset);
8836 break;
8837 }
8838 /* Not a COMMON reference, so an unrecognized pattern. */
8839 *decl = error_mark_node;
5ff904cd
JL		 8840 break;
8841
c7e4ee3a
CB		 8842 case PARM_DECL:
8843 *decl = t;
8844 *offset = bitsize_int (0L, 0L);
5ff904cd
JL		 8845 break;
8846
c7e4ee3a
CB		 8847 case ADDR_EXPR:
8848 if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8849 {
8850 /* A reference to COMMON. */
8851 *decl = TREE_OPERAND (t, 0);
8852 *offset = bitsize_int (0L, 0L);
8853 break;
8854 }
8855 /* Fall through. */
5ff904cd 8856 default:
c7e4ee3a
CB		 8857 /* Not a COMMON reference, so an unrecognized pattern. */
8858 *decl = error_mark_node;
5ff904cd
JL		 8859 break;
8860 }
c7e4ee3a
CB		 8861}
8862#endif
5ff904cd 8863
c7e4ee3a
CB		 8864/* Given a tree that is possibly intended for use as an lvalue, return
8865 information representing a canonical view of that tree as a decl, an
8866 offset into that decl, and a size for the lvalue.
5ff904cd 8867
c7e4ee3a
CB		 8868 If there's no applicable decl, NULL_TREE is returned for the decl,
8869 and the other fields are left undefined.
5ff904cd 8870
c7e4ee3a
CB		 8871 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8872 is returned for the decl, and the other fields are left undefined.
5ff904cd 8873
c7e4ee3a
CB		 8874 Otherwise, the decl returned currently is either a VAR_DECL or a
8875 PARM_DECL.
5ff904cd 8876
c7e4ee3a
CB		 8877 The offset returned is always valid, but of course not necessarily
8878 a constant, and not necessarily converted into the appropriate
8879 type, leaving that up to the caller (so as to avoid that overhead
8880 if the decls being looked at are different anyway).
5ff904cd 8881
c7e4ee3a
CB		 8882 If the size cannot be determined (e.g. an adjustable array),
8883 an ERROR_MARK node is returned for the size. Otherwise, the
8884 size returned is valid, not necessarily a constant, and not
8885 necessarily converted into the appropriate type as with the
8886 offset.
5ff904cd 8887
c7e4ee3a
CB		 8888 Note that the offset and size expressions are expressed in the
8889 base storage units (usually bits) rather than in the units of
8890 the type of the decl, because two decls with different types
8891 might overlap but with apparently non-overlapping array offsets,
8892 whereas converting the array offsets to consistant offsets will
8893 reveal the overlap. */
5ff904cd
JL		 8894
8895#if FFECOM_targetCURRENT == FFECOM_targetGCC
8896static void
c7e4ee3a
CB		 8897ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
8898 tree *size, tree t)
5ff904cd 8899{
c7e4ee3a
CB		 8900 /* The default path is to report a nonexistant decl. */
8901 *decl = NULL_TREE;
5ff904cd 8902
c7e4ee3a 8903 if (t == NULL_TREE)
5ff904cd
JL		 8904 return;
8905
c7e4ee3a
CB		 8906 switch (TREE_CODE (t))
8907 {
8908 case ERROR_MARK:
8909 case IDENTIFIER_NODE:
8910 case INTEGER_CST:
8911 case REAL_CST:
8912 case COMPLEX_CST:
8913 case STRING_CST:
8914 case CONST_DECL:
8915 case PLUS_EXPR:
8916 case MINUS_EXPR:
8917 case MULT_EXPR:
8918 case TRUNC_DIV_EXPR:
8919 case CEIL_DIV_EXPR:
8920 case FLOOR_DIV_EXPR:
8921 case ROUND_DIV_EXPR:
8922 case TRUNC_MOD_EXPR:
8923 case CEIL_MOD_EXPR:
8924 case FLOOR_MOD_EXPR:
8925 case ROUND_MOD_EXPR:
8926 case RDIV_EXPR:
8927 case EXACT_DIV_EXPR:
8928 case FIX_TRUNC_EXPR:
8929 case FIX_CEIL_EXPR:
8930 case FIX_FLOOR_EXPR:
8931 case FIX_ROUND_EXPR:
8932 case FLOAT_EXPR:
8933 case EXPON_EXPR:
8934 case NEGATE_EXPR:
8935 case MIN_EXPR:
8936 case MAX_EXPR:
8937 case ABS_EXPR:
8938 case FFS_EXPR:
8939 case LSHIFT_EXPR:
8940 case RSHIFT_EXPR:
8941 case LROTATE_EXPR:
8942 case RROTATE_EXPR:
8943 case BIT_IOR_EXPR:
8944 case BIT_XOR_EXPR:
8945 case BIT_AND_EXPR:
8946 case BIT_ANDTC_EXPR:
8947 case BIT_NOT_EXPR:
8948 case TRUTH_ANDIF_EXPR:
8949 case TRUTH_ORIF_EXPR:
8950 case TRUTH_AND_EXPR:
8951 case TRUTH_OR_EXPR:
8952 case TRUTH_XOR_EXPR:
8953 case TRUTH_NOT_EXPR:
8954 case LT_EXPR:
8955 case LE_EXPR:
8956 case GT_EXPR:
8957 case GE_EXPR:
8958 case EQ_EXPR:
8959 case NE_EXPR:
8960 case COMPLEX_EXPR:
8961 case CONJ_EXPR:
8962 case REALPART_EXPR:
8963 case IMAGPART_EXPR:
8964 case LABEL_EXPR:
8965 case COMPONENT_REF:
8966 case COMPOUND_EXPR:
8967 case ADDR_EXPR:
8968 return;
5ff904cd 8969
c7e4ee3a
CB		 8970 case VAR_DECL:
8971 case PARM_DECL:
8972 *decl = t;
8973 *offset = bitsize_int (0L, 0L);
8974 *size = TYPE_SIZE (TREE_TYPE (t));
8975 return;
5ff904cd 8976
c7e4ee3a
CB		 8977 case ARRAY_REF:
8978 {
8979 tree array = TREE_OPERAND (t, 0);
8980 tree element = TREE_OPERAND (t, 1);
8981 tree init_offset;
8982
8983 if ((array == NULL_TREE)
8984 || (element == NULL_TREE))
8985 {
8986 *decl = error_mark_node;
8987 return;
8988 }
8989
8990 ffecom_tree_canonize_ref_ (decl, &init_offset, size,
8991 array);
8992 if ((*decl == NULL_TREE)
8993 || (*decl == error_mark_node))
8994 return;
8995
8996 *offset = size_binop (MULT_EXPR,
8997 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))),
8998 size_binop (MINUS_EXPR,
8999 element,
9000 TYPE_MIN_VALUE
9001 (TYPE_DOMAIN
9002 (TREE_TYPE (array)))));
9003
9004 *offset = size_binop (PLUS_EXPR,
9005 init_offset,
9006 *offset);
9007
9008 *size = TYPE_SIZE (TREE_TYPE (t));
9009 return;
9010 }
9011
9012 case INDIRECT_REF:
9013
9014 /* Most of this code is to handle references to COMMON. And so
9015 far that is useful only for calling library functions, since
9016 external (user) functions might reference common areas. But
9017 even calling an external function, it's worthwhile to decode
9018 COMMON references because if not storing into COMMON, we don't
9019 want COMMON-based arguments to gratuitously force use of a
9020 temporary. */
9021
9022 *size = TYPE_SIZE (TREE_TYPE (t));
5ff904cd 9023
c7e4ee3a
CB		 9024 ffecom_tree_canonize_ptr_ (decl, offset,
9025 TREE_OPERAND (t, 0));
5ff904cd 9026
c7e4ee3a 9027 return;
5ff904cd 9028
c7e4ee3a
CB		 9029 case CONVERT_EXPR:
9030 case NOP_EXPR:
9031 case MODIFY_EXPR:
9032 case NON_LVALUE_EXPR:
9033 case RESULT_DECL:
9034 case FIELD_DECL:
9035 case COND_EXPR: /* More cases than we can handle. */
9036 case SAVE_EXPR:
9037 case REFERENCE_EXPR:
9038 case PREDECREMENT_EXPR:
9039 case PREINCREMENT_EXPR:
9040 case POSTDECREMENT_EXPR:
9041 case POSTINCREMENT_EXPR:
9042 case CALL_EXPR:
9043 default:
9044 *decl = error_mark_node;
9045 return;
9046 }
9047}
9048#endif
5ff904cd 9049
c7e4ee3a 9050/* Do divide operation appropriate to type of operands. */
5ff904cd 9051
c7e4ee3a
CB		 9052#if FFECOM_targetCURRENT == FFECOM_targetGCC
9053static tree
9054ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9055 tree dest_tree, ffebld dest, bool *dest_used,
9056 tree hook)
9057{
9058 if ((left == error_mark_node)
9059 || (right == error_mark_node))
9060 return error_mark_node;
a6fa6420 9061
c7e4ee3a
CB		 9062 switch (TREE_CODE (tree_type))
9063 {
9064 case INTEGER_TYPE:
9065 return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9066 left,
9067 right);
a6fa6420 9068
c7e4ee3a
CB		 9069 case COMPLEX_TYPE:
9070 {
9071 ffecomGfrt ix;
a6fa6420 9072
c7e4ee3a
CB		 9073 if (TREE_TYPE (tree_type)
9074 == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9075 ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
9076 else
9077 ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
a6fa6420 9078
c7e4ee3a
CB		 9079 left = ffecom_1 (ADDR_EXPR,
9080 build_pointer_type (TREE_TYPE (left)),
9081 left);
9082 left = build_tree_list (NULL_TREE, left);
9083 right = ffecom_1 (ADDR_EXPR,
9084 build_pointer_type (TREE_TYPE (right)),
9085 right);
9086 right = build_tree_list (NULL_TREE, right);
9087 TREE_CHAIN (left) = right;
a6fa6420 9088
c7e4ee3a
CB		 9089 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9090 ffecom_gfrt_kindtype (ix),
9091 ffe_is_f2c_library (),
9092 tree_type,
9093 left,
9094 dest_tree, dest, dest_used,
9095 NULL_TREE, TRUE, hook);
9096 }
9097 break;
5ff904cd 9098
c7e4ee3a
CB		 9099 case RECORD_TYPE:
9100 {
9101 ffecomGfrt ix;
5ff904cd 9102
c7e4ee3a
CB		 9103 if (TREE_TYPE (TYPE_FIELDS (tree_type))
9104 == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9105 ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
9106 else
9107 ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
5ff904cd 9108
c7e4ee3a
CB		 9109 left = ffecom_1 (ADDR_EXPR,
9110 build_pointer_type (TREE_TYPE (left)),
9111 left);
9112 left = build_tree_list (NULL_TREE, left);
9113 right = ffecom_1 (ADDR_EXPR,
9114 build_pointer_type (TREE_TYPE (right)),
9115 right);
9116 right = build_tree_list (NULL_TREE, right);
9117 TREE_CHAIN (left) = right;
a6fa6420 9118
c7e4ee3a
CB		 9119 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9120 ffecom_gfrt_kindtype (ix),
9121 ffe_is_f2c_library (),
9122 tree_type,
9123 left,
9124 dest_tree, dest, dest_used,
9125 NULL_TREE, TRUE, hook);
9126 }
9127 break;
5ff904cd 9128
c7e4ee3a
CB		 9129 default:
9130 return ffecom_2 (RDIV_EXPR, tree_type,
9131 left,
9132 right);
5ff904cd 9133 }
c7e4ee3a 9134}
5ff904cd 9135
c7e4ee3a
CB		 9136#endif
9137/* Build type info for non-dummy variable. */
5ff904cd 9138
c7e4ee3a
CB		 9139#if FFECOM_targetCURRENT == FFECOM_targetGCC
9140static tree
9141ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9142 ffeinfoKindtype kt)
9143{
9144 tree type;
9145 ffebld dl;
9146 ffebld dim;
9147 tree lowt;
9148 tree hight;
5ff904cd 9149
c7e4ee3a
CB		 9150 type = ffecom_tree_type[bt][kt];
9151 if (bt == FFEINFO_basictypeCHARACTER)
9152 {
9153 hight = build_int_2 (ffesymbol_size (s), 0);
9154 TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
5ff904cd 9155
c7e4ee3a
CB		 9156 type
9157 = build_array_type
9158 (type,
9159 build_range_type (ffecom_f2c_ftnlen_type_node,
9160 ffecom_f2c_ftnlen_one_node,
9161 hight));
9162 type = ffecom_check_size_overflow_ (s, type, FALSE);
9163 }
5ff904cd 9164
c7e4ee3a
CB		 9165 for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9166 {
9167 if (type == error_mark_node)
9168 break;
5ff904cd 9169
c7e4ee3a
CB		 9170 dim = ffebld_head (dl);
9171 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
5ff904cd 9172
c7e4ee3a
CB		 9173 if (ffebld_left (dim) == NULL)
9174 lowt = integer_one_node;
9175 else
9176 lowt = ffecom_expr (ffebld_left (dim));
5ff904cd 9177
c7e4ee3a
CB		 9178 if (TREE_CODE (lowt) != INTEGER_CST)
9179 lowt = variable_size (lowt);
5ff904cd 9180
c7e4ee3a
CB		 9181 assert (ffebld_right (dim) != NULL);
9182 hight = ffecom_expr (ffebld_right (dim));
5ff904cd 9183
c7e4ee3a
CB		 9184 if (TREE_CODE (hight) != INTEGER_CST)
9185 hight = variable_size (hight);
5ff904cd 9186
c7e4ee3a
CB		 9187 type = build_array_type (type,
9188 build_range_type (ffecom_integer_type_node,
9189 lowt, hight));
9190 type = ffecom_check_size_overflow_ (s, type, FALSE);
9191 }
5ff904cd 9192
c7e4ee3a 9193 return type;
5ff904cd
JL		 9194}
9195
9196#endif
c7e4ee3a 9197/* Build Namelist type. */
5ff904cd 9198
c7e4ee3a
CB		 9199#if FFECOM_targetCURRENT == FFECOM_targetGCC
9200static tree
9201ffecom_type_namelist_ ()
9202{
9203 static tree type = NULL_TREE;
5ff904cd 9204
c7e4ee3a
CB		 9205 if (type == NULL_TREE)
9206 {
9207 static tree namefield, varsfield, nvarsfield;
9208 tree vardesctype;
5ff904cd 9209
c7e4ee3a 9210 vardesctype = ffecom_type_vardesc_ ();
5ff904cd 9211
c7e4ee3a
CB		 9212 push_obstacks_nochange ();
9213 end_temporary_allocation ();
a6fa6420 9214
c7e4ee3a 9215 type = make_node (RECORD_TYPE);
a6fa6420 9216
c7e4ee3a 9217 vardesctype = build_pointer_type (build_pointer_type (vardesctype));
a6fa6420 9218
c7e4ee3a
CB		 9219 namefield = ffecom_decl_field (type, NULL_TREE, "name",
9220 string_type_node);
9221 varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9222 nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9223 integer_type_node);
a6fa6420 9224
c7e4ee3a
CB		 9225 TYPE_FIELDS (type) = namefield;
9226 layout_type (type);
a6fa6420 9227
c7e4ee3a
CB		 9228 resume_temporary_allocation ();
9229 pop_obstacks ();
5ff904cd 9230 }
5ff904cd 9231
c7e4ee3a
CB		 9232 return type;
9233}
5ff904cd 9234
c7e4ee3a 9235#endif
5ff904cd 9236
c7e4ee3a
CB		 9237/* Make a copy of a type, assuming caller has switched to the permanent
9238 obstacks and that the type is for an aggregate (array) initializer. */
5ff904cd 9239
c7e4ee3a
CB		 9240#if FFECOM_targetCURRENT == FFECOM_targetGCC && 0 /* Not used now. */
9241static tree
9242ffecom_type_permanent_copy_ (tree t)
9243{
9244 tree domain;
9245 tree max;
5ff904cd 9246
c7e4ee3a 9247 assert (TREE_TYPE (t) != NULL_TREE);
5ff904cd 9248
c7e4ee3a 9249 domain = TYPE_DOMAIN (t);
5ff904cd 9250
c7e4ee3a
CB		 9251 assert (TREE_CODE (t) == ARRAY_TYPE);
9252 assert (TREE_PERMANENT (TREE_TYPE (t)));
9253 assert (TREE_PERMANENT (TREE_TYPE (domain)));
9254 assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain)));
5ff904cd 9255
c7e4ee3a
CB		 9256 max = TYPE_MAX_VALUE (domain);
9257 if (!TREE_PERMANENT (max))
9258 {
9259 assert (TREE_CODE (max) == INTEGER_CST);
5ff904cd 9260
c7e4ee3a
CB		 9261 max = build_int_2 (TREE_INT_CST_LOW (max), TREE_INT_CST_HIGH (max));
9262 TREE_TYPE (max) = TREE_TYPE (TYPE_MIN_VALUE (domain));
9263 }
5ff904cd 9264
c7e4ee3a
CB		 9265 return build_array_type (TREE_TYPE (t),
9266 build_range_type (TREE_TYPE (domain),
9267 TYPE_MIN_VALUE (domain),
9268 max));
9269}
9270#endif
5ff904cd 9271
c7e4ee3a 9272/* Build Vardesc type. */
5ff904cd 9273
c7e4ee3a
CB		 9274#if FFECOM_targetCURRENT == FFECOM_targetGCC
9275static tree
9276ffecom_type_vardesc_ ()
9277{
9278 static tree type = NULL_TREE;
9279 static tree namefield, addrfield, dimsfield, typefield;
5ff904cd 9280
c7e4ee3a
CB		 9281 if (type == NULL_TREE)
9282 {
9283 push_obstacks_nochange ();
9284 end_temporary_allocation ();
5ff904cd 9285
c7e4ee3a 9286 type = make_node (RECORD_TYPE);
5ff904cd 9287
c7e4ee3a
CB		 9288 namefield = ffecom_decl_field (type, NULL_TREE, "name",
9289 string_type_node);
9290 addrfield = ffecom_decl_field (type, namefield, "addr",
9291 string_type_node);
9292 dimsfield = ffecom_decl_field (type, addrfield, "dims",
9293 ffecom_f2c_ptr_to_ftnlen_type_node);
9294 typefield = ffecom_decl_field (type, dimsfield, "type",
9295 integer_type_node);
5ff904cd 9296
c7e4ee3a
CB		 9297 TYPE_FIELDS (type) = namefield;
9298 layout_type (type);
9299
9300 resume_temporary_allocation ();
9301 pop_obstacks ();
9302 }
9303
9304 return type;
5ff904cd
JL		 9305}
9306
9307#endif
5ff904cd
JL		 9308
9309#if FFECOM_targetCURRENT == FFECOM_targetGCC
9310static tree
c7e4ee3a 9311ffecom_vardesc_ (ffebld expr)
5ff904cd 9312{
c7e4ee3a 9313 ffesymbol s;
5ff904cd 9314
c7e4ee3a
CB		 9315 assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9316 s = ffebld_symter (expr);
5ff904cd 9317
c7e4ee3a
CB		 9318 if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9319 {
9320 int i;
9321 tree vardesctype = ffecom_type_vardesc_ ();
9322 tree var;
9323 tree nameinit;
9324 tree dimsinit;
9325 tree addrinit;
9326 tree typeinit;
9327 tree field;
9328 tree varinits;
9329 int yes;
9330 static int mynumber = 0;
5ff904cd 9331
c7e4ee3a 9332 yes = suspend_momentary ();
5ff904cd 9333
c7e4ee3a
CB		 9334 var = build_decl (VAR_DECL,
9335 ffecom_get_invented_identifier ("__g77_vardesc_%d",
9336 NULL, mynumber++),
9337 vardesctype);
9338 TREE_STATIC (var) = 1;
9339 DECL_INITIAL (var) = error_mark_node;
5ff904cd 9340
c7e4ee3a 9341 var = start_decl (var, FALSE);
5ff904cd 9342
c7e4ee3a 9343 /* Process inits. */
5ff904cd 9344
c7e4ee3a
CB		 9345 nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9346 + 1,
9347 ffesymbol_text (s));
9348 TREE_TYPE (nameinit)
9349 = build_type_variant
9350 (build_array_type
9351 (char_type_node,
9352 build_range_type (integer_type_node,
9353 integer_one_node,
9354 build_int_2 (i, 0))),
9355 1, 0);
9356 TREE_CONSTANT (nameinit) = 1;
9357 TREE_STATIC (nameinit) = 1;
9358 nameinit = ffecom_1 (ADDR_EXPR,
9359 build_pointer_type (TREE_TYPE (nameinit)),
9360 nameinit);
5ff904cd 9361
c7e4ee3a 9362 addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
5ff904cd 9363
c7e4ee3a 9364 dimsinit = ffecom_vardesc_dims_ (s);
5ff904cd 9365
c7e4ee3a
CB		 9366 if (typeinit == NULL_TREE)
9367 {
9368 ffeinfoBasictype bt = ffesymbol_basictype (s);
9369 ffeinfoKindtype kt = ffesymbol_kindtype (s);
9370 int tc = ffecom_f2c_typecode (bt, kt);
5ff904cd 9371
c7e4ee3a
CB		 9372 assert (tc != -1);
9373 typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9374 }
9375 else
9376 typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
5ff904cd 9377
c7e4ee3a
CB		 9378 varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9379 nameinit);
9380 TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9381 addrinit);
9382 TREE_CHAIN (TREE_CHAIN (varinits))
9383 = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9384 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9385 = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
5ff904cd 9386
c7e4ee3a
CB		 9387 varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9388 TREE_CONSTANT (varinits) = 1;
9389 TREE_STATIC (varinits) = 1;
5ff904cd 9390
c7e4ee3a 9391 finish_decl (var, varinits, FALSE);
5ff904cd 9392
c7e4ee3a 9393 var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
5ff904cd 9394
c7e4ee3a 9395 resume_momentary (yes);
5ff904cd 9396
c7e4ee3a
CB		 9397 ffesymbol_hook (s).vardesc_tree = var;
9398 }
5ff904cd 9399
c7e4ee3a
CB		 9400 return ffesymbol_hook (s).vardesc_tree;
9401}
5ff904cd 9402
c7e4ee3a 9403#endif
5ff904cd 9404#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 9405static tree
9406ffecom_vardesc_array_ (ffesymbol s)
5ff904cd 9407{
c7e4ee3a
CB		 9408 ffebld b;
9409 tree list;
9410 tree item = NULL_TREE;
9411 tree var;
9412 int i;
9413 int yes;
9414 static int mynumber = 0;
5ff904cd 9415
c7e4ee3a
CB		 9416 for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9417 b != NULL;
9418 b = ffebld_trail (b), ++i)
9419 {
9420 tree t;
5ff904cd 9421
c7e4ee3a 9422 t = ffecom_vardesc_ (ffebld_head (b));
5ff904cd 9423
c7e4ee3a
CB		 9424 if (list == NULL_TREE)
9425 list = item = build_tree_list (NULL_TREE, t);
9426 else
5ff904cd 9427 {
c7e4ee3a
CB		 9428 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9429 item = TREE_CHAIN (item);
5ff904cd 9430 }
5ff904cd 9431 }
5ff904cd 9432
c7e4ee3a 9433 yes = suspend_momentary ();
5ff904cd 9434
c7e4ee3a
CB		 9435 item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9436 build_range_type (integer_type_node,
9437 integer_one_node,
9438 build_int_2 (i, 0)));
9439 list = build (CONSTRUCTOR, item, NULL_TREE, list);
9440 TREE_CONSTANT (list) = 1;
9441 TREE_STATIC (list) = 1;
5ff904cd 9442
c7e4ee3a
CB		 9443 var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL,
9444 mynumber++);
9445 var = build_decl (VAR_DECL, var, item);
9446 TREE_STATIC (var) = 1;
9447 DECL_INITIAL (var) = error_mark_node;
9448 var = start_decl (var, FALSE);
9449 finish_decl (var, list, FALSE);
5ff904cd 9450
c7e4ee3a 9451 resume_momentary (yes);
5ff904cd 9452
c7e4ee3a
CB		 9453 return var;
9454}
5ff904cd 9455
c7e4ee3a
CB		 9456#endif
9457#if FFECOM_targetCURRENT == FFECOM_targetGCC
9458static tree
9459ffecom_vardesc_dims_ (ffesymbol s)
9460{
9461 if (ffesymbol_dims (s) == NULL)
9462 return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9463 integer_zero_node);
5ff904cd 9464
c7e4ee3a
CB		 9465 {
9466 ffebld b;
9467 ffebld e;
9468 tree list;
9469 tree backlist;
9470 tree item = NULL_TREE;
9471 tree var;
9472 int yes;
9473 tree numdim;
9474 tree numelem;
9475 tree baseoff = NULL_TREE;
9476 static int mynumber = 0;
9477
9478 numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9479 TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9480
9481 numelem = ffecom_expr (ffesymbol_arraysize (s));
9482 TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9483
9484 list = NULL_TREE;
9485 backlist = NULL_TREE;
9486 for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9487 b != NULL;
9488 b = ffebld_trail (b), e = ffebld_trail (e))
5ff904cd 9489 {
c7e4ee3a
CB		 9490 tree t;
9491 tree low;
9492 tree back;
5ff904cd 9493
c7e4ee3a
CB		 9494 if (ffebld_trail (b) == NULL)
9495 t = NULL_TREE;
9496 else
5ff904cd 9497 {
c7e4ee3a
CB		 9498 t = convert (ffecom_f2c_ftnlen_type_node,
9499 ffecom_expr (ffebld_head (e)));
5ff904cd 9500
c7e4ee3a
CB		 9501 if (list == NULL_TREE)
9502 list = item = build_tree_list (NULL_TREE, t);
9503 else
9504 {
9505 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9506 item = TREE_CHAIN (item);
9507 }
9508 }
5ff904cd 9509
c7e4ee3a
CB		 9510 if (ffebld_left (ffebld_head (b)) == NULL)
9511 low = ffecom_integer_one_node;
9512 else
9513 low = ffecom_expr (ffebld_left (ffebld_head (b)));
9514 low = convert (ffecom_f2c_ftnlen_type_node, low);
5ff904cd 9515
c7e4ee3a
CB		 9516 back = build_tree_list (low, t);
9517 TREE_CHAIN (back) = backlist;
9518 backlist = back;
9519 }
5ff904cd 9520
c7e4ee3a
CB		 9521 for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9522 {
9523 if (TREE_VALUE (item) == NULL_TREE)
9524 baseoff = TREE_PURPOSE (item);
9525 else
9526 baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9527 TREE_PURPOSE (item),
9528 ffecom_2 (MULT_EXPR,
9529 ffecom_f2c_ftnlen_type_node,
9530 TREE_VALUE (item),
9531 baseoff));
5ff904cd
JL		 9532 }
9533
c7e4ee3a 9534 /* backlist now dead, along with all TREE_PURPOSEs on it. */
5ff904cd 9535
c7e4ee3a
CB		 9536 baseoff = build_tree_list (NULL_TREE, baseoff);
9537 TREE_CHAIN (baseoff) = list;
5ff904cd 9538
c7e4ee3a
CB		 9539 numelem = build_tree_list (NULL_TREE, numelem);
9540 TREE_CHAIN (numelem) = baseoff;
5ff904cd 9541
c7e4ee3a
CB		 9542 numdim = build_tree_list (NULL_TREE, numdim);
9543 TREE_CHAIN (numdim) = numelem;
5ff904cd 9544
c7e4ee3a 9545 yes = suspend_momentary ();
5ff904cd 9546
c7e4ee3a
CB		 9547 item = build_array_type (ffecom_f2c_ftnlen_type_node,
9548 build_range_type (integer_type_node,
9549 integer_zero_node,
9550 build_int_2
9551 ((int) ffesymbol_rank (s)
9552 + 2, 0)));
9553 list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9554 TREE_CONSTANT (list) = 1;
9555 TREE_STATIC (list) = 1;
9556
9557 var = ffecom_get_invented_identifier ("__g77_dims_%d", NULL,
9558 mynumber++);
9559 var = build_decl (VAR_DECL, var, item);
9560 TREE_STATIC (var) = 1;
9561 DECL_INITIAL (var) = error_mark_node;
9562 var = start_decl (var, FALSE);
9563 finish_decl (var, list, FALSE);
9564
9565 var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9566
9567 resume_momentary (yes);
9568
9569 return var;
9570 }
5ff904cd 9571}
c7e4ee3a 9572
5ff904cd 9573#endif
c7e4ee3a
CB		 9574/* Essentially does a "fold (build1 (code, type, node))" while checking
9575 for certain housekeeping things.
5ff904cd 9576
c7e4ee3a
CB		 9577 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9578 ffecom_1_fn instead. */
5ff904cd
JL		 9579
9580#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 9581tree
9582ffecom_1 (enum tree_code code, tree type, tree node)
5ff904cd 9583{
c7e4ee3a
CB		 9584 tree item;
9585
9586 if ((node == error_mark_node)
9587 || (type == error_mark_node))
5ff904cd
JL		 9588 return error_mark_node;
9589
c7e4ee3a 9590 if (code == ADDR_EXPR)
5ff904cd 9591 {
c7e4ee3a
CB		 9592 if (!mark_addressable (node))
9593 assert ("can't mark_addressable this node!" == NULL);
9594 }
5ff904cd 9595
c7e4ee3a
CB		 9596 switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9597 {
9598 tree realtype;
5ff904cd 9599
c7e4ee3a
CB		 9600 case REALPART_EXPR:
9601 item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
5ff904cd
JL		 9602 break;
9603
c7e4ee3a
CB		 9604 case IMAGPART_EXPR:
9605 item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9606 break;
5ff904cd 9607
5ff904cd 9608
c7e4ee3a
CB		 9609 case NEGATE_EXPR:
9610 if (TREE_CODE (type) != RECORD_TYPE)
9611 {
9612 item = build1 (code, type, node);
9613 break;
9614 }
9615 node = ffecom_stabilize_aggregate_ (node);
9616 realtype = TREE_TYPE (TYPE_FIELDS (type));
9617 item =
9618 ffecom_2 (COMPLEX_EXPR, type,
9619 ffecom_1 (NEGATE_EXPR, realtype,
9620 ffecom_1 (REALPART_EXPR, realtype,
9621 node)),
9622 ffecom_1 (NEGATE_EXPR, realtype,
9623 ffecom_1 (IMAGPART_EXPR, realtype,
9624 node)));
5ff904cd
JL		 9625 break;
9626
9627 default:
c7e4ee3a
CB		 9628 item = build1 (code, type, node);
9629 break;
5ff904cd 9630 }
5ff904cd 9631
c7e4ee3a
CB		 9632 if (TREE_SIDE_EFFECTS (node))
9633 TREE_SIDE_EFFECTS (item) = 1;
9634 if ((code == ADDR_EXPR) && staticp (node))
9635 TREE_CONSTANT (item) = 1;
9636 return fold (item);
9637}
5ff904cd 9638#endif
5ff904cd 9639
c7e4ee3a
CB		 9640/* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9641 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9642 does not set TREE_ADDRESSABLE (because calling an inline
9643 function does not mean the function needs to be separately
9644 compiled). */
5ff904cd
JL		 9645
9646#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 9647tree
9648ffecom_1_fn (tree node)
5ff904cd 9649{
c7e4ee3a 9650 tree item;
5ff904cd 9651 tree type;
5ff904cd 9652
c7e4ee3a
CB		 9653 if (node == error_mark_node)
9654 return error_mark_node;
5ff904cd 9655
c7e4ee3a
CB		 9656 type = build_type_variant (TREE_TYPE (node),
9657 TREE_READONLY (node),
9658 TREE_THIS_VOLATILE (node));
9659 item = build1 (ADDR_EXPR,
9660 build_pointer_type (type), node);
9661 if (TREE_SIDE_EFFECTS (node))
9662 TREE_SIDE_EFFECTS (item) = 1;
9663 if (staticp (node))
9664 TREE_CONSTANT (item) = 1;
9665 return fold (item);
5ff904cd 9666}
5ff904cd 9667#endif
c7e4ee3a
CB		 9668
9669/* Essentially does a "fold (build (code, type, node1, node2))" while
9670 checking for certain housekeeping things. */
5ff904cd
JL		 9671
9672#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 9673tree
9674ffecom_2 (enum tree_code code, tree type, tree node1,
9675 tree node2)
5ff904cd 9676{
c7e4ee3a 9677 tree item;
5ff904cd 9678
c7e4ee3a
CB		 9679 if ((node1 == error_mark_node)
9680 || (node2 == error_mark_node)
9681 || (type == error_mark_node))
9682 return error_mark_node;
9683
9684 switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
5ff904cd 9685 {
c7e4ee3a 9686 tree a, b, c, d, realtype;
5ff904cd 9687
c7e4ee3a
CB		 9688 case CONJ_EXPR:
9689 assert ("no CONJ_EXPR support yet" == NULL);
9690 return error_mark_node;
5ff904cd 9691
c7e4ee3a
CB		 9692 case COMPLEX_EXPR:
9693 item = build_tree_list (TYPE_FIELDS (type), node1);
9694 TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9695 item = build (CONSTRUCTOR, type, NULL_TREE, item);
9696 break;
5ff904cd 9697
c7e4ee3a
CB		 9698 case PLUS_EXPR:
9699 if (TREE_CODE (type) != RECORD_TYPE)
9700 {
9701 item = build (code, type, node1, node2);
9702 break;
9703 }
9704 node1 = ffecom_stabilize_aggregate_ (node1);
9705 node2 = ffecom_stabilize_aggregate_ (node2);
9706 realtype = TREE_TYPE (TYPE_FIELDS (type));
9707 item =
9708 ffecom_2 (COMPLEX_EXPR, type,
9709 ffecom_2 (PLUS_EXPR, realtype,
9710 ffecom_1 (REALPART_EXPR, realtype,
9711 node1),
9712 ffecom_1 (REALPART_EXPR, realtype,
9713 node2)),
9714 ffecom_2 (PLUS_EXPR, realtype,
9715 ffecom_1 (IMAGPART_EXPR, realtype,
9716 node1),
9717 ffecom_1 (IMAGPART_EXPR, realtype,
9718 node2)));
9719 break;
5ff904cd 9720
c7e4ee3a
CB		 9721 case MINUS_EXPR:
9722 if (TREE_CODE (type) != RECORD_TYPE)
9723 {
9724 item = build (code, type, node1, node2);
9725 break;
9726 }
9727 node1 = ffecom_stabilize_aggregate_ (node1);
9728 node2 = ffecom_stabilize_aggregate_ (node2);
9729 realtype = TREE_TYPE (TYPE_FIELDS (type));
9730 item =
9731 ffecom_2 (COMPLEX_EXPR, type,
9732 ffecom_2 (MINUS_EXPR, realtype,
9733 ffecom_1 (REALPART_EXPR, realtype,
9734 node1),
9735 ffecom_1 (REALPART_EXPR, realtype,
9736 node2)),
9737 ffecom_2 (MINUS_EXPR, realtype,
9738 ffecom_1 (IMAGPART_EXPR, realtype,
9739 node1),
9740 ffecom_1 (IMAGPART_EXPR, realtype,
9741 node2)));
9742 break;
5ff904cd 9743
c7e4ee3a
CB		 9744 case MULT_EXPR:
9745 if (TREE_CODE (type) != RECORD_TYPE)
9746 {
9747 item = build (code, type, node1, node2);
9748 break;
9749 }
9750 node1 = ffecom_stabilize_aggregate_ (node1);
9751 node2 = ffecom_stabilize_aggregate_ (node2);
9752 realtype = TREE_TYPE (TYPE_FIELDS (type));
9753 a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9754 node1));
9755 b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9756 node1));
9757 c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9758 node2));
9759 d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9760 node2));
9761 item =
9762 ffecom_2 (COMPLEX_EXPR, type,
9763 ffecom_2 (MINUS_EXPR, realtype,
9764 ffecom_2 (MULT_EXPR, realtype,
9765 a,
9766 c),
9767 ffecom_2 (MULT_EXPR, realtype,
9768 b,
9769 d)),
9770 ffecom_2 (PLUS_EXPR, realtype,
9771 ffecom_2 (MULT_EXPR, realtype,
9772 a,
9773 d),
9774 ffecom_2 (MULT_EXPR, realtype,
9775 c,
9776 b)));
9777 break;
5ff904cd 9778
c7e4ee3a
CB		 9779 case EQ_EXPR:
9780 if ((TREE_CODE (node1) != RECORD_TYPE)
9781 && (TREE_CODE (node2) != RECORD_TYPE))
9782 {
9783 item = build (code, type, node1, node2);
9784 break;
9785 }
9786 assert (TREE_CODE (node1) == RECORD_TYPE);
9787 assert (TREE_CODE (node2) == RECORD_TYPE);
9788 node1 = ffecom_stabilize_aggregate_ (node1);
9789 node2 = ffecom_stabilize_aggregate_ (node2);
9790 realtype = TREE_TYPE (TYPE_FIELDS (type));
9791 item =
9792 ffecom_2 (TRUTH_ANDIF_EXPR, type,
9793 ffecom_2 (code, type,
9794 ffecom_1 (REALPART_EXPR, realtype,
9795 node1),
9796 ffecom_1 (REALPART_EXPR, realtype,
9797 node2)),
9798 ffecom_2 (code, type,
9799 ffecom_1 (IMAGPART_EXPR, realtype,
9800 node1),
9801 ffecom_1 (IMAGPART_EXPR, realtype,
9802 node2)));
9803 break;
9804
9805 case NE_EXPR:
9806 if ((TREE_CODE (node1) != RECORD_TYPE)
9807 && (TREE_CODE (node2) != RECORD_TYPE))
9808 {
9809 item = build (code, type, node1, node2);
9810 break;
9811 }
9812 assert (TREE_CODE (node1) == RECORD_TYPE);
9813 assert (TREE_CODE (node2) == RECORD_TYPE);
9814 node1 = ffecom_stabilize_aggregate_ (node1);
9815 node2 = ffecom_stabilize_aggregate_ (node2);
9816 realtype = TREE_TYPE (TYPE_FIELDS (type));
9817 item =
9818 ffecom_2 (TRUTH_ORIF_EXPR, type,
9819 ffecom_2 (code, type,
9820 ffecom_1 (REALPART_EXPR, realtype,
9821 node1),
9822 ffecom_1 (REALPART_EXPR, realtype,
9823 node2)),
9824 ffecom_2 (code, type,
9825 ffecom_1 (IMAGPART_EXPR, realtype,
9826 node1),
9827 ffecom_1 (IMAGPART_EXPR, realtype,
9828 node2)));
9829 break;
5ff904cd 9830
c7e4ee3a
CB		 9831 default:
9832 item = build (code, type, node1, node2);
9833 break;
5ff904cd
JL		 9834 }
9835
c7e4ee3a
CB		 9836 if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9837 TREE_SIDE_EFFECTS (item) = 1;
9838 return fold (item);
5ff904cd
JL		 9839}
9840
9841#endif
c7e4ee3a 9842/* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
5ff904cd 9843
c7e4ee3a
CB		 9844 ffesymbol s; // the ENTRY point itself
9845 if (ffecom_2pass_advise_entrypoint(s))
9846 // the ENTRY point has been accepted
5ff904cd 9847
c7e4ee3a
CB		 9848 Does whatever compiler needs to do when it learns about the entrypoint,
9849 like determine the return type of the master function, count the
9850 number of entrypoints, etc. Returns FALSE if the return type is
9851 not compatible with the return type(s) of other entrypoint(s).
5ff904cd 9852
c7e4ee3a
CB		 9853 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9854 later (after _finish_progunit) be called with the same entrypoint(s)
9855 as passed to this fn for which TRUE was returned.
5ff904cd 9856
c7e4ee3a
CB		 9857 03-Jan-92 JCB 2.0
9858 Return FALSE if the return type conflicts with previous entrypoints. */
5ff904cd
JL		 9859
9860#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 9861bool
9862ffecom_2pass_advise_entrypoint (ffesymbol entry)
5ff904cd 9863{
c7e4ee3a
CB		 9864 ffebld list; /* opITEM. */
9865 ffebld mlist; /* opITEM. */
9866 ffebld plist; /* opITEM. */
9867 ffebld arg; /* ffebld_head(opITEM). */
9868 ffebld item; /* opITEM. */
9869 ffesymbol s; /* ffebld_symter(arg). */
9870 ffeinfoBasictype bt = ffesymbol_basictype (entry);
9871 ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9872 ffetargetCharacterSize size = ffesymbol_size (entry);
9873 bool ok;
5ff904cd 9874
c7e4ee3a
CB		 9875 if (ffecom_num_entrypoints_ == 0)
9876 { /* First entrypoint, make list of main
9877 arglist's dummies. */
9878 assert (ffecom_primary_entry_ != NULL);
5ff904cd 9879
c7e4ee3a
CB		 9880 ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9881 ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9882 ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
5ff904cd 9883
c7e4ee3a
CB		 9884 for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9885 list != NULL;
9886 list = ffebld_trail (list))
9887 {
9888 arg = ffebld_head (list);
9889 if (ffebld_op (arg) != FFEBLD_opSYMTER)
9890 continue; /* Alternate return or some such thing. */
9891 item = ffebld_new_item (arg, NULL);
9892 if (plist == NULL)
9893 ffecom_master_arglist_ = item;
9894 else
9895 ffebld_set_trail (plist, item);
9896 plist = item;
9897 }
5ff904cd
JL		 9898 }
9899
c7e4ee3a
CB		 9900 /* If necessary, scan entry arglist for alternate returns. Do this scan
9901 apparently redundantly (it's done below to UNIONize the arglists) so
9902 that we don't complain about RETURN 1 if an offending ENTRY is the only
9903 one with an alternate return. */
5ff904cd 9904
c7e4ee3a 9905 if (!ffecom_is_altreturning_)
5ff904cd 9906 {
c7e4ee3a
CB		 9907 for (list = ffesymbol_dummyargs (entry);
9908 list != NULL;
9909 list = ffebld_trail (list))
9910 {
9911 arg = ffebld_head (list);
9912 if (ffebld_op (arg) == FFEBLD_opSTAR)
9913 {
9914 ffecom_is_altreturning_ = TRUE;
9915 break;
9916 }
9917 }
9918 }
5ff904cd 9919
c7e4ee3a 9920 /* Now check type compatibility. */
5ff904cd 9921
c7e4ee3a
CB		 9922 switch (ffecom_master_bt_)
9923 {
9924 case FFEINFO_basictypeNONE:
9925 ok = (bt != FFEINFO_basictypeCHARACTER);
9926 break;
5ff904cd 9927
c7e4ee3a
CB		 9928 case FFEINFO_basictypeCHARACTER:
9929 ok
9930 = (bt == FFEINFO_basictypeCHARACTER)
9931 && (kt == ffecom_master_kt_)
9932 && (size == ffecom_master_size_);
9933 break;
5ff904cd 9934
c7e4ee3a
CB		 9935 case FFEINFO_basictypeANY:
9936 return FALSE; /* Just don't bother. */
5ff904cd 9937
c7e4ee3a
CB		 9938 default:
9939 if (bt == FFEINFO_basictypeCHARACTER)
5ff904cd 9940 {
c7e4ee3a
CB		 9941 ok = FALSE;
9942 break;
5ff904cd 9943 }
c7e4ee3a
CB		 9944 ok = TRUE;
9945 if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
9946 {
9947 ffecom_master_bt_ = FFEINFO_basictypeNONE;
9948 ffecom_master_kt_ = FFEINFO_kindtypeNONE;
9949 }
9950 break;
9951 }
5ff904cd 9952
c7e4ee3a
CB		 9953 if (!ok)
9954 {
9955 ffebad_start (FFEBAD_ENTRY_CONFLICTS);
9956 ffest_ffebad_here_current_stmt (0);
9957 ffebad_finish ();
9958 return FALSE; /* Can't handle entrypoint. */
9959 }
5ff904cd 9960
c7e4ee3a 9961 /* Entrypoint type compatible with previous types. */
5ff904cd 9962
c7e4ee3a 9963 ++ffecom_num_entrypoints_;
5ff904cd 9964
c7e4ee3a
CB		 9965 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9966
9967 for (list = ffesymbol_dummyargs (entry);
9968 list != NULL;
9969 list = ffebld_trail (list))
9970 {
9971 arg = ffebld_head (list);
9972 if (ffebld_op (arg) != FFEBLD_opSYMTER)
9973 continue; /* Alternate return or some such thing. */
9974 s = ffebld_symter (arg);
9975 for (plist = NULL, mlist = ffecom_master_arglist_;
9976 mlist != NULL;
9977 plist = mlist, mlist = ffebld_trail (mlist))
9978 { /* plist points to previous item for easy
9979 appending of arg. */
9980 if (ffebld_symter (ffebld_head (mlist)) == s)
9981 break; /* Already have this arg in the master list. */
9982 }
9983 if (mlist != NULL)
9984 continue; /* Already have this arg in the master list. */
5ff904cd 9985
c7e4ee3a 9986 /* Append this arg to the master list. */
5ff904cd 9987
c7e4ee3a
CB		 9988 item = ffebld_new_item (arg, NULL);
9989 if (plist == NULL)
9990 ffecom_master_arglist_ = item;
9991 else
9992 ffebld_set_trail (plist, item);
5ff904cd
JL		 9993 }
9994
c7e4ee3a 9995 return TRUE;
5ff904cd
JL		 9996}
9997
9998#endif
c7e4ee3a
CB		 9999/* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10000
10001 ffesymbol s; // the ENTRY point itself
10002 ffecom_2pass_do_entrypoint(s);
10003
10004 Does whatever compiler needs to do to make the entrypoint actually
10005 happen. Must be called for each entrypoint after
10006 ffecom_finish_progunit is called. */
10007
5ff904cd 10008#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 10009void
10010ffecom_2pass_do_entrypoint (ffesymbol entry)
5ff904cd 10011{
c7e4ee3a
CB		 10012 static int mfn_num = 0;
10013 static int ent_num;
5ff904cd 10014
c7e4ee3a
CB		 10015 if (mfn_num != ffecom_num_fns_)
10016 { /* First entrypoint for this program unit. */
10017 ent_num = 1;
10018 mfn_num = ffecom_num_fns_;
10019 ffecom_do_entry_ (ffecom_primary_entry_, 0);
10020 }
10021 else
10022 ++ent_num;
5ff904cd 10023
c7e4ee3a 10024 --ffecom_num_entrypoints_;
5ff904cd 10025
c7e4ee3a
CB		 10026 ffecom_do_entry_ (entry, ent_num);
10027}
5ff904cd 10028
c7e4ee3a 10029#endif
5ff904cd 10030
c7e4ee3a
CB		 10031/* Essentially does a "fold (build (code, type, node1, node2))" while
10032 checking for certain housekeeping things. Always sets
10033 TREE_SIDE_EFFECTS. */
5ff904cd 10034
c7e4ee3a
CB		 10035#if FFECOM_targetCURRENT == FFECOM_targetGCC
10036tree
10037ffecom_2s (enum tree_code code, tree type, tree node1,
10038 tree node2)
10039{
10040 tree item;
5ff904cd 10041
c7e4ee3a
CB		 10042 if ((node1 == error_mark_node)
10043 || (node2 == error_mark_node)
10044 || (type == error_mark_node))
10045 return error_mark_node;
5ff904cd 10046
c7e4ee3a
CB		 10047 item = build (code, type, node1, node2);
10048 TREE_SIDE_EFFECTS (item) = 1;
10049 return fold (item);
5ff904cd
JL		 10050}
10051
10052#endif
c7e4ee3a
CB		 10053/* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10054 checking for certain housekeeping things. */
10055
5ff904cd 10056#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 10057tree
10058ffecom_3 (enum tree_code code, tree type, tree node1,
10059 tree node2, tree node3)
5ff904cd 10060{
c7e4ee3a 10061 tree item;
5ff904cd 10062
c7e4ee3a
CB		 10063 if ((node1 == error_mark_node)
10064 || (node2 == error_mark_node)
10065 || (node3 == error_mark_node)
10066 || (type == error_mark_node))
10067 return error_mark_node;
5ff904cd 10068
c7e4ee3a
CB		 10069 item = build (code, type, node1, node2, node3);
10070 if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10071 || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10072 TREE_SIDE_EFFECTS (item) = 1;
10073 return fold (item);
10074}
5ff904cd 10075
c7e4ee3a
CB		 10076#endif
10077/* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10078 checking for certain housekeeping things. Always sets
10079 TREE_SIDE_EFFECTS. */
5ff904cd 10080
c7e4ee3a
CB		 10081#if FFECOM_targetCURRENT == FFECOM_targetGCC
10082tree
10083ffecom_3s (enum tree_code code, tree type, tree node1,
10084 tree node2, tree node3)
10085{
10086 tree item;
5ff904cd 10087
c7e4ee3a
CB		 10088 if ((node1 == error_mark_node)
10089 || (node2 == error_mark_node)
10090 || (node3 == error_mark_node)
10091 || (type == error_mark_node))
10092 return error_mark_node;
5ff904cd 10093
c7e4ee3a
CB		 10094 item = build (code, type, node1, node2, node3);
10095 TREE_SIDE_EFFECTS (item) = 1;
10096 return fold (item);
10097}
5ff904cd 10098
c7e4ee3a 10099#endif
5ff904cd 10100
c7e4ee3a 10101/* ffecom_arg_expr -- Transform argument expr into gcc tree
5ff904cd 10102
c7e4ee3a 10103 See use by ffecom_list_expr.
5ff904cd 10104
c7e4ee3a
CB		 10105 If expression is NULL, returns an integer zero tree. If it is not
10106 a CHARACTER expression, returns whatever ffecom_expr
10107 returns and sets the length return value to NULL_TREE. Otherwise
10108 generates code to evaluate the character expression, returns the proper
10109 pointer to the result, but does NOT set the length return value to a tree
10110 that specifies the length of the result. (In other words, the length
10111 variable is always set to NULL_TREE, because a length is never passed.)
5ff904cd 10112
c7e4ee3a
CB		 10113 21-Dec-91 JCB 1.1
10114 Don't set returned length, since nobody needs it (yet; someday if
10115 we allow CHARACTER*(*) dummies to statement functions, we'll need
10116 it). */
5ff904cd 10117
c7e4ee3a
CB		 10118#if FFECOM_targetCURRENT == FFECOM_targetGCC
10119tree
10120ffecom_arg_expr (ffebld expr, tree *length)
10121{
10122 tree ign;
5ff904cd 10123
c7e4ee3a 10124 *length = NULL_TREE;
5ff904cd 10125
c7e4ee3a
CB		 10126 if (expr == NULL)
10127 return integer_zero_node;
5ff904cd 10128
c7e4ee3a
CB		 10129 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10130 return ffecom_expr (expr);
5ff904cd 10131
c7e4ee3a
CB		 10132 return ffecom_arg_ptr_to_expr (expr, &ign);
10133}
10134
10135#endif
10136/* Transform expression into constant argument-pointer-to-expression tree.
10137
10138 If the expression can be transformed into a argument-pointer-to-expression
10139 tree that is constant, that is done, and the tree returned. Else
10140 NULL_TREE is returned.
5ff904cd 10141
c7e4ee3a
CB		 10142 That way, a caller can attempt to provide compile-time initialization
10143 of a variable and, if that fails, *then* choose to start a new block
10144 and resort to using temporaries, as appropriate. */
5ff904cd 10145
c7e4ee3a
CB		 10146tree
10147ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10148{
10149 if (! expr)
10150 return integer_zero_node;
5ff904cd 10151
c7e4ee3a
CB		 10152 if (ffebld_op (expr) == FFEBLD_opANY)
10153 {
10154 if (length)
10155 *length = error_mark_node;
10156 return error_mark_node;
10157 }
10158
10159 if (ffebld_arity (expr) == 0
10160 && (ffebld_op (expr) != FFEBLD_opSYMTER
10161 || ffebld_where (expr) == FFEINFO_whereCOMMON
10162 || ffebld_where (expr) == FFEINFO_whereGLOBAL
10163 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10164 {
10165 tree t;
10166
10167 t = ffecom_arg_ptr_to_expr (expr, length);
10168 assert (TREE_CONSTANT (t));
10169 assert (! length || TREE_CONSTANT (*length));
10170 return t;
10171 }
10172
10173 if (length
10174 && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10175 *length = build_int_2 (ffebld_size (expr), 0);
10176 else if (length)
10177 *length = NULL_TREE;
10178 return NULL_TREE;
5ff904cd
JL		 10179}
10180
c7e4ee3a 10181/* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
5ff904cd 10182
c7e4ee3a
CB		 10183 See use by ffecom_list_ptr_to_expr.
10184
10185 If expression is NULL, returns an integer zero tree. If it is not
10186 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10187 returns and sets the length return value to NULL_TREE. Otherwise
10188 generates code to evaluate the character expression, returns the proper
10189 pointer to the result, AND sets the length return value to a tree that
10190 specifies the length of the result.
10191
10192 If the length argument is NULL, this is a slightly special
10193 case of building a FORMAT expression, that is, an expression that
10194 will be used at run time without regard to length. For the current
10195 implementation, which uses the libf2c library, this means it is nice
10196 to append a null byte to the end of the expression, where feasible,
10197 to make sure any diagnostic about the FORMAT string terminates at
10198 some useful point.
10199
10200 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10201 length argument. This might even be seen as a feature, if a null
10202 byte can always be appended. */
5ff904cd
JL		 10203
10204#if FFECOM_targetCURRENT == FFECOM_targetGCC
10205tree
c7e4ee3a 10206ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
5ff904cd
JL		 10207{
10208 tree item;
c7e4ee3a
CB		 10209 tree ign_length;
10210 ffecomConcatList_ catlist;
5ff904cd 10211
c7e4ee3a
CB		 10212 if (length != NULL)
10213 *length = NULL_TREE;
5ff904cd 10214
c7e4ee3a
CB		 10215 if (expr == NULL)
10216 return integer_zero_node;
5ff904cd 10217
c7e4ee3a 10218 switch (ffebld_op (expr))
5ff904cd 10219 {
c7e4ee3a
CB		 10220 case FFEBLD_opPERCENT_VAL:
10221 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10222 return ffecom_expr (ffebld_left (expr));
10223 {
10224 tree temp_exp;
10225 tree temp_length;
5ff904cd 10226
c7e4ee3a
CB		 10227 temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10228 if (temp_exp == error_mark_node)
10229 return error_mark_node;
5ff904cd 10230
c7e4ee3a
CB		 10231 return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10232 temp_exp);
10233 }
5ff904cd 10234
c7e4ee3a
CB		 10235 case FFEBLD_opPERCENT_REF:
10236 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10237 return ffecom_ptr_to_expr (ffebld_left (expr));
10238 if (length != NULL)
10239 {
10240 ign_length = NULL_TREE;
10241 length = &ign_length;
10242 }
10243 expr = ffebld_left (expr);
10244 break;
5ff904cd 10245
c7e4ee3a
CB		 10246 case FFEBLD_opPERCENT_DESCR:
10247 switch (ffeinfo_basictype (ffebld_info (expr)))
5ff904cd 10248 {
c7e4ee3a
CB		 10249#ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10250 case FFEINFO_basictypeHOLLERITH:
10251#endif
10252 case FFEINFO_basictypeCHARACTER:
10253 break; /* Passed by descriptor anyway. */
10254
10255 default:
10256 item = ffecom_ptr_to_expr (expr);
10257 if (item != error_mark_node)
10258 *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
5ff904cd
JL		 10259 break;
10260 }
5ff904cd
JL		 10261 break;
10262
10263 default:
5ff904cd
JL		 10264 break;
10265 }
10266
c7e4ee3a
CB		 10267#ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10268 if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10269 && (length != NULL))
10270 { /* Pass Hollerith by descriptor. */
10271 ffetargetHollerith h;
10272
10273 assert (ffebld_op (expr) == FFEBLD_opCONTER);
10274 h = ffebld_cu_val_hollerith (ffebld_constant_union
10275 (ffebld_conter (expr)));
10276 *length
10277 = build_int_2 (h.length, 0);
10278 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10279 }
10280#endif
10281
10282 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10283 return ffecom_ptr_to_expr (expr);
10284
10285 assert (ffeinfo_kindtype (ffebld_info (expr))
10286 == FFEINFO_kindtypeCHARACTER1);
10287
10288 catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10289 switch (ffecom_concat_list_count_ (catlist))
10290 {
10291 case 0: /* Shouldn't happen, but in case it does... */
10292 if (length != NULL)
10293 {
10294 *length = ffecom_f2c_ftnlen_zero_node;
10295 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10296 }
10297 ffecom_concat_list_kill_ (catlist);
10298 return null_pointer_node;
10299
10300 case 1: /* The (fairly) easy case. */
10301 if (length == NULL)
10302 ffecom_char_args_with_null_ (&item, &ign_length,
10303 ffecom_concat_list_expr_ (catlist, 0));
10304 else
10305 ffecom_char_args_ (&item, length,
10306 ffecom_concat_list_expr_ (catlist, 0));
10307 ffecom_concat_list_kill_ (catlist);
10308 assert (item != NULL_TREE);
10309 return item;
10310
10311 default: /* Must actually concatenate things. */
10312 break;
10313 }
10314
10315 {
10316 int count = ffecom_concat_list_count_ (catlist);
10317 int i;
10318 tree lengths;
10319 tree items;
10320 tree length_array;
10321 tree item_array;
10322 tree citem;
10323 tree clength;
10324 tree temporary;
10325 tree num;
10326 tree known_length;
10327 ffetargetCharacterSize sz;
10328
10329 sz = ffecom_concat_list_maxlen_ (catlist);
10330 /* ~~Kludge! */
10331 assert (sz != FFETARGET_charactersizeNONE);
10332
10333#ifdef HOHO
10334 length_array
10335 = lengths
10336 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10337 FFETARGET_charactersizeNONE, count, TRUE);
10338 item_array
10339 = items
10340 = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10341 FFETARGET_charactersizeNONE, count, TRUE);
10342 temporary = ffecom_push_tempvar (char_type_node,
10343 sz, -1, TRUE);
10344#else
10345 {
10346 tree hook;
10347
10348 hook = ffebld_nonter_hook (expr);
10349 assert (hook);
10350 assert (TREE_CODE (hook) == TREE_VEC);
10351 assert (TREE_VEC_LENGTH (hook) == 3);
10352 length_array = lengths = TREE_VEC_ELT (hook, 0);
10353 item_array = items = TREE_VEC_ELT (hook, 1);
10354 temporary = TREE_VEC_ELT (hook, 2);
10355 }
10356#endif
10357
10358 known_length = ffecom_f2c_ftnlen_zero_node;
10359
10360 for (i = 0; i < count; ++i)
10361 {
10362 if ((i == count)
10363 && (length == NULL))
10364 ffecom_char_args_with_null_ (&citem, &clength,
10365 ffecom_concat_list_expr_ (catlist, i));
10366 else
10367 ffecom_char_args_ (&citem, &clength,
10368 ffecom_concat_list_expr_ (catlist, i));
10369 if ((citem == error_mark_node)
10370 || (clength == error_mark_node))
10371 {
10372 ffecom_concat_list_kill_ (catlist);
10373 *length = error_mark_node;
10374 return error_mark_node;
10375 }
10376
10377 items
10378 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10379 ffecom_modify (void_type_node,
10380 ffecom_2 (ARRAY_REF,
10381 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10382 item_array,
10383 build_int_2 (i, 0)),
10384 citem),
10385 items);
10386 clength = ffecom_save_tree (clength);
10387 if (length != NULL)
10388 known_length
10389 = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10390 known_length,
10391 clength);
10392 lengths
10393 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10394 ffecom_modify (void_type_node,
10395 ffecom_2 (ARRAY_REF,
10396 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10397 length_array,
10398 build_int_2 (i, 0)),
10399 clength),
10400 lengths);
10401 }
10402
10403 temporary = ffecom_1 (ADDR_EXPR,
10404 build_pointer_type (TREE_TYPE (temporary)),
10405 temporary);
10406
10407 item = build_tree_list (NULL_TREE, temporary);
10408 TREE_CHAIN (item)
10409 = build_tree_list (NULL_TREE,
10410 ffecom_1 (ADDR_EXPR,
10411 build_pointer_type (TREE_TYPE (items)),
10412 items));
10413 TREE_CHAIN (TREE_CHAIN (item))
10414 = build_tree_list (NULL_TREE,
10415 ffecom_1 (ADDR_EXPR,
10416 build_pointer_type (TREE_TYPE (lengths)),
10417 lengths));
10418 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10419 = build_tree_list
10420 (NULL_TREE,
10421 ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10422 convert (ffecom_f2c_ftnlen_type_node,
10423 build_int_2 (count, 0))));
10424 num = build_int_2 (sz, 0);
10425 TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10426 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10427 = build_tree_list (NULL_TREE, num);
10428
10429 item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
5ff904cd 10430 TREE_SIDE_EFFECTS (item) = 1;
c7e4ee3a
CB		 10431 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10432 item,
10433 temporary);
10434
10435 if (length != NULL)
10436 *length = known_length;
10437 }
10438
10439 ffecom_concat_list_kill_ (catlist);
10440 assert (item != NULL_TREE);
10441 return item;
5ff904cd 10442}
c7e4ee3a 10443
5ff904cd 10444#endif
c7e4ee3a 10445/* Generate call to run-time function.
5ff904cd 10446
c7e4ee3a
CB		 10447 The first arg is the GNU Fortran Run-Time function index, the second
10448 arg is the list of arguments to pass to it. Returned is the expression
10449 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10450 result (which may be void). */
5ff904cd
JL		 10451
10452#if FFECOM_targetCURRENT == FFECOM_targetGCC
10453tree
c7e4ee3a 10454ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
5ff904cd 10455{
c7e4ee3a
CB		 10456 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10457 ffecom_gfrt_kindtype (ix),
10458 ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10459 NULL_TREE, args, NULL_TREE, NULL,
10460 NULL, NULL_TREE, TRUE, hook);
5ff904cd
JL		 10461}
10462#endif
10463
c7e4ee3a 10464/* Transform constant-union to tree. */
5ff904cd
JL		 10465
10466#if FFECOM_targetCURRENT == FFECOM_targetGCC
10467tree
c7e4ee3a
CB		 10468ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10469 ffeinfoKindtype kt, tree tree_type)
5ff904cd
JL		 10470{
10471 tree item;
10472
c7e4ee3a 10473 switch (bt)
5ff904cd 10474 {
c7e4ee3a
CB		 10475 case FFEINFO_basictypeINTEGER:
10476 {
10477 int val;
5ff904cd 10478
c7e4ee3a
CB		 10479 switch (kt)
10480 {
10481#if FFETARGET_okINTEGER1
10482 case FFEINFO_kindtypeINTEGER1:
10483 val = ffebld_cu_val_integer1 (*cu);
10484 break;
10485#endif
5ff904cd 10486
c7e4ee3a
CB		 10487#if FFETARGET_okINTEGER2
10488 case FFEINFO_kindtypeINTEGER2:
10489 val = ffebld_cu_val_integer2 (*cu);
10490 break;
10491#endif
5ff904cd 10492
c7e4ee3a
CB		 10493#if FFETARGET_okINTEGER3
10494 case FFEINFO_kindtypeINTEGER3:
10495 val = ffebld_cu_val_integer3 (*cu);
10496 break;
10497#endif
5ff904cd 10498
c7e4ee3a
CB		 10499#if FFETARGET_okINTEGER4
10500 case FFEINFO_kindtypeINTEGER4:
10501 val = ffebld_cu_val_integer4 (*cu);
10502 break;
10503#endif
5ff904cd 10504
c7e4ee3a
CB		 10505 default:
10506 assert ("bad INTEGER constant kind type" == NULL);
10507 /* Fall through. */
10508 case FFEINFO_kindtypeANY:
10509 return error_mark_node;
10510 }
10511 item = build_int_2 (val, (val < 0) ? -1 : 0);
10512 TREE_TYPE (item) = tree_type;
10513 }
5ff904cd 10514 break;
5ff904cd 10515
c7e4ee3a
CB		 10516 case FFEINFO_basictypeLOGICAL:
10517 {
10518 int val;
5ff904cd 10519
c7e4ee3a
CB		 10520 switch (kt)
10521 {
10522#if FFETARGET_okLOGICAL1
10523 case FFEINFO_kindtypeLOGICAL1:
10524 val = ffebld_cu_val_logical1 (*cu);
10525 break;
5ff904cd 10526#endif
5ff904cd 10527
c7e4ee3a
CB		 10528#if FFETARGET_okLOGICAL2
10529 case FFEINFO_kindtypeLOGICAL2:
10530 val = ffebld_cu_val_logical2 (*cu);
10531 break;
10532#endif
5ff904cd 10533
c7e4ee3a
CB		 10534#if FFETARGET_okLOGICAL3
10535 case FFEINFO_kindtypeLOGICAL3:
10536 val = ffebld_cu_val_logical3 (*cu);
10537 break;
10538#endif
5ff904cd 10539
c7e4ee3a
CB		 10540#if FFETARGET_okLOGICAL4
10541 case FFEINFO_kindtypeLOGICAL4:
10542 val = ffebld_cu_val_logical4 (*cu);
10543 break;
10544#endif
5ff904cd 10545
c7e4ee3a
CB		 10546 default:
10547 assert ("bad LOGICAL constant kind type" == NULL);
10548 /* Fall through. */
10549 case FFEINFO_kindtypeANY:
10550 return error_mark_node;
10551 }
10552 item = build_int_2 (val, (val < 0) ? -1 : 0);
10553 TREE_TYPE (item) = tree_type;
10554 }
10555 break;
5ff904cd 10556
c7e4ee3a
CB		 10557 case FFEINFO_basictypeREAL:
10558 {
10559 REAL_VALUE_TYPE val;
5ff904cd 10560
c7e4ee3a
CB		 10561 switch (kt)
10562 {
10563#if FFETARGET_okREAL1
10564 case FFEINFO_kindtypeREAL1:
10565 val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10566 break;
10567#endif
5ff904cd 10568
c7e4ee3a
CB		 10569#if FFETARGET_okREAL2
10570 case FFEINFO_kindtypeREAL2:
10571 val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10572 break;
10573#endif
5ff904cd 10574
c7e4ee3a
CB		 10575#if FFETARGET_okREAL3
10576 case FFEINFO_kindtypeREAL3:
10577 val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10578 break;
10579#endif
5ff904cd 10580
c7e4ee3a
CB		 10581#if FFETARGET_okREAL4
10582 case FFEINFO_kindtypeREAL4:
10583 val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10584 break;
10585#endif
5ff904cd 10586
c7e4ee3a
CB		 10587 default:
10588 assert ("bad REAL constant kind type" == NULL);
10589 /* Fall through. */
10590 case FFEINFO_kindtypeANY:
10591 return error_mark_node;
10592 }
10593 item = build_real (tree_type, val);
10594 }
5ff904cd
JL		 10595 break;
10596
c7e4ee3a
CB		 10597 case FFEINFO_basictypeCOMPLEX:
10598 {
10599 REAL_VALUE_TYPE real;
10600 REAL_VALUE_TYPE imag;
10601 tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
5ff904cd 10602
c7e4ee3a
CB		 10603 switch (kt)
10604 {
10605#if FFETARGET_okCOMPLEX1
10606 case FFEINFO_kindtypeREAL1:
10607 real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10608 imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10609 break;
10610#endif
5ff904cd 10611
c7e4ee3a
CB		 10612#if FFETARGET_okCOMPLEX2
10613 case FFEINFO_kindtypeREAL2:
10614 real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10615 imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10616 break;
10617#endif
5ff904cd 10618
c7e4ee3a
CB		 10619#if FFETARGET_okCOMPLEX3
10620 case FFEINFO_kindtypeREAL3:
10621 real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10622 imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10623 break;
10624#endif
5ff904cd 10625
c7e4ee3a
CB		 10626#if FFETARGET_okCOMPLEX4
10627 case FFEINFO_kindtypeREAL4:
10628 real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10629 imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10630 break;
10631#endif
5ff904cd 10632
c7e4ee3a
CB		 10633 default:
10634 assert ("bad REAL constant kind type" == NULL);
10635 /* Fall through. */
10636 case FFEINFO_kindtypeANY:
10637 return error_mark_node;
10638 }
10639 item = ffecom_build_complex_constant_ (tree_type,
10640 build_real (el_type, real),
10641 build_real (el_type, imag));
10642 }
10643 break;
5ff904cd 10644
c7e4ee3a
CB		 10645 case FFEINFO_basictypeCHARACTER:
10646 { /* Happens only in DATA and similar contexts. */
10647 ffetargetCharacter1 val;
5ff904cd 10648
c7e4ee3a
CB		 10649 switch (kt)
10650 {
10651#if FFETARGET_okCHARACTER1
10652 case FFEINFO_kindtypeLOGICAL1:
10653 val = ffebld_cu_val_character1 (*cu);
10654 break;
10655#endif
10656
10657 default:
10658 assert ("bad CHARACTER constant kind type" == NULL);
10659 /* Fall through. */
10660 case FFEINFO_kindtypeANY:
10661 return error_mark_node;
10662 }
10663 item = build_string (ffetarget_length_character1 (val),
10664 ffetarget_text_character1 (val));
10665 TREE_TYPE (item)
10666 = build_type_variant (build_array_type (char_type_node,
10667 build_range_type
10668 (integer_type_node,
10669 integer_one_node,
10670 build_int_2
10671 (ffetarget_length_character1
10672 (val), 0))),
10673 1, 0);
10674 }
10675 break;
5ff904cd 10676
c7e4ee3a
CB		 10677 case FFEINFO_basictypeHOLLERITH:
10678 {
10679 ffetargetHollerith h;
5ff904cd 10680
c7e4ee3a 10681 h = ffebld_cu_val_hollerith (*cu);
5ff904cd 10682
c7e4ee3a
CB		 10683 /* If not at least as wide as default INTEGER, widen it. */
10684 if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10685 item = build_string (h.length, h.text);
10686 else
10687 {
10688 char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
5ff904cd 10689
c7e4ee3a
CB		 10690 memcpy (str, h.text, h.length);
10691 memset (&str[h.length], ' ',
10692 FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10693 - h.length);
10694 item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10695 str);
10696 }
10697 TREE_TYPE (item)
10698 = build_type_variant (build_array_type (char_type_node,
10699 build_range_type
10700 (integer_type_node,
10701 integer_one_node,
10702 build_int_2
10703 (h.length, 0))),
10704 1, 0);
10705 }
10706 break;
5ff904cd 10707
c7e4ee3a
CB		 10708 case FFEINFO_basictypeTYPELESS:
10709 {
10710 ffetargetInteger1 ival;
10711 ffetargetTypeless tless;
10712 ffebad error;
5ff904cd 10713
c7e4ee3a
CB		 10714 tless = ffebld_cu_val_typeless (*cu);
10715 error = ffetarget_convert_integer1_typeless (&ival, tless);
10716 assert (error == FFEBAD);
5ff904cd 10717
c7e4ee3a
CB		 10718 item = build_int_2 ((int) ival, 0);
10719 }
10720 break;
5ff904cd 10721
c7e4ee3a
CB		 10722 default:
10723 assert ("not yet on constant type" == NULL);
10724 /* Fall through. */
10725 case FFEINFO_basictypeANY:
10726 return error_mark_node;
5ff904cd 10727 }
5ff904cd 10728
c7e4ee3a 10729 TREE_CONSTANT (item) = 1;
5ff904cd 10730
c7e4ee3a 10731 return item;
5ff904cd
JL		 10732}
10733
10734#endif
10735
c7e4ee3a
CB		 10736/* Transform expression into constant tree.
10737
10738 If the expression can be transformed into a tree that is constant,
10739 that is done, and the tree returned. Else NULL_TREE is returned.
10740
10741 That way, a caller can attempt to provide compile-time initialization
10742 of a variable and, if that fails, *then* choose to start a new block
10743 and resort to using temporaries, as appropriate. */
5ff904cd 10744
5ff904cd 10745tree
c7e4ee3a 10746ffecom_const_expr (ffebld expr)
5ff904cd 10747{
c7e4ee3a
CB		 10748 if (! expr)
10749 return integer_zero_node;
5ff904cd 10750
c7e4ee3a 10751 if (ffebld_op (expr) == FFEBLD_opANY)
5ff904cd
JL		 10752 return error_mark_node;
10753
c7e4ee3a
CB		 10754 if (ffebld_arity (expr) == 0
10755 && (ffebld_op (expr) != FFEBLD_opSYMTER
10756#if NEWCOMMON
10757 /* ~~Enable once common/equivalence is handled properly? */
10758 || ffebld_where (expr) == FFEINFO_whereCOMMON
5ff904cd 10759#endif
c7e4ee3a
CB		 10760 || ffebld_where (expr) == FFEINFO_whereGLOBAL
10761 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10762 {
10763 tree t;
5ff904cd 10764
c7e4ee3a
CB		 10765 t = ffecom_expr (expr);
10766 assert (TREE_CONSTANT (t));
10767 return t;
10768 }
5ff904cd 10769
c7e4ee3a 10770 return NULL_TREE;
5ff904cd
JL		 10771}
10772
c7e4ee3a 10773/* Handy way to make a field in a struct/union. */
5ff904cd
JL		 10774
10775#if FFECOM_targetCURRENT == FFECOM_targetGCC
10776tree
c7e4ee3a
CB		 10777ffecom_decl_field (tree context, tree prevfield,
10778 const char *name, tree type)
5ff904cd 10779{
c7e4ee3a 10780 tree field;
5ff904cd 10781
c7e4ee3a
CB		 10782 field = build_decl (FIELD_DECL, get_identifier (name), type);
10783 DECL_CONTEXT (field) = context;
10784 DECL_FRAME_SIZE (field) = 0;
10785 if (prevfield != NULL_TREE)
10786 TREE_CHAIN (prevfield) = field;
5ff904cd 10787
c7e4ee3a 10788 return field;
5ff904cd
JL		 10789}
10790
10791#endif
5ff904cd 10792
c7e4ee3a
CB		 10793void
10794ffecom_close_include (FILE *f)
10795{
10796#if FFECOM_GCC_INCLUDE
10797 ffecom_close_include_ (f);
10798#endif
10799}
5ff904cd 10800
c7e4ee3a
CB		 10801int
10802ffecom_decode_include_option (char *spec)
10803{
10804#if FFECOM_GCC_INCLUDE
10805 return ffecom_decode_include_option_ (spec);
10806#else
10807 return 1;
10808#endif
10809}
5ff904cd 10810
c7e4ee3a 10811/* End a compound statement (block). */
5ff904cd
JL		 10812
10813#if FFECOM_targetCURRENT == FFECOM_targetGCC
10814tree
c7e4ee3a 10815ffecom_end_compstmt (void)
5ff904cd 10816{
c7e4ee3a
CB		 10817 return bison_rule_compstmt_ ();
10818}
10819#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
5ff904cd 10820
c7e4ee3a 10821/* ffecom_end_transition -- Perform end transition on all symbols
5ff904cd 10822
c7e4ee3a 10823 ffecom_end_transition();
5ff904cd 10824
c7e4ee3a 10825 Calls ffecom_sym_end_transition for each global and local symbol. */
5ff904cd 10826
c7e4ee3a
CB		 10827void
10828ffecom_end_transition ()
10829{
10830#if FFECOM_targetCURRENT == FFECOM_targetGCC
10831 ffebld item;
5ff904cd 10832#endif
5ff904cd 10833
c7e4ee3a
CB		 10834 if (ffe_is_ffedebug ())
10835 fprintf (dmpout, "; end_stmt_transition\n");
86fc7a6c 10836
c7e4ee3a
CB		 10837#if FFECOM_targetCURRENT == FFECOM_targetGCC
10838 ffecom_list_blockdata_ = NULL;
10839 ffecom_list_common_ = NULL;
10840#endif
86fc7a6c 10841
c7e4ee3a
CB		 10842 ffesymbol_drive (ffecom_sym_end_transition);
10843 if (ffe_is_ffedebug ())
10844 {
10845 ffestorag_report ();
10846#if FFECOM_targetCURRENT == FFECOM_targetFFE
10847 ffesymbol_report_all ();
10848#endif
10849 }
5ff904cd
JL		 10850
10851#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 10852 ffecom_start_progunit_ ();
10853
10854 for (item = ffecom_list_blockdata_;
10855 item != NULL;
10856 item = ffebld_trail (item))
10857 {
10858 ffebld callee;
10859 ffesymbol s;
10860 tree dt;
10861 tree t;
10862 tree var;
10863 int yes;
10864 static int number = 0;
10865
10866 callee = ffebld_head (item);
10867 s = ffebld_symter (callee);
10868 t = ffesymbol_hook (s).decl_tree;
10869 if (t == NULL_TREE)
10870 {
10871 s = ffecom_sym_transform_ (s);
10872 t = ffesymbol_hook (s).decl_tree;
10873 }
5ff904cd 10874
c7e4ee3a 10875 yes = suspend_momentary ();
5ff904cd 10876
c7e4ee3a 10877 dt = build_pointer_type (TREE_TYPE (t));
5ff904cd 10878
c7e4ee3a
CB		 10879 var = build_decl (VAR_DECL,
10880 ffecom_get_invented_identifier ("__g77_forceload_%d",
10881 NULL, number++),
10882 dt);
10883 DECL_EXTERNAL (var) = 0;
10884 TREE_STATIC (var) = 1;
10885 TREE_PUBLIC (var) = 0;
10886 DECL_INITIAL (var) = error_mark_node;
10887 TREE_USED (var) = 1;
5ff904cd 10888
c7e4ee3a 10889 var = start_decl (var, FALSE);
702edf1d 10890
c7e4ee3a 10891 t = ffecom_1 (ADDR_EXPR, dt, t);
5ff904cd 10892
c7e4ee3a 10893 finish_decl (var, t, FALSE);
5ff904cd 10894
c7e4ee3a
CB		 10895 resume_momentary (yes);
10896 }
10897
10898 /* This handles any COMMON areas that weren't referenced but have, for
10899 example, important initial data. */
10900
10901 for (item = ffecom_list_common_;
10902 item != NULL;
10903 item = ffebld_trail (item))
10904 ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10905
10906 ffecom_list_common_ = NULL;
5ff904cd 10907#endif
c7e4ee3a 10908}
5ff904cd 10909
c7e4ee3a 10910/* ffecom_exec_transition -- Perform exec transition on all symbols
5ff904cd 10911
c7e4ee3a 10912 ffecom_exec_transition();
5ff904cd 10913
c7e4ee3a
CB		 10914 Calls ffecom_sym_exec_transition for each global and local symbol.
10915 Make sure error updating not inhibited. */
5ff904cd 10916
c7e4ee3a
CB		 10917void
10918ffecom_exec_transition ()
10919{
10920 bool inhibited;
5ff904cd 10921
c7e4ee3a
CB		 10922 if (ffe_is_ffedebug ())
10923 fprintf (dmpout, "; exec_stmt_transition\n");
5ff904cd 10924
c7e4ee3a
CB		 10925 inhibited = ffebad_inhibit ();
10926 ffebad_set_inhibit (FALSE);
5ff904cd 10927
c7e4ee3a
CB		 10928 ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10929 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
10930 if (ffe_is_ffedebug ())
5ff904cd 10931 {
c7e4ee3a
CB		 10932 ffestorag_report ();
10933#if FFECOM_targetCURRENT == FFECOM_targetFFE
10934 ffesymbol_report_all ();
10935#endif
10936 }
5ff904cd 10937
c7e4ee3a
CB		 10938 if (inhibited)
10939 ffebad_set_inhibit (TRUE);
10940}
5ff904cd 10941
c7e4ee3a 10942/* Handle assignment statement.
5ff904cd 10943
c7e4ee3a
CB		 10944 Convert dest and source using ffecom_expr, then join them
10945 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
5ff904cd 10946
c7e4ee3a
CB		 10947#if FFECOM_targetCURRENT == FFECOM_targetGCC
10948void
10949ffecom_expand_let_stmt (ffebld dest, ffebld source)
10950{
10951 tree dest_tree;
10952 tree dest_length;
10953 tree source_tree;
10954 tree expr_tree;
5ff904cd 10955
c7e4ee3a
CB		 10956 if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
10957 {
10958 bool dest_used;
5ff904cd 10959
c7e4ee3a
CB		 10960 /* This attempts to replicate the test below, but must not be
10961 true when the test below is false. (Always err on the side
10962 of creating unused temporaries, to avoid ICEs.) */
10963 if (ffebld_op (dest) != FFEBLD_opSYMTER
10964 || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
10965 && (TREE_CODE (dest_tree) != VAR_DECL
10966 || TREE_ADDRESSABLE (dest_tree))))
10967 {
10968 ffecom_prepare_expr_ (source, dest);
10969 dest_used = TRUE;
10970 }
10971 else
10972 {
10973 ffecom_prepare_expr_ (source, NULL);
10974 dest_used = FALSE;
10975 }
5ff904cd 10976
c7e4ee3a 10977 ffecom_prepare_expr_w (NULL_TREE, dest);
5ff904cd 10978
c7e4ee3a 10979 ffecom_prepare_end ();
5ff904cd 10980
c7e4ee3a
CB		 10981 dest_tree = ffecom_expr_w (NULL_TREE, dest);
10982 if (dest_tree == error_mark_node)
10983 return;
5ff904cd 10984
c7e4ee3a
CB		 10985 if ((TREE_CODE (dest_tree) != VAR_DECL)
10986 || TREE_ADDRESSABLE (dest_tree))
10987 source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
10988 FALSE, FALSE);
10989 else
10990 {
10991 assert (! dest_used);
10992 dest_used = FALSE;
10993 source_tree = ffecom_expr (source);
10994 }
10995 if (source_tree == error_mark_node)
10996 return;
5ff904cd 10997
c7e4ee3a
CB		 10998 if (dest_used)
10999 expr_tree = source_tree;
11000 else
11001 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11002 dest_tree,
11003 source_tree);
5ff904cd 11004
c7e4ee3a
CB		 11005 expand_expr_stmt (expr_tree);
11006 return;
11007 }
5ff904cd 11008
c7e4ee3a
CB		 11009 ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11010 ffecom_prepare_expr_w (NULL_TREE, dest);
11011
11012 ffecom_prepare_end ();
11013
11014 ffecom_char_args_ (&dest_tree, &dest_length, dest);
11015 ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11016 source);
5ff904cd
JL		 11017}
11018
11019#endif
c7e4ee3a 11020/* ffecom_expr -- Transform expr into gcc tree
5ff904cd 11021
c7e4ee3a
CB		 11022 tree t;
11023 ffebld expr; // FFE expression.
11024 tree = ffecom_expr(expr);
5ff904cd 11025
c7e4ee3a
CB		 11026 Recursive descent on expr while making corresponding tree nodes and
11027 attaching type info and such. */
5ff904cd
JL		 11028
11029#if FFECOM_targetCURRENT == FFECOM_targetGCC
11030tree
c7e4ee3a 11031ffecom_expr (ffebld expr)
5ff904cd 11032{
c7e4ee3a 11033 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
5ff904cd 11034}
c7e4ee3a 11035
5ff904cd 11036#endif
c7e4ee3a 11037/* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
5ff904cd 11038
c7e4ee3a
CB		 11039#if FFECOM_targetCURRENT == FFECOM_targetGCC
11040tree
11041ffecom_expr_assign (ffebld expr)
11042{
11043 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11044}
5ff904cd 11045
c7e4ee3a
CB		 11046#endif
11047/* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
5ff904cd
JL		 11048
11049#if FFECOM_targetCURRENT == FFECOM_targetGCC
11050tree
c7e4ee3a 11051ffecom_expr_assign_w (ffebld expr)
5ff904cd 11052{
c7e4ee3a
CB		 11053 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11054}
5ff904cd 11055
5ff904cd 11056#endif
c7e4ee3a
CB		 11057/* Transform expr for use as into read/write tree and stabilize the
11058 reference. Not for use on CHARACTER expressions.
5ff904cd 11059
c7e4ee3a
CB		 11060 Recursive descent on expr while making corresponding tree nodes and
11061 attaching type info and such. */
5ff904cd 11062
c7e4ee3a
CB		 11063#if FFECOM_targetCURRENT == FFECOM_targetGCC
11064tree
11065ffecom_expr_rw (tree type, ffebld expr)
11066{
11067 assert (expr != NULL);
11068 /* Different target types not yet supported. */
11069 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11070
11071 return stabilize_reference (ffecom_expr (expr));
11072}
5ff904cd 11073
5ff904cd 11074#endif
c7e4ee3a
CB		 11075/* Transform expr for use as into write tree and stabilize the
11076 reference. Not for use on CHARACTER expressions.
5ff904cd 11077
c7e4ee3a
CB		 11078 Recursive descent on expr while making corresponding tree nodes and
11079 attaching type info and such. */
5ff904cd 11080
c7e4ee3a
CB		 11081#if FFECOM_targetCURRENT == FFECOM_targetGCC
11082tree
11083ffecom_expr_w (tree type, ffebld expr)
11084{
11085 assert (expr != NULL);
11086 /* Different target types not yet supported. */
11087 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11088
11089 return stabilize_reference (ffecom_expr (expr));
11090}
5ff904cd 11091
5ff904cd 11092#endif
c7e4ee3a
CB		 11093/* Do global stuff. */
11094
11095#if FFECOM_targetCURRENT == FFECOM_targetGCC
11096void
11097ffecom_finish_compile ()
11098{
11099 assert (ffecom_outer_function_decl_ == NULL_TREE);
11100 assert (current_function_decl == NULL_TREE);
11101
11102 ffeglobal_drive (ffecom_finish_global_);
11103}
5ff904cd 11104
5ff904cd 11105#endif
c7e4ee3a
CB		 11106/* Public entry point for front end to access finish_decl. */
11107
11108#if FFECOM_targetCURRENT == FFECOM_targetGCC
11109void
11110ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11111{
11112 assert (!is_top_level);
11113 finish_decl (decl, init, FALSE);
11114}
5ff904cd 11115
5ff904cd 11116#endif
c7e4ee3a
CB		 11117/* Finish a program unit. */
11118
11119#if FFECOM_targetCURRENT == FFECOM_targetGCC
11120void
11121ffecom_finish_progunit ()
11122{
11123 ffecom_end_compstmt ();
11124
11125 ffecom_previous_function_decl_ = current_function_decl;
11126 ffecom_which_entrypoint_decl_ = NULL_TREE;
11127
11128 finish_function (0);
11129}
5ff904cd 11130
5ff904cd 11131#endif
c7e4ee3a
CB		 11132/* Wrapper for get_identifier. pattern is sprintf-like, assumed to contain
11133 one %s if text is not NULL, assumed to contain one %d if number is
11134 not -1. If both are assumed, the %s is assumed to precede the %d. */
11135
11136#if FFECOM_targetCURRENT == FFECOM_targetGCC
11137tree
11138ffecom_get_invented_identifier (const char *pattern, const char *text,
11139 int number)
11140{
11141 tree decl;
11142 char *nam;
11143 mallocSize lenlen;
11144 char space[66];
11145
11146 lenlen = 0;
11147 if (text)
11148 lenlen += strlen (text);
11149 if (number != -1)
11150 lenlen += 20;
11151 if (text || number != -1)
11152 {
11153 lenlen += strlen (pattern);
11154 if (lenlen > ARRAY_SIZE (space))
11155 nam = malloc_new_ks (malloc_pool_image (), pattern, lenlen);
11156 else
11157 nam = &space[0];
11158 }
11159 else
11160 {
11161 lenlen = 0;
11162 nam = (char *) pattern;
11163 }
11164
11165 if (text == NULL)
11166 {
11167 if (number != -1)
11168 sprintf (&nam[0], pattern, number);
11169 }
11170 else
11171 {
11172 if (number == -1)
11173 sprintf (&nam[0], pattern, text);
11174 else
11175 sprintf (&nam[0], pattern, text, number);
11176 }
11177
11178 decl = get_identifier (nam);
11179
11180 if (lenlen > ARRAY_SIZE (space))
11181 malloc_kill_ks (malloc_pool_image (), nam, lenlen);
11182
11183 IDENTIFIER_INVENTED (decl) = 1;
11184
11185 return decl;
11186}
11187
11188ffeinfoBasictype
11189ffecom_gfrt_basictype (ffecomGfrt gfrt)
11190{
11191 assert (gfrt < FFECOM_gfrt);
11192
11193 switch (ffecom_gfrt_type_[gfrt])
11194 {
11195 case FFECOM_rttypeVOID_:
11196 case FFECOM_rttypeVOIDSTAR_:
11197 return FFEINFO_basictypeNONE;
11198
11199 case FFECOM_rttypeFTNINT_:
11200 return FFEINFO_basictypeINTEGER;
11201
11202 case FFECOM_rttypeINTEGER_:
11203 return FFEINFO_basictypeINTEGER;
11204
11205 case FFECOM_rttypeLONGINT_:
11206 return FFEINFO_basictypeINTEGER;
11207
11208 case FFECOM_rttypeLOGICAL_:
11209 return FFEINFO_basictypeLOGICAL;
11210
11211 case FFECOM_rttypeREAL_F2C_:
11212 case FFECOM_rttypeREAL_GNU_:
11213 return FFEINFO_basictypeREAL;
11214
11215 case FFECOM_rttypeCOMPLEX_F2C_:
11216 case FFECOM_rttypeCOMPLEX_GNU_:
11217 return FFEINFO_basictypeCOMPLEX;
11218
11219 case FFECOM_rttypeDOUBLE_:
11220 case FFECOM_rttypeDOUBLEREAL_:
11221 return FFEINFO_basictypeREAL;
11222
11223 case FFECOM_rttypeDBLCMPLX_F2C_:
11224 case FFECOM_rttypeDBLCMPLX_GNU_:
11225 return FFEINFO_basictypeCOMPLEX;
11226
11227 case FFECOM_rttypeCHARACTER_:
11228 return FFEINFO_basictypeCHARACTER;
11229
11230 default:
11231 return FFEINFO_basictypeANY;
11232 }
11233}
11234
11235ffeinfoKindtype
11236ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11237{
11238 assert (gfrt < FFECOM_gfrt);
11239
11240 switch (ffecom_gfrt_type_[gfrt])
11241 {
11242 case FFECOM_rttypeVOID_:
11243 case FFECOM_rttypeVOIDSTAR_:
11244 return FFEINFO_kindtypeNONE;
5ff904cd 11245
c7e4ee3a
CB		 11246 case FFECOM_rttypeFTNINT_:
11247 return FFEINFO_kindtypeINTEGER1;
5ff904cd 11248
c7e4ee3a
CB		 11249 case FFECOM_rttypeINTEGER_:
11250 return FFEINFO_kindtypeINTEGER1;
5ff904cd 11251
c7e4ee3a
CB		 11252 case FFECOM_rttypeLONGINT_:
11253 return FFEINFO_kindtypeINTEGER4;
5ff904cd 11254
c7e4ee3a
CB		 11255 case FFECOM_rttypeLOGICAL_:
11256 return FFEINFO_kindtypeLOGICAL1;
5ff904cd 11257
c7e4ee3a
CB		 11258 case FFECOM_rttypeREAL_F2C_:
11259 case FFECOM_rttypeREAL_GNU_:
11260 return FFEINFO_kindtypeREAL1;
5ff904cd 11261
c7e4ee3a
CB		 11262 case FFECOM_rttypeCOMPLEX_F2C_:
11263 case FFECOM_rttypeCOMPLEX_GNU_:
11264 return FFEINFO_kindtypeREAL1;
5ff904cd 11265
c7e4ee3a
CB		 11266 case FFECOM_rttypeDOUBLE_:
11267 case FFECOM_rttypeDOUBLEREAL_:
11268 return FFEINFO_kindtypeREAL2;
5ff904cd 11269
c7e4ee3a
CB		 11270 case FFECOM_rttypeDBLCMPLX_F2C_:
11271 case FFECOM_rttypeDBLCMPLX_GNU_:
11272 return FFEINFO_kindtypeREAL2;
5ff904cd 11273
c7e4ee3a
CB		 11274 case FFECOM_rttypeCHARACTER_:
11275 return FFEINFO_kindtypeCHARACTER1;
5ff904cd 11276
c7e4ee3a
CB		 11277 default:
11278 return FFEINFO_kindtypeANY;
11279 }
11280}
5ff904cd 11281
c7e4ee3a
CB		 11282void
11283ffecom_init_0 ()
11284{
11285 tree endlink;
11286 int i;
11287 int j;
11288 tree t;
11289 tree field;
11290 ffetype type;
11291 ffetype base_type;
5ff904cd 11292
c7e4ee3a
CB		 11293 /* This block of code comes from the now-obsolete cktyps.c. It checks
11294 whether the compiler environment is buggy in known ways, some of which
11295 would, if not explicitly checked here, result in subtle bugs in g77. */
5ff904cd 11296
c7e4ee3a
CB		 11297 if (ffe_is_do_internal_checks ())
11298 {
11299 static char names[][12]
11300 =
11301 {"bar", "bletch", "foo", "foobar"};
11302 char *name;
11303 unsigned long ul;
11304 double fl;
5ff904cd 11305
c7e4ee3a
CB		 11306 name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11307 (int (*)()) strcmp);
11308 if (name != (char *) &names[2])
11309 {
11310 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11311 == NULL);
11312 abort ();
11313 }
5ff904cd 11314
c7e4ee3a
CB		 11315 ul = strtoul ("123456789", NULL, 10);
11316 if (ul != 123456789L)
11317 {
11318 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11319 in proj.h" == NULL);
11320 abort ();
11321 }
5ff904cd 11322
c7e4ee3a
CB		 11323 fl = atof ("56.789");
11324 if ((fl < 56.788) || (fl > 56.79))
11325 {
11326 assert ("atof not type double, fix your #include <stdio.h>"
11327 == NULL);
11328 abort ();
11329 }
11330 }
5ff904cd 11331
c7e4ee3a
CB		 11332 /* Set the sizetype before we do anything else. This _should_ be the
11333 first type we create. */
5ff904cd 11334
c7e4ee3a
CB		 11335 t = make_unsigned_type (POINTER_SIZE);
11336 assert (t == sizetype);
5ff904cd 11337
c7e4ee3a
CB		 11338#if FFECOM_GCC_INCLUDE
11339 ffecom_initialize_char_syntax_ ();
11340#endif
5ff904cd 11341
c7e4ee3a
CB		 11342 ffecom_outer_function_decl_ = NULL_TREE;
11343 current_function_decl = NULL_TREE;
11344 named_labels = NULL_TREE;
11345 current_binding_level = NULL_BINDING_LEVEL;
11346 free_binding_level = NULL_BINDING_LEVEL;
11347 /* Make the binding_level structure for global names. */
11348 pushlevel (0);
11349 global_binding_level = current_binding_level;
11350 current_binding_level->prep_state = 2;
5ff904cd 11351
c7e4ee3a 11352 /* Define `int' and `char' first so that dbx will output them first. */
5ff904cd 11353
c7e4ee3a
CB		 11354 integer_type_node = make_signed_type (INT_TYPE_SIZE);
11355 pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11356 integer_type_node));
5ff904cd 11357
c7e4ee3a
CB		 11358 char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11359 pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11360 char_type_node));
5ff904cd 11361
c7e4ee3a
CB		 11362 long_integer_type_node = make_signed_type (LONG_TYPE_SIZE);
11363 pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11364 long_integer_type_node));
5ff904cd 11365
c7e4ee3a
CB		 11366 unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE);
11367 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11368 unsigned_type_node));
5ff904cd 11369
c7e4ee3a
CB		 11370 long_unsigned_type_node = make_unsigned_type (LONG_TYPE_SIZE);
11371 pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11372 long_unsigned_type_node));
5ff904cd 11373
c7e4ee3a
CB		 11374 long_long_integer_type_node = make_signed_type (LONG_LONG_TYPE_SIZE);
11375 pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11376 long_long_integer_type_node));
5ff904cd 11377
c7e4ee3a
CB		 11378 long_long_unsigned_type_node = make_unsigned_type (LONG_LONG_TYPE_SIZE);
11379 pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11380 long_long_unsigned_type_node));
5ff904cd 11381
c7e4ee3a
CB		 11382 error_mark_node = make_node (ERROR_MARK);
11383 TREE_TYPE (error_mark_node) = error_mark_node;
5ff904cd 11384
c7e4ee3a
CB		 11385 short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE);
11386 pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11387 short_integer_type_node));
5ff904cd 11388
c7e4ee3a
CB		 11389 short_unsigned_type_node = make_unsigned_type (SHORT_TYPE_SIZE);
11390 pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11391 short_unsigned_type_node));
5ff904cd 11392
c7e4ee3a
CB		 11393 /* Define both `signed char' and `unsigned char'. */
11394 signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE);
11395 pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11396 signed_char_type_node));
5ff904cd 11397
c7e4ee3a
CB		 11398 unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11399 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11400 unsigned_char_type_node));
5ff904cd 11401
c7e4ee3a
CB		 11402 float_type_node = make_node (REAL_TYPE);
11403 TYPE_PRECISION (float_type_node) = FLOAT_TYPE_SIZE;
11404 layout_type (float_type_node);
11405 pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11406 float_type_node));
5ff904cd 11407
c7e4ee3a
CB		 11408 double_type_node = make_node (REAL_TYPE);
11409 TYPE_PRECISION (double_type_node) = DOUBLE_TYPE_SIZE;
11410 layout_type (double_type_node);
11411 pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11412 double_type_node));
5ff904cd 11413
c7e4ee3a
CB		 11414 long_double_type_node = make_node (REAL_TYPE);
11415 TYPE_PRECISION (long_double_type_node) = LONG_DOUBLE_TYPE_SIZE;
11416 layout_type (long_double_type_node);
11417 pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11418 long_double_type_node));
5ff904cd 11419
c7e4ee3a
CB		 11420 complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11421 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11422 complex_integer_type_node));
5ff904cd 11423
c7e4ee3a
CB		 11424 complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11425 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11426 complex_float_type_node));
5ff904cd 11427
c7e4ee3a
CB		 11428 complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11429 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11430 complex_double_type_node));
5ff904cd 11431
c7e4ee3a
CB		 11432 complex_long_double_type_node = ffecom_make_complex_type_ (long_double_type_node);
11433 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11434 complex_long_double_type_node));
5ff904cd 11435
c7e4ee3a
CB		 11436 integer_zero_node = build_int_2 (0, 0);
11437 TREE_TYPE (integer_zero_node) = integer_type_node;
11438 integer_one_node = build_int_2 (1, 0);
11439 TREE_TYPE (integer_one_node) = integer_type_node;
5ff904cd 11440
c7e4ee3a
CB		 11441 size_zero_node = build_int_2 (0, 0);
11442 TREE_TYPE (size_zero_node) = sizetype;
11443 size_one_node = build_int_2 (1, 0);
11444 TREE_TYPE (size_one_node) = sizetype;
5ff904cd 11445
c7e4ee3a
CB		 11446 void_type_node = make_node (VOID_TYPE);
11447 pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11448 void_type_node));
11449 layout_type (void_type_node); /* Uses integer_zero_node */
11450 /* We are not going to have real types in C with less than byte alignment,
11451 so we might as well not have any types that claim to have it. */
11452 TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
5ff904cd 11453
c7e4ee3a
CB		 11454 null_pointer_node = build_int_2 (0, 0);
11455 TREE_TYPE (null_pointer_node) = build_pointer_type (void_type_node);
11456 layout_type (TREE_TYPE (null_pointer_node));
5ff904cd 11457
c7e4ee3a 11458 string_type_node = build_pointer_type (char_type_node);
5ff904cd 11459
c7e4ee3a
CB		 11460 ffecom_tree_fun_type_void
11461 = build_function_type (void_type_node, NULL_TREE);
5ff904cd 11462
c7e4ee3a
CB		 11463 ffecom_tree_ptr_to_fun_type_void
11464 = build_pointer_type (ffecom_tree_fun_type_void);
5ff904cd 11465
c7e4ee3a 11466 endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
5ff904cd 11467
c7e4ee3a
CB		 11468 float_ftype_float
11469 = build_function_type (float_type_node,
11470 tree_cons (NULL_TREE, float_type_node, endlink));
5ff904cd 11471
c7e4ee3a
CB		 11472 double_ftype_double
11473 = build_function_type (double_type_node,
11474 tree_cons (NULL_TREE, double_type_node, endlink));
5ff904cd 11475
c7e4ee3a
CB		 11476 ldouble_ftype_ldouble
11477 = build_function_type (long_double_type_node,
11478 tree_cons (NULL_TREE, long_double_type_node,
11479 endlink));
5ff904cd 11480
c7e4ee3a
CB		 11481 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11482 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11483 {
11484 ffecom_tree_type[i][j] = NULL_TREE;
11485 ffecom_tree_fun_type[i][j] = NULL_TREE;
11486 ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11487 ffecom_f2c_typecode_[i][j] = -1;
11488 }
5ff904cd 11489
c7e4ee3a
CB		 11490 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11491 to size FLOAT_TYPE_SIZE because they have to be the same size as
11492 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11493 Compiler options and other such stuff that change the ways these
11494 types are set should not affect this particular setup. */
5ff904cd 11495
c7e4ee3a
CB		 11496 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11497 = t = make_signed_type (FLOAT_TYPE_SIZE);
11498 pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11499 t));
11500 type = ffetype_new ();
11501 base_type = type;
11502 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11503 type);
11504 ffetype_set_ams (type,
11505 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11506 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11507 ffetype_set_star (base_type,
11508 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11509 type);
11510 ffetype_set_kind (base_type, 1, type);
11511 assert (ffetype_size (type) == sizeof (ffetargetInteger1));
5ff904cd 11512
c7e4ee3a
CB		 11513 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11514 = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11515 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11516 t));
5ff904cd 11517
c7e4ee3a
CB		 11518 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11519 = t = make_signed_type (CHAR_TYPE_SIZE);
11520 pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11521 t));
11522 type = ffetype_new ();
11523 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11524 type);
11525 ffetype_set_ams (type,
11526 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11527 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11528 ffetype_set_star (base_type,
11529 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11530 type);
11531 ffetype_set_kind (base_type, 3, type);
11532 assert (ffetype_size (type) == sizeof (ffetargetInteger2));
5ff904cd 11533
c7e4ee3a
CB		 11534 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11535 = t = make_unsigned_type (CHAR_TYPE_SIZE);
11536 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11537 t));
11538
11539 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11540 = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11541 pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11542 t));
11543 type = ffetype_new ();
11544 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11545 type);
11546 ffetype_set_ams (type,
11547 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11548 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11549 ffetype_set_star (base_type,
11550 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11551 type);
11552 ffetype_set_kind (base_type, 6, type);
11553 assert (ffetype_size (type) == sizeof (ffetargetInteger3));
5ff904cd 11554
c7e4ee3a
CB		 11555 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11556 = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11557 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11558 t));
5ff904cd 11559
c7e4ee3a
CB		 11560 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11561 = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11562 pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11563 t));
11564 type = ffetype_new ();
11565 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11566 type);
11567 ffetype_set_ams (type,
11568 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11569 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11570 ffetype_set_star (base_type,
11571 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11572 type);
11573 ffetype_set_kind (base_type, 2, type);
11574 assert (ffetype_size (type) == sizeof (ffetargetInteger4));
5ff904cd 11575
c7e4ee3a
CB		 11576 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11577 = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11578 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11579 t));
5ff904cd 11580
c7e4ee3a
CB		 11581#if 0
11582 if (ffe_is_do_internal_checks ()
11583 && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11584 && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11585 && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11586 && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
5ff904cd 11587 {
c7e4ee3a
CB		 11588 fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11589 LONG_TYPE_SIZE);
5ff904cd 11590 }
c7e4ee3a 11591#endif
5ff904cd 11592
c7e4ee3a
CB		 11593 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11594 = t = make_signed_type (FLOAT_TYPE_SIZE);
11595 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11596 t));
11597 type = ffetype_new ();
11598 base_type = type;
11599 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11600 type);
11601 ffetype_set_ams (type,
11602 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11603 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11604 ffetype_set_star (base_type,
11605 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11606 type);
11607 ffetype_set_kind (base_type, 1, type);
11608 assert (ffetype_size (type) == sizeof (ffetargetLogical1));
5ff904cd 11609
c7e4ee3a
CB		 11610 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11611 = t = make_signed_type (CHAR_TYPE_SIZE);
11612 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11613 t));
11614 type = ffetype_new ();
11615 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11616 type);
11617 ffetype_set_ams (type,
11618 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11619 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11620 ffetype_set_star (base_type,
11621 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11622 type);
11623 ffetype_set_kind (base_type, 3, type);
11624 assert (ffetype_size (type) == sizeof (ffetargetLogical2));
5ff904cd 11625
c7e4ee3a
CB		 11626 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11627 = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11628 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11629 t));
11630 type = ffetype_new ();
11631 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11632 type);
11633 ffetype_set_ams (type,
11634 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11635 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11636 ffetype_set_star (base_type,
11637 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11638 type);
11639 ffetype_set_kind (base_type, 6, type);
11640 assert (ffetype_size (type) == sizeof (ffetargetLogical3));
5ff904cd 11641
c7e4ee3a
CB		 11642 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11643 = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11644 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11645 t));
11646 type = ffetype_new ();
11647 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11648 type);
11649 ffetype_set_ams (type,
11650 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11651 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11652 ffetype_set_star (base_type,
11653 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11654 type);
11655 ffetype_set_kind (base_type, 2, type);
11656 assert (ffetype_size (type) == sizeof (ffetargetLogical4));
5ff904cd 11657
c7e4ee3a
CB		 11658 ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11659 = t = make_node (REAL_TYPE);
11660 TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11661 pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11662 t));
11663 layout_type (t);
11664 type = ffetype_new ();
11665 base_type = type;
11666 ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11667 type);
11668 ffetype_set_ams (type,
11669 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11670 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11671 ffetype_set_star (base_type,
11672 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11673 type);
11674 ffetype_set_kind (base_type, 1, type);
11675 ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11676 = FFETARGET_f2cTYREAL;
11677 assert (ffetype_size (type) == sizeof (ffetargetReal1));
5ff904cd 11678
c7e4ee3a
CB		 11679 ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11680 = t = make_node (REAL_TYPE);
11681 TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2; /* Always twice REAL. */
11682 pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11683 t));
11684 layout_type (t);
11685 type = ffetype_new ();
11686 ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11687 type);
11688 ffetype_set_ams (type,
11689 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11690 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11691 ffetype_set_star (base_type,
11692 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11693 type);
11694 ffetype_set_kind (base_type, 2, type);
11695 ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11696 = FFETARGET_f2cTYDREAL;
11697 assert (ffetype_size (type) == sizeof (ffetargetReal2));
5ff904cd 11698
c7e4ee3a
CB		 11699 ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11700 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11701 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11702 t));
11703 type = ffetype_new ();
11704 base_type = type;
11705 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11706 type);
11707 ffetype_set_ams (type,
11708 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11709 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11710 ffetype_set_star (base_type,
11711 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11712 type);
11713 ffetype_set_kind (base_type, 1, type);
11714 ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11715 = FFETARGET_f2cTYCOMPLEX;
11716 assert (ffetype_size (type) == sizeof (ffetargetComplex1));
5ff904cd 11717
c7e4ee3a
CB		 11718 ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11719 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11720 pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11721 t));
11722 type = ffetype_new ();
11723 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11724 type);
11725 ffetype_set_ams (type,
11726 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11727 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11728 ffetype_set_star (base_type,
11729 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11730 type);
11731 ffetype_set_kind (base_type, 2,
11732 type);
11733 ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11734 = FFETARGET_f2cTYDCOMPLEX;
11735 assert (ffetype_size (type) == sizeof (ffetargetComplex2));
5ff904cd 11736
c7e4ee3a 11737 /* Make function and ptr-to-function types for non-CHARACTER types. */
5ff904cd 11738
c7e4ee3a
CB		 11739 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11740 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11741 {
11742 if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11743 {
11744 if (i == FFEINFO_basictypeINTEGER)
11745 {
11746 /* Figure out the smallest INTEGER type that can hold
11747 a pointer on this machine. */
11748 if (GET_MODE_SIZE (TYPE_MODE (t))
11749 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11750 {
11751 if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11752 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11753 > GET_MODE_SIZE (TYPE_MODE (t))))
11754 ffecom_pointer_kind_ = j;
11755 }
11756 }
11757 else if (i == FFEINFO_basictypeCOMPLEX)
11758 t = void_type_node;
11759 /* For f2c compatibility, REAL functions are really
11760 implemented as DOUBLE PRECISION. */
11761 else if ((i == FFEINFO_basictypeREAL)
11762 && (j == FFEINFO_kindtypeREAL1))
11763 t = ffecom_tree_type
11764 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
5ff904cd 11765
c7e4ee3a
CB		 11766 t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11767 NULL_TREE);
11768 ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11769 }
11770 }
5ff904cd 11771
c7e4ee3a 11772 /* Set up pointer types. */
5ff904cd 11773
c7e4ee3a
CB		 11774 if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11775 fatal ("no INTEGER type can hold a pointer on this configuration");
11776 else if (0 && ffe_is_do_internal_checks ())
11777 fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11778 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11779 FFEINFO_kindtypeINTEGERDEFAULT),
11780 7,
11781 ffeinfo_type (FFEINFO_basictypeINTEGER,
11782 ffecom_pointer_kind_));
5ff904cd 11783
c7e4ee3a
CB		 11784 if (ffe_is_ugly_assign ())
11785 ffecom_label_kind_ = ffecom_pointer_kind_; /* Require ASSIGN etc to this. */
11786 else
11787 ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11788 if (0 && ffe_is_do_internal_checks ())
11789 fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
5ff904cd 11790
c7e4ee3a
CB		 11791 ffecom_integer_type_node
11792 = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11793 ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11794 integer_zero_node);
11795 ffecom_integer_one_node = convert (ffecom_integer_type_node,
11796 integer_one_node);
5ff904cd 11797
c7e4ee3a
CB		 11798 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11799 Turns out that by TYLONG, runtime/libI77/lio.h really means
11800 "whatever size an ftnint is". For consistency and sanity,
11801 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11802 all are INTEGER, which we also make out of whatever back-end
11803 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11804 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11805 accommodate machines like the Alpha. Note that this suggests
11806 f2c and libf2c are missing a distinction perhaps needed on
11807 some machines between "int" and "long int". -- burley 0.5.5 950215 */
5ff904cd 11808
c7e4ee3a
CB		 11809 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11810 FFETARGET_f2cTYLONG);
11811 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11812 FFETARGET_f2cTYSHORT);
11813 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11814 FFETARGET_f2cTYINT1);
11815 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11816 FFETARGET_f2cTYQUAD);
11817 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11818 FFETARGET_f2cTYLOGICAL);
11819 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11820 FFETARGET_f2cTYLOGICAL2);
11821 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11822 FFETARGET_f2cTYLOGICAL1);
11823 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11824 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11825 FFETARGET_f2cTYQUAD);
5ff904cd 11826
c7e4ee3a
CB		 11827 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11828 loop. CHARACTER items are built as arrays of unsigned char. */
5ff904cd 11829
c7e4ee3a
CB		 11830 ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11831 [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11832 type = ffetype_new ();
11833 base_type = type;
11834 ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11835 FFEINFO_kindtypeCHARACTER1,
11836 type);
11837 ffetype_set_ams (type,
11838 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11839 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11840 ffetype_set_kind (base_type, 1, type);
11841 assert (ffetype_size (type)
11842 == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
5ff904cd 11843
c7e4ee3a
CB		 11844 ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11845 [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11846 ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11847 [FFEINFO_kindtypeCHARACTER1]
11848 = ffecom_tree_ptr_to_fun_type_void;
11849 ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11850 = FFETARGET_f2cTYCHAR;
5ff904cd 11851
c7e4ee3a
CB		 11852 ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11853 = 0;
5ff904cd 11854
c7e4ee3a 11855 /* Make multi-return-value type and fields. */
5ff904cd 11856
c7e4ee3a 11857 ffecom_multi_type_node_ = make_node (UNION_TYPE);
5ff904cd 11858
c7e4ee3a 11859 field = NULL_TREE;
5ff904cd 11860
c7e4ee3a
CB		 11861 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11862 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11863 {
11864 char name[30];
5ff904cd 11865
c7e4ee3a
CB		 11866 if (ffecom_tree_type[i][j] == NULL_TREE)
11867 continue; /* Not supported. */
11868 sprintf (&name[0], "bt_%s_kt_%s",
11869 ffeinfo_basictype_string ((ffeinfoBasictype) i),
11870 ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11871 ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11872 get_identifier (name),
11873 ffecom_tree_type[i][j]);
11874 DECL_CONTEXT (ffecom_multi_fields_[i][j])
11875 = ffecom_multi_type_node_;
11876 DECL_FRAME_SIZE (ffecom_multi_fields_[i][j]) = 0;
11877 TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11878 field = ffecom_multi_fields_[i][j];
11879 }
5ff904cd 11880
c7e4ee3a
CB		 11881 TYPE_FIELDS (ffecom_multi_type_node_) = field;
11882 layout_type (ffecom_multi_type_node_);
5ff904cd 11883
c7e4ee3a
CB		 11884 /* Subroutines usually return integer because they might have alternate
11885 returns. */
5ff904cd 11886
c7e4ee3a
CB		 11887 ffecom_tree_subr_type
11888 = build_function_type (integer_type_node, NULL_TREE);
11889 ffecom_tree_ptr_to_subr_type
11890 = build_pointer_type (ffecom_tree_subr_type);
11891 ffecom_tree_blockdata_type
11892 = build_function_type (void_type_node, NULL_TREE);
5ff904cd 11893
c7e4ee3a
CB		 11894 builtin_function ("__builtin_sqrtf", float_ftype_float,
11895 BUILT_IN_FSQRT, "sqrtf");
11896 builtin_function ("__builtin_fsqrt", double_ftype_double,
11897 BUILT_IN_FSQRT, "sqrt");
11898 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11899 BUILT_IN_FSQRT, "sqrtl");
11900 builtin_function ("__builtin_sinf", float_ftype_float,
11901 BUILT_IN_SIN, "sinf");
11902 builtin_function ("__builtin_sin", double_ftype_double,
11903 BUILT_IN_SIN, "sin");
11904 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11905 BUILT_IN_SIN, "sinl");
11906 builtin_function ("__builtin_cosf", float_ftype_float,
11907 BUILT_IN_COS, "cosf");
11908 builtin_function ("__builtin_cos", double_ftype_double,
11909 BUILT_IN_COS, "cos");
11910 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11911 BUILT_IN_COS, "cosl");
5ff904cd 11912
c7e4ee3a
CB		 11913#if BUILT_FOR_270
11914 pedantic_lvalues = FALSE;
5ff904cd 11915#endif
5ff904cd 11916
c7e4ee3a
CB		 11917 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11918 FFECOM_f2cINTEGER,
11919 "integer");
11920 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11921 FFECOM_f2cADDRESS,
11922 "address");
11923 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11924 FFECOM_f2cREAL,
11925 "real");
11926 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11927 FFECOM_f2cDOUBLEREAL,
11928 "doublereal");
11929 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11930 FFECOM_f2cCOMPLEX,
11931 "complex");
11932 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11933 FFECOM_f2cDOUBLECOMPLEX,
11934 "doublecomplex");
11935 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11936 FFECOM_f2cLONGINT,
11937 "longint");
11938 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11939 FFECOM_f2cLOGICAL,
11940 "logical");
11941 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11942 FFECOM_f2cFLAG,
11943 "flag");
11944 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11945 FFECOM_f2cFTNLEN,
11946 "ftnlen");
11947 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11948 FFECOM_f2cFTNINT,
11949 "ftnint");
5ff904cd 11950
c7e4ee3a
CB		 11951 ffecom_f2c_ftnlen_zero_node
11952 = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
5ff904cd 11953
c7e4ee3a
CB		 11954 ffecom_f2c_ftnlen_one_node
11955 = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
5ff904cd 11956
c7e4ee3a
CB		 11957 ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11958 TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
5ff904cd 11959
c7e4ee3a
CB		 11960 ffecom_f2c_ptr_to_ftnlen_type_node
11961 = build_pointer_type (ffecom_f2c_ftnlen_type_node);
5ff904cd 11962
c7e4ee3a
CB		 11963 ffecom_f2c_ptr_to_ftnint_type_node
11964 = build_pointer_type (ffecom_f2c_ftnint_type_node);
5ff904cd 11965
c7e4ee3a
CB		 11966 ffecom_f2c_ptr_to_integer_type_node
11967 = build_pointer_type (ffecom_f2c_integer_type_node);
5ff904cd 11968
c7e4ee3a
CB		 11969 ffecom_f2c_ptr_to_real_type_node
11970 = build_pointer_type (ffecom_f2c_real_type_node);
5ff904cd 11971
c7e4ee3a
CB		 11972 ffecom_float_zero_ = build_real (float_type_node, dconst0);
11973 ffecom_double_zero_ = build_real (double_type_node, dconst0);
11974 {
11975 REAL_VALUE_TYPE point_5;
5ff904cd 11976
c7e4ee3a
CB		 11977#ifdef REAL_ARITHMETIC
11978 REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
11979#else
11980 point_5 = .5;
11981#endif
11982 ffecom_float_half_ = build_real (float_type_node, point_5);
11983 ffecom_double_half_ = build_real (double_type_node, point_5);
11984 }
5ff904cd 11985
c7e4ee3a 11986 /* Do "extern int xargc;". */
5ff904cd 11987
c7e4ee3a
CB		 11988 ffecom_tree_xargc_ = build_decl (VAR_DECL,
11989 get_identifier ("f__xargc"),
11990 integer_type_node);
11991 DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
11992 TREE_STATIC (ffecom_tree_xargc_) = 1;
11993 TREE_PUBLIC (ffecom_tree_xargc_) = 1;
11994 ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
11995 finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
5ff904cd 11996
c7e4ee3a
CB		 11997#if 0 /* This is being fixed, and seems to be working now. */
11998 if ((FLOAT_TYPE_SIZE != 32)
11999 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
5ff904cd 12000 {
c7e4ee3a
CB		 12001 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12002 (int) FLOAT_TYPE_SIZE);
12003 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12004 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12005 warning ("properly unless they all are 32 bits wide.");
12006 warning ("Please keep this in mind before you report bugs. g77 should");
12007 warning ("support non-32-bit machines better as of version 0.6.");
12008 }
12009#endif
5ff904cd 12010
c7e4ee3a
CB		 12011#if 0 /* Code in ste.c that would crash has been commented out. */
12012 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12013 < TYPE_PRECISION (string_type_node))
12014 /* I/O will probably crash. */
12015 warning ("configuration: char * holds %d bits, but ftnlen only %d",
12016 TYPE_PRECISION (string_type_node),
12017 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12018#endif
5ff904cd 12019
c7e4ee3a
CB		 12020#if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
12021 if (TYPE_PRECISION (ffecom_integer_type_node)
12022 < TYPE_PRECISION (string_type_node))
12023 /* ASSIGN 10 TO I will crash. */
12024 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12025 ASSIGN statement might fail",
12026 TYPE_PRECISION (string_type_node),
12027 TYPE_PRECISION (ffecom_integer_type_node));
12028#endif
12029}
5ff904cd 12030
c7e4ee3a
CB		 12031#endif
12032/* ffecom_init_2 -- Initialize
5ff904cd 12033
c7e4ee3a 12034 ffecom_init_2(); */
5ff904cd 12035
c7e4ee3a
CB		 12036#if FFECOM_targetCURRENT == FFECOM_targetGCC
12037void
12038ffecom_init_2 ()
12039{
12040 assert (ffecom_outer_function_decl_ == NULL_TREE);
12041 assert (current_function_decl == NULL_TREE);
12042 assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
5ff904cd 12043
c7e4ee3a
CB		 12044 ffecom_master_arglist_ = NULL;
12045 ++ffecom_num_fns_;
12046 ffecom_primary_entry_ = NULL;
12047 ffecom_is_altreturning_ = FALSE;
12048 ffecom_func_result_ = NULL_TREE;
12049 ffecom_multi_retval_ = NULL_TREE;
12050}
5ff904cd 12051
c7e4ee3a
CB		 12052#endif
12053/* ffecom_list_expr -- Transform list of exprs into gcc tree
5ff904cd 12054
c7e4ee3a
CB		 12055 tree t;
12056 ffebld expr; // FFE opITEM list.
12057 tree = ffecom_list_expr(expr);
5ff904cd 12058
c7e4ee3a 12059 List of actual args is transformed into corresponding gcc backend list. */
5ff904cd 12060
c7e4ee3a
CB		 12061#if FFECOM_targetCURRENT == FFECOM_targetGCC
12062tree
12063ffecom_list_expr (ffebld expr)
5ff904cd 12064{
c7e4ee3a
CB		 12065 tree list;
12066 tree *plist = &list;
12067 tree trail = NULL_TREE; /* Append char length args here. */
12068 tree *ptrail = &trail;
12069 tree length;
5ff904cd 12070
c7e4ee3a 12071 while (expr != NULL)
5ff904cd 12072 {
c7e4ee3a 12073 tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
5ff904cd 12074
c7e4ee3a
CB		 12075 if (texpr == error_mark_node)
12076 return error_mark_node;
5ff904cd 12077
c7e4ee3a
CB		 12078 *plist = build_tree_list (NULL_TREE, texpr);
12079 plist = &TREE_CHAIN (*plist);
12080 expr = ffebld_trail (expr);
12081 if (length != NULL_TREE)
5ff904cd 12082 {
c7e4ee3a
CB		 12083 *ptrail = build_tree_list (NULL_TREE, length);
12084 ptrail = &TREE_CHAIN (*ptrail);
5ff904cd
JL		 12085 }
12086 }
12087
c7e4ee3a 12088 *plist = trail;
5ff904cd 12089
c7e4ee3a
CB		 12090 return list;
12091}
5ff904cd 12092
c7e4ee3a
CB		 12093#endif
12094/* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
5ff904cd 12095
c7e4ee3a
CB		 12096 tree t;
12097 ffebld expr; // FFE opITEM list.
12098 tree = ffecom_list_ptr_to_expr(expr);
5ff904cd 12099
c7e4ee3a
CB		 12100 List of actual args is transformed into corresponding gcc backend list for
12101 use in calling an external procedure (vs. a statement function). */
5ff904cd 12102
c7e4ee3a
CB		 12103#if FFECOM_targetCURRENT == FFECOM_targetGCC
12104tree
12105ffecom_list_ptr_to_expr (ffebld expr)
12106{
12107 tree list;
12108 tree *plist = &list;
12109 tree trail = NULL_TREE; /* Append char length args here. */
12110 tree *ptrail = &trail;
12111 tree length;
5ff904cd 12112
c7e4ee3a
CB		 12113 while (expr != NULL)
12114 {
12115 tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
5ff904cd 12116
c7e4ee3a
CB		 12117 if (texpr == error_mark_node)
12118 return error_mark_node;
5ff904cd 12119
c7e4ee3a
CB		 12120 *plist = build_tree_list (NULL_TREE, texpr);
12121 plist = &TREE_CHAIN (*plist);
12122 expr = ffebld_trail (expr);
12123 if (length != NULL_TREE)
12124 {
12125 *ptrail = build_tree_list (NULL_TREE, length);
12126 ptrail = &TREE_CHAIN (*ptrail);
12127 }
12128 }
5ff904cd 12129
c7e4ee3a 12130 *plist = trail;
5ff904cd 12131
c7e4ee3a
CB		 12132 return list;
12133}
5ff904cd 12134
c7e4ee3a
CB		 12135#endif
12136/* Obtain gcc's LABEL_DECL tree for label. */
5ff904cd 12137
c7e4ee3a
CB		 12138#if FFECOM_targetCURRENT == FFECOM_targetGCC
12139tree
12140ffecom_lookup_label (ffelab label)
12141{
12142 tree glabel;
5ff904cd 12143
c7e4ee3a
CB		 12144 if (ffelab_hook (label) == NULL_TREE)
12145 {
12146 char labelname[16];
5ff904cd 12147
c7e4ee3a
CB		 12148 switch (ffelab_type (label))
12149 {
12150 case FFELAB_typeLOOPEND:
12151 case FFELAB_typeNOTLOOP:
12152 case FFELAB_typeENDIF:
12153 sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12154 glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12155 void_type_node);
12156 DECL_CONTEXT (glabel) = current_function_decl;
12157 DECL_MODE (glabel) = VOIDmode;
12158 break;
5ff904cd 12159
c7e4ee3a
CB		 12160 case FFELAB_typeFORMAT:
12161 push_obstacks_nochange ();
12162 end_temporary_allocation ();
5ff904cd 12163
c7e4ee3a
CB		 12164 glabel = build_decl (VAR_DECL,
12165 ffecom_get_invented_identifier
12166 ("__g77_format_%d", NULL,
12167 (int) ffelab_value (label)),
12168 build_type_variant (build_array_type
12169 (char_type_node,
12170 NULL_TREE),
12171 1, 0));
12172 TREE_CONSTANT (glabel) = 1;
12173 TREE_STATIC (glabel) = 1;
12174 DECL_CONTEXT (glabel) = 0;
12175 DECL_INITIAL (glabel) = NULL;
12176 make_decl_rtl (glabel, NULL, 0);
12177 expand_decl (glabel);
5ff904cd 12178
c7e4ee3a
CB		 12179 resume_temporary_allocation ();
12180 pop_obstacks ();
5ff904cd 12181
c7e4ee3a 12182 break;
5ff904cd 12183
c7e4ee3a
CB		 12184 case FFELAB_typeANY:
12185 glabel = error_mark_node;
12186 break;
5ff904cd 12187
c7e4ee3a
CB		 12188 default:
12189 assert ("bad label type" == NULL);
12190 glabel = NULL;
12191 break;
12192 }
12193 ffelab_set_hook (label, glabel);
12194 }
12195 else
12196 {
12197 glabel = ffelab_hook (label);
12198 }
5ff904cd 12199
c7e4ee3a
CB		 12200 return glabel;
12201}
5ff904cd 12202
c7e4ee3a
CB		 12203#endif
12204/* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12205 a single source specification (as in the fourth argument of MVBITS).
12206 If the type is NULL_TREE, the type of lhs is used to make the type of
12207 the MODIFY_EXPR. */
5ff904cd 12208
c7e4ee3a
CB		 12209#if FFECOM_targetCURRENT == FFECOM_targetGCC
12210tree
12211ffecom_modify (tree newtype, tree lhs,
12212 tree rhs)
12213{
12214 if (lhs == error_mark_node || rhs == error_mark_node)
12215 return error_mark_node;
5ff904cd 12216
c7e4ee3a
CB		 12217 if (newtype == NULL_TREE)
12218 newtype = TREE_TYPE (lhs);
5ff904cd 12219
c7e4ee3a
CB		 12220 if (TREE_SIDE_EFFECTS (lhs))
12221 lhs = stabilize_reference (lhs);
5ff904cd 12222
c7e4ee3a
CB		 12223 return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12224}
5ff904cd 12225
c7e4ee3a 12226#endif
5ff904cd 12227
c7e4ee3a 12228/* Register source file name. */
5ff904cd 12229
c7e4ee3a
CB		 12230void
12231ffecom_file (char *name)
12232{
12233#if FFECOM_GCC_INCLUDE
12234 ffecom_file_ (name);
12235#endif
12236}
5ff904cd 12237
c7e4ee3a 12238/* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
5ff904cd 12239
c7e4ee3a
CB		 12240 ffestorag st;
12241 ffecom_notify_init_storage(st);
5ff904cd 12242
c7e4ee3a
CB		 12243 Gets called when all possible units in an aggregate storage area (a LOCAL
12244 with equivalences or a COMMON) have been initialized. The initialization
12245 info either is in ffestorag_init or, if that is NULL,
12246 ffestorag_accretion:
5ff904cd 12247
c7e4ee3a
CB		 12248 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12249 even for an array if the array is one element in length!
5ff904cd 12250
c7e4ee3a
CB		 12251 ffestorag_accretion will contain an opACCTER. It is much like an
12252 opARRTER except it has an ffebit object in it instead of just a size.
12253 The back end can use the info in the ffebit object, if it wants, to
12254 reduce the amount of actual initialization, but in any case it should
12255 kill the ffebit object when done. Also, set accretion to NULL but
12256 init to a non-NULL value.
5ff904cd 12257
c7e4ee3a
CB		 12258 After performing initialization, DO NOT set init to NULL, because that'll
12259 tell the front end it is ok for more initialization to happen. Instead,
12260 set init to an opANY expression or some such thing that you can use to
12261 tell that you've already initialized the object.
5ff904cd 12262
c7e4ee3a
CB		 12263 27-Oct-91 JCB 1.1
12264 Support two-pass FFE. */
5ff904cd 12265
c7e4ee3a
CB		 12266void
12267ffecom_notify_init_storage (ffestorag st)
12268{
12269 ffebld init; /* The initialization expression. */
12270#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12271 ffetargetOffset size; /* The size of the entity. */
12272 ffetargetAlign pad; /* Its initial padding. */
12273#endif
12274
12275 if (ffestorag_init (st) == NULL)
5ff904cd 12276 {
c7e4ee3a
CB		 12277 init = ffestorag_accretion (st);
12278 assert (init != NULL);
12279 ffestorag_set_accretion (st, NULL);
12280 ffestorag_set_accretes (st, 0);
12281
12282#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12283 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12284 size = ffebld_accter_size (init);
12285 pad = ffebld_accter_pad (init);
12286 ffebit_kill (ffebld_accter_bits (init));
12287 ffebld_set_op (init, FFEBLD_opARRTER);
12288 ffebld_set_arrter (init, ffebld_accter (init));
12289 ffebld_arrter_set_size (init, size);
12290 ffebld_arrter_set_pad (init, size);
12291#endif
12292
12293#if FFECOM_TWOPASS
12294 ffestorag_set_init (st, init);
12295#endif
5ff904cd 12296 }
c7e4ee3a
CB		 12297#if FFECOM_ONEPASS
12298 else
12299 init = ffestorag_init (st);
5ff904cd
JL		 12300#endif
12301
c7e4ee3a
CB		 12302#if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
12303 ffestorag_set_init (st, ffebld_new_any ());
5ff904cd 12304
c7e4ee3a
CB		 12305 if (ffebld_op (init) == FFEBLD_opANY)
12306 return; /* Oh, we already did this! */
5ff904cd 12307
c7e4ee3a
CB		 12308#if FFECOM_targetCURRENT == FFECOM_targetFFE
12309 {
12310 ffesymbol s;
5ff904cd 12311
c7e4ee3a
CB		 12312 if (ffestorag_symbol (st) != NULL)
12313 s = ffestorag_symbol (st);
12314 else
12315 s = ffestorag_typesymbol (st);
5ff904cd 12316
c7e4ee3a
CB		 12317 fprintf (dmpout, "= initialize_storage \"%s\" ",
12318 (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12319 ffebld_dump (init);
12320 fputc ('\n', dmpout);
12321 }
12322#endif
5ff904cd 12323
c7e4ee3a
CB		 12324#endif /* if FFECOM_ONEPASS */
12325}
5ff904cd 12326
c7e4ee3a 12327/* ffecom_notify_init_symbol -- A symbol is now fully init'ed
5ff904cd 12328
c7e4ee3a
CB		 12329 ffesymbol s;
12330 ffecom_notify_init_symbol(s);
5ff904cd 12331
c7e4ee3a
CB		 12332 Gets called when all possible units in a symbol (not placed in COMMON
12333 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12334 have been initialized. The initialization info either is in
12335 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
5ff904cd 12336
c7e4ee3a
CB		 12337 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12338 even for an array if the array is one element in length!
5ff904cd 12339
c7e4ee3a
CB		 12340 ffesymbol_accretion will contain an opACCTER. It is much like an
12341 opARRTER except it has an ffebit object in it instead of just a size.
12342 The back end can use the info in the ffebit object, if it wants, to
12343 reduce the amount of actual initialization, but in any case it should
12344 kill the ffebit object when done. Also, set accretion to NULL but
12345 init to a non-NULL value.
5ff904cd 12346
c7e4ee3a
CB		 12347 After performing initialization, DO NOT set init to NULL, because that'll
12348 tell the front end it is ok for more initialization to happen. Instead,
12349 set init to an opANY expression or some such thing that you can use to
12350 tell that you've already initialized the object.
5ff904cd 12351
c7e4ee3a
CB		 12352 27-Oct-91 JCB 1.1
12353 Support two-pass FFE. */
5ff904cd 12354
c7e4ee3a
CB		 12355void
12356ffecom_notify_init_symbol (ffesymbol s)
12357{
12358 ffebld init; /* The initialization expression. */
12359#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12360 ffetargetOffset size; /* The size of the entity. */
12361 ffetargetAlign pad; /* Its initial padding. */
12362#endif
5ff904cd 12363
c7e4ee3a
CB		 12364 if (ffesymbol_storage (s) == NULL)
12365 return; /* Do nothing until COMMON/EQUIVALENCE
12366 possibilities checked. */
5ff904cd 12367
c7e4ee3a
CB		 12368 if ((ffesymbol_init (s) == NULL)
12369 && ((init = ffesymbol_accretion (s)) != NULL))
12370 {
12371 ffesymbol_set_accretion (s, NULL);
12372 ffesymbol_set_accretes (s, 0);
5ff904cd 12373
c7e4ee3a
CB		 12374#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12375 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12376 size = ffebld_accter_size (init);
12377 pad = ffebld_accter_pad (init);
12378 ffebit_kill (ffebld_accter_bits (init));
12379 ffebld_set_op (init, FFEBLD_opARRTER);
12380 ffebld_set_arrter (init, ffebld_accter (init));
12381 ffebld_arrter_set_size (init, size);
12382 ffebld_arrter_set_pad (init, size);
12383#endif
5ff904cd 12384
c7e4ee3a
CB		 12385#if FFECOM_TWOPASS
12386 ffesymbol_set_init (s, init);
12387#endif
12388 }
12389#if FFECOM_ONEPASS
12390 else
12391 init = ffesymbol_init (s);
12392#endif
5ff904cd 12393
c7e4ee3a
CB		 12394#if FFECOM_ONEPASS
12395 ffesymbol_set_init (s, ffebld_new_any ());
5ff904cd 12396
c7e4ee3a
CB		 12397 if (ffebld_op (init) == FFEBLD_opANY)
12398 return; /* Oh, we already did this! */
5ff904cd 12399
c7e4ee3a
CB		 12400#if FFECOM_targetCURRENT == FFECOM_targetFFE
12401 fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12402 ffebld_dump (init);
12403 fputc ('\n', dmpout);
12404#endif
5ff904cd 12405
c7e4ee3a
CB		 12406#endif /* if FFECOM_ONEPASS */
12407}
5ff904cd 12408
c7e4ee3a 12409/* ffecom_notify_primary_entry -- Learn which is the primary entry point
5ff904cd 12410
c7e4ee3a
CB		 12411 ffesymbol s;
12412 ffecom_notify_primary_entry(s);
5ff904cd 12413
c7e4ee3a
CB		 12414 Gets called when implicit or explicit PROGRAM statement seen or when
12415 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12416 global symbol that serves as the entry point. */
5ff904cd 12417
c7e4ee3a
CB		 12418void
12419ffecom_notify_primary_entry (ffesymbol s)
12420{
12421 ffecom_primary_entry_ = s;
12422 ffecom_primary_entry_kind_ = ffesymbol_kind (s);
5ff904cd 12423
c7e4ee3a
CB		 12424 if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12425 || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12426 ffecom_primary_entry_is_proc_ = TRUE;
12427 else
12428 ffecom_primary_entry_is_proc_ = FALSE;
5ff904cd 12429
c7e4ee3a
CB		 12430 if (!ffe_is_silent ())
12431 {
12432 if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12433 fprintf (stderr, "%s:\n", ffesymbol_text (s));
12434 else
12435 fprintf (stderr, " %s:\n", ffesymbol_text (s));
12436 }
5ff904cd 12437
c7e4ee3a
CB		 12438#if FFECOM_targetCURRENT == FFECOM_targetGCC
12439 if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12440 {
12441 ffebld list;
12442 ffebld arg;
5ff904cd 12443
c7e4ee3a
CB		 12444 for (list = ffesymbol_dummyargs (s);
12445 list != NULL;
12446 list = ffebld_trail (list))
12447 {
12448 arg = ffebld_head (list);
12449 if (ffebld_op (arg) == FFEBLD_opSTAR)
12450 {
12451 ffecom_is_altreturning_ = TRUE;
12452 break;
12453 }
12454 }
12455 }
12456#endif
12457}
5ff904cd 12458
c7e4ee3a
CB		 12459FILE *
12460ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12461{
12462#if FFECOM_GCC_INCLUDE
12463 return ffecom_open_include_ (name, l, c);
12464#else
12465 return fopen (name, "r");
5ff904cd 12466#endif
c7e4ee3a 12467}
5ff904cd 12468
c7e4ee3a 12469/* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
5ff904cd 12470
c7e4ee3a
CB		 12471 tree t;
12472 ffebld expr; // FFE expression.
12473 tree = ffecom_ptr_to_expr(expr);
5ff904cd 12474
c7e4ee3a 12475 Like ffecom_expr, but sticks address-of in front of most things. */
5ff904cd 12476
c7e4ee3a
CB		 12477#if FFECOM_targetCURRENT == FFECOM_targetGCC
12478tree
12479ffecom_ptr_to_expr (ffebld expr)
12480{
12481 tree item;
12482 ffeinfoBasictype bt;
12483 ffeinfoKindtype kt;
12484 ffesymbol s;
5ff904cd 12485
c7e4ee3a 12486 assert (expr != NULL);
5ff904cd 12487
c7e4ee3a
CB		 12488 switch (ffebld_op (expr))
12489 {
12490 case FFEBLD_opSYMTER:
12491 s = ffebld_symter (expr);
12492 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12493 {
12494 ffecomGfrt ix;
5ff904cd 12495
c7e4ee3a
CB		 12496 ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12497 assert (ix != FFECOM_gfrt);
12498 if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12499 {
12500 ffecom_make_gfrt_ (ix);
12501 item = ffecom_gfrt_[ix];
12502 }
12503 }
12504 else
12505 {
12506 item = ffesymbol_hook (s).decl_tree;
12507 if (item == NULL_TREE)
12508 {
12509 s = ffecom_sym_transform_ (s);
12510 item = ffesymbol_hook (s).decl_tree;
12511 }
12512 }
12513 assert (item != NULL);
12514 if (item == error_mark_node)
12515 return item;
12516 if (!ffesymbol_hook (s).addr)
12517 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12518 item);
12519 return item;
5ff904cd 12520
c7e4ee3a
CB		 12521 case FFEBLD_opARRAYREF:
12522 {
12523 ffebld dims[FFECOM_dimensionsMAX];
12524 tree array;
12525 int i;
5ff904cd 12526
c7e4ee3a 12527 item = ffecom_ptr_to_expr (ffebld_left (expr));
5ff904cd 12528
c7e4ee3a
CB		 12529 if (item == error_mark_node)
12530 return item;
5ff904cd 12531
c7e4ee3a
CB		 12532 if ((ffebld_where (expr) == FFEINFO_whereFLEETING)
12533 && !mark_addressable (item))
12534 return error_mark_node; /* Make sure non-const ref is to
12535 non-reg. */
5ff904cd 12536
c7e4ee3a
CB		 12537 /* Build up ARRAY_REFs in reverse order (since we're column major
12538 here in Fortran land). */
5ff904cd 12539
c7e4ee3a
CB		 12540 for (i = 0, expr = ffebld_right (expr);
12541 expr != NULL;
12542 expr = ffebld_trail (expr))
12543 dims[i++] = ffebld_head (expr);
5ff904cd 12544
c7e4ee3a
CB		 12545 for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
12546 i >= 0;
12547 --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
12548 {
12549 /* The initial subtraction should happen in the original type so
12550 that (possible) negative values are handled appropriately. */
12551 item
12552 = ffecom_2 (PLUS_EXPR,
12553 build_pointer_type (TREE_TYPE (array)),
12554 item,
12555 size_binop (MULT_EXPR,
12556 size_in_bytes (TREE_TYPE (array)),
12557 convert (sizetype,
12558 fold (build (MINUS_EXPR,
12559 TREE_TYPE (TYPE_MIN_VALUE (TYPE_DOMAIN (array))),
12560 ffecom_expr (dims[i]),
12561 TYPE_MIN_VALUE (TYPE_DOMAIN (array)))))));
12562 }
12563 }
12564 return item;
5ff904cd 12565
c7e4ee3a 12566 case FFEBLD_opCONTER:
5ff904cd 12567
c7e4ee3a
CB		 12568 bt = ffeinfo_basictype (ffebld_info (expr));
12569 kt = ffeinfo_kindtype (ffebld_info (expr));
5ff904cd 12570
c7e4ee3a
CB		 12571 item = ffecom_constantunion (&ffebld_constant_union
12572 (ffebld_conter (expr)), bt, kt,
12573 ffecom_tree_type[bt][kt]);
12574 if (item == error_mark_node)
12575 return error_mark_node;
12576 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12577 item);
12578 return item;
5ff904cd 12579
c7e4ee3a
CB		 12580 case FFEBLD_opANY:
12581 return error_mark_node;
5ff904cd 12582
c7e4ee3a
CB		 12583 default:
12584 bt = ffeinfo_basictype (ffebld_info (expr));
12585 kt = ffeinfo_kindtype (ffebld_info (expr));
12586
12587 item = ffecom_expr (expr);
12588 if (item == error_mark_node)
12589 return error_mark_node;
12590
12591 /* The back end currently optimizes a bit too zealously for us, in that
12592 we fail JCB001 if the following block of code is omitted. It checks
12593 to see if the transformed expression is a symbol or array reference,
12594 and encloses it in a SAVE_EXPR if that is the case. */
12595
12596 STRIP_NOPS (item);
12597 if ((TREE_CODE (item) == VAR_DECL)
12598 || (TREE_CODE (item) == PARM_DECL)
12599 || (TREE_CODE (item) == RESULT_DECL)
12600 || (TREE_CODE (item) == INDIRECT_REF)
12601 || (TREE_CODE (item) == ARRAY_REF)
12602 || (TREE_CODE (item) == COMPONENT_REF)
12603#ifdef OFFSET_REF
12604 || (TREE_CODE (item) == OFFSET_REF)
12605#endif
12606 || (TREE_CODE (item) == BUFFER_REF)
12607 || (TREE_CODE (item) == REALPART_EXPR)
12608 || (TREE_CODE (item) == IMAGPART_EXPR))
12609 {
12610 item = ffecom_save_tree (item);
12611 }
12612
12613 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12614 item);
12615 return item;
12616 }
12617
12618 assert ("fall-through error" == NULL);
12619 return error_mark_node;
5ff904cd
JL		 12620}
12621
12622#endif
c7e4ee3a 12623/* Obtain a temp var with given data type.
5ff904cd 12624
c7e4ee3a
CB		 12625 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12626 or >= 0 for a CHARACTER type.
5ff904cd 12627
c7e4ee3a 12628 elements is -1 for a scalar or > 0 for an array of type. */
5ff904cd
JL		 12629
12630#if FFECOM_targetCURRENT == FFECOM_targetGCC
12631tree
c7e4ee3a
CB		 12632ffecom_make_tempvar (const char *commentary, tree type,
12633 ffetargetCharacterSize size, int elements)
5ff904cd 12634{
c7e4ee3a
CB		 12635 int yes;
12636 tree t;
12637 static int mynumber;
5ff904cd 12638
c7e4ee3a 12639 assert (current_binding_level->prep_state < 2);
702edf1d 12640
c7e4ee3a
CB		 12641 if (type == error_mark_node)
12642 return error_mark_node;
702edf1d 12643
c7e4ee3a 12644 yes = suspend_momentary ();
5ff904cd 12645
c7e4ee3a
CB		 12646 if (size != FFETARGET_charactersizeNONE)
12647 type = build_array_type (type,
12648 build_range_type (ffecom_f2c_ftnlen_type_node,
12649 ffecom_f2c_ftnlen_one_node,
12650 build_int_2 (size, 0)));
12651 if (elements != -1)
12652 type = build_array_type (type,
12653 build_range_type (integer_type_node,
12654 integer_zero_node,
12655 build_int_2 (elements - 1,
12656 0)));
12657 t = build_decl (VAR_DECL,
12658 ffecom_get_invented_identifier ("__g77_%s_%d",
12659 commentary,
12660 mynumber++),
12661 type);
5ff904cd 12662
c7e4ee3a
CB		 12663 t = start_decl (t, FALSE);
12664 finish_decl (t, NULL_TREE, FALSE);
12665
12666 resume_momentary (yes);
5ff904cd 12667
c7e4ee3a
CB		 12668 return t;
12669}
5ff904cd 12670#endif
5ff904cd 12671
c7e4ee3a 12672/* Prepare argument pointer to expression.
5ff904cd 12673
c7e4ee3a
CB		 12674 Like ffecom_prepare_expr, except for expressions to be evaluated
12675 via ffecom_arg_ptr_to_expr. */
5ff904cd 12676
c7e4ee3a
CB		 12677void
12678ffecom_prepare_arg_ptr_to_expr (ffebld expr)
5ff904cd 12679{
c7e4ee3a
CB		 12680 /* ~~For now, it seems to be the same thing. */
12681 ffecom_prepare_expr (expr);
12682 return;
12683}
702edf1d 12684
c7e4ee3a 12685/* End of preparations. */
702edf1d 12686
c7e4ee3a
CB		 12687bool
12688ffecom_prepare_end (void)
12689{
12690 int prep_state = current_binding_level->prep_state;
5ff904cd 12691
c7e4ee3a
CB		 12692 assert (prep_state < 2);
12693 current_binding_level->prep_state = 2;
5ff904cd 12694
c7e4ee3a 12695 return (prep_state == 1) ? TRUE : FALSE;
5ff904cd
JL		 12696}
12697
c7e4ee3a 12698/* Prepare expression.
5ff904cd 12699
c7e4ee3a
CB		 12700 This is called before any code is generated for the current block.
12701 It scans the expression, declares any temporaries that might be needed
12702 during evaluation of the expression, and stores those temporaries in
12703 the appropriate "hook" fields of the expression. `dest', if not NULL,
12704 specifies the destination that ffecom_expr_ will see, in case that
12705 helps avoid generating unused temporaries.
12706
12707 ~~Improve to avoid allocating unused temporaries by taking `dest'
12708 into account vis-a-vis aliasing requirements of complex/character
12709 functions. */
12710
12711void
12712ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
5ff904cd 12713{
c7e4ee3a
CB		 12714 ffeinfoBasictype bt;
12715 ffeinfoKindtype kt;
12716 ffetargetCharacterSize sz;
12717 tree tempvar = NULL_TREE;
5ff904cd 12718
c7e4ee3a
CB		 12719 assert (current_binding_level->prep_state < 2);
12720
12721 if (! expr)
12722 return;
12723
12724 bt = ffeinfo_basictype (ffebld_info (expr));
12725 kt = ffeinfo_kindtype (ffebld_info (expr));
12726 sz = ffeinfo_size (ffebld_info (expr));
12727
12728 /* Generate whatever temporaries are needed to represent the result
12729 of the expression. */
12730
12731 switch (ffebld_op (expr))
5ff904cd 12732 {
c7e4ee3a
CB		 12733 default:
12734 /* Don't make temps for SYMTER, CONTER, etc. */
12735 if (ffebld_arity (expr) == 0)
12736 break;
5ff904cd 12737
c7e4ee3a 12738 switch (bt)
5ff904cd 12739 {
c7e4ee3a
CB		 12740 case FFEINFO_basictypeCOMPLEX:
12741 if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12742 {
12743 ffesymbol s;
5ff904cd 12744
c7e4ee3a
CB		 12745 if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12746 break;
5ff904cd 12747
c7e4ee3a
CB		 12748 s = ffebld_symter (ffebld_left (expr));
12749 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12750 || ! ffesymbol_is_f2c (s))
12751 break;
12752 }
12753 else if (ffebld_op (expr) == FFEBLD_opPOWER)
12754 {
12755 /* Requires special treatment. There's no POW_CC function
12756 in libg2c, so POW_ZZ is used, which means we always
12757 need a double-complex temp, not a single-complex. */
12758 kt = FFEINFO_kindtypeREAL2;
12759 }
12760 else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12761 /* The other ops don't need temps for complex operands. */
12762 break;
5ff904cd 12763
c7e4ee3a
CB		 12764 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12765 REAL(C). See 19990325-0.f, routine `check', for cases. */
12766 tempvar = ffecom_make_tempvar ("complex",
12767 ffecom_tree_type
12768 [FFEINFO_basictypeCOMPLEX][kt],
12769 FFETARGET_charactersizeNONE,
12770 -1);
5ff904cd
JL		 12771 break;
12772
c7e4ee3a
CB		 12773 case FFEINFO_basictypeCHARACTER:
12774 if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12775 break;
12776
12777 if (sz == FFETARGET_charactersizeNONE)
12778 /* ~~Kludge alert! This should someday be fixed. */
12779 sz = 24;
12780
12781 tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
5ff904cd
JL		 12782 break;
12783
12784 default:
5ff904cd
JL		 12785 break;
12786 }
c7e4ee3a 12787 break;
5ff904cd 12788
c7e4ee3a
CB		 12789#ifdef HAHA
12790 case FFEBLD_opPOWER:
12791 {
12792 tree rtype, ltype;
12793 tree rtmp, ltmp, result;
5ff904cd 12794
c7e4ee3a
CB		 12795 ltype = ffecom_type_expr (ffebld_left (expr));
12796 rtype = ffecom_type_expr (ffebld_right (expr));
5ff904cd 12797
c7e4ee3a
CB		 12798 rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12799 ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12800 result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
5ff904cd 12801
c7e4ee3a
CB		 12802 tempvar = make_tree_vec (3);
12803 TREE_VEC_ELT (tempvar, 0) = rtmp;
12804 TREE_VEC_ELT (tempvar, 1) = ltmp;
12805 TREE_VEC_ELT (tempvar, 2) = result;
12806 }
12807 break;
12808#endif /* HAHA */
5ff904cd 12809
c7e4ee3a
CB		 12810 case FFEBLD_opCONCATENATE:
12811 {
12812 /* This gets special handling, because only one set of temps
12813 is needed for a tree of these -- the tree is treated as
12814 a flattened list of concatenations when generating code. */
5ff904cd 12815
c7e4ee3a
CB		 12816 ffecomConcatList_ catlist;
12817 tree ltmp, itmp, result;
12818 int count;
12819 int i;
5ff904cd 12820
c7e4ee3a
CB		 12821 catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12822 count = ffecom_concat_list_count_ (catlist);
5ff904cd 12823
c7e4ee3a
CB		 12824 if (count >= 2)
12825 {
12826 ltmp
12827 = ffecom_make_tempvar ("concat_len",
12828 ffecom_f2c_ftnlen_type_node,
12829 FFETARGET_charactersizeNONE, count);
12830 itmp
12831 = ffecom_make_tempvar ("concat_item",
12832 ffecom_f2c_address_type_node,
12833 FFETARGET_charactersizeNONE, count);
12834 result
12835 = ffecom_make_tempvar ("concat_res",
12836 char_type_node,
12837 ffecom_concat_list_maxlen_ (catlist),
12838 -1);
12839
12840 tempvar = make_tree_vec (3);
12841 TREE_VEC_ELT (tempvar, 0) = ltmp;
12842 TREE_VEC_ELT (tempvar, 1) = itmp;
12843 TREE_VEC_ELT (tempvar, 2) = result;
12844 }
5ff904cd 12845
c7e4ee3a
CB		 12846 for (i = 0; i < count; ++i)
12847 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12848 i));
5ff904cd 12849
c7e4ee3a 12850 ffecom_concat_list_kill_ (catlist);
5ff904cd 12851
c7e4ee3a
CB		 12852 if (tempvar)
12853 {
12854 ffebld_nonter_set_hook (expr, tempvar);
12855 current_binding_level->prep_state = 1;
12856 }
12857 }
12858 return;
5ff904cd 12859
c7e4ee3a
CB		 12860 case FFEBLD_opCONVERT:
12861 if (bt == FFEINFO_basictypeCHARACTER
12862 && ((ffebld_size_known (ffebld_left (expr))
12863 == FFETARGET_charactersizeNONE)
12864 || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12865 tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12866 break;
12867 }
5ff904cd 12868
c7e4ee3a
CB		 12869 if (tempvar)
12870 {
12871 ffebld_nonter_set_hook (expr, tempvar);
12872 current_binding_level->prep_state = 1;
12873 }
5ff904cd 12874
c7e4ee3a 12875 /* Prepare subexpressions for this expr. */
5ff904cd 12876
c7e4ee3a 12877 switch (ffebld_op (expr))
5ff904cd 12878 {
c7e4ee3a
CB		 12879 case FFEBLD_opPERCENT_LOC:
12880 ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12881 break;
5ff904cd 12882
c7e4ee3a
CB		 12883 case FFEBLD_opPERCENT_VAL:
12884 case FFEBLD_opPERCENT_REF:
12885 ffecom_prepare_expr (ffebld_left (expr));
12886 break;
5ff904cd 12887
c7e4ee3a
CB		 12888 case FFEBLD_opPERCENT_DESCR:
12889 ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12890 break;
5ff904cd 12891
c7e4ee3a
CB		 12892 case FFEBLD_opITEM:
12893 {
12894 ffebld item;
5ff904cd 12895
c7e4ee3a
CB		 12896 for (item = expr;
12897 item != NULL;
12898 item = ffebld_trail (item))
12899 if (ffebld_head (item) != NULL)
12900 ffecom_prepare_expr (ffebld_head (item));
12901 }
12902 break;
5ff904cd 12903
c7e4ee3a
CB		 12904 default:
12905 /* Need to handle character conversion specially. */
12906 switch (ffebld_arity (expr))
12907 {
12908 case 2:
12909 ffecom_prepare_expr (ffebld_left (expr));
12910 ffecom_prepare_expr (ffebld_right (expr));
12911 break;
5ff904cd 12912
c7e4ee3a
CB		 12913 case 1:
12914 ffecom_prepare_expr (ffebld_left (expr));
12915 break;
5ff904cd 12916
c7e4ee3a
CB		 12917 default:
12918 break;
12919 }
12920 }
5ff904cd 12921
c7e4ee3a 12922 return;
5ff904cd
JL		 12923}
12924
c7e4ee3a 12925/* Prepare expression for reading and writing.
5ff904cd 12926
c7e4ee3a
CB		 12927 Like ffecom_prepare_expr, except for expressions to be evaluated
12928 via ffecom_expr_rw. */
5ff904cd 12929
c7e4ee3a
CB		 12930void
12931ffecom_prepare_expr_rw (tree type, ffebld expr)
12932{
12933 /* This is all we support for now. */
12934 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
5ff904cd 12935
c7e4ee3a
CB		 12936 /* ~~For now, it seems to be the same thing. */
12937 ffecom_prepare_expr (expr);
12938 return;
12939}
5ff904cd 12940
c7e4ee3a 12941/* Prepare expression for writing.
5ff904cd 12942
c7e4ee3a
CB		 12943 Like ffecom_prepare_expr, except for expressions to be evaluated
12944 via ffecom_expr_w. */
5ff904cd
JL		 12945
12946void
c7e4ee3a 12947ffecom_prepare_expr_w (tree type, ffebld expr)
5ff904cd 12948{
c7e4ee3a
CB		 12949 /* This is all we support for now. */
12950 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
5ff904cd 12951
c7e4ee3a
CB		 12952 /* ~~For now, it seems to be the same thing. */
12953 ffecom_prepare_expr (expr);
12954 return;
12955}
5ff904cd 12956
c7e4ee3a 12957/* Prepare expression for returning.
5ff904cd 12958
c7e4ee3a
CB		 12959 Like ffecom_prepare_expr, except for expressions to be evaluated
12960 via ffecom_return_expr. */
5ff904cd 12961
c7e4ee3a
CB		 12962void
12963ffecom_prepare_return_expr (ffebld expr)
12964{
12965 assert (current_binding_level->prep_state < 2);
5ff904cd 12966
c7e4ee3a
CB		 12967 if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12968 && ffecom_is_altreturning_
12969 && expr != NULL)
12970 ffecom_prepare_expr (expr);
12971}
5ff904cd 12972
c7e4ee3a 12973/* Prepare pointer to expression.
5ff904cd 12974
c7e4ee3a
CB		 12975 Like ffecom_prepare_expr, except for expressions to be evaluated
12976 via ffecom_ptr_to_expr. */
5ff904cd 12977
c7e4ee3a
CB		 12978void
12979ffecom_prepare_ptr_to_expr (ffebld expr)
12980{
12981 /* ~~For now, it seems to be the same thing. */
12982 ffecom_prepare_expr (expr);
12983 return;
5ff904cd
JL		 12984}
12985
c7e4ee3a 12986/* Transform expression into constant pointer-to-expression tree.
5ff904cd 12987
c7e4ee3a
CB		 12988 If the expression can be transformed into a pointer-to-expression tree
12989 that is constant, that is done, and the tree returned. Else NULL_TREE
12990 is returned.
5ff904cd 12991
c7e4ee3a
CB		 12992 That way, a caller can attempt to provide compile-time initialization
12993 of a variable and, if that fails, *then* choose to start a new block
12994 and resort to using temporaries, as appropriate. */
5ff904cd 12995
c7e4ee3a
CB		 12996tree
12997ffecom_ptr_to_const_expr (ffebld expr)
5ff904cd 12998{
c7e4ee3a
CB		 12999 if (! expr)
13000 return integer_zero_node;
5ff904cd 13001
c7e4ee3a
CB		 13002 if (ffebld_op (expr) == FFEBLD_opANY)
13003 return error_mark_node;
5ff904cd 13004
c7e4ee3a
CB		 13005 if (ffebld_arity (expr) == 0
13006 && (ffebld_op (expr) != FFEBLD_opSYMTER
13007 || ffebld_where (expr) == FFEINFO_whereCOMMON
13008 || ffebld_where (expr) == FFEINFO_whereGLOBAL
13009 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
5ff904cd 13010 {
c7e4ee3a
CB		 13011 tree t;
13012
13013 t = ffecom_ptr_to_expr (expr);
13014 assert (TREE_CONSTANT (t));
13015 return t;
5ff904cd
JL		 13016 }
13017
c7e4ee3a
CB		 13018 return NULL_TREE;
13019}
13020
13021/* ffecom_return_expr -- Returns return-value expr given alt return expr
13022
13023 tree rtn; // NULL_TREE means use expand_null_return()
13024 ffebld expr; // NULL if no alt return expr to RETURN stmt
13025 rtn = ffecom_return_expr(expr);
13026
13027 Based on the program unit type and other info (like return function
13028 type, return master function type when alternate ENTRY points,
13029 whether subroutine has any alternate RETURN points, etc), returns the
13030 appropriate expression to be returned to the caller, or NULL_TREE
13031 meaning no return value or the caller expects it to be returned somewhere
13032 else (which is handled by other parts of this module). */
13033
5ff904cd 13034#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 13035tree
13036ffecom_return_expr (ffebld expr)
13037{
13038 tree rtn;
13039
13040 switch (ffecom_primary_entry_kind_)
5ff904cd 13041 {
c7e4ee3a
CB		 13042 case FFEINFO_kindPROGRAM:
13043 case FFEINFO_kindBLOCKDATA:
13044 rtn = NULL_TREE;
13045 break;
5ff904cd 13046
c7e4ee3a
CB		 13047 case FFEINFO_kindSUBROUTINE:
13048 if (!ffecom_is_altreturning_)
13049 rtn = NULL_TREE; /* No alt returns, never an expr. */
13050 else if (expr == NULL)
13051 rtn = integer_zero_node;
13052 else
13053 rtn = ffecom_expr (expr);
13054 break;
13055
13056 case FFEINFO_kindFUNCTION:
13057 if ((ffecom_multi_retval_ != NULL_TREE)
13058 || (ffesymbol_basictype (ffecom_primary_entry_)
13059 == FFEINFO_basictypeCHARACTER)
13060 || ((ffesymbol_basictype (ffecom_primary_entry_)
13061 == FFEINFO_basictypeCOMPLEX)
13062 && (ffecom_num_entrypoints_ == 0)
13063 && ffesymbol_is_f2c (ffecom_primary_entry_)))
13064 { /* Value is returned by direct assignment
13065 into (implicit) dummy. */
13066 rtn = NULL_TREE;
13067 break;
5ff904cd 13068 }
c7e4ee3a
CB		 13069 rtn = ffecom_func_result_;
13070#if 0
13071 /* Spurious error if RETURN happens before first reference! So elide
13072 this code. In particular, for debugging registry, rtn should always
13073 be non-null after all, but TREE_USED won't be set until we encounter
13074 a reference in the code. Perfectly okay (but weird) code that,
13075 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13076 this diagnostic for no reason. Have people use -O -Wuninitialized
13077 and leave it to the back end to find obviously weird cases. */
5ff904cd 13078
c7e4ee3a
CB		 13079 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13080 situation; if the return value has never been referenced, it won't
13081 have a tree under 2pass mode. */
13082 if ((rtn == NULL_TREE)
13083 || !TREE_USED (rtn))
13084 {
13085 ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13086 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13087 ffesymbol_where_column (ffecom_primary_entry_));
13088 ffebad_string (ffesymbol_text (ffesymbol_funcresult
13089 (ffecom_primary_entry_)));
13090 ffebad_finish ();
13091 }
5ff904cd 13092#endif
c7e4ee3a 13093 break;
5ff904cd 13094
c7e4ee3a
CB		 13095 default:
13096 assert ("bad unit kind" == NULL);
13097 case FFEINFO_kindANY:
13098 rtn = error_mark_node;
13099 break;
13100 }
5ff904cd 13101
c7e4ee3a
CB		 13102 return rtn;
13103}
5ff904cd 13104
c7e4ee3a
CB		 13105#endif
13106/* Do save_expr only if tree is not error_mark_node. */
5ff904cd
JL		 13107
13108#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 13109tree
13110ffecom_save_tree (tree t)
5ff904cd 13111{
c7e4ee3a 13112 return save_expr (t);
5ff904cd 13113}
5ff904cd 13114#endif
c7e4ee3a
CB		 13115
13116/* Start a compound statement (block). */
5ff904cd
JL		 13117
13118#if FFECOM_targetCURRENT == FFECOM_targetGCC
13119void
c7e4ee3a 13120ffecom_start_compstmt (void)
5ff904cd 13121{
c7e4ee3a 13122 bison_rule_pushlevel_ ();
5ff904cd 13123}
c7e4ee3a 13124#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
5ff904cd 13125
c7e4ee3a 13126/* Public entry point for front end to access start_decl. */
5ff904cd
JL		 13127
13128#if FFECOM_targetCURRENT == FFECOM_targetGCC
13129tree
c7e4ee3a 13130ffecom_start_decl (tree decl, bool is_initialized)
5ff904cd 13131{
c7e4ee3a
CB		 13132 DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13133 return start_decl (decl, FALSE);
13134}
5ff904cd 13135
c7e4ee3a
CB		 13136#endif
13137/* ffecom_sym_commit -- Symbol's state being committed to reality
5ff904cd 13138
c7e4ee3a
CB		 13139 ffesymbol s;
13140 ffecom_sym_commit(s);
5ff904cd 13141
c7e4ee3a
CB		 13142 Does whatever the backend needs when a symbol is committed after having
13143 been backtrackable for a period of time. */
5ff904cd 13144
c7e4ee3a
CB		 13145#if FFECOM_targetCURRENT == FFECOM_targetGCC
13146void
13147ffecom_sym_commit (ffesymbol s UNUSED)
13148{
13149 assert (!ffesymbol_retractable ());
13150}
5ff904cd 13151
c7e4ee3a
CB		 13152#endif
13153/* ffecom_sym_end_transition -- Perform end transition on all symbols
5ff904cd 13154
c7e4ee3a 13155 ffecom_sym_end_transition();
5ff904cd 13156
c7e4ee3a
CB		 13157 Does backend-specific stuff and also calls ffest_sym_end_transition
13158 to do the necessary FFE stuff.
5ff904cd 13159
c7e4ee3a
CB		 13160 Backtracking is never enabled when this fn is called, so don't worry
13161 about it. */
5ff904cd 13162
c7e4ee3a
CB		 13163ffesymbol
13164ffecom_sym_end_transition (ffesymbol s)
13165{
13166 ffestorag st;
5ff904cd 13167
c7e4ee3a 13168 assert (!ffesymbol_retractable ());
5ff904cd 13169
c7e4ee3a 13170 s = ffest_sym_end_transition (s);
5ff904cd 13171
c7e4ee3a
CB		 13172#if FFECOM_targetCURRENT == FFECOM_targetGCC
13173 if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13174 && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13175 {
13176 ffecom_list_blockdata_
13177 = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13178 FFEINTRIN_specNONE,
13179 FFEINTRIN_impNONE),
13180 ffecom_list_blockdata_);
5ff904cd 13181 }
5ff904cd 13182#endif
5ff904cd 13183
c7e4ee3a
CB		 13184 /* This is where we finally notice that a symbol has partial initialization
13185 and finalize it. */
5ff904cd 13186
c7e4ee3a
CB		 13187 if (ffesymbol_accretion (s) != NULL)
13188 {
13189 assert (ffesymbol_init (s) == NULL);
13190 ffecom_notify_init_symbol (s);
13191 }
13192 else if (((st = ffesymbol_storage (s)) != NULL)
13193 && ((st = ffestorag_parent (st)) != NULL)
13194 && (ffestorag_accretion (st) != NULL))
13195 {
13196 assert (ffestorag_init (st) == NULL);
13197 ffecom_notify_init_storage (st);
13198 }
5ff904cd
JL		 13199
13200#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 13201 if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13202 && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13203 && (ffesymbol_storage (s) != NULL))
13204 {
13205 ffecom_list_common_
13206 = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13207 FFEINTRIN_specNONE,
13208 FFEINTRIN_impNONE),
13209 ffecom_list_common_);
13210 }
13211#endif
5ff904cd 13212
c7e4ee3a
CB		 13213 return s;
13214}
5ff904cd 13215
c7e4ee3a 13216/* ffecom_sym_exec_transition -- Perform exec transition on all symbols
5ff904cd 13217
c7e4ee3a 13218 ffecom_sym_exec_transition();
5ff904cd 13219
c7e4ee3a
CB		 13220 Does backend-specific stuff and also calls ffest_sym_exec_transition
13221 to do the necessary FFE stuff.
5ff904cd 13222
c7e4ee3a
CB		 13223 See the long-winded description in ffecom_sym_learned for info
13224 on handling the situation where backtracking is inhibited. */
5ff904cd 13225
c7e4ee3a
CB		 13226ffesymbol
13227ffecom_sym_exec_transition (ffesymbol s)
13228{
13229 s = ffest_sym_exec_transition (s);
5ff904cd 13230
c7e4ee3a
CB		 13231 return s;
13232}
5ff904cd 13233
c7e4ee3a 13234/* ffecom_sym_learned -- Initial or more info gained on symbol after exec
5ff904cd 13235
c7e4ee3a
CB		 13236 ffesymbol s;
13237 s = ffecom_sym_learned(s);
5ff904cd 13238
c7e4ee3a
CB		 13239 Called when a new symbol is seen after the exec transition or when more
13240 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
13241 it arrives here is that all its latest info is updated already, so its
13242 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13243 field filled in if its gone through here or exec_transition first, and
13244 so on.
5ff904cd 13245
c7e4ee3a
CB		 13246 The backend probably wants to check ffesymbol_retractable() to see if
13247 backtracking is in effect. If so, the FFE's changes to the symbol may
13248 be retracted (undone) or committed (ratified), at which time the
13249 appropriate ffecom_sym_retract or _commit function will be called
13250 for that function.
5ff904cd 13251
c7e4ee3a
CB		 13252 If the backend has its own backtracking mechanism, great, use it so that
13253 committal is a simple operation. Though it doesn't make much difference,
13254 I suppose: the reason for tentative symbol evolution in the FFE is to
13255 enable error detection in weird incorrect statements early and to disable
13256 incorrect error detection on a correct statement. The backend is not
13257 likely to introduce any information that'll get involved in these
13258 considerations, so it is probably just fine that the implementation
13259 model for this fn and for _exec_transition is to not do anything
13260 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13261 and instead wait until ffecom_sym_commit is called (which it never
13262 will be as long as we're using ambiguity-detecting statement analysis in
13263 the FFE, which we are initially to shake out the code, but don't depend
13264 on this), otherwise go ahead and do whatever is needed.
5ff904cd 13265
c7e4ee3a
CB		 13266 In essence, then, when this fn and _exec_transition get called while
13267 backtracking is enabled, a general mechanism would be to flag which (or
13268 both) of these were called (and in what order? neat question as to what
13269 might happen that I'm too lame to think through right now) and then when
13270 _commit is called reproduce the original calling sequence, if any, for
13271 the two fns (at which point backtracking will, of course, be disabled). */
5ff904cd 13272
c7e4ee3a
CB		 13273ffesymbol
13274ffecom_sym_learned (ffesymbol s)
13275{
13276 ffestorag_exec_layout (s);
5ff904cd 13277
c7e4ee3a 13278 return s;
5ff904cd
JL		 13279}
13280
c7e4ee3a 13281/* ffecom_sym_retract -- Symbol's state being retracted from reality
5ff904cd 13282
c7e4ee3a
CB		 13283 ffesymbol s;
13284 ffecom_sym_retract(s);
5ff904cd 13285
c7e4ee3a
CB		 13286 Does whatever the backend needs when a symbol is retracted after having
13287 been backtrackable for a period of time. */
5ff904cd
JL		 13288
13289#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 13290void
13291ffecom_sym_retract (ffesymbol s UNUSED)
5ff904cd 13292{
c7e4ee3a 13293 assert (!ffesymbol_retractable ());
5ff904cd 13294
c7e4ee3a
CB		 13295#if 0 /* GCC doesn't commit any backtrackable sins,
13296 so nothing needed here. */
13297 switch (ffesymbol_hook (s).state)
5ff904cd 13298 {
c7e4ee3a 13299 case 0: /* nothing happened yet. */
5ff904cd
JL		 13300 break;
13301
c7e4ee3a 13302 case 1: /* exec transition happened. */
5ff904cd
JL		 13303 break;
13304
c7e4ee3a
CB		 13305 case 2: /* learned happened. */
13306 break;
5ff904cd 13307
c7e4ee3a
CB		 13308 case 3: /* learned then exec. */
13309 break;
13310
13311 case 4: /* exec then learned. */
5ff904cd
JL		 13312 break;
13313
13314 default:
c7e4ee3a 13315 assert ("bad hook state" == NULL);
5ff904cd
JL		 13316 break;
13317 }
c7e4ee3a
CB		 13318#endif
13319}
5ff904cd 13320
c7e4ee3a
CB		 13321#endif
13322/* Create temporary gcc label. */
13323
13324#if FFECOM_targetCURRENT == FFECOM_targetGCC
13325tree
13326ffecom_temp_label ()
13327{
13328 tree glabel;
13329 static int mynumber = 0;
13330
13331 glabel = build_decl (LABEL_DECL,
13332 ffecom_get_invented_identifier ("__g77_label_%d",
13333 NULL,
13334 mynumber++),
13335 void_type_node);
13336 DECL_CONTEXT (glabel) = current_function_decl;
13337 DECL_MODE (glabel) = VOIDmode;
13338
13339 return glabel;
5ff904cd
JL		 13340}
13341
13342#endif
c7e4ee3a
CB		 13343/* Return an expression that is usable as an arg in a conditional context
13344 (IF, DO WHILE, .NOT., and so on).
13345
13346 Use the one provided for the back end as of >2.6.0. */
5ff904cd
JL		 13347
13348#if FFECOM_targetCURRENT == FFECOM_targetGCC
a2977d2d 13349tree
c7e4ee3a 13350ffecom_truth_value (tree expr)
5ff904cd 13351{
c7e4ee3a 13352 return truthvalue_conversion (expr);
5ff904cd 13353}
c7e4ee3a 13354
5ff904cd 13355#endif
c7e4ee3a
CB		 13356/* Return the inversion of a truth value (the inversion of what
13357 ffecom_truth_value builds).
5ff904cd 13358
c7e4ee3a
CB		 13359 Apparently invert_truthvalue, which is properly in the back end, is
13360 enough for now, so just use it. */
5ff904cd
JL		 13361
13362#if FFECOM_targetCURRENT == FFECOM_targetGCC
13363tree
c7e4ee3a 13364ffecom_truth_value_invert (tree expr)
5ff904cd 13365{
c7e4ee3a 13366 return invert_truthvalue (ffecom_truth_value (expr));
5ff904cd
JL		 13367}
13368
13369#endif
5ff904cd 13370
c7e4ee3a
CB		 13371/* Return the tree that is the type of the expression, as would be
13372 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13373 transforming the expression, generating temporaries, etc. */
5ff904cd 13374
c7e4ee3a
CB		 13375tree
13376ffecom_type_expr (ffebld expr)
13377{
13378 ffeinfoBasictype bt;
13379 ffeinfoKindtype kt;
13380 tree tree_type;
13381
13382 assert (expr != NULL);
13383
13384 bt = ffeinfo_basictype (ffebld_info (expr));
13385 kt = ffeinfo_kindtype (ffebld_info (expr));
13386 tree_type = ffecom_tree_type[bt][kt];
13387
13388 switch (ffebld_op (expr))
13389 {
13390 case FFEBLD_opCONTER:
13391 case FFEBLD_opSYMTER:
13392 case FFEBLD_opARRAYREF:
13393 case FFEBLD_opUPLUS:
13394 case FFEBLD_opPAREN:
13395 case FFEBLD_opUMINUS:
13396 case FFEBLD_opADD:
13397 case FFEBLD_opSUBTRACT:
13398 case FFEBLD_opMULTIPLY:
13399 case FFEBLD_opDIVIDE:
13400 case FFEBLD_opPOWER:
13401 case FFEBLD_opNOT:
13402 case FFEBLD_opFUNCREF:
13403 case FFEBLD_opSUBRREF:
13404 case FFEBLD_opAND:
13405 case FFEBLD_opOR:
13406 case FFEBLD_opXOR:
13407 case FFEBLD_opNEQV:
13408 case FFEBLD_opEQV:
13409 case FFEBLD_opCONVERT:
13410 case FFEBLD_opLT:
13411 case FFEBLD_opLE:
13412 case FFEBLD_opEQ:
13413 case FFEBLD_opNE:
13414 case FFEBLD_opGT:
13415 case FFEBLD_opGE:
13416 case FFEBLD_opPERCENT_LOC:
13417 return tree_type;
13418
13419 case FFEBLD_opACCTER:
13420 case FFEBLD_opARRTER:
13421 case FFEBLD_opITEM:
13422 case FFEBLD_opSTAR:
13423 case FFEBLD_opBOUNDS:
13424 case FFEBLD_opREPEAT:
13425 case FFEBLD_opLABTER:
13426 case FFEBLD_opLABTOK:
13427 case FFEBLD_opIMPDO:
13428 case FFEBLD_opCONCATENATE:
13429 case FFEBLD_opSUBSTR:
13430 default:
13431 assert ("bad op for ffecom_type_expr" == NULL);
13432 /* Fall through. */
13433 case FFEBLD_opANY:
13434 return error_mark_node;
13435 }
13436}
13437
13438/* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13439
13440 If the PARM_DECL already exists, return it, else create it. It's an
13441 integer_type_node argument for the master function that implements a
13442 subroutine or function with more than one entrypoint and is bound at
13443 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13444 first ENTRY statement, and so on). */
5ff904cd
JL		 13445
13446#if FFECOM_targetCURRENT == FFECOM_targetGCC
c7e4ee3a
CB		 13447tree
13448ffecom_which_entrypoint_decl ()
5ff904cd 13449{
c7e4ee3a
CB		 13450 assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13451
13452 return ffecom_which_entrypoint_decl_;
5ff904cd
JL		 13453}
13454
13455#endif
c7e4ee3a
CB		 13456\f
13457/* The following sections consists of private and public functions
13458 that have the same names and perform roughly the same functions
13459 as counterparts in the C front end. Changes in the C front end
13460 might affect how things should be done here. Only functions
13461 needed by the back end should be public here; the rest should
13462 be private (static in the C sense). Functions needed by other
13463 g77 front-end modules should be accessed by them via public
13464 ffecom_* names, which should themselves call private versions
13465 in this section so the private versions are easy to recognize
13466 when upgrading to a new gcc and finding interesting changes
13467 in the front end.
5ff904cd 13468
c7e4ee3a
CB		 13469 Functions named after rule "foo:" in c-parse.y are named
13470 "bison_rule_foo_" so they are easy to find. */
5ff904cd 13471
c7e4ee3a 13472#if FFECOM_targetCURRENT == FFECOM_targetGCC
5ff904cd 13473
c7e4ee3a
CB		 13474static void
13475bison_rule_pushlevel_ ()
13476{
13477 emit_line_note (input_filename, lineno);
13478 pushlevel (0);
13479 clear_last_expr ();
13480 push_momentary ();
13481 expand_start_bindings (0);
13482}
5ff904cd 13483
c7e4ee3a
CB		 13484static tree
13485bison_rule_compstmt_ ()
5ff904cd 13486{
c7e4ee3a
CB		 13487 tree t;
13488 int keep = kept_level_p ();
5ff904cd 13489
c7e4ee3a
CB		 13490 /* Make the temps go away. */
13491 if (! keep)
13492 current_binding_level->names = NULL_TREE;
5ff904cd 13493
c7e4ee3a
CB		 13494 emit_line_note (input_filename, lineno);
13495 expand_end_bindings (getdecls (), keep, 0);
13496 t = poplevel (keep, 1, 0);
13497 pop_momentary ();
5ff904cd 13498
c7e4ee3a
CB		 13499 return t;
13500}
5ff904cd 13501
c7e4ee3a
CB		 13502/* Return a definition for a builtin function named NAME and whose data type
13503 is TYPE. TYPE should be a function type with argument types.
13504 FUNCTION_CODE tells later passes how to compile calls to this function.
13505 See tree.h for its possible values.
5ff904cd 13506
c7e4ee3a
CB		 13507 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13508 the name to be called if we can't opencode the function. */
5ff904cd 13509
c7e4ee3a
CB		 13510static tree
13511builtin_function (const char *name, tree type,
13512 enum built_in_function function_code,
13513 const char *library_name)
13514{
13515 tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13516 DECL_EXTERNAL (decl) = 1;
13517 TREE_PUBLIC (decl) = 1;
13518 if (library_name)
13519 DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13520 make_decl_rtl (decl, NULL_PTR, 1);
13521 pushdecl (decl);
13522 if (function_code != NOT_BUILT_IN)
5ff904cd 13523 {
c7e4ee3a
CB		 13524 DECL_BUILT_IN (decl) = 1;
13525 DECL_FUNCTION_CODE (decl) = function_code;
5ff904cd 13526 }
5ff904cd 13527
c7e4ee3a 13528 return decl;
5ff904cd
JL		 13529}
13530
c7e4ee3a
CB		 13531/* Handle when a new declaration NEWDECL
13532 has the same name as an old one OLDDECL
13533 in the same binding contour.
13534 Prints an error message if appropriate.
5ff904cd 13535
c7e4ee3a
CB		 13536 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13537 Otherwise, return 0. */
5ff904cd 13538
c7e4ee3a
CB		 13539static int
13540duplicate_decls (tree newdecl, tree olddecl)
5ff904cd 13541{
c7e4ee3a
CB		 13542 int types_match = 1;
13543 int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13544 && DECL_INITIAL (newdecl) != 0);
13545 tree oldtype = TREE_TYPE (olddecl);
13546 tree newtype = TREE_TYPE (newdecl);
5ff904cd 13547
c7e4ee3a
CB		 13548 if (olddecl == newdecl)
13549 return 1;
5ff904cd 13550
c7e4ee3a
CB		 13551 if (TREE_CODE (newtype) == ERROR_MARK
13552 || TREE_CODE (oldtype) == ERROR_MARK)
13553 types_match = 0;
5ff904cd 13554
c7e4ee3a
CB		 13555 /* New decl is completely inconsistent with the old one =>
13556 tell caller to replace the old one.
13557 This is always an error except in the case of shadowing a builtin. */
13558 if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13559 return 0;
5ff904cd 13560
c7e4ee3a
CB		 13561 /* For real parm decl following a forward decl,
13562 return 1 so old decl will be reused. */
13563 if (types_match && TREE_CODE (newdecl) == PARM_DECL
13564 && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13565 return 1;
5ff904cd 13566
c7e4ee3a
CB		 13567 /* The new declaration is the same kind of object as the old one.
13568 The declarations may partially match. Print warnings if they don't
13569 match enough. Ultimately, copy most of the information from the new
13570 decl to the old one, and keep using the old one. */
5ff904cd 13571
c7e4ee3a
CB		 13572 if (TREE_CODE (olddecl) == FUNCTION_DECL
13573 && DECL_BUILT_IN (olddecl))
13574 {
13575 /* A function declaration for a built-in function. */
13576 if (!TREE_PUBLIC (newdecl))
13577 return 0;
13578 else if (!types_match)
13579 {
13580 /* Accept the return type of the new declaration if same modes. */
13581 tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13582 tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
5ff904cd 13583
c7e4ee3a
CB		 13584 /* Make sure we put the new type in the same obstack as the old ones.
13585 If the old types are not both in the same obstack, use the
13586 permanent one. */
13587 if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
13588 push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
13589 else
13590 {
13591 push_obstacks_nochange ();
13592 end_temporary_allocation ();
13593 }
5ff904cd 13594
c7e4ee3a
CB		 13595 if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13596 {
13597 /* Function types may be shared, so we can't just modify
13598 the return type of olddecl's function type. */
13599 tree newtype
13600 = build_function_type (newreturntype,
13601 TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
5ff904cd 13602
c7e4ee3a
CB		 13603 types_match = 1;
13604 if (types_match)
13605 TREE_TYPE (olddecl) = newtype;
13606 }
5ff904cd 13607
c7e4ee3a
CB		 13608 pop_obstacks ();
13609 }
13610 if (!types_match)
13611 return 0;
13612 }
13613 else if (TREE_CODE (olddecl) == FUNCTION_DECL
13614 && DECL_SOURCE_LINE (olddecl) == 0)
5ff904cd 13615 {
c7e4ee3a
CB		 13616 /* A function declaration for a predeclared function
13617 that isn't actually built in. */
13618 if (!TREE_PUBLIC (newdecl))
13619 return 0;
13620 else if (!types_match)
13621 {
13622 /* If the types don't match, preserve volatility indication.
13623 Later on, we will discard everything else about the
13624 default declaration. */
13625 TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13626 }
13627 }
5ff904cd 13628
c7e4ee3a
CB		 13629 /* Copy all the DECL_... slots specified in the new decl
13630 except for any that we copy here from the old type.
5ff904cd 13631
c7e4ee3a
CB		 13632 Past this point, we don't change OLDTYPE and NEWTYPE
13633 even if we change the types of NEWDECL and OLDDECL. */
5ff904cd 13634
c7e4ee3a
CB		 13635 if (types_match)
13636 {
13637 /* Make sure we put the new type in the same obstack as the old ones.
13638 If the old types are not both in the same obstack, use the permanent
13639 one. */
13640 if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
13641 push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
13642 else
13643 {
13644 push_obstacks_nochange ();
13645 end_temporary_allocation ();
13646 }
5ff904cd 13647
c7e4ee3a
CB		 13648 /* Merge the data types specified in the two decls. */
13649 if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13650 TREE_TYPE (newdecl)
13651 = TREE_TYPE (olddecl)
13652 = TREE_TYPE (newdecl);
5ff904cd 13653
c7e4ee3a
CB		 13654 /* Lay the type out, unless already done. */
13655 if (oldtype != TREE_TYPE (newdecl))
13656 {
13657 if (TREE_TYPE (newdecl) != error_mark_node)
13658 layout_type (TREE_TYPE (newdecl));
13659 if (TREE_CODE (newdecl) != FUNCTION_DECL
13660 && TREE_CODE (newdecl) != TYPE_DECL
13661 && TREE_CODE (newdecl) != CONST_DECL)
13662 layout_decl (newdecl, 0);
13663 }
13664 else
13665 {
13666 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13667 DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13668 if (TREE_CODE (olddecl) != FUNCTION_DECL)
13669 if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13670 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13671 }
5ff904cd 13672
c7e4ee3a
CB		 13673 /* Keep the old rtl since we can safely use it. */
13674 DECL_RTL (newdecl) = DECL_RTL (olddecl);
5ff904cd 13675
c7e4ee3a
CB		 13676 /* Merge the type qualifiers. */
13677 if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13678 && !TREE_THIS_VOLATILE (newdecl))
13679 TREE_THIS_VOLATILE (olddecl) = 0;
13680 if (TREE_READONLY (newdecl))
13681 TREE_READONLY (olddecl) = 1;
13682 if (TREE_THIS_VOLATILE (newdecl))
13683 {
13684 TREE_THIS_VOLATILE (olddecl) = 1;
13685 if (TREE_CODE (newdecl) == VAR_DECL)
13686 make_var_volatile (newdecl);
13687 }
5ff904cd 13688
c7e4ee3a
CB		 13689 /* Keep source location of definition rather than declaration.
13690 Likewise, keep decl at outer scope. */
13691 if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13692 || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13693 {
13694 DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13695 DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
5ff904cd 13696
c7e4ee3a
CB		 13697 if (DECL_CONTEXT (olddecl) == 0
13698 && TREE_CODE (newdecl) != FUNCTION_DECL)
13699 DECL_CONTEXT (newdecl) = 0;
13700 }
5ff904cd 13701
c7e4ee3a
CB		 13702 /* Merge the unused-warning information. */
13703 if (DECL_IN_SYSTEM_HEADER (olddecl))
13704 DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13705 else if (DECL_IN_SYSTEM_HEADER (newdecl))
13706 DECL_IN_SYSTEM_HEADER (olddecl) = 1;
5ff904cd 13707
c7e4ee3a
CB		 13708 /* Merge the initialization information. */
13709 if (DECL_INITIAL (newdecl) == 0)
13710 DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
5ff904cd 13711
c7e4ee3a
CB		 13712 /* Merge the section attribute.
13713 We want to issue an error if the sections conflict but that must be
13714 done later in decl_attributes since we are called before attributes
13715 are assigned. */
13716 if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13717 DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
5ff904cd 13718
c7e4ee3a
CB		 13719#if BUILT_FOR_270
13720 if (TREE_CODE (newdecl) == FUNCTION_DECL)
13721 {
13722 DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13723 DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13724 }
5ff904cd 13725#endif
5ff904cd 13726
c7e4ee3a
CB		 13727 pop_obstacks ();
13728 }
13729 /* If cannot merge, then use the new type and qualifiers,
13730 and don't preserve the old rtl. */
13731 else
13732 {
13733 TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13734 TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13735 TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13736 TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13737 }
5ff904cd 13738
c7e4ee3a
CB		 13739 /* Merge the storage class information. */
13740 /* For functions, static overrides non-static. */
13741 if (TREE_CODE (newdecl) == FUNCTION_DECL)
13742 {
13743 TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13744 /* This is since we don't automatically
13745 copy the attributes of NEWDECL into OLDDECL. */
13746 TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13747 /* If this clears `static', clear it in the identifier too. */
13748 if (! TREE_PUBLIC (olddecl))
13749 TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13750 }
13751 if (DECL_EXTERNAL (newdecl))
13752 {
13753 TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13754 DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13755 /* An extern decl does not override previous storage class. */
13756 TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13757 }
13758 else
13759 {
13760 TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13761 TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13762 }
5ff904cd 13763
c7e4ee3a
CB		 13764 /* If either decl says `inline', this fn is inline,
13765 unless its definition was passed already. */
13766 if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13767 DECL_INLINE (olddecl) = 1;
13768 DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
5ff904cd 13769
c7e4ee3a
CB		 13770 /* Get rid of any built-in function if new arg types don't match it
13771 or if we have a function definition. */
13772 if (TREE_CODE (newdecl) == FUNCTION_DECL
13773 && DECL_BUILT_IN (olddecl)
13774 && (!types_match || new_is_definition))
13775 {
13776 TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13777 DECL_BUILT_IN (olddecl) = 0;
13778 }
5ff904cd 13779
c7e4ee3a
CB		 13780 /* If redeclaring a builtin function, and not a definition,
13781 it stays built in.
13782 Also preserve various other info from the definition. */
13783 if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13784 {
13785 if (DECL_BUILT_IN (olddecl))
13786 {
13787 DECL_BUILT_IN (newdecl) = 1;
13788 DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13789 }
13790 else
13791 DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
5ff904cd 13792
c7e4ee3a
CB		 13793 DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13794 DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13795 DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13796 DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13797 }
5ff904cd 13798
c7e4ee3a
CB		 13799 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13800 But preserve olddecl's DECL_UID. */
13801 {
13802 register unsigned olddecl_uid = DECL_UID (olddecl);
5ff904cd 13803
c7e4ee3a
CB		 13804 memcpy ((char *) olddecl + sizeof (struct tree_common),
13805 (char *) newdecl + sizeof (struct tree_common),
13806 sizeof (struct tree_decl) - sizeof (struct tree_common));
13807 DECL_UID (olddecl) = olddecl_uid;
13808 }
5ff904cd 13809
c7e4ee3a 13810 return 1;
5ff904cd
JL		 13811}
13812
c7e4ee3a
CB		 13813/* Finish processing of a declaration;
13814 install its initial value.
13815 If the length of an array type is not known before,
13816 it must be determined now, from the initial value, or it is an error. */
13817
5ff904cd 13818static void
c7e4ee3a 13819finish_decl (tree decl, tree init, bool is_top_level)
5ff904cd 13820{
c7e4ee3a
CB		 13821 register tree type = TREE_TYPE (decl);
13822 int was_incomplete = (DECL_SIZE (decl) == 0);
13823 int temporary = allocation_temporary_p ();
13824 bool at_top_level = (current_binding_level == global_binding_level);
13825 bool top_level = is_top_level || at_top_level;
5ff904cd 13826
c7e4ee3a
CB		 13827 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13828 level anyway. */
13829 assert (!is_top_level || !at_top_level);
5ff904cd 13830
c7e4ee3a
CB		 13831 if (TREE_CODE (decl) == PARM_DECL)
13832 assert (init == NULL_TREE);
13833 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13834 overlaps DECL_ARG_TYPE. */
13835 else if (init == NULL_TREE)
13836 assert (DECL_INITIAL (decl) == NULL_TREE);
13837 else
13838 assert (DECL_INITIAL (decl) == error_mark_node);
5ff904cd 13839
c7e4ee3a 13840 if (init != NULL_TREE)
5ff904cd 13841 {
c7e4ee3a
CB		 13842 if (TREE_CODE (decl) != TYPE_DECL)
13843 DECL_INITIAL (decl) = init;
13844 else
13845 {
13846 /* typedef foo = bar; store the type of bar as the type of foo. */
13847 TREE_TYPE (decl) = TREE_TYPE (init);
13848 DECL_INITIAL (decl) = init = 0;
13849 }
5ff904cd
JL		 13850 }
13851
c7e4ee3a
CB		 13852 /* Pop back to the obstack that is current for this binding level. This is
13853 because MAXINDEX, rtl, etc. to be made below must go in the permanent
13854 obstack. But don't discard the temporary data yet. */
13855 pop_obstacks ();
5ff904cd 13856
c7e4ee3a 13857 /* Deduce size of array from initialization, if not already known */
5ff904cd 13858
c7e4ee3a
CB		 13859 if (TREE_CODE (type) == ARRAY_TYPE
13860 && TYPE_DOMAIN (type) == 0
13861 && TREE_CODE (decl) != TYPE_DECL)
13862 {
13863 assert (top_level);
13864 assert (was_incomplete);
5ff904cd 13865
c7e4ee3a
CB		 13866 layout_decl (decl, 0);
13867 }
5ff904cd 13868
c7e4ee3a
CB		 13869 if (TREE_CODE (decl) == VAR_DECL)
13870 {
13871 if (DECL_SIZE (decl) == NULL_TREE
13872 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13873 layout_decl (decl, 0);
5ff904cd 13874
c7e4ee3a
CB		 13875 if (DECL_SIZE (decl) == NULL_TREE
13876 && (TREE_STATIC (decl)
13877 ?
13878 /* A static variable with an incomplete type is an error if it is
13879 initialized. Also if it is not file scope. Otherwise, let it
13880 through, but if it is not `extern' then it may cause an error
13881 message later. */
13882 (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13883 :
13884 /* An automatic variable with an incomplete type is an error. */
13885 !DECL_EXTERNAL (decl)))
13886 {
13887 assert ("storage size not known" == NULL);
13888 abort ();
13889 }
5ff904cd 13890
c7e4ee3a
CB		 13891 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13892 && (DECL_SIZE (decl) != 0)
13893 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13894 {
13895 assert ("storage size not constant" == NULL);
13896 abort ();
13897 }
13898 }
5ff904cd 13899
c7e4ee3a
CB		 13900 /* Output the assembler code and/or RTL code for variables and functions,
13901 unless the type is an undefined structure or union. If not, it will get
13902 done when the type is completed. */
5ff904cd 13903
c7e4ee3a 13904 if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
5ff904cd 13905 {
c7e4ee3a
CB		 13906 rest_of_decl_compilation (decl, NULL,
13907 DECL_CONTEXT (decl) == 0,
13908 0);
5ff904cd 13909
c7e4ee3a
CB		 13910 if (DECL_CONTEXT (decl) != 0)
13911 {
13912 /* Recompute the RTL of a local array now if it used to be an
13913 incomplete type. */
13914 if (was_incomplete
13915 && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
5ff904cd 13916 {
c7e4ee3a
CB		 13917 /* If we used it already as memory, it must stay in memory. */
13918 TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13919 /* If it's still incomplete now, no init will save it. */
13920 if (DECL_SIZE (decl) == 0)
13921 DECL_INITIAL (decl) = 0;
13922 expand_decl (decl);
5ff904cd 13923 }
c7e4ee3a
CB		 13924 /* Compute and store the initial value. */
13925 if (TREE_CODE (decl) != FUNCTION_DECL)
13926 expand_decl_init (decl);
13927 }
13928 }
13929 else if (TREE_CODE (decl) == TYPE_DECL)
13930 {
13931 rest_of_decl_compilation (decl, NULL_PTR,
13932 DECL_CONTEXT (decl) == 0,
13933 0);
13934 }
5ff904cd 13935
c7e4ee3a
CB		 13936 /* This test used to include TREE_PERMANENT, however, we have the same
13937 problem with initializers at the function level. Such initializers get
13938 saved until the end of the function on the momentary_obstack. */
13939 if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
13940 && temporary
13941 /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
13942 DECL_ARG_TYPE. */
13943 && TREE_CODE (decl) != PARM_DECL)
13944 {
13945 /* We need to remember that this array HAD an initialization, but
13946 discard the actual temporary nodes, since we can't have a permanent
13947 node keep pointing to them. */
13948 /* We make an exception for inline functions, since it's normal for a
13949 local extern redeclaration of an inline function to have a copy of
13950 the top-level decl's DECL_INLINE. */
13951 if ((DECL_INITIAL (decl) != 0)
13952 && (DECL_INITIAL (decl) != error_mark_node))
13953 {
13954 /* If this is a const variable, then preserve the
13955 initializer instead of discarding it so that we can optimize
13956 references to it. */
13957 /* This test used to include TREE_STATIC, but this won't be set
13958 for function level initializers. */
13959 if (TREE_READONLY (decl))
5ff904cd 13960 {
c7e4ee3a
CB		 13961 preserve_initializer ();
13962 /* Hack? Set the permanent bit for something that is
13963 permanent, but not on the permenent obstack, so as to
13964 convince output_constant_def to make its rtl on the
13965 permanent obstack. */
13966 TREE_PERMANENT (DECL_INITIAL (decl)) = 1;
5ff904cd 13967
c7e4ee3a
CB		 13968 /* The initializer and DECL must have the same (or equivalent
13969 types), but if the initializer is a STRING_CST, its type
13970 might not be on the right obstack, so copy the type
13971 of DECL. */
13972 TREE_TYPE (DECL_INITIAL (decl)) = type;
5ff904cd 13973 }
c7e4ee3a
CB		 13974 else
13975 DECL_INITIAL (decl) = error_mark_node;
5ff904cd 13976 }
5ff904cd 13977 }
c7e4ee3a
CB		 13978
13979 /* If requested, warn about definitions of large data objects. */
13980
13981 if (warn_larger_than
13982 && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL)
13983 && !DECL_EXTERNAL (decl))
5ff904cd 13984 {
c7e4ee3a
CB		 13985 register tree decl_size = DECL_SIZE (decl);
13986
13987 if (decl_size && TREE_CODE (decl_size) == INTEGER_CST)
5ff904cd 13988 {
c7e4ee3a
CB		 13989 unsigned units = TREE_INT_CST_LOW (decl_size) / BITS_PER_UNIT;
13990
13991 if (units > larger_than_size)
13992 warning_with_decl (decl, "size of `%s' is %u bytes", units);
5ff904cd
JL		 13993 }
13994 }
13995
c7e4ee3a
CB		 13996 /* If we have gone back from temporary to permanent allocation, actually
13997 free the temporary space that we no longer need. */
13998 if (temporary && !allocation_temporary_p ())
13999 permanent_allocation (0);
5ff904cd 14000
c7e4ee3a
CB		 14001 /* At the end of a declaration, throw away any variable type sizes of types
14002 defined inside that declaration. There is no use computing them in the
14003 following function definition. */
14004 if (current_binding_level == global_binding_level)
14005 get_pending_sizes ();
14006}
5ff904cd 14007
c7e4ee3a
CB		 14008/* Finish up a function declaration and compile that function
14009 all the way to assembler language output. The free the storage
14010 for the function definition.
5ff904cd 14011
c7e4ee3a 14012 This is called after parsing the body of the function definition.
5ff904cd 14013
c7e4ee3a
CB		 14014 NESTED is nonzero if the function being finished is nested in another. */
14015
14016static void
14017finish_function (int nested)
14018{
14019 register tree fndecl = current_function_decl;
14020
14021 assert (fndecl != NULL_TREE);
14022 if (TREE_CODE (fndecl) != ERROR_MARK)
14023 {
14024 if (nested)
14025 assert (DECL_CONTEXT (fndecl) != NULL_TREE);
5ff904cd 14026 else
c7e4ee3a
CB		 14027 assert (DECL_CONTEXT (fndecl) == NULL_TREE);
14028 }
5ff904cd 14029
c7e4ee3a
CB		 14030/* TREE_READONLY (fndecl) = 1;
14031 This caused &foo to be of type ptr-to-const-function
14032 which then got a warning when stored in a ptr-to-function variable. */
5ff904cd 14033
c7e4ee3a 14034 poplevel (1, 0, 1);
5ff904cd 14035
c7e4ee3a
CB		 14036 if (TREE_CODE (fndecl) != ERROR_MARK)
14037 {
14038 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
5ff904cd 14039
c7e4ee3a 14040 /* Must mark the RESULT_DECL as being in this function. */
5ff904cd 14041
c7e4ee3a 14042 DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
5ff904cd 14043
c7e4ee3a
CB		 14044 /* Obey `register' declarations if `setjmp' is called in this fn. */
14045 /* Generate rtl for function exit. */
14046 expand_function_end (input_filename, lineno, 0);
5ff904cd 14047
c7e4ee3a
CB		 14048 /* So we can tell if jump_optimize sets it to 1. */
14049 can_reach_end = 0;
5ff904cd 14050
c7e4ee3a
CB		 14051 /* Run the optimizers and output the assembler code for this function. */
14052 rest_of_compilation (fndecl);
14053 }
5ff904cd 14054
c7e4ee3a
CB		 14055 /* Free all the tree nodes making up this function. */
14056 /* Switch back to allocating nodes permanently until we start another
14057 function. */
14058 if (!nested)
14059 permanent_allocation (1);
14060
14061 if (TREE_CODE (fndecl) != ERROR_MARK
14062 && !nested
14063 && DECL_SAVED_INSNS (fndecl) == 0)
14064 {
14065 /* Stop pointing to the local nodes about to be freed. */
14066 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14067 function definition. */
14068 /* For a nested function, this is done in pop_f_function_context. */
14069 /* If rest_of_compilation set this to 0, leave it 0. */
14070 if (DECL_INITIAL (fndecl) != 0)
14071 DECL_INITIAL (fndecl) = error_mark_node;
14072 DECL_ARGUMENTS (fndecl) = 0;
5ff904cd 14073 }
c7e4ee3a
CB		 14074
14075 if (!nested)
5ff904cd 14076 {
c7e4ee3a
CB		 14077 /* Let the error reporting routines know that we're outside a function.
14078 For a nested function, this value is used in pop_c_function_context
14079 and then reset via pop_function_context. */
14080 ffecom_outer_function_decl_ = current_function_decl = NULL;
5ff904cd 14081 }
c7e4ee3a 14082}
5ff904cd 14083
c7e4ee3a
CB		 14084/* Plug-in replacement for identifying the name of a decl and, for a
14085 function, what we call it in diagnostics. For now, "program unit"
14086 should suffice, since it's a bit of a hassle to figure out which
14087 of several kinds of things it is. Note that it could conceivably
14088 be a statement function, which probably isn't really a program unit
14089 per se, but if that comes up, it should be easy to check (being a
14090 nested function and all). */
14091
14092static char *
14093lang_printable_name (tree decl, int v)
14094{
14095 /* Just to keep GCC quiet about the unused variable.
14096 In theory, differing values of V should produce different
14097 output. */
14098 switch (v)
5ff904cd 14099 {
c7e4ee3a
CB		 14100 default:
14101 if (TREE_CODE (decl) == ERROR_MARK)
14102 return "erroneous code";
14103 return IDENTIFIER_POINTER (DECL_NAME (decl));
5ff904cd 14104 }
c7e4ee3a
CB		 14105}
14106
14107/* g77's function to print out name of current function that caused
14108 an error. */
14109
14110#if BUILT_FOR_270
14111void
14112lang_print_error_function (file)
14113 char *file;
14114{
14115 static ffeglobal last_g = NULL;
14116 static ffesymbol last_s = NULL;
14117 ffeglobal g;
14118 ffesymbol s;
14119 const char *kind;
14120
14121 if ((ffecom_primary_entry_ == NULL)
14122 || (ffesymbol_global (ffecom_primary_entry_) == NULL))
5ff904cd 14123 {
c7e4ee3a
CB		 14124 g = NULL;
14125 s = NULL;
14126 kind = NULL;
5ff904cd
JL		 14127 }
14128 else
14129 {
c7e4ee3a
CB		 14130 g = ffesymbol_global (ffecom_primary_entry_);
14131 if (ffecom_nested_entry_ == NULL)
14132 {
14133 s = ffecom_primary_entry_;
14134 switch (ffesymbol_kind (s))
14135 {
14136 case FFEINFO_kindFUNCTION:
14137 kind = "function";
14138 break;
5ff904cd 14139
c7e4ee3a
CB		 14140 case FFEINFO_kindSUBROUTINE:
14141 kind = "subroutine";
14142 break;
5ff904cd 14143
c7e4ee3a
CB		 14144 case FFEINFO_kindPROGRAM:
14145 kind = "program";
14146 break;
14147
14148 case FFEINFO_kindBLOCKDATA:
14149 kind = "block-data";
14150 break;
14151
14152 default:
14153 kind = ffeinfo_kind_message (ffesymbol_kind (s));
14154 break;
14155 }
14156 }
14157 else
14158 {
14159 s = ffecom_nested_entry_;
14160 kind = "statement function";
14161 }
5ff904cd
JL		 14162 }
14163
c7e4ee3a 14164 if ((last_g != g) || (last_s != s))
5ff904cd 14165 {
c7e4ee3a
CB		 14166 if (file)
14167 fprintf (stderr, "%s: ", file);
14168
14169 if (s == NULL)
14170 fprintf (stderr, "Outside of any program unit:\n");
14171 else
5ff904cd 14172 {
c7e4ee3a
CB		 14173 const char *name = ffesymbol_text (s);
14174
14175 fprintf (stderr, "In %s `%s':\n", kind, name);
5ff904cd 14176 }
5ff904cd 14177
c7e4ee3a
CB		 14178 last_g = g;
14179 last_s = s;
5ff904cd 14180 }
c7e4ee3a
CB		 14181}
14182#endif
5ff904cd 14183
c7e4ee3a 14184/* Similar to `lookup_name' but look only at current binding level. */
5ff904cd 14185
c7e4ee3a
CB		 14186static tree
14187lookup_name_current_level (tree name)
14188{
14189 register tree t;
5ff904cd 14190
c7e4ee3a
CB		 14191 if (current_binding_level == global_binding_level)
14192 return IDENTIFIER_GLOBAL_VALUE (name);
14193
14194 if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14195 return 0;
14196
14197 for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14198 if (DECL_NAME (t) == name)
14199 break;
14200
14201 return t;
5ff904cd
JL		 14202}
14203
c7e4ee3a 14204/* Create a new `struct binding_level'. */
5ff904cd 14205
c7e4ee3a
CB		 14206static struct binding_level *
14207make_binding_level ()
5ff904cd 14208{
c7e4ee3a
CB		 14209 /* NOSTRICT */
14210 return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14211}
5ff904cd 14212
c7e4ee3a
CB		 14213/* Save and restore the variables in this file and elsewhere
14214 that keep track of the progress of compilation of the current function.
14215 Used for nested functions. */
5ff904cd 14216
c7e4ee3a
CB		 14217struct f_function
14218{
14219 struct f_function *next;
14220 tree named_labels;
14221 tree shadowed_labels;
14222 struct binding_level *binding_level;
14223};
5ff904cd 14224
c7e4ee3a 14225struct f_function *f_function_chain;
5ff904cd 14226
c7e4ee3a 14227/* Restore the variables used during compilation of a C function. */
5ff904cd 14228
c7e4ee3a
CB		 14229static void
14230pop_f_function_context ()
14231{
14232 struct f_function *p = f_function_chain;
14233 tree link;
5ff904cd 14234
c7e4ee3a
CB		 14235 /* Bring back all the labels that were shadowed. */
14236 for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14237 if (DECL_NAME (TREE_VALUE (link)) != 0)
14238 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14239 = TREE_VALUE (link);
5ff904cd 14240
c7e4ee3a
CB		 14241 if (current_function_decl != error_mark_node
14242 && DECL_SAVED_INSNS (current_function_decl) == 0)
14243 {
14244 /* Stop pointing to the local nodes about to be freed. */
14245 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14246 function definition. */
14247 DECL_INITIAL (current_function_decl) = error_mark_node;
14248 DECL_ARGUMENTS (current_function_decl) = 0;
5ff904cd
JL		 14249 }
14250
c7e4ee3a 14251 pop_function_context ();
5ff904cd 14252
c7e4ee3a 14253 f_function_chain = p->next;
5ff904cd 14254
c7e4ee3a
CB		 14255 named_labels = p->named_labels;
14256 shadowed_labels = p->shadowed_labels;
14257 current_binding_level = p->binding_level;
5ff904cd 14258
c7e4ee3a
CB		 14259 free (p);
14260}
5ff904cd 14261
c7e4ee3a
CB		 14262/* Save and reinitialize the variables
14263 used during compilation of a C function. */
5ff904cd 14264
c7e4ee3a
CB		 14265static void
14266push_f_function_context ()
14267{
14268 struct f_function *p
14269 = (struct f_function *) xmalloc (sizeof (struct f_function));
5ff904cd 14270
c7e4ee3a
CB		 14271 push_function_context ();
14272
14273 p->next = f_function_chain;
14274 f_function_chain = p;
14275
14276 p->named_labels = named_labels;
14277 p->shadowed_labels = shadowed_labels;
14278 p->binding_level = current_binding_level;
14279}
5ff904cd 14280
c7e4ee3a
CB		 14281static void
14282push_parm_decl (tree parm)
14283{
14284 int old_immediate_size_expand = immediate_size_expand;
5ff904cd 14285
c7e4ee3a 14286 /* Don't try computing parm sizes now -- wait till fn is called. */
5ff904cd 14287
c7e4ee3a 14288 immediate_size_expand = 0;
5ff904cd 14289
c7e4ee3a 14290 push_obstacks_nochange ();
5ff904cd 14291
c7e4ee3a 14292 /* Fill in arg stuff. */
5ff904cd 14293
c7e4ee3a
CB		 14294 DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14295 DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14296 TREE_READONLY (parm) = 1; /* All implementation args are read-only. */
5ff904cd 14297
c7e4ee3a
CB		 14298 parm = pushdecl (parm);
14299
14300 immediate_size_expand = old_immediate_size_expand;
14301
14302 finish_decl (parm, NULL_TREE, FALSE);
5ff904cd
JL		 14303}
14304
c7e4ee3a 14305/* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
5ff904cd 14306
c7e4ee3a
CB		 14307static tree
14308pushdecl_top_level (x)
14309 tree x;
14310{
14311 register tree t;
14312 register struct binding_level *b = current_binding_level;
14313 register tree f = current_function_decl;
5ff904cd 14314
c7e4ee3a
CB		 14315 current_binding_level = global_binding_level;
14316 current_function_decl = NULL_TREE;
14317 t = pushdecl (x);
14318 current_binding_level = b;
14319 current_function_decl = f;
14320 return t;
14321}
14322
14323/* Store the list of declarations of the current level.
14324 This is done for the parameter declarations of a function being defined,
14325 after they are modified in the light of any missing parameters. */
14326
14327static tree
14328storedecls (decls)
14329 tree decls;
14330{
14331 return current_binding_level->names = decls;
14332}
14333
14334/* Store the parameter declarations into the current function declaration.
14335 This is called after parsing the parameter declarations, before
14336 digesting the body of the function.
14337
14338 For an old-style definition, modify the function's type
14339 to specify at least the number of arguments. */
5ff904cd
JL		 14340
14341static void
c7e4ee3a 14342store_parm_decls (int is_main_program UNUSED)
5ff904cd
JL		 14343{
14344 register tree fndecl = current_function_decl;
14345
c7e4ee3a
CB		 14346 if (fndecl == error_mark_node)
14347 return;
5ff904cd 14348
c7e4ee3a
CB		 14349 /* This is a chain of PARM_DECLs from old-style parm declarations. */
14350 DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
5ff904cd 14351
c7e4ee3a 14352 /* Initialize the RTL code for the function. */
5ff904cd 14353
c7e4ee3a 14354 init_function_start (fndecl, input_filename, lineno);
56a0044b 14355
c7e4ee3a 14356 /* Set up parameters and prepare for return, for the function. */
5ff904cd 14357
c7e4ee3a
CB		 14358 expand_function_start (fndecl, 0);
14359}
5ff904cd 14360
c7e4ee3a
CB		 14361static tree
14362start_decl (tree decl, bool is_top_level)
14363{
14364 register tree tem;
14365 bool at_top_level = (current_binding_level == global_binding_level);
14366 bool top_level = is_top_level || at_top_level;
5ff904cd 14367
c7e4ee3a
CB		 14368 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14369 level anyway. */
14370 assert (!is_top_level || !at_top_level);
5ff904cd 14371
c7e4ee3a
CB		 14372 /* The corresponding pop_obstacks is in finish_decl. */
14373 push_obstacks_nochange ();
14374
14375 if (DECL_INITIAL (decl) != NULL_TREE)
14376 {
14377 assert (DECL_INITIAL (decl) == error_mark_node);
14378 assert (!DECL_EXTERNAL (decl));
56a0044b 14379 }
c7e4ee3a
CB		 14380 else if (top_level)
14381 assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
5ff904cd 14382
c7e4ee3a
CB		 14383 /* For Fortran, we by default put things in .common when possible. */
14384 DECL_COMMON (decl) = 1;
5ff904cd 14385
c7e4ee3a
CB		 14386 /* Add this decl to the current binding level. TEM may equal DECL or it may
14387 be a previous decl of the same name. */
14388 if (is_top_level)
14389 tem = pushdecl_top_level (decl);
14390 else
14391 tem = pushdecl (decl);
14392
14393 /* For a local variable, define the RTL now. */
14394 if (!top_level
14395 /* But not if this is a duplicate decl and we preserved the rtl from the
14396 previous one (which may or may not happen). */
14397 && DECL_RTL (tem) == 0)
5ff904cd 14398 {
c7e4ee3a
CB		 14399 if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14400 expand_decl (tem);
14401 else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14402 && DECL_INITIAL (tem) != 0)
14403 expand_decl (tem);
5ff904cd
JL		 14404 }
14405
c7e4ee3a 14406 if (DECL_INITIAL (tem) != NULL_TREE)
5ff904cd 14407 {
c7e4ee3a
CB		 14408 /* When parsing and digesting the initializer, use temporary storage.
14409 Do this even if we will ignore the value. */
14410 if (at_top_level)
14411 temporary_allocation ();
5ff904cd 14412 }
c7e4ee3a
CB		 14413
14414 return tem;
5ff904cd
JL		 14415}
14416
c7e4ee3a
CB		 14417/* Create the FUNCTION_DECL for a function definition.
14418 DECLSPECS and DECLARATOR are the parts of the declaration;
14419 they describe the function's name and the type it returns,
14420 but twisted together in a fashion that parallels the syntax of C.
5ff904cd 14421
c7e4ee3a
CB		 14422 This function creates a binding context for the function body
14423 as well as setting up the FUNCTION_DECL in current_function_decl.
5ff904cd 14424
c7e4ee3a
CB		 14425 Returns 1 on success. If the DECLARATOR is not suitable for a function
14426 (it defines a datum instead), we return 0, which tells
14427 yyparse to report a parse error.
5ff904cd 14428
c7e4ee3a
CB		 14429 NESTED is nonzero for a function nested within another function. */
14430
14431static void
14432start_function (tree name, tree type, int nested, int public)
5ff904cd 14433{
c7e4ee3a
CB		 14434 tree decl1;
14435 tree restype;
14436 int old_immediate_size_expand = immediate_size_expand;
5ff904cd 14437
c7e4ee3a
CB		 14438 named_labels = 0;
14439 shadowed_labels = 0;
14440
14441 /* Don't expand any sizes in the return type of the function. */
14442 immediate_size_expand = 0;
14443
14444 if (nested)
5ff904cd 14445 {
c7e4ee3a
CB		 14446 assert (!public);
14447 assert (current_function_decl != NULL_TREE);
14448 assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14449 }
14450 else
14451 {
14452 assert (current_function_decl == NULL_TREE);
5ff904cd 14453 }
c7e4ee3a
CB		 14454
14455 if (TREE_CODE (type) == ERROR_MARK)
14456 decl1 = current_function_decl = error_mark_node;
56a0044b 14457 else
5ff904cd 14458 {
c7e4ee3a
CB		 14459 decl1 = build_decl (FUNCTION_DECL,
14460 name,
14461 type);
14462 TREE_PUBLIC (decl1) = public ? 1 : 0;
14463 if (nested)
14464 DECL_INLINE (decl1) = 1;
14465 TREE_STATIC (decl1) = 1;
14466 DECL_EXTERNAL (decl1) = 0;
5ff904cd 14467
c7e4ee3a 14468 announce_function (decl1);
5ff904cd 14469
c7e4ee3a
CB		 14470 /* Make the init_value nonzero so pushdecl knows this is not tentative.
14471 error_mark_node is replaced below (in poplevel) with the BLOCK. */
14472 DECL_INITIAL (decl1) = error_mark_node;
5ff904cd 14473
c7e4ee3a
CB		 14474 /* Record the decl so that the function name is defined. If we already have
14475 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
5ff904cd 14476
c7e4ee3a 14477 current_function_decl = pushdecl (decl1);
5ff904cd
JL		 14478 }
14479
c7e4ee3a
CB		 14480 if (!nested)
14481 ffecom_outer_function_decl_ = current_function_decl;
5ff904cd 14482
c7e4ee3a
CB		 14483 pushlevel (0);
14484 current_binding_level->prep_state = 2;
5ff904cd 14485
c7e4ee3a
CB		 14486 if (TREE_CODE (current_function_decl) != ERROR_MARK)
14487 {
14488 make_function_rtl (current_function_decl);
5ff904cd 14489
c7e4ee3a
CB		 14490 restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14491 DECL_RESULT (current_function_decl)
14492 = build_decl (RESULT_DECL, NULL_TREE, restype);
5ff904cd 14493 }
5ff904cd 14494
c7e4ee3a
CB		 14495 if (!nested)
14496 /* Allocate further tree nodes temporarily during compilation of this
14497 function only. */
14498 temporary_allocation ();
5ff904cd 14499
c7e4ee3a
CB		 14500 if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14501 TREE_ADDRESSABLE (current_function_decl) = 1;
14502
14503 immediate_size_expand = old_immediate_size_expand;
14504}
14505\f
14506/* Here are the public functions the GNU back end needs. */
14507
14508tree
14509convert (type, expr)
14510 tree type, expr;
5ff904cd 14511{
c7e4ee3a
CB		 14512 register tree e = expr;
14513 register enum tree_code code = TREE_CODE (type);
5ff904cd 14514
c7e4ee3a
CB		 14515 if (type == TREE_TYPE (e)
14516 || TREE_CODE (e) == ERROR_MARK)
14517 return e;
14518 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14519 return fold (build1 (NOP_EXPR, type, e));
14520 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14521 || code == ERROR_MARK)
14522 return error_mark_node;
14523 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14524 {
14525 assert ("void value not ignored as it ought to be" == NULL);
14526 return error_mark_node;
14527 }
14528 if (code == VOID_TYPE)
14529 return build1 (CONVERT_EXPR, type, e);
14530 if ((code != RECORD_TYPE)
14531 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14532 e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14533 e);
14534 if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14535 return fold (convert_to_integer (type, e));
14536 if (code == POINTER_TYPE)
14537 return fold (convert_to_pointer (type, e));
14538 if (code == REAL_TYPE)
14539 return fold (convert_to_real (type, e));
14540 if (code == COMPLEX_TYPE)
14541 return fold (convert_to_complex (type, e));
14542 if (code == RECORD_TYPE)
14543 return fold (ffecom_convert_to_complex_ (type, e));
5ff904cd 14544
c7e4ee3a
CB		 14545 assert ("conversion to non-scalar type requested" == NULL);
14546 return error_mark_node;
14547}
5ff904cd 14548
c7e4ee3a
CB		 14549/* integrate_decl_tree calls this function, but since we don't use the
14550 DECL_LANG_SPECIFIC field, this is a no-op. */
5ff904cd 14551
c7e4ee3a
CB		 14552void
14553copy_lang_decl (node)
14554 tree node UNUSED;
14555{
5ff904cd
JL		 14556}
14557
c7e4ee3a
CB		 14558/* Return the list of declarations of the current level.
14559 Note that this list is in reverse order unless/until
14560 you nreverse it; and when you do nreverse it, you must
14561 store the result back using `storedecls' or you will lose. */
5ff904cd 14562
c7e4ee3a
CB		 14563tree
14564getdecls ()
5ff904cd 14565{
c7e4ee3a 14566 return current_binding_level->names;
5ff904cd
JL		 14567}
14568
c7e4ee3a 14569/* Nonzero if we are currently in the global binding level. */
5ff904cd 14570
c7e4ee3a
CB		 14571int
14572global_bindings_p ()
5ff904cd 14573{
c7e4ee3a
CB		 14574 return current_binding_level == global_binding_level;
14575}
5ff904cd 14576
c7e4ee3a
CB		 14577/* Print an error message for invalid use of an incomplete type.
14578 VALUE is the expression that was used (or 0 if that isn't known)
14579 and TYPE is the type that was invalid. */
5ff904cd 14580
c7e4ee3a
CB		 14581void
14582incomplete_type_error (value, type)
14583 tree value UNUSED;
14584 tree type;
14585{
14586 if (TREE_CODE (type) == ERROR_MARK)
14587 return;
5ff904cd 14588
c7e4ee3a
CB		 14589 assert ("incomplete type?!?" == NULL);
14590}
14591
14592void
14593init_decl_processing ()
5ff904cd 14594{
c7e4ee3a
CB		 14595 malloc_init ();
14596 ffe_init_0 ();
14597}
5ff904cd 14598
c7e4ee3a
CB		 14599char *
14600init_parse (filename)
14601 char *filename;
14602{
14603#if BUILT_FOR_270
14604 extern void (*print_error_function) (char *);
14605#endif
5ff904cd 14606
c7e4ee3a
CB		 14607 /* Open input file. */
14608 if (filename == 0 || !strcmp (filename, "-"))
5ff904cd 14609 {
c7e4ee3a
CB		 14610 finput = stdin;
14611 filename = "stdin";
5ff904cd 14612 }
c7e4ee3a
CB		 14613 else
14614 finput = fopen (filename, "r");
14615 if (finput == 0)
14616 pfatal_with_name (filename);
5ff904cd 14617
c7e4ee3a
CB		 14618#ifdef IO_BUFFER_SIZE
14619 setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14620#endif
5ff904cd 14621
c7e4ee3a
CB		 14622 /* Make identifier nodes long enough for the language-specific slots. */
14623 set_identifier_size (sizeof (struct lang_identifier));
14624 decl_printable_name = lang_printable_name;
14625#if BUILT_FOR_270
14626 print_error_function = lang_print_error_function;
14627#endif
5ff904cd 14628
c7e4ee3a
CB		 14629 return filename;
14630}
5ff904cd 14631
c7e4ee3a
CB		 14632void
14633finish_parse ()
14634{
14635 fclose (finput);
14636}
14637
14638/* Delete the node BLOCK from the current binding level.
14639 This is used for the block inside a stmt expr ({...})
14640 so that the block can be reinserted where appropriate. */
14641
14642static void
14643delete_block (block)
14644 tree block;
14645{
14646 tree t;
14647 if (current_binding_level->blocks == block)
14648 current_binding_level->blocks = TREE_CHAIN (block);
14649 for (t = current_binding_level->blocks; t;)
14650 {
14651 if (TREE_CHAIN (t) == block)
14652 TREE_CHAIN (t) = TREE_CHAIN (block);
14653 else
14654 t = TREE_CHAIN (t);
14655 }
14656 TREE_CHAIN (block) = NULL;
14657 /* Clear TREE_USED which is always set by poplevel.
14658 The flag is set again if insert_block is called. */
14659 TREE_USED (block) = 0;
14660}
14661
14662void
14663insert_block (block)
14664 tree block;
14665{
14666 TREE_USED (block) = 1;
14667 current_binding_level->blocks
14668 = chainon (current_binding_level->blocks, block);
14669}
14670
14671int
14672lang_decode_option (argc, argv)
14673 int argc;
14674 char **argv;
14675{
14676 return ffe_decode_option (argc, argv);
5ff904cd
JL		 14677}
14678
c7e4ee3a 14679/* used by print-tree.c */
5ff904cd 14680
c7e4ee3a
CB		 14681void
14682lang_print_xnode (file, node, indent)
14683 FILE *file UNUSED;
14684 tree node UNUSED;
14685 int indent UNUSED;
5ff904cd 14686{
c7e4ee3a 14687}
5ff904cd 14688
c7e4ee3a
CB		 14689void
14690lang_finish ()
14691{
14692 ffe_terminate_0 ();
5ff904cd 14693
c7e4ee3a
CB		 14694 if (ffe_is_ffedebug ())
14695 malloc_pool_display (malloc_pool_image ());
5ff904cd
JL		 14696}
14697
c7e4ee3a
CB		 14698char *
14699lang_identify ()
5ff904cd 14700{
c7e4ee3a
CB		 14701 return "f77";
14702}
5ff904cd 14703
c7e4ee3a
CB		 14704void
14705lang_init_options ()
14706{
14707 /* Set default options for Fortran. */
14708 flag_move_all_movables = 1;
14709 flag_reduce_all_givs = 1;
14710 flag_argument_noalias = 2;
14711}
5ff904cd 14712
c7e4ee3a
CB		 14713void
14714lang_init ()
14715{
14716 /* If the file is output from cpp, it should contain a first line
14717 `# 1 "real-filename"', and the current design of gcc (toplev.c
14718 in particular and the way it sets up information relied on by
14719 INCLUDE) requires that we read this now, and store the
14720 "real-filename" info in master_input_filename. Ask the lexer
14721 to try doing this. */
14722 ffelex_hash_kludge (finput);
14723}
5ff904cd 14724
c7e4ee3a
CB		 14725int
14726mark_addressable (exp)
14727 tree exp;
14728{
14729 register tree x = exp;
14730 while (1)
14731 switch (TREE_CODE (x))
14732 {
14733 case ADDR_EXPR:
14734 case COMPONENT_REF:
14735 case ARRAY_REF:
14736 x = TREE_OPERAND (x, 0);
14737 break;
5ff904cd 14738
c7e4ee3a
CB		 14739 case CONSTRUCTOR:
14740 TREE_ADDRESSABLE (x) = 1;
14741 return 1;
5ff904cd 14742
c7e4ee3a
CB		 14743 case VAR_DECL:
14744 case CONST_DECL:
14745 case PARM_DECL:
14746 case RESULT_DECL:
14747 if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14748 && DECL_NONLOCAL (x))
14749 {
14750 if (TREE_PUBLIC (x))
14751 {
14752 assert ("address of global register var requested" == NULL);
14753 return 0;
14754 }
14755 assert ("address of register variable requested" == NULL);
14756 }
14757 else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14758 {
14759 if (TREE_PUBLIC (x))
14760 {
14761 assert ("address of global register var requested" == NULL);
14762 return 0;
14763 }
14764 assert ("address of register var requested" == NULL);
14765 }
14766 put_var_into_stack (x);
5ff904cd 14767
c7e4ee3a
CB		 14768 /* drops in */
14769 case FUNCTION_DECL:
14770 TREE_ADDRESSABLE (x) = 1;
14771#if 0 /* poplevel deals with this now. */
14772 if (DECL_CONTEXT (x) == 0)
14773 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14774#endif
5ff904cd 14775
c7e4ee3a
CB		 14776 default:
14777 return 1;
14778 }
5ff904cd
JL		 14779}
14780
c7e4ee3a
CB		 14781/* If DECL has a cleanup, build and return that cleanup here.
14782 This is a callback called by expand_expr. */
5ff904cd 14783
c7e4ee3a
CB		 14784tree
14785maybe_build_cleanup (decl)
14786 tree decl UNUSED;
5ff904cd 14787{
c7e4ee3a
CB		 14788 /* There are no cleanups in Fortran. */
14789 return NULL_TREE;
5ff904cd
JL		 14790}
14791
c7e4ee3a
CB		 14792/* Exit a binding level.
14793 Pop the level off, and restore the state of the identifier-decl mappings
14794 that were in effect when this level was entered.
5ff904cd 14795
c7e4ee3a
CB		 14796 If KEEP is nonzero, this level had explicit declarations, so
14797 and create a "block" (a BLOCK node) for the level
14798 to record its declarations and subblocks for symbol table output.
5ff904cd 14799
c7e4ee3a
CB		 14800 If FUNCTIONBODY is nonzero, this level is the body of a function,
14801 so create a block as if KEEP were set and also clear out all
14802 label names.
5ff904cd 14803
c7e4ee3a
CB		 14804 If REVERSE is nonzero, reverse the order of decls before putting
14805 them into the BLOCK. */
5ff904cd 14806
c7e4ee3a
CB		 14807tree
14808poplevel (keep, reverse, functionbody)
14809 int keep;
14810 int reverse;
14811 int functionbody;
5ff904cd 14812{
c7e4ee3a
CB		 14813 register tree link;
14814 /* The chain of decls was accumulated in reverse order.
14815 Put it into forward order, just for cleanliness. */
14816 tree decls;
14817 tree subblocks = current_binding_level->blocks;
14818 tree block = 0;
14819 tree decl;
14820 int block_previously_created;
5ff904cd 14821
c7e4ee3a
CB		 14822 /* Get the decls in the order they were written.
14823 Usually current_binding_level->names is in reverse order.
14824 But parameter decls were previously put in forward order. */
702edf1d 14825
c7e4ee3a
CB		 14826 if (reverse)
14827 current_binding_level->names
14828 = decls = nreverse (current_binding_level->names);
14829 else
14830 decls = current_binding_level->names;
5ff904cd 14831
c7e4ee3a
CB		 14832 /* Output any nested inline functions within this block
14833 if they weren't already output. */
5ff904cd 14834
c7e4ee3a
CB		 14835 for (decl = decls; decl; decl = TREE_CHAIN (decl))
14836 if (TREE_CODE (decl) == FUNCTION_DECL
14837 && ! TREE_ASM_WRITTEN (decl)
14838 && DECL_INITIAL (decl) != 0
14839 && TREE_ADDRESSABLE (decl))
14840 {
14841 /* If this decl was copied from a file-scope decl
14842 on account of a block-scope extern decl,
14843 propagate TREE_ADDRESSABLE to the file-scope decl.
14844
14845 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14846 true, since then the decl goes through save_for_inline_copying. */
14847 if (DECL_ABSTRACT_ORIGIN (decl) != 0
14848 && DECL_ABSTRACT_ORIGIN (decl) != decl)
14849 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14850 else if (DECL_SAVED_INSNS (decl) != 0)
14851 {
14852 push_function_context ();
14853 output_inline_function (decl);
14854 pop_function_context ();
14855 }
14856 }
5ff904cd 14857
c7e4ee3a
CB		 14858 /* If there were any declarations or structure tags in that level,
14859 or if this level is a function body,
14860 create a BLOCK to record them for the life of this function. */
5ff904cd 14861
c7e4ee3a
CB		 14862 block = 0;
14863 block_previously_created = (current_binding_level->this_block != 0);
14864 if (block_previously_created)
14865 block = current_binding_level->this_block;
14866 else if (keep || functionbody)
14867 block = make_node (BLOCK);
14868 if (block != 0)
14869 {
14870 BLOCK_VARS (block) = decls;
14871 BLOCK_SUBBLOCKS (block) = subblocks;
14872 remember_end_note (block);
14873 }
5ff904cd 14874
c7e4ee3a 14875 /* In each subblock, record that this is its superior. */
5ff904cd 14876
c7e4ee3a
CB		 14877 for (link = subblocks; link; link = TREE_CHAIN (link))
14878 BLOCK_SUPERCONTEXT (link) = block;
5ff904cd 14879
c7e4ee3a 14880 /* Clear out the meanings of the local variables of this level. */
5ff904cd 14881
c7e4ee3a 14882 for (link = decls; link; link = TREE_CHAIN (link))
5ff904cd 14883 {
c7e4ee3a
CB		 14884 if (DECL_NAME (link) != 0)
14885 {
14886 /* If the ident. was used or addressed via a local extern decl,
14887 don't forget that fact. */
14888 if (DECL_EXTERNAL (link))
14889 {
14890 if (TREE_USED (link))
14891 TREE_USED (DECL_NAME (link)) = 1;
14892 if (TREE_ADDRESSABLE (link))
14893 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14894 }
14895 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14896 }
5ff904cd 14897 }
5ff904cd 14898
c7e4ee3a
CB		 14899 /* If the level being exited is the top level of a function,
14900 check over all the labels, and clear out the current
14901 (function local) meanings of their names. */
5ff904cd 14902
c7e4ee3a 14903 if (functionbody)
5ff904cd 14904 {
c7e4ee3a
CB		 14905 /* If this is the top level block of a function,
14906 the vars are the function's parameters.
14907 Don't leave them in the BLOCK because they are
14908 found in the FUNCTION_DECL instead. */
14909
14910 BLOCK_VARS (block) = 0;
5ff904cd
JL		 14911 }
14912
c7e4ee3a
CB		 14913 /* Pop the current level, and free the structure for reuse. */
14914
14915 {
14916 register struct binding_level *level = current_binding_level;
14917 current_binding_level = current_binding_level->level_chain;
14918
14919 level->level_chain = free_binding_level;
14920 free_binding_level = level;
14921 }
14922
14923 /* Dispose of the block that we just made inside some higher level. */
14924 if (functionbody
14925 && current_function_decl != error_mark_node)
14926 DECL_INITIAL (current_function_decl) = block;
14927 else if (block)
5ff904cd 14928 {
c7e4ee3a
CB		 14929 if (!block_previously_created)
14930 current_binding_level->blocks
14931 = chainon (current_binding_level->blocks, block);
5ff904cd 14932 }
c7e4ee3a
CB		 14933 /* If we did not make a block for the level just exited,
14934 any blocks made for inner levels
14935 (since they cannot be recorded as subblocks in that level)
14936 must be carried forward so they will later become subblocks
14937 of something else. */
14938 else if (subblocks)
14939 current_binding_level->blocks
14940 = chainon (current_binding_level->blocks, subblocks);
5ff904cd 14941
c7e4ee3a
CB		 14942 if (block)
14943 TREE_USED (block) = 1;
14944 return block;
5ff904cd
JL		 14945}
14946
c7e4ee3a
CB		 14947void
14948print_lang_decl (file, node, indent)
14949 FILE *file UNUSED;
14950 tree node UNUSED;
14951 int indent UNUSED;
14952{
14953}
5ff904cd 14954
c7e4ee3a
CB		 14955void
14956print_lang_identifier (file, node, indent)
14957 FILE *file;
14958 tree node;
14959 int indent;
14960{
14961 print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14962 print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14963}
5ff904cd 14964
c7e4ee3a
CB		 14965void
14966print_lang_statistics ()
14967{
14968}
5ff904cd 14969
c7e4ee3a
CB		 14970void
14971print_lang_type (file, node, indent)
14972 FILE *file UNUSED;
14973 tree node UNUSED;
14974 int indent UNUSED;
5ff904cd 14975{
c7e4ee3a 14976}
5ff904cd 14977
c7e4ee3a
CB		 14978/* Record a decl-node X as belonging to the current lexical scope.
14979 Check for errors (such as an incompatible declaration for the same
14980 name already seen in the same scope).
5ff904cd 14981
c7e4ee3a
CB		 14982 Returns either X or an old decl for the same name.
14983 If an old decl is returned, it may have been smashed
14984 to agree with what X says. */
5ff904cd 14985
c7e4ee3a
CB		 14986tree
14987pushdecl (x)
14988 tree x;
14989{
14990 register tree t;
14991 register tree name = DECL_NAME (x);
14992 register struct binding_level *b = current_binding_level;
5ff904cd 14993
c7e4ee3a
CB		 14994 if ((TREE_CODE (x) == FUNCTION_DECL)
14995 && (DECL_INITIAL (x) == 0)
14996 && DECL_EXTERNAL (x))
14997 DECL_CONTEXT (x) = NULL_TREE;
56a0044b 14998 else
c7e4ee3a
CB		 14999 DECL_CONTEXT (x) = current_function_decl;
15000
15001 if (name)
56a0044b 15002 {
c7e4ee3a
CB		 15003 if (IDENTIFIER_INVENTED (name))
15004 {
15005#if BUILT_FOR_270
15006 DECL_ARTIFICIAL (x) = 1;
15007#endif
15008 DECL_IN_SYSTEM_HEADER (x) = 1;
15009 }
5ff904cd 15010
c7e4ee3a 15011 t = lookup_name_current_level (name);
5ff904cd 15012
c7e4ee3a 15013 assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
5ff904cd 15014
c7e4ee3a
CB		 15015 /* Don't push non-parms onto list for parms until we understand
15016 why we're doing this and whether it works. */
56a0044b 15017
c7e4ee3a
CB		 15018 assert ((b == global_binding_level)
15019 || !ffecom_transform_only_dummies_
15020 || TREE_CODE (x) == PARM_DECL);
5ff904cd 15021
c7e4ee3a
CB		 15022 if ((t != NULL_TREE) && duplicate_decls (x, t))
15023 return t;
5ff904cd 15024
c7e4ee3a
CB		 15025 /* If we are processing a typedef statement, generate a whole new
15026 ..._TYPE node (which will be just an variant of the existing
15027 ..._TYPE node with identical properties) and then install the
15028 TYPE_DECL node generated to represent the typedef name as the
15029 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
5ff904cd 15030
c7e4ee3a
CB		 15031 The whole point here is to end up with a situation where each and every
15032 ..._TYPE node the compiler creates will be uniquely associated with
15033 AT MOST one node representing a typedef name. This way, even though
15034 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15035 (i.e. "typedef name") nodes very early on, later parts of the
15036 compiler can always do the reverse translation and get back the
15037 corresponding typedef name. For example, given:
5ff904cd 15038
c7e4ee3a 15039 typedef struct S MY_TYPE; MY_TYPE object;
5ff904cd 15040
c7e4ee3a
CB		 15041 Later parts of the compiler might only know that `object' was of type
15042 `struct S' if it were not for code just below. With this code
15043 however, later parts of the compiler see something like:
5ff904cd 15044
c7e4ee3a 15045 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
5ff904cd 15046
c7e4ee3a
CB		 15047 And they can then deduce (from the node for type struct S') that the
15048 original object declaration was:
5ff904cd 15049
c7e4ee3a 15050 MY_TYPE object;
5ff904cd 15051
c7e4ee3a
CB		 15052 Being able to do this is important for proper support of protoize, and
15053 also for generating precise symbolic debugging information which
15054 takes full account of the programmer's (typedef) vocabulary.
5ff904cd 15055
c7e4ee3a
CB		 15056 Obviously, we don't want to generate a duplicate ..._TYPE node if the
15057 TYPE_DECL node that we are now processing really represents a
15058 standard built-in type.
5ff904cd 15059
c7e4ee3a
CB		 15060 Since all standard types are effectively declared at line zero in the
15061 source file, we can easily check to see if we are working on a
15062 standard type by checking the current value of lineno. */
15063
15064 if (TREE_CODE (x) == TYPE_DECL)
15065 {
15066 if (DECL_SOURCE_LINE (x) == 0)
15067 {
15068 if (TYPE_NAME (TREE_TYPE (x)) == 0)
15069 TYPE_NAME (TREE_TYPE (x)) = x;
15070 }
15071 else if (TREE_TYPE (x) != error_mark_node)
15072 {
15073 tree tt = TREE_TYPE (x);
15074
15075 tt = build_type_copy (tt);
15076 TYPE_NAME (tt) = x;
15077 TREE_TYPE (x) = tt;
15078 }
15079 }
5ff904cd 15080
c7e4ee3a
CB		 15081 /* This name is new in its binding level. Install the new declaration
15082 and return it. */
15083 if (b == global_binding_level)
15084 IDENTIFIER_GLOBAL_VALUE (name) = x;
15085 else
15086 IDENTIFIER_LOCAL_VALUE (name) = x;
15087 }
5ff904cd 15088
c7e4ee3a
CB		 15089 /* Put decls on list in reverse order. We will reverse them later if
15090 necessary. */
15091 TREE_CHAIN (x) = b->names;
15092 b->names = x;
5ff904cd 15093
c7e4ee3a 15094 return x;
5ff904cd
JL		 15095}
15096
c7e4ee3a 15097/* Nonzero if the current level needs to have a BLOCK made. */
5ff904cd 15098
c7e4ee3a
CB		 15099static int
15100kept_level_p ()
5ff904cd 15101{
c7e4ee3a
CB		 15102 tree decl;
15103
15104 for (decl = current_binding_level->names;
15105 decl;
15106 decl = TREE_CHAIN (decl))
15107 {
15108 if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15109 || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15110 /* Currently, there aren't supposed to be non-artificial names
15111 at other than the top block for a function -- they're
15112 believed to always be temps. But it's wise to check anyway. */
15113 return 1;
15114 }
15115 return 0;
5ff904cd
JL		 15116}
15117
c7e4ee3a
CB		 15118/* Enter a new binding level.
15119 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15120 not for that of tags. */
5ff904cd
JL		 15121
15122void
c7e4ee3a
CB		 15123pushlevel (tag_transparent)
15124 int tag_transparent;
5ff904cd 15125{
c7e4ee3a 15126 register struct binding_level *newlevel = NULL_BINDING_LEVEL;
5ff904cd 15127
c7e4ee3a 15128 assert (! tag_transparent);
5ff904cd 15129
c7e4ee3a
CB		 15130 if (current_binding_level == global_binding_level)
15131 {
15132 named_labels = 0;
15133 }
5ff904cd 15134
c7e4ee3a 15135 /* Reuse or create a struct for this binding level. */
5ff904cd 15136
c7e4ee3a 15137 if (free_binding_level)
77f77701 15138 {
c7e4ee3a
CB		 15139 newlevel = free_binding_level;
15140 free_binding_level = free_binding_level->level_chain;
77f77701
DB		 15141 }
15142 else
c7e4ee3a
CB		 15143 {
15144 newlevel = make_binding_level ();
15145 }
77f77701 15146
c7e4ee3a
CB		 15147 /* Add this level to the front of the chain (stack) of levels that
15148 are active. */
71b5e532 15149
c7e4ee3a
CB		 15150 *newlevel = clear_binding_level;
15151 newlevel->level_chain = current_binding_level;
15152 current_binding_level = newlevel;
5ff904cd
JL		 15153}
15154
c7e4ee3a
CB		 15155/* Set the BLOCK node for the innermost scope
15156 (the one we are currently in). */
77f77701 15157
5ff904cd 15158void
c7e4ee3a
CB		 15159set_block (block)
15160 register tree block;
5ff904cd 15161{
c7e4ee3a 15162 current_binding_level->this_block = block;
5ff904cd
JL		 15163}
15164
c7e4ee3a 15165/* ~~gcc/tree.h *should* declare this, because toplev.c references it. */
5ff904cd 15166
c7e4ee3a 15167/* Can't 'yydebug' a front end not generated by yacc/bison! */
bc289659
ML		 15168
15169void
c7e4ee3a
CB		 15170set_yydebug (value)
15171 int value;
bc289659 15172{
c7e4ee3a
CB		 15173 if (value)
15174 fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
bc289659
ML		 15175}
15176
c7e4ee3a
CB		 15177tree
15178signed_or_unsigned_type (unsignedp, type)
15179 int unsignedp;
15180 tree type;
5ff904cd 15181{
c7e4ee3a 15182 tree type2;
5ff904cd 15183
c7e4ee3a
CB		 15184 if (! INTEGRAL_TYPE_P (type))
15185 return type;
15186 if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15187 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15188 if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15189 return unsignedp ? unsigned_type_node : integer_type_node;
15190 if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15191 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15192 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15193 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15194 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15195 return (unsignedp ? long_long_unsigned_type_node
15196 : long_long_integer_type_node);
5ff904cd 15197
c7e4ee3a
CB		 15198 type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15199 if (type2 == NULL_TREE)
15200 return type;
f84639ba 15201
c7e4ee3a 15202 return type2;
5ff904cd
JL		 15203}
15204
c7e4ee3a
CB		 15205tree
15206signed_type (type)
15207 tree type;
5ff904cd 15208{
c7e4ee3a
CB		 15209 tree type1 = TYPE_MAIN_VARIANT (type);
15210 ffeinfoKindtype kt;
15211 tree type2;
5ff904cd 15212
c7e4ee3a
CB		 15213 if (type1 == unsigned_char_type_node || type1 == char_type_node)
15214 return signed_char_type_node;
15215 if (type1 == unsigned_type_node)
15216 return integer_type_node;
15217 if (type1 == short_unsigned_type_node)
15218 return short_integer_type_node;
15219 if (type1 == long_unsigned_type_node)
15220 return long_integer_type_node;
15221 if (type1 == long_long_unsigned_type_node)
15222 return long_long_integer_type_node;
15223#if 0 /* gcc/c-* files only */
15224 if (type1 == unsigned_intDI_type_node)
15225 return intDI_type_node;
15226 if (type1 == unsigned_intSI_type_node)
15227 return intSI_type_node;
15228 if (type1 == unsigned_intHI_type_node)
15229 return intHI_type_node;
15230 if (type1 == unsigned_intQI_type_node)
15231 return intQI_type_node;
15232#endif
5ff904cd 15233
c7e4ee3a
CB		 15234 type2 = type_for_size (TYPE_PRECISION (type1), 0);
15235 if (type2 != NULL_TREE)
15236 return type2;
5ff904cd 15237
c7e4ee3a
CB		 15238 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15239 {
15240 type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
5ff904cd 15241
c7e4ee3a
CB		 15242 if (type1 == type2)
15243 return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15244 }
15245
15246 return type;
5ff904cd
JL		 15247}
15248
c7e4ee3a
CB		 15249/* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15250 or validate its data type for an `if' or `while' statement or ?..: exp.
15251
15252 This preparation consists of taking the ordinary
15253 representation of an expression expr and producing a valid tree
15254 boolean expression describing whether expr is nonzero. We could
15255 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15256 but we optimize comparisons, &&, ||, and !.
15257
15258 The resulting type should always be `integer_type_node'. */
5ff904cd
JL		 15259
15260tree
c7e4ee3a
CB		 15261truthvalue_conversion (expr)
15262 tree expr;
5ff904cd 15263{
c7e4ee3a
CB		 15264 if (TREE_CODE (expr) == ERROR_MARK)
15265 return expr;
5ff904cd 15266
c7e4ee3a
CB		 15267#if 0 /* This appears to be wrong for C++. */
15268 /* These really should return error_mark_node after 2.4 is stable.
15269 But not all callers handle ERROR_MARK properly. */
15270 switch (TREE_CODE (TREE_TYPE (expr)))
15271 {
15272 case RECORD_TYPE:
15273 error ("struct type value used where scalar is required");
15274 return integer_zero_node;
5ff904cd 15275
c7e4ee3a
CB		 15276 case UNION_TYPE:
15277 error ("union type value used where scalar is required");
15278 return integer_zero_node;
5ff904cd 15279
c7e4ee3a
CB		 15280 case ARRAY_TYPE:
15281 error ("array type value used where scalar is required");
15282 return integer_zero_node;
5ff904cd 15283
c7e4ee3a
CB		 15284 default:
15285 break;
15286 }
15287#endif /* 0 */
5ff904cd 15288
c7e4ee3a
CB		 15289 switch (TREE_CODE (expr))
15290 {
15291 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15292 or comparison expressions as truth values at this level. */
15293#if 0
15294 case COMPONENT_REF:
15295 /* A one-bit unsigned bit-field is already acceptable. */
15296 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15297 && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15298 return expr;
15299 break;
15300#endif
15301
15302 case EQ_EXPR:
15303 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15304 or comparison expressions as truth values at this level. */
15305#if 0
15306 if (integer_zerop (TREE_OPERAND (expr, 1)))
15307 return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15308#endif
15309 case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15310 case TRUTH_ANDIF_EXPR:
15311 case TRUTH_ORIF_EXPR:
15312 case TRUTH_AND_EXPR:
15313 case TRUTH_OR_EXPR:
15314 case TRUTH_XOR_EXPR:
15315 TREE_TYPE (expr) = integer_type_node;
15316 return expr;
5ff904cd 15317
c7e4ee3a
CB		 15318 case ERROR_MARK:
15319 return expr;
5ff904cd 15320
c7e4ee3a
CB		 15321 case INTEGER_CST:
15322 return integer_zerop (expr) ? integer_zero_node : integer_one_node;
5ff904cd 15323
c7e4ee3a
CB		 15324 case REAL_CST:
15325 return real_zerop (expr) ? integer_zero_node : integer_one_node;
5ff904cd 15326
c7e4ee3a
CB		 15327 case ADDR_EXPR:
15328 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15329 return build (COMPOUND_EXPR, integer_type_node,
15330 TREE_OPERAND (expr, 0), integer_one_node);
15331 else
15332 return integer_one_node;
5ff904cd 15333
c7e4ee3a
CB		 15334 case COMPLEX_EXPR:
15335 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15336 ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15337 integer_type_node,
15338 truthvalue_conversion (TREE_OPERAND (expr, 0)),
15339 truthvalue_conversion (TREE_OPERAND (expr, 1)));
5ff904cd 15340
c7e4ee3a
CB		 15341 case NEGATE_EXPR:
15342 case ABS_EXPR:
15343 case FLOAT_EXPR:
15344 case FFS_EXPR:
15345 /* These don't change whether an object is non-zero or zero. */
15346 return truthvalue_conversion (TREE_OPERAND (expr, 0));
5ff904cd 15347
c7e4ee3a
CB		 15348 case LROTATE_EXPR:
15349 case RROTATE_EXPR:
15350 /* These don't change whether an object is zero or non-zero, but
15351 we can't ignore them if their second arg has side-effects. */
15352 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15353 return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15354 truthvalue_conversion (TREE_OPERAND (expr, 0)));
15355 else
15356 return truthvalue_conversion (TREE_OPERAND (expr, 0));
5ff904cd 15357
c7e4ee3a
CB		 15358 case COND_EXPR:
15359 /* Distribute the conversion into the arms of a COND_EXPR. */
15360 return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15361 truthvalue_conversion (TREE_OPERAND (expr, 1)),
15362 truthvalue_conversion (TREE_OPERAND (expr, 2))));
5ff904cd 15363
c7e4ee3a
CB		 15364 case CONVERT_EXPR:
15365 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15366 since that affects how `default_conversion' will behave. */
15367 if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15368 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15369 break;
15370 /* fall through... */
15371 case NOP_EXPR:
15372 /* If this is widening the argument, we can ignore it. */
15373 if (TYPE_PRECISION (TREE_TYPE (expr))
15374 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15375 return truthvalue_conversion (TREE_OPERAND (expr, 0));
15376 break;
5ff904cd 15377
c7e4ee3a
CB		 15378 case MINUS_EXPR:
15379 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15380 this case. */
15381 if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15382 && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15383 break;
15384 /* fall through... */
15385 case BIT_XOR_EXPR:
15386 /* This and MINUS_EXPR can be changed into a comparison of the
15387 two objects. */
15388 if (TREE_TYPE (TREE_OPERAND (expr, 0))
15389 == TREE_TYPE (TREE_OPERAND (expr, 1)))
15390 return ffecom_2 (NE_EXPR, integer_type_node,
15391 TREE_OPERAND (expr, 0),
15392 TREE_OPERAND (expr, 1));
15393 return ffecom_2 (NE_EXPR, integer_type_node,
15394 TREE_OPERAND (expr, 0),
15395 fold (build1 (NOP_EXPR,
15396 TREE_TYPE (TREE_OPERAND (expr, 0)),
15397 TREE_OPERAND (expr, 1))));
15398
15399 case BIT_AND_EXPR:
15400 if (integer_onep (TREE_OPERAND (expr, 1)))
15401 return expr;
15402 break;
15403
15404 case MODIFY_EXPR:
15405#if 0 /* No such thing in Fortran. */
15406 if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15407 warning ("suggest parentheses around assignment used as truth value");
15408#endif
15409 break;
15410
15411 default:
15412 break;
5ff904cd
JL		 15413 }
15414
c7e4ee3a
CB		 15415 if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15416 return (ffecom_2
15417 ((TREE_SIDE_EFFECTS (expr)
15418 ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15419 integer_type_node,
15420 truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15421 TREE_TYPE (TREE_TYPE (expr)),
15422 expr)),
15423 truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15424 TREE_TYPE (TREE_TYPE (expr)),
15425 expr))));
15426
15427 return ffecom_2 (NE_EXPR, integer_type_node,
15428 expr,
15429 convert (TREE_TYPE (expr), integer_zero_node));
15430}
15431
15432tree
15433type_for_mode (mode, unsignedp)
15434 enum machine_mode mode;
15435 int unsignedp;
15436{
15437 int i;
15438 int j;
15439 tree t;
5ff904cd 15440
c7e4ee3a
CB		 15441 if (mode == TYPE_MODE (integer_type_node))
15442 return unsignedp ? unsigned_type_node : integer_type_node;
5ff904cd 15443
c7e4ee3a
CB		 15444 if (mode == TYPE_MODE (signed_char_type_node))
15445 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
5ff904cd 15446
c7e4ee3a
CB		 15447 if (mode == TYPE_MODE (short_integer_type_node))
15448 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
5ff904cd 15449
c7e4ee3a
CB		 15450 if (mode == TYPE_MODE (long_integer_type_node))
15451 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
5ff904cd 15452
c7e4ee3a
CB		 15453 if (mode == TYPE_MODE (long_long_integer_type_node))
15454 return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
5ff904cd 15455
c7e4ee3a
CB		 15456 if (mode == TYPE_MODE (float_type_node))
15457 return float_type_node;
5ff904cd 15458
c7e4ee3a
CB		 15459 if (mode == TYPE_MODE (double_type_node))
15460 return double_type_node;
5ff904cd 15461
c7e4ee3a
CB		 15462 if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15463 return build_pointer_type (char_type_node);
5ff904cd 15464
c7e4ee3a
CB		 15465 if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15466 return build_pointer_type (integer_type_node);
5ff904cd 15467
c7e4ee3a
CB		 15468 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15469 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15470 {
15471 if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15472 && (mode == TYPE_MODE (t)))
15473 {
15474 if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15475 return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15476 else
15477 return t;
15478 }
15479 }
5ff904cd 15480
c7e4ee3a 15481 return 0;
5ff904cd
JL		 15482}
15483
c7e4ee3a
CB		 15484tree
15485type_for_size (bits, unsignedp)
15486 unsigned bits;
15487 int unsignedp;
5ff904cd 15488{
c7e4ee3a
CB		 15489 ffeinfoKindtype kt;
15490 tree type_node;
5ff904cd 15491
c7e4ee3a
CB		 15492 if (bits == TYPE_PRECISION (integer_type_node))
15493 return unsignedp ? unsigned_type_node : integer_type_node;
5ff904cd 15494
c7e4ee3a
CB		 15495 if (bits == TYPE_PRECISION (signed_char_type_node))
15496 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
5ff904cd 15497
c7e4ee3a
CB		 15498 if (bits == TYPE_PRECISION (short_integer_type_node))
15499 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
5ff904cd 15500
c7e4ee3a
CB		 15501 if (bits == TYPE_PRECISION (long_integer_type_node))
15502 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
5ff904cd 15503
c7e4ee3a
CB		 15504 if (bits == TYPE_PRECISION (long_long_integer_type_node))
15505 return (unsignedp ? long_long_unsigned_type_node
15506 : long_long_integer_type_node);
5ff904cd 15507
c7e4ee3a 15508 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
5ff904cd 15509 {
c7e4ee3a 15510 type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
5ff904cd 15511
c7e4ee3a
CB		 15512 if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15513 return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15514 : type_node;
15515 }
5ff904cd 15516
c7e4ee3a
CB		 15517 return 0;
15518}
5ff904cd 15519
c7e4ee3a
CB		 15520tree
15521unsigned_type (type)
15522 tree type;
15523{
15524 tree type1 = TYPE_MAIN_VARIANT (type);
15525 ffeinfoKindtype kt;
15526 tree type2;
5ff904cd 15527
c7e4ee3a
CB		 15528 if (type1 == signed_char_type_node || type1 == char_type_node)
15529 return unsigned_char_type_node;
15530 if (type1 == integer_type_node)
15531 return unsigned_type_node;
15532 if (type1 == short_integer_type_node)
15533 return short_unsigned_type_node;
15534 if (type1 == long_integer_type_node)
15535 return long_unsigned_type_node;
15536 if (type1 == long_long_integer_type_node)
15537 return long_long_unsigned_type_node;
15538#if 0 /* gcc/c-* files only */
15539 if (type1 == intDI_type_node)
15540 return unsigned_intDI_type_node;
15541 if (type1 == intSI_type_node)
15542 return unsigned_intSI_type_node;
15543 if (type1 == intHI_type_node)
15544 return unsigned_intHI_type_node;
15545 if (type1 == intQI_type_node)
15546 return unsigned_intQI_type_node;
15547#endif
5ff904cd 15548
c7e4ee3a
CB		 15549 type2 = type_for_size (TYPE_PRECISION (type1), 1);
15550 if (type2 != NULL_TREE)
15551 return type2;
5ff904cd 15552
c7e4ee3a
CB		 15553 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15554 {
15555 type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
5ff904cd 15556
c7e4ee3a
CB		 15557 if (type1 == type2)
15558 return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15559 }
5ff904cd 15560
c7e4ee3a
CB		 15561 return type;
15562}
5ff904cd 15563
c7e4ee3a
CB		 15564#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15565\f
15566#if FFECOM_GCC_INCLUDE
5ff904cd 15567
c7e4ee3a 15568/* From gcc/cccp.c, the code to handle -I. */
5ff904cd 15569
c7e4ee3a
CB		 15570/* Skip leading "./" from a directory name.
15571 This may yield the empty string, which represents the current directory. */
5ff904cd 15572
c7e4ee3a
CB		 15573static const char *
15574skip_redundant_dir_prefix (const char *dir)
15575{
15576 while (dir[0] == '.' && dir[1] == '/')
15577 for (dir += 2; *dir == '/'; dir++)
15578 continue;
15579 if (dir[0] == '.' && !dir[1])
15580 dir++;
15581 return dir;
15582}
5ff904cd 15583
c7e4ee3a
CB		 15584/* The file_name_map structure holds a mapping of file names for a
15585 particular directory. This mapping is read from the file named
15586 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15587 map filenames on a file system with severe filename restrictions,
15588 such as DOS. The format of the file name map file is just a series
15589 of lines with two tokens on each line. The first token is the name
15590 to map, and the second token is the actual name to use. */
5ff904cd 15591
c7e4ee3a
CB		 15592struct file_name_map
15593{
15594 struct file_name_map *map_next;
15595 char *map_from;
15596 char *map_to;
15597};
5ff904cd 15598
c7e4ee3a 15599#define FILE_NAME_MAP_FILE "header.gcc"
5ff904cd 15600
c7e4ee3a
CB		 15601/* Current maximum length of directory names in the search path
15602 for include files. (Altered as we get more of them.) */
5ff904cd 15603
c7e4ee3a 15604static int max_include_len = 0;
5ff904cd 15605
c7e4ee3a
CB		 15606struct file_name_list
15607 {
15608 struct file_name_list *next;
15609 char *fname;
15610 /* Mapping of file names for this directory. */
15611 struct file_name_map *name_map;
15612 /* Non-zero if name_map is valid. */
15613 int got_name_map;
15614 };
5ff904cd 15615
c7e4ee3a
CB		 15616static struct file_name_list *include = NULL; /* First dir to search */
15617static struct file_name_list *last_include = NULL; /* Last in chain */
5ff904cd 15618
c7e4ee3a
CB		 15619/* I/O buffer structure.
15620 The `fname' field is nonzero for source files and #include files
15621 and for the dummy text used for -D and -U.
15622 It is zero for rescanning results of macro expansion
15623 and for expanding macro arguments. */
15624#define INPUT_STACK_MAX 400
15625static struct file_buf {
15626 char *fname;
15627 /* Filename specified with #line command. */
15628 char *nominal_fname;
15629 /* Record where in the search path this file was found.
15630 For #include_next. */
15631 struct file_name_list *dir;
15632 ffewhereLine line;
15633 ffewhereColumn column;
15634} instack[INPUT_STACK_MAX];
5ff904cd 15635
c7e4ee3a
CB		 15636static int last_error_tick = 0; /* Incremented each time we print it. */
15637static int input_file_stack_tick = 0; /* Incremented when status changes. */
5ff904cd 15638
c7e4ee3a
CB		 15639/* Current nesting level of input sources.
15640 `instack[indepth]' is the level currently being read. */
15641static int indepth = -1;
5ff904cd 15642
c7e4ee3a 15643typedef struct file_buf FILE_BUF;
5ff904cd 15644
c7e4ee3a 15645typedef unsigned char U_CHAR;
5ff904cd 15646
c7e4ee3a
CB		 15647/* table to tell if char can be part of a C identifier. */
15648U_CHAR is_idchar[256];
15649/* table to tell if char can be first char of a c identifier. */
15650U_CHAR is_idstart[256];
15651/* table to tell if c is horizontal space. */
15652U_CHAR is_hor_space[256];
15653/* table to tell if c is horizontal or vertical space. */
15654static U_CHAR is_space[256];
5ff904cd 15655
c7e4ee3a
CB		 15656#define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15657#define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
5ff904cd 15658
c7e4ee3a
CB		 15659/* Nonzero means -I- has been seen,
15660 so don't look for #include "foo" the source-file directory. */
15661static int ignore_srcdir;
5ff904cd 15662
c7e4ee3a
CB		 15663#ifndef INCLUDE_LEN_FUDGE
15664#define INCLUDE_LEN_FUDGE 0
15665#endif
5ff904cd 15666
c7e4ee3a
CB		 15667static void append_include_chain (struct file_name_list *first,
15668 struct file_name_list *last);
15669static FILE *open_include_file (char *filename,
15670 struct file_name_list *searchptr);
15671static void print_containing_files (ffebadSeverity sev);
15672static const char *skip_redundant_dir_prefix (const char *);
15673static char *read_filename_string (int ch, FILE *f);
15674static struct file_name_map *read_name_map (const char *dirname);
5ff904cd 15675
c7e4ee3a
CB		 15676/* Append a chain of `struct file_name_list's
15677 to the end of the main include chain.
15678 FIRST is the beginning of the chain to append, and LAST is the end. */
5ff904cd 15679
c7e4ee3a
CB		 15680static void
15681append_include_chain (first, last)
15682 struct file_name_list *first, *last;
5ff904cd 15683{
c7e4ee3a 15684 struct file_name_list *dir;
5ff904cd 15685
c7e4ee3a
CB		 15686 if (!first || !last)
15687 return;
5ff904cd 15688
c7e4ee3a
CB		 15689 if (include == 0)
15690 include = first;
15691 else
15692 last_include->next = first;
5ff904cd 15693
c7e4ee3a
CB		 15694 for (dir = first; ; dir = dir->next) {
15695 int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15696 if (len > max_include_len)
15697 max_include_len = len;
15698 if (dir == last)
15699 break;
15700 }
15701
15702 last->next = NULL;
15703 last_include = last;
5ff904cd
JL		 15704}
15705
c7e4ee3a
CB		 15706/* Try to open include file FILENAME. SEARCHPTR is the directory
15707 being tried from the include file search path. This function maps
15708 filenames on file systems based on information read by
15709 read_name_map. */
15710
15711static FILE *
15712open_include_file (filename, searchptr)
15713 char *filename;
15714 struct file_name_list *searchptr;
5ff904cd 15715{
c7e4ee3a
CB		 15716 register struct file_name_map *map;
15717 register char *from;
15718 char *p, *dir;
5ff904cd 15719
c7e4ee3a
CB		 15720 if (searchptr && ! searchptr->got_name_map)
15721 {
15722 searchptr->name_map = read_name_map (searchptr->fname
15723 ? searchptr->fname : ".");
15724 searchptr->got_name_map = 1;
15725 }
5ff904cd 15726
c7e4ee3a
CB		 15727 /* First check the mapping for the directory we are using. */
15728 if (searchptr && searchptr->name_map)
15729 {
15730 from = filename;
15731 if (searchptr->fname)
15732 from += strlen (searchptr->fname) + 1;
15733 for (map = searchptr->name_map; map; map = map->map_next)
15734 {
15735 if (! strcmp (map->map_from, from))
15736 {
15737 /* Found a match. */
15738 return fopen (map->map_to, "r");
15739 }
15740 }
15741 }
5ff904cd 15742
c7e4ee3a
CB		 15743 /* Try to find a mapping file for the particular directory we are
15744 looking in. Thus #include <sys/types.h> will look up sys/types.h
15745 in /usr/include/header.gcc and look up types.h in
15746 /usr/include/sys/header.gcc. */
15747 p = rindex (filename, '/');
15748#ifdef DIR_SEPARATOR
15749 if (! p) p = rindex (filename, DIR_SEPARATOR);
15750 else {
15751 char *tmp = rindex (filename, DIR_SEPARATOR);
15752 if (tmp != NULL && tmp > p) p = tmp;
15753 }
15754#endif
15755 if (! p)
15756 p = filename;
15757 if (searchptr
15758 && searchptr->fname
15759 && strlen (searchptr->fname) == (size_t) (p - filename)
15760 && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15761 {
15762 /* FILENAME is in SEARCHPTR, which we've already checked. */
15763 return fopen (filename, "r");
15764 }
15765
15766 if (p == filename)
15767 {
15768 from = filename;
15769 map = read_name_map (".");
15770 }
15771 else
5ff904cd 15772 {
c7e4ee3a
CB		 15773 dir = (char *) xmalloc (p - filename + 1);
15774 memcpy (dir, filename, p - filename);
15775 dir[p - filename] = '\0';
15776 from = p + 1;
15777 map = read_name_map (dir);
15778 free (dir);
5ff904cd 15779 }
c7e4ee3a
CB		 15780 for (; map; map = map->map_next)
15781 if (! strcmp (map->map_from, from))
15782 return fopen (map->map_to, "r");
5ff904cd 15783
c7e4ee3a 15784 return fopen (filename, "r");
5ff904cd
JL		 15785}
15786
c7e4ee3a
CB		 15787/* Print the file names and line numbers of the #include
15788 commands which led to the current file. */
5ff904cd 15789
c7e4ee3a
CB		 15790static void
15791print_containing_files (ffebadSeverity sev)
15792{
15793 FILE_BUF *ip = NULL;
15794 int i;
15795 int first = 1;
15796 const char *str1;
15797 const char *str2;
5ff904cd 15798
c7e4ee3a
CB		 15799 /* If stack of files hasn't changed since we last printed
15800 this info, don't repeat it. */
15801 if (last_error_tick == input_file_stack_tick)
15802 return;
5ff904cd 15803
c7e4ee3a
CB		 15804 for (i = indepth; i >= 0; i--)
15805 if (instack[i].fname != NULL) {
15806 ip = &instack[i];
15807 break;
15808 }
5ff904cd 15809
c7e4ee3a
CB		 15810 /* Give up if we don't find a source file. */
15811 if (ip == NULL)
15812 return;
5ff904cd 15813
c7e4ee3a
CB		 15814 /* Find the other, outer source files. */
15815 for (i--; i >= 0; i--)
15816 if (instack[i].fname != NULL)
15817 {
15818 ip = &instack[i];
15819 if (first)
15820 {
15821 first = 0;
15822 str1 = "In file included";
15823 }
15824 else
15825 {
15826 str1 = "... ...";
15827 }
5ff904cd 15828
c7e4ee3a
CB		 15829 if (i == 1)
15830 str2 = ":";
15831 else
15832 str2 = "";
5ff904cd 15833
c7e4ee3a
CB		 15834 ffebad_start_msg ("%A from %B at %0%C", sev);
15835 ffebad_here (0, ip->line, ip->column);
15836 ffebad_string (str1);
15837 ffebad_string (ip->nominal_fname);
15838 ffebad_string (str2);
15839 ffebad_finish ();
15840 }
5ff904cd 15841
c7e4ee3a
CB		 15842 /* Record we have printed the status as of this time. */
15843 last_error_tick = input_file_stack_tick;
15844}
5ff904cd 15845
c7e4ee3a
CB		 15846/* Read a space delimited string of unlimited length from a stdio
15847 file. */
5ff904cd 15848
c7e4ee3a
CB		 15849static char *
15850read_filename_string (ch, f)
15851 int ch;
15852 FILE *f;
15853{
15854 char *alloc, *set;
15855 int len;
5ff904cd 15856
c7e4ee3a
CB		 15857 len = 20;
15858 set = alloc = xmalloc (len + 1);
15859 if (! is_space[ch])
15860 {
15861 *set++ = ch;
15862 while ((ch = getc (f)) != EOF && ! is_space[ch])
15863 {
15864 if (set - alloc == len)
15865 {
15866 len *= 2;
15867 alloc = xrealloc (alloc, len + 1);
15868 set = alloc + len / 2;
15869 }
15870 *set++ = ch;
15871 }
15872 }
15873 *set = '\0';
15874 ungetc (ch, f);
15875 return alloc;
15876}
5ff904cd 15877
c7e4ee3a 15878/* Read the file name map file for DIRNAME. */
5ff904cd 15879
c7e4ee3a
CB		 15880static struct file_name_map *
15881read_name_map (dirname)
15882 const char *dirname;
15883{
15884 /* This structure holds a linked list of file name maps, one per
15885 directory. */
15886 struct file_name_map_list
15887 {
15888 struct file_name_map_list *map_list_next;
15889 char *map_list_name;
15890 struct file_name_map *map_list_map;
15891 };
15892 static struct file_name_map_list *map_list;
15893 register struct file_name_map_list *map_list_ptr;
15894 char *name;
15895 FILE *f;
15896 size_t dirlen;
15897 int separator_needed;
5ff904cd 15898
c7e4ee3a 15899 dirname = skip_redundant_dir_prefix (dirname);
5ff904cd 15900
c7e4ee3a
CB		 15901 for (map_list_ptr = map_list; map_list_ptr;
15902 map_list_ptr = map_list_ptr->map_list_next)
15903 if (! strcmp (map_list_ptr->map_list_name, dirname))
15904 return map_list_ptr->map_list_map;
5ff904cd 15905
c7e4ee3a
CB		 15906 map_list_ptr = ((struct file_name_map_list *)
15907 xmalloc (sizeof (struct file_name_map_list)));
15908 map_list_ptr->map_list_name = xstrdup (dirname);
15909 map_list_ptr->map_list_map = NULL;
5ff904cd 15910
c7e4ee3a
CB		 15911 dirlen = strlen (dirname);
15912 separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15913 name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15914 strcpy (name, dirname);
15915 name[dirlen] = '/';
15916 strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15917 f = fopen (name, "r");
15918 free (name);
15919 if (!f)
15920 map_list_ptr->map_list_map = NULL;
15921 else
15922 {
15923 int ch;
5ff904cd 15924
c7e4ee3a
CB		 15925 while ((ch = getc (f)) != EOF)
15926 {
15927 char *from, *to;
15928 struct file_name_map *ptr;
15929
15930 if (is_space[ch])
15931 continue;
15932 from = read_filename_string (ch, f);
15933 while ((ch = getc (f)) != EOF && is_hor_space[ch])
15934 ;
15935 to = read_filename_string (ch, f);
5ff904cd 15936
c7e4ee3a
CB		 15937 ptr = ((struct file_name_map *)
15938 xmalloc (sizeof (struct file_name_map)));
15939 ptr->map_from = from;
5ff904cd 15940
c7e4ee3a
CB		 15941 /* Make the real filename absolute. */
15942 if (*to == '/')
15943 ptr->map_to = to;
15944 else
15945 {
15946 ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15947 strcpy (ptr->map_to, dirname);
15948 ptr->map_to[dirlen] = '/';
15949 strcpy (ptr->map_to + dirlen + separator_needed, to);
15950 free (to);
15951 }
5ff904cd 15952
c7e4ee3a
CB		 15953 ptr->map_next = map_list_ptr->map_list_map;
15954 map_list_ptr->map_list_map = ptr;
5ff904cd 15955
c7e4ee3a
CB		 15956 while ((ch = getc (f)) != '\n')
15957 if (ch == EOF)
15958 break;
15959 }
15960 fclose (f);
5ff904cd
JL		 15961 }
15962
c7e4ee3a
CB		 15963 map_list_ptr->map_list_next = map_list;
15964 map_list = map_list_ptr;
5ff904cd 15965
c7e4ee3a 15966 return map_list_ptr->map_list_map;
5ff904cd
JL		 15967}
15968
c7e4ee3a
CB		 15969static void
15970ffecom_file_ (char *name)
5ff904cd 15971{
c7e4ee3a 15972 FILE_BUF *fp;
5ff904cd 15973
c7e4ee3a
CB		 15974 /* Do partial setup of input buffer for the sake of generating
15975 early #line directives (when -g is in effect). */
5ff904cd 15976
c7e4ee3a
CB		 15977 fp = &instack[++indepth];
15978 memset ((char *) fp, 0, sizeof (FILE_BUF));
15979 if (name == NULL)
15980 name = "";
15981 fp->nominal_fname = fp->fname = name;
15982}
5ff904cd 15983
c7e4ee3a 15984/* Initialize syntactic classifications of characters. */
5ff904cd 15985
c7e4ee3a
CB		 15986static void
15987ffecom_initialize_char_syntax_ ()
15988{
15989 register int i;
5ff904cd 15990
c7e4ee3a
CB		 15991 /*
15992 * Set up is_idchar and is_idstart tables. These should be
15993 * faster than saying (is_alpha (c) || c == '_'), etc.
15994 * Set up these things before calling any routines tthat
15995 * refer to them.
15996 */
15997 for (i = 'a'; i <= 'z'; i++) {
15998 is_idchar[i - 'a' + 'A'] = 1;
15999 is_idchar[i] = 1;
16000 is_idstart[i - 'a' + 'A'] = 1;
16001 is_idstart[i] = 1;
16002 }
16003 for (i = '0'; i <= '9'; i++)
16004 is_idchar[i] = 1;
16005 is_idchar['_'] = 1;
16006 is_idstart['_'] = 1;
5ff904cd 16007
c7e4ee3a
CB		 16008 /* horizontal space table */
16009 is_hor_space[' '] = 1;
16010 is_hor_space['\t'] = 1;
16011 is_hor_space['\v'] = 1;
16012 is_hor_space['\f'] = 1;
16013 is_hor_space['\r'] = 1;
5ff904cd 16014
c7e4ee3a
CB		 16015 is_space[' '] = 1;
16016 is_space['\t'] = 1;
16017 is_space['\v'] = 1;
16018 is_space['\f'] = 1;
16019 is_space['\n'] = 1;
16020 is_space['\r'] = 1;
16021}
5ff904cd 16022
c7e4ee3a
CB		 16023static void
16024ffecom_close_include_ (FILE *f)
16025{
16026 fclose (f);
5ff904cd 16027
c7e4ee3a
CB		 16028 indepth--;
16029 input_file_stack_tick++;
5ff904cd 16030
c7e4ee3a
CB		 16031 ffewhere_line_kill (instack[indepth].line);
16032 ffewhere_column_kill (instack[indepth].column);
16033}
5ff904cd 16034
c7e4ee3a
CB		 16035static int
16036ffecom_decode_include_option_ (char *spec)
16037{
16038 struct file_name_list *dirtmp;
16039
16040 if (! ignore_srcdir && !strcmp (spec, "-"))
16041 ignore_srcdir = 1;
16042 else
16043 {
16044 dirtmp = (struct file_name_list *)
16045 xmalloc (sizeof (struct file_name_list));
16046 dirtmp->next = 0; /* New one goes on the end */
16047 if (spec[0] != 0)
16048 dirtmp->fname = spec;
16049 else
16050 fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16051 dirtmp->got_name_map = 0;
16052 append_include_chain (dirtmp, dirtmp);
16053 }
16054 return 1;
5ff904cd
JL		 16055}
16056
c7e4ee3a
CB		 16057/* Open INCLUDEd file. */
16058
16059static FILE *
16060ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
5ff904cd 16061{
c7e4ee3a
CB		 16062 char *fbeg = name;
16063 size_t flen = strlen (fbeg);
16064 struct file_name_list *search_start = include; /* Chain of dirs to search */
16065 struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16066 struct file_name_list *searchptr = 0;
16067 char *fname; /* Dynamically allocated fname buffer */
16068 FILE *f;
16069 FILE_BUF *fp;
5ff904cd 16070
c7e4ee3a
CB		 16071 if (flen == 0)
16072 return NULL;
5ff904cd 16073
c7e4ee3a 16074 dsp[0].fname = NULL;
5ff904cd 16075
c7e4ee3a
CB		 16076 /* If -I- was specified, don't search current dir, only spec'd ones. */
16077 if (!ignore_srcdir)
16078 {
16079 for (fp = &instack[indepth]; fp >= instack; fp--)
16080 {
16081 int n;
16082 char *ep;
16083 char *nam;
5ff904cd 16084
c7e4ee3a
CB		 16085 if ((nam = fp->nominal_fname) != NULL)
16086 {
16087 /* Found a named file. Figure out dir of the file,
16088 and put it in front of the search list. */
16089 dsp[0].next = search_start;
16090 search_start = dsp;
16091#ifndef VMS
16092 ep = rindex (nam, '/');
16093#ifdef DIR_SEPARATOR
16094 if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR);
16095 else {
16096 char *tmp = rindex (nam, DIR_SEPARATOR);
16097 if (tmp != NULL && tmp > ep) ep = tmp;
16098 }
16099#endif
16100#else /* VMS */
16101 ep = rindex (nam, ']');
16102 if (ep == NULL) ep = rindex (nam, '>');
16103 if (ep == NULL) ep = rindex (nam, ':');
16104 if (ep != NULL) ep++;
16105#endif /* VMS */
16106 if (ep != NULL)
16107 {
16108 n = ep - nam;
16109 dsp[0].fname = (char *) xmalloc (n + 1);
16110 strncpy (dsp[0].fname, nam, n);
16111 dsp[0].fname[n] = '\0';
16112 if (n + INCLUDE_LEN_FUDGE > max_include_len)
16113 max_include_len = n + INCLUDE_LEN_FUDGE;
16114 }
16115 else
16116 dsp[0].fname = NULL; /* Current directory */
16117 dsp[0].got_name_map = 0;
16118 break;
16119 }
16120 }
16121 }
5ff904cd 16122
c7e4ee3a
CB		 16123 /* Allocate this permanently, because it gets stored in the definitions
16124 of macros. */
16125 fname = xmalloc (max_include_len + flen + 4);
16126 /* + 2 above for slash and terminating null. */
16127 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16128 for g77 yet). */
5ff904cd 16129
c7e4ee3a 16130 /* If specified file name is absolute, just open it. */
5ff904cd 16131
c7e4ee3a
CB		 16132 if (*fbeg == '/'
16133#ifdef DIR_SEPARATOR
16134 || *fbeg == DIR_SEPARATOR
16135#endif
16136 )
16137 {
16138 strncpy (fname, (char *) fbeg, flen);
16139 fname[flen] = 0;
16140 f = open_include_file (fname, NULL_PTR);
5ff904cd 16141 }
c7e4ee3a
CB		 16142 else
16143 {
16144 f = NULL;
5ff904cd 16145
c7e4ee3a
CB		 16146 /* Search directory path, trying to open the file.
16147 Copy each filename tried into FNAME. */
5ff904cd 16148
c7e4ee3a
CB		 16149 for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16150 {
16151 if (searchptr->fname)
16152 {
16153 /* The empty string in a search path is ignored.
16154 This makes it possible to turn off entirely
16155 a standard piece of the list. */
16156 if (searchptr->fname[0] == 0)
16157 continue;
16158 strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16159 if (fname[0] && fname[strlen (fname) - 1] != '/')
16160 strcat (fname, "/");
16161 fname[strlen (fname) + flen] = 0;
16162 }
16163 else
16164 fname[0] = 0;
5ff904cd 16165
c7e4ee3a
CB		 16166 strncat (fname, fbeg, flen);
16167#ifdef VMS
16168 /* Change this 1/2 Unix 1/2 VMS file specification into a
16169 full VMS file specification */
16170 if (searchptr->fname && (searchptr->fname[0] != 0))
16171 {
16172 /* Fix up the filename */
16173 hack_vms_include_specification (fname);
16174 }
16175 else
16176 {
16177 /* This is a normal VMS filespec, so use it unchanged. */
16178 strncpy (fname, (char *) fbeg, flen);
16179 fname[flen] = 0;
16180#if 0 /* Not for g77. */
16181 /* if it's '#include filename', add the missing .h */
16182 if (index (fname, '.') == NULL)
16183 strcat (fname, ".h");
5ff904cd 16184#endif
c7e4ee3a
CB		 16185 }
16186#endif /* VMS */
16187 f = open_include_file (fname, searchptr);
16188#ifdef EACCES
16189 if (f == NULL && errno == EACCES)
16190 {
16191 print_containing_files (FFEBAD_severityWARNING);
16192 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16193 FFEBAD_severityWARNING);
16194 ffebad_string (fname);
16195 ffebad_here (0, l, c);
16196 ffebad_finish ();
16197 }
16198#endif
16199 if (f != NULL)
16200 break;
16201 }
16202 }
5ff904cd 16203
c7e4ee3a 16204 if (f == NULL)
5ff904cd 16205 {
c7e4ee3a 16206 /* A file that was not found. */
5ff904cd 16207
c7e4ee3a
CB		 16208 strncpy (fname, (char *) fbeg, flen);
16209 fname[flen] = 0;
16210 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16211 ffebad_start (FFEBAD_OPEN_INCLUDE);
16212 ffebad_here (0, l, c);
16213 ffebad_string (fname);
16214 ffebad_finish ();
5ff904cd
JL		 16215 }
16216
c7e4ee3a
CB		 16217 if (dsp[0].fname != NULL)
16218 free (dsp[0].fname);
5ff904cd 16219
c7e4ee3a
CB		 16220 if (f == NULL)
16221 return NULL;
5ff904cd 16222
c7e4ee3a
CB		 16223 if (indepth >= (INPUT_STACK_MAX - 1))
16224 {
16225 print_containing_files (FFEBAD_severityFATAL);
16226 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16227 FFEBAD_severityFATAL);
16228 ffebad_string (fname);
16229 ffebad_here (0, l, c);
16230 ffebad_finish ();
16231 return NULL;
16232 }
5ff904cd 16233
c7e4ee3a
CB		 16234 instack[indepth].line = ffewhere_line_use (l);
16235 instack[indepth].column = ffewhere_column_use (c);
5ff904cd 16236
c7e4ee3a
CB		 16237 fp = &instack[indepth + 1];
16238 memset ((char *) fp, 0, sizeof (FILE_BUF));
16239 fp->nominal_fname = fp->fname = fname;
16240 fp->dir = searchptr;
5ff904cd 16241
c7e4ee3a
CB		 16242 indepth++;
16243 input_file_stack_tick++;
5ff904cd 16244
c7e4ee3a
CB		 16245 return f;
16246}
16247#endif /* FFECOM_GCC_INCLUDE */
5ff904cd 16248
c7e4ee3a
CB		 16249/**INDENT* (Do not reformat this comment even with -fca option.)
16250 Data-gathering files: Given the source file listed below, compiled with
16251 f2c I obtained the output file listed after that, and from the output
16252 file I derived the above code.
5ff904cd 16253
c7e4ee3a
CB		 16254-------- (begin input file to f2c)
16255 implicit none
16256 character*10 A1,A2
16257 complex C1,C2
16258 integer I1,I2
16259 real R1,R2
16260 double precision D1,D2
16261C
16262 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16263c /
16264 call fooI(I1/I2)
16265 call fooR(R1/I1)
16266 call fooD(D1/I1)
16267 call fooC(C1/I1)
16268 call fooR(R1/R2)
16269 call fooD(R1/D1)
16270 call fooD(D1/D2)
16271 call fooD(D1/R1)
16272 call fooC(C1/C2)
16273 call fooC(C1/R1)
16274 call fooZ(C1/D1)
16275c **
16276 call fooI(I1**I2)
16277 call fooR(R1**I1)
16278 call fooD(D1**I1)
16279 call fooC(C1**I1)
16280 call fooR(R1**R2)
16281 call fooD(R1**D1)
16282 call fooD(D1**D2)
16283 call fooD(D1**R1)
16284 call fooC(C1**C2)
16285 call fooC(C1**R1)
16286 call fooZ(C1**D1)
16287c FFEINTRIN_impABS
16288 call fooR(ABS(R1))
16289c FFEINTRIN_impACOS
16290 call fooR(ACOS(R1))
16291c FFEINTRIN_impAIMAG
16292 call fooR(AIMAG(C1))
16293c FFEINTRIN_impAINT
16294 call fooR(AINT(R1))
16295c FFEINTRIN_impALOG
16296 call fooR(ALOG(R1))
16297c FFEINTRIN_impALOG10
16298 call fooR(ALOG10(R1))
16299c FFEINTRIN_impAMAX0
16300 call fooR(AMAX0(I1,I2))
16301c FFEINTRIN_impAMAX1
16302 call fooR(AMAX1(R1,R2))
16303c FFEINTRIN_impAMIN0
16304 call fooR(AMIN0(I1,I2))
16305c FFEINTRIN_impAMIN1
16306 call fooR(AMIN1(R1,R2))
16307c FFEINTRIN_impAMOD
16308 call fooR(AMOD(R1,R2))
16309c FFEINTRIN_impANINT
16310 call fooR(ANINT(R1))
16311c FFEINTRIN_impASIN
16312 call fooR(ASIN(R1))
16313c FFEINTRIN_impATAN
16314 call fooR(ATAN(R1))
16315c FFEINTRIN_impATAN2
16316 call fooR(ATAN2(R1,R2))
16317c FFEINTRIN_impCABS
16318 call fooR(CABS(C1))
16319c FFEINTRIN_impCCOS
16320 call fooC(CCOS(C1))
16321c FFEINTRIN_impCEXP
16322 call fooC(CEXP(C1))
16323c FFEINTRIN_impCHAR
16324 call fooA(CHAR(I1))
16325c FFEINTRIN_impCLOG
16326 call fooC(CLOG(C1))
16327c FFEINTRIN_impCONJG
16328 call fooC(CONJG(C1))
16329c FFEINTRIN_impCOS
16330 call fooR(COS(R1))
16331c FFEINTRIN_impCOSH
16332 call fooR(COSH(R1))
16333c FFEINTRIN_impCSIN
16334 call fooC(CSIN(C1))
16335c FFEINTRIN_impCSQRT
16336 call fooC(CSQRT(C1))
16337c FFEINTRIN_impDABS
16338 call fooD(DABS(D1))
16339c FFEINTRIN_impDACOS
16340 call fooD(DACOS(D1))
16341c FFEINTRIN_impDASIN
16342 call fooD(DASIN(D1))
16343c FFEINTRIN_impDATAN
16344 call fooD(DATAN(D1))
16345c FFEINTRIN_impDATAN2
16346 call fooD(DATAN2(D1,D2))
16347c FFEINTRIN_impDCOS
16348 call fooD(DCOS(D1))
16349c FFEINTRIN_impDCOSH
16350 call fooD(DCOSH(D1))
16351c FFEINTRIN_impDDIM
16352 call fooD(DDIM(D1,D2))
16353c FFEINTRIN_impDEXP
16354 call fooD(DEXP(D1))
16355c FFEINTRIN_impDIM
16356 call fooR(DIM(R1,R2))
16357c FFEINTRIN_impDINT
16358 call fooD(DINT(D1))
16359c FFEINTRIN_impDLOG
16360 call fooD(DLOG(D1))
16361c FFEINTRIN_impDLOG10
16362 call fooD(DLOG10(D1))
16363c FFEINTRIN_impDMAX1
16364 call fooD(DMAX1(D1,D2))
16365c FFEINTRIN_impDMIN1
16366 call fooD(DMIN1(D1,D2))
16367c FFEINTRIN_impDMOD
16368 call fooD(DMOD(D1,D2))
16369c FFEINTRIN_impDNINT
16370 call fooD(DNINT(D1))
16371c FFEINTRIN_impDPROD
16372 call fooD(DPROD(R1,R2))
16373c FFEINTRIN_impDSIGN
16374 call fooD(DSIGN(D1,D2))
16375c FFEINTRIN_impDSIN
16376 call fooD(DSIN(D1))
16377c FFEINTRIN_impDSINH
16378 call fooD(DSINH(D1))
16379c FFEINTRIN_impDSQRT
16380 call fooD(DSQRT(D1))
16381c FFEINTRIN_impDTAN
16382 call fooD(DTAN(D1))
16383c FFEINTRIN_impDTANH
16384 call fooD(DTANH(D1))
16385c FFEINTRIN_impEXP
16386 call fooR(EXP(R1))
16387c FFEINTRIN_impIABS
16388 call fooI(IABS(I1))
16389c FFEINTRIN_impICHAR
16390 call fooI(ICHAR(A1))
16391c FFEINTRIN_impIDIM
16392 call fooI(IDIM(I1,I2))
16393c FFEINTRIN_impIDNINT
16394 call fooI(IDNINT(D1))
16395c FFEINTRIN_impINDEX
16396 call fooI(INDEX(A1,A2))
16397c FFEINTRIN_impISIGN
16398 call fooI(ISIGN(I1,I2))
16399c FFEINTRIN_impLEN
16400 call fooI(LEN(A1))
16401c FFEINTRIN_impLGE
16402 call fooL(LGE(A1,A2))
16403c FFEINTRIN_impLGT
16404 call fooL(LGT(A1,A2))
16405c FFEINTRIN_impLLE
16406 call fooL(LLE(A1,A2))
16407c FFEINTRIN_impLLT
16408 call fooL(LLT(A1,A2))
16409c FFEINTRIN_impMAX0
16410 call fooI(MAX0(I1,I2))
16411c FFEINTRIN_impMAX1
16412 call fooI(MAX1(R1,R2))
16413c FFEINTRIN_impMIN0
16414 call fooI(MIN0(I1,I2))
16415c FFEINTRIN_impMIN1
16416 call fooI(MIN1(R1,R2))
16417c FFEINTRIN_impMOD
16418 call fooI(MOD(I1,I2))
16419c FFEINTRIN_impNINT
16420 call fooI(NINT(R1))
16421c FFEINTRIN_impSIGN
16422 call fooR(SIGN(R1,R2))
16423c FFEINTRIN_impSIN
16424 call fooR(SIN(R1))
16425c FFEINTRIN_impSINH
16426 call fooR(SINH(R1))
16427c FFEINTRIN_impSQRT
16428 call fooR(SQRT(R1))
16429c FFEINTRIN_impTAN
16430 call fooR(TAN(R1))
16431c FFEINTRIN_impTANH
16432 call fooR(TANH(R1))
16433c FFEINTRIN_imp_CMPLX_C
16434 call fooC(cmplx(C1,C2))
16435c FFEINTRIN_imp_CMPLX_D
16436 call fooZ(cmplx(D1,D2))
16437c FFEINTRIN_imp_CMPLX_I
16438 call fooC(cmplx(I1,I2))
16439c FFEINTRIN_imp_CMPLX_R
16440 call fooC(cmplx(R1,R2))
16441c FFEINTRIN_imp_DBLE_C
16442 call fooD(dble(C1))
16443c FFEINTRIN_imp_DBLE_D
16444 call fooD(dble(D1))
16445c FFEINTRIN_imp_DBLE_I
16446 call fooD(dble(I1))
16447c FFEINTRIN_imp_DBLE_R
16448 call fooD(dble(R1))
16449c FFEINTRIN_imp_INT_C
16450 call fooI(int(C1))
16451c FFEINTRIN_imp_INT_D
16452 call fooI(int(D1))
16453c FFEINTRIN_imp_INT_I
16454 call fooI(int(I1))
16455c FFEINTRIN_imp_INT_R
16456 call fooI(int(R1))
16457c FFEINTRIN_imp_REAL_C
16458 call fooR(real(C1))
16459c FFEINTRIN_imp_REAL_D
16460 call fooR(real(D1))
16461c FFEINTRIN_imp_REAL_I
16462 call fooR(real(I1))
16463c FFEINTRIN_imp_REAL_R
16464 call fooR(real(R1))
16465c
16466c FFEINTRIN_imp_INT_D:
16467c
16468c FFEINTRIN_specIDINT
16469 call fooI(IDINT(D1))
16470c
16471c FFEINTRIN_imp_INT_R:
16472c
16473c FFEINTRIN_specIFIX
16474 call fooI(IFIX(R1))
16475c FFEINTRIN_specINT
16476 call fooI(INT(R1))
16477c
16478c FFEINTRIN_imp_REAL_D:
16479c
16480c FFEINTRIN_specSNGL
16481 call fooR(SNGL(D1))
16482c
16483c FFEINTRIN_imp_REAL_I:
16484c
16485c FFEINTRIN_specFLOAT
16486 call fooR(FLOAT(I1))
16487c FFEINTRIN_specREAL
16488 call fooR(REAL(I1))
16489c
16490 end
16491-------- (end input file to f2c)
5ff904cd 16492
c7e4ee3a
CB		 16493-------- (begin output from providing above input file as input to:
16494-------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16495-------- -e "s:^#.*$::g"')
5ff904cd 16496
c7e4ee3a
CB		 16497// -- translated by f2c (version 19950223).
16498 You must link the resulting object file with the libraries:
16499 -lf2c -lm (in that order)
16500//
5ff904cd 16501
5ff904cd 16502
c7e4ee3a 16503// f2c.h -- Standard Fortran to C header file //
5ff904cd 16504
c7e4ee3a 16505/// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
5ff904cd 16506
c7e4ee3a 16507 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
5ff904cd 16508
5ff904cd 16509
5ff904cd 16510
5ff904cd 16511
c7e4ee3a
CB		 16512// F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16513// we assume short, float are OK //
16514typedef long int // long int // integer;
16515typedef char *address;
16516typedef short int shortint;
16517typedef float real;
16518typedef double doublereal;
16519typedef struct { real r, i; } complex;
16520typedef struct { doublereal r, i; } doublecomplex;
16521typedef long int // long int // logical;
16522typedef short int shortlogical;
16523typedef char logical1;
16524typedef char integer1;
16525// typedef long long longint; // // system-dependent //
5ff904cd 16526
5ff904cd 16527
5ff904cd 16528
5ff904cd 16529
c7e4ee3a 16530// Extern is for use with -E //
5ff904cd 16531
5ff904cd 16532
5ff904cd 16533
5ff904cd 16534
c7e4ee3a 16535// I/O stuff //
5ff904cd 16536
5ff904cd 16537
5ff904cd 16538
5ff904cd 16539
5ff904cd 16540
5ff904cd 16541
5ff904cd 16542
5ff904cd 16543
c7e4ee3a
CB		 16544typedef long int // int or long int // flag;
16545typedef long int // int or long int // ftnlen;
16546typedef long int // int or long int // ftnint;
5ff904cd 16547
5ff904cd 16548
c7e4ee3a
CB		 16549//external read, write//
16550typedef struct
16551{ flag cierr;
16552 ftnint ciunit;
16553 flag ciend;
16554 char *cifmt;
16555 ftnint cirec;
16556} cilist;
5ff904cd 16557
c7e4ee3a
CB		 16558//internal read, write//
16559typedef struct
16560{ flag icierr;
16561 char *iciunit;
16562 flag iciend;
16563 char *icifmt;
16564 ftnint icirlen;
16565 ftnint icirnum;
16566} icilist;
5ff904cd 16567
c7e4ee3a
CB		 16568//open//
16569typedef struct
16570{ flag oerr;
16571 ftnint ounit;
16572 char *ofnm;
16573 ftnlen ofnmlen;
16574 char *osta;
16575 char *oacc;
16576 char *ofm;
16577 ftnint orl;
16578 char *oblnk;
16579} olist;
5ff904cd 16580
c7e4ee3a
CB		 16581//close//
16582typedef struct
16583{ flag cerr;
16584 ftnint cunit;
16585 char *csta;
16586} cllist;
5ff904cd 16587
c7e4ee3a
CB		 16588//rewind, backspace, endfile//
16589typedef struct
16590{ flag aerr;
16591 ftnint aunit;
16592} alist;
5ff904cd 16593
c7e4ee3a
CB		 16594// inquire //
16595typedef struct
16596{ flag inerr;
16597 ftnint inunit;
16598 char *infile;
16599 ftnlen infilen;
16600 ftnint *inex; //parameters in standard's order//
16601 ftnint *inopen;
16602 ftnint *innum;
16603 ftnint *innamed;
16604 char *inname;
16605 ftnlen innamlen;
16606 char *inacc;
16607 ftnlen inacclen;
16608 char *inseq;
16609 ftnlen inseqlen;
16610 char *indir;
16611 ftnlen indirlen;
16612 char *infmt;
16613 ftnlen infmtlen;
16614 char *inform;
16615 ftnint informlen;
16616 char *inunf;
16617 ftnlen inunflen;
16618 ftnint *inrecl;
16619 ftnint *innrec;
16620 char *inblank;
16621 ftnlen inblanklen;
16622} inlist;
5ff904cd 16623
5ff904cd 16624
5ff904cd 16625
c7e4ee3a
CB		 16626union Multitype { // for multiple entry points //
16627 integer1 g;
16628 shortint h;
16629 integer i;
16630 // longint j; //
16631 real r;
16632 doublereal d;
16633 complex c;
16634 doublecomplex z;
16635 };
16636
16637typedef union Multitype Multitype;
5ff904cd 16638
c7e4ee3a 16639typedef long Long; // No longer used; formerly in Namelist //
5ff904cd 16640
c7e4ee3a
CB		 16641struct Vardesc { // for Namelist //
16642 char *name;
16643 char *addr;
16644 ftnlen *dims;
16645 int type;
16646 };
16647typedef struct Vardesc Vardesc;
5ff904cd 16648
c7e4ee3a
CB		 16649struct Namelist {
16650 char *name;
16651 Vardesc **vars;
16652 int nvars;
16653 };
16654typedef struct Namelist Namelist;
5ff904cd 16655
5ff904cd 16656
5ff904cd 16657
5ff904cd 16658
5ff904cd 16659
5ff904cd 16660
5ff904cd 16661
5ff904cd 16662
c7e4ee3a 16663// procedure parameter types for -A and -C++ //
5ff904cd 16664
5ff904cd 16665
5ff904cd 16666
5ff904cd 16667
c7e4ee3a
CB		 16668typedef int // Unknown procedure type // (*U_fp)();
16669typedef shortint (*J_fp)();
16670typedef integer (*I_fp)();
16671typedef real (*R_fp)();
16672typedef doublereal (*D_fp)(), (*E_fp)();
16673typedef // Complex // void (*C_fp)();
16674typedef // Double Complex // void (*Z_fp)();
16675typedef logical (*L_fp)();
16676typedef shortlogical (*K_fp)();
16677typedef // Character // void (*H_fp)();
16678typedef // Subroutine // int (*S_fp)();
5ff904cd 16679
c7e4ee3a
CB		 16680// E_fp is for real functions when -R is not specified //
16681typedef void C_f; // complex function //
16682typedef void H_f; // character function //
16683typedef void Z_f; // double complex function //
16684typedef doublereal E_f; // real function with -R not specified //
5ff904cd 16685
c7e4ee3a 16686// undef any lower-case symbols that your C compiler predefines, e.g.: //
5ff904cd 16687
5ff904cd 16688
c7e4ee3a
CB		 16689// (No such symbols should be defined in a strict ANSI C compiler.
16690 We can avoid trouble with f2c-translated code by using
16691 gcc -ansi [-traditional].) //
16692
5ff904cd 16693
5ff904cd 16694
5ff904cd 16695
5ff904cd 16696
5ff904cd 16697
5ff904cd 16698
5ff904cd 16699
5ff904cd 16700
5ff904cd 16701
5ff904cd 16702
5ff904cd 16703
5ff904cd 16704
5ff904cd 16705
5ff904cd 16706
5ff904cd 16707
5ff904cd 16708
5ff904cd 16709
5ff904cd 16710
5ff904cd 16711
5ff904cd 16712
5ff904cd 16713
5ff904cd 16714
c7e4ee3a
CB		 16715// Main program // MAIN__()
16716{
16717 // System generated locals //
16718 integer i__1;
16719 real r__1, r__2;
16720 doublereal d__1, d__2;
16721 complex q__1;
16722 doublecomplex z__1, z__2, z__3;
16723 logical L__1;
16724 char ch__1[1];
16725
16726 // Builtin functions //
16727 void c_div();
16728 integer pow_ii();
16729 double pow_ri(), pow_di();
16730 void pow_ci();
16731 double pow_dd();
16732 void pow_zz();
16733 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16734 asin(), atan(), atan2(), c_abs();
16735 void c_cos(), c_exp(), c_log(), r_cnjg();
16736 double cos(), cosh();
16737 void c_sin(), c_sqrt();
16738 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16739 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16740 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16741 logical l_ge(), l_gt(), l_le(), l_lt();
16742 integer i_nint();
16743 double r_sign();
16744
16745 // Local variables //
16746 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16747 fool_(), fooz_(), getem_();
16748 static char a1[10], a2[10];
16749 static complex c1, c2;
16750 static doublereal d1, d2;
16751 static integer i1, i2;
16752 static real r1, r2;
16753
16754
16755 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16756// / //
16757 i__1 = i1 / i2;
16758 fooi_(&i__1);
16759 r__1 = r1 / i1;
16760 foor_(&r__1);
16761 d__1 = d1 / i1;
16762 food_(&d__1);
16763 d__1 = (doublereal) i1;
16764 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16765 fooc_(&q__1);
16766 r__1 = r1 / r2;
16767 foor_(&r__1);
16768 d__1 = r1 / d1;
16769 food_(&d__1);
16770 d__1 = d1 / d2;
16771 food_(&d__1);
16772 d__1 = d1 / r1;
16773 food_(&d__1);
16774 c_div(&q__1, &c1, &c2);
16775 fooc_(&q__1);
16776 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16777 fooc_(&q__1);
16778 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16779 fooz_(&z__1);
16780// ** //
16781 i__1 = pow_ii(&i1, &i2);
16782 fooi_(&i__1);
16783 r__1 = pow_ri(&r1, &i1);
16784 foor_(&r__1);
16785 d__1 = pow_di(&d1, &i1);
16786 food_(&d__1);
16787 pow_ci(&q__1, &c1, &i1);
16788 fooc_(&q__1);
16789 d__1 = (doublereal) r1;
16790 d__2 = (doublereal) r2;
16791 r__1 = pow_dd(&d__1, &d__2);
16792 foor_(&r__1);
16793 d__2 = (doublereal) r1;
16794 d__1 = pow_dd(&d__2, &d1);
16795 food_(&d__1);
16796 d__1 = pow_dd(&d1, &d2);
16797 food_(&d__1);
16798 d__2 = (doublereal) r1;
16799 d__1 = pow_dd(&d1, &d__2);
16800 food_(&d__1);
16801 z__2.r = c1.r, z__2.i = c1.i;
16802 z__3.r = c2.r, z__3.i = c2.i;
16803 pow_zz(&z__1, &z__2, &z__3);
16804 q__1.r = z__1.r, q__1.i = z__1.i;
16805 fooc_(&q__1);
16806 z__2.r = c1.r, z__2.i = c1.i;
16807 z__3.r = r1, z__3.i = 0.;
16808 pow_zz(&z__1, &z__2, &z__3);
16809 q__1.r = z__1.r, q__1.i = z__1.i;
16810 fooc_(&q__1);
16811 z__2.r = c1.r, z__2.i = c1.i;
16812 z__3.r = d1, z__3.i = 0.;
16813 pow_zz(&z__1, &z__2, &z__3);
16814 fooz_(&z__1);
16815// FFEINTRIN_impABS //
16816 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16817 foor_(&r__1);
16818// FFEINTRIN_impACOS //
16819 r__1 = acos(r1);
16820 foor_(&r__1);
16821// FFEINTRIN_impAIMAG //
16822 r__1 = r_imag(&c1);
16823 foor_(&r__1);
16824// FFEINTRIN_impAINT //
16825 r__1 = r_int(&r1);
16826 foor_(&r__1);
16827// FFEINTRIN_impALOG //
16828 r__1 = log(r1);
16829 foor_(&r__1);
16830// FFEINTRIN_impALOG10 //
16831 r__1 = r_lg10(&r1);
16832 foor_(&r__1);
16833// FFEINTRIN_impAMAX0 //
16834 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16835 foor_(&r__1);
16836// FFEINTRIN_impAMAX1 //
16837 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16838 foor_(&r__1);
16839// FFEINTRIN_impAMIN0 //
16840 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16841 foor_(&r__1);
16842// FFEINTRIN_impAMIN1 //
16843 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16844 foor_(&r__1);
16845// FFEINTRIN_impAMOD //
16846 r__1 = r_mod(&r1, &r2);
16847 foor_(&r__1);
16848// FFEINTRIN_impANINT //
16849 r__1 = r_nint(&r1);
16850 foor_(&r__1);
16851// FFEINTRIN_impASIN //
16852 r__1 = asin(r1);
16853 foor_(&r__1);
16854// FFEINTRIN_impATAN //
16855 r__1 = atan(r1);
16856 foor_(&r__1);
16857// FFEINTRIN_impATAN2 //
16858 r__1 = atan2(r1, r2);
16859 foor_(&r__1);
16860// FFEINTRIN_impCABS //
16861 r__1 = c_abs(&c1);
16862 foor_(&r__1);
16863// FFEINTRIN_impCCOS //
16864 c_cos(&q__1, &c1);
16865 fooc_(&q__1);
16866// FFEINTRIN_impCEXP //
16867 c_exp(&q__1, &c1);
16868 fooc_(&q__1);
16869// FFEINTRIN_impCHAR //
16870 *(unsigned char *)&ch__1[0] = i1;
16871 fooa_(ch__1, 1L);
16872// FFEINTRIN_impCLOG //
16873 c_log(&q__1, &c1);
16874 fooc_(&q__1);
16875// FFEINTRIN_impCONJG //
16876 r_cnjg(&q__1, &c1);
16877 fooc_(&q__1);
16878// FFEINTRIN_impCOS //
16879 r__1 = cos(r1);
16880 foor_(&r__1);
16881// FFEINTRIN_impCOSH //
16882 r__1 = cosh(r1);
16883 foor_(&r__1);
16884// FFEINTRIN_impCSIN //
16885 c_sin(&q__1, &c1);
16886 fooc_(&q__1);
16887// FFEINTRIN_impCSQRT //
16888 c_sqrt(&q__1, &c1);
16889 fooc_(&q__1);
16890// FFEINTRIN_impDABS //
16891 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16892 food_(&d__1);
16893// FFEINTRIN_impDACOS //
16894 d__1 = acos(d1);
16895 food_(&d__1);
16896// FFEINTRIN_impDASIN //
16897 d__1 = asin(d1);
16898 food_(&d__1);
16899// FFEINTRIN_impDATAN //
16900 d__1 = atan(d1);
16901 food_(&d__1);
16902// FFEINTRIN_impDATAN2 //
16903 d__1 = atan2(d1, d2);
16904 food_(&d__1);
16905// FFEINTRIN_impDCOS //
16906 d__1 = cos(d1);
16907 food_(&d__1);
16908// FFEINTRIN_impDCOSH //
16909 d__1 = cosh(d1);
16910 food_(&d__1);
16911// FFEINTRIN_impDDIM //
16912 d__1 = d_dim(&d1, &d2);
16913 food_(&d__1);
16914// FFEINTRIN_impDEXP //
16915 d__1 = exp(d1);
16916 food_(&d__1);
16917// FFEINTRIN_impDIM //
16918 r__1 = r_dim(&r1, &r2);
16919 foor_(&r__1);
16920// FFEINTRIN_impDINT //
16921 d__1 = d_int(&d1);
16922 food_(&d__1);
16923// FFEINTRIN_impDLOG //
16924 d__1 = log(d1);
16925 food_(&d__1);
16926// FFEINTRIN_impDLOG10 //
16927 d__1 = d_lg10(&d1);
16928 food_(&d__1);
16929// FFEINTRIN_impDMAX1 //
16930 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16931 food_(&d__1);
16932// FFEINTRIN_impDMIN1 //
16933 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16934 food_(&d__1);
16935// FFEINTRIN_impDMOD //
16936 d__1 = d_mod(&d1, &d2);
16937 food_(&d__1);
16938// FFEINTRIN_impDNINT //
16939 d__1 = d_nint(&d1);
16940 food_(&d__1);
16941// FFEINTRIN_impDPROD //
16942 d__1 = (doublereal) r1 * r2;
16943 food_(&d__1);
16944// FFEINTRIN_impDSIGN //
16945 d__1 = d_sign(&d1, &d2);
16946 food_(&d__1);
16947// FFEINTRIN_impDSIN //
16948 d__1 = sin(d1);
16949 food_(&d__1);
16950// FFEINTRIN_impDSINH //
16951 d__1 = sinh(d1);
16952 food_(&d__1);
16953// FFEINTRIN_impDSQRT //
16954 d__1 = sqrt(d1);
16955 food_(&d__1);
16956// FFEINTRIN_impDTAN //
16957 d__1 = tan(d1);
16958 food_(&d__1);
16959// FFEINTRIN_impDTANH //
16960 d__1 = tanh(d1);
16961 food_(&d__1);
16962// FFEINTRIN_impEXP //
16963 r__1 = exp(r1);
16964 foor_(&r__1);
16965// FFEINTRIN_impIABS //
16966 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16967 fooi_(&i__1);
16968// FFEINTRIN_impICHAR //
16969 i__1 = *(unsigned char *)a1;
16970 fooi_(&i__1);
16971// FFEINTRIN_impIDIM //
16972 i__1 = i_dim(&i1, &i2);
16973 fooi_(&i__1);
16974// FFEINTRIN_impIDNINT //
16975 i__1 = i_dnnt(&d1);
16976 fooi_(&i__1);
16977// FFEINTRIN_impINDEX //
16978 i__1 = i_indx(a1, a2, 10L, 10L);
16979 fooi_(&i__1);
16980// FFEINTRIN_impISIGN //
16981 i__1 = i_sign(&i1, &i2);
16982 fooi_(&i__1);
16983// FFEINTRIN_impLEN //
16984 i__1 = i_len(a1, 10L);
16985 fooi_(&i__1);
16986// FFEINTRIN_impLGE //
16987 L__1 = l_ge(a1, a2, 10L, 10L);
16988 fool_(&L__1);
16989// FFEINTRIN_impLGT //
16990 L__1 = l_gt(a1, a2, 10L, 10L);
16991 fool_(&L__1);
16992// FFEINTRIN_impLLE //
16993 L__1 = l_le(a1, a2, 10L, 10L);
16994 fool_(&L__1);
16995// FFEINTRIN_impLLT //
16996 L__1 = l_lt(a1, a2, 10L, 10L);
16997 fool_(&L__1);
16998// FFEINTRIN_impMAX0 //
16999 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17000 fooi_(&i__1);
17001// FFEINTRIN_impMAX1 //
17002 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
17003 fooi_(&i__1);
17004// FFEINTRIN_impMIN0 //
17005 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17006 fooi_(&i__1);
17007// FFEINTRIN_impMIN1 //
17008 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
17009 fooi_(&i__1);
17010// FFEINTRIN_impMOD //
17011 i__1 = i1 % i2;
17012 fooi_(&i__1);
17013// FFEINTRIN_impNINT //
17014 i__1 = i_nint(&r1);
17015 fooi_(&i__1);
17016// FFEINTRIN_impSIGN //
17017 r__1 = r_sign(&r1, &r2);
17018 foor_(&r__1);
17019// FFEINTRIN_impSIN //
17020 r__1 = sin(r1);
17021 foor_(&r__1);
17022// FFEINTRIN_impSINH //
17023 r__1 = sinh(r1);
17024 foor_(&r__1);
17025// FFEINTRIN_impSQRT //
17026 r__1 = sqrt(r1);
17027 foor_(&r__1);
17028// FFEINTRIN_impTAN //
17029 r__1 = tan(r1);
17030 foor_(&r__1);
17031// FFEINTRIN_impTANH //
17032 r__1 = tanh(r1);
17033 foor_(&r__1);
17034// FFEINTRIN_imp_CMPLX_C //
17035 r__1 = c1.r;
17036 r__2 = c2.r;
17037 q__1.r = r__1, q__1.i = r__2;
17038 fooc_(&q__1);
17039// FFEINTRIN_imp_CMPLX_D //
17040 z__1.r = d1, z__1.i = d2;
17041 fooz_(&z__1);
17042// FFEINTRIN_imp_CMPLX_I //
17043 r__1 = (real) i1;
17044 r__2 = (real) i2;
17045 q__1.r = r__1, q__1.i = r__2;
17046 fooc_(&q__1);
17047// FFEINTRIN_imp_CMPLX_R //
17048 q__1.r = r1, q__1.i = r2;
17049 fooc_(&q__1);
17050// FFEINTRIN_imp_DBLE_C //
17051 d__1 = (doublereal) c1.r;
17052 food_(&d__1);
17053// FFEINTRIN_imp_DBLE_D //
17054 d__1 = d1;
17055 food_(&d__1);
17056// FFEINTRIN_imp_DBLE_I //
17057 d__1 = (doublereal) i1;
17058 food_(&d__1);
17059// FFEINTRIN_imp_DBLE_R //
17060 d__1 = (doublereal) r1;
17061 food_(&d__1);
17062// FFEINTRIN_imp_INT_C //
17063 i__1 = (integer) c1.r;
17064 fooi_(&i__1);
17065// FFEINTRIN_imp_INT_D //
17066 i__1 = (integer) d1;
17067 fooi_(&i__1);
17068// FFEINTRIN_imp_INT_I //
17069 i__1 = i1;
17070 fooi_(&i__1);
17071// FFEINTRIN_imp_INT_R //
17072 i__1 = (integer) r1;
17073 fooi_(&i__1);
17074// FFEINTRIN_imp_REAL_C //
17075 r__1 = c1.r;
17076 foor_(&r__1);
17077// FFEINTRIN_imp_REAL_D //
17078 r__1 = (real) d1;
17079 foor_(&r__1);
17080// FFEINTRIN_imp_REAL_I //
17081 r__1 = (real) i1;
17082 foor_(&r__1);
17083// FFEINTRIN_imp_REAL_R //
17084 r__1 = r1;
17085 foor_(&r__1);
17086
17087// FFEINTRIN_imp_INT_D: //
17088
17089// FFEINTRIN_specIDINT //
17090 i__1 = (integer) d1;
17091 fooi_(&i__1);
17092
17093// FFEINTRIN_imp_INT_R: //
17094
17095// FFEINTRIN_specIFIX //
17096 i__1 = (integer) r1;
17097 fooi_(&i__1);
17098// FFEINTRIN_specINT //
17099 i__1 = (integer) r1;
17100 fooi_(&i__1);
17101
17102// FFEINTRIN_imp_REAL_D: //
5ff904cd 17103
c7e4ee3a
CB		 17104// FFEINTRIN_specSNGL //
17105 r__1 = (real) d1;
17106 foor_(&r__1);
5ff904cd 17107
c7e4ee3a 17108// FFEINTRIN_imp_REAL_I: //
5ff904cd 17109
c7e4ee3a
CB		 17110// FFEINTRIN_specFLOAT //
17111 r__1 = (real) i1;
17112 foor_(&r__1);
17113// FFEINTRIN_specREAL //
17114 r__1 = (real) i1;
17115 foor_(&r__1);
5ff904cd 17116
c7e4ee3a 17117} // MAIN__ //
5ff904cd 17118
c7e4ee3a 17119-------- (end output file from f2c)
5ff904cd 17120
c7e4ee3a 17121*/
GNU Compiler Collection
This page took 3.881044 seconds and 5 git commands to generate.