1 /* com.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
3 Free Software Foundation, Inc.
4 Contributed by James Craig Burley.
6 This file is part of GNU Fortran.
8 GNU Fortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU Fortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Fortran; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
27 Contains compiler-specific functions.
32 /* Understanding this module means understanding the interface between
33 the g77 front end and the gcc back end (or, perhaps, some other
34 back end). In here are the functions called by the front end proper
35 to notify whatever back end is in place about certain things, and
36 also the back-end-specific functions. It's a bear to deal with, so
37 lately I've been trying to simplify things, especially with regard
38 to the gcc-back-end-specific stuff.
40 Building expressions generally seems quite easy, but building decls
41 has been challenging and is undergoing revision. gcc has several
44 TYPE_DECL -- a type (int, float, struct, function, etc.)
45 CONST_DECL -- a constant of some type other than function
46 LABEL_DECL -- a variable or a constant?
47 PARM_DECL -- an argument to a function (a variable that is a dummy)
48 RESULT_DECL -- the return value of a function (a variable)
49 VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
50 FUNCTION_DECL -- a function (either the actual function or an extern ref)
51 FIELD_DECL -- a field in a struct or union (goes into types)
53 g77 has a set of functions that somewhat parallels the gcc front end
54 when it comes to building decls:
56 Internal Function (one we define, not just declare as extern):
57 if (is_nested) push_f_function_context ();
58 start_function (get_identifier ("function_name"), function_type,
59 is_nested, is_public);
60 // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
61 store_parm_decls (is_main_program);
62 ffecom_start_compstmt ();
63 // for stmts and decls inside function, do appropriate things;
64 ffecom_end_compstmt ();
65 finish_function (is_nested);
66 if (is_nested) pop_f_function_context ();
71 // fill in external, public, static, &c for decl, and
72 // set DECL_INITIAL to error_mark_node if going to initialize
73 // set is_top_level TRUE only if not at top level and decl
74 // must go in top level (i.e. not within current function decl context)
75 d = start_decl (decl, is_top_level);
76 init = ...; // if have initializer
77 finish_decl (d, init, is_top_level);
84 #if FFECOM_targetCURRENT == FFECOM_targetGCC
89 #include "output.h" /* Must follow tree.h so TREE_CODE is defined! */
92 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
94 #define FFECOM_GCC_INCLUDE 1 /* Enable -I. */
96 /* VMS-specific definitions */
99 #define O_RDONLY 0 /* Open arg for Read/Only */
100 #define O_WRONLY 1 /* Open arg for Write/Only */
101 #define read(fd,buf,size) VMS_read (fd,buf,size)
102 #define write(fd,buf,size) VMS_write (fd,buf,size)
103 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
104 #define fopen(fname,mode) VMS_fopen (fname,mode)
105 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
106 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
107 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
108 static int VMS_fstat (), VMS_stat ();
109 static char * VMS_strncat ();
110 static int VMS_read ();
111 static int VMS_write ();
112 static int VMS_open ();
113 static FILE * VMS_fopen ();
114 static FILE * VMS_freopen ();
115 static void hack_vms_include_specification ();
116 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
117 #define ino_t vms_ino_t
118 #define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */
121 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
138 /* Externals defined here. */
140 #if FFECOM_targetCURRENT == FFECOM_targetGCC
142 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
145 const char * const language_string = "GNU F77";
147 /* Stream for reading from the input file. */
150 /* These definitions parallel those in c-decl.c so that code from that
151 module can be used pretty much as is. Much of these defs aren't
152 otherwise used, i.e. by g77 code per se, except some of them are used
153 to build some of them that are. The ones that are global (i.e. not
154 "static") are those that ste.c and such might use (directly
155 or by using com macros that reference them in their definitions). */
157 tree string_type_node;
159 /* The rest of these are inventions for g77, though there might be
160 similar things in the C front end. As they are found, these
161 inventions should be renamed to be canonical. Note that only
162 the ones currently required to be global are so. */
164 static tree ffecom_tree_fun_type_void;
166 tree ffecom_integer_type_node; /* Abbrev for _tree_type[blah][blah]. */
167 tree ffecom_integer_zero_node; /* Like *_*_* with g77's integer type. */
168 tree ffecom_integer_one_node; /* " */
169 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
171 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
172 just use build_function_type and build_pointer_type on the
173 appropriate _tree_type array element. */
175 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
176 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
177 static tree ffecom_tree_subr_type;
178 static tree ffecom_tree_ptr_to_subr_type;
179 static tree ffecom_tree_blockdata_type;
181 static tree ffecom_tree_xargc_;
183 ffecomSymbol ffecom_symbol_null_
192 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
193 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
195 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
196 tree ffecom_f2c_integer_type_node;
197 tree ffecom_f2c_ptr_to_integer_type_node;
198 tree ffecom_f2c_address_type_node;
199 tree ffecom_f2c_real_type_node;
200 tree ffecom_f2c_ptr_to_real_type_node;
201 tree ffecom_f2c_doublereal_type_node;
202 tree ffecom_f2c_complex_type_node;
203 tree ffecom_f2c_doublecomplex_type_node;
204 tree ffecom_f2c_longint_type_node;
205 tree ffecom_f2c_logical_type_node;
206 tree ffecom_f2c_flag_type_node;
207 tree ffecom_f2c_ftnlen_type_node;
208 tree ffecom_f2c_ftnlen_zero_node;
209 tree ffecom_f2c_ftnlen_one_node;
210 tree ffecom_f2c_ftnlen_two_node;
211 tree ffecom_f2c_ptr_to_ftnlen_type_node;
212 tree ffecom_f2c_ftnint_type_node;
213 tree ffecom_f2c_ptr_to_ftnint_type_node;
214 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
216 /* Simple definitions and enumerations. */
218 #ifndef FFECOM_sizeMAXSTACKITEM
219 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
220 larger than this # bytes
221 off stack if possible. */
224 /* For systems that have large enough stacks, they should define
225 this to 0, and here, for ease of use later on, we just undefine
228 #if FFECOM_sizeMAXSTACKITEM == 0
229 #undef FFECOM_sizeMAXSTACKITEM
235 FFECOM_rttypeVOIDSTAR_, /* C's `void *' type. */
236 FFECOM_rttypeFTNINT_, /* f2c's `ftnint' type. */
237 FFECOM_rttypeINTEGER_, /* f2c's `integer' type. */
238 FFECOM_rttypeLONGINT_, /* f2c's `longint' type. */
239 FFECOM_rttypeLOGICAL_, /* f2c's `logical' type. */
240 FFECOM_rttypeREAL_F2C_, /* f2c's `real' returned as `double'. */
241 FFECOM_rttypeREAL_GNU_, /* `real' returned as such. */
242 FFECOM_rttypeCOMPLEX_F2C_, /* f2c's `complex' returned via 1st arg. */
243 FFECOM_rttypeCOMPLEX_GNU_, /* f2c's `complex' returned directly. */
244 FFECOM_rttypeDOUBLE_, /* C's `double' type. */
245 FFECOM_rttypeDOUBLEREAL_, /* f2c's `doublereal' type. */
246 FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
247 FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
248 FFECOM_rttypeCHARACTER_, /* f2c `char *'/`ftnlen' pair. */
252 /* Internal typedefs. */
254 #if FFECOM_targetCURRENT == FFECOM_targetGCC
255 typedef struct _ffecom_concat_list_ ffecomConcatList_;
256 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
258 /* Private include files. */
261 /* Internal structure definitions. */
263 #if FFECOM_targetCURRENT == FFECOM_targetGCC
264 struct _ffecom_concat_list_
269 ffetargetCharacterSize minlen;
270 ffetargetCharacterSize maxlen;
272 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
274 /* Static functions (internal). */
276 #if FFECOM_targetCURRENT == FFECOM_targetGCC
277 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
278 static tree ffecom_widest_expr_type_ (ffebld list);
279 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
280 tree dest_size, tree source_tree,
281 ffebld source, bool scalar_arg);
282 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
283 tree args, tree callee_commons,
285 static tree ffecom_build_f2c_string_ (int i, const char *s);
286 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
287 bool is_f2c_complex, tree type,
288 tree args, tree dest_tree,
289 ffebld dest, bool *dest_used,
290 tree callee_commons, bool scalar_args, tree hook);
291 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
292 bool is_f2c_complex, tree type,
293 ffebld left, ffebld right,
294 tree dest_tree, ffebld dest,
295 bool *dest_used, tree callee_commons,
296 bool scalar_args, bool ref, tree hook);
297 static void ffecom_char_args_x_ (tree *xitem, tree *length,
298 ffebld expr, bool with_null);
299 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
300 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
301 static ffecomConcatList_
302 ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
304 ffetargetCharacterSize max);
305 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
306 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
307 ffetargetCharacterSize max);
308 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
309 ffesymbol member, tree member_type,
310 ffetargetOffset offset);
311 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
312 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
313 bool *dest_used, bool assignp, bool widenp);
314 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
315 ffebld dest, bool *dest_used);
316 static tree ffecom_expr_power_integer_ (ffebld expr);
317 static void ffecom_expr_transform_ (ffebld expr);
318 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
319 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
321 static ffeglobal ffecom_finish_global_ (ffeglobal global);
322 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
323 static tree ffecom_get_appended_identifier_ (char us, const char *text);
324 static tree ffecom_get_external_identifier_ (ffesymbol s);
325 static tree ffecom_get_identifier_ (const char *text);
326 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
329 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
330 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
331 static tree ffecom_init_zero_ (tree decl);
332 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
334 static tree ffecom_intrinsic_len_ (ffebld expr);
335 static void ffecom_let_char_ (tree dest_tree,
337 ffetargetCharacterSize dest_size,
339 static void ffecom_make_gfrt_ (ffecomGfrt ix);
340 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
341 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
342 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
344 static void ffecom_push_dummy_decls_ (ffebld dumlist,
346 static void ffecom_start_progunit_ (void);
347 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
348 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
349 static void ffecom_transform_common_ (ffesymbol s);
350 static void ffecom_transform_equiv_ (ffestorag st);
351 static tree ffecom_transform_namelist_ (ffesymbol s);
352 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
354 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
355 tree *size, tree tree);
356 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
357 tree dest_tree, ffebld dest,
358 bool *dest_used, tree hook);
359 static tree ffecom_type_localvar_ (ffesymbol s,
362 static tree ffecom_type_namelist_ (void);
363 static tree ffecom_type_vardesc_ (void);
364 static tree ffecom_vardesc_ (ffebld expr);
365 static tree ffecom_vardesc_array_ (ffesymbol s);
366 static tree ffecom_vardesc_dims_ (ffesymbol s);
367 static tree ffecom_convert_narrow_ (tree type, tree expr);
368 static tree ffecom_convert_widen_ (tree type, tree expr);
369 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
371 /* These are static functions that parallel those found in the C front
372 end and thus have the same names. */
374 #if FFECOM_targetCURRENT == FFECOM_targetGCC
375 static tree bison_rule_compstmt_ (void);
376 static void bison_rule_pushlevel_ (void);
377 static void delete_block (tree block);
378 static int duplicate_decls (tree newdecl, tree olddecl);
379 static void finish_decl (tree decl, tree init, bool is_top_level);
380 static void finish_function (int nested);
381 static const char *lang_printable_name (tree decl, int v);
382 static tree lookup_name_current_level (tree name);
383 static struct binding_level *make_binding_level (void);
384 static void pop_f_function_context (void);
385 static void push_f_function_context (void);
386 static void push_parm_decl (tree parm);
387 static tree pushdecl_top_level (tree decl);
388 static int kept_level_p (void);
389 static tree storedecls (tree decls);
390 static void store_parm_decls (int is_main_program);
391 static tree start_decl (tree decl, bool is_top_level);
392 static void start_function (tree name, tree type, int nested, int public);
393 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
394 #if FFECOM_GCC_INCLUDE
395 static void ffecom_file_ (const char *name);
396 static void ffecom_initialize_char_syntax_ (void);
397 static void ffecom_close_include_ (FILE *f);
398 static int ffecom_decode_include_option_ (char *spec);
399 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
401 #endif /* FFECOM_GCC_INCLUDE */
403 /* Static objects accessed by functions in this module. */
405 static ffesymbol ffecom_primary_entry_ = NULL;
406 static ffesymbol ffecom_nested_entry_ = NULL;
407 static ffeinfoKind ffecom_primary_entry_kind_;
408 static bool ffecom_primary_entry_is_proc_;
409 #if FFECOM_targetCURRENT == FFECOM_targetGCC
410 static tree ffecom_outer_function_decl_;
411 static tree ffecom_previous_function_decl_;
412 static tree ffecom_which_entrypoint_decl_;
413 static tree ffecom_float_zero_ = NULL_TREE;
414 static tree ffecom_float_half_ = NULL_TREE;
415 static tree ffecom_double_zero_ = NULL_TREE;
416 static tree ffecom_double_half_ = NULL_TREE;
417 static tree ffecom_func_result_;/* For functions. */
418 static tree ffecom_func_length_;/* For CHARACTER fns. */
419 static ffebld ffecom_list_blockdata_;
420 static ffebld ffecom_list_common_;
421 static ffebld ffecom_master_arglist_;
422 static ffeinfoBasictype ffecom_master_bt_;
423 static ffeinfoKindtype ffecom_master_kt_;
424 static ffetargetCharacterSize ffecom_master_size_;
425 static int ffecom_num_fns_ = 0;
426 static int ffecom_num_entrypoints_ = 0;
427 static bool ffecom_is_altreturning_ = FALSE;
428 static tree ffecom_multi_type_node_;
429 static tree ffecom_multi_retval_;
431 ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
432 static bool ffecom_member_namelisted_; /* _member_phase1_ namelisted? */
433 static bool ffecom_doing_entry_ = FALSE;
434 static bool ffecom_transform_only_dummies_ = FALSE;
435 static int ffecom_typesize_pointer_;
436 static int ffecom_typesize_integer1_;
438 /* Holds pointer-to-function expressions. */
440 static tree ffecom_gfrt_[FFECOM_gfrt]
443 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
444 #include "com-rt.def"
448 /* Holds the external names of the functions. */
450 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
453 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
454 #include "com-rt.def"
458 /* Whether the function returns. */
460 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
463 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
464 #include "com-rt.def"
468 /* Whether the function returns type complex. */
470 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
473 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
474 #include "com-rt.def"
478 /* Whether the function is const
479 (i.e., has no side effects and only depends on its arguments). */
481 static bool ffecom_gfrt_const_[FFECOM_gfrt]
484 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
485 #include "com-rt.def"
489 /* Type code for the function return value. */
491 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
494 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
495 #include "com-rt.def"
499 /* String of codes for the function's arguments. */
501 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
504 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
505 #include "com-rt.def"
508 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
510 /* Internal macros. */
512 #if FFECOM_targetCURRENT == FFECOM_targetGCC
514 /* We let tm.h override the types used here, to handle trivial differences
515 such as the choice of unsigned int or long unsigned int for size_t.
516 When machines start needing nontrivial differences in the size type,
517 it would be best to do something here to figure out automatically
518 from other information what type to use. */
521 #define SIZE_TYPE "long unsigned int"
524 #define ffecom_concat_list_count_(catlist) ((catlist).count)
525 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
526 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
527 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
529 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
530 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
532 /* For each binding contour we allocate a binding_level structure
533 * which records the names defined in that contour.
536 * 1) one for each function definition,
537 * where internal declarations of the parameters appear.
539 * The current meaning of a name can be found by searching the levels from
540 * the current one out to the global one.
543 /* Note that the information in the `names' component of the global contour
544 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
548 /* A chain of _DECL nodes for all variables, constants, functions,
549 and typedef types. These are in the reverse of the order supplied.
553 /* For each level (except not the global one),
554 a chain of BLOCK nodes for all the levels
555 that were entered and exited one level down. */
558 /* The BLOCK node for this level, if one has been preallocated.
559 If 0, the BLOCK is allocated (if needed) when the level is popped. */
562 /* The binding level which this one is contained in (inherits from). */
563 struct binding_level *level_chain;
565 /* 0: no ffecom_prepare_* functions called at this level yet;
566 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
567 2: ffecom_prepare_end called. */
571 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
573 /* The binding level currently in effect. */
575 static struct binding_level *current_binding_level;
577 /* A chain of binding_level structures awaiting reuse. */
579 static struct binding_level *free_binding_level;
581 /* The outermost binding level, for names of file scope.
582 This is created when the compiler is started and exists
583 through the entire run. */
585 static struct binding_level *global_binding_level;
587 /* Binding level structures are initialized by copying this one. */
589 static struct binding_level clear_binding_level
591 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
593 /* Language-dependent contents of an identifier. */
595 struct lang_identifier
597 struct tree_identifier ignore;
598 tree global_value, local_value, label_value;
602 /* Macros for access to language-specific slots in an identifier. */
603 /* Each of these slots contains a DECL node or null. */
605 /* This represents the value which the identifier has in the
606 file-scope namespace. */
607 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
608 (((struct lang_identifier *)(NODE))->global_value)
609 /* This represents the value which the identifier has in the current
611 #define IDENTIFIER_LOCAL_VALUE(NODE) \
612 (((struct lang_identifier *)(NODE))->local_value)
613 /* This represents the value which the identifier has as a label in
614 the current label scope. */
615 #define IDENTIFIER_LABEL_VALUE(NODE) \
616 (((struct lang_identifier *)(NODE))->label_value)
617 /* This is nonzero if the identifier was "made up" by g77 code. */
618 #define IDENTIFIER_INVENTED(NODE) \
619 (((struct lang_identifier *)(NODE))->invented)
621 /* In identifiers, C uses the following fields in a special way:
622 TREE_PUBLIC to record that there was a previous local extern decl.
623 TREE_USED to record that such a decl was used.
624 TREE_ADDRESSABLE to record that the address of such a decl was used. */
626 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
627 that have names. Here so we can clear out their names' definitions
628 at the end of the function. */
630 static tree named_labels;
632 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
634 static tree shadowed_labels;
636 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
638 /* Return the subscript expression, modified to do range-checking.
640 `array' is the array to be checked against.
641 `element' is the subscript expression to check.
642 `dim' is the dimension number (starting at 0).
643 `total_dims' is the total number of dimensions (0 for CHARACTER substring).
647 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
648 const char *array_name)
650 tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
651 tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
656 if (element == error_mark_node)
659 if (TREE_TYPE (low) != TREE_TYPE (element))
661 if (TYPE_PRECISION (TREE_TYPE (low))
662 > TYPE_PRECISION (TREE_TYPE (element)))
663 element = convert (TREE_TYPE (low), element);
666 low = convert (TREE_TYPE (element), low);
668 high = convert (TREE_TYPE (element), high);
672 element = ffecom_save_tree (element);
673 cond = ffecom_2 (LE_EXPR, integer_type_node,
678 cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
680 ffecom_2 (LE_EXPR, integer_type_node,
697 var = concat (array_name, "[", (dim ? "end" : "start"),
698 "-substring]", NULL);
699 len = strlen (var) + 1;
700 arg1 = build_string (len, var);
705 len = strlen (array_name) + 1;
706 arg1 = build_string (len, array_name);
710 var = xmalloc (strlen (array_name) + 40);
711 sprintf (var, "%s[subscript-%d-of-%d]",
713 dim + 1, total_dims);
714 len = strlen (var) + 1;
715 arg1 = build_string (len, var);
721 = build_type_variant (build_array_type (char_type_node,
725 build_int_2 (len, 0))),
727 TREE_CONSTANT (arg1) = 1;
728 TREE_STATIC (arg1) = 1;
729 arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
732 /* s_rnge adds one to the element to print it, so bias against
733 that -- want to print a faithful *subscript* value. */
734 arg2 = convert (ffecom_f2c_ftnint_type_node,
735 ffecom_2 (MINUS_EXPR,
738 convert (TREE_TYPE (element),
741 proc = concat (input_filename, "/",
742 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)),
744 len = strlen (proc) + 1;
745 arg3 = build_string (len, proc);
750 = build_type_variant (build_array_type (char_type_node,
754 build_int_2 (len, 0))),
756 TREE_CONSTANT (arg3) = 1;
757 TREE_STATIC (arg3) = 1;
758 arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
761 arg4 = convert (ffecom_f2c_ftnint_type_node,
762 build_int_2 (lineno, 0));
764 arg1 = build_tree_list (NULL_TREE, arg1);
765 arg2 = build_tree_list (NULL_TREE, arg2);
766 arg3 = build_tree_list (NULL_TREE, arg3);
767 arg4 = build_tree_list (NULL_TREE, arg4);
768 TREE_CHAIN (arg3) = arg4;
769 TREE_CHAIN (arg2) = arg3;
770 TREE_CHAIN (arg1) = arg2;
774 die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
776 TREE_SIDE_EFFECTS (die) = 1;
778 element = ffecom_3 (COND_EXPR,
787 /* Return the computed element of an array reference.
789 `item' is NULL_TREE, or the transformed pointer to the array.
790 `expr' is the original opARRAYREF expression, which is transformed
791 if `item' is NULL_TREE.
792 `want_ptr' is non-zero if a pointer to the element, instead of
793 the element itself, is to be returned. */
796 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
798 ffebld dims[FFECOM_dimensionsMAX];
801 int flatten = ffe_is_flatten_arrays ();
807 const char *array_name;
811 if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
812 array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
814 array_name = "[expr?]";
816 /* Build up ARRAY_REFs in reverse order (since we're column major
817 here in Fortran land). */
819 for (i = 0, list = ffebld_right (expr);
821 ++i, list = ffebld_trail (list))
823 dims[i] = ffebld_head (list);
824 type = ffeinfo_type (ffebld_basictype (dims[i]),
825 ffebld_kindtype (dims[i]));
827 && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
828 && ffetype_size (type) > ffecom_typesize_integer1_)
829 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
830 pointers and 32-bit integers. Do the full 64-bit pointer
831 arithmetic, for codes using arrays for nonstandard heap-like
838 need_ptr = want_ptr || flatten;
843 item = ffecom_ptr_to_expr (ffebld_left (expr));
845 item = ffecom_expr (ffebld_left (expr));
847 if (item == error_mark_node)
850 if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
851 && ! mark_addressable (item))
852 return error_mark_node;
855 if (item == error_mark_node)
862 for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
864 --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
866 min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
867 element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
868 if (flag_bounds_check)
869 element = ffecom_subscript_check_ (array, element, i, total_dims,
871 if (element == error_mark_node)
874 /* Widen integral arithmetic as desired while preserving
876 tree_type = TREE_TYPE (element);
877 tree_type_x = tree_type;
879 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
880 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
881 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
883 if (TREE_TYPE (min) != tree_type_x)
884 min = convert (tree_type_x, min);
885 if (TREE_TYPE (element) != tree_type_x)
886 element = convert (tree_type_x, element);
888 item = ffecom_2 (PLUS_EXPR,
889 build_pointer_type (TREE_TYPE (array)),
891 size_binop (MULT_EXPR,
892 size_in_bytes (TREE_TYPE (array)),
894 fold (build (MINUS_EXPR,
900 item = ffecom_1 (INDIRECT_REF,
901 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
911 array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
913 element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
914 if (flag_bounds_check)
915 element = ffecom_subscript_check_ (array, element, i, total_dims,
917 if (element == error_mark_node)
920 /* Widen integral arithmetic as desired while preserving
922 tree_type = TREE_TYPE (element);
923 tree_type_x = tree_type;
925 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
926 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
927 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
929 element = convert (tree_type_x, element);
931 item = ffecom_2 (ARRAY_REF,
932 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
941 /* This is like gcc's stabilize_reference -- in fact, most of the code
942 comes from that -- but it handles the situation where the reference
943 is going to have its subparts picked at, and it shouldn't change
944 (or trigger extra invocations of functions in the subtrees) due to
945 this. save_expr is a bit overzealous, because we don't need the
946 entire thing calculated and saved like a temp. So, for DECLs, no
947 change is needed, because these are stable aggregates, and ARRAY_REF
948 and such might well be stable too, but for things like calculations,
949 we do need to calculate a snapshot of a value before picking at it. */
951 #if FFECOM_targetCURRENT == FFECOM_targetGCC
953 ffecom_stabilize_aggregate_ (tree ref)
956 enum tree_code code = TREE_CODE (ref);
963 /* No action is needed in this case. */
973 result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
977 result = build_nt (INDIRECT_REF,
978 stabilize_reference_1 (TREE_OPERAND (ref, 0)));
982 result = build_nt (COMPONENT_REF,
983 stabilize_reference (TREE_OPERAND (ref, 0)),
984 TREE_OPERAND (ref, 1));
988 result = build_nt (BIT_FIELD_REF,
989 stabilize_reference (TREE_OPERAND (ref, 0)),
990 stabilize_reference_1 (TREE_OPERAND (ref, 1)),
991 stabilize_reference_1 (TREE_OPERAND (ref, 2)));
995 result = build_nt (ARRAY_REF,
996 stabilize_reference (TREE_OPERAND (ref, 0)),
997 stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1001 result = build_nt (COMPOUND_EXPR,
1002 stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1003 stabilize_reference (TREE_OPERAND (ref, 1)));
1011 return save_expr (ref);
1014 return error_mark_node;
1017 TREE_TYPE (result) = TREE_TYPE (ref);
1018 TREE_READONLY (result) = TREE_READONLY (ref);
1019 TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1020 TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1026 /* A rip-off of gcc's convert.c convert_to_complex function,
1027 reworked to handle complex implemented as C structures
1028 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1030 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1032 ffecom_convert_to_complex_ (tree type, tree expr)
1034 register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1037 assert (TREE_CODE (type) == RECORD_TYPE);
1039 subtype = TREE_TYPE (TYPE_FIELDS (type));
1041 if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1043 expr = convert (subtype, expr);
1044 return ffecom_2 (COMPLEX_EXPR, type, expr,
1045 convert (subtype, integer_zero_node));
1048 if (form == RECORD_TYPE)
1050 tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1051 if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1055 expr = save_expr (expr);
1056 return ffecom_2 (COMPLEX_EXPR,
1059 ffecom_1 (REALPART_EXPR,
1060 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1063 ffecom_1 (IMAGPART_EXPR,
1064 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1069 if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1070 error ("pointer value used where a complex was expected");
1072 error ("aggregate value used where a complex was expected");
1074 return ffecom_2 (COMPLEX_EXPR, type,
1075 convert (subtype, integer_zero_node),
1076 convert (subtype, integer_zero_node));
1080 /* Like gcc's convert(), but crashes if widening might happen. */
1082 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1084 ffecom_convert_narrow_ (type, expr)
1087 register tree e = expr;
1088 register enum tree_code code = TREE_CODE (type);
1090 if (type == TREE_TYPE (e)
1091 || TREE_CODE (e) == ERROR_MARK)
1093 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1094 return fold (build1 (NOP_EXPR, type, e));
1095 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1096 || code == ERROR_MARK)
1097 return error_mark_node;
1098 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1100 assert ("void value not ignored as it ought to be" == NULL);
1101 return error_mark_node;
1103 assert (code != VOID_TYPE);
1104 if ((code != RECORD_TYPE)
1105 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1106 assert ("converting COMPLEX to REAL" == NULL);
1107 assert (code != ENUMERAL_TYPE);
1108 if (code == INTEGER_TYPE)
1110 assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1111 && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1112 || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1113 && (TYPE_PRECISION (type)
1114 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1115 return fold (convert_to_integer (type, e));
1117 if (code == POINTER_TYPE)
1119 assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1120 return fold (convert_to_pointer (type, e));
1122 if (code == REAL_TYPE)
1124 assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1125 assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1126 return fold (convert_to_real (type, e));
1128 if (code == COMPLEX_TYPE)
1130 assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1131 assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1132 return fold (convert_to_complex (type, e));
1134 if (code == RECORD_TYPE)
1136 assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1137 /* Check that at least the first field name agrees. */
1138 assert (DECL_NAME (TYPE_FIELDS (type))
1139 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1140 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1141 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1142 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1143 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1145 return fold (ffecom_convert_to_complex_ (type, e));
1148 assert ("conversion to non-scalar type requested" == NULL);
1149 return error_mark_node;
1153 /* Like gcc's convert(), but crashes if narrowing might happen. */
1155 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1157 ffecom_convert_widen_ (type, expr)
1160 register tree e = expr;
1161 register enum tree_code code = TREE_CODE (type);
1163 if (type == TREE_TYPE (e)
1164 || TREE_CODE (e) == ERROR_MARK)
1166 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1167 return fold (build1 (NOP_EXPR, type, e));
1168 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1169 || code == ERROR_MARK)
1170 return error_mark_node;
1171 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1173 assert ("void value not ignored as it ought to be" == NULL);
1174 return error_mark_node;
1176 assert (code != VOID_TYPE);
1177 if ((code != RECORD_TYPE)
1178 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1179 assert ("narrowing COMPLEX to REAL" == NULL);
1180 assert (code != ENUMERAL_TYPE);
1181 if (code == INTEGER_TYPE)
1183 assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1184 && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1185 || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1186 && (TYPE_PRECISION (type)
1187 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1188 return fold (convert_to_integer (type, e));
1190 if (code == POINTER_TYPE)
1192 assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1193 return fold (convert_to_pointer (type, e));
1195 if (code == REAL_TYPE)
1197 assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1198 assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1199 return fold (convert_to_real (type, e));
1201 if (code == COMPLEX_TYPE)
1203 assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1204 assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1205 return fold (convert_to_complex (type, e));
1207 if (code == RECORD_TYPE)
1209 assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1210 /* Check that at least the first field name agrees. */
1211 assert (DECL_NAME (TYPE_FIELDS (type))
1212 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1213 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1214 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1215 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1216 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1218 return fold (ffecom_convert_to_complex_ (type, e));
1221 assert ("conversion to non-scalar type requested" == NULL);
1222 return error_mark_node;
1226 /* Handles making a COMPLEX type, either the standard
1227 (but buggy?) gbe way, or the safer (but less elegant?)
1230 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1232 ffecom_make_complex_type_ (tree subtype)
1238 if (ffe_is_emulate_complex ())
1240 type = make_node (RECORD_TYPE);
1241 realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1242 imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1243 TYPE_FIELDS (type) = realfield;
1248 type = make_node (COMPLEX_TYPE);
1249 TREE_TYPE (type) = subtype;
1257 /* Chooses either the gbe or the f2c way to build a
1258 complex constant. */
1260 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1262 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1266 if (ffe_is_emulate_complex ())
1268 bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1269 TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1270 bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1274 bothparts = build_complex (type, realpart, imagpart);
1281 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1283 ffecom_arglist_expr_ (const char *c, ffebld expr)
1286 tree *plist = &list;
1287 tree trail = NULL_TREE; /* Append char length args here. */
1288 tree *ptrail = &trail;
1293 tree wanted = NULL_TREE;
1294 static char zed[] = "0";
1299 while (expr != NULL)
1322 wanted = ffecom_f2c_complex_type_node;
1326 wanted = ffecom_f2c_doublereal_type_node;
1330 wanted = ffecom_f2c_doublecomplex_type_node;
1334 wanted = ffecom_f2c_real_type_node;
1338 wanted = ffecom_f2c_integer_type_node;
1342 wanted = ffecom_f2c_longint_type_node;
1346 assert ("bad argstring code" == NULL);
1352 exprh = ffebld_head (expr);
1356 if ((wanted == NULL_TREE)
1359 (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1360 [ffeinfo_kindtype (ffebld_info (exprh))])
1361 == TYPE_MODE (wanted))))
1363 = build_tree_list (NULL_TREE,
1364 ffecom_arg_ptr_to_expr (exprh,
1368 item = ffecom_arg_expr (exprh, &length);
1369 item = ffecom_convert_widen_ (wanted, item);
1372 item = ffecom_1 (ADDR_EXPR,
1373 build_pointer_type (TREE_TYPE (item)),
1377 = build_tree_list (NULL_TREE,
1381 plist = &TREE_CHAIN (*plist);
1382 expr = ffebld_trail (expr);
1383 if (length != NULL_TREE)
1385 *ptrail = build_tree_list (NULL_TREE, length);
1386 ptrail = &TREE_CHAIN (*ptrail);
1390 /* We've run out of args in the call; if the implementation expects
1391 more, supply null pointers for them, which the implementation can
1392 check to see if an arg was omitted. */
1394 while (*c != '\0' && *c != '0')
1399 assert ("missing arg to run-time routine!" == NULL);
1414 assert ("bad arg string code" == NULL);
1418 = build_tree_list (NULL_TREE,
1420 plist = &TREE_CHAIN (*plist);
1429 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1431 ffecom_widest_expr_type_ (ffebld list)
1434 ffebld widest = NULL;
1436 ffetype widest_type = NULL;
1439 for (; list != NULL; list = ffebld_trail (list))
1441 item = ffebld_head (list);
1444 if ((widest != NULL)
1445 && (ffeinfo_basictype (ffebld_info (item))
1446 != ffeinfo_basictype (ffebld_info (widest))))
1448 type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1449 ffeinfo_kindtype (ffebld_info (item)));
1450 if ((widest == FFEINFO_kindtypeNONE)
1451 || (ffetype_size (type)
1452 > ffetype_size (widest_type)))
1459 assert (widest != NULL);
1460 t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1461 [ffeinfo_kindtype (ffebld_info (widest))];
1462 assert (t != NULL_TREE);
1467 /* Check whether a partial overlap between two expressions is possible.
1469 Can *starting* to write a portion of expr1 change the value
1470 computed (perhaps already, *partially*) by expr2?
1472 Currently, this is a concern only for a COMPLEX expr1. But if it
1473 isn't in COMMON or local EQUIVALENCE, since we don't support
1474 aliasing of arguments, it isn't a concern. */
1477 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1482 switch (ffebld_op (expr1))
1484 case FFEBLD_opSYMTER:
1485 sym = ffebld_symter (expr1);
1488 case FFEBLD_opARRAYREF:
1489 if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1491 sym = ffebld_symter (ffebld_left (expr1));
1498 if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1499 && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1500 || ! (st = ffesymbol_storage (sym))
1501 || ! ffestorag_parent (st)))
1504 /* It's in COMMON or local EQUIVALENCE. */
1509 /* Check whether dest and source might overlap. ffebld versions of these
1510 might or might not be passed, will be NULL if not.
1512 The test is really whether source_tree is modifiable and, if modified,
1513 might overlap destination such that the value(s) in the destination might
1514 change before it is finally modified. dest_* are the canonized
1515 destination itself. */
1517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1519 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1520 tree source_tree, ffebld source UNUSED,
1528 if (source_tree == NULL_TREE)
1531 switch (TREE_CODE (source_tree))
1534 case IDENTIFIER_NODE:
1545 case TRUNC_DIV_EXPR:
1547 case FLOOR_DIV_EXPR:
1548 case ROUND_DIV_EXPR:
1549 case TRUNC_MOD_EXPR:
1551 case FLOOR_MOD_EXPR:
1552 case ROUND_MOD_EXPR:
1554 case EXACT_DIV_EXPR:
1555 case FIX_TRUNC_EXPR:
1557 case FIX_FLOOR_EXPR:
1558 case FIX_ROUND_EXPR:
1573 case BIT_ANDTC_EXPR:
1575 case TRUTH_ANDIF_EXPR:
1576 case TRUTH_ORIF_EXPR:
1577 case TRUTH_AND_EXPR:
1579 case TRUTH_XOR_EXPR:
1580 case TRUTH_NOT_EXPR:
1596 return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1597 TREE_OPERAND (source_tree, 1), NULL,
1601 return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1602 TREE_OPERAND (source_tree, 0), NULL,
1607 case NON_LVALUE_EXPR:
1609 if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1612 ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1614 source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1619 ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1620 TREE_OPERAND (source_tree, 1), NULL,
1622 || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1623 TREE_OPERAND (source_tree, 2), NULL,
1628 ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1630 TREE_OPERAND (source_tree, 0));
1634 if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1637 source_decl = source_tree;
1638 source_offset = bitsize_zero_node;
1639 source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1643 case REFERENCE_EXPR:
1644 case PREDECREMENT_EXPR:
1645 case PREINCREMENT_EXPR:
1646 case POSTDECREMENT_EXPR:
1647 case POSTINCREMENT_EXPR:
1655 /* Come here when source_decl, source_offset, and source_size filled
1656 in appropriately. */
1658 if (source_decl == NULL_TREE)
1659 return FALSE; /* No decl involved, so no overlap. */
1661 if (source_decl != dest_decl)
1662 return FALSE; /* Different decl, no overlap. */
1664 if (TREE_CODE (dest_size) == ERROR_MARK)
1665 return TRUE; /* Assignment into entire assumed-size
1666 array? Shouldn't happen.... */
1668 t = ffecom_2 (LE_EXPR, integer_type_node,
1669 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1671 convert (TREE_TYPE (dest_offset),
1673 convert (TREE_TYPE (dest_offset),
1676 if (integer_onep (t))
1677 return FALSE; /* Destination precedes source. */
1680 || (source_size == NULL_TREE)
1681 || (TREE_CODE (source_size) == ERROR_MARK)
1682 || integer_zerop (source_size))
1683 return TRUE; /* No way to tell if dest follows source. */
1685 t = ffecom_2 (LE_EXPR, integer_type_node,
1686 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1688 convert (TREE_TYPE (source_offset),
1690 convert (TREE_TYPE (source_offset),
1693 if (integer_onep (t))
1694 return FALSE; /* Destination follows source. */
1696 return TRUE; /* Destination and source overlap. */
1700 /* Check whether dest might overlap any of a list of arguments or is
1701 in a COMMON area the callee might know about (and thus modify). */
1703 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1705 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1706 tree args, tree callee_commons,
1714 ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1717 if (dest_decl == NULL_TREE)
1718 return FALSE; /* Seems unlikely! */
1720 /* If the decl cannot be determined reliably, or if its in COMMON
1721 and the callee isn't known to not futz with COMMON via other
1722 means, overlap might happen. */
1724 if ((TREE_CODE (dest_decl) == ERROR_MARK)
1725 || ((callee_commons != NULL_TREE)
1726 && TREE_PUBLIC (dest_decl)))
1729 for (; args != NULL_TREE; args = TREE_CHAIN (args))
1731 if (((arg = TREE_VALUE (args)) != NULL_TREE)
1732 && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1733 arg, NULL, scalar_args))
1741 /* Build a string for a variable name as used by NAMELIST. This means that
1742 if we're using the f2c library, we build an uppercase string, since
1745 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1747 ffecom_build_f2c_string_ (int i, const char *s)
1749 if (!ffe_is_f2c_library ())
1750 return build_string (i, s);
1759 if (((size_t) i) > ARRAY_SIZE (space))
1760 tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1764 for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1768 t = build_string (i, tmp);
1770 if (((size_t) i) > ARRAY_SIZE (space))
1771 malloc_kill_ks (malloc_pool_image (), tmp, i);
1778 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1779 type to just get whatever the function returns), handling the
1780 f2c value-returning convention, if required, by prepending
1781 to the arglist a pointer to a temporary to receive the return value. */
1783 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1785 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1786 tree type, tree args, tree dest_tree,
1787 ffebld dest, bool *dest_used, tree callee_commons,
1788 bool scalar_args, tree hook)
1793 if (dest_used != NULL)
1798 if ((dest_used == NULL)
1800 || (ffeinfo_basictype (ffebld_info (dest))
1801 != FFEINFO_basictypeCOMPLEX)
1802 || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1803 || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1804 || ffecom_args_overlapping_ (dest_tree, dest, args,
1809 tempvar = ffecom_make_tempvar (ffecom_tree_type
1810 [FFEINFO_basictypeCOMPLEX][kt],
1811 FFETARGET_charactersizeNONE,
1821 tempvar = dest_tree;
1826 = build_tree_list (NULL_TREE,
1827 ffecom_1 (ADDR_EXPR,
1828 build_pointer_type (TREE_TYPE (tempvar)),
1830 TREE_CHAIN (item) = args;
1832 item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1835 if (tempvar != dest_tree)
1836 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1839 item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1842 if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1843 item = ffecom_convert_narrow_ (type, item);
1849 /* Given two arguments, transform them and make a call to the given
1850 function via ffecom_call_. */
1852 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1854 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1855 tree type, ffebld left, ffebld right,
1856 tree dest_tree, ffebld dest, bool *dest_used,
1857 tree callee_commons, bool scalar_args, bool ref, tree hook)
1866 /* Pass arguments by reference. */
1867 left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1868 right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1872 /* Pass arguments by value. */
1873 left_tree = ffecom_arg_expr (left, &left_length);
1874 right_tree = ffecom_arg_expr (right, &right_length);
1878 left_tree = build_tree_list (NULL_TREE, left_tree);
1879 right_tree = build_tree_list (NULL_TREE, right_tree);
1880 TREE_CHAIN (left_tree) = right_tree;
1882 if (left_length != NULL_TREE)
1884 left_length = build_tree_list (NULL_TREE, left_length);
1885 TREE_CHAIN (right_tree) = left_length;
1888 if (right_length != NULL_TREE)
1890 right_length = build_tree_list (NULL_TREE, right_length);
1891 if (left_length != NULL_TREE)
1892 TREE_CHAIN (left_length) = right_length;
1894 TREE_CHAIN (right_tree) = right_length;
1897 return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1898 dest_tree, dest, dest_used, callee_commons,
1903 /* Return ptr/length args for char subexpression
1905 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1906 subexpressions by constructing the appropriate trees for the ptr-to-
1907 character-text and length-of-character-text arguments in a calling
1910 Note that if with_null is TRUE, and the expression is an opCONTER,
1911 a null byte is appended to the string. */
1913 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1915 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1919 ffetargetCharacter1 val;
1920 ffetargetCharacterSize newlen;
1922 switch (ffebld_op (expr))
1924 case FFEBLD_opCONTER:
1925 val = ffebld_constant_character1 (ffebld_conter (expr));
1926 newlen = ffetarget_length_character1 (val);
1929 /* Begin FFETARGET-NULL-KLUDGE. */
1933 *length = build_int_2 (newlen, 0);
1934 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1935 high = build_int_2 (newlen, 0);
1936 TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1937 item = build_string (newlen,
1938 ffetarget_text_character1 (val));
1939 /* End FFETARGET-NULL-KLUDGE. */
1941 = build_type_variant
1945 (ffecom_f2c_ftnlen_type_node,
1946 ffecom_f2c_ftnlen_one_node,
1949 TREE_CONSTANT (item) = 1;
1950 TREE_STATIC (item) = 1;
1951 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
1955 case FFEBLD_opSYMTER:
1957 ffesymbol s = ffebld_symter (expr);
1959 item = ffesymbol_hook (s).decl_tree;
1960 if (item == NULL_TREE)
1962 s = ffecom_sym_transform_ (s);
1963 item = ffesymbol_hook (s).decl_tree;
1965 if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
1967 if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
1968 *length = ffesymbol_hook (s).length_tree;
1971 *length = build_int_2 (ffesymbol_size (s), 0);
1972 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1975 else if (item == error_mark_node)
1976 *length = error_mark_node;
1978 /* FFEINFO_kindFUNCTION. */
1979 *length = NULL_TREE;
1980 if (!ffesymbol_hook (s).addr
1981 && (item != error_mark_node))
1982 item = ffecom_1 (ADDR_EXPR,
1983 build_pointer_type (TREE_TYPE (item)),
1988 case FFEBLD_opARRAYREF:
1990 ffecom_char_args_ (&item, length, ffebld_left (expr));
1992 if (item == error_mark_node || *length == error_mark_node)
1994 item = *length = error_mark_node;
1998 item = ffecom_arrayref_ (item, expr, 1);
2002 case FFEBLD_opSUBSTR:
2006 ffebld thing = ffebld_right (expr);
2009 const char *char_name;
2013 assert (ffebld_op (thing) == FFEBLD_opITEM);
2014 start = ffebld_head (thing);
2015 thing = ffebld_trail (thing);
2016 assert (ffebld_trail (thing) == NULL);
2017 end = ffebld_head (thing);
2019 /* Determine name for pretty-printing range-check errors. */
2020 for (left_symter = ffebld_left (expr);
2021 left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2022 left_symter = ffebld_left (left_symter))
2024 if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2025 char_name = ffesymbol_text (ffebld_symter (left_symter));
2027 char_name = "[expr?]";
2029 ffecom_char_args_ (&item, length, ffebld_left (expr));
2031 if (item == error_mark_node || *length == error_mark_node)
2033 item = *length = error_mark_node;
2037 array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2039 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2047 end_tree = ffecom_expr (end);
2048 if (flag_bounds_check)
2049 end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2051 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2054 if (end_tree == error_mark_node)
2056 item = *length = error_mark_node;
2065 start_tree = ffecom_expr (start);
2066 if (flag_bounds_check)
2067 start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2069 start_tree = convert (ffecom_f2c_ftnlen_type_node,
2072 if (start_tree == error_mark_node)
2074 item = *length = error_mark_node;
2078 start_tree = ffecom_save_tree (start_tree);
2080 item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2082 ffecom_2 (MINUS_EXPR,
2083 TREE_TYPE (start_tree),
2085 ffecom_f2c_ftnlen_one_node));
2089 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2090 ffecom_f2c_ftnlen_one_node,
2091 ffecom_2 (MINUS_EXPR,
2092 ffecom_f2c_ftnlen_type_node,
2098 end_tree = ffecom_expr (end);
2099 if (flag_bounds_check)
2100 end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2102 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2105 if (end_tree == error_mark_node)
2107 item = *length = error_mark_node;
2111 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2112 ffecom_f2c_ftnlen_one_node,
2113 ffecom_2 (MINUS_EXPR,
2114 ffecom_f2c_ftnlen_type_node,
2115 end_tree, start_tree));
2121 case FFEBLD_opFUNCREF:
2123 ffesymbol s = ffebld_symter (ffebld_left (expr));
2126 ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2129 if (size == FFETARGET_charactersizeNONE)
2130 /* ~~Kludge alert! This should someday be fixed. */
2133 *length = build_int_2 (size, 0);
2134 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2136 if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2137 == FFEINFO_whereINTRINSIC)
2141 /* Invocation of an intrinsic returning CHARACTER*1. */
2142 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2146 ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2147 assert (ix != FFECOM_gfrt);
2148 item = ffecom_gfrt_tree_ (ix);
2153 item = ffesymbol_hook (s).decl_tree;
2154 if (item == NULL_TREE)
2156 s = ffecom_sym_transform_ (s);
2157 item = ffesymbol_hook (s).decl_tree;
2159 if (item == error_mark_node)
2161 item = *length = error_mark_node;
2165 if (!ffesymbol_hook (s).addr)
2166 item = ffecom_1_fn (item);
2170 tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2172 tempvar = ffebld_nonter_hook (expr);
2175 tempvar = ffecom_1 (ADDR_EXPR,
2176 build_pointer_type (TREE_TYPE (tempvar)),
2179 args = build_tree_list (NULL_TREE, tempvar);
2181 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) /* Sfunc args by value. */
2182 TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2185 TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2186 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2188 TREE_CHAIN (TREE_CHAIN (args))
2189 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2190 ffebld_right (expr));
2194 TREE_CHAIN (TREE_CHAIN (args))
2195 = ffecom_list_ptr_to_expr (ffebld_right (expr));
2199 item = ffecom_3s (CALL_EXPR,
2200 TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2201 item, args, NULL_TREE);
2202 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2207 case FFEBLD_opCONVERT:
2209 ffecom_char_args_ (&item, length, ffebld_left (expr));
2211 if (item == error_mark_node || *length == error_mark_node)
2213 item = *length = error_mark_node;
2217 if ((ffebld_size_known (ffebld_left (expr))
2218 == FFETARGET_charactersizeNONE)
2219 || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2220 { /* Possible blank-padding needed, copy into
2227 tempvar = ffecom_make_tempvar (char_type_node,
2228 ffebld_size (expr), -1);
2230 tempvar = ffebld_nonter_hook (expr);
2233 tempvar = ffecom_1 (ADDR_EXPR,
2234 build_pointer_type (TREE_TYPE (tempvar)),
2237 newlen = build_int_2 (ffebld_size (expr), 0);
2238 TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2240 args = build_tree_list (NULL_TREE, tempvar);
2241 TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2242 TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2243 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2244 = build_tree_list (NULL_TREE, *length);
2246 item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2247 TREE_SIDE_EFFECTS (item) = 1;
2248 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2253 { /* Just truncate the length. */
2254 *length = build_int_2 (ffebld_size (expr), 0);
2255 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2260 assert ("bad op for single char arg expr" == NULL);
2269 /* Check the size of the type to be sure it doesn't overflow the
2270 "portable" capacities of the compiler back end. `dummy' types
2271 can generally overflow the normal sizes as long as the computations
2272 themselves don't overflow. A particular target of the back end
2273 must still enforce its size requirements, though, and the back
2274 end takes care of this in stor-layout.c. */
2276 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2278 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2280 if (TREE_CODE (type) == ERROR_MARK)
2283 if (TYPE_SIZE (type) == NULL_TREE)
2286 if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2289 if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2290 || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2291 || TREE_OVERFLOW (TYPE_SIZE (type)))))
2293 ffebad_start (FFEBAD_ARRAY_LARGE);
2294 ffebad_string (ffesymbol_text (s));
2295 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2298 return error_mark_node;
2305 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2306 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2307 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2309 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2311 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2313 ffetargetCharacterSize sz = ffesymbol_size (s);
2318 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2319 tlen = NULL_TREE; /* A statement function, no length passed. */
2322 if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2323 tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2324 ffesymbol_text (s));
2326 tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2327 tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2329 DECL_ARTIFICIAL (tlen) = 1;
2333 if (sz == FFETARGET_charactersizeNONE)
2335 assert (tlen != NULL_TREE);
2336 highval = variable_size (tlen);
2340 highval = build_int_2 (sz, 0);
2341 TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2344 type = build_array_type (type,
2345 build_range_type (ffecom_f2c_ftnlen_type_node,
2346 ffecom_f2c_ftnlen_one_node,
2354 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2356 ffecomConcatList_ catlist;
2357 ffebld expr; // expr of CHARACTER basictype.
2358 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2359 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2361 Scans expr for character subexpressions, updates and returns catlist
2364 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2365 static ffecomConcatList_
2366 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2367 ffetargetCharacterSize max)
2369 ffetargetCharacterSize sz;
2371 recurse: /* :::::::::::::::::::: */
2376 if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2377 return catlist; /* Don't append any more items. */
2379 switch (ffebld_op (expr))
2381 case FFEBLD_opCONTER:
2382 case FFEBLD_opSYMTER:
2383 case FFEBLD_opARRAYREF:
2384 case FFEBLD_opFUNCREF:
2385 case FFEBLD_opSUBSTR:
2386 case FFEBLD_opCONVERT: /* Callers should strip this off beforehand
2387 if they don't need to preserve it. */
2388 if (catlist.count == catlist.max)
2389 { /* Make a (larger) list. */
2393 newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2394 newx = malloc_new_ks (malloc_pool_image (), "catlist",
2395 newmax * sizeof (newx[0]));
2396 if (catlist.max != 0)
2398 memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2399 malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2400 catlist.max * sizeof (newx[0]));
2402 catlist.max = newmax;
2403 catlist.exprs = newx;
2405 if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2406 catlist.minlen += sz;
2408 ++catlist.minlen; /* Not true for F90; can be 0 length. */
2409 if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2410 catlist.maxlen = sz;
2412 catlist.maxlen += sz;
2413 if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2414 { /* This item overlaps (or is beyond) the end
2415 of the destination. */
2416 switch (ffebld_op (expr))
2418 case FFEBLD_opCONTER:
2419 case FFEBLD_opSYMTER:
2420 case FFEBLD_opARRAYREF:
2421 case FFEBLD_opFUNCREF:
2422 case FFEBLD_opSUBSTR:
2423 /* ~~Do useful truncations here. */
2427 assert ("op changed or inconsistent switches!" == NULL);
2431 catlist.exprs[catlist.count++] = expr;
2434 case FFEBLD_opPAREN:
2435 expr = ffebld_left (expr);
2436 goto recurse; /* :::::::::::::::::::: */
2438 case FFEBLD_opCONCATENATE:
2439 catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2440 expr = ffebld_right (expr);
2441 goto recurse; /* :::::::::::::::::::: */
2443 #if 0 /* Breaks passing small actual arg to larger
2444 dummy arg of sfunc */
2445 case FFEBLD_opCONVERT:
2446 expr = ffebld_left (expr);
2448 ffetargetCharacterSize cmax;
2450 cmax = catlist.len + ffebld_size_known (expr);
2452 if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2455 goto recurse; /* :::::::::::::::::::: */
2462 assert ("bad op in _gather_" == NULL);
2468 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2470 ffecomConcatList_ catlist;
2471 ffecom_concat_list_kill_(catlist);
2473 Anything allocated within the list info is deallocated. */
2475 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2477 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2479 if (catlist.max != 0)
2480 malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2481 catlist.max * sizeof (catlist.exprs[0]));
2485 /* Make list of concatenated string exprs.
2487 Returns a flattened list of concatenated subexpressions given a
2488 tree of such expressions. */
2490 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2491 static ffecomConcatList_
2492 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2494 ffecomConcatList_ catlist;
2496 catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2497 return ffecom_concat_list_gather_ (catlist, expr, max);
2502 /* Provide some kind of useful info on member of aggregate area,
2503 since current g77/gcc technology does not provide debug info
2504 on these members. */
2506 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2508 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2509 tree member_type UNUSED, ffetargetOffset offset)
2519 for (type_id = member_type;
2520 TREE_CODE (type_id) != IDENTIFIER_NODE;
2523 switch (TREE_CODE (type_id))
2527 type_id = TYPE_NAME (type_id);
2532 type_id = TREE_TYPE (type_id);
2536 assert ("no IDENTIFIER_NODE for type!" == NULL);
2537 type_id = error_mark_node;
2543 if (ffecom_transform_only_dummies_
2544 || !ffe_is_debug_kludge ())
2545 return; /* Can't do this yet, maybe later. */
2548 + strlen (aggr_type)
2549 + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2551 + IDENTIFIER_LENGTH (type_id);
2554 if (((size_t) len) >= ARRAY_SIZE (space))
2555 buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2559 sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2561 IDENTIFIER_POINTER (DECL_NAME (aggr)),
2564 value = build_string (len, buff);
2566 = build_type_variant (build_array_type (char_type_node,
2570 build_int_2 (strlen (buff), 0))),
2572 decl = build_decl (VAR_DECL,
2573 ffecom_get_identifier_ (ffesymbol_text (member)),
2575 TREE_CONSTANT (decl) = 1;
2576 TREE_STATIC (decl) = 1;
2577 DECL_INITIAL (decl) = error_mark_node;
2578 DECL_IN_SYSTEM_HEADER (decl) = 1; /* Don't let -Wunused complain. */
2579 decl = start_decl (decl, FALSE);
2580 finish_decl (decl, value, FALSE);
2582 if (buff != &space[0])
2583 malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2587 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2589 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2590 int i; // entry# for this entrypoint (used by master fn)
2591 ffecom_do_entrypoint_(s,i);
2593 Makes a public entry point that calls our private master fn (already
2596 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2598 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2601 tree type; /* Type of function. */
2602 tree multi_retval; /* Var holding return value (union). */
2603 tree result; /* Var holding result. */
2604 ffeinfoBasictype bt;
2608 bool charfunc; /* All entry points return same type
2610 bool cmplxfunc; /* Use f2c way of returning COMPLEX. */
2611 bool multi; /* Master fn has multiple return types. */
2612 bool altreturning = FALSE; /* This entry point has alternate returns. */
2613 int old_lineno = lineno;
2614 const char *old_input_filename = input_filename;
2616 input_filename = ffesymbol_where_filename (fn);
2617 lineno = ffesymbol_where_filelinenum (fn);
2619 ffecom_doing_entry_ = TRUE; /* Don't bother with array dimensions. */
2621 switch (ffecom_primary_entry_kind_)
2623 case FFEINFO_kindFUNCTION:
2625 /* Determine actual return type for function. */
2627 gt = FFEGLOBAL_typeFUNC;
2628 bt = ffesymbol_basictype (fn);
2629 kt = ffesymbol_kindtype (fn);
2630 if (bt == FFEINFO_basictypeNONE)
2632 ffeimplic_establish_symbol (fn);
2633 if (ffesymbol_funcresult (fn) != NULL)
2634 ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2635 bt = ffesymbol_basictype (fn);
2636 kt = ffesymbol_kindtype (fn);
2639 if (bt == FFEINFO_basictypeCHARACTER)
2640 charfunc = TRUE, cmplxfunc = FALSE;
2641 else if ((bt == FFEINFO_basictypeCOMPLEX)
2642 && ffesymbol_is_f2c (fn))
2643 charfunc = FALSE, cmplxfunc = TRUE;
2645 charfunc = cmplxfunc = FALSE;
2648 type = ffecom_tree_fun_type_void;
2649 else if (ffesymbol_is_f2c (fn))
2650 type = ffecom_tree_fun_type[bt][kt];
2652 type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2654 if ((type == NULL_TREE)
2655 || (TREE_TYPE (type) == NULL_TREE))
2656 type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
2658 multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2661 case FFEINFO_kindSUBROUTINE:
2662 gt = FFEGLOBAL_typeSUBR;
2663 bt = FFEINFO_basictypeNONE;
2664 kt = FFEINFO_kindtypeNONE;
2665 if (ffecom_is_altreturning_)
2666 { /* Am _I_ altreturning? */
2667 for (item = ffesymbol_dummyargs (fn);
2669 item = ffebld_trail (item))
2671 if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2673 altreturning = TRUE;
2678 type = ffecom_tree_subr_type;
2680 type = ffecom_tree_fun_type_void;
2683 type = ffecom_tree_fun_type_void;
2690 assert ("say what??" == NULL);
2692 case FFEINFO_kindANY:
2693 gt = FFEGLOBAL_typeANY;
2694 bt = FFEINFO_basictypeNONE;
2695 kt = FFEINFO_kindtypeNONE;
2696 type = error_mark_node;
2703 /* build_decl uses the current lineno and input_filename to set the decl
2704 source info. So, I've putzed with ffestd and ffeste code to update that
2705 source info to point to the appropriate statement just before calling
2706 ffecom_do_entrypoint (which calls this fn). */
2708 start_function (ffecom_get_external_identifier_ (fn),
2710 0, /* nested/inline */
2711 1); /* TREE_PUBLIC */
2713 if (((g = ffesymbol_global (fn)) != NULL)
2714 && ((ffeglobal_type (g) == gt)
2715 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2717 ffeglobal_set_hook (g, current_function_decl);
2720 /* Reset args in master arg list so they get retransitioned. */
2722 for (item = ffecom_master_arglist_;
2724 item = ffebld_trail (item))
2729 arg = ffebld_head (item);
2730 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2731 continue; /* Alternate return or some such thing. */
2732 s = ffebld_symter (arg);
2733 ffesymbol_hook (s).decl_tree = NULL_TREE;
2734 ffesymbol_hook (s).length_tree = NULL_TREE;
2737 /* Build dummy arg list for this entry point. */
2739 if (charfunc || cmplxfunc)
2740 { /* Prepend arg for where result goes. */
2745 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2747 type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2749 result = ffecom_get_invented_identifier ("__g77_%s", "result");
2751 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2754 length = ffecom_char_enhance_arg_ (&type, fn);
2756 length = NULL_TREE; /* Not ref'd if !charfunc. */
2758 type = build_pointer_type (type);
2759 result = build_decl (PARM_DECL, result, type);
2761 push_parm_decl (result);
2762 ffecom_func_result_ = result;
2766 push_parm_decl (length);
2767 ffecom_func_length_ = length;
2771 result = DECL_RESULT (current_function_decl);
2773 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2775 store_parm_decls (0);
2777 ffecom_start_compstmt ();
2778 /* Disallow temp vars at this level. */
2779 current_binding_level->prep_state = 2;
2781 /* Make local var to hold return type for multi-type master fn. */
2785 multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2787 multi_retval = build_decl (VAR_DECL, multi_retval,
2788 ffecom_multi_type_node_);
2789 multi_retval = start_decl (multi_retval, FALSE);
2790 finish_decl (multi_retval, NULL_TREE, FALSE);
2793 multi_retval = NULL_TREE; /* Not actually ref'd if !multi. */
2795 /* Here we emit the actual code for the entry point. */
2801 tree arglist = NULL_TREE;
2802 tree *plist = &arglist;
2808 /* Prepare actual arg list based on master arg list. */
2810 for (list = ffecom_master_arglist_;
2812 list = ffebld_trail (list))
2814 arg = ffebld_head (list);
2815 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2817 s = ffebld_symter (arg);
2818 if (ffesymbol_hook (s).decl_tree == NULL_TREE
2819 || ffesymbol_hook (s).decl_tree == error_mark_node)
2820 actarg = null_pointer_node; /* We don't have this arg. */
2822 actarg = ffesymbol_hook (s).decl_tree;
2823 *plist = build_tree_list (NULL_TREE, actarg);
2824 plist = &TREE_CHAIN (*plist);
2827 /* This code appends the length arguments for character
2828 variables/arrays. */
2830 for (list = ffecom_master_arglist_;
2832 list = ffebld_trail (list))
2834 arg = ffebld_head (list);
2835 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2837 s = ffebld_symter (arg);
2838 if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2839 continue; /* Only looking for CHARACTER arguments. */
2840 if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2841 continue; /* Only looking for variables and arrays. */
2842 if (ffesymbol_hook (s).length_tree == NULL_TREE
2843 || ffesymbol_hook (s).length_tree == error_mark_node)
2844 actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2846 actarg = ffesymbol_hook (s).length_tree;
2847 *plist = build_tree_list (NULL_TREE, actarg);
2848 plist = &TREE_CHAIN (*plist);
2851 /* Prepend character-value return info to actual arg list. */
2855 prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2856 TREE_CHAIN (prepend)
2857 = build_tree_list (NULL_TREE, ffecom_func_length_);
2858 TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2862 /* Prepend multi-type return value to actual arg list. */
2867 = build_tree_list (NULL_TREE,
2868 ffecom_1 (ADDR_EXPR,
2869 build_pointer_type (TREE_TYPE (multi_retval)),
2871 TREE_CHAIN (prepend) = arglist;
2875 /* Prepend my entry-point number to the actual arg list. */
2877 prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2878 TREE_CHAIN (prepend) = arglist;
2881 /* Build the call to the master function. */
2883 master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2884 call = ffecom_3s (CALL_EXPR,
2885 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2886 master_fn, arglist, NULL_TREE);
2888 /* Decide whether the master function is a function or subroutine, and
2889 handle the return value for my entry point. */
2891 if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2894 expand_expr_stmt (call);
2895 expand_null_return ();
2897 else if (multi && cmplxfunc)
2899 expand_expr_stmt (call);
2901 = ffecom_1 (INDIRECT_REF,
2902 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2904 result = ffecom_modify (NULL_TREE, result,
2905 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2907 ffecom_multi_fields_[bt][kt]));
2908 expand_expr_stmt (result);
2909 expand_null_return ();
2913 expand_expr_stmt (call);
2915 = ffecom_modify (NULL_TREE, result,
2916 convert (TREE_TYPE (result),
2917 ffecom_2 (COMPONENT_REF,
2918 ffecom_tree_type[bt][kt],
2920 ffecom_multi_fields_[bt][kt])));
2921 expand_return (result);
2926 = ffecom_1 (INDIRECT_REF,
2927 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2929 result = ffecom_modify (NULL_TREE, result, call);
2930 expand_expr_stmt (result);
2931 expand_null_return ();
2935 result = ffecom_modify (NULL_TREE,
2937 convert (TREE_TYPE (result),
2939 expand_return (result);
2943 ffecom_end_compstmt ();
2945 finish_function (0);
2947 lineno = old_lineno;
2948 input_filename = old_input_filename;
2950 ffecom_doing_entry_ = FALSE;
2954 /* Transform expr into gcc tree with possible destination
2956 Recursive descent on expr while making corresponding tree nodes and
2957 attaching type info and such. If destination supplied and compatible
2958 with temporary that would be made in certain cases, temporary isn't
2959 made, destination used instead, and dest_used flag set TRUE. */
2961 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2963 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
2964 bool *dest_used, bool assignp, bool widenp)
2969 ffeinfoBasictype bt;
2972 tree dt; /* decl_tree for an ffesymbol. */
2973 tree tree_type, tree_type_x;
2976 enum tree_code code;
2978 assert (expr != NULL);
2980 if (dest_used != NULL)
2983 bt = ffeinfo_basictype (ffebld_info (expr));
2984 kt = ffeinfo_kindtype (ffebld_info (expr));
2985 tree_type = ffecom_tree_type[bt][kt];
2987 /* Widen integral arithmetic as desired while preserving signedness. */
2988 tree_type_x = NULL_TREE;
2989 if (widenp && tree_type
2990 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
2991 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
2992 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
2994 switch (ffebld_op (expr))
2996 case FFEBLD_opACCTER:
2999 ffebit bits = ffebld_accter_bits (expr);
3000 ffetargetOffset source_offset = 0;
3001 ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3004 assert (dest_offset == 0
3005 || (bt == FFEINFO_basictypeCHARACTER
3006 && kt == FFEINFO_kindtypeCHARACTER1));
3011 ffebldConstantUnion cu;
3014 ffebldConstantArray ca = ffebld_accter (expr);
3016 ffebit_test (bits, source_offset, &value, &length);
3022 for (i = 0; i < length; ++i)
3024 cu = ffebld_constantarray_get (ca, bt, kt,
3027 t = ffecom_constantunion (&cu, bt, kt, tree_type);
3030 && dest_offset != 0)
3031 purpose = build_int_2 (dest_offset, 0);
3033 purpose = NULL_TREE;
3035 if (list == NULL_TREE)
3036 list = item = build_tree_list (purpose, t);
3039 TREE_CHAIN (item) = build_tree_list (purpose, t);
3040 item = TREE_CHAIN (item);
3044 source_offset += length;
3045 dest_offset += length;
3049 item = build_int_2 ((ffebld_accter_size (expr)
3050 + ffebld_accter_pad (expr)) - 1, 0);
3051 ffebit_kill (ffebld_accter_bits (expr));
3052 TREE_TYPE (item) = ffecom_integer_type_node;
3056 build_range_type (ffecom_integer_type_node,
3057 ffecom_integer_zero_node,
3059 list = build (CONSTRUCTOR, item, NULL_TREE, list);
3060 TREE_CONSTANT (list) = 1;
3061 TREE_STATIC (list) = 1;
3064 case FFEBLD_opARRTER:
3069 if (ffebld_arrter_pad (expr) == 0)
3073 assert (bt == FFEINFO_basictypeCHARACTER
3074 && kt == FFEINFO_kindtypeCHARACTER1);
3076 /* Becomes PURPOSE first time through loop. */
3077 item = build_int_2 (ffebld_arrter_pad (expr), 0);
3080 for (i = 0; i < ffebld_arrter_size (expr); ++i)
3082 ffebldConstantUnion cu
3083 = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3085 t = ffecom_constantunion (&cu, bt, kt, tree_type);
3087 if (list == NULL_TREE)
3088 /* Assume item is PURPOSE first time through loop. */
3089 list = item = build_tree_list (item, t);
3092 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3093 item = TREE_CHAIN (item);
3098 item = build_int_2 ((ffebld_arrter_size (expr)
3099 + ffebld_arrter_pad (expr)) - 1, 0);
3100 TREE_TYPE (item) = ffecom_integer_type_node;
3104 build_range_type (ffecom_integer_type_node,
3105 ffecom_integer_zero_node,
3107 list = build (CONSTRUCTOR, item, NULL_TREE, list);
3108 TREE_CONSTANT (list) = 1;
3109 TREE_STATIC (list) = 1;
3112 case FFEBLD_opCONTER:
3113 assert (ffebld_conter_pad (expr) == 0);
3115 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3119 case FFEBLD_opSYMTER:
3120 if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3121 || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3122 return ffecom_ptr_to_expr (expr); /* Same as %REF(intrinsic). */
3123 s = ffebld_symter (expr);
3124 t = ffesymbol_hook (s).decl_tree;
3127 { /* ASSIGN'ed-label expr. */
3128 if (ffe_is_ugly_assign ())
3130 /* User explicitly wants ASSIGN'ed variables to be at the same
3131 memory address as the variables when used in non-ASSIGN
3132 contexts. That can make old, arcane, non-standard code
3133 work, but don't try to do it when a pointer wouldn't fit
3134 in the normal variable (take other approach, and warn,
3139 s = ffecom_sym_transform_ (s);
3140 t = ffesymbol_hook (s).decl_tree;
3141 assert (t != NULL_TREE);
3144 if (t == error_mark_node)
3147 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3148 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3150 if (ffesymbol_hook (s).addr)
3151 t = ffecom_1 (INDIRECT_REF,
3152 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3156 if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3158 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3159 FFEBAD_severityWARNING);
3160 ffebad_string (ffesymbol_text (s));
3161 ffebad_here (0, ffesymbol_where_line (s),
3162 ffesymbol_where_column (s));
3167 /* Don't use the normal variable's tree for ASSIGN, though mark
3168 it as in the system header (housekeeping). Use an explicit,
3169 specially created sibling that is known to be wide enough
3170 to hold pointers to labels. */
3173 && TREE_CODE (t) == VAR_DECL)
3174 DECL_IN_SYSTEM_HEADER (t) = 1; /* Don't let -Wunused complain. */
3176 t = ffesymbol_hook (s).assign_tree;
3179 s = ffecom_sym_transform_assign_ (s);
3180 t = ffesymbol_hook (s).assign_tree;
3181 assert (t != NULL_TREE);
3188 s = ffecom_sym_transform_ (s);
3189 t = ffesymbol_hook (s).decl_tree;
3190 assert (t != NULL_TREE);
3192 if (ffesymbol_hook (s).addr)
3193 t = ffecom_1 (INDIRECT_REF,
3194 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3198 case FFEBLD_opARRAYREF:
3199 return ffecom_arrayref_ (NULL_TREE, expr, 0);
3201 case FFEBLD_opUPLUS:
3202 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3203 return ffecom_1 (NOP_EXPR, tree_type, left);
3205 case FFEBLD_opPAREN:
3206 /* ~~~Make sure Fortran rules respected here */
3207 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3208 return ffecom_1 (NOP_EXPR, tree_type, left);
3210 case FFEBLD_opUMINUS:
3211 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3214 tree_type = tree_type_x;
3215 left = convert (tree_type, left);
3217 return ffecom_1 (NEGATE_EXPR, tree_type, left);
3220 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3221 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3224 tree_type = tree_type_x;
3225 left = convert (tree_type, left);
3226 right = convert (tree_type, right);
3228 return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3230 case FFEBLD_opSUBTRACT:
3231 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3232 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3235 tree_type = tree_type_x;
3236 left = convert (tree_type, left);
3237 right = convert (tree_type, right);
3239 return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3241 case FFEBLD_opMULTIPLY:
3242 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3243 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3246 tree_type = tree_type_x;
3247 left = convert (tree_type, left);
3248 right = convert (tree_type, right);
3250 return ffecom_2 (MULT_EXPR, tree_type, left, right);
3252 case FFEBLD_opDIVIDE:
3253 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3254 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3257 tree_type = tree_type_x;
3258 left = convert (tree_type, left);
3259 right = convert (tree_type, right);
3261 return ffecom_tree_divide_ (tree_type, left, right,
3262 dest_tree, dest, dest_used,
3263 ffebld_nonter_hook (expr));
3265 case FFEBLD_opPOWER:
3267 ffebld left = ffebld_left (expr);
3268 ffebld right = ffebld_right (expr);
3270 ffeinfoKindtype rtkt;
3271 ffeinfoKindtype ltkt;
3274 switch (ffeinfo_basictype (ffebld_info (right)))
3277 case FFEINFO_basictypeINTEGER:
3280 item = ffecom_expr_power_integer_ (expr);
3281 if (item != NULL_TREE)
3285 rtkt = FFEINFO_kindtypeINTEGER1;
3286 switch (ffeinfo_basictype (ffebld_info (left)))
3288 case FFEINFO_basictypeINTEGER:
3289 if ((ffeinfo_kindtype (ffebld_info (left))
3290 == FFEINFO_kindtypeINTEGER4)
3291 || (ffeinfo_kindtype (ffebld_info (right))
3292 == FFEINFO_kindtypeINTEGER4))
3294 code = FFECOM_gfrtPOW_QQ;
3295 ltkt = FFEINFO_kindtypeINTEGER4;
3296 rtkt = FFEINFO_kindtypeINTEGER4;
3300 code = FFECOM_gfrtPOW_II;
3301 ltkt = FFEINFO_kindtypeINTEGER1;
3305 case FFEINFO_basictypeREAL:
3306 if (ffeinfo_kindtype (ffebld_info (left))
3307 == FFEINFO_kindtypeREAL1)
3309 code = FFECOM_gfrtPOW_RI;
3310 ltkt = FFEINFO_kindtypeREAL1;
3314 code = FFECOM_gfrtPOW_DI;
3315 ltkt = FFEINFO_kindtypeREAL2;
3319 case FFEINFO_basictypeCOMPLEX:
3320 if (ffeinfo_kindtype (ffebld_info (left))
3321 == FFEINFO_kindtypeREAL1)
3323 code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
3324 ltkt = FFEINFO_kindtypeREAL1;
3328 code = FFECOM_gfrtPOW_ZI; /* Overlapping result okay. */
3329 ltkt = FFEINFO_kindtypeREAL2;
3334 assert ("bad pow_*i" == NULL);
3335 code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
3336 ltkt = FFEINFO_kindtypeREAL1;
3339 if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3340 left = ffeexpr_convert (left, NULL, NULL,
3341 ffeinfo_basictype (ffebld_info (left)),
3343 FFETARGET_charactersizeNONE,
3344 FFEEXPR_contextLET);
3345 if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3346 right = ffeexpr_convert (right, NULL, NULL,
3347 FFEINFO_basictypeINTEGER,
3349 FFETARGET_charactersizeNONE,
3350 FFEEXPR_contextLET);
3353 case FFEINFO_basictypeREAL:
3354 if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3355 left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3356 FFEINFO_kindtypeREALDOUBLE, 0,
3357 FFETARGET_charactersizeNONE,
3358 FFEEXPR_contextLET);
3359 if (ffeinfo_kindtype (ffebld_info (right))
3360 == FFEINFO_kindtypeREAL1)
3361 right = ffeexpr_convert (right, NULL, NULL,
3362 FFEINFO_basictypeREAL,
3363 FFEINFO_kindtypeREALDOUBLE, 0,
3364 FFETARGET_charactersizeNONE,
3365 FFEEXPR_contextLET);
3366 /* We used to call FFECOM_gfrtPOW_DD here,
3367 which passes arguments by reference. */
3368 code = FFECOM_gfrtL_POW;
3369 /* Pass arguments by value. */
3373 case FFEINFO_basictypeCOMPLEX:
3374 if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3375 left = ffeexpr_convert (left, NULL, NULL,
3376 FFEINFO_basictypeCOMPLEX,
3377 FFEINFO_kindtypeREALDOUBLE, 0,
3378 FFETARGET_charactersizeNONE,
3379 FFEEXPR_contextLET);
3380 if (ffeinfo_kindtype (ffebld_info (right))
3381 == FFEINFO_kindtypeREAL1)
3382 right = ffeexpr_convert (right, NULL, NULL,
3383 FFEINFO_basictypeCOMPLEX,
3384 FFEINFO_kindtypeREALDOUBLE, 0,
3385 FFETARGET_charactersizeNONE,
3386 FFEEXPR_contextLET);
3387 code = FFECOM_gfrtPOW_ZZ; /* Overlapping result okay. */
3388 ref = TRUE; /* Pass arguments by reference. */
3392 assert ("bad pow_x*" == NULL);
3393 code = FFECOM_gfrtPOW_II;
3396 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3397 ffecom_gfrt_kindtype (code),
3398 (ffe_is_f2c_library ()
3399 && ffecom_gfrt_complex_[code]),
3400 tree_type, left, right,
3401 dest_tree, dest, dest_used,
3402 NULL_TREE, FALSE, ref,
3403 ffebld_nonter_hook (expr));
3409 case FFEINFO_basictypeLOGICAL:
3410 item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3411 return convert (tree_type, item);
3413 case FFEINFO_basictypeINTEGER:
3414 return ffecom_1 (BIT_NOT_EXPR, tree_type,
3415 ffecom_expr (ffebld_left (expr)));
3418 assert ("NOT bad basictype" == NULL);
3420 case FFEINFO_basictypeANY:
3421 return error_mark_node;
3425 case FFEBLD_opFUNCREF:
3426 assert (ffeinfo_basictype (ffebld_info (expr))
3427 != FFEINFO_basictypeCHARACTER);
3429 case FFEBLD_opSUBRREF:
3430 if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3431 == FFEINFO_whereINTRINSIC)
3432 { /* Invocation of an intrinsic. */
3433 item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3437 s = ffebld_symter (ffebld_left (expr));
3438 dt = ffesymbol_hook (s).decl_tree;
3439 if (dt == NULL_TREE)
3441 s = ffecom_sym_transform_ (s);
3442 dt = ffesymbol_hook (s).decl_tree;
3444 if (dt == error_mark_node)
3447 if (ffesymbol_hook (s).addr)
3450 item = ffecom_1_fn (dt);
3452 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3453 args = ffecom_list_expr (ffebld_right (expr));
3455 args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3457 if (args == error_mark_node)
3458 return error_mark_node;
3460 item = ffecom_call_ (item, kt,
3461 ffesymbol_is_f2c (s)
3462 && (bt == FFEINFO_basictypeCOMPLEX)
3463 && (ffesymbol_where (s)
3464 != FFEINFO_whereCONSTANT),
3467 dest_tree, dest, dest_used,
3468 error_mark_node, FALSE,
3469 ffebld_nonter_hook (expr));
3470 TREE_SIDE_EFFECTS (item) = 1;
3476 case FFEINFO_basictypeLOGICAL:
3478 = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3479 ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3480 ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3481 return convert (tree_type, item);
3483 case FFEINFO_basictypeINTEGER:
3484 return ffecom_2 (BIT_AND_EXPR, tree_type,
3485 ffecom_expr (ffebld_left (expr)),
3486 ffecom_expr (ffebld_right (expr)));
3489 assert ("AND bad basictype" == NULL);
3491 case FFEINFO_basictypeANY:
3492 return error_mark_node;
3499 case FFEINFO_basictypeLOGICAL:
3501 = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3502 ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3503 ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3504 return convert (tree_type, item);
3506 case FFEINFO_basictypeINTEGER:
3507 return ffecom_2 (BIT_IOR_EXPR, tree_type,
3508 ffecom_expr (ffebld_left (expr)),
3509 ffecom_expr (ffebld_right (expr)));
3512 assert ("OR bad basictype" == NULL);
3514 case FFEINFO_basictypeANY:
3515 return error_mark_node;
3523 case FFEINFO_basictypeLOGICAL:
3525 = ffecom_2 (NE_EXPR, integer_type_node,
3526 ffecom_expr (ffebld_left (expr)),
3527 ffecom_expr (ffebld_right (expr)));
3528 return convert (tree_type, ffecom_truth_value (item));
3530 case FFEINFO_basictypeINTEGER:
3531 return ffecom_2 (BIT_XOR_EXPR, tree_type,
3532 ffecom_expr (ffebld_left (expr)),
3533 ffecom_expr (ffebld_right (expr)));
3536 assert ("XOR/NEQV bad basictype" == NULL);
3538 case FFEINFO_basictypeANY:
3539 return error_mark_node;
3546 case FFEINFO_basictypeLOGICAL:
3548 = ffecom_2 (EQ_EXPR, integer_type_node,
3549 ffecom_expr (ffebld_left (expr)),
3550 ffecom_expr (ffebld_right (expr)));
3551 return convert (tree_type, ffecom_truth_value (item));
3553 case FFEINFO_basictypeINTEGER:
3555 ffecom_1 (BIT_NOT_EXPR, tree_type,
3556 ffecom_2 (BIT_XOR_EXPR, tree_type,
3557 ffecom_expr (ffebld_left (expr)),
3558 ffecom_expr (ffebld_right (expr))));
3561 assert ("EQV bad basictype" == NULL);
3563 case FFEINFO_basictypeANY:
3564 return error_mark_node;
3568 case FFEBLD_opCONVERT:
3569 if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3570 return error_mark_node;
3574 case FFEINFO_basictypeLOGICAL:
3575 case FFEINFO_basictypeINTEGER:
3576 case FFEINFO_basictypeREAL:
3577 return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3579 case FFEINFO_basictypeCOMPLEX:
3580 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3582 case FFEINFO_basictypeINTEGER:
3583 case FFEINFO_basictypeLOGICAL:
3584 case FFEINFO_basictypeREAL:
3585 item = ffecom_expr (ffebld_left (expr));
3586 if (item == error_mark_node)
3587 return error_mark_node;
3588 /* convert() takes care of converting to the subtype first,
3589 at least in gcc-2.7.2. */
3590 item = convert (tree_type, item);
3593 case FFEINFO_basictypeCOMPLEX:
3594 return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3597 assert ("CONVERT COMPLEX bad basictype" == NULL);
3599 case FFEINFO_basictypeANY:
3600 return error_mark_node;
3605 assert ("CONVERT bad basictype" == NULL);
3607 case FFEINFO_basictypeANY:
3608 return error_mark_node;
3614 goto relational; /* :::::::::::::::::::: */
3618 goto relational; /* :::::::::::::::::::: */
3622 goto relational; /* :::::::::::::::::::: */
3626 goto relational; /* :::::::::::::::::::: */
3630 goto relational; /* :::::::::::::::::::: */
3635 relational: /* :::::::::::::::::::: */
3636 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3638 case FFEINFO_basictypeLOGICAL:
3639 case FFEINFO_basictypeINTEGER:
3640 case FFEINFO_basictypeREAL:
3641 item = ffecom_2 (code, integer_type_node,
3642 ffecom_expr (ffebld_left (expr)),
3643 ffecom_expr (ffebld_right (expr)));
3644 return convert (tree_type, item);
3646 case FFEINFO_basictypeCOMPLEX:
3647 assert (code == EQ_EXPR || code == NE_EXPR);
3650 tree arg1 = ffecom_expr (ffebld_left (expr));
3651 tree arg2 = ffecom_expr (ffebld_right (expr));
3653 if (arg1 == error_mark_node || arg2 == error_mark_node)
3654 return error_mark_node;
3656 arg1 = ffecom_save_tree (arg1);
3657 arg2 = ffecom_save_tree (arg2);
3659 if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3661 real_type = TREE_TYPE (TREE_TYPE (arg1));
3662 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3666 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3667 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3671 = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3672 ffecom_2 (EQ_EXPR, integer_type_node,
3673 ffecom_1 (REALPART_EXPR, real_type, arg1),
3674 ffecom_1 (REALPART_EXPR, real_type, arg2)),
3675 ffecom_2 (EQ_EXPR, integer_type_node,
3676 ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3677 ffecom_1 (IMAGPART_EXPR, real_type,
3679 if (code == EQ_EXPR)
3680 item = ffecom_truth_value (item);
3682 item = ffecom_truth_value_invert (item);
3683 return convert (tree_type, item);
3686 case FFEINFO_basictypeCHARACTER:
3688 ffebld left = ffebld_left (expr);
3689 ffebld right = ffebld_right (expr);
3695 /* f2c run-time functions do the implicit blank-padding for us,
3696 so we don't usually have to implement blank-padding ourselves.
3697 (The exception is when we pass an argument to a separately
3698 compiled statement function -- if we know the arg is not the
3699 same length as the dummy, we must truncate or extend it. If
3700 we "inline" statement functions, that necessity goes away as
3703 Strip off the CONVERT operators that blank-pad. (Truncation by
3704 CONVERT shouldn't happen here, but it can happen in
3707 while (ffebld_op (left) == FFEBLD_opCONVERT)
3708 left = ffebld_left (left);
3709 while (ffebld_op (right) == FFEBLD_opCONVERT)
3710 right = ffebld_left (right);
3712 left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3713 right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3715 if (left_tree == error_mark_node || left_length == error_mark_node
3716 || right_tree == error_mark_node
3717 || right_length == error_mark_node)
3718 return error_mark_node;
3720 if ((ffebld_size_known (left) == 1)
3721 && (ffebld_size_known (right) == 1))
3724 = ffecom_1 (INDIRECT_REF,
3725 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3728 = ffecom_1 (INDIRECT_REF,
3729 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3733 = ffecom_2 (code, integer_type_node,
3734 ffecom_2 (ARRAY_REF,
3735 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3738 ffecom_2 (ARRAY_REF,
3739 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3745 item = build_tree_list (NULL_TREE, left_tree);
3746 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3747 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3749 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3750 = build_tree_list (NULL_TREE, right_length);
3751 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3752 item = ffecom_2 (code, integer_type_node,
3754 convert (TREE_TYPE (item),
3755 integer_zero_node));
3757 item = convert (tree_type, item);
3763 assert ("relational bad basictype" == NULL);
3765 case FFEINFO_basictypeANY:
3766 return error_mark_node;
3770 case FFEBLD_opPERCENT_LOC:
3771 item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3772 return convert (tree_type, item);
3776 case FFEBLD_opBOUNDS:
3777 case FFEBLD_opREPEAT:
3778 case FFEBLD_opLABTER:
3779 case FFEBLD_opLABTOK:
3780 case FFEBLD_opIMPDO:
3781 case FFEBLD_opCONCATENATE:
3782 case FFEBLD_opSUBSTR:
3784 assert ("bad op" == NULL);
3787 return error_mark_node;
3791 assert ("didn't think anything got here anymore!!" == NULL);
3793 switch (ffebld_arity (expr))
3796 TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3797 TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3798 if (TREE_OPERAND (item, 0) == error_mark_node
3799 || TREE_OPERAND (item, 1) == error_mark_node)
3800 return error_mark_node;
3804 TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3805 if (TREE_OPERAND (item, 0) == error_mark_node)
3806 return error_mark_node;
3818 /* Returns the tree that does the intrinsic invocation.
3820 Note: this function applies only to intrinsics returning
3821 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3824 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3826 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3827 ffebld dest, bool *dest_used)
3830 tree saved_expr1; /* For those who need it. */
3831 tree saved_expr2; /* For those who need it. */
3832 ffeinfoBasictype bt;
3836 tree real_type; /* REAL type corresponding to COMPLEX. */
3838 ffebld list = ffebld_right (expr); /* List of (some) args. */
3839 ffebld arg1; /* For handy reference. */
3842 ffeintrinImp codegen_imp;
3845 assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3847 if (dest_used != NULL)
3850 bt = ffeinfo_basictype (ffebld_info (expr));
3851 kt = ffeinfo_kindtype (ffebld_info (expr));
3852 tree_type = ffecom_tree_type[bt][kt];
3856 arg1 = ffebld_head (list);
3857 if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3858 return error_mark_node;
3859 if ((list = ffebld_trail (list)) != NULL)
3861 arg2 = ffebld_head (list);
3862 if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3863 return error_mark_node;
3864 if ((list = ffebld_trail (list)) != NULL)
3866 arg3 = ffebld_head (list);
3867 if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3868 return error_mark_node;
3877 arg1 = arg2 = arg3 = NULL;
3879 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3880 args. This is used by the MAX/MIN expansions. */
3883 arg1_type = ffecom_tree_type
3884 [ffeinfo_basictype (ffebld_info (arg1))]
3885 [ffeinfo_kindtype (ffebld_info (arg1))];
3887 arg1_type = NULL_TREE; /* Really not needed, but might catch bugs
3890 /* There are several ways for each of the cases in the following switch
3891 statements to exit (from simplest to use to most complicated):
3893 break; (when expr_tree == NULL)
3895 A standard call is made to the specific intrinsic just as if it had been
3896 passed in as a dummy procedure and called as any old procedure. This
3897 method can produce slower code but in some cases it's the easiest way for
3898 now. However, if a (presumably faster) direct call is available,
3899 that is used, so this is the easiest way in many more cases now.
3901 gfrt = FFECOM_gfrtWHATEVER;
3904 gfrt contains the gfrt index of a library function to call, passing the
3905 argument(s) by value rather than by reference. Used when a more
3906 careful choice of library function is needed than that provided
3907 by the vanilla `break;'.
3911 The expr_tree has been completely set up and is ready to be returned
3912 as is. No further actions are taken. Use this when the tree is not
3913 in the simple form for one of the arity_n labels. */
3915 /* For info on how the switch statement cases were written, see the files
3916 enclosed in comments below the switch statement. */
3918 codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3919 gfrt = ffeintrin_gfrt_direct (codegen_imp);
3920 if (gfrt == FFECOM_gfrt)
3921 gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3923 switch (codegen_imp)
3925 case FFEINTRIN_impABS:
3926 case FFEINTRIN_impCABS:
3927 case FFEINTRIN_impCDABS:
3928 case FFEINTRIN_impDABS:
3929 case FFEINTRIN_impIABS:
3930 if (ffeinfo_basictype (ffebld_info (arg1))
3931 == FFEINFO_basictypeCOMPLEX)
3933 if (kt == FFEINFO_kindtypeREAL1)
3934 gfrt = FFECOM_gfrtCABS;
3935 else if (kt == FFEINFO_kindtypeREAL2)
3936 gfrt = FFECOM_gfrtCDABS;
3939 return ffecom_1 (ABS_EXPR, tree_type,
3940 convert (tree_type, ffecom_expr (arg1)));
3942 case FFEINTRIN_impACOS:
3943 case FFEINTRIN_impDACOS:
3946 case FFEINTRIN_impAIMAG:
3947 case FFEINTRIN_impDIMAG:
3948 case FFEINTRIN_impIMAGPART:
3949 if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
3950 arg1_type = TREE_TYPE (arg1_type);
3952 arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
3956 ffecom_1 (IMAGPART_EXPR, arg1_type,
3957 ffecom_expr (arg1)));
3959 case FFEINTRIN_impAINT:
3960 case FFEINTRIN_impDINT:
3962 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
3963 return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
3964 #else /* in the meantime, must use floor to avoid range problems with ints */
3965 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3966 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3969 ffecom_3 (COND_EXPR, double_type_node,
3971 (ffecom_2 (GE_EXPR, integer_type_node,
3974 ffecom_float_zero_))),
3975 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3976 build_tree_list (NULL_TREE,
3977 convert (double_type_node,
3980 ffecom_1 (NEGATE_EXPR, double_type_node,
3981 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
3982 build_tree_list (NULL_TREE,
3983 convert (double_type_node,
3984 ffecom_1 (NEGATE_EXPR,
3992 case FFEINTRIN_impANINT:
3993 case FFEINTRIN_impDNINT:
3994 #if 0 /* This way of doing it won't handle real
3995 numbers of large magnitudes. */
3996 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
3997 expr_tree = convert (tree_type,
3998 convert (integer_type_node,
3999 ffecom_3 (COND_EXPR, tree_type,
4004 ffecom_float_zero_)),
4005 ffecom_2 (PLUS_EXPR,
4008 ffecom_float_half_),
4009 ffecom_2 (MINUS_EXPR,
4012 ffecom_float_half_))));
4014 #else /* So we instead call floor. */
4015 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4016 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4019 ffecom_3 (COND_EXPR, double_type_node,
4021 (ffecom_2 (GE_EXPR, integer_type_node,
4024 ffecom_float_zero_))),
4025 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4026 build_tree_list (NULL_TREE,
4027 convert (double_type_node,
4028 ffecom_2 (PLUS_EXPR,
4032 ffecom_float_half_)))),
4034 ffecom_1 (NEGATE_EXPR, double_type_node,
4035 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4036 build_tree_list (NULL_TREE,
4037 convert (double_type_node,
4038 ffecom_2 (MINUS_EXPR,
4041 ffecom_float_half_),
4048 case FFEINTRIN_impASIN:
4049 case FFEINTRIN_impDASIN:
4050 case FFEINTRIN_impATAN:
4051 case FFEINTRIN_impDATAN:
4052 case FFEINTRIN_impATAN2:
4053 case FFEINTRIN_impDATAN2:
4056 case FFEINTRIN_impCHAR:
4057 case FFEINTRIN_impACHAR:
4059 tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4061 tempvar = ffebld_nonter_hook (expr);
4065 tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4067 expr_tree = ffecom_modify (tmv,
4068 ffecom_2 (ARRAY_REF, tmv, tempvar,
4070 convert (tmv, ffecom_expr (arg1)));
4072 expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4075 expr_tree = ffecom_1 (ADDR_EXPR,
4076 build_pointer_type (TREE_TYPE (expr_tree)),
4080 case FFEINTRIN_impCMPLX:
4081 case FFEINTRIN_impDCMPLX:
4084 convert (tree_type, ffecom_expr (arg1));
4086 real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4088 ffecom_2 (COMPLEX_EXPR, tree_type,
4089 convert (real_type, ffecom_expr (arg1)),
4091 ffecom_expr (arg2)));
4093 case FFEINTRIN_impCOMPLEX:
4095 ffecom_2 (COMPLEX_EXPR, tree_type,
4097 ffecom_expr (arg2));
4099 case FFEINTRIN_impCONJG:
4100 case FFEINTRIN_impDCONJG:
4104 real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4105 arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4107 ffecom_2 (COMPLEX_EXPR, tree_type,
4108 ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4109 ffecom_1 (NEGATE_EXPR, real_type,
4110 ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4113 case FFEINTRIN_impCOS:
4114 case FFEINTRIN_impCCOS:
4115 case FFEINTRIN_impCDCOS:
4116 case FFEINTRIN_impDCOS:
4117 if (bt == FFEINFO_basictypeCOMPLEX)
4119 if (kt == FFEINFO_kindtypeREAL1)
4120 gfrt = FFECOM_gfrtCCOS; /* Overlapping result okay. */
4121 else if (kt == FFEINFO_kindtypeREAL2)
4122 gfrt = FFECOM_gfrtCDCOS; /* Overlapping result okay. */
4126 case FFEINTRIN_impCOSH:
4127 case FFEINTRIN_impDCOSH:
4130 case FFEINTRIN_impDBLE:
4131 case FFEINTRIN_impDFLOAT:
4132 case FFEINTRIN_impDREAL:
4133 case FFEINTRIN_impFLOAT:
4134 case FFEINTRIN_impIDINT:
4135 case FFEINTRIN_impIFIX:
4136 case FFEINTRIN_impINT2:
4137 case FFEINTRIN_impINT8:
4138 case FFEINTRIN_impINT:
4139 case FFEINTRIN_impLONG:
4140 case FFEINTRIN_impREAL:
4141 case FFEINTRIN_impSHORT:
4142 case FFEINTRIN_impSNGL:
4143 return convert (tree_type, ffecom_expr (arg1));
4145 case FFEINTRIN_impDIM:
4146 case FFEINTRIN_impDDIM:
4147 case FFEINTRIN_impIDIM:
4148 saved_expr1 = ffecom_save_tree (convert (tree_type,
4149 ffecom_expr (arg1)));
4150 saved_expr2 = ffecom_save_tree (convert (tree_type,
4151 ffecom_expr (arg2)));
4153 ffecom_3 (COND_EXPR, tree_type,
4155 (ffecom_2 (GT_EXPR, integer_type_node,
4158 ffecom_2 (MINUS_EXPR, tree_type,
4161 convert (tree_type, ffecom_float_zero_));
4163 case FFEINTRIN_impDPROD:
4165 ffecom_2 (MULT_EXPR, tree_type,
4166 convert (tree_type, ffecom_expr (arg1)),
4167 convert (tree_type, ffecom_expr (arg2)));
4169 case FFEINTRIN_impEXP:
4170 case FFEINTRIN_impCDEXP:
4171 case FFEINTRIN_impCEXP:
4172 case FFEINTRIN_impDEXP:
4173 if (bt == FFEINFO_basictypeCOMPLEX)
4175 if (kt == FFEINFO_kindtypeREAL1)
4176 gfrt = FFECOM_gfrtCEXP; /* Overlapping result okay. */
4177 else if (kt == FFEINFO_kindtypeREAL2)
4178 gfrt = FFECOM_gfrtCDEXP; /* Overlapping result okay. */
4182 case FFEINTRIN_impICHAR:
4183 case FFEINTRIN_impIACHAR:
4184 #if 0 /* The simple approach. */
4185 ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4187 = ffecom_1 (INDIRECT_REF,
4188 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4191 = ffecom_2 (ARRAY_REF,
4192 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4195 return convert (tree_type, expr_tree);
4196 #else /* The more interesting (and more optimal) approach. */
4197 expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4198 expr_tree = ffecom_3 (COND_EXPR, tree_type,
4201 convert (tree_type, integer_zero_node));
4205 case FFEINTRIN_impINDEX:
4208 case FFEINTRIN_impLEN:
4210 break; /* The simple approach. */
4212 return ffecom_intrinsic_len_ (arg1); /* The more optimal approach. */
4215 case FFEINTRIN_impLGE:
4216 case FFEINTRIN_impLGT:
4217 case FFEINTRIN_impLLE:
4218 case FFEINTRIN_impLLT:
4221 case FFEINTRIN_impLOG:
4222 case FFEINTRIN_impALOG:
4223 case FFEINTRIN_impCDLOG:
4224 case FFEINTRIN_impCLOG:
4225 case FFEINTRIN_impDLOG:
4226 if (bt == FFEINFO_basictypeCOMPLEX)
4228 if (kt == FFEINFO_kindtypeREAL1)
4229 gfrt = FFECOM_gfrtCLOG; /* Overlapping result okay. */
4230 else if (kt == FFEINFO_kindtypeREAL2)
4231 gfrt = FFECOM_gfrtCDLOG; /* Overlapping result okay. */
4235 case FFEINTRIN_impLOG10:
4236 case FFEINTRIN_impALOG10:
4237 case FFEINTRIN_impDLOG10:
4238 if (gfrt != FFECOM_gfrt)
4239 break; /* Already picked one, stick with it. */
4241 if (kt == FFEINFO_kindtypeREAL1)
4242 /* We used to call FFECOM_gfrtALOG10 here. */
4243 gfrt = FFECOM_gfrtL_LOG10;
4244 else if (kt == FFEINFO_kindtypeREAL2)
4245 /* We used to call FFECOM_gfrtDLOG10 here. */
4246 gfrt = FFECOM_gfrtL_LOG10;
4249 case FFEINTRIN_impMAX:
4250 case FFEINTRIN_impAMAX0:
4251 case FFEINTRIN_impAMAX1:
4252 case FFEINTRIN_impDMAX1:
4253 case FFEINTRIN_impMAX0:
4254 case FFEINTRIN_impMAX1:
4255 if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4256 arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4258 arg1_type = tree_type;
4259 expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4260 convert (arg1_type, ffecom_expr (arg1)),
4261 convert (arg1_type, ffecom_expr (arg2)));
4262 for (; list != NULL; list = ffebld_trail (list))
4264 if ((ffebld_head (list) == NULL)
4265 || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4267 expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4270 ffecom_expr (ffebld_head (list))));
4272 return convert (tree_type, expr_tree);
4274 case FFEINTRIN_impMIN:
4275 case FFEINTRIN_impAMIN0:
4276 case FFEINTRIN_impAMIN1:
4277 case FFEINTRIN_impDMIN1:
4278 case FFEINTRIN_impMIN0:
4279 case FFEINTRIN_impMIN1:
4280 if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4281 arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4283 arg1_type = tree_type;
4284 expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4285 convert (arg1_type, ffecom_expr (arg1)),
4286 convert (arg1_type, ffecom_expr (arg2)));
4287 for (; list != NULL; list = ffebld_trail (list))
4289 if ((ffebld_head (list) == NULL)
4290 || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4292 expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4295 ffecom_expr (ffebld_head (list))));
4297 return convert (tree_type, expr_tree);
4299 case FFEINTRIN_impMOD:
4300 case FFEINTRIN_impAMOD:
4301 case FFEINTRIN_impDMOD:
4302 if (bt != FFEINFO_basictypeREAL)
4303 return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4304 convert (tree_type, ffecom_expr (arg1)),
4305 convert (tree_type, ffecom_expr (arg2)));
4307 if (kt == FFEINFO_kindtypeREAL1)
4308 /* We used to call FFECOM_gfrtAMOD here. */
4309 gfrt = FFECOM_gfrtL_FMOD;
4310 else if (kt == FFEINFO_kindtypeREAL2)
4311 /* We used to call FFECOM_gfrtDMOD here. */
4312 gfrt = FFECOM_gfrtL_FMOD;
4315 case FFEINTRIN_impNINT:
4316 case FFEINTRIN_impIDNINT:
4318 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4319 return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4321 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4322 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4324 convert (ffecom_integer_type_node,
4325 ffecom_3 (COND_EXPR, arg1_type,
4327 (ffecom_2 (GE_EXPR, integer_type_node,
4330 ffecom_float_zero_))),
4331 ffecom_2 (PLUS_EXPR, arg1_type,
4334 ffecom_float_half_)),
4335 ffecom_2 (MINUS_EXPR, arg1_type,
4338 ffecom_float_half_))));
4341 case FFEINTRIN_impSIGN:
4342 case FFEINTRIN_impDSIGN:
4343 case FFEINTRIN_impISIGN:
4345 tree arg2_tree = ffecom_expr (arg2);
4349 (ffecom_1 (ABS_EXPR, tree_type,
4351 ffecom_expr (arg1))));
4353 = ffecom_3 (COND_EXPR, tree_type,
4355 (ffecom_2 (GE_EXPR, integer_type_node,
4357 convert (TREE_TYPE (arg2_tree),
4358 integer_zero_node))),
4360 ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4361 /* Make sure SAVE_EXPRs get referenced early enough. */
4363 = ffecom_2 (COMPOUND_EXPR, tree_type,
4364 convert (void_type_node, saved_expr1),
4369 case FFEINTRIN_impSIN:
4370 case FFEINTRIN_impCDSIN:
4371 case FFEINTRIN_impCSIN:
4372 case FFEINTRIN_impDSIN:
4373 if (bt == FFEINFO_basictypeCOMPLEX)
4375 if (kt == FFEINFO_kindtypeREAL1)
4376 gfrt = FFECOM_gfrtCSIN; /* Overlapping result okay. */
4377 else if (kt == FFEINFO_kindtypeREAL2)
4378 gfrt = FFECOM_gfrtCDSIN; /* Overlapping result okay. */
4382 case FFEINTRIN_impSINH:
4383 case FFEINTRIN_impDSINH:
4386 case FFEINTRIN_impSQRT:
4387 case FFEINTRIN_impCDSQRT:
4388 case FFEINTRIN_impCSQRT:
4389 case FFEINTRIN_impDSQRT:
4390 if (bt == FFEINFO_basictypeCOMPLEX)
4392 if (kt == FFEINFO_kindtypeREAL1)
4393 gfrt = FFECOM_gfrtCSQRT; /* Overlapping result okay. */
4394 else if (kt == FFEINFO_kindtypeREAL2)
4395 gfrt = FFECOM_gfrtCDSQRT; /* Overlapping result okay. */
4399 case FFEINTRIN_impTAN:
4400 case FFEINTRIN_impDTAN:
4401 case FFEINTRIN_impTANH:
4402 case FFEINTRIN_impDTANH:
4405 case FFEINTRIN_impREALPART:
4406 if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4407 arg1_type = TREE_TYPE (arg1_type);
4409 arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4413 ffecom_1 (REALPART_EXPR, arg1_type,
4414 ffecom_expr (arg1)));
4416 case FFEINTRIN_impIAND:
4417 case FFEINTRIN_impAND:
4418 return ffecom_2 (BIT_AND_EXPR, tree_type,
4420 ffecom_expr (arg1)),
4422 ffecom_expr (arg2)));
4424 case FFEINTRIN_impIOR:
4425 case FFEINTRIN_impOR:
4426 return ffecom_2 (BIT_IOR_EXPR, tree_type,
4428 ffecom_expr (arg1)),
4430 ffecom_expr (arg2)));
4432 case FFEINTRIN_impIEOR:
4433 case FFEINTRIN_impXOR:
4434 return ffecom_2 (BIT_XOR_EXPR, tree_type,
4436 ffecom_expr (arg1)),
4438 ffecom_expr (arg2)));
4440 case FFEINTRIN_impLSHIFT:
4441 return ffecom_2 (LSHIFT_EXPR, tree_type,
4443 convert (integer_type_node,
4444 ffecom_expr (arg2)));
4446 case FFEINTRIN_impRSHIFT:
4447 return ffecom_2 (RSHIFT_EXPR, tree_type,
4449 convert (integer_type_node,
4450 ffecom_expr (arg2)));
4452 case FFEINTRIN_impNOT:
4453 return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4455 case FFEINTRIN_impBIT_SIZE:
4456 return convert (tree_type, TYPE_SIZE (arg1_type));
4458 case FFEINTRIN_impBTEST:
4460 ffetargetLogical1 target_true;
4461 ffetargetLogical1 target_false;
4465 ffetarget_logical1 (&target_true, TRUE);
4466 ffetarget_logical1 (&target_false, FALSE);
4467 if (target_true == 1)
4468 true_tree = convert (tree_type, integer_one_node);
4470 true_tree = convert (tree_type, build_int_2 (target_true, 0));
4471 if (target_false == 0)
4472 false_tree = convert (tree_type, integer_zero_node);
4474 false_tree = convert (tree_type, build_int_2 (target_false, 0));
4477 ffecom_3 (COND_EXPR, tree_type,
4479 (ffecom_2 (EQ_EXPR, integer_type_node,
4480 ffecom_2 (BIT_AND_EXPR, arg1_type,
4482 ffecom_2 (LSHIFT_EXPR, arg1_type,
4485 convert (integer_type_node,
4486 ffecom_expr (arg2)))),
4488 integer_zero_node))),
4493 case FFEINTRIN_impIBCLR:
4495 ffecom_2 (BIT_AND_EXPR, tree_type,
4497 ffecom_1 (BIT_NOT_EXPR, tree_type,
4498 ffecom_2 (LSHIFT_EXPR, tree_type,
4501 convert (integer_type_node,
4502 ffecom_expr (arg2)))));
4504 case FFEINTRIN_impIBITS:
4506 tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4507 ffecom_expr (arg3)));
4509 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4512 = ffecom_2 (BIT_AND_EXPR, tree_type,
4513 ffecom_2 (RSHIFT_EXPR, tree_type,
4515 convert (integer_type_node,
4516 ffecom_expr (arg2))),
4518 ffecom_2 (RSHIFT_EXPR, uns_type,
4519 ffecom_1 (BIT_NOT_EXPR,
4522 integer_zero_node)),
4523 ffecom_2 (MINUS_EXPR,
4525 TYPE_SIZE (uns_type),
4527 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4529 = ffecom_3 (COND_EXPR, tree_type,
4531 (ffecom_2 (NE_EXPR, integer_type_node,
4533 integer_zero_node)),
4535 convert (tree_type, integer_zero_node));
4540 case FFEINTRIN_impIBSET:
4542 ffecom_2 (BIT_IOR_EXPR, tree_type,
4544 ffecom_2 (LSHIFT_EXPR, tree_type,
4545 convert (tree_type, integer_one_node),
4546 convert (integer_type_node,
4547 ffecom_expr (arg2))));
4549 case FFEINTRIN_impISHFT:
4551 tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4552 tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4553 ffecom_expr (arg2)));
4555 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4558 = ffecom_3 (COND_EXPR, tree_type,
4560 (ffecom_2 (GE_EXPR, integer_type_node,
4562 integer_zero_node)),
4563 ffecom_2 (LSHIFT_EXPR, tree_type,
4567 ffecom_2 (RSHIFT_EXPR, uns_type,
4568 convert (uns_type, arg1_tree),
4569 ffecom_1 (NEGATE_EXPR,
4572 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4574 = ffecom_3 (COND_EXPR, tree_type,
4576 (ffecom_2 (NE_EXPR, integer_type_node,
4578 TYPE_SIZE (uns_type))),
4580 convert (tree_type, integer_zero_node));
4582 /* Make sure SAVE_EXPRs get referenced early enough. */
4584 = ffecom_2 (COMPOUND_EXPR, tree_type,
4585 convert (void_type_node, arg1_tree),
4586 ffecom_2 (COMPOUND_EXPR, tree_type,
4587 convert (void_type_node, arg2_tree),
4592 case FFEINTRIN_impISHFTC:
4594 tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4595 tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4596 ffecom_expr (arg2)));
4597 tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4598 : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4604 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4607 = ffecom_2 (LSHIFT_EXPR, tree_type,
4608 ffecom_1 (BIT_NOT_EXPR, tree_type,
4609 convert (tree_type, integer_zero_node)),
4611 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4613 = ffecom_3 (COND_EXPR, tree_type,
4615 (ffecom_2 (NE_EXPR, integer_type_node,
4617 TYPE_SIZE (uns_type))),
4619 convert (tree_type, integer_zero_node));
4621 mask_arg1 = ffecom_save_tree (mask_arg1);
4623 = ffecom_2 (BIT_AND_EXPR, tree_type,
4625 ffecom_1 (BIT_NOT_EXPR, tree_type,
4627 masked_arg1 = ffecom_save_tree (masked_arg1);
4629 = ffecom_2 (BIT_IOR_EXPR, tree_type,
4631 ffecom_2 (RSHIFT_EXPR, uns_type,
4632 convert (uns_type, masked_arg1),
4633 ffecom_1 (NEGATE_EXPR,
4636 ffecom_2 (LSHIFT_EXPR, tree_type,
4638 ffecom_2 (PLUS_EXPR, integer_type_node,
4642 = ffecom_2 (BIT_IOR_EXPR, tree_type,
4643 ffecom_2 (LSHIFT_EXPR, tree_type,
4647 ffecom_2 (RSHIFT_EXPR, uns_type,
4648 convert (uns_type, masked_arg1),
4649 ffecom_2 (MINUS_EXPR,
4654 = ffecom_3 (COND_EXPR, tree_type,
4656 (ffecom_2 (LT_EXPR, integer_type_node,
4658 integer_zero_node)),
4662 = ffecom_2 (BIT_IOR_EXPR, tree_type,
4663 ffecom_2 (BIT_AND_EXPR, tree_type,
4666 ffecom_2 (BIT_AND_EXPR, tree_type,
4667 ffecom_1 (BIT_NOT_EXPR, tree_type,
4671 = ffecom_3 (COND_EXPR, tree_type,
4673 (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4674 ffecom_2 (EQ_EXPR, integer_type_node,
4679 ffecom_2 (EQ_EXPR, integer_type_node,
4681 integer_zero_node))),
4684 /* Make sure SAVE_EXPRs get referenced early enough. */
4686 = ffecom_2 (COMPOUND_EXPR, tree_type,
4687 convert (void_type_node, arg1_tree),
4688 ffecom_2 (COMPOUND_EXPR, tree_type,
4689 convert (void_type_node, arg2_tree),
4690 ffecom_2 (COMPOUND_EXPR, tree_type,
4691 convert (void_type_node,
4693 ffecom_2 (COMPOUND_EXPR, tree_type,
4694 convert (void_type_node,
4698 = ffecom_2 (COMPOUND_EXPR, tree_type,
4699 convert (void_type_node,
4705 case FFEINTRIN_impLOC:
4707 tree arg1_tree = ffecom_expr (arg1);
4710 = convert (tree_type,
4711 ffecom_1 (ADDR_EXPR,
4712 build_pointer_type (TREE_TYPE (arg1_tree)),
4717 case FFEINTRIN_impMVBITS:
4722 ffebld arg4 = ffebld_head (ffebld_trail (list));
4725 ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4729 tree arg5_plus_arg3;
4731 arg2_tree = convert (integer_type_node,
4732 ffecom_expr (arg2));
4733 arg3_tree = ffecom_save_tree (convert (integer_type_node,
4734 ffecom_expr (arg3)));
4735 arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4736 arg4_type = TREE_TYPE (arg4_tree);
4738 arg1_tree = ffecom_save_tree (convert (arg4_type,
4739 ffecom_expr (arg1)));
4741 arg5_tree = ffecom_save_tree (convert (integer_type_node,
4742 ffecom_expr (arg5)));
4745 = ffecom_2 (LSHIFT_EXPR, arg4_type,
4746 ffecom_2 (BIT_AND_EXPR, arg4_type,
4747 ffecom_2 (RSHIFT_EXPR, arg4_type,
4750 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4751 ffecom_2 (LSHIFT_EXPR, arg4_type,
4752 ffecom_1 (BIT_NOT_EXPR,
4756 integer_zero_node)),
4760 = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4764 = ffecom_2 (LSHIFT_EXPR, arg4_type,
4765 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4767 integer_zero_node)),
4769 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4771 = ffecom_3 (COND_EXPR, arg4_type,
4773 (ffecom_2 (NE_EXPR, integer_type_node,
4775 convert (TREE_TYPE (arg5_plus_arg3),
4776 TYPE_SIZE (arg4_type)))),
4778 convert (arg4_type, integer_zero_node));
4781 = ffecom_2 (BIT_AND_EXPR, arg4_type,
4783 ffecom_2 (BIT_IOR_EXPR, arg4_type,
4785 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4786 ffecom_2 (LSHIFT_EXPR, arg4_type,
4787 ffecom_1 (BIT_NOT_EXPR,
4791 integer_zero_node)),
4794 = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4797 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4799 = ffecom_3 (COND_EXPR, arg4_type,
4801 (ffecom_2 (NE_EXPR, integer_type_node,
4803 convert (TREE_TYPE (arg3_tree),
4804 integer_zero_node))),
4808 = ffecom_3 (COND_EXPR, arg4_type,
4810 (ffecom_2 (NE_EXPR, integer_type_node,
4812 convert (TREE_TYPE (arg3_tree),
4813 TYPE_SIZE (arg4_type)))),
4818 = ffecom_2s (MODIFY_EXPR, void_type_node,
4821 /* Make sure SAVE_EXPRs get referenced early enough. */
4823 = ffecom_2 (COMPOUND_EXPR, void_type_node,
4825 ffecom_2 (COMPOUND_EXPR, void_type_node,
4827 ffecom_2 (COMPOUND_EXPR, void_type_node,
4829 ffecom_2 (COMPOUND_EXPR, void_type_node,
4833 = ffecom_2 (COMPOUND_EXPR, void_type_node,
4840 case FFEINTRIN_impDERF:
4841 case FFEINTRIN_impERF:
4842 case FFEINTRIN_impDERFC:
4843 case FFEINTRIN_impERFC:
4846 case FFEINTRIN_impIARGC:
4847 /* extern int xargc; i__1 = xargc - 1; */
4848 expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4850 convert (TREE_TYPE (ffecom_tree_xargc_),
4854 case FFEINTRIN_impSIGNAL_func:
4855 case FFEINTRIN_impSIGNAL_subr:
4861 arg1_tree = convert (ffecom_f2c_integer_type_node,
4862 ffecom_expr (arg1));
4863 arg1_tree = ffecom_1 (ADDR_EXPR,
4864 build_pointer_type (TREE_TYPE (arg1_tree)),
4867 /* Pass procedure as a pointer to it, anything else by value. */
4868 if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4869 arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4871 arg2_tree = ffecom_ptr_to_expr (arg2);
4872 arg2_tree = convert (TREE_TYPE (null_pointer_node),
4876 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4878 arg3_tree = NULL_TREE;
4880 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4881 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4882 TREE_CHAIN (arg1_tree) = arg2_tree;
4885 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4886 ffecom_gfrt_kindtype (gfrt),
4888 ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4892 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4893 ffebld_nonter_hook (expr));
4895 if (arg3_tree != NULL_TREE)
4897 = ffecom_modify (NULL_TREE, arg3_tree,
4898 convert (TREE_TYPE (arg3_tree),
4903 case FFEINTRIN_impALARM:
4909 arg1_tree = convert (ffecom_f2c_integer_type_node,
4910 ffecom_expr (arg1));
4911 arg1_tree = ffecom_1 (ADDR_EXPR,
4912 build_pointer_type (TREE_TYPE (arg1_tree)),
4915 /* Pass procedure as a pointer to it, anything else by value. */
4916 if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4917 arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4919 arg2_tree = ffecom_ptr_to_expr (arg2);
4920 arg2_tree = convert (TREE_TYPE (null_pointer_node),
4924 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4926 arg3_tree = NULL_TREE;
4928 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4929 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4930 TREE_CHAIN (arg1_tree) = arg2_tree;
4933 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4934 ffecom_gfrt_kindtype (gfrt),
4938 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4939 ffebld_nonter_hook (expr));
4941 if (arg3_tree != NULL_TREE)
4943 = ffecom_modify (NULL_TREE, arg3_tree,
4944 convert (TREE_TYPE (arg3_tree),
4949 case FFEINTRIN_impCHDIR_subr:
4950 case FFEINTRIN_impFDATE_subr:
4951 case FFEINTRIN_impFGET_subr:
4952 case FFEINTRIN_impFPUT_subr:
4953 case FFEINTRIN_impGETCWD_subr:
4954 case FFEINTRIN_impHOSTNM_subr:
4955 case FFEINTRIN_impSYSTEM_subr:
4956 case FFEINTRIN_impUNLINK_subr:
4958 tree arg1_len = integer_zero_node;
4962 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
4965 arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
4967 arg2_tree = NULL_TREE;
4969 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4970 arg1_len = build_tree_list (NULL_TREE, arg1_len);
4971 TREE_CHAIN (arg1_tree) = arg1_len;
4974 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4975 ffecom_gfrt_kindtype (gfrt),
4979 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4980 ffebld_nonter_hook (expr));
4982 if (arg2_tree != NULL_TREE)
4984 = ffecom_modify (NULL_TREE, arg2_tree,
4985 convert (TREE_TYPE (arg2_tree),
4990 case FFEINTRIN_impEXIT:
4994 expr_tree = build_tree_list (NULL_TREE,
4995 ffecom_1 (ADDR_EXPR,
4997 (ffecom_integer_type_node),
4998 integer_zero_node));
5001 ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5002 ffecom_gfrt_kindtype (gfrt),
5006 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5007 ffebld_nonter_hook (expr));
5009 case FFEINTRIN_impFLUSH:
5011 gfrt = FFECOM_gfrtFLUSH;
5013 gfrt = FFECOM_gfrtFLUSH1;
5016 case FFEINTRIN_impCHMOD_subr:
5017 case FFEINTRIN_impLINK_subr:
5018 case FFEINTRIN_impRENAME_subr:
5019 case FFEINTRIN_impSYMLNK_subr:
5021 tree arg1_len = integer_zero_node;
5023 tree arg2_len = integer_zero_node;
5027 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5028 arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5030 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5032 arg3_tree = NULL_TREE;
5034 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5035 arg1_len = build_tree_list (NULL_TREE, arg1_len);
5036 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5037 arg2_len = build_tree_list (NULL_TREE, arg2_len);
5038 TREE_CHAIN (arg1_tree) = arg2_tree;
5039 TREE_CHAIN (arg2_tree) = arg1_len;
5040 TREE_CHAIN (arg1_len) = arg2_len;
5041 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5042 ffecom_gfrt_kindtype (gfrt),
5046 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5047 ffebld_nonter_hook (expr));
5048 if (arg3_tree != NULL_TREE)
5049 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5050 convert (TREE_TYPE (arg3_tree),
5055 case FFEINTRIN_impLSTAT_subr:
5056 case FFEINTRIN_impSTAT_subr:
5058 tree arg1_len = integer_zero_node;
5063 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5065 arg2_tree = ffecom_ptr_to_expr (arg2);
5068 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5070 arg3_tree = NULL_TREE;
5072 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5073 arg1_len = build_tree_list (NULL_TREE, arg1_len);
5074 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5075 TREE_CHAIN (arg1_tree) = arg2_tree;
5076 TREE_CHAIN (arg2_tree) = arg1_len;
5077 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5078 ffecom_gfrt_kindtype (gfrt),
5082 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5083 ffebld_nonter_hook (expr));
5084 if (arg3_tree != NULL_TREE)
5085 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5086 convert (TREE_TYPE (arg3_tree),
5091 case FFEINTRIN_impFGETC_subr:
5092 case FFEINTRIN_impFPUTC_subr:
5096 tree arg2_len = integer_zero_node;
5099 arg1_tree = convert (ffecom_f2c_integer_type_node,
5100 ffecom_expr (arg1));
5101 arg1_tree = ffecom_1 (ADDR_EXPR,
5102 build_pointer_type (TREE_TYPE (arg1_tree)),
5105 arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5107 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5109 arg3_tree = NULL_TREE;
5111 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5112 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5113 arg2_len = build_tree_list (NULL_TREE, arg2_len);
5114 TREE_CHAIN (arg1_tree) = arg2_tree;
5115 TREE_CHAIN (arg2_tree) = arg2_len;
5117 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5118 ffecom_gfrt_kindtype (gfrt),
5122 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5123 ffebld_nonter_hook (expr));
5124 if (arg3_tree != NULL_TREE)
5125 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5126 convert (TREE_TYPE (arg3_tree),
5131 case FFEINTRIN_impFSTAT_subr:
5137 arg1_tree = convert (ffecom_f2c_integer_type_node,
5138 ffecom_expr (arg1));
5139 arg1_tree = ffecom_1 (ADDR_EXPR,
5140 build_pointer_type (TREE_TYPE (arg1_tree)),
5143 arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5144 ffecom_ptr_to_expr (arg2));
5147 arg3_tree = NULL_TREE;
5149 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5151 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5152 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5153 TREE_CHAIN (arg1_tree) = arg2_tree;
5154 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5155 ffecom_gfrt_kindtype (gfrt),
5159 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5160 ffebld_nonter_hook (expr));
5161 if (arg3_tree != NULL_TREE) {
5162 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5163 convert (TREE_TYPE (arg3_tree),
5169 case FFEINTRIN_impKILL_subr:
5175 arg1_tree = convert (ffecom_f2c_integer_type_node,
5176 ffecom_expr (arg1));
5177 arg1_tree = ffecom_1 (ADDR_EXPR,
5178 build_pointer_type (TREE_TYPE (arg1_tree)),
5181 arg2_tree = convert (ffecom_f2c_integer_type_node,
5182 ffecom_expr (arg2));
5183 arg2_tree = ffecom_1 (ADDR_EXPR,
5184 build_pointer_type (TREE_TYPE (arg2_tree)),
5188 arg3_tree = NULL_TREE;
5190 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5192 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5193 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5194 TREE_CHAIN (arg1_tree) = arg2_tree;
5195 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5196 ffecom_gfrt_kindtype (gfrt),
5200 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5201 ffebld_nonter_hook (expr));
5202 if (arg3_tree != NULL_TREE) {
5203 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5204 convert (TREE_TYPE (arg3_tree),
5210 case FFEINTRIN_impCTIME_subr:
5211 case FFEINTRIN_impTTYNAM_subr:
5213 tree arg1_len = integer_zero_node;
5217 arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5219 arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5220 ffecom_f2c_longint_type_node :
5221 ffecom_f2c_integer_type_node),
5222 ffecom_expr (arg1));
5223 arg2_tree = ffecom_1 (ADDR_EXPR,
5224 build_pointer_type (TREE_TYPE (arg2_tree)),
5227 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5228 arg1_len = build_tree_list (NULL_TREE, arg1_len);
5229 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5230 TREE_CHAIN (arg1_len) = arg2_tree;
5231 TREE_CHAIN (arg1_tree) = arg1_len;
5234 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5235 ffecom_gfrt_kindtype (gfrt),
5239 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5240 ffebld_nonter_hook (expr));
5241 TREE_SIDE_EFFECTS (expr_tree) = 1;
5245 case FFEINTRIN_impIRAND:
5246 case FFEINTRIN_impRAND:
5247 /* Arg defaults to 0 (normal random case) */
5252 arg1_tree = ffecom_integer_zero_node;
5254 arg1_tree = ffecom_expr (arg1);
5255 arg1_tree = convert (ffecom_f2c_integer_type_node,
5257 arg1_tree = ffecom_1 (ADDR_EXPR,
5258 build_pointer_type (TREE_TYPE (arg1_tree)),
5260 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5262 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5263 ffecom_gfrt_kindtype (gfrt),
5265 ((codegen_imp == FFEINTRIN_impIRAND) ?
5266 ffecom_f2c_integer_type_node :
5267 ffecom_f2c_real_type_node),
5269 dest_tree, dest, dest_used,
5271 ffebld_nonter_hook (expr));
5275 case FFEINTRIN_impFTELL_subr:
5276 case FFEINTRIN_impUMASK_subr:
5281 arg1_tree = convert (ffecom_f2c_integer_type_node,
5282 ffecom_expr (arg1));
5283 arg1_tree = ffecom_1 (ADDR_EXPR,
5284 build_pointer_type (TREE_TYPE (arg1_tree)),
5288 arg2_tree = NULL_TREE;
5290 arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5292 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5293 ffecom_gfrt_kindtype (gfrt),
5296 build_tree_list (NULL_TREE, arg1_tree),
5297 NULL_TREE, NULL, NULL, NULL_TREE,
5299 ffebld_nonter_hook (expr));
5300 if (arg2_tree != NULL_TREE) {
5301 expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5302 convert (TREE_TYPE (arg2_tree),
5308 case FFEINTRIN_impCPU_TIME:
5309 case FFEINTRIN_impSECOND_subr:
5313 arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5316 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5317 ffecom_gfrt_kindtype (gfrt),
5321 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5322 ffebld_nonter_hook (expr));
5325 = ffecom_modify (NULL_TREE, arg1_tree,
5326 convert (TREE_TYPE (arg1_tree),
5331 case FFEINTRIN_impDTIME_subr:
5332 case FFEINTRIN_impETIME_subr:
5337 result_tree = ffecom_expr_w (NULL_TREE, arg2);
5339 arg1_tree = ffecom_ptr_to_expr (arg1);
5341 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5342 ffecom_gfrt_kindtype (gfrt),
5345 build_tree_list (NULL_TREE, arg1_tree),
5346 NULL_TREE, NULL, NULL, NULL_TREE,
5348 ffebld_nonter_hook (expr));
5349 expr_tree = ffecom_modify (NULL_TREE, result_tree,
5350 convert (TREE_TYPE (result_tree),
5355 /* Straightforward calls of libf2c routines: */
5356 case FFEINTRIN_impABORT:
5357 case FFEINTRIN_impACCESS:
5358 case FFEINTRIN_impBESJ0:
5359 case FFEINTRIN_impBESJ1:
5360 case FFEINTRIN_impBESJN:
5361 case FFEINTRIN_impBESY0:
5362 case FFEINTRIN_impBESY1:
5363 case FFEINTRIN_impBESYN:
5364 case FFEINTRIN_impCHDIR_func:
5365 case FFEINTRIN_impCHMOD_func:
5366 case FFEINTRIN_impDATE:
5367 case FFEINTRIN_impDATE_AND_TIME:
5368 case FFEINTRIN_impDBESJ0:
5369 case FFEINTRIN_impDBESJ1:
5370 case FFEINTRIN_impDBESJN:
5371 case FFEINTRIN_impDBESY0:
5372 case FFEINTRIN_impDBESY1:
5373 case FFEINTRIN_impDBESYN:
5374 case FFEINTRIN_impDTIME_func:
5375 case FFEINTRIN_impETIME_func:
5376 case FFEINTRIN_impFGETC_func:
5377 case FFEINTRIN_impFGET_func:
5378 case FFEINTRIN_impFNUM:
5379 case FFEINTRIN_impFPUTC_func:
5380 case FFEINTRIN_impFPUT_func:
5381 case FFEINTRIN_impFSEEK:
5382 case FFEINTRIN_impFSTAT_func:
5383 case FFEINTRIN_impFTELL_func:
5384 case FFEINTRIN_impGERROR:
5385 case FFEINTRIN_impGETARG:
5386 case FFEINTRIN_impGETCWD_func:
5387 case FFEINTRIN_impGETENV:
5388 case FFEINTRIN_impGETGID:
5389 case FFEINTRIN_impGETLOG:
5390 case FFEINTRIN_impGETPID:
5391 case FFEINTRIN_impGETUID:
5392 case FFEINTRIN_impGMTIME:
5393 case FFEINTRIN_impHOSTNM_func:
5394 case FFEINTRIN_impIDATE_unix:
5395 case FFEINTRIN_impIDATE_vxt:
5396 case FFEINTRIN_impIERRNO:
5397 case FFEINTRIN_impISATTY:
5398 case FFEINTRIN_impITIME:
5399 case FFEINTRIN_impKILL_func:
5400 case FFEINTRIN_impLINK_func:
5401 case FFEINTRIN_impLNBLNK:
5402 case FFEINTRIN_impLSTAT_func:
5403 case FFEINTRIN_impLTIME:
5404 case FFEINTRIN_impMCLOCK8:
5405 case FFEINTRIN_impMCLOCK:
5406 case FFEINTRIN_impPERROR:
5407 case FFEINTRIN_impRENAME_func:
5408 case FFEINTRIN_impSECNDS:
5409 case FFEINTRIN_impSECOND_func:
5410 case FFEINTRIN_impSLEEP:
5411 case FFEINTRIN_impSRAND:
5412 case FFEINTRIN_impSTAT_func:
5413 case FFEINTRIN_impSYMLNK_func:
5414 case FFEINTRIN_impSYSTEM_CLOCK:
5415 case FFEINTRIN_impSYSTEM_func:
5416 case FFEINTRIN_impTIME8:
5417 case FFEINTRIN_impTIME_unix:
5418 case FFEINTRIN_impTIME_vxt:
5419 case FFEINTRIN_impUMASK_func:
5420 case FFEINTRIN_impUNLINK_func:
5423 case FFEINTRIN_impCTIME_func: /* CHARACTER functions not handled here. */
5424 case FFEINTRIN_impFDATE_func: /* CHARACTER functions not handled here. */
5425 case FFEINTRIN_impTTYNAM_func: /* CHARACTER functions not handled here. */
5426 case FFEINTRIN_impNONE:
5427 case FFEINTRIN_imp: /* Hush up gcc warning. */
5428 fprintf (stderr, "No %s implementation.\n",
5429 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5430 assert ("unimplemented intrinsic" == NULL);
5431 return error_mark_node;
5434 assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5436 expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5437 ffebld_right (expr));
5439 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5440 (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5442 expr_tree, dest_tree, dest, dest_used,
5444 ffebld_nonter_hook (expr));
5446 /* See bottom of this file for f2c transforms used to determine
5447 many of the above implementations. The info seems to confuse
5448 Emacs's C mode indentation, which is why it's been moved to
5449 the bottom of this source file. */
5453 /* For power (exponentiation) where right-hand operand is type INTEGER,
5454 generate in-line code to do it the fast way (which, if the operand
5455 is a constant, might just mean a series of multiplies). */
5457 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5459 ffecom_expr_power_integer_ (ffebld expr)
5461 tree l = ffecom_expr (ffebld_left (expr));
5462 tree r = ffecom_expr (ffebld_right (expr));
5463 tree ltype = TREE_TYPE (l);
5464 tree rtype = TREE_TYPE (r);
5465 tree result = NULL_TREE;
5467 if (l == error_mark_node
5468 || r == error_mark_node)
5469 return error_mark_node;
5471 if (TREE_CODE (r) == INTEGER_CST)
5473 int sgn = tree_int_cst_sgn (r);
5476 return convert (ltype, integer_one_node);
5478 if ((TREE_CODE (ltype) == INTEGER_TYPE)
5481 /* Reciprocal of integer is either 0, -1, or 1, so after
5482 calculating that (which we leave to the back end to do
5483 or not do optimally), don't bother with any multiplying. */
5485 result = ffecom_tree_divide_ (ltype,
5486 convert (ltype, integer_one_node),
5488 NULL_TREE, NULL, NULL, NULL_TREE);
5489 r = ffecom_1 (NEGATE_EXPR,
5492 if ((TREE_INT_CST_LOW (r) & 1) == 0)
5493 result = ffecom_1 (ABS_EXPR, rtype,
5497 /* Generate appropriate series of multiplies, preceded
5498 by divide if the exponent is negative. */
5504 l = ffecom_tree_divide_ (ltype,
5505 convert (ltype, integer_one_node),
5507 NULL_TREE, NULL, NULL,
5508 ffebld_nonter_hook (expr));
5509 r = ffecom_1 (NEGATE_EXPR, rtype, r);
5510 assert (TREE_CODE (r) == INTEGER_CST);
5512 if (tree_int_cst_sgn (r) < 0)
5513 { /* The "most negative" number. */
5514 r = ffecom_1 (NEGATE_EXPR, rtype,
5515 ffecom_2 (RSHIFT_EXPR, rtype,
5519 l = ffecom_2 (MULT_EXPR, ltype,
5527 if (TREE_INT_CST_LOW (r) & 1)
5529 if (result == NULL_TREE)
5532 result = ffecom_2 (MULT_EXPR, ltype,
5537 r = ffecom_2 (RSHIFT_EXPR, rtype,
5540 if (integer_zerop (r))
5542 assert (TREE_CODE (r) == INTEGER_CST);
5545 l = ffecom_2 (MULT_EXPR, ltype,
5552 /* Though rhs isn't a constant, in-line code cannot be expanded
5553 while transforming dummies
5554 because the back end cannot be easily convinced to generate
5555 stores (MODIFY_EXPR), handle temporaries, and so on before
5556 all the appropriate rtx's have been generated for things like
5557 dummy args referenced in rhs -- which doesn't happen until
5558 store_parm_decls() is called (expand_function_start, I believe,
5559 does the actual rtx-stuffing of PARM_DECLs).
5561 So, in this case, let the caller generate the call to the
5562 run-time-library function to evaluate the power for us. */
5564 if (ffecom_transform_only_dummies_)
5567 /* Right-hand operand not a constant, expand in-line code to figure
5568 out how to do the multiplies, &c.
5570 The returned expression is expressed this way in GNU C, where l and
5573 ({ typeof (r) rtmp = r;
5574 typeof (l) ltmp = l;
5581 if ((basetypeof (l) == basetypeof (int))
5584 result = ((typeof (l)) 1) / ltmp;
5585 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5591 if ((basetypeof (l) != basetypeof (int))
5594 ltmp = ((typeof (l)) 1) / ltmp;
5598 rtmp = -(rtmp >> 1);
5606 if ((rtmp >>= 1) == 0)
5615 Note that some of the above is compile-time collapsable, such as
5616 the first part of the if statements that checks the base type of
5617 l against int. The if statements are phrased that way to suggest
5618 an easy way to generate the if/else constructs here, knowing that
5619 the back end should (and probably does) eliminate the resulting
5620 dead code (either the int case or the non-int case), something
5621 it couldn't do without the redundant phrasing, requiring explicit
5622 dead-code elimination here, which would be kind of difficult to
5629 tree basetypeof_l_is_int;
5634 = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5636 se = expand_start_stmt_expr ();
5638 ffecom_start_compstmt ();
5641 rtmp = ffecom_make_tempvar ("power_r", rtype,
5642 FFETARGET_charactersizeNONE, -1);
5643 ltmp = ffecom_make_tempvar ("power_l", ltype,
5644 FFETARGET_charactersizeNONE, -1);
5645 result = ffecom_make_tempvar ("power_res", ltype,
5646 FFETARGET_charactersizeNONE, -1);
5647 if (TREE_CODE (ltype) == COMPLEX_TYPE
5648 || TREE_CODE (ltype) == RECORD_TYPE)
5649 divide = ffecom_make_tempvar ("power_div", ltype,
5650 FFETARGET_charactersizeNONE, -1);
5657 hook = ffebld_nonter_hook (expr);
5659 assert (TREE_CODE (hook) == TREE_VEC);
5660 assert (TREE_VEC_LENGTH (hook) == 4);
5661 rtmp = TREE_VEC_ELT (hook, 0);
5662 ltmp = TREE_VEC_ELT (hook, 1);
5663 result = TREE_VEC_ELT (hook, 2);
5664 divide = TREE_VEC_ELT (hook, 3);
5665 if (TREE_CODE (ltype) == COMPLEX_TYPE
5666 || TREE_CODE (ltype) == RECORD_TYPE)
5673 expand_expr_stmt (ffecom_modify (void_type_node,
5676 expand_expr_stmt (ffecom_modify (void_type_node,
5679 expand_start_cond (ffecom_truth_value
5680 (ffecom_2 (EQ_EXPR, integer_type_node,
5682 convert (rtype, integer_zero_node))),
5684 expand_expr_stmt (ffecom_modify (void_type_node,
5686 convert (ltype, integer_one_node)));
5687 expand_start_else ();
5688 if (! integer_zerop (basetypeof_l_is_int))
5690 expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5693 integer_zero_node)),
5695 expand_expr_stmt (ffecom_modify (void_type_node,
5699 convert (ltype, integer_one_node),
5701 NULL_TREE, NULL, NULL,
5703 expand_start_cond (ffecom_truth_value
5704 (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5705 ffecom_2 (LT_EXPR, integer_type_node,
5708 integer_zero_node)),
5709 ffecom_2 (EQ_EXPR, integer_type_node,
5710 ffecom_2 (BIT_AND_EXPR,
5712 ffecom_1 (NEGATE_EXPR,
5718 integer_zero_node)))),
5720 expand_expr_stmt (ffecom_modify (void_type_node,
5722 ffecom_1 (NEGATE_EXPR,
5726 expand_start_else ();
5728 expand_expr_stmt (ffecom_modify (void_type_node,
5730 convert (ltype, integer_one_node)));
5731 expand_start_cond (ffecom_truth_value
5732 (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5733 ffecom_truth_value_invert
5734 (basetypeof_l_is_int),
5735 ffecom_2 (LT_EXPR, integer_type_node,
5738 integer_zero_node)))),
5740 expand_expr_stmt (ffecom_modify (void_type_node,
5744 convert (ltype, integer_one_node),
5746 NULL_TREE, NULL, NULL,
5748 expand_expr_stmt (ffecom_modify (void_type_node,
5750 ffecom_1 (NEGATE_EXPR, rtype,
5752 expand_start_cond (ffecom_truth_value
5753 (ffecom_2 (LT_EXPR, integer_type_node,
5755 convert (rtype, integer_zero_node))),
5757 expand_expr_stmt (ffecom_modify (void_type_node,
5759 ffecom_1 (NEGATE_EXPR, rtype,
5760 ffecom_2 (RSHIFT_EXPR,
5763 integer_one_node))));
5764 expand_expr_stmt (ffecom_modify (void_type_node,
5766 ffecom_2 (MULT_EXPR, ltype,
5771 expand_start_loop (1);
5772 expand_start_cond (ffecom_truth_value
5773 (ffecom_2 (BIT_AND_EXPR, rtype,
5775 convert (rtype, integer_one_node))),
5777 expand_expr_stmt (ffecom_modify (void_type_node,
5779 ffecom_2 (MULT_EXPR, ltype,
5783 expand_exit_loop_if_false (NULL,
5785 (ffecom_modify (rtype,
5787 ffecom_2 (RSHIFT_EXPR,
5790 integer_one_node))));
5791 expand_expr_stmt (ffecom_modify (void_type_node,
5793 ffecom_2 (MULT_EXPR, ltype,
5798 if (!integer_zerop (basetypeof_l_is_int))
5800 expand_expr_stmt (result);
5802 t = ffecom_end_compstmt ();
5804 result = expand_end_stmt_expr (se);
5806 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5808 if (TREE_CODE (t) == BLOCK)
5810 /* Make a BIND_EXPR for the BLOCK already made. */
5811 result = build (BIND_EXPR, TREE_TYPE (result),
5812 NULL_TREE, result, t);
5813 /* Remove the block from the tree at this point.
5814 It gets put back at the proper place
5815 when the BIND_EXPR is expanded. */
5826 /* ffecom_expr_transform_ -- Transform symbols in expr
5828 ffebld expr; // FFE expression.
5829 ffecom_expr_transform_ (expr);
5831 Recursive descent on expr while transforming any untransformed SYMTERs. */
5833 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5835 ffecom_expr_transform_ (ffebld expr)
5840 tail_recurse: /* :::::::::::::::::::: */
5845 switch (ffebld_op (expr))
5847 case FFEBLD_opSYMTER:
5848 s = ffebld_symter (expr);
5849 t = ffesymbol_hook (s).decl_tree;
5850 if ((t == NULL_TREE)
5851 && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5852 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5853 && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5855 s = ffecom_sym_transform_ (s);
5856 t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy,
5859 break; /* Ok if (t == NULL) here. */
5862 ffecom_expr_transform_ (ffebld_head (expr));
5863 expr = ffebld_trail (expr);
5864 goto tail_recurse; /* :::::::::::::::::::: */
5870 switch (ffebld_arity (expr))
5873 ffecom_expr_transform_ (ffebld_left (expr));
5874 expr = ffebld_right (expr);
5875 goto tail_recurse; /* :::::::::::::::::::: */
5878 expr = ffebld_left (expr);
5879 goto tail_recurse; /* :::::::::::::::::::: */
5889 /* Make a type based on info in live f2c.h file. */
5891 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5893 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5897 case FFECOM_f2ccodeCHAR:
5898 *type = make_signed_type (CHAR_TYPE_SIZE);
5901 case FFECOM_f2ccodeSHORT:
5902 *type = make_signed_type (SHORT_TYPE_SIZE);
5905 case FFECOM_f2ccodeINT:
5906 *type = make_signed_type (INT_TYPE_SIZE);
5909 case FFECOM_f2ccodeLONG:
5910 *type = make_signed_type (LONG_TYPE_SIZE);
5913 case FFECOM_f2ccodeLONGLONG:
5914 *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5917 case FFECOM_f2ccodeCHARPTR:
5918 *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5919 ? signed_char_type_node
5920 : unsigned_char_type_node);
5923 case FFECOM_f2ccodeFLOAT:
5924 *type = make_node (REAL_TYPE);
5925 TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5926 layout_type (*type);
5929 case FFECOM_f2ccodeDOUBLE:
5930 *type = make_node (REAL_TYPE);
5931 TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5932 layout_type (*type);
5935 case FFECOM_f2ccodeLONGDOUBLE:
5936 *type = make_node (REAL_TYPE);
5937 TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
5938 layout_type (*type);
5941 case FFECOM_f2ccodeTWOREALS:
5942 *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
5945 case FFECOM_f2ccodeTWODOUBLEREALS:
5946 *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
5950 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
5951 *type = error_mark_node;
5955 pushdecl (build_decl (TYPE_DECL,
5956 ffecom_get_invented_identifier ("__g77_f2c_%s", name),
5961 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5962 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5966 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
5972 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
5973 if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
5974 && compare_tree_int (TYPE_SIZE (t), size) == 0)
5976 assert (code != -1);
5977 ffecom_f2c_typecode_[bt][j] = code;
5983 /* Finish up globals after doing all program units in file
5985 Need to handle only uninitialized COMMON areas. */
5987 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5989 ffecom_finish_global_ (ffeglobal global)
5995 if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
5998 if (ffeglobal_common_init (global))
6001 cbt = ffeglobal_hook (global);
6002 if ((cbt == NULL_TREE)
6003 || !ffeglobal_common_have_size (global))
6004 return global; /* No need to make common, never ref'd. */
6006 DECL_EXTERNAL (cbt) = 0;
6008 /* Give the array a size now. */
6010 size = build_int_2 ((ffeglobal_common_size (global)
6011 + ffeglobal_common_pad (global)) - 1,
6014 cbtype = TREE_TYPE (cbt);
6015 TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6018 if (!TREE_TYPE (size))
6019 TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6020 layout_type (cbtype);
6022 cbt = start_decl (cbt, FALSE);
6023 assert (cbt == ffeglobal_hook (global));
6025 finish_decl (cbt, NULL_TREE, FALSE);
6031 /* Finish up any untransformed symbols. */
6033 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6035 ffecom_finish_symbol_transform_ (ffesymbol s)
6037 if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6040 /* It's easy to know to transform an untransformed symbol, to make sure
6041 we put out debugging info for it. But COMMON variables, unlike
6042 EQUIVALENCE ones, aren't given declarations in addition to the
6043 tree expressions that specify offsets, because COMMON variables
6044 can be referenced in the outer scope where only dummy arguments
6045 (PARM_DECLs) should really be seen. To be safe, just don't do any
6046 VAR_DECLs for COMMON variables when we transform them for real
6047 use, and therefore we do all the VAR_DECL creating here. */
6049 if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6051 if (ffesymbol_kind (s) != FFEINFO_kindNONE
6052 || (ffesymbol_where (s) != FFEINFO_whereNONE
6053 && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6054 && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6055 /* Not transformed, and not CHARACTER*(*), and not a dummy
6056 argument, which can happen only if the entry point names
6057 it "rides in on" are all invalidated for other reasons. */
6058 s = ffecom_sym_transform_ (s);
6061 if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6062 && (ffesymbol_hook (s).decl_tree != error_mark_node))
6064 /* This isn't working, at least for dbxout. The .s file looks
6065 okay to me (burley), but in gdb 4.9 at least, the variables
6066 appear to reside somewhere outside of the common area, so
6067 it doesn't make sense to mislead anyone by generating the info
6068 on those variables until this is fixed. NOTE: Same problem
6069 with EQUIVALENCE, sadly...see similar #if later. */
6070 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6071 ffesymbol_storage (s));
6078 /* Append underscore(s) to name before calling get_identifier. "us"
6079 is nonzero if the name already contains an underscore and thus
6080 needs two underscores appended. */
6082 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6084 ffecom_get_appended_identifier_ (char us, const char *name)
6090 newname = xmalloc ((i = strlen (name)) + 1
6091 + ffe_is_underscoring ()
6093 memcpy (newname, name, i);
6095 newname[i + us] = '_';
6096 newname[i + 1 + us] = '\0';
6097 id = get_identifier (newname);
6105 /* Decide whether to append underscore to name before calling
6108 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6110 ffecom_get_external_identifier_ (ffesymbol s)
6113 const char *name = ffesymbol_text (s);
6115 /* If name is a built-in name, just return it as is. */
6117 if (!ffe_is_underscoring ()
6118 || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6119 #if FFETARGET_isENFORCED_MAIN_NAME
6120 || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6122 || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6124 || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6125 return get_identifier (name);
6127 us = ffe_is_second_underscore ()
6128 ? (strchr (name, '_') != NULL)
6131 return ffecom_get_appended_identifier_ (us, name);
6135 /* Decide whether to append underscore to internal name before calling
6138 This is for non-external, top-function-context names only. Transform
6139 identifier so it doesn't conflict with the transformed result
6140 of using a _different_ external name. E.g. if "CALL FOO" is
6141 transformed into "FOO_();", then the variable in "FOO_ = 3"
6142 must be transformed into something that does not conflict, since
6143 these two things should be independent.
6145 The transformation is as follows. If the name does not contain
6146 an underscore, there is no possible conflict, so just return.
6147 If the name does contain an underscore, then transform it just
6148 like we transform an external identifier. */
6150 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6152 ffecom_get_identifier_ (const char *name)
6154 /* If name does not contain an underscore, just return it as is. */
6156 if (!ffe_is_underscoring ()
6157 || (strchr (name, '_') == NULL))
6158 return get_identifier (name);
6160 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6165 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6168 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6169 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6170 ffesymbol_kindtype(s));
6172 Call after setting up containing function and getting trees for all
6175 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6177 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6179 ffebld expr = ffesymbol_sfexpr (s);
6183 bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6184 static bool recurse = FALSE;
6185 int old_lineno = lineno;
6186 const char *old_input_filename = input_filename;
6188 ffecom_nested_entry_ = s;
6190 /* For now, we don't have a handy pointer to where the sfunc is actually
6191 defined, though that should be easy to add to an ffesymbol. (The
6192 token/where info available might well point to the place where the type
6193 of the sfunc is declared, especially if that precedes the place where
6194 the sfunc itself is defined, which is typically the case.) We should
6195 put out a null pointer rather than point somewhere wrong, but I want to
6196 see how it works at this point. */
6198 input_filename = ffesymbol_where_filename (s);
6199 lineno = ffesymbol_where_filelinenum (s);
6201 /* Pretransform the expression so any newly discovered things belong to the
6202 outer program unit, not to the statement function. */
6204 ffecom_expr_transform_ (expr);
6206 /* Make sure no recursive invocation of this fn (a specific case of failing
6207 to pretransform an sfunc's expression, i.e. where its expression
6208 references another untransformed sfunc) happens. */
6213 push_f_function_context ();
6216 type = void_type_node;
6219 type = ffecom_tree_type[bt][kt];
6220 if (type == NULL_TREE)
6221 type = integer_type_node; /* _sym_exec_transition reports
6225 start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6226 build_function_type (type, NULL_TREE),
6227 1, /* nested/inline */
6228 0); /* TREE_PUBLIC */
6230 /* We don't worry about COMPLEX return values here, because this is
6231 entirely internal to our code, and gcc has the ability to return COMPLEX
6232 directly as a value. */
6235 { /* Prepend arg for where result goes. */
6238 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6240 result = ffecom_get_invented_identifier ("__g77_%s", "result");
6242 ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */
6244 type = build_pointer_type (type);
6245 result = build_decl (PARM_DECL, result, type);
6247 push_parm_decl (result);
6250 result = NULL_TREE; /* Not ref'd if !charfunc. */
6252 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6254 store_parm_decls (0);
6256 ffecom_start_compstmt ();
6262 ffetargetCharacterSize sz = ffesymbol_size (s);
6265 result_length = build_int_2 (sz, 0);
6266 TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6268 ffecom_prepare_let_char_ (sz, expr);
6270 ffecom_prepare_end ();
6272 ffecom_let_char_ (result, result_length, sz, expr);
6273 expand_null_return ();
6277 ffecom_prepare_expr (expr);
6279 ffecom_prepare_end ();
6281 expand_return (ffecom_modify (NULL_TREE,
6282 DECL_RESULT (current_function_decl),
6283 ffecom_expr (expr)));
6287 ffecom_end_compstmt ();
6289 func = current_function_decl;
6290 finish_function (1);
6292 pop_f_function_context ();
6296 lineno = old_lineno;
6297 input_filename = old_input_filename;
6299 ffecom_nested_entry_ = NULL;
6306 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6308 ffecom_gfrt_args_ (ffecomGfrt ix)
6310 return ffecom_gfrt_argstring_[ix];
6314 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6316 ffecom_gfrt_tree_ (ffecomGfrt ix)
6318 if (ffecom_gfrt_[ix] == NULL_TREE)
6319 ffecom_make_gfrt_ (ix);
6321 return ffecom_1 (ADDR_EXPR,
6322 build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6327 /* Return initialize-to-zero expression for this VAR_DECL. */
6329 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6330 /* A somewhat evil way to prevent the garbage collector
6331 from collecting 'tree' structures. */
6332 #define NUM_TRACKED_CHUNK 63
6333 static struct tree_ggc_tracker
6335 struct tree_ggc_tracker *next;
6336 tree trees[NUM_TRACKED_CHUNK];
6337 } *tracker_head = NULL;
6340 mark_tracker_head (void *arg)
6342 struct tree_ggc_tracker *head;
6345 for (head = * (struct tree_ggc_tracker **) arg;
6350 for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6351 ggc_mark_tree (head->trees[i]);
6356 ffecom_save_tree_forever (tree t)
6359 if (tracker_head != NULL)
6360 for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6361 if (tracker_head->trees[i] == NULL)
6363 tracker_head->trees[i] = t;
6368 /* Need to allocate a new block. */
6369 struct tree_ggc_tracker *old_head = tracker_head;
6371 tracker_head = ggc_alloc (sizeof (*tracker_head));
6372 tracker_head->next = old_head;
6373 tracker_head->trees[0] = t;
6374 for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6375 tracker_head->trees[i] = NULL;
6380 ffecom_init_zero_ (tree decl)
6383 int incremental = TREE_STATIC (decl);
6384 tree type = TREE_TYPE (decl);
6388 make_decl_rtl (decl, NULL);
6389 assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6392 if ((TREE_CODE (type) != ARRAY_TYPE)
6393 && (TREE_CODE (type) != RECORD_TYPE)
6394 && (TREE_CODE (type) != UNION_TYPE)
6396 init = convert (type, integer_zero_node);
6397 else if (!incremental)
6399 init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6400 TREE_CONSTANT (init) = 1;
6401 TREE_STATIC (init) = 1;
6405 assemble_zeros (int_size_in_bytes (type));
6406 init = error_mark_node;
6413 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6415 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6421 switch (ffebld_op (arg))
6423 case FFEBLD_opCONTER: /* For F90, check 0-length. */
6424 if (ffetarget_length_character1
6425 (ffebld_constant_character1
6426 (ffebld_conter (arg))) == 0)
6428 *maybe_tree = integer_zero_node;
6429 return convert (tree_type, integer_zero_node);
6432 *maybe_tree = integer_one_node;
6433 expr_tree = build_int_2 (*ffetarget_text_character1
6434 (ffebld_constant_character1
6435 (ffebld_conter (arg))),
6437 TREE_TYPE (expr_tree) = tree_type;
6440 case FFEBLD_opSYMTER:
6441 case FFEBLD_opARRAYREF:
6442 case FFEBLD_opFUNCREF:
6443 case FFEBLD_opSUBSTR:
6444 ffecom_char_args_ (&expr_tree, &length_tree, arg);
6446 if ((expr_tree == error_mark_node)
6447 || (length_tree == error_mark_node))
6449 *maybe_tree = error_mark_node;
6450 return error_mark_node;
6453 if (integer_zerop (length_tree))
6455 *maybe_tree = integer_zero_node;
6456 return convert (tree_type, integer_zero_node);
6460 = ffecom_1 (INDIRECT_REF,
6461 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6464 = ffecom_2 (ARRAY_REF,
6465 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6468 expr_tree = convert (tree_type, expr_tree);
6470 if (TREE_CODE (length_tree) == INTEGER_CST)
6471 *maybe_tree = integer_one_node;
6472 else /* Must check length at run time. */
6474 = ffecom_truth_value
6475 (ffecom_2 (GT_EXPR, integer_type_node,
6477 ffecom_f2c_ftnlen_zero_node));
6480 case FFEBLD_opPAREN:
6481 case FFEBLD_opCONVERT:
6482 if (ffeinfo_size (ffebld_info (arg)) == 0)
6484 *maybe_tree = integer_zero_node;
6485 return convert (tree_type, integer_zero_node);
6487 return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6490 case FFEBLD_opCONCATENATE:
6497 expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6499 expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6501 *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6504 expr_tree = ffecom_3 (COND_EXPR, tree_type,
6512 assert ("bad op in ICHAR" == NULL);
6513 return error_mark_node;
6518 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6522 length_arg = ffecom_intrinsic_len_ (expr);
6524 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6525 subexpressions by constructing the appropriate tree for the
6526 length-of-character-text argument in a calling sequence. */
6528 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6530 ffecom_intrinsic_len_ (ffebld expr)
6532 ffetargetCharacter1 val;
6535 switch (ffebld_op (expr))
6537 case FFEBLD_opCONTER:
6538 val = ffebld_constant_character1 (ffebld_conter (expr));
6539 length = build_int_2 (ffetarget_length_character1 (val), 0);
6540 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6543 case FFEBLD_opSYMTER:
6545 ffesymbol s = ffebld_symter (expr);
6548 item = ffesymbol_hook (s).decl_tree;
6549 if (item == NULL_TREE)
6551 s = ffecom_sym_transform_ (s);
6552 item = ffesymbol_hook (s).decl_tree;
6554 if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6556 if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6557 length = ffesymbol_hook (s).length_tree;
6560 length = build_int_2 (ffesymbol_size (s), 0);
6561 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6564 else if (item == error_mark_node)
6565 length = error_mark_node;
6566 else /* FFEINFO_kindFUNCTION: */
6571 case FFEBLD_opARRAYREF:
6572 length = ffecom_intrinsic_len_ (ffebld_left (expr));
6575 case FFEBLD_opSUBSTR:
6579 ffebld thing = ffebld_right (expr);
6583 assert (ffebld_op (thing) == FFEBLD_opITEM);
6584 start = ffebld_head (thing);
6585 thing = ffebld_trail (thing);
6586 assert (ffebld_trail (thing) == NULL);
6587 end = ffebld_head (thing);
6589 length = ffecom_intrinsic_len_ (ffebld_left (expr));
6591 if (length == error_mark_node)
6600 length = convert (ffecom_f2c_ftnlen_type_node,
6606 start_tree = convert (ffecom_f2c_ftnlen_type_node,
6607 ffecom_expr (start));
6609 if (start_tree == error_mark_node)
6611 length = error_mark_node;
6617 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6618 ffecom_f2c_ftnlen_one_node,
6619 ffecom_2 (MINUS_EXPR,
6620 ffecom_f2c_ftnlen_type_node,
6626 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6629 if (end_tree == error_mark_node)
6631 length = error_mark_node;
6635 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6636 ffecom_f2c_ftnlen_one_node,
6637 ffecom_2 (MINUS_EXPR,
6638 ffecom_f2c_ftnlen_type_node,
6639 end_tree, start_tree));
6645 case FFEBLD_opCONCATENATE:
6647 = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6648 ffecom_intrinsic_len_ (ffebld_left (expr)),
6649 ffecom_intrinsic_len_ (ffebld_right (expr)));
6652 case FFEBLD_opFUNCREF:
6653 case FFEBLD_opCONVERT:
6654 length = build_int_2 (ffebld_size (expr), 0);
6655 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6659 assert ("bad op for single char arg expr" == NULL);
6660 length = ffecom_f2c_ftnlen_zero_node;
6664 assert (length != NULL_TREE);
6670 /* Handle CHARACTER assignments.
6672 Generates code to do the assignment. Used by ordinary assignment
6673 statement handler ffecom_let_stmt and by statement-function
6674 handler to generate code for a statement function. */
6676 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6678 ffecom_let_char_ (tree dest_tree, tree dest_length,
6679 ffetargetCharacterSize dest_size, ffebld source)
6681 ffecomConcatList_ catlist;
6686 if ((dest_tree == error_mark_node)
6687 || (dest_length == error_mark_node))
6690 assert (dest_tree != NULL_TREE);
6691 assert (dest_length != NULL_TREE);
6693 /* Source might be an opCONVERT, which just means it is a different size
6694 than the destination. Since the underlying implementation here handles
6695 that (directly or via the s_copy or s_cat run-time-library functions),
6696 we don't need the "convenience" of an opCONVERT that tells us to
6697 truncate or blank-pad, particularly since the resulting implementation
6698 would probably be slower than otherwise. */
6700 while (ffebld_op (source) == FFEBLD_opCONVERT)
6701 source = ffebld_left (source);
6703 catlist = ffecom_concat_list_new_ (source, dest_size);
6704 switch (ffecom_concat_list_count_ (catlist))
6706 case 0: /* Shouldn't happen, but in case it does... */
6707 ffecom_concat_list_kill_ (catlist);
6708 source_tree = null_pointer_node;
6709 source_length = ffecom_f2c_ftnlen_zero_node;
6710 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6711 TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6712 TREE_CHAIN (TREE_CHAIN (expr_tree))
6713 = build_tree_list (NULL_TREE, dest_length);
6714 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6715 = build_tree_list (NULL_TREE, source_length);
6717 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6718 TREE_SIDE_EFFECTS (expr_tree) = 1;
6720 expand_expr_stmt (expr_tree);
6724 case 1: /* The (fairly) easy case. */
6725 ffecom_char_args_ (&source_tree, &source_length,
6726 ffecom_concat_list_expr_ (catlist, 0));
6727 ffecom_concat_list_kill_ (catlist);
6728 assert (source_tree != NULL_TREE);
6729 assert (source_length != NULL_TREE);
6731 if ((source_tree == error_mark_node)
6732 || (source_length == error_mark_node))
6738 = ffecom_1 (INDIRECT_REF,
6739 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6743 = ffecom_2 (ARRAY_REF,
6744 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6749 = ffecom_1 (INDIRECT_REF,
6750 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6754 = ffecom_2 (ARRAY_REF,
6755 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6760 expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6762 expand_expr_stmt (expr_tree);
6767 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6768 TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6769 TREE_CHAIN (TREE_CHAIN (expr_tree))
6770 = build_tree_list (NULL_TREE, dest_length);
6771 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6772 = build_tree_list (NULL_TREE, source_length);
6774 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6775 TREE_SIDE_EFFECTS (expr_tree) = 1;
6777 expand_expr_stmt (expr_tree);
6781 default: /* Must actually concatenate things. */
6785 /* Heavy-duty concatenation. */
6788 int count = ffecom_concat_list_count_ (catlist);
6800 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6801 FFETARGET_charactersizeNONE, count, TRUE);
6802 item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6803 FFETARGET_charactersizeNONE,
6809 hook = ffebld_nonter_hook (source);
6811 assert (TREE_CODE (hook) == TREE_VEC);
6812 assert (TREE_VEC_LENGTH (hook) == 2);
6813 length_array = lengths = TREE_VEC_ELT (hook, 0);
6814 item_array = items = TREE_VEC_ELT (hook, 1);
6818 for (i = 0; i < count; ++i)
6820 ffecom_char_args_ (&citem, &clength,
6821 ffecom_concat_list_expr_ (catlist, i));
6822 if ((citem == error_mark_node)
6823 || (clength == error_mark_node))
6825 ffecom_concat_list_kill_ (catlist);
6830 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6831 ffecom_modify (void_type_node,
6832 ffecom_2 (ARRAY_REF,
6833 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6835 build_int_2 (i, 0)),
6839 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6840 ffecom_modify (void_type_node,
6841 ffecom_2 (ARRAY_REF,
6842 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6844 build_int_2 (i, 0)),
6849 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6850 TREE_CHAIN (expr_tree)
6851 = build_tree_list (NULL_TREE,
6852 ffecom_1 (ADDR_EXPR,
6853 build_pointer_type (TREE_TYPE (items)),
6855 TREE_CHAIN (TREE_CHAIN (expr_tree))
6856 = build_tree_list (NULL_TREE,
6857 ffecom_1 (ADDR_EXPR,
6858 build_pointer_type (TREE_TYPE (lengths)),
6860 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6863 ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6864 convert (ffecom_f2c_ftnlen_type_node,
6865 build_int_2 (count, 0))));
6866 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6867 = build_tree_list (NULL_TREE, dest_length);
6869 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6870 TREE_SIDE_EFFECTS (expr_tree) = 1;
6872 expand_expr_stmt (expr_tree);
6875 ffecom_concat_list_kill_ (catlist);
6879 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6882 ffecom_make_gfrt_(ix);
6884 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6885 for the indicated run-time routine (ix). */
6887 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6889 ffecom_make_gfrt_ (ffecomGfrt ix)
6894 switch (ffecom_gfrt_type_[ix])
6896 case FFECOM_rttypeVOID_:
6897 ttype = void_type_node;
6900 case FFECOM_rttypeVOIDSTAR_:
6901 ttype = TREE_TYPE (null_pointer_node); /* `void *'. */
6904 case FFECOM_rttypeFTNINT_:
6905 ttype = ffecom_f2c_ftnint_type_node;
6908 case FFECOM_rttypeINTEGER_:
6909 ttype = ffecom_f2c_integer_type_node;
6912 case FFECOM_rttypeLONGINT_:
6913 ttype = ffecom_f2c_longint_type_node;
6916 case FFECOM_rttypeLOGICAL_:
6917 ttype = ffecom_f2c_logical_type_node;
6920 case FFECOM_rttypeREAL_F2C_:
6921 ttype = double_type_node;
6924 case FFECOM_rttypeREAL_GNU_:
6925 ttype = float_type_node;
6928 case FFECOM_rttypeCOMPLEX_F2C_:
6929 ttype = void_type_node;
6932 case FFECOM_rttypeCOMPLEX_GNU_:
6933 ttype = ffecom_f2c_complex_type_node;
6936 case FFECOM_rttypeDOUBLE_:
6937 ttype = double_type_node;
6940 case FFECOM_rttypeDOUBLEREAL_:
6941 ttype = ffecom_f2c_doublereal_type_node;
6944 case FFECOM_rttypeDBLCMPLX_F2C_:
6945 ttype = void_type_node;
6948 case FFECOM_rttypeDBLCMPLX_GNU_:
6949 ttype = ffecom_f2c_doublecomplex_type_node;
6952 case FFECOM_rttypeCHARACTER_:
6953 ttype = void_type_node;
6958 assert ("bad rttype" == NULL);
6962 ttype = build_function_type (ttype, NULL_TREE);
6963 t = build_decl (FUNCTION_DECL,
6964 get_identifier (ffecom_gfrt_name_[ix]),
6966 DECL_EXTERNAL (t) = 1;
6967 TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
6968 TREE_PUBLIC (t) = 1;
6969 TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
6971 /* Sanity check: A function that's const cannot be volatile. */
6973 assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
6975 /* Sanity check: A function that's const cannot return complex. */
6977 assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
6979 t = start_decl (t, TRUE);
6981 finish_decl (t, NULL_TREE, TRUE);
6983 ffecom_gfrt_[ix] = t;
6987 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
6989 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6991 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
6993 ffesymbol s = ffestorag_symbol (st);
6995 if (ffesymbol_namelisted (s))
6996 ffecom_member_namelisted_ = TRUE;
7000 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
7001 the member so debugger will see it. Otherwise nobody should be
7002 referencing the member. */
7004 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7006 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7014 || ((mt = ffestorag_hook (mst)) == NULL)
7015 || (mt == error_mark_node))
7019 || ((s = ffestorag_symbol (st)) == NULL))
7022 type = ffecom_type_localvar_ (s,
7023 ffesymbol_basictype (s),
7024 ffesymbol_kindtype (s));
7025 if (type == error_mark_node)
7028 t = build_decl (VAR_DECL,
7029 ffecom_get_identifier_ (ffesymbol_text (s)),
7032 TREE_STATIC (t) = TREE_STATIC (mt);
7033 DECL_INITIAL (t) = NULL_TREE;
7034 TREE_ASM_WRITTEN (t) = 1;
7038 gen_rtx (MEM, TYPE_MODE (type),
7039 plus_constant (XEXP (DECL_RTL (mt), 0),
7040 ffestorag_modulo (mst)
7041 + ffestorag_offset (st)
7042 - ffestorag_offset (mst))));
7044 t = start_decl (t, FALSE);
7046 finish_decl (t, NULL_TREE, FALSE);
7050 /* Prepare source expression for assignment into a destination perhaps known
7051 to be of a specific size. */
7054 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7056 ffecomConcatList_ catlist;
7061 tree tempvar = NULL_TREE;
7063 while (ffebld_op (source) == FFEBLD_opCONVERT)
7064 source = ffebld_left (source);
7066 catlist = ffecom_concat_list_new_ (source, dest_size);
7067 count = ffecom_concat_list_count_ (catlist);
7072 = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7073 FFETARGET_charactersizeNONE, count);
7075 = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7076 FFETARGET_charactersizeNONE, count);
7078 tempvar = make_tree_vec (2);
7079 TREE_VEC_ELT (tempvar, 0) = ltmp;
7080 TREE_VEC_ELT (tempvar, 1) = itmp;
7083 for (i = 0; i < count; ++i)
7084 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7086 ffecom_concat_list_kill_ (catlist);
7090 ffebld_nonter_set_hook (source, tempvar);
7091 current_binding_level->prep_state = 1;
7095 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7097 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7098 (which generates their trees) and then their trees get push_parm_decl'd.
7100 The second arg is TRUE if the dummies are for a statement function, in
7101 which case lengths are not pushed for character arguments (since they are
7102 always known by both the caller and the callee, though the code allows
7103 for someday permitting CHAR*(*) stmtfunc dummies). */
7105 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7107 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7114 ffecom_transform_only_dummies_ = TRUE;
7116 /* First push the parms corresponding to actual dummy "contents". */
7118 for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7120 dummy = ffebld_head (dumlist);
7121 switch (ffebld_op (dummy))
7125 continue; /* Forget alternate returns. */
7130 assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7131 s = ffebld_symter (dummy);
7132 parm = ffesymbol_hook (s).decl_tree;
7133 if (parm == NULL_TREE)
7135 s = ffecom_sym_transform_ (s);
7136 parm = ffesymbol_hook (s).decl_tree;
7137 assert (parm != NULL_TREE);
7139 if (parm != error_mark_node)
7140 push_parm_decl (parm);
7143 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7145 for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7147 dummy = ffebld_head (dumlist);
7148 switch (ffebld_op (dummy))
7152 continue; /* Forget alternate returns, they mean
7158 s = ffebld_symter (dummy);
7159 if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7160 continue; /* Only looking for CHARACTER arguments. */
7161 if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7162 continue; /* Stmtfunc arg with known size needs no
7164 if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7165 continue; /* Only looking for variables and arrays. */
7166 parm = ffesymbol_hook (s).length_tree;
7167 assert (parm != NULL_TREE);
7168 if (parm != error_mark_node)
7169 push_parm_decl (parm);
7172 ffecom_transform_only_dummies_ = FALSE;
7176 /* ffecom_start_progunit_ -- Beginning of program unit
7178 Does GNU back end stuff necessary to teach it about the start of its
7179 equivalent of a Fortran program unit. */
7181 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7183 ffecom_start_progunit_ ()
7185 ffesymbol fn = ffecom_primary_entry_;
7187 tree id; /* Identifier (name) of function. */
7188 tree type; /* Type of function. */
7189 tree result; /* Result of function. */
7190 ffeinfoBasictype bt;
7194 ffeglobalType egt = FFEGLOBAL_type;
7197 bool altentries = (ffecom_num_entrypoints_ != 0);
7200 && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7201 && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7202 bool main_program = FALSE;
7203 int old_lineno = lineno;
7204 const char *old_input_filename = input_filename;
7206 assert (fn != NULL);
7207 assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7209 input_filename = ffesymbol_where_filename (fn);
7210 lineno = ffesymbol_where_filelinenum (fn);
7212 switch (ffecom_primary_entry_kind_)
7214 case FFEINFO_kindPROGRAM:
7215 main_program = TRUE;
7216 gt = FFEGLOBAL_typeMAIN;
7217 bt = FFEINFO_basictypeNONE;
7218 kt = FFEINFO_kindtypeNONE;
7219 type = ffecom_tree_fun_type_void;
7224 case FFEINFO_kindBLOCKDATA:
7225 gt = FFEGLOBAL_typeBDATA;
7226 bt = FFEINFO_basictypeNONE;
7227 kt = FFEINFO_kindtypeNONE;
7228 type = ffecom_tree_fun_type_void;
7233 case FFEINFO_kindFUNCTION:
7234 gt = FFEGLOBAL_typeFUNC;
7235 egt = FFEGLOBAL_typeEXT;
7236 bt = ffesymbol_basictype (fn);
7237 kt = ffesymbol_kindtype (fn);
7238 if (bt == FFEINFO_basictypeNONE)
7240 ffeimplic_establish_symbol (fn);
7241 if (ffesymbol_funcresult (fn) != NULL)
7242 ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7243 bt = ffesymbol_basictype (fn);
7244 kt = ffesymbol_kindtype (fn);
7248 charfunc = cmplxfunc = FALSE;
7249 else if (bt == FFEINFO_basictypeCHARACTER)
7250 charfunc = TRUE, cmplxfunc = FALSE;
7251 else if ((bt == FFEINFO_basictypeCOMPLEX)
7252 && ffesymbol_is_f2c (fn)
7254 charfunc = FALSE, cmplxfunc = TRUE;
7256 charfunc = cmplxfunc = FALSE;
7258 if (multi || charfunc)
7259 type = ffecom_tree_fun_type_void;
7260 else if (ffesymbol_is_f2c (fn) && !altentries)
7261 type = ffecom_tree_fun_type[bt][kt];
7263 type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7265 if ((type == NULL_TREE)
7266 || (TREE_TYPE (type) == NULL_TREE))
7267 type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
7270 case FFEINFO_kindSUBROUTINE:
7271 gt = FFEGLOBAL_typeSUBR;
7272 egt = FFEGLOBAL_typeEXT;
7273 bt = FFEINFO_basictypeNONE;
7274 kt = FFEINFO_kindtypeNONE;
7275 if (ffecom_is_altreturning_)
7276 type = ffecom_tree_subr_type;
7278 type = ffecom_tree_fun_type_void;
7284 assert ("say what??" == NULL);
7286 case FFEINFO_kindANY:
7287 gt = FFEGLOBAL_typeANY;
7288 bt = FFEINFO_basictypeNONE;
7289 kt = FFEINFO_kindtypeNONE;
7290 type = error_mark_node;
7298 id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7299 ffesymbol_text (fn));
7301 #if FFETARGET_isENFORCED_MAIN
7302 else if (main_program)
7303 id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7306 id = ffecom_get_external_identifier_ (fn);
7310 0, /* nested/inline */
7311 !altentries); /* TREE_PUBLIC */
7313 TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */
7316 && ((g = ffesymbol_global (fn)) != NULL)
7317 && ((ffeglobal_type (g) == gt)
7318 || (ffeglobal_type (g) == egt)))
7320 ffeglobal_set_hook (g, current_function_decl);
7323 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7324 exec-transitioning needs current_function_decl to be filled in. So we
7325 do these things in two phases. */
7328 { /* 1st arg identifies which entrypoint. */
7329 ffecom_which_entrypoint_decl_
7330 = build_decl (PARM_DECL,
7331 ffecom_get_invented_identifier ("__g77_%s",
7332 "which_entrypoint"),
7334 push_parm_decl (ffecom_which_entrypoint_decl_);
7340 { /* Arg for result (return value). */
7345 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7347 type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7349 type = ffecom_multi_type_node_;
7351 result = ffecom_get_invented_identifier ("__g77_%s", "result");
7353 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7356 length = ffecom_char_enhance_arg_ (&type, fn);
7358 length = NULL_TREE; /* Not ref'd if !charfunc. */
7360 type = build_pointer_type (type);
7361 result = build_decl (PARM_DECL, result, type);
7363 push_parm_decl (result);
7365 ffecom_multi_retval_ = result;
7367 ffecom_func_result_ = result;
7371 push_parm_decl (length);
7372 ffecom_func_length_ = length;
7376 if (ffecom_primary_entry_is_proc_)
7379 arglist = ffecom_master_arglist_;
7381 arglist = ffesymbol_dummyargs (fn);
7382 ffecom_push_dummy_decls_ (arglist, FALSE);
7385 if (TREE_CODE (current_function_decl) != ERROR_MARK)
7386 store_parm_decls (main_program ? 1 : 0);
7388 ffecom_start_compstmt ();
7389 /* Disallow temp vars at this level. */
7390 current_binding_level->prep_state = 2;
7392 lineno = old_lineno;
7393 input_filename = old_input_filename;
7395 /* This handles any symbols still untransformed, in case -g specified.
7396 This used to be done in ffecom_finish_progunit, but it turns out to
7397 be necessary to do it here so that statement functions are
7398 expanded before code. But don't bother for BLOCK DATA. */
7400 if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7401 ffesymbol_drive (ffecom_finish_symbol_transform_);
7405 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7408 ffecom_sym_transform_(s);
7410 The ffesymbol_hook info for s is updated with appropriate backend info
7413 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7415 ffecom_sym_transform_ (ffesymbol s)
7417 tree t; /* Transformed thingy. */
7418 tree tlen; /* Length if CHAR*(*). */
7419 bool addr; /* Is t the address of the thingy? */
7420 ffeinfoBasictype bt;
7423 int old_lineno = lineno;
7424 const char *old_input_filename = input_filename;
7426 /* Must ensure special ASSIGN variables are declared at top of outermost
7427 block, else they'll end up in the innermost block when their first
7428 ASSIGN is seen, which leaves them out of scope when they're the
7429 subject of a GOTO or I/O statement.
7431 We make this variable even if -fugly-assign. Just let it go unused,
7432 in case it turns out there are cases where we really want to use this
7433 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7435 if (! ffecom_transform_only_dummies_
7436 && ffesymbol_assigned (s)
7437 && ! ffesymbol_hook (s).assign_tree)
7438 s = ffecom_sym_transform_assign_ (s);
7440 if (ffesymbol_sfdummyparent (s) == NULL)
7442 input_filename = ffesymbol_where_filename (s);
7443 lineno = ffesymbol_where_filelinenum (s);
7447 ffesymbol sf = ffesymbol_sfdummyparent (s);
7449 input_filename = ffesymbol_where_filename (sf);
7450 lineno = ffesymbol_where_filelinenum (sf);
7453 bt = ffeinfo_basictype (ffebld_info (s));
7454 kt = ffeinfo_kindtype (ffebld_info (s));
7460 switch (ffesymbol_kind (s))
7462 case FFEINFO_kindNONE:
7463 switch (ffesymbol_where (s))
7465 case FFEINFO_whereDUMMY: /* Subroutine or function. */
7466 assert (ffecom_transform_only_dummies_);
7468 /* Before 0.4, this could be ENTITY/DUMMY, but see
7469 ffestu_sym_end_transition -- no longer true (in particular, if
7470 it could be an ENTITY, it _will_ be made one, so that
7471 possibility won't come through here). So we never make length
7472 arg for CHARACTER type. */
7474 t = build_decl (PARM_DECL,
7475 ffecom_get_identifier_ (ffesymbol_text (s)),
7476 ffecom_tree_ptr_to_subr_type);
7478 DECL_ARTIFICIAL (t) = 1;
7483 case FFEINFO_whereGLOBAL: /* Subroutine or function. */
7484 assert (!ffecom_transform_only_dummies_);
7486 if (((g = ffesymbol_global (s)) != NULL)
7487 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7488 || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7489 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7490 && (ffeglobal_hook (g) != NULL_TREE)
7491 && ffe_is_globals ())
7493 t = ffeglobal_hook (g);
7497 t = build_decl (FUNCTION_DECL,
7498 ffecom_get_external_identifier_ (s),
7499 ffecom_tree_subr_type); /* Assume subr. */
7500 DECL_EXTERNAL (t) = 1;
7501 TREE_PUBLIC (t) = 1;
7503 t = start_decl (t, FALSE);
7504 finish_decl (t, NULL_TREE, FALSE);
7507 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7508 || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7509 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7510 ffeglobal_set_hook (g, t);
7512 ffecom_save_tree_forever (t);
7517 assert ("NONE where unexpected" == NULL);
7519 case FFEINFO_whereANY:
7524 case FFEINFO_kindENTITY:
7525 switch (ffeinfo_where (ffesymbol_info (s)))
7528 case FFEINFO_whereCONSTANT:
7529 /* ~~Debugging info needed? */
7530 assert (!ffecom_transform_only_dummies_);
7531 t = error_mark_node; /* Shouldn't ever see this in expr. */
7534 case FFEINFO_whereLOCAL:
7535 assert (!ffecom_transform_only_dummies_);
7538 ffestorag st = ffesymbol_storage (s);
7542 && (ffestorag_size (st) == 0))
7544 t = error_mark_node;
7548 type = ffecom_type_localvar_ (s, bt, kt);
7550 if (type == error_mark_node)
7552 t = error_mark_node;
7557 && (ffestorag_parent (st) != NULL))
7558 { /* Child of EQUIVALENCE parent. */
7561 ffetargetOffset offset;
7563 est = ffestorag_parent (st);
7564 ffecom_transform_equiv_ (est);
7566 et = ffestorag_hook (est);
7567 assert (et != NULL_TREE);
7569 if (! TREE_STATIC (et))
7570 put_var_into_stack (et);
7572 offset = ffestorag_modulo (est)
7573 + ffestorag_offset (ffesymbol_storage (s))
7574 - ffestorag_offset (est);
7576 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7578 /* (t_type *) (((char *) &et) + offset) */
7580 t = convert (string_type_node, /* (char *) */
7581 ffecom_1 (ADDR_EXPR,
7582 build_pointer_type (TREE_TYPE (et)),
7584 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7586 build_int_2 (offset, 0));
7587 t = convert (build_pointer_type (type),
7589 TREE_CONSTANT (t) = staticp (et);
7596 bool init = ffesymbol_is_init (s);
7598 t = build_decl (VAR_DECL,
7599 ffecom_get_identifier_ (ffesymbol_text (s)),
7603 || ffesymbol_namelisted (s)
7604 #ifdef FFECOM_sizeMAXSTACKITEM
7606 && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7608 || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7609 && (ffecom_primary_entry_kind_
7610 != FFEINFO_kindBLOCKDATA)
7611 && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7612 TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7614 TREE_STATIC (t) = 0; /* No need to make static. */
7616 if (init || ffe_is_init_local_zero ())
7617 DECL_INITIAL (t) = error_mark_node;
7619 /* Keep -Wunused from complaining about var if it
7620 is used as sfunc arg or DATA implied-DO. */
7621 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7622 DECL_IN_SYSTEM_HEADER (t) = 1;
7624 t = start_decl (t, FALSE);
7628 if (ffesymbol_init (s) != NULL)
7629 initexpr = ffecom_expr (ffesymbol_init (s));
7631 initexpr = ffecom_init_zero_ (t);
7633 else if (ffe_is_init_local_zero ())
7634 initexpr = ffecom_init_zero_ (t);
7636 initexpr = NULL_TREE; /* Not ref'd if !init. */
7638 finish_decl (t, initexpr, FALSE);
7640 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7642 assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7643 assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7644 ffestorag_size (st)));
7650 case FFEINFO_whereRESULT:
7651 assert (!ffecom_transform_only_dummies_);
7653 if (bt == FFEINFO_basictypeCHARACTER)
7654 { /* Result is already in list of dummies, use
7656 t = ffecom_func_result_;
7657 tlen = ffecom_func_length_;
7661 if ((ffecom_num_entrypoints_ == 0)
7662 && (bt == FFEINFO_basictypeCOMPLEX)
7663 && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7664 { /* Result is already in list of dummies, use
7666 t = ffecom_func_result_;
7670 if (ffecom_func_result_ != NULL_TREE)
7672 t = ffecom_func_result_;
7675 if ((ffecom_num_entrypoints_ != 0)
7676 && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7678 assert (ffecom_multi_retval_ != NULL_TREE);
7679 t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7680 ffecom_multi_retval_);
7681 t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7682 t, ffecom_multi_fields_[bt][kt]);
7687 t = build_decl (VAR_DECL,
7688 ffecom_get_identifier_ (ffesymbol_text (s)),
7689 ffecom_tree_type[bt][kt]);
7690 TREE_STATIC (t) = 0; /* Put result on stack. */
7691 t = start_decl (t, FALSE);
7692 finish_decl (t, NULL_TREE, FALSE);
7694 ffecom_func_result_ = t;
7698 case FFEINFO_whereDUMMY:
7706 bool adjustable = FALSE; /* Conditionally adjustable? */
7708 type = ffecom_tree_type[bt][kt];
7709 if (ffesymbol_sfdummyparent (s) != NULL)
7711 if (current_function_decl == ffecom_outer_function_decl_)
7712 { /* Exec transition before sfunc
7713 context; get it later. */
7716 t = ffecom_get_identifier_ (ffesymbol_text
7717 (ffesymbol_sfdummyparent (s)));
7720 t = ffecom_get_identifier_ (ffesymbol_text (s));
7722 assert (ffecom_transform_only_dummies_);
7724 old_sizes = get_pending_sizes ();
7725 put_pending_sizes (old_sizes);
7727 if (bt == FFEINFO_basictypeCHARACTER)
7728 tlen = ffecom_char_enhance_arg_ (&type, s);
7729 type = ffecom_check_size_overflow_ (s, type, TRUE);
7731 for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7733 if (type == error_mark_node)
7736 dim = ffebld_head (dl);
7737 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7738 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7739 low = ffecom_integer_one_node;
7741 low = ffecom_expr (ffebld_left (dim));
7742 assert (ffebld_right (dim) != NULL);
7743 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7744 || ffecom_doing_entry_)
7746 /* Used to just do high=low. But for ffecom_tree_
7747 canonize_ref_, it probably is important to correctly
7748 assess the size. E.g. given COMPLEX C(*),CFUNC and
7749 C(2)=CFUNC(C), overlap can happen, while it can't
7750 for, say, C(1)=CFUNC(C(2)). */
7751 /* Even more recently used to set to INT_MAX, but that
7752 broke when some overflow checking went into the back
7753 end. Now we just leave the upper bound unspecified. */
7757 high = ffecom_expr (ffebld_right (dim));
7759 /* Determine whether array is conditionally adjustable,
7760 to decide whether back-end magic is needed.
7762 Normally the front end uses the back-end function
7763 variable_size to wrap SAVE_EXPR's around expressions
7764 affecting the size/shape of an array so that the
7765 size/shape info doesn't change during execution
7766 of the compiled code even though variables and
7767 functions referenced in those expressions might.
7769 variable_size also makes sure those saved expressions
7770 get evaluated immediately upon entry to the
7771 compiled procedure -- the front end normally doesn't
7772 have to worry about that.
7774 However, there is a problem with this that affects
7775 g77's implementation of entry points, and that is
7776 that it is _not_ true that each invocation of the
7777 compiled procedure is permitted to evaluate
7778 array size/shape info -- because it is possible
7779 that, for some invocations, that info is invalid (in
7780 which case it is "promised" -- i.e. a violation of
7781 the Fortran standard -- that the compiled code
7782 won't reference the array or its size/shape
7783 during that particular invocation).
7785 To phrase this in C terms, consider this gcc function:
7787 void foo (int *n, float (*a)[*n])
7789 // a is "pointer to array ...", fyi.
7792 Suppose that, for some invocations, it is permitted
7793 for a caller of foo to do this:
7797 Now the _written_ code for foo can take such a call
7798 into account by either testing explicitly for whether
7799 (a == NULL) || (n == NULL) -- presumably it is
7800 not permitted to reference *a in various fashions
7801 if (n == NULL) I suppose -- or it can avoid it by
7802 looking at other info (other arguments, static/global
7805 However, this won't work in gcc 2.5.8 because it'll
7806 automatically emit the code to save the "*n"
7807 expression, which'll yield a NULL dereference for
7808 the "foo (NULL, NULL)" call, something the code
7809 for foo cannot prevent.
7811 g77 definitely needs to avoid executing such
7812 code anytime the pointer to the adjustable array
7813 is NULL, because even if its bounds expressions
7814 don't have any references to possible "absent"
7815 variables like "*n" -- say all variable references
7816 are to COMMON variables, i.e. global (though in C,
7817 local static could actually make sense) -- the
7818 expressions could yield other run-time problems
7819 for allowably "dead" values in those variables.
7821 For example, let's consider a more complicated
7827 void foo (float (*a)[i/j])
7832 The above is (essentially) quite valid for Fortran
7833 but, again, for a call like "foo (NULL);", it is
7834 permitted for i and j to be undefined when the
7835 call is made. If j happened to be zero, for
7836 example, emitting the code to evaluate "i/j"
7837 could result in a run-time error.
7839 Offhand, though I don't have my F77 or F90
7840 standards handy, it might even be valid for a
7841 bounds expression to contain a function reference,
7842 in which case I doubt it is permitted for an
7843 implementation to invoke that function in the
7844 Fortran case involved here (invocation of an
7845 alternate ENTRY point that doesn't have the adjustable
7846 array as one of its arguments).
7848 So, the code that the compiler would normally emit
7849 to preevaluate the size/shape info for an
7850 adjustable array _must not_ be executed at run time
7851 in certain cases. Specifically, for Fortran,
7852 the case is when the pointer to the adjustable
7853 array == NULL. (For gnu-ish C, it might be nice
7854 for the source code itself to specify an expression
7855 that, if TRUE, inhibits execution of the code. Or
7856 reverse the sense for elegance.)
7858 (Note that g77 could use a different test than NULL,
7859 actually, since it happens to always pass an
7860 integer to the called function that specifies which
7861 entry point is being invoked. Hmm, this might
7862 solve the next problem.)
7864 One way a user could, I suppose, write "foo" so
7865 it works is to insert COND_EXPR's for the
7866 size/shape info so the dangerous stuff isn't
7867 actually done, as in:
7869 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7874 The next problem is that the front end needs to
7875 be able to tell the back end about the array's
7876 decl _before_ it tells it about the conditional
7877 expression to inhibit evaluation of size/shape info,
7880 To solve this, the front end needs to be able
7881 to give the back end the expression to inhibit
7882 generation of the preevaluation code _after_
7883 it makes the decl for the adjustable array.
7885 Until then, the above example using the COND_EXPR
7886 doesn't pass muster with gcc because the "(a == NULL)"
7887 part has a reference to "a", which is still
7888 undefined at that point.
7890 g77 will therefore use a different mechanism in the
7894 && ((TREE_CODE (low) != INTEGER_CST)
7895 || (high && TREE_CODE (high) != INTEGER_CST)))
7898 #if 0 /* Old approach -- see below. */
7899 if (TREE_CODE (low) != INTEGER_CST)
7900 low = ffecom_3 (COND_EXPR, integer_type_node,
7901 ffecom_adjarray_passed_ (s),
7903 ffecom_integer_zero_node);
7905 if (high && TREE_CODE (high) != INTEGER_CST)
7906 high = ffecom_3 (COND_EXPR, integer_type_node,
7907 ffecom_adjarray_passed_ (s),
7909 ffecom_integer_zero_node);
7912 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7913 probably. Fixes 950302-1.f. */
7915 if (TREE_CODE (low) != INTEGER_CST)
7916 low = variable_size (low);
7918 /* ~~~Similarly, this fixes dumb0.f. The C front end
7919 does this, which is why dumb0.c would work. */
7921 if (high && TREE_CODE (high) != INTEGER_CST)
7922 high = variable_size (high);
7927 build_range_type (ffecom_integer_type_node,
7929 type = ffecom_check_size_overflow_ (s, type, TRUE);
7932 if (type == error_mark_node)
7934 t = error_mark_node;
7938 if ((ffesymbol_sfdummyparent (s) == NULL)
7939 || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
7941 type = build_pointer_type (type);
7945 t = build_decl (PARM_DECL, t, type);
7947 DECL_ARTIFICIAL (t) = 1;
7950 /* If this arg is present in every entry point's list of
7951 dummy args, then we're done. */
7953 if (ffesymbol_numentries (s)
7954 == (ffecom_num_entrypoints_ + 1))
7959 /* If variable_size in stor-layout has been called during
7960 the above, then get_pending_sizes should have the
7961 yet-to-be-evaluated saved expressions pending.
7962 Make the whole lot of them get emitted, conditionally
7963 on whether the array decl ("t" above) is not NULL. */
7966 tree sizes = get_pending_sizes ();
7971 tem = TREE_CHAIN (tem))
7973 tree temv = TREE_VALUE (tem);
7979 = ffecom_2 (COMPOUND_EXPR,
7988 = ffecom_3 (COND_EXPR,
7995 convert (TREE_TYPE (sizes),
7996 integer_zero_node));
7997 sizes = ffecom_save_tree (sizes);
8000 = tree_cons (NULL_TREE, sizes, tem);
8004 put_pending_sizes (sizes);
8010 && (ffesymbol_numentries (s)
8011 != ffecom_num_entrypoints_ + 1))
8013 = ffecom_2 (NE_EXPR, integer_type_node,
8019 && (ffesymbol_numentries (s)
8020 != ffecom_num_entrypoints_ + 1))
8022 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8023 ffebad_here (0, ffesymbol_where_line (s),
8024 ffesymbol_where_column (s));
8025 ffebad_string (ffesymbol_text (s));
8034 case FFEINFO_whereCOMMON:
8039 ffestorag st = ffesymbol_storage (s);
8042 cs = ffesymbol_common (s); /* The COMMON area itself. */
8043 if (st != NULL) /* Else not laid out. */
8045 ffecom_transform_common_ (cs);
8046 st = ffesymbol_storage (s);
8049 type = ffecom_type_localvar_ (s, bt, kt);
8051 cg = ffesymbol_global (cs); /* The global COMMON info. */
8053 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8056 ct = ffeglobal_hook (cg); /* The common area's tree. */
8058 if ((ct == NULL_TREE)
8060 || (type == error_mark_node))
8061 t = error_mark_node;
8064 ffetargetOffset offset;
8067 cst = ffestorag_parent (st);
8068 assert (cst == ffesymbol_storage (cs));
8070 offset = ffestorag_modulo (cst)
8071 + ffestorag_offset (st)
8072 - ffestorag_offset (cst);
8074 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8076 /* (t_type *) (((char *) &ct) + offset) */
8078 t = convert (string_type_node, /* (char *) */
8079 ffecom_1 (ADDR_EXPR,
8080 build_pointer_type (TREE_TYPE (ct)),
8082 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8084 build_int_2 (offset, 0));
8085 t = convert (build_pointer_type (type),
8087 TREE_CONSTANT (t) = 1;
8094 case FFEINFO_whereIMMEDIATE:
8095 case FFEINFO_whereGLOBAL:
8096 case FFEINFO_whereFLEETING:
8097 case FFEINFO_whereFLEETING_CADDR:
8098 case FFEINFO_whereFLEETING_IADDR:
8099 case FFEINFO_whereINTRINSIC:
8100 case FFEINFO_whereCONSTANT_SUBOBJECT:
8102 assert ("ENTITY where unheard of" == NULL);
8104 case FFEINFO_whereANY:
8105 t = error_mark_node;
8110 case FFEINFO_kindFUNCTION:
8111 switch (ffeinfo_where (ffesymbol_info (s)))
8113 case FFEINFO_whereLOCAL: /* Me. */
8114 assert (!ffecom_transform_only_dummies_);
8115 t = current_function_decl;
8118 case FFEINFO_whereGLOBAL:
8119 assert (!ffecom_transform_only_dummies_);
8121 if (((g = ffesymbol_global (s)) != NULL)
8122 && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8123 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8124 && (ffeglobal_hook (g) != NULL_TREE)
8125 && ffe_is_globals ())
8127 t = ffeglobal_hook (g);
8131 if (ffesymbol_is_f2c (s)
8132 && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8133 t = ffecom_tree_fun_type[bt][kt];
8135 t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8137 t = build_decl (FUNCTION_DECL,
8138 ffecom_get_external_identifier_ (s),
8140 DECL_EXTERNAL (t) = 1;
8141 TREE_PUBLIC (t) = 1;
8143 t = start_decl (t, FALSE);
8144 finish_decl (t, NULL_TREE, FALSE);
8147 && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8148 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8149 ffeglobal_set_hook (g, t);
8151 ffecom_save_tree_forever (t);
8155 case FFEINFO_whereDUMMY:
8156 assert (ffecom_transform_only_dummies_);
8158 if (ffesymbol_is_f2c (s)
8159 && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8160 t = ffecom_tree_ptr_to_fun_type[bt][kt];
8162 t = build_pointer_type
8163 (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8165 t = build_decl (PARM_DECL,
8166 ffecom_get_identifier_ (ffesymbol_text (s)),
8169 DECL_ARTIFICIAL (t) = 1;
8174 case FFEINFO_whereCONSTANT: /* Statement function. */
8175 assert (!ffecom_transform_only_dummies_);
8176 t = ffecom_gen_sfuncdef_ (s, bt, kt);
8179 case FFEINFO_whereINTRINSIC:
8180 assert (!ffecom_transform_only_dummies_);
8181 break; /* Let actual references generate their
8185 assert ("FUNCTION where unheard of" == NULL);
8187 case FFEINFO_whereANY:
8188 t = error_mark_node;
8193 case FFEINFO_kindSUBROUTINE:
8194 switch (ffeinfo_where (ffesymbol_info (s)))
8196 case FFEINFO_whereLOCAL: /* Me. */
8197 assert (!ffecom_transform_only_dummies_);
8198 t = current_function_decl;
8201 case FFEINFO_whereGLOBAL:
8202 assert (!ffecom_transform_only_dummies_);
8204 if (((g = ffesymbol_global (s)) != NULL)
8205 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8206 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8207 && (ffeglobal_hook (g) != NULL_TREE)
8208 && ffe_is_globals ())
8210 t = ffeglobal_hook (g);
8214 t = build_decl (FUNCTION_DECL,
8215 ffecom_get_external_identifier_ (s),
8216 ffecom_tree_subr_type);
8217 DECL_EXTERNAL (t) = 1;
8218 TREE_PUBLIC (t) = 1;
8220 t = start_decl (t, FALSE);
8221 finish_decl (t, NULL_TREE, FALSE);
8224 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8225 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8226 ffeglobal_set_hook (g, t);
8228 ffecom_save_tree_forever (t);
8232 case FFEINFO_whereDUMMY:
8233 assert (ffecom_transform_only_dummies_);
8235 t = build_decl (PARM_DECL,
8236 ffecom_get_identifier_ (ffesymbol_text (s)),
8237 ffecom_tree_ptr_to_subr_type);
8239 DECL_ARTIFICIAL (t) = 1;
8244 case FFEINFO_whereINTRINSIC:
8245 assert (!ffecom_transform_only_dummies_);
8246 break; /* Let actual references generate their
8250 assert ("SUBROUTINE where unheard of" == NULL);
8252 case FFEINFO_whereANY:
8253 t = error_mark_node;
8258 case FFEINFO_kindPROGRAM:
8259 switch (ffeinfo_where (ffesymbol_info (s)))
8261 case FFEINFO_whereLOCAL: /* Me. */
8262 assert (!ffecom_transform_only_dummies_);
8263 t = current_function_decl;
8266 case FFEINFO_whereCOMMON:
8267 case FFEINFO_whereDUMMY:
8268 case FFEINFO_whereGLOBAL:
8269 case FFEINFO_whereRESULT:
8270 case FFEINFO_whereFLEETING:
8271 case FFEINFO_whereFLEETING_CADDR:
8272 case FFEINFO_whereFLEETING_IADDR:
8273 case FFEINFO_whereIMMEDIATE:
8274 case FFEINFO_whereINTRINSIC:
8275 case FFEINFO_whereCONSTANT:
8276 case FFEINFO_whereCONSTANT_SUBOBJECT:
8278 assert ("PROGRAM where unheard of" == NULL);
8280 case FFEINFO_whereANY:
8281 t = error_mark_node;
8286 case FFEINFO_kindBLOCKDATA:
8287 switch (ffeinfo_where (ffesymbol_info (s)))
8289 case FFEINFO_whereLOCAL: /* Me. */
8290 assert (!ffecom_transform_only_dummies_);
8291 t = current_function_decl;
8294 case FFEINFO_whereGLOBAL:
8295 assert (!ffecom_transform_only_dummies_);
8297 t = build_decl (FUNCTION_DECL,
8298 ffecom_get_external_identifier_ (s),
8299 ffecom_tree_blockdata_type);
8300 DECL_EXTERNAL (t) = 1;
8301 TREE_PUBLIC (t) = 1;
8303 t = start_decl (t, FALSE);
8304 finish_decl (t, NULL_TREE, FALSE);
8306 ffecom_save_tree_forever (t);
8310 case FFEINFO_whereCOMMON:
8311 case FFEINFO_whereDUMMY:
8312 case FFEINFO_whereRESULT:
8313 case FFEINFO_whereFLEETING:
8314 case FFEINFO_whereFLEETING_CADDR:
8315 case FFEINFO_whereFLEETING_IADDR:
8316 case FFEINFO_whereIMMEDIATE:
8317 case FFEINFO_whereINTRINSIC:
8318 case FFEINFO_whereCONSTANT:
8319 case FFEINFO_whereCONSTANT_SUBOBJECT:
8321 assert ("BLOCKDATA where unheard of" == NULL);
8323 case FFEINFO_whereANY:
8324 t = error_mark_node;
8329 case FFEINFO_kindCOMMON:
8330 switch (ffeinfo_where (ffesymbol_info (s)))
8332 case FFEINFO_whereLOCAL:
8333 assert (!ffecom_transform_only_dummies_);
8334 ffecom_transform_common_ (s);
8337 case FFEINFO_whereNONE:
8338 case FFEINFO_whereCOMMON:
8339 case FFEINFO_whereDUMMY:
8340 case FFEINFO_whereGLOBAL:
8341 case FFEINFO_whereRESULT:
8342 case FFEINFO_whereFLEETING:
8343 case FFEINFO_whereFLEETING_CADDR:
8344 case FFEINFO_whereFLEETING_IADDR:
8345 case FFEINFO_whereIMMEDIATE:
8346 case FFEINFO_whereINTRINSIC:
8347 case FFEINFO_whereCONSTANT:
8348 case FFEINFO_whereCONSTANT_SUBOBJECT:
8350 assert ("COMMON where unheard of" == NULL);
8352 case FFEINFO_whereANY:
8353 t = error_mark_node;
8358 case FFEINFO_kindCONSTRUCT:
8359 switch (ffeinfo_where (ffesymbol_info (s)))
8361 case FFEINFO_whereLOCAL:
8362 assert (!ffecom_transform_only_dummies_);
8365 case FFEINFO_whereNONE:
8366 case FFEINFO_whereCOMMON:
8367 case FFEINFO_whereDUMMY:
8368 case FFEINFO_whereGLOBAL:
8369 case FFEINFO_whereRESULT:
8370 case FFEINFO_whereFLEETING:
8371 case FFEINFO_whereFLEETING_CADDR:
8372 case FFEINFO_whereFLEETING_IADDR:
8373 case FFEINFO_whereIMMEDIATE:
8374 case FFEINFO_whereINTRINSIC:
8375 case FFEINFO_whereCONSTANT:
8376 case FFEINFO_whereCONSTANT_SUBOBJECT:
8378 assert ("CONSTRUCT where unheard of" == NULL);
8380 case FFEINFO_whereANY:
8381 t = error_mark_node;
8386 case FFEINFO_kindNAMELIST:
8387 switch (ffeinfo_where (ffesymbol_info (s)))
8389 case FFEINFO_whereLOCAL:
8390 assert (!ffecom_transform_only_dummies_);
8391 t = ffecom_transform_namelist_ (s);
8394 case FFEINFO_whereNONE:
8395 case FFEINFO_whereCOMMON:
8396 case FFEINFO_whereDUMMY:
8397 case FFEINFO_whereGLOBAL:
8398 case FFEINFO_whereRESULT:
8399 case FFEINFO_whereFLEETING:
8400 case FFEINFO_whereFLEETING_CADDR:
8401 case FFEINFO_whereFLEETING_IADDR:
8402 case FFEINFO_whereIMMEDIATE:
8403 case FFEINFO_whereINTRINSIC:
8404 case FFEINFO_whereCONSTANT:
8405 case FFEINFO_whereCONSTANT_SUBOBJECT:
8407 assert ("NAMELIST where unheard of" == NULL);
8409 case FFEINFO_whereANY:
8410 t = error_mark_node;
8416 assert ("kind unheard of" == NULL);
8418 case FFEINFO_kindANY:
8419 t = error_mark_node;
8423 ffesymbol_hook (s).decl_tree = t;
8424 ffesymbol_hook (s).length_tree = tlen;
8425 ffesymbol_hook (s).addr = addr;
8427 lineno = old_lineno;
8428 input_filename = old_input_filename;
8434 /* Transform into ASSIGNable symbol.
8436 Symbol has already been transformed, but for whatever reason, the
8437 resulting decl_tree has been deemed not usable for an ASSIGN target.
8438 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8439 another local symbol of type void * and stuff that in the assign_tree
8440 argument. The F77/F90 standards allow this implementation. */
8442 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8444 ffecom_sym_transform_assign_ (ffesymbol s)
8446 tree t; /* Transformed thingy. */
8447 int old_lineno = lineno;
8448 const char *old_input_filename = input_filename;
8450 if (ffesymbol_sfdummyparent (s) == NULL)
8452 input_filename = ffesymbol_where_filename (s);
8453 lineno = ffesymbol_where_filelinenum (s);
8457 ffesymbol sf = ffesymbol_sfdummyparent (s);
8459 input_filename = ffesymbol_where_filename (sf);
8460 lineno = ffesymbol_where_filelinenum (sf);
8463 assert (!ffecom_transform_only_dummies_);
8465 t = build_decl (VAR_DECL,
8466 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8467 ffesymbol_text (s)),
8468 TREE_TYPE (null_pointer_node));
8470 switch (ffesymbol_where (s))
8472 case FFEINFO_whereLOCAL:
8473 /* Unlike for regular vars, SAVE status is easy to determine for
8474 ASSIGNed vars, since there's no initialization, there's no
8475 effective storage association (so "SAVE J" does not apply to
8476 K even given "EQUIVALENCE (J,K)"), there's no size issue
8477 to worry about, etc. */
8478 if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8479 && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8480 && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8481 TREE_STATIC (t) = 1; /* SAVEd in proc, make static. */
8483 TREE_STATIC (t) = 0; /* No need to make static. */
8486 case FFEINFO_whereCOMMON:
8487 TREE_STATIC (t) = 1; /* Assume COMMONs always SAVEd. */
8490 case FFEINFO_whereDUMMY:
8491 /* Note that twinning a DUMMY means the caller won't see
8492 the ASSIGNed value. But both F77 and F90 allow implementations
8493 to do this, i.e. disallow Fortran code that would try and
8494 take advantage of actually putting a label into a variable
8495 via a dummy argument (or any other storage association, for
8497 TREE_STATIC (t) = 0;
8501 TREE_STATIC (t) = 0;
8505 t = start_decl (t, FALSE);
8506 finish_decl (t, NULL_TREE, FALSE);
8508 ffesymbol_hook (s).assign_tree = t;
8510 lineno = old_lineno;
8511 input_filename = old_input_filename;
8517 /* Implement COMMON area in back end.
8519 Because COMMON-based variables can be referenced in the dimension
8520 expressions of dummy (adjustable) arrays, and because dummies
8521 (in the gcc back end) need to be put in the outer binding level
8522 of a function (which has two binding levels, the outer holding
8523 the dummies and the inner holding the other vars), special care
8524 must be taken to handle COMMON areas.
8526 The current strategy is basically to always tell the back end about
8527 the COMMON area as a top-level external reference to just a block
8528 of storage of the master type of that area (e.g. integer, real,
8529 character, whatever -- not a structure). As a distinct action,
8530 if initial values are provided, tell the back end about the area
8531 as a top-level non-external (initialized) area and remember not to
8532 allow further initialization or expansion of the area. Meanwhile,
8533 if no initialization happens at all, tell the back end about
8534 the largest size we've seen declared so the space does get reserved.
8535 (This function doesn't handle all that stuff, but it does some
8536 of the important things.)
8538 Meanwhile, for COMMON variables themselves, just keep creating
8539 references like *((float *) (&common_area + offset)) each time
8540 we reference the variable. In other words, don't make a VAR_DECL
8541 or any kind of component reference (like we used to do before 0.4),
8542 though we might do that as well just for debugging purposes (and
8543 stuff the rtl with the appropriate offset expression). */
8545 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8547 ffecom_transform_common_ (ffesymbol s)
8549 ffestorag st = ffesymbol_storage (s);
8550 ffeglobal g = ffesymbol_global (s);
8555 bool is_init = ffestorag_is_init (st);
8557 assert (st != NULL);
8560 || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8563 /* First update the size of the area in global terms. */
8565 ffeglobal_size_common (s, ffestorag_size (st));
8567 if (!ffeglobal_common_init (g))
8568 is_init = FALSE; /* No explicit init, don't let erroneous joins init. */
8570 cbt = ffeglobal_hook (g);
8572 /* If we already have declared this common block for a previous program
8573 unit, and either we already initialized it or we don't have new
8574 initialization for it, just return what we have without changing it. */
8576 if ((cbt != NULL_TREE)
8578 || !DECL_EXTERNAL (cbt)))
8580 if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8584 /* Process inits. */
8588 if (ffestorag_init (st) != NULL)
8592 /* Set the padding for the expression, so ffecom_expr
8593 knows to insert that many zeros. */
8594 switch (ffebld_op (sexp = ffestorag_init (st)))
8596 case FFEBLD_opCONTER:
8597 ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8600 case FFEBLD_opARRTER:
8601 ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8604 case FFEBLD_opACCTER:
8605 ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8609 assert ("bad op for cmn init (pad)" == NULL);
8613 init = ffecom_expr (sexp);
8614 if (init == error_mark_node)
8615 { /* Hopefully the back end complained! */
8617 if (cbt != NULL_TREE)
8622 init = error_mark_node;
8627 /* cbtype must be permanently allocated! */
8629 /* Allocate the MAX of the areas so far, seen filewide. */
8630 high = build_int_2 ((ffeglobal_common_size (g)
8631 + ffeglobal_common_pad (g)) - 1, 0);
8632 TREE_TYPE (high) = ffecom_integer_type_node;
8635 cbtype = build_array_type (char_type_node,
8636 build_range_type (integer_type_node,
8640 cbtype = build_array_type (char_type_node, NULL_TREE);
8642 if (cbt == NULL_TREE)
8645 = build_decl (VAR_DECL,
8646 ffecom_get_external_identifier_ (s),
8648 TREE_STATIC (cbt) = 1;
8649 TREE_PUBLIC (cbt) = 1;
8654 TREE_TYPE (cbt) = cbtype;
8656 DECL_EXTERNAL (cbt) = init ? 0 : 1;
8657 DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8659 cbt = start_decl (cbt, TRUE);
8660 if (ffeglobal_hook (g) != NULL)
8661 assert (cbt == ffeglobal_hook (g));
8663 assert (!init || !DECL_EXTERNAL (cbt));
8665 /* Make sure that any type can live in COMMON and be referenced
8666 without getting a bus error. We could pick the most restrictive
8667 alignment of all entities actually placed in the COMMON, but
8668 this seems easy enough. */
8670 DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8671 DECL_USER_ALIGN (cbt) = 0;
8673 if (is_init && (ffestorag_init (st) == NULL))
8674 init = ffecom_init_zero_ (cbt);
8676 finish_decl (cbt, init, TRUE);
8679 ffestorag_set_init (st, ffebld_new_any ());
8683 assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8684 assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8685 assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8686 (ffeglobal_common_size (g)
8687 + ffeglobal_common_pad (g))));
8690 ffeglobal_set_hook (g, cbt);
8692 ffestorag_set_hook (st, cbt);
8694 ffecom_save_tree_forever (cbt);
8698 /* Make master area for local EQUIVALENCE. */
8700 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8702 ffecom_transform_equiv_ (ffestorag eqst)
8708 bool is_init = ffestorag_is_init (eqst);
8710 assert (eqst != NULL);
8712 eqt = ffestorag_hook (eqst);
8714 if (eqt != NULL_TREE)
8717 /* Process inits. */
8721 if (ffestorag_init (eqst) != NULL)
8725 /* Set the padding for the expression, so ffecom_expr
8726 knows to insert that many zeros. */
8727 switch (ffebld_op (sexp = ffestorag_init (eqst)))
8729 case FFEBLD_opCONTER:
8730 ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8733 case FFEBLD_opARRTER:
8734 ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8737 case FFEBLD_opACCTER:
8738 ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8742 assert ("bad op for eqv init (pad)" == NULL);
8746 init = ffecom_expr (sexp);
8747 if (init == error_mark_node)
8748 init = NULL_TREE; /* Hopefully the back end complained! */
8751 init = error_mark_node;
8753 else if (ffe_is_init_local_zero ())
8754 init = error_mark_node;
8758 ffecom_member_namelisted_ = FALSE;
8759 ffestorag_drive (ffestorag_list_equivs (eqst),
8760 &ffecom_member_phase1_,
8763 high = build_int_2 ((ffestorag_size (eqst)
8764 + ffestorag_modulo (eqst)) - 1, 0);
8765 TREE_TYPE (high) = ffecom_integer_type_node;
8767 eqtype = build_array_type (char_type_node,
8768 build_range_type (ffecom_integer_type_node,
8769 ffecom_integer_zero_node,
8772 eqt = build_decl (VAR_DECL,
8773 ffecom_get_invented_identifier ("__g77_equiv_%s",
8775 (ffestorag_symbol (eqst))),
8777 DECL_EXTERNAL (eqt) = 0;
8779 || ffecom_member_namelisted_
8780 #ifdef FFECOM_sizeMAXSTACKITEM
8781 || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8783 || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8784 && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8785 && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8786 TREE_STATIC (eqt) = 1;
8788 TREE_STATIC (eqt) = 0;
8789 TREE_PUBLIC (eqt) = 0;
8790 TREE_ADDRESSABLE (eqt) = 1; /* Ensure non-register allocation */
8791 DECL_CONTEXT (eqt) = current_function_decl;
8793 DECL_INITIAL (eqt) = error_mark_node;
8795 DECL_INITIAL (eqt) = NULL_TREE;
8797 eqt = start_decl (eqt, FALSE);
8799 /* Make sure that any type can live in EQUIVALENCE and be referenced
8800 without getting a bus error. We could pick the most restrictive
8801 alignment of all entities actually placed in the EQUIVALENCE, but
8802 this seems easy enough. */
8804 DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8805 DECL_USER_ALIGN (eqt) = 0;
8807 if ((!is_init && ffe_is_init_local_zero ())
8808 || (is_init && (ffestorag_init (eqst) == NULL)))
8809 init = ffecom_init_zero_ (eqt);
8811 finish_decl (eqt, init, FALSE);
8814 ffestorag_set_init (eqst, ffebld_new_any ());
8817 assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8818 assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8819 (ffestorag_size (eqst)
8820 + ffestorag_modulo (eqst))));
8823 ffestorag_set_hook (eqst, eqt);
8825 ffestorag_drive (ffestorag_list_equivs (eqst),
8826 &ffecom_member_phase2_,
8831 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8833 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8835 ffecom_transform_namelist_ (ffesymbol s)
8838 tree nmltype = ffecom_type_namelist_ ();
8846 static int mynumber = 0;
8848 nmlt = build_decl (VAR_DECL,
8849 ffecom_get_invented_identifier ("__g77_namelist_%d",
8852 TREE_STATIC (nmlt) = 1;
8853 DECL_INITIAL (nmlt) = error_mark_node;
8855 nmlt = start_decl (nmlt, FALSE);
8857 /* Process inits. */
8859 i = strlen (ffesymbol_text (s));
8861 high = build_int_2 (i, 0);
8862 TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8864 nameinit = ffecom_build_f2c_string_ (i + 1,
8865 ffesymbol_text (s));
8866 TREE_TYPE (nameinit)
8867 = build_type_variant
8870 build_range_type (ffecom_f2c_ftnlen_type_node,
8871 ffecom_f2c_ftnlen_one_node,
8874 TREE_CONSTANT (nameinit) = 1;
8875 TREE_STATIC (nameinit) = 1;
8876 nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8879 varsinit = ffecom_vardesc_array_ (s);
8880 varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8882 TREE_CONSTANT (varsinit) = 1;
8883 TREE_STATIC (varsinit) = 1;
8888 for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8891 nvarsinit = build_int_2 (i, 0);
8892 TREE_TYPE (nvarsinit) = integer_type_node;
8893 TREE_CONSTANT (nvarsinit) = 1;
8894 TREE_STATIC (nvarsinit) = 1;
8896 nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8897 TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8899 TREE_CHAIN (TREE_CHAIN (nmlinits))
8900 = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8902 nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8903 TREE_CONSTANT (nmlinits) = 1;
8904 TREE_STATIC (nmlinits) = 1;
8906 finish_decl (nmlt, nmlinits, FALSE);
8908 nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8915 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8916 analyzed on the assumption it is calculating a pointer to be
8917 indirected through. It must return the proper decl and offset,
8918 taking into account different units of measurements for offsets. */
8920 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8922 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8925 switch (TREE_CODE (t))
8929 case NON_LVALUE_EXPR:
8930 ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8934 ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8935 if ((*decl == NULL_TREE)
8936 || (*decl == error_mark_node))
8939 if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
8941 /* An offset into COMMON. */
8942 *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
8943 *offset, TREE_OPERAND (t, 1)));
8944 /* Convert offset (presumably in bytes) into canonical units
8945 (presumably bits). */
8946 *offset = size_binop (MULT_EXPR,
8947 convert (bitsizetype, *offset),
8948 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
8951 /* Not a COMMON reference, so an unrecognized pattern. */
8952 *decl = error_mark_node;
8957 *offset = bitsize_zero_node;
8961 if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
8963 /* A reference to COMMON. */
8964 *decl = TREE_OPERAND (t, 0);
8965 *offset = bitsize_zero_node;
8970 /* Not a COMMON reference, so an unrecognized pattern. */
8971 *decl = error_mark_node;
8977 /* Given a tree that is possibly intended for use as an lvalue, return
8978 information representing a canonical view of that tree as a decl, an
8979 offset into that decl, and a size for the lvalue.
8981 If there's no applicable decl, NULL_TREE is returned for the decl,
8982 and the other fields are left undefined.
8984 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8985 is returned for the decl, and the other fields are left undefined.
8987 Otherwise, the decl returned currently is either a VAR_DECL or a
8990 The offset returned is always valid, but of course not necessarily
8991 a constant, and not necessarily converted into the appropriate
8992 type, leaving that up to the caller (so as to avoid that overhead
8993 if the decls being looked at are different anyway).
8995 If the size cannot be determined (e.g. an adjustable array),
8996 an ERROR_MARK node is returned for the size. Otherwise, the
8997 size returned is valid, not necessarily a constant, and not
8998 necessarily converted into the appropriate type as with the
9001 Note that the offset and size expressions are expressed in the
9002 base storage units (usually bits) rather than in the units of
9003 the type of the decl, because two decls with different types
9004 might overlap but with apparently non-overlapping array offsets,
9005 whereas converting the array offsets to consistant offsets will
9006 reveal the overlap. */
9008 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9010 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9013 /* The default path is to report a nonexistant decl. */
9019 switch (TREE_CODE (t))
9022 case IDENTIFIER_NODE:
9031 case TRUNC_DIV_EXPR:
9033 case FLOOR_DIV_EXPR:
9034 case ROUND_DIV_EXPR:
9035 case TRUNC_MOD_EXPR:
9037 case FLOOR_MOD_EXPR:
9038 case ROUND_MOD_EXPR:
9040 case EXACT_DIV_EXPR:
9041 case FIX_TRUNC_EXPR:
9043 case FIX_FLOOR_EXPR:
9044 case FIX_ROUND_EXPR:
9059 case BIT_ANDTC_EXPR:
9061 case TRUTH_ANDIF_EXPR:
9062 case TRUTH_ORIF_EXPR:
9063 case TRUTH_AND_EXPR:
9065 case TRUTH_XOR_EXPR:
9066 case TRUTH_NOT_EXPR:
9086 *offset = bitsize_zero_node;
9087 *size = TYPE_SIZE (TREE_TYPE (t));
9092 tree array = TREE_OPERAND (t, 0);
9093 tree element = TREE_OPERAND (t, 1);
9096 if ((array == NULL_TREE)
9097 || (element == NULL_TREE))
9099 *decl = error_mark_node;
9103 ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9105 if ((*decl == NULL_TREE)
9106 || (*decl == error_mark_node))
9109 /* Calculate ((element - base) * NBBY) + init_offset. */
9110 *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9112 TYPE_MIN_VALUE (TYPE_DOMAIN
9113 (TREE_TYPE (array)))));
9115 *offset = size_binop (MULT_EXPR,
9116 convert (bitsizetype, *offset),
9117 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9119 *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9121 *size = TYPE_SIZE (TREE_TYPE (t));
9127 /* Most of this code is to handle references to COMMON. And so
9128 far that is useful only for calling library functions, since
9129 external (user) functions might reference common areas. But
9130 even calling an external function, it's worthwhile to decode
9131 COMMON references because if not storing into COMMON, we don't
9132 want COMMON-based arguments to gratuitously force use of a
9135 *size = TYPE_SIZE (TREE_TYPE (t));
9137 ffecom_tree_canonize_ptr_ (decl, offset,
9138 TREE_OPERAND (t, 0));
9145 case NON_LVALUE_EXPR:
9148 case COND_EXPR: /* More cases than we can handle. */
9150 case REFERENCE_EXPR:
9151 case PREDECREMENT_EXPR:
9152 case PREINCREMENT_EXPR:
9153 case POSTDECREMENT_EXPR:
9154 case POSTINCREMENT_EXPR:
9157 *decl = error_mark_node;
9163 /* Do divide operation appropriate to type of operands. */
9165 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9167 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9168 tree dest_tree, ffebld dest, bool *dest_used,
9171 if ((left == error_mark_node)
9172 || (right == error_mark_node))
9173 return error_mark_node;
9175 switch (TREE_CODE (tree_type))
9178 return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9183 if (! optimize_size)
9184 return ffecom_2 (RDIV_EXPR, tree_type,
9190 if (TREE_TYPE (tree_type)
9191 == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9192 ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
9194 ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
9196 left = ffecom_1 (ADDR_EXPR,
9197 build_pointer_type (TREE_TYPE (left)),
9199 left = build_tree_list (NULL_TREE, left);
9200 right = ffecom_1 (ADDR_EXPR,
9201 build_pointer_type (TREE_TYPE (right)),
9203 right = build_tree_list (NULL_TREE, right);
9204 TREE_CHAIN (left) = right;
9206 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9207 ffecom_gfrt_kindtype (ix),
9208 ffe_is_f2c_library (),
9211 dest_tree, dest, dest_used,
9212 NULL_TREE, TRUE, hook);
9220 if (TREE_TYPE (TYPE_FIELDS (tree_type))
9221 == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9222 ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
9224 ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
9226 left = ffecom_1 (ADDR_EXPR,
9227 build_pointer_type (TREE_TYPE (left)),
9229 left = build_tree_list (NULL_TREE, left);
9230 right = ffecom_1 (ADDR_EXPR,
9231 build_pointer_type (TREE_TYPE (right)),
9233 right = build_tree_list (NULL_TREE, right);
9234 TREE_CHAIN (left) = right;
9236 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9237 ffecom_gfrt_kindtype (ix),
9238 ffe_is_f2c_library (),
9241 dest_tree, dest, dest_used,
9242 NULL_TREE, TRUE, hook);
9247 return ffecom_2 (RDIV_EXPR, tree_type,
9254 /* Build type info for non-dummy variable. */
9256 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9258 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9267 type = ffecom_tree_type[bt][kt];
9268 if (bt == FFEINFO_basictypeCHARACTER)
9270 hight = build_int_2 (ffesymbol_size (s), 0);
9271 TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9276 build_range_type (ffecom_f2c_ftnlen_type_node,
9277 ffecom_f2c_ftnlen_one_node,
9279 type = ffecom_check_size_overflow_ (s, type, FALSE);
9282 for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9284 if (type == error_mark_node)
9287 dim = ffebld_head (dl);
9288 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9290 if (ffebld_left (dim) == NULL)
9291 lowt = integer_one_node;
9293 lowt = ffecom_expr (ffebld_left (dim));
9295 if (TREE_CODE (lowt) != INTEGER_CST)
9296 lowt = variable_size (lowt);
9298 assert (ffebld_right (dim) != NULL);
9299 hight = ffecom_expr (ffebld_right (dim));
9301 if (TREE_CODE (hight) != INTEGER_CST)
9302 hight = variable_size (hight);
9304 type = build_array_type (type,
9305 build_range_type (ffecom_integer_type_node,
9307 type = ffecom_check_size_overflow_ (s, type, FALSE);
9314 /* Build Namelist type. */
9316 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9318 ffecom_type_namelist_ ()
9320 static tree type = NULL_TREE;
9322 if (type == NULL_TREE)
9324 static tree namefield, varsfield, nvarsfield;
9327 vardesctype = ffecom_type_vardesc_ ();
9329 type = make_node (RECORD_TYPE);
9331 vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9333 namefield = ffecom_decl_field (type, NULL_TREE, "name",
9335 varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9336 nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9339 TYPE_FIELDS (type) = namefield;
9342 ggc_add_tree_root (&type, 1);
9350 /* Build Vardesc type. */
9352 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9354 ffecom_type_vardesc_ ()
9356 static tree type = NULL_TREE;
9357 static tree namefield, addrfield, dimsfield, typefield;
9359 if (type == NULL_TREE)
9361 type = make_node (RECORD_TYPE);
9363 namefield = ffecom_decl_field (type, NULL_TREE, "name",
9365 addrfield = ffecom_decl_field (type, namefield, "addr",
9367 dimsfield = ffecom_decl_field (type, addrfield, "dims",
9368 ffecom_f2c_ptr_to_ftnlen_type_node);
9369 typefield = ffecom_decl_field (type, dimsfield, "type",
9372 TYPE_FIELDS (type) = namefield;
9375 ggc_add_tree_root (&type, 1);
9383 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9385 ffecom_vardesc_ (ffebld expr)
9389 assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9390 s = ffebld_symter (expr);
9392 if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9395 tree vardesctype = ffecom_type_vardesc_ ();
9403 static int mynumber = 0;
9405 var = build_decl (VAR_DECL,
9406 ffecom_get_invented_identifier ("__g77_vardesc_%d",
9409 TREE_STATIC (var) = 1;
9410 DECL_INITIAL (var) = error_mark_node;
9412 var = start_decl (var, FALSE);
9414 /* Process inits. */
9416 nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9418 ffesymbol_text (s));
9419 TREE_TYPE (nameinit)
9420 = build_type_variant
9423 build_range_type (integer_type_node,
9425 build_int_2 (i, 0))),
9427 TREE_CONSTANT (nameinit) = 1;
9428 TREE_STATIC (nameinit) = 1;
9429 nameinit = ffecom_1 (ADDR_EXPR,
9430 build_pointer_type (TREE_TYPE (nameinit)),
9433 addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9435 dimsinit = ffecom_vardesc_dims_ (s);
9437 if (typeinit == NULL_TREE)
9439 ffeinfoBasictype bt = ffesymbol_basictype (s);
9440 ffeinfoKindtype kt = ffesymbol_kindtype (s);
9441 int tc = ffecom_f2c_typecode (bt, kt);
9444 typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9447 typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9449 varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9451 TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9453 TREE_CHAIN (TREE_CHAIN (varinits))
9454 = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9455 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9456 = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9458 varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9459 TREE_CONSTANT (varinits) = 1;
9460 TREE_STATIC (varinits) = 1;
9462 finish_decl (var, varinits, FALSE);
9464 var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9466 ffesymbol_hook (s).vardesc_tree = var;
9469 return ffesymbol_hook (s).vardesc_tree;
9473 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9475 ffecom_vardesc_array_ (ffesymbol s)
9479 tree item = NULL_TREE;
9482 static int mynumber = 0;
9484 for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9486 b = ffebld_trail (b), ++i)
9490 t = ffecom_vardesc_ (ffebld_head (b));
9492 if (list == NULL_TREE)
9493 list = item = build_tree_list (NULL_TREE, t);
9496 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9497 item = TREE_CHAIN (item);
9501 item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9502 build_range_type (integer_type_node,
9504 build_int_2 (i, 0)));
9505 list = build (CONSTRUCTOR, item, NULL_TREE, list);
9506 TREE_CONSTANT (list) = 1;
9507 TREE_STATIC (list) = 1;
9509 var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9510 var = build_decl (VAR_DECL, var, item);
9511 TREE_STATIC (var) = 1;
9512 DECL_INITIAL (var) = error_mark_node;
9513 var = start_decl (var, FALSE);
9514 finish_decl (var, list, FALSE);
9520 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9522 ffecom_vardesc_dims_ (ffesymbol s)
9524 if (ffesymbol_dims (s) == NULL)
9525 return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9533 tree item = NULL_TREE;
9537 tree baseoff = NULL_TREE;
9538 static int mynumber = 0;
9540 numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9541 TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9543 numelem = ffecom_expr (ffesymbol_arraysize (s));
9544 TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9547 backlist = NULL_TREE;
9548 for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9550 b = ffebld_trail (b), e = ffebld_trail (e))
9556 if (ffebld_trail (b) == NULL)
9560 t = convert (ffecom_f2c_ftnlen_type_node,
9561 ffecom_expr (ffebld_head (e)));
9563 if (list == NULL_TREE)
9564 list = item = build_tree_list (NULL_TREE, t);
9567 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9568 item = TREE_CHAIN (item);
9572 if (ffebld_left (ffebld_head (b)) == NULL)
9573 low = ffecom_integer_one_node;
9575 low = ffecom_expr (ffebld_left (ffebld_head (b)));
9576 low = convert (ffecom_f2c_ftnlen_type_node, low);
9578 back = build_tree_list (low, t);
9579 TREE_CHAIN (back) = backlist;
9583 for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9585 if (TREE_VALUE (item) == NULL_TREE)
9586 baseoff = TREE_PURPOSE (item);
9588 baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9589 TREE_PURPOSE (item),
9590 ffecom_2 (MULT_EXPR,
9591 ffecom_f2c_ftnlen_type_node,
9596 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9598 baseoff = build_tree_list (NULL_TREE, baseoff);
9599 TREE_CHAIN (baseoff) = list;
9601 numelem = build_tree_list (NULL_TREE, numelem);
9602 TREE_CHAIN (numelem) = baseoff;
9604 numdim = build_tree_list (NULL_TREE, numdim);
9605 TREE_CHAIN (numdim) = numelem;
9607 item = build_array_type (ffecom_f2c_ftnlen_type_node,
9608 build_range_type (integer_type_node,
9611 ((int) ffesymbol_rank (s)
9613 list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9614 TREE_CONSTANT (list) = 1;
9615 TREE_STATIC (list) = 1;
9617 var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9618 var = build_decl (VAR_DECL, var, item);
9619 TREE_STATIC (var) = 1;
9620 DECL_INITIAL (var) = error_mark_node;
9621 var = start_decl (var, FALSE);
9622 finish_decl (var, list, FALSE);
9624 var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9631 /* Essentially does a "fold (build1 (code, type, node))" while checking
9632 for certain housekeeping things.
9634 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9635 ffecom_1_fn instead. */
9637 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9639 ffecom_1 (enum tree_code code, tree type, tree node)
9643 if ((node == error_mark_node)
9644 || (type == error_mark_node))
9645 return error_mark_node;
9647 if (code == ADDR_EXPR)
9649 if (!mark_addressable (node))
9650 assert ("can't mark_addressable this node!" == NULL);
9653 switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9658 item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9662 item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9667 if (TREE_CODE (type) != RECORD_TYPE)
9669 item = build1 (code, type, node);
9672 node = ffecom_stabilize_aggregate_ (node);
9673 realtype = TREE_TYPE (TYPE_FIELDS (type));
9675 ffecom_2 (COMPLEX_EXPR, type,
9676 ffecom_1 (NEGATE_EXPR, realtype,
9677 ffecom_1 (REALPART_EXPR, realtype,
9679 ffecom_1 (NEGATE_EXPR, realtype,
9680 ffecom_1 (IMAGPART_EXPR, realtype,
9685 item = build1 (code, type, node);
9689 if (TREE_SIDE_EFFECTS (node))
9690 TREE_SIDE_EFFECTS (item) = 1;
9691 if ((code == ADDR_EXPR) && staticp (node))
9692 TREE_CONSTANT (item) = 1;
9697 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9698 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9699 does not set TREE_ADDRESSABLE (because calling an inline
9700 function does not mean the function needs to be separately
9703 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9705 ffecom_1_fn (tree node)
9710 if (node == error_mark_node)
9711 return error_mark_node;
9713 type = build_type_variant (TREE_TYPE (node),
9714 TREE_READONLY (node),
9715 TREE_THIS_VOLATILE (node));
9716 item = build1 (ADDR_EXPR,
9717 build_pointer_type (type), node);
9718 if (TREE_SIDE_EFFECTS (node))
9719 TREE_SIDE_EFFECTS (item) = 1;
9721 TREE_CONSTANT (item) = 1;
9726 /* Essentially does a "fold (build (code, type, node1, node2))" while
9727 checking for certain housekeeping things. */
9729 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9731 ffecom_2 (enum tree_code code, tree type, tree node1,
9736 if ((node1 == error_mark_node)
9737 || (node2 == error_mark_node)
9738 || (type == error_mark_node))
9739 return error_mark_node;
9741 switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9743 tree a, b, c, d, realtype;
9746 assert ("no CONJ_EXPR support yet" == NULL);
9747 return error_mark_node;
9750 item = build_tree_list (TYPE_FIELDS (type), node1);
9751 TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9752 item = build (CONSTRUCTOR, type, NULL_TREE, item);
9756 if (TREE_CODE (type) != RECORD_TYPE)
9758 item = build (code, type, node1, node2);
9761 node1 = ffecom_stabilize_aggregate_ (node1);
9762 node2 = ffecom_stabilize_aggregate_ (node2);
9763 realtype = TREE_TYPE (TYPE_FIELDS (type));
9765 ffecom_2 (COMPLEX_EXPR, type,
9766 ffecom_2 (PLUS_EXPR, realtype,
9767 ffecom_1 (REALPART_EXPR, realtype,
9769 ffecom_1 (REALPART_EXPR, realtype,
9771 ffecom_2 (PLUS_EXPR, realtype,
9772 ffecom_1 (IMAGPART_EXPR, realtype,
9774 ffecom_1 (IMAGPART_EXPR, realtype,
9779 if (TREE_CODE (type) != RECORD_TYPE)
9781 item = build (code, type, node1, node2);
9784 node1 = ffecom_stabilize_aggregate_ (node1);
9785 node2 = ffecom_stabilize_aggregate_ (node2);
9786 realtype = TREE_TYPE (TYPE_FIELDS (type));
9788 ffecom_2 (COMPLEX_EXPR, type,
9789 ffecom_2 (MINUS_EXPR, realtype,
9790 ffecom_1 (REALPART_EXPR, realtype,
9792 ffecom_1 (REALPART_EXPR, realtype,
9794 ffecom_2 (MINUS_EXPR, realtype,
9795 ffecom_1 (IMAGPART_EXPR, realtype,
9797 ffecom_1 (IMAGPART_EXPR, realtype,
9802 if (TREE_CODE (type) != RECORD_TYPE)
9804 item = build (code, type, node1, node2);
9807 node1 = ffecom_stabilize_aggregate_ (node1);
9808 node2 = ffecom_stabilize_aggregate_ (node2);
9809 realtype = TREE_TYPE (TYPE_FIELDS (type));
9810 a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9812 b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9814 c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9816 d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9819 ffecom_2 (COMPLEX_EXPR, type,
9820 ffecom_2 (MINUS_EXPR, realtype,
9821 ffecom_2 (MULT_EXPR, realtype,
9824 ffecom_2 (MULT_EXPR, realtype,
9827 ffecom_2 (PLUS_EXPR, realtype,
9828 ffecom_2 (MULT_EXPR, realtype,
9831 ffecom_2 (MULT_EXPR, realtype,
9837 if ((TREE_CODE (node1) != RECORD_TYPE)
9838 && (TREE_CODE (node2) != RECORD_TYPE))
9840 item = build (code, type, node1, node2);
9843 assert (TREE_CODE (node1) == RECORD_TYPE);
9844 assert (TREE_CODE (node2) == RECORD_TYPE);
9845 node1 = ffecom_stabilize_aggregate_ (node1);
9846 node2 = ffecom_stabilize_aggregate_ (node2);
9847 realtype = TREE_TYPE (TYPE_FIELDS (type));
9849 ffecom_2 (TRUTH_ANDIF_EXPR, type,
9850 ffecom_2 (code, type,
9851 ffecom_1 (REALPART_EXPR, realtype,
9853 ffecom_1 (REALPART_EXPR, realtype,
9855 ffecom_2 (code, type,
9856 ffecom_1 (IMAGPART_EXPR, realtype,
9858 ffecom_1 (IMAGPART_EXPR, realtype,
9863 if ((TREE_CODE (node1) != RECORD_TYPE)
9864 && (TREE_CODE (node2) != RECORD_TYPE))
9866 item = build (code, type, node1, node2);
9869 assert (TREE_CODE (node1) == RECORD_TYPE);
9870 assert (TREE_CODE (node2) == RECORD_TYPE);
9871 node1 = ffecom_stabilize_aggregate_ (node1);
9872 node2 = ffecom_stabilize_aggregate_ (node2);
9873 realtype = TREE_TYPE (TYPE_FIELDS (type));
9875 ffecom_2 (TRUTH_ORIF_EXPR, type,
9876 ffecom_2 (code, type,
9877 ffecom_1 (REALPART_EXPR, realtype,
9879 ffecom_1 (REALPART_EXPR, realtype,
9881 ffecom_2 (code, type,
9882 ffecom_1 (IMAGPART_EXPR, realtype,
9884 ffecom_1 (IMAGPART_EXPR, realtype,
9889 item = build (code, type, node1, node2);
9893 if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9894 TREE_SIDE_EFFECTS (item) = 1;
9899 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9901 ffesymbol s; // the ENTRY point itself
9902 if (ffecom_2pass_advise_entrypoint(s))
9903 // the ENTRY point has been accepted
9905 Does whatever compiler needs to do when it learns about the entrypoint,
9906 like determine the return type of the master function, count the
9907 number of entrypoints, etc. Returns FALSE if the return type is
9908 not compatible with the return type(s) of other entrypoint(s).
9910 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9911 later (after _finish_progunit) be called with the same entrypoint(s)
9912 as passed to this fn for which TRUE was returned.
9915 Return FALSE if the return type conflicts with previous entrypoints. */
9917 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9919 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9921 ffebld list; /* opITEM. */
9922 ffebld mlist; /* opITEM. */
9923 ffebld plist; /* opITEM. */
9924 ffebld arg; /* ffebld_head(opITEM). */
9925 ffebld item; /* opITEM. */
9926 ffesymbol s; /* ffebld_symter(arg). */
9927 ffeinfoBasictype bt = ffesymbol_basictype (entry);
9928 ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9929 ffetargetCharacterSize size = ffesymbol_size (entry);
9932 if (ffecom_num_entrypoints_ == 0)
9933 { /* First entrypoint, make list of main
9934 arglist's dummies. */
9935 assert (ffecom_primary_entry_ != NULL);
9937 ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
9938 ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
9939 ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
9941 for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
9943 list = ffebld_trail (list))
9945 arg = ffebld_head (list);
9946 if (ffebld_op (arg) != FFEBLD_opSYMTER)
9947 continue; /* Alternate return or some such thing. */
9948 item = ffebld_new_item (arg, NULL);
9950 ffecom_master_arglist_ = item;
9952 ffebld_set_trail (plist, item);
9957 /* If necessary, scan entry arglist for alternate returns. Do this scan
9958 apparently redundantly (it's done below to UNIONize the arglists) so
9959 that we don't complain about RETURN 1 if an offending ENTRY is the only
9960 one with an alternate return. */
9962 if (!ffecom_is_altreturning_)
9964 for (list = ffesymbol_dummyargs (entry);
9966 list = ffebld_trail (list))
9968 arg = ffebld_head (list);
9969 if (ffebld_op (arg) == FFEBLD_opSTAR)
9971 ffecom_is_altreturning_ = TRUE;
9977 /* Now check type compatibility. */
9979 switch (ffecom_master_bt_)
9981 case FFEINFO_basictypeNONE:
9982 ok = (bt != FFEINFO_basictypeCHARACTER);
9985 case FFEINFO_basictypeCHARACTER:
9987 = (bt == FFEINFO_basictypeCHARACTER)
9988 && (kt == ffecom_master_kt_)
9989 && (size == ffecom_master_size_);
9992 case FFEINFO_basictypeANY:
9993 return FALSE; /* Just don't bother. */
9996 if (bt == FFEINFO_basictypeCHARACTER)
10002 if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10004 ffecom_master_bt_ = FFEINFO_basictypeNONE;
10005 ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10012 ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10013 ffest_ffebad_here_current_stmt (0);
10015 return FALSE; /* Can't handle entrypoint. */
10018 /* Entrypoint type compatible with previous types. */
10020 ++ffecom_num_entrypoints_;
10022 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10024 for (list = ffesymbol_dummyargs (entry);
10026 list = ffebld_trail (list))
10028 arg = ffebld_head (list);
10029 if (ffebld_op (arg) != FFEBLD_opSYMTER)
10030 continue; /* Alternate return or some such thing. */
10031 s = ffebld_symter (arg);
10032 for (plist = NULL, mlist = ffecom_master_arglist_;
10034 plist = mlist, mlist = ffebld_trail (mlist))
10035 { /* plist points to previous item for easy
10036 appending of arg. */
10037 if (ffebld_symter (ffebld_head (mlist)) == s)
10038 break; /* Already have this arg in the master list. */
10041 continue; /* Already have this arg in the master list. */
10043 /* Append this arg to the master list. */
10045 item = ffebld_new_item (arg, NULL);
10047 ffecom_master_arglist_ = item;
10049 ffebld_set_trail (plist, item);
10056 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10058 ffesymbol s; // the ENTRY point itself
10059 ffecom_2pass_do_entrypoint(s);
10061 Does whatever compiler needs to do to make the entrypoint actually
10062 happen. Must be called for each entrypoint after
10063 ffecom_finish_progunit is called. */
10065 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10067 ffecom_2pass_do_entrypoint (ffesymbol entry)
10069 static int mfn_num = 0;
10070 static int ent_num;
10072 if (mfn_num != ffecom_num_fns_)
10073 { /* First entrypoint for this program unit. */
10075 mfn_num = ffecom_num_fns_;
10076 ffecom_do_entry_ (ffecom_primary_entry_, 0);
10081 --ffecom_num_entrypoints_;
10083 ffecom_do_entry_ (entry, ent_num);
10088 /* Essentially does a "fold (build (code, type, node1, node2))" while
10089 checking for certain housekeeping things. Always sets
10090 TREE_SIDE_EFFECTS. */
10092 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10094 ffecom_2s (enum tree_code code, tree type, tree node1,
10099 if ((node1 == error_mark_node)
10100 || (node2 == error_mark_node)
10101 || (type == error_mark_node))
10102 return error_mark_node;
10104 item = build (code, type, node1, node2);
10105 TREE_SIDE_EFFECTS (item) = 1;
10106 return fold (item);
10110 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10111 checking for certain housekeeping things. */
10113 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10115 ffecom_3 (enum tree_code code, tree type, tree node1,
10116 tree node2, tree node3)
10120 if ((node1 == error_mark_node)
10121 || (node2 == error_mark_node)
10122 || (node3 == error_mark_node)
10123 || (type == error_mark_node))
10124 return error_mark_node;
10126 item = build (code, type, node1, node2, node3);
10127 if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10128 || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10129 TREE_SIDE_EFFECTS (item) = 1;
10130 return fold (item);
10134 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10135 checking for certain housekeeping things. Always sets
10136 TREE_SIDE_EFFECTS. */
10138 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10140 ffecom_3s (enum tree_code code, tree type, tree node1,
10141 tree node2, tree node3)
10145 if ((node1 == error_mark_node)
10146 || (node2 == error_mark_node)
10147 || (node3 == error_mark_node)
10148 || (type == error_mark_node))
10149 return error_mark_node;
10151 item = build (code, type, node1, node2, node3);
10152 TREE_SIDE_EFFECTS (item) = 1;
10153 return fold (item);
10158 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10160 See use by ffecom_list_expr.
10162 If expression is NULL, returns an integer zero tree. If it is not
10163 a CHARACTER expression, returns whatever ffecom_expr
10164 returns and sets the length return value to NULL_TREE. Otherwise
10165 generates code to evaluate the character expression, returns the proper
10166 pointer to the result, but does NOT set the length return value to a tree
10167 that specifies the length of the result. (In other words, the length
10168 variable is always set to NULL_TREE, because a length is never passed.)
10171 Don't set returned length, since nobody needs it (yet; someday if
10172 we allow CHARACTER*(*) dummies to statement functions, we'll need
10175 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10177 ffecom_arg_expr (ffebld expr, tree *length)
10181 *length = NULL_TREE;
10184 return integer_zero_node;
10186 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10187 return ffecom_expr (expr);
10189 return ffecom_arg_ptr_to_expr (expr, &ign);
10193 /* Transform expression into constant argument-pointer-to-expression tree.
10195 If the expression can be transformed into a argument-pointer-to-expression
10196 tree that is constant, that is done, and the tree returned. Else
10197 NULL_TREE is returned.
10199 That way, a caller can attempt to provide compile-time initialization
10200 of a variable and, if that fails, *then* choose to start a new block
10201 and resort to using temporaries, as appropriate. */
10204 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10207 return integer_zero_node;
10209 if (ffebld_op (expr) == FFEBLD_opANY)
10212 *length = error_mark_node;
10213 return error_mark_node;
10216 if (ffebld_arity (expr) == 0
10217 && (ffebld_op (expr) != FFEBLD_opSYMTER
10218 || ffebld_where (expr) == FFEINFO_whereCOMMON
10219 || ffebld_where (expr) == FFEINFO_whereGLOBAL
10220 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10224 t = ffecom_arg_ptr_to_expr (expr, length);
10225 assert (TREE_CONSTANT (t));
10226 assert (! length || TREE_CONSTANT (*length));
10231 && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10232 *length = build_int_2 (ffebld_size (expr), 0);
10234 *length = NULL_TREE;
10238 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10240 See use by ffecom_list_ptr_to_expr.
10242 If expression is NULL, returns an integer zero tree. If it is not
10243 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10244 returns and sets the length return value to NULL_TREE. Otherwise
10245 generates code to evaluate the character expression, returns the proper
10246 pointer to the result, AND sets the length return value to a tree that
10247 specifies the length of the result.
10249 If the length argument is NULL, this is a slightly special
10250 case of building a FORMAT expression, that is, an expression that
10251 will be used at run time without regard to length. For the current
10252 implementation, which uses the libf2c library, this means it is nice
10253 to append a null byte to the end of the expression, where feasible,
10254 to make sure any diagnostic about the FORMAT string terminates at
10257 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10258 length argument. This might even be seen as a feature, if a null
10259 byte can always be appended. */
10261 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10263 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10267 ffecomConcatList_ catlist;
10269 if (length != NULL)
10270 *length = NULL_TREE;
10273 return integer_zero_node;
10275 switch (ffebld_op (expr))
10277 case FFEBLD_opPERCENT_VAL:
10278 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10279 return ffecom_expr (ffebld_left (expr));
10284 temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10285 if (temp_exp == error_mark_node)
10286 return error_mark_node;
10288 return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10292 case FFEBLD_opPERCENT_REF:
10293 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10294 return ffecom_ptr_to_expr (ffebld_left (expr));
10295 if (length != NULL)
10297 ign_length = NULL_TREE;
10298 length = &ign_length;
10300 expr = ffebld_left (expr);
10303 case FFEBLD_opPERCENT_DESCR:
10304 switch (ffeinfo_basictype (ffebld_info (expr)))
10306 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10307 case FFEINFO_basictypeHOLLERITH:
10309 case FFEINFO_basictypeCHARACTER:
10310 break; /* Passed by descriptor anyway. */
10313 item = ffecom_ptr_to_expr (expr);
10314 if (item != error_mark_node)
10315 *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10324 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10325 if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10326 && (length != NULL))
10327 { /* Pass Hollerith by descriptor. */
10328 ffetargetHollerith h;
10330 assert (ffebld_op (expr) == FFEBLD_opCONTER);
10331 h = ffebld_cu_val_hollerith (ffebld_constant_union
10332 (ffebld_conter (expr)));
10334 = build_int_2 (h.length, 0);
10335 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10339 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10340 return ffecom_ptr_to_expr (expr);
10342 assert (ffeinfo_kindtype (ffebld_info (expr))
10343 == FFEINFO_kindtypeCHARACTER1);
10345 while (ffebld_op (expr) == FFEBLD_opPAREN)
10346 expr = ffebld_left (expr);
10348 catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10349 switch (ffecom_concat_list_count_ (catlist))
10351 case 0: /* Shouldn't happen, but in case it does... */
10352 if (length != NULL)
10354 *length = ffecom_f2c_ftnlen_zero_node;
10355 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10357 ffecom_concat_list_kill_ (catlist);
10358 return null_pointer_node;
10360 case 1: /* The (fairly) easy case. */
10361 if (length == NULL)
10362 ffecom_char_args_with_null_ (&item, &ign_length,
10363 ffecom_concat_list_expr_ (catlist, 0));
10365 ffecom_char_args_ (&item, length,
10366 ffecom_concat_list_expr_ (catlist, 0));
10367 ffecom_concat_list_kill_ (catlist);
10368 assert (item != NULL_TREE);
10371 default: /* Must actually concatenate things. */
10376 int count = ffecom_concat_list_count_ (catlist);
10387 ffetargetCharacterSize sz;
10389 sz = ffecom_concat_list_maxlen_ (catlist);
10391 assert (sz != FFETARGET_charactersizeNONE);
10396 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10397 FFETARGET_charactersizeNONE, count, TRUE);
10400 = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10401 FFETARGET_charactersizeNONE, count, TRUE);
10402 temporary = ffecom_push_tempvar (char_type_node,
10408 hook = ffebld_nonter_hook (expr);
10410 assert (TREE_CODE (hook) == TREE_VEC);
10411 assert (TREE_VEC_LENGTH (hook) == 3);
10412 length_array = lengths = TREE_VEC_ELT (hook, 0);
10413 item_array = items = TREE_VEC_ELT (hook, 1);
10414 temporary = TREE_VEC_ELT (hook, 2);
10418 known_length = ffecom_f2c_ftnlen_zero_node;
10420 for (i = 0; i < count; ++i)
10423 && (length == NULL))
10424 ffecom_char_args_with_null_ (&citem, &clength,
10425 ffecom_concat_list_expr_ (catlist, i));
10427 ffecom_char_args_ (&citem, &clength,
10428 ffecom_concat_list_expr_ (catlist, i));
10429 if ((citem == error_mark_node)
10430 || (clength == error_mark_node))
10432 ffecom_concat_list_kill_ (catlist);
10433 *length = error_mark_node;
10434 return error_mark_node;
10438 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10439 ffecom_modify (void_type_node,
10440 ffecom_2 (ARRAY_REF,
10441 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10443 build_int_2 (i, 0)),
10446 clength = ffecom_save_tree (clength);
10447 if (length != NULL)
10449 = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10453 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10454 ffecom_modify (void_type_node,
10455 ffecom_2 (ARRAY_REF,
10456 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10458 build_int_2 (i, 0)),
10463 temporary = ffecom_1 (ADDR_EXPR,
10464 build_pointer_type (TREE_TYPE (temporary)),
10467 item = build_tree_list (NULL_TREE, temporary);
10469 = build_tree_list (NULL_TREE,
10470 ffecom_1 (ADDR_EXPR,
10471 build_pointer_type (TREE_TYPE (items)),
10473 TREE_CHAIN (TREE_CHAIN (item))
10474 = build_tree_list (NULL_TREE,
10475 ffecom_1 (ADDR_EXPR,
10476 build_pointer_type (TREE_TYPE (lengths)),
10478 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10481 ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10482 convert (ffecom_f2c_ftnlen_type_node,
10483 build_int_2 (count, 0))));
10484 num = build_int_2 (sz, 0);
10485 TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10486 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10487 = build_tree_list (NULL_TREE, num);
10489 item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10490 TREE_SIDE_EFFECTS (item) = 1;
10491 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10495 if (length != NULL)
10496 *length = known_length;
10499 ffecom_concat_list_kill_ (catlist);
10500 assert (item != NULL_TREE);
10505 /* Generate call to run-time function.
10507 The first arg is the GNU Fortran Run-Time function index, the second
10508 arg is the list of arguments to pass to it. Returned is the expression
10509 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10510 result (which may be void). */
10512 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10514 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10516 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10517 ffecom_gfrt_kindtype (ix),
10518 ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10519 NULL_TREE, args, NULL_TREE, NULL,
10520 NULL, NULL_TREE, TRUE, hook);
10524 /* Transform constant-union to tree. */
10526 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10528 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10529 ffeinfoKindtype kt, tree tree_type)
10535 case FFEINFO_basictypeINTEGER:
10541 #if FFETARGET_okINTEGER1
10542 case FFEINFO_kindtypeINTEGER1:
10543 val = ffebld_cu_val_integer1 (*cu);
10547 #if FFETARGET_okINTEGER2
10548 case FFEINFO_kindtypeINTEGER2:
10549 val = ffebld_cu_val_integer2 (*cu);
10553 #if FFETARGET_okINTEGER3
10554 case FFEINFO_kindtypeINTEGER3:
10555 val = ffebld_cu_val_integer3 (*cu);
10559 #if FFETARGET_okINTEGER4
10560 case FFEINFO_kindtypeINTEGER4:
10561 val = ffebld_cu_val_integer4 (*cu);
10566 assert ("bad INTEGER constant kind type" == NULL);
10567 /* Fall through. */
10568 case FFEINFO_kindtypeANY:
10569 return error_mark_node;
10571 item = build_int_2 (val, (val < 0) ? -1 : 0);
10572 TREE_TYPE (item) = tree_type;
10576 case FFEINFO_basictypeLOGICAL:
10582 #if FFETARGET_okLOGICAL1
10583 case FFEINFO_kindtypeLOGICAL1:
10584 val = ffebld_cu_val_logical1 (*cu);
10588 #if FFETARGET_okLOGICAL2
10589 case FFEINFO_kindtypeLOGICAL2:
10590 val = ffebld_cu_val_logical2 (*cu);
10594 #if FFETARGET_okLOGICAL3
10595 case FFEINFO_kindtypeLOGICAL3:
10596 val = ffebld_cu_val_logical3 (*cu);
10600 #if FFETARGET_okLOGICAL4
10601 case FFEINFO_kindtypeLOGICAL4:
10602 val = ffebld_cu_val_logical4 (*cu);
10607 assert ("bad LOGICAL constant kind type" == NULL);
10608 /* Fall through. */
10609 case FFEINFO_kindtypeANY:
10610 return error_mark_node;
10612 item = build_int_2 (val, (val < 0) ? -1 : 0);
10613 TREE_TYPE (item) = tree_type;
10617 case FFEINFO_basictypeREAL:
10619 REAL_VALUE_TYPE val;
10623 #if FFETARGET_okREAL1
10624 case FFEINFO_kindtypeREAL1:
10625 val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10629 #if FFETARGET_okREAL2
10630 case FFEINFO_kindtypeREAL2:
10631 val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10635 #if FFETARGET_okREAL3
10636 case FFEINFO_kindtypeREAL3:
10637 val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10641 #if FFETARGET_okREAL4
10642 case FFEINFO_kindtypeREAL4:
10643 val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10648 assert ("bad REAL constant kind type" == NULL);
10649 /* Fall through. */
10650 case FFEINFO_kindtypeANY:
10651 return error_mark_node;
10653 item = build_real (tree_type, val);
10657 case FFEINFO_basictypeCOMPLEX:
10659 REAL_VALUE_TYPE real;
10660 REAL_VALUE_TYPE imag;
10661 tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10665 #if FFETARGET_okCOMPLEX1
10666 case FFEINFO_kindtypeREAL1:
10667 real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10668 imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10672 #if FFETARGET_okCOMPLEX2
10673 case FFEINFO_kindtypeREAL2:
10674 real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10675 imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10679 #if FFETARGET_okCOMPLEX3
10680 case FFEINFO_kindtypeREAL3:
10681 real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10682 imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10686 #if FFETARGET_okCOMPLEX4
10687 case FFEINFO_kindtypeREAL4:
10688 real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10689 imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10694 assert ("bad REAL constant kind type" == NULL);
10695 /* Fall through. */
10696 case FFEINFO_kindtypeANY:
10697 return error_mark_node;
10699 item = ffecom_build_complex_constant_ (tree_type,
10700 build_real (el_type, real),
10701 build_real (el_type, imag));
10705 case FFEINFO_basictypeCHARACTER:
10706 { /* Happens only in DATA and similar contexts. */
10707 ffetargetCharacter1 val;
10711 #if FFETARGET_okCHARACTER1
10712 case FFEINFO_kindtypeLOGICAL1:
10713 val = ffebld_cu_val_character1 (*cu);
10718 assert ("bad CHARACTER constant kind type" == NULL);
10719 /* Fall through. */
10720 case FFEINFO_kindtypeANY:
10721 return error_mark_node;
10723 item = build_string (ffetarget_length_character1 (val),
10724 ffetarget_text_character1 (val));
10726 = build_type_variant (build_array_type (char_type_node,
10728 (integer_type_node,
10731 (ffetarget_length_character1
10737 case FFEINFO_basictypeHOLLERITH:
10739 ffetargetHollerith h;
10741 h = ffebld_cu_val_hollerith (*cu);
10743 /* If not at least as wide as default INTEGER, widen it. */
10744 if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10745 item = build_string (h.length, h.text);
10748 char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10750 memcpy (str, h.text, h.length);
10751 memset (&str[h.length], ' ',
10752 FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10754 item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10758 = build_type_variant (build_array_type (char_type_node,
10760 (integer_type_node,
10768 case FFEINFO_basictypeTYPELESS:
10770 ffetargetInteger1 ival;
10771 ffetargetTypeless tless;
10774 tless = ffebld_cu_val_typeless (*cu);
10775 error = ffetarget_convert_integer1_typeless (&ival, tless);
10776 assert (error == FFEBAD);
10778 item = build_int_2 ((int) ival, 0);
10783 assert ("not yet on constant type" == NULL);
10784 /* Fall through. */
10785 case FFEINFO_basictypeANY:
10786 return error_mark_node;
10789 TREE_CONSTANT (item) = 1;
10796 /* Transform expression into constant tree.
10798 If the expression can be transformed into a tree that is constant,
10799 that is done, and the tree returned. Else NULL_TREE is returned.
10801 That way, a caller can attempt to provide compile-time initialization
10802 of a variable and, if that fails, *then* choose to start a new block
10803 and resort to using temporaries, as appropriate. */
10806 ffecom_const_expr (ffebld expr)
10809 return integer_zero_node;
10811 if (ffebld_op (expr) == FFEBLD_opANY)
10812 return error_mark_node;
10814 if (ffebld_arity (expr) == 0
10815 && (ffebld_op (expr) != FFEBLD_opSYMTER
10817 /* ~~Enable once common/equivalence is handled properly? */
10818 || ffebld_where (expr) == FFEINFO_whereCOMMON
10820 || ffebld_where (expr) == FFEINFO_whereGLOBAL
10821 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10825 t = ffecom_expr (expr);
10826 assert (TREE_CONSTANT (t));
10833 /* Handy way to make a field in a struct/union. */
10835 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10837 ffecom_decl_field (tree context, tree prevfield,
10838 const char *name, tree type)
10842 field = build_decl (FIELD_DECL, get_identifier (name), type);
10843 DECL_CONTEXT (field) = context;
10844 DECL_ALIGN (field) = 0;
10845 DECL_USER_ALIGN (field) = 0;
10846 if (prevfield != NULL_TREE)
10847 TREE_CHAIN (prevfield) = field;
10855 ffecom_close_include (FILE *f)
10857 #if FFECOM_GCC_INCLUDE
10858 ffecom_close_include_ (f);
10863 ffecom_decode_include_option (char *spec)
10865 #if FFECOM_GCC_INCLUDE
10866 return ffecom_decode_include_option_ (spec);
10872 /* End a compound statement (block). */
10874 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10876 ffecom_end_compstmt (void)
10878 return bison_rule_compstmt_ ();
10880 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
10882 /* ffecom_end_transition -- Perform end transition on all symbols
10884 ffecom_end_transition();
10886 Calls ffecom_sym_end_transition for each global and local symbol. */
10889 ffecom_end_transition ()
10891 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10895 if (ffe_is_ffedebug ())
10896 fprintf (dmpout, "; end_stmt_transition\n");
10898 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10899 ffecom_list_blockdata_ = NULL;
10900 ffecom_list_common_ = NULL;
10903 ffesymbol_drive (ffecom_sym_end_transition);
10904 if (ffe_is_ffedebug ())
10906 ffestorag_report ();
10907 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10908 ffesymbol_report_all ();
10912 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10913 ffecom_start_progunit_ ();
10915 for (item = ffecom_list_blockdata_;
10917 item = ffebld_trail (item))
10924 static int number = 0;
10926 callee = ffebld_head (item);
10927 s = ffebld_symter (callee);
10928 t = ffesymbol_hook (s).decl_tree;
10929 if (t == NULL_TREE)
10931 s = ffecom_sym_transform_ (s);
10932 t = ffesymbol_hook (s).decl_tree;
10935 dt = build_pointer_type (TREE_TYPE (t));
10937 var = build_decl (VAR_DECL,
10938 ffecom_get_invented_identifier ("__g77_forceload_%d",
10941 DECL_EXTERNAL (var) = 0;
10942 TREE_STATIC (var) = 1;
10943 TREE_PUBLIC (var) = 0;
10944 DECL_INITIAL (var) = error_mark_node;
10945 TREE_USED (var) = 1;
10947 var = start_decl (var, FALSE);
10949 t = ffecom_1 (ADDR_EXPR, dt, t);
10951 finish_decl (var, t, FALSE);
10954 /* This handles any COMMON areas that weren't referenced but have, for
10955 example, important initial data. */
10957 for (item = ffecom_list_common_;
10959 item = ffebld_trail (item))
10960 ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
10962 ffecom_list_common_ = NULL;
10966 /* ffecom_exec_transition -- Perform exec transition on all symbols
10968 ffecom_exec_transition();
10970 Calls ffecom_sym_exec_transition for each global and local symbol.
10971 Make sure error updating not inhibited. */
10974 ffecom_exec_transition ()
10978 if (ffe_is_ffedebug ())
10979 fprintf (dmpout, "; exec_stmt_transition\n");
10981 inhibited = ffebad_inhibit ();
10982 ffebad_set_inhibit (FALSE);
10984 ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
10985 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
10986 if (ffe_is_ffedebug ())
10988 ffestorag_report ();
10989 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10990 ffesymbol_report_all ();
10995 ffebad_set_inhibit (TRUE);
10998 /* Handle assignment statement.
11000 Convert dest and source using ffecom_expr, then join them
11001 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
11003 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11005 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11012 if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11017 /* This attempts to replicate the test below, but must not be
11018 true when the test below is false. (Always err on the side
11019 of creating unused temporaries, to avoid ICEs.) */
11020 if (ffebld_op (dest) != FFEBLD_opSYMTER
11021 || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11022 && (TREE_CODE (dest_tree) != VAR_DECL
11023 || TREE_ADDRESSABLE (dest_tree))))
11025 ffecom_prepare_expr_ (source, dest);
11030 ffecom_prepare_expr_ (source, NULL);
11034 ffecom_prepare_expr_w (NULL_TREE, dest);
11036 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11037 create a temporary through which the assignment is to take place,
11038 since MODIFY_EXPR doesn't handle partial overlap properly. */
11039 if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11040 && ffecom_possible_partial_overlap_ (dest, source))
11042 assign_temp = ffecom_make_tempvar ("complex_let",
11044 [ffebld_basictype (dest)]
11045 [ffebld_kindtype (dest)],
11046 FFETARGET_charactersizeNONE,
11050 assign_temp = NULL_TREE;
11052 ffecom_prepare_end ();
11054 dest_tree = ffecom_expr_w (NULL_TREE, dest);
11055 if (dest_tree == error_mark_node)
11058 if ((TREE_CODE (dest_tree) != VAR_DECL)
11059 || TREE_ADDRESSABLE (dest_tree))
11060 source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11064 assert (! dest_used);
11066 source_tree = ffecom_expr (source);
11068 if (source_tree == error_mark_node)
11072 expr_tree = source_tree;
11073 else if (assign_temp)
11076 /* The back end understands a conceptual move (evaluate source;
11077 store into dest), so use that, in case it can determine
11078 that it is going to use, say, two registers as temporaries
11079 anyway. So don't use the temp (and someday avoid generating
11080 it, once this code starts triggering regularly). */
11081 expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11085 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11088 expand_expr_stmt (expr_tree);
11089 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11095 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11099 expand_expr_stmt (expr_tree);
11103 ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11104 ffecom_prepare_expr_w (NULL_TREE, dest);
11106 ffecom_prepare_end ();
11108 ffecom_char_args_ (&dest_tree, &dest_length, dest);
11109 ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11114 /* ffecom_expr -- Transform expr into gcc tree
11117 ffebld expr; // FFE expression.
11118 tree = ffecom_expr(expr);
11120 Recursive descent on expr while making corresponding tree nodes and
11121 attaching type info and such. */
11123 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11125 ffecom_expr (ffebld expr)
11127 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11131 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
11133 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11135 ffecom_expr_assign (ffebld expr)
11137 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11141 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
11143 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11145 ffecom_expr_assign_w (ffebld expr)
11147 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11151 /* Transform expr for use as into read/write tree and stabilize the
11152 reference. Not for use on CHARACTER expressions.
11154 Recursive descent on expr while making corresponding tree nodes and
11155 attaching type info and such. */
11157 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11159 ffecom_expr_rw (tree type, ffebld expr)
11161 assert (expr != NULL);
11162 /* Different target types not yet supported. */
11163 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11165 return stabilize_reference (ffecom_expr (expr));
11169 /* Transform expr for use as into write tree and stabilize the
11170 reference. Not for use on CHARACTER expressions.
11172 Recursive descent on expr while making corresponding tree nodes and
11173 attaching type info and such. */
11175 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11177 ffecom_expr_w (tree type, ffebld expr)
11179 assert (expr != NULL);
11180 /* Different target types not yet supported. */
11181 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11183 return stabilize_reference (ffecom_expr (expr));
11187 /* Do global stuff. */
11189 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11191 ffecom_finish_compile ()
11193 assert (ffecom_outer_function_decl_ == NULL_TREE);
11194 assert (current_function_decl == NULL_TREE);
11196 ffeglobal_drive (ffecom_finish_global_);
11200 /* Public entry point for front end to access finish_decl. */
11202 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11204 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11206 assert (!is_top_level);
11207 finish_decl (decl, init, FALSE);
11211 /* Finish a program unit. */
11213 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11215 ffecom_finish_progunit ()
11217 ffecom_end_compstmt ();
11219 ffecom_previous_function_decl_ = current_function_decl;
11220 ffecom_which_entrypoint_decl_ = NULL_TREE;
11222 finish_function (0);
11227 /* Wrapper for get_identifier. pattern is sprintf-like. */
11229 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11231 ffecom_get_invented_identifier (const char *pattern, ...)
11237 va_start (ap, pattern);
11238 if (vasprintf (&nam, pattern, ap) == 0)
11241 decl = get_identifier (nam);
11243 IDENTIFIER_INVENTED (decl) = 1;
11248 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11250 assert (gfrt < FFECOM_gfrt);
11252 switch (ffecom_gfrt_type_[gfrt])
11254 case FFECOM_rttypeVOID_:
11255 case FFECOM_rttypeVOIDSTAR_:
11256 return FFEINFO_basictypeNONE;
11258 case FFECOM_rttypeFTNINT_:
11259 return FFEINFO_basictypeINTEGER;
11261 case FFECOM_rttypeINTEGER_:
11262 return FFEINFO_basictypeINTEGER;
11264 case FFECOM_rttypeLONGINT_:
11265 return FFEINFO_basictypeINTEGER;
11267 case FFECOM_rttypeLOGICAL_:
11268 return FFEINFO_basictypeLOGICAL;
11270 case FFECOM_rttypeREAL_F2C_:
11271 case FFECOM_rttypeREAL_GNU_:
11272 return FFEINFO_basictypeREAL;
11274 case FFECOM_rttypeCOMPLEX_F2C_:
11275 case FFECOM_rttypeCOMPLEX_GNU_:
11276 return FFEINFO_basictypeCOMPLEX;
11278 case FFECOM_rttypeDOUBLE_:
11279 case FFECOM_rttypeDOUBLEREAL_:
11280 return FFEINFO_basictypeREAL;
11282 case FFECOM_rttypeDBLCMPLX_F2C_:
11283 case FFECOM_rttypeDBLCMPLX_GNU_:
11284 return FFEINFO_basictypeCOMPLEX;
11286 case FFECOM_rttypeCHARACTER_:
11287 return FFEINFO_basictypeCHARACTER;
11290 return FFEINFO_basictypeANY;
11295 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11297 assert (gfrt < FFECOM_gfrt);
11299 switch (ffecom_gfrt_type_[gfrt])
11301 case FFECOM_rttypeVOID_:
11302 case FFECOM_rttypeVOIDSTAR_:
11303 return FFEINFO_kindtypeNONE;
11305 case FFECOM_rttypeFTNINT_:
11306 return FFEINFO_kindtypeINTEGER1;
11308 case FFECOM_rttypeINTEGER_:
11309 return FFEINFO_kindtypeINTEGER1;
11311 case FFECOM_rttypeLONGINT_:
11312 return FFEINFO_kindtypeINTEGER4;
11314 case FFECOM_rttypeLOGICAL_:
11315 return FFEINFO_kindtypeLOGICAL1;
11317 case FFECOM_rttypeREAL_F2C_:
11318 case FFECOM_rttypeREAL_GNU_:
11319 return FFEINFO_kindtypeREAL1;
11321 case FFECOM_rttypeCOMPLEX_F2C_:
11322 case FFECOM_rttypeCOMPLEX_GNU_:
11323 return FFEINFO_kindtypeREAL1;
11325 case FFECOM_rttypeDOUBLE_:
11326 case FFECOM_rttypeDOUBLEREAL_:
11327 return FFEINFO_kindtypeREAL2;
11329 case FFECOM_rttypeDBLCMPLX_F2C_:
11330 case FFECOM_rttypeDBLCMPLX_GNU_:
11331 return FFEINFO_kindtypeREAL2;
11333 case FFECOM_rttypeCHARACTER_:
11334 return FFEINFO_kindtypeCHARACTER1;
11337 return FFEINFO_kindtypeANY;
11351 tree double_ftype_double;
11352 tree float_ftype_float;
11353 tree ldouble_ftype_ldouble;
11354 tree ffecom_tree_ptr_to_fun_type_void;
11356 /* This block of code comes from the now-obsolete cktyps.c. It checks
11357 whether the compiler environment is buggy in known ways, some of which
11358 would, if not explicitly checked here, result in subtle bugs in g77. */
11360 if (ffe_is_do_internal_checks ())
11362 static char names[][12]
11364 {"bar", "bletch", "foo", "foobar"};
11369 name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11370 (int (*)(const void *, const void *)) strcmp);
11371 if (name != (char *) &names[2])
11373 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11378 ul = strtoul ("123456789", NULL, 10);
11379 if (ul != 123456789L)
11381 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11382 in proj.h" == NULL);
11386 fl = atof ("56.789");
11387 if ((fl < 56.788) || (fl > 56.79))
11389 assert ("atof not type double, fix your #include <stdio.h>"
11395 #if FFECOM_GCC_INCLUDE
11396 ffecom_initialize_char_syntax_ ();
11399 ffecom_outer_function_decl_ = NULL_TREE;
11400 current_function_decl = NULL_TREE;
11401 named_labels = NULL_TREE;
11402 current_binding_level = NULL_BINDING_LEVEL;
11403 free_binding_level = NULL_BINDING_LEVEL;
11404 /* Make the binding_level structure for global names. */
11406 global_binding_level = current_binding_level;
11407 current_binding_level->prep_state = 2;
11409 build_common_tree_nodes (1);
11411 /* Define `int' and `char' first so that dbx will output them first. */
11412 pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11413 integer_type_node));
11414 pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11416 pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11417 long_integer_type_node));
11418 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11419 unsigned_type_node));
11420 pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11421 long_unsigned_type_node));
11422 pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11423 long_long_integer_type_node));
11424 pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11425 long_long_unsigned_type_node));
11426 pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11427 short_integer_type_node));
11428 pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11429 short_unsigned_type_node));
11431 /* Set the sizetype before we make other types. This *should* be the
11432 first type we create. */
11435 (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11436 ffecom_typesize_pointer_
11437 = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11439 build_common_tree_nodes_2 (0);
11441 /* Define both `signed char' and `unsigned char'. */
11442 pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11443 signed_char_type_node));
11445 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11446 unsigned_char_type_node));
11448 pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11450 pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11451 double_type_node));
11452 pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11453 long_double_type_node));
11455 /* For now, override what build_common_tree_nodes has done. */
11456 complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11457 complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11458 complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11459 complex_long_double_type_node
11460 = ffecom_make_complex_type_ (long_double_type_node);
11462 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11463 complex_integer_type_node));
11464 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11465 complex_float_type_node));
11466 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11467 complex_double_type_node));
11468 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11469 complex_long_double_type_node));
11471 pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11473 /* We are not going to have real types in C with less than byte alignment,
11474 so we might as well not have any types that claim to have it. */
11475 TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11476 TYPE_USER_ALIGN (void_type_node) = 0;
11478 string_type_node = build_pointer_type (char_type_node);
11480 ffecom_tree_fun_type_void
11481 = build_function_type (void_type_node, NULL_TREE);
11483 ffecom_tree_ptr_to_fun_type_void
11484 = build_pointer_type (ffecom_tree_fun_type_void);
11486 endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11489 = build_function_type (float_type_node,
11490 tree_cons (NULL_TREE, float_type_node, endlink));
11492 double_ftype_double
11493 = build_function_type (double_type_node,
11494 tree_cons (NULL_TREE, double_type_node, endlink));
11496 ldouble_ftype_ldouble
11497 = build_function_type (long_double_type_node,
11498 tree_cons (NULL_TREE, long_double_type_node,
11501 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11502 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11504 ffecom_tree_type[i][j] = NULL_TREE;
11505 ffecom_tree_fun_type[i][j] = NULL_TREE;
11506 ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11507 ffecom_f2c_typecode_[i][j] = -1;
11510 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11511 to size FLOAT_TYPE_SIZE because they have to be the same size as
11512 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11513 Compiler options and other such stuff that change the ways these
11514 types are set should not affect this particular setup. */
11516 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11517 = t = make_signed_type (FLOAT_TYPE_SIZE);
11518 pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11520 type = ffetype_new ();
11522 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11524 ffetype_set_ams (type,
11525 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11526 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11527 ffetype_set_star (base_type,
11528 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11530 ffetype_set_kind (base_type, 1, type);
11531 ffecom_typesize_integer1_ = ffetype_size (type);
11532 assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11534 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11535 = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11536 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11539 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11540 = t = make_signed_type (CHAR_TYPE_SIZE);
11541 pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11543 type = ffetype_new ();
11544 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
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,
11552 ffetype_set_kind (base_type, 3, type);
11553 assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11555 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11556 = t = make_unsigned_type (CHAR_TYPE_SIZE);
11557 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11560 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11561 = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11562 pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11564 type = ffetype_new ();
11565 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
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,
11573 ffetype_set_kind (base_type, 6, type);
11574 assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11576 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11577 = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11578 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11581 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11582 = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11583 pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11585 type = ffetype_new ();
11586 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11588 ffetype_set_ams (type,
11589 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11590 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11591 ffetype_set_star (base_type,
11592 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11594 ffetype_set_kind (base_type, 2, type);
11595 assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11597 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11598 = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11599 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11603 if (ffe_is_do_internal_checks ()
11604 && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11605 && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11606 && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11607 && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11609 fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11614 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11615 = t = make_signed_type (FLOAT_TYPE_SIZE);
11616 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11618 type = ffetype_new ();
11620 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11622 ffetype_set_ams (type,
11623 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11624 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11625 ffetype_set_star (base_type,
11626 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11628 ffetype_set_kind (base_type, 1, type);
11629 assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11631 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11632 = t = make_signed_type (CHAR_TYPE_SIZE);
11633 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11635 type = ffetype_new ();
11636 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11638 ffetype_set_ams (type,
11639 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11640 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11641 ffetype_set_star (base_type,
11642 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11644 ffetype_set_kind (base_type, 3, type);
11645 assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11647 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11648 = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11649 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11651 type = ffetype_new ();
11652 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11654 ffetype_set_ams (type,
11655 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11656 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11657 ffetype_set_star (base_type,
11658 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11660 ffetype_set_kind (base_type, 6, type);
11661 assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11663 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11664 = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11665 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11667 type = ffetype_new ();
11668 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11670 ffetype_set_ams (type,
11671 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11672 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11673 ffetype_set_star (base_type,
11674 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11676 ffetype_set_kind (base_type, 2, type);
11677 assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11679 ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11680 = t = make_node (REAL_TYPE);
11681 TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11682 pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11685 type = ffetype_new ();
11687 ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11689 ffetype_set_ams (type,
11690 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11691 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11692 ffetype_set_star (base_type,
11693 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11695 ffetype_set_kind (base_type, 1, type);
11696 ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11697 = FFETARGET_f2cTYREAL;
11698 assert (ffetype_size (type) == sizeof (ffetargetReal1));
11700 ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11701 = t = make_node (REAL_TYPE);
11702 TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2; /* Always twice REAL. */
11703 pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11706 type = ffetype_new ();
11707 ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11709 ffetype_set_ams (type,
11710 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11711 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11712 ffetype_set_star (base_type,
11713 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11715 ffetype_set_kind (base_type, 2, type);
11716 ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11717 = FFETARGET_f2cTYDREAL;
11718 assert (ffetype_size (type) == sizeof (ffetargetReal2));
11720 ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11721 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11722 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11724 type = ffetype_new ();
11726 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11728 ffetype_set_ams (type,
11729 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11730 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11731 ffetype_set_star (base_type,
11732 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11734 ffetype_set_kind (base_type, 1, type);
11735 ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11736 = FFETARGET_f2cTYCOMPLEX;
11737 assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11739 ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11740 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11741 pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11743 type = ffetype_new ();
11744 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11746 ffetype_set_ams (type,
11747 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11748 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11749 ffetype_set_star (base_type,
11750 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11752 ffetype_set_kind (base_type, 2,
11754 ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11755 = FFETARGET_f2cTYDCOMPLEX;
11756 assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11758 /* Make function and ptr-to-function types for non-CHARACTER types. */
11760 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11761 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11763 if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11765 if (i == FFEINFO_basictypeINTEGER)
11767 /* Figure out the smallest INTEGER type that can hold
11768 a pointer on this machine. */
11769 if (GET_MODE_SIZE (TYPE_MODE (t))
11770 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11772 if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11773 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11774 > GET_MODE_SIZE (TYPE_MODE (t))))
11775 ffecom_pointer_kind_ = j;
11778 else if (i == FFEINFO_basictypeCOMPLEX)
11779 t = void_type_node;
11780 /* For f2c compatibility, REAL functions are really
11781 implemented as DOUBLE PRECISION. */
11782 else if ((i == FFEINFO_basictypeREAL)
11783 && (j == FFEINFO_kindtypeREAL1))
11784 t = ffecom_tree_type
11785 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11787 t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11789 ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11793 /* Set up pointer types. */
11795 if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11796 fatal_error ("no INTEGER type can hold a pointer on this configuration");
11797 else if (0 && ffe_is_do_internal_checks ())
11798 fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11799 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11800 FFEINFO_kindtypeINTEGERDEFAULT),
11802 ffeinfo_type (FFEINFO_basictypeINTEGER,
11803 ffecom_pointer_kind_));
11805 if (ffe_is_ugly_assign ())
11806 ffecom_label_kind_ = ffecom_pointer_kind_; /* Require ASSIGN etc to this. */
11808 ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11809 if (0 && ffe_is_do_internal_checks ())
11810 fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11812 ffecom_integer_type_node
11813 = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11814 ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11815 integer_zero_node);
11816 ffecom_integer_one_node = convert (ffecom_integer_type_node,
11819 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11820 Turns out that by TYLONG, runtime/libI77/lio.h really means
11821 "whatever size an ftnint is". For consistency and sanity,
11822 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11823 all are INTEGER, which we also make out of whatever back-end
11824 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11825 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11826 accommodate machines like the Alpha. Note that this suggests
11827 f2c and libf2c are missing a distinction perhaps needed on
11828 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11830 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11831 FFETARGET_f2cTYLONG);
11832 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11833 FFETARGET_f2cTYSHORT);
11834 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11835 FFETARGET_f2cTYINT1);
11836 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11837 FFETARGET_f2cTYQUAD);
11838 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11839 FFETARGET_f2cTYLOGICAL);
11840 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11841 FFETARGET_f2cTYLOGICAL2);
11842 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11843 FFETARGET_f2cTYLOGICAL1);
11844 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11845 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11846 FFETARGET_f2cTYQUAD);
11848 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11849 loop. CHARACTER items are built as arrays of unsigned char. */
11851 ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11852 [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11853 type = ffetype_new ();
11855 ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11856 FFEINFO_kindtypeCHARACTER1,
11858 ffetype_set_ams (type,
11859 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11860 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11861 ffetype_set_kind (base_type, 1, type);
11862 assert (ffetype_size (type)
11863 == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11865 ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11866 [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11867 ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11868 [FFEINFO_kindtypeCHARACTER1]
11869 = ffecom_tree_ptr_to_fun_type_void;
11870 ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11871 = FFETARGET_f2cTYCHAR;
11873 ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11876 /* Make multi-return-value type and fields. */
11878 ffecom_multi_type_node_ = make_node (UNION_TYPE);
11882 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11883 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11887 if (ffecom_tree_type[i][j] == NULL_TREE)
11888 continue; /* Not supported. */
11889 sprintf (&name[0], "bt_%s_kt_%s",
11890 ffeinfo_basictype_string ((ffeinfoBasictype) i),
11891 ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11892 ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11893 get_identifier (name),
11894 ffecom_tree_type[i][j]);
11895 DECL_CONTEXT (ffecom_multi_fields_[i][j])
11896 = ffecom_multi_type_node_;
11897 DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11898 DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11899 TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11900 field = ffecom_multi_fields_[i][j];
11903 TYPE_FIELDS (ffecom_multi_type_node_) = field;
11904 layout_type (ffecom_multi_type_node_);
11906 /* Subroutines usually return integer because they might have alternate
11909 ffecom_tree_subr_type
11910 = build_function_type (integer_type_node, NULL_TREE);
11911 ffecom_tree_ptr_to_subr_type
11912 = build_pointer_type (ffecom_tree_subr_type);
11913 ffecom_tree_blockdata_type
11914 = build_function_type (void_type_node, NULL_TREE);
11916 builtin_function ("__builtin_sqrtf", float_ftype_float,
11917 BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
11918 builtin_function ("__builtin_fsqrt", double_ftype_double,
11919 BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
11920 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11921 BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
11922 builtin_function ("__builtin_sinf", float_ftype_float,
11923 BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
11924 builtin_function ("__builtin_sin", double_ftype_double,
11925 BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11926 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11927 BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
11928 builtin_function ("__builtin_cosf", float_ftype_float,
11929 BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
11930 builtin_function ("__builtin_cos", double_ftype_double,
11931 BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11932 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11933 BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
11936 pedantic_lvalues = FALSE;
11939 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
11942 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
11945 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
11948 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
11949 FFECOM_f2cDOUBLEREAL,
11951 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
11954 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
11955 FFECOM_f2cDOUBLECOMPLEX,
11957 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
11960 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
11963 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
11966 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
11969 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
11973 ffecom_f2c_ftnlen_zero_node
11974 = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
11976 ffecom_f2c_ftnlen_one_node
11977 = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
11979 ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
11980 TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
11982 ffecom_f2c_ptr_to_ftnlen_type_node
11983 = build_pointer_type (ffecom_f2c_ftnlen_type_node);
11985 ffecom_f2c_ptr_to_ftnint_type_node
11986 = build_pointer_type (ffecom_f2c_ftnint_type_node);
11988 ffecom_f2c_ptr_to_integer_type_node
11989 = build_pointer_type (ffecom_f2c_integer_type_node);
11991 ffecom_f2c_ptr_to_real_type_node
11992 = build_pointer_type (ffecom_f2c_real_type_node);
11994 ffecom_float_zero_ = build_real (float_type_node, dconst0);
11995 ffecom_double_zero_ = build_real (double_type_node, dconst0);
11997 REAL_VALUE_TYPE point_5;
11999 #ifdef REAL_ARITHMETIC
12000 REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12004 ffecom_float_half_ = build_real (float_type_node, point_5);
12005 ffecom_double_half_ = build_real (double_type_node, point_5);
12008 /* Do "extern int xargc;". */
12010 ffecom_tree_xargc_ = build_decl (VAR_DECL,
12011 get_identifier ("f__xargc"),
12012 integer_type_node);
12013 DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12014 TREE_STATIC (ffecom_tree_xargc_) = 1;
12015 TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12016 ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12017 finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12019 #if 0 /* This is being fixed, and seems to be working now. */
12020 if ((FLOAT_TYPE_SIZE != 32)
12021 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12023 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12024 (int) FLOAT_TYPE_SIZE);
12025 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12026 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12027 warning ("properly unless they all are 32 bits wide.");
12028 warning ("Please keep this in mind before you report bugs. g77 should");
12029 warning ("support non-32-bit machines better as of version 0.6.");
12033 #if 0 /* Code in ste.c that would crash has been commented out. */
12034 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12035 < TYPE_PRECISION (string_type_node))
12036 /* I/O will probably crash. */
12037 warning ("configuration: char * holds %d bits, but ftnlen only %d",
12038 TYPE_PRECISION (string_type_node),
12039 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12042 #if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
12043 if (TYPE_PRECISION (ffecom_integer_type_node)
12044 < TYPE_PRECISION (string_type_node))
12045 /* ASSIGN 10 TO I will crash. */
12046 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12047 ASSIGN statement might fail",
12048 TYPE_PRECISION (string_type_node),
12049 TYPE_PRECISION (ffecom_integer_type_node));
12054 /* ffecom_init_2 -- Initialize
12056 ffecom_init_2(); */
12058 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12062 assert (ffecom_outer_function_decl_ == NULL_TREE);
12063 assert (current_function_decl == NULL_TREE);
12064 assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12066 ffecom_master_arglist_ = NULL;
12068 ffecom_primary_entry_ = NULL;
12069 ffecom_is_altreturning_ = FALSE;
12070 ffecom_func_result_ = NULL_TREE;
12071 ffecom_multi_retval_ = NULL_TREE;
12075 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12078 ffebld expr; // FFE opITEM list.
12079 tree = ffecom_list_expr(expr);
12081 List of actual args is transformed into corresponding gcc backend list. */
12083 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12085 ffecom_list_expr (ffebld expr)
12088 tree *plist = &list;
12089 tree trail = NULL_TREE; /* Append char length args here. */
12090 tree *ptrail = &trail;
12093 while (expr != NULL)
12095 tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12097 if (texpr == error_mark_node)
12098 return error_mark_node;
12100 *plist = build_tree_list (NULL_TREE, texpr);
12101 plist = &TREE_CHAIN (*plist);
12102 expr = ffebld_trail (expr);
12103 if (length != NULL_TREE)
12105 *ptrail = build_tree_list (NULL_TREE, length);
12106 ptrail = &TREE_CHAIN (*ptrail);
12116 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12119 ffebld expr; // FFE opITEM list.
12120 tree = ffecom_list_ptr_to_expr(expr);
12122 List of actual args is transformed into corresponding gcc backend list for
12123 use in calling an external procedure (vs. a statement function). */
12125 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12127 ffecom_list_ptr_to_expr (ffebld expr)
12130 tree *plist = &list;
12131 tree trail = NULL_TREE; /* Append char length args here. */
12132 tree *ptrail = &trail;
12135 while (expr != NULL)
12137 tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12139 if (texpr == error_mark_node)
12140 return error_mark_node;
12142 *plist = build_tree_list (NULL_TREE, texpr);
12143 plist = &TREE_CHAIN (*plist);
12144 expr = ffebld_trail (expr);
12145 if (length != NULL_TREE)
12147 *ptrail = build_tree_list (NULL_TREE, length);
12148 ptrail = &TREE_CHAIN (*ptrail);
12158 /* Obtain gcc's LABEL_DECL tree for label. */
12160 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12162 ffecom_lookup_label (ffelab label)
12166 if (ffelab_hook (label) == NULL_TREE)
12168 char labelname[16];
12170 switch (ffelab_type (label))
12172 case FFELAB_typeLOOPEND:
12173 case FFELAB_typeNOTLOOP:
12174 case FFELAB_typeENDIF:
12175 sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12176 glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12178 DECL_CONTEXT (glabel) = current_function_decl;
12179 DECL_MODE (glabel) = VOIDmode;
12182 case FFELAB_typeFORMAT:
12183 glabel = build_decl (VAR_DECL,
12184 ffecom_get_invented_identifier
12185 ("__g77_format_%d", (int) ffelab_value (label)),
12186 build_type_variant (build_array_type
12190 TREE_CONSTANT (glabel) = 1;
12191 TREE_STATIC (glabel) = 1;
12192 DECL_CONTEXT (glabel) = current_function_decl;
12193 DECL_INITIAL (glabel) = NULL;
12194 make_decl_rtl (glabel, NULL);
12195 expand_decl (glabel);
12197 ffecom_save_tree_forever (glabel);
12201 case FFELAB_typeANY:
12202 glabel = error_mark_node;
12206 assert ("bad label type" == NULL);
12210 ffelab_set_hook (label, glabel);
12214 glabel = ffelab_hook (label);
12221 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12222 a single source specification (as in the fourth argument of MVBITS).
12223 If the type is NULL_TREE, the type of lhs is used to make the type of
12224 the MODIFY_EXPR. */
12226 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12228 ffecom_modify (tree newtype, tree lhs,
12231 if (lhs == error_mark_node || rhs == error_mark_node)
12232 return error_mark_node;
12234 if (newtype == NULL_TREE)
12235 newtype = TREE_TYPE (lhs);
12237 if (TREE_SIDE_EFFECTS (lhs))
12238 lhs = stabilize_reference (lhs);
12240 return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12245 /* Register source file name. */
12248 ffecom_file (const char *name)
12250 #if FFECOM_GCC_INCLUDE
12251 ffecom_file_ (name);
12255 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12258 ffecom_notify_init_storage(st);
12260 Gets called when all possible units in an aggregate storage area (a LOCAL
12261 with equivalences or a COMMON) have been initialized. The initialization
12262 info either is in ffestorag_init or, if that is NULL,
12263 ffestorag_accretion:
12265 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12266 even for an array if the array is one element in length!
12268 ffestorag_accretion will contain an opACCTER. It is much like an
12269 opARRTER except it has an ffebit object in it instead of just a size.
12270 The back end can use the info in the ffebit object, if it wants, to
12271 reduce the amount of actual initialization, but in any case it should
12272 kill the ffebit object when done. Also, set accretion to NULL but
12273 init to a non-NULL value.
12275 After performing initialization, DO NOT set init to NULL, because that'll
12276 tell the front end it is ok for more initialization to happen. Instead,
12277 set init to an opANY expression or some such thing that you can use to
12278 tell that you've already initialized the object.
12281 Support two-pass FFE. */
12284 ffecom_notify_init_storage (ffestorag st)
12286 ffebld init; /* The initialization expression. */
12287 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12288 ffetargetOffset size; /* The size of the entity. */
12289 ffetargetAlign pad; /* Its initial padding. */
12292 if (ffestorag_init (st) == NULL)
12294 init = ffestorag_accretion (st);
12295 assert (init != NULL);
12296 ffestorag_set_accretion (st, NULL);
12297 ffestorag_set_accretes (st, 0);
12299 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12300 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12301 size = ffebld_accter_size (init);
12302 pad = ffebld_accter_pad (init);
12303 ffebit_kill (ffebld_accter_bits (init));
12304 ffebld_set_op (init, FFEBLD_opARRTER);
12305 ffebld_set_arrter (init, ffebld_accter (init));
12306 ffebld_arrter_set_size (init, size);
12307 ffebld_arrter_set_pad (init, size);
12311 ffestorag_set_init (st, init);
12316 init = ffestorag_init (st);
12319 #if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
12320 ffestorag_set_init (st, ffebld_new_any ());
12322 if (ffebld_op (init) == FFEBLD_opANY)
12323 return; /* Oh, we already did this! */
12325 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12329 if (ffestorag_symbol (st) != NULL)
12330 s = ffestorag_symbol (st);
12332 s = ffestorag_typesymbol (st);
12334 fprintf (dmpout, "= initialize_storage \"%s\" ",
12335 (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12336 ffebld_dump (init);
12337 fputc ('\n', dmpout);
12341 #endif /* if FFECOM_ONEPASS */
12344 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12347 ffecom_notify_init_symbol(s);
12349 Gets called when all possible units in a symbol (not placed in COMMON
12350 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12351 have been initialized. The initialization info either is in
12352 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12354 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12355 even for an array if the array is one element in length!
12357 ffesymbol_accretion will contain an opACCTER. It is much like an
12358 opARRTER except it has an ffebit object in it instead of just a size.
12359 The back end can use the info in the ffebit object, if it wants, to
12360 reduce the amount of actual initialization, but in any case it should
12361 kill the ffebit object when done. Also, set accretion to NULL but
12362 init to a non-NULL value.
12364 After performing initialization, DO NOT set init to NULL, because that'll
12365 tell the front end it is ok for more initialization to happen. Instead,
12366 set init to an opANY expression or some such thing that you can use to
12367 tell that you've already initialized the object.
12370 Support two-pass FFE. */
12373 ffecom_notify_init_symbol (ffesymbol s)
12375 ffebld init; /* The initialization expression. */
12376 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12377 ffetargetOffset size; /* The size of the entity. */
12378 ffetargetAlign pad; /* Its initial padding. */
12381 if (ffesymbol_storage (s) == NULL)
12382 return; /* Do nothing until COMMON/EQUIVALENCE
12383 possibilities checked. */
12385 if ((ffesymbol_init (s) == NULL)
12386 && ((init = ffesymbol_accretion (s)) != NULL))
12388 ffesymbol_set_accretion (s, NULL);
12389 ffesymbol_set_accretes (s, 0);
12391 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12392 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12393 size = ffebld_accter_size (init);
12394 pad = ffebld_accter_pad (init);
12395 ffebit_kill (ffebld_accter_bits (init));
12396 ffebld_set_op (init, FFEBLD_opARRTER);
12397 ffebld_set_arrter (init, ffebld_accter (init));
12398 ffebld_arrter_set_size (init, size);
12399 ffebld_arrter_set_pad (init, size);
12403 ffesymbol_set_init (s, init);
12408 init = ffesymbol_init (s);
12412 ffesymbol_set_init (s, ffebld_new_any ());
12414 if (ffebld_op (init) == FFEBLD_opANY)
12415 return; /* Oh, we already did this! */
12417 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12418 fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12419 ffebld_dump (init);
12420 fputc ('\n', dmpout);
12423 #endif /* if FFECOM_ONEPASS */
12426 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12429 ffecom_notify_primary_entry(s);
12431 Gets called when implicit or explicit PROGRAM statement seen or when
12432 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12433 global symbol that serves as the entry point. */
12436 ffecom_notify_primary_entry (ffesymbol s)
12438 ffecom_primary_entry_ = s;
12439 ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12441 if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12442 || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12443 ffecom_primary_entry_is_proc_ = TRUE;
12445 ffecom_primary_entry_is_proc_ = FALSE;
12447 if (!ffe_is_silent ())
12449 if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12450 fprintf (stderr, "%s:\n", ffesymbol_text (s));
12452 fprintf (stderr, " %s:\n", ffesymbol_text (s));
12455 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12456 if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12461 for (list = ffesymbol_dummyargs (s);
12463 list = ffebld_trail (list))
12465 arg = ffebld_head (list);
12466 if (ffebld_op (arg) == FFEBLD_opSTAR)
12468 ffecom_is_altreturning_ = TRUE;
12477 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12479 #if FFECOM_GCC_INCLUDE
12480 return ffecom_open_include_ (name, l, c);
12482 return fopen (name, "r");
12486 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12489 ffebld expr; // FFE expression.
12490 tree = ffecom_ptr_to_expr(expr);
12492 Like ffecom_expr, but sticks address-of in front of most things. */
12494 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12496 ffecom_ptr_to_expr (ffebld expr)
12499 ffeinfoBasictype bt;
12500 ffeinfoKindtype kt;
12503 assert (expr != NULL);
12505 switch (ffebld_op (expr))
12507 case FFEBLD_opSYMTER:
12508 s = ffebld_symter (expr);
12509 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12513 ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12514 assert (ix != FFECOM_gfrt);
12515 if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12517 ffecom_make_gfrt_ (ix);
12518 item = ffecom_gfrt_[ix];
12523 item = ffesymbol_hook (s).decl_tree;
12524 if (item == NULL_TREE)
12526 s = ffecom_sym_transform_ (s);
12527 item = ffesymbol_hook (s).decl_tree;
12530 assert (item != NULL);
12531 if (item == error_mark_node)
12533 if (!ffesymbol_hook (s).addr)
12534 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12538 case FFEBLD_opARRAYREF:
12539 return ffecom_arrayref_ (NULL_TREE, expr, 1);
12541 case FFEBLD_opCONTER:
12543 bt = ffeinfo_basictype (ffebld_info (expr));
12544 kt = ffeinfo_kindtype (ffebld_info (expr));
12546 item = ffecom_constantunion (&ffebld_constant_union
12547 (ffebld_conter (expr)), bt, kt,
12548 ffecom_tree_type[bt][kt]);
12549 if (item == error_mark_node)
12550 return error_mark_node;
12551 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12556 return error_mark_node;
12559 bt = ffeinfo_basictype (ffebld_info (expr));
12560 kt = ffeinfo_kindtype (ffebld_info (expr));
12562 item = ffecom_expr (expr);
12563 if (item == error_mark_node)
12564 return error_mark_node;
12566 /* The back end currently optimizes a bit too zealously for us, in that
12567 we fail JCB001 if the following block of code is omitted. It checks
12568 to see if the transformed expression is a symbol or array reference,
12569 and encloses it in a SAVE_EXPR if that is the case. */
12572 if ((TREE_CODE (item) == VAR_DECL)
12573 || (TREE_CODE (item) == PARM_DECL)
12574 || (TREE_CODE (item) == RESULT_DECL)
12575 || (TREE_CODE (item) == INDIRECT_REF)
12576 || (TREE_CODE (item) == ARRAY_REF)
12577 || (TREE_CODE (item) == COMPONENT_REF)
12579 || (TREE_CODE (item) == OFFSET_REF)
12581 || (TREE_CODE (item) == BUFFER_REF)
12582 || (TREE_CODE (item) == REALPART_EXPR)
12583 || (TREE_CODE (item) == IMAGPART_EXPR))
12585 item = ffecom_save_tree (item);
12588 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12593 assert ("fall-through error" == NULL);
12594 return error_mark_node;
12598 /* Obtain a temp var with given data type.
12600 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12601 or >= 0 for a CHARACTER type.
12603 elements is -1 for a scalar or > 0 for an array of type. */
12605 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12607 ffecom_make_tempvar (const char *commentary, tree type,
12608 ffetargetCharacterSize size, int elements)
12611 static int mynumber;
12613 assert (current_binding_level->prep_state < 2);
12615 if (type == error_mark_node)
12616 return error_mark_node;
12618 if (size != FFETARGET_charactersizeNONE)
12619 type = build_array_type (type,
12620 build_range_type (ffecom_f2c_ftnlen_type_node,
12621 ffecom_f2c_ftnlen_one_node,
12622 build_int_2 (size, 0)));
12623 if (elements != -1)
12624 type = build_array_type (type,
12625 build_range_type (integer_type_node,
12627 build_int_2 (elements - 1,
12629 t = build_decl (VAR_DECL,
12630 ffecom_get_invented_identifier ("__g77_%s_%d",
12635 t = start_decl (t, FALSE);
12636 finish_decl (t, NULL_TREE, FALSE);
12642 /* Prepare argument pointer to expression.
12644 Like ffecom_prepare_expr, except for expressions to be evaluated
12645 via ffecom_arg_ptr_to_expr. */
12648 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12650 /* ~~For now, it seems to be the same thing. */
12651 ffecom_prepare_expr (expr);
12655 /* End of preparations. */
12658 ffecom_prepare_end (void)
12660 int prep_state = current_binding_level->prep_state;
12662 assert (prep_state < 2);
12663 current_binding_level->prep_state = 2;
12665 return (prep_state == 1) ? TRUE : FALSE;
12668 /* Prepare expression.
12670 This is called before any code is generated for the current block.
12671 It scans the expression, declares any temporaries that might be needed
12672 during evaluation of the expression, and stores those temporaries in
12673 the appropriate "hook" fields of the expression. `dest', if not NULL,
12674 specifies the destination that ffecom_expr_ will see, in case that
12675 helps avoid generating unused temporaries.
12677 ~~Improve to avoid allocating unused temporaries by taking `dest'
12678 into account vis-a-vis aliasing requirements of complex/character
12682 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12684 ffeinfoBasictype bt;
12685 ffeinfoKindtype kt;
12686 ffetargetCharacterSize sz;
12687 tree tempvar = NULL_TREE;
12689 assert (current_binding_level->prep_state < 2);
12694 bt = ffeinfo_basictype (ffebld_info (expr));
12695 kt = ffeinfo_kindtype (ffebld_info (expr));
12696 sz = ffeinfo_size (ffebld_info (expr));
12698 /* Generate whatever temporaries are needed to represent the result
12699 of the expression. */
12701 if (bt == FFEINFO_basictypeCHARACTER)
12703 while (ffebld_op (expr) == FFEBLD_opPAREN)
12704 expr = ffebld_left (expr);
12707 switch (ffebld_op (expr))
12710 /* Don't make temps for SYMTER, CONTER, etc. */
12711 if (ffebld_arity (expr) == 0)
12716 case FFEINFO_basictypeCOMPLEX:
12717 if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12721 if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12724 s = ffebld_symter (ffebld_left (expr));
12725 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12726 || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12727 && ! ffesymbol_is_f2c (s))
12728 || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12729 && ! ffe_is_f2c_library ()))
12732 else if (ffebld_op (expr) == FFEBLD_opPOWER)
12734 /* Requires special treatment. There's no POW_CC function
12735 in libg2c, so POW_ZZ is used, which means we always
12736 need a double-complex temp, not a single-complex. */
12737 kt = FFEINFO_kindtypeREAL2;
12739 else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12740 /* The other ops don't need temps for complex operands. */
12743 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12744 REAL(C). See 19990325-0.f, routine `check', for cases. */
12745 tempvar = ffecom_make_tempvar ("complex",
12747 [FFEINFO_basictypeCOMPLEX][kt],
12748 FFETARGET_charactersizeNONE,
12752 case FFEINFO_basictypeCHARACTER:
12753 if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12756 if (sz == FFETARGET_charactersizeNONE)
12757 /* ~~Kludge alert! This should someday be fixed. */
12760 tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12769 case FFEBLD_opPOWER:
12772 tree rtmp, ltmp, result;
12774 ltype = ffecom_type_expr (ffebld_left (expr));
12775 rtype = ffecom_type_expr (ffebld_right (expr));
12777 rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12778 ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12779 result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12781 tempvar = make_tree_vec (3);
12782 TREE_VEC_ELT (tempvar, 0) = rtmp;
12783 TREE_VEC_ELT (tempvar, 1) = ltmp;
12784 TREE_VEC_ELT (tempvar, 2) = result;
12789 case FFEBLD_opCONCATENATE:
12791 /* This gets special handling, because only one set of temps
12792 is needed for a tree of these -- the tree is treated as
12793 a flattened list of concatenations when generating code. */
12795 ffecomConcatList_ catlist;
12796 tree ltmp, itmp, result;
12800 catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12801 count = ffecom_concat_list_count_ (catlist);
12806 = ffecom_make_tempvar ("concat_len",
12807 ffecom_f2c_ftnlen_type_node,
12808 FFETARGET_charactersizeNONE, count);
12810 = ffecom_make_tempvar ("concat_item",
12811 ffecom_f2c_address_type_node,
12812 FFETARGET_charactersizeNONE, count);
12814 = ffecom_make_tempvar ("concat_res",
12816 ffecom_concat_list_maxlen_ (catlist),
12819 tempvar = make_tree_vec (3);
12820 TREE_VEC_ELT (tempvar, 0) = ltmp;
12821 TREE_VEC_ELT (tempvar, 1) = itmp;
12822 TREE_VEC_ELT (tempvar, 2) = result;
12825 for (i = 0; i < count; ++i)
12826 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12829 ffecom_concat_list_kill_ (catlist);
12833 ffebld_nonter_set_hook (expr, tempvar);
12834 current_binding_level->prep_state = 1;
12839 case FFEBLD_opCONVERT:
12840 if (bt == FFEINFO_basictypeCHARACTER
12841 && ((ffebld_size_known (ffebld_left (expr))
12842 == FFETARGET_charactersizeNONE)
12843 || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12844 tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12850 ffebld_nonter_set_hook (expr, tempvar);
12851 current_binding_level->prep_state = 1;
12854 /* Prepare subexpressions for this expr. */
12856 switch (ffebld_op (expr))
12858 case FFEBLD_opPERCENT_LOC:
12859 ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12862 case FFEBLD_opPERCENT_VAL:
12863 case FFEBLD_opPERCENT_REF:
12864 ffecom_prepare_expr (ffebld_left (expr));
12867 case FFEBLD_opPERCENT_DESCR:
12868 ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12871 case FFEBLD_opITEM:
12877 item = ffebld_trail (item))
12878 if (ffebld_head (item) != NULL)
12879 ffecom_prepare_expr (ffebld_head (item));
12884 /* Need to handle character conversion specially. */
12885 switch (ffebld_arity (expr))
12888 ffecom_prepare_expr (ffebld_left (expr));
12889 ffecom_prepare_expr (ffebld_right (expr));
12893 ffecom_prepare_expr (ffebld_left (expr));
12904 /* Prepare expression for reading and writing.
12906 Like ffecom_prepare_expr, except for expressions to be evaluated
12907 via ffecom_expr_rw. */
12910 ffecom_prepare_expr_rw (tree type, ffebld expr)
12912 /* This is all we support for now. */
12913 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12915 /* ~~For now, it seems to be the same thing. */
12916 ffecom_prepare_expr (expr);
12920 /* Prepare expression for writing.
12922 Like ffecom_prepare_expr, except for expressions to be evaluated
12923 via ffecom_expr_w. */
12926 ffecom_prepare_expr_w (tree type, ffebld expr)
12928 /* This is all we support for now. */
12929 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12931 /* ~~For now, it seems to be the same thing. */
12932 ffecom_prepare_expr (expr);
12936 /* Prepare expression for returning.
12938 Like ffecom_prepare_expr, except for expressions to be evaluated
12939 via ffecom_return_expr. */
12942 ffecom_prepare_return_expr (ffebld expr)
12944 assert (current_binding_level->prep_state < 2);
12946 if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
12947 && ffecom_is_altreturning_
12949 ffecom_prepare_expr (expr);
12952 /* Prepare pointer to expression.
12954 Like ffecom_prepare_expr, except for expressions to be evaluated
12955 via ffecom_ptr_to_expr. */
12958 ffecom_prepare_ptr_to_expr (ffebld expr)
12960 /* ~~For now, it seems to be the same thing. */
12961 ffecom_prepare_expr (expr);
12965 /* Transform expression into constant pointer-to-expression tree.
12967 If the expression can be transformed into a pointer-to-expression tree
12968 that is constant, that is done, and the tree returned. Else NULL_TREE
12971 That way, a caller can attempt to provide compile-time initialization
12972 of a variable and, if that fails, *then* choose to start a new block
12973 and resort to using temporaries, as appropriate. */
12976 ffecom_ptr_to_const_expr (ffebld expr)
12979 return integer_zero_node;
12981 if (ffebld_op (expr) == FFEBLD_opANY)
12982 return error_mark_node;
12984 if (ffebld_arity (expr) == 0
12985 && (ffebld_op (expr) != FFEBLD_opSYMTER
12986 || ffebld_where (expr) == FFEINFO_whereCOMMON
12987 || ffebld_where (expr) == FFEINFO_whereGLOBAL
12988 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
12992 t = ffecom_ptr_to_expr (expr);
12993 assert (TREE_CONSTANT (t));
13000 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13002 tree rtn; // NULL_TREE means use expand_null_return()
13003 ffebld expr; // NULL if no alt return expr to RETURN stmt
13004 rtn = ffecom_return_expr(expr);
13006 Based on the program unit type and other info (like return function
13007 type, return master function type when alternate ENTRY points,
13008 whether subroutine has any alternate RETURN points, etc), returns the
13009 appropriate expression to be returned to the caller, or NULL_TREE
13010 meaning no return value or the caller expects it to be returned somewhere
13011 else (which is handled by other parts of this module). */
13013 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13015 ffecom_return_expr (ffebld expr)
13019 switch (ffecom_primary_entry_kind_)
13021 case FFEINFO_kindPROGRAM:
13022 case FFEINFO_kindBLOCKDATA:
13026 case FFEINFO_kindSUBROUTINE:
13027 if (!ffecom_is_altreturning_)
13028 rtn = NULL_TREE; /* No alt returns, never an expr. */
13029 else if (expr == NULL)
13030 rtn = integer_zero_node;
13032 rtn = ffecom_expr (expr);
13035 case FFEINFO_kindFUNCTION:
13036 if ((ffecom_multi_retval_ != NULL_TREE)
13037 || (ffesymbol_basictype (ffecom_primary_entry_)
13038 == FFEINFO_basictypeCHARACTER)
13039 || ((ffesymbol_basictype (ffecom_primary_entry_)
13040 == FFEINFO_basictypeCOMPLEX)
13041 && (ffecom_num_entrypoints_ == 0)
13042 && ffesymbol_is_f2c (ffecom_primary_entry_)))
13043 { /* Value is returned by direct assignment
13044 into (implicit) dummy. */
13048 rtn = ffecom_func_result_;
13050 /* Spurious error if RETURN happens before first reference! So elide
13051 this code. In particular, for debugging registry, rtn should always
13052 be non-null after all, but TREE_USED won't be set until we encounter
13053 a reference in the code. Perfectly okay (but weird) code that,
13054 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13055 this diagnostic for no reason. Have people use -O -Wuninitialized
13056 and leave it to the back end to find obviously weird cases. */
13058 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13059 situation; if the return value has never been referenced, it won't
13060 have a tree under 2pass mode. */
13061 if ((rtn == NULL_TREE)
13062 || !TREE_USED (rtn))
13064 ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13065 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13066 ffesymbol_where_column (ffecom_primary_entry_));
13067 ffebad_string (ffesymbol_text (ffesymbol_funcresult
13068 (ffecom_primary_entry_)));
13075 assert ("bad unit kind" == NULL);
13076 case FFEINFO_kindANY:
13077 rtn = error_mark_node;
13085 /* Do save_expr only if tree is not error_mark_node. */
13087 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13089 ffecom_save_tree (tree t)
13091 return save_expr (t);
13095 /* Start a compound statement (block). */
13097 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13099 ffecom_start_compstmt (void)
13101 bison_rule_pushlevel_ ();
13103 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13105 /* Public entry point for front end to access start_decl. */
13107 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13109 ffecom_start_decl (tree decl, bool is_initialized)
13111 DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13112 return start_decl (decl, FALSE);
13116 /* ffecom_sym_commit -- Symbol's state being committed to reality
13119 ffecom_sym_commit(s);
13121 Does whatever the backend needs when a symbol is committed after having
13122 been backtrackable for a period of time. */
13124 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13126 ffecom_sym_commit (ffesymbol s UNUSED)
13128 assert (!ffesymbol_retractable ());
13132 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13134 ffecom_sym_end_transition();
13136 Does backend-specific stuff and also calls ffest_sym_end_transition
13137 to do the necessary FFE stuff.
13139 Backtracking is never enabled when this fn is called, so don't worry
13143 ffecom_sym_end_transition (ffesymbol s)
13147 assert (!ffesymbol_retractable ());
13149 s = ffest_sym_end_transition (s);
13151 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13152 if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13153 && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13155 ffecom_list_blockdata_
13156 = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13157 FFEINTRIN_specNONE,
13158 FFEINTRIN_impNONE),
13159 ffecom_list_blockdata_);
13163 /* This is where we finally notice that a symbol has partial initialization
13164 and finalize it. */
13166 if (ffesymbol_accretion (s) != NULL)
13168 assert (ffesymbol_init (s) == NULL);
13169 ffecom_notify_init_symbol (s);
13171 else if (((st = ffesymbol_storage (s)) != NULL)
13172 && ((st = ffestorag_parent (st)) != NULL)
13173 && (ffestorag_accretion (st) != NULL))
13175 assert (ffestorag_init (st) == NULL);
13176 ffecom_notify_init_storage (st);
13179 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13180 if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13181 && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13182 && (ffesymbol_storage (s) != NULL))
13184 ffecom_list_common_
13185 = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13186 FFEINTRIN_specNONE,
13187 FFEINTRIN_impNONE),
13188 ffecom_list_common_);
13195 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13197 ffecom_sym_exec_transition();
13199 Does backend-specific stuff and also calls ffest_sym_exec_transition
13200 to do the necessary FFE stuff.
13202 See the long-winded description in ffecom_sym_learned for info
13203 on handling the situation where backtracking is inhibited. */
13206 ffecom_sym_exec_transition (ffesymbol s)
13208 s = ffest_sym_exec_transition (s);
13213 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13216 s = ffecom_sym_learned(s);
13218 Called when a new symbol is seen after the exec transition or when more
13219 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
13220 it arrives here is that all its latest info is updated already, so its
13221 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13222 field filled in if its gone through here or exec_transition first, and
13225 The backend probably wants to check ffesymbol_retractable() to see if
13226 backtracking is in effect. If so, the FFE's changes to the symbol may
13227 be retracted (undone) or committed (ratified), at which time the
13228 appropriate ffecom_sym_retract or _commit function will be called
13231 If the backend has its own backtracking mechanism, great, use it so that
13232 committal is a simple operation. Though it doesn't make much difference,
13233 I suppose: the reason for tentative symbol evolution in the FFE is to
13234 enable error detection in weird incorrect statements early and to disable
13235 incorrect error detection on a correct statement. The backend is not
13236 likely to introduce any information that'll get involved in these
13237 considerations, so it is probably just fine that the implementation
13238 model for this fn and for _exec_transition is to not do anything
13239 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13240 and instead wait until ffecom_sym_commit is called (which it never
13241 will be as long as we're using ambiguity-detecting statement analysis in
13242 the FFE, which we are initially to shake out the code, but don't depend
13243 on this), otherwise go ahead and do whatever is needed.
13245 In essence, then, when this fn and _exec_transition get called while
13246 backtracking is enabled, a general mechanism would be to flag which (or
13247 both) of these were called (and in what order? neat question as to what
13248 might happen that I'm too lame to think through right now) and then when
13249 _commit is called reproduce the original calling sequence, if any, for
13250 the two fns (at which point backtracking will, of course, be disabled). */
13253 ffecom_sym_learned (ffesymbol s)
13255 ffestorag_exec_layout (s);
13260 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13263 ffecom_sym_retract(s);
13265 Does whatever the backend needs when a symbol is retracted after having
13266 been backtrackable for a period of time. */
13268 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13270 ffecom_sym_retract (ffesymbol s UNUSED)
13272 assert (!ffesymbol_retractable ());
13274 #if 0 /* GCC doesn't commit any backtrackable sins,
13275 so nothing needed here. */
13276 switch (ffesymbol_hook (s).state)
13278 case 0: /* nothing happened yet. */
13281 case 1: /* exec transition happened. */
13284 case 2: /* learned happened. */
13287 case 3: /* learned then exec. */
13290 case 4: /* exec then learned. */
13294 assert ("bad hook state" == NULL);
13301 /* Create temporary gcc label. */
13303 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13305 ffecom_temp_label ()
13308 static int mynumber = 0;
13310 glabel = build_decl (LABEL_DECL,
13311 ffecom_get_invented_identifier ("__g77_label_%d",
13314 DECL_CONTEXT (glabel) = current_function_decl;
13315 DECL_MODE (glabel) = VOIDmode;
13321 /* Return an expression that is usable as an arg in a conditional context
13322 (IF, DO WHILE, .NOT., and so on).
13324 Use the one provided for the back end as of >2.6.0. */
13326 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13328 ffecom_truth_value (tree expr)
13330 return truthvalue_conversion (expr);
13334 /* Return the inversion of a truth value (the inversion of what
13335 ffecom_truth_value builds).
13337 Apparently invert_truthvalue, which is properly in the back end, is
13338 enough for now, so just use it. */
13340 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13342 ffecom_truth_value_invert (tree expr)
13344 return invert_truthvalue (ffecom_truth_value (expr));
13349 /* Return the tree that is the type of the expression, as would be
13350 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13351 transforming the expression, generating temporaries, etc. */
13354 ffecom_type_expr (ffebld expr)
13356 ffeinfoBasictype bt;
13357 ffeinfoKindtype kt;
13360 assert (expr != NULL);
13362 bt = ffeinfo_basictype (ffebld_info (expr));
13363 kt = ffeinfo_kindtype (ffebld_info (expr));
13364 tree_type = ffecom_tree_type[bt][kt];
13366 switch (ffebld_op (expr))
13368 case FFEBLD_opCONTER:
13369 case FFEBLD_opSYMTER:
13370 case FFEBLD_opARRAYREF:
13371 case FFEBLD_opUPLUS:
13372 case FFEBLD_opPAREN:
13373 case FFEBLD_opUMINUS:
13375 case FFEBLD_opSUBTRACT:
13376 case FFEBLD_opMULTIPLY:
13377 case FFEBLD_opDIVIDE:
13378 case FFEBLD_opPOWER:
13380 case FFEBLD_opFUNCREF:
13381 case FFEBLD_opSUBRREF:
13385 case FFEBLD_opNEQV:
13387 case FFEBLD_opCONVERT:
13394 case FFEBLD_opPERCENT_LOC:
13397 case FFEBLD_opACCTER:
13398 case FFEBLD_opARRTER:
13399 case FFEBLD_opITEM:
13400 case FFEBLD_opSTAR:
13401 case FFEBLD_opBOUNDS:
13402 case FFEBLD_opREPEAT:
13403 case FFEBLD_opLABTER:
13404 case FFEBLD_opLABTOK:
13405 case FFEBLD_opIMPDO:
13406 case FFEBLD_opCONCATENATE:
13407 case FFEBLD_opSUBSTR:
13409 assert ("bad op for ffecom_type_expr" == NULL);
13410 /* Fall through. */
13412 return error_mark_node;
13416 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13418 If the PARM_DECL already exists, return it, else create it. It's an
13419 integer_type_node argument for the master function that implements a
13420 subroutine or function with more than one entrypoint and is bound at
13421 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13422 first ENTRY statement, and so on). */
13424 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13426 ffecom_which_entrypoint_decl ()
13428 assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13430 return ffecom_which_entrypoint_decl_;
13435 /* The following sections consists of private and public functions
13436 that have the same names and perform roughly the same functions
13437 as counterparts in the C front end. Changes in the C front end
13438 might affect how things should be done here. Only functions
13439 needed by the back end should be public here; the rest should
13440 be private (static in the C sense). Functions needed by other
13441 g77 front-end modules should be accessed by them via public
13442 ffecom_* names, which should themselves call private versions
13443 in this section so the private versions are easy to recognize
13444 when upgrading to a new gcc and finding interesting changes
13447 Functions named after rule "foo:" in c-parse.y are named
13448 "bison_rule_foo_" so they are easy to find. */
13450 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13453 bison_rule_pushlevel_ ()
13455 emit_line_note (input_filename, lineno);
13457 clear_last_expr ();
13458 expand_start_bindings (0);
13462 bison_rule_compstmt_ ()
13465 int keep = kept_level_p ();
13467 /* Make the temps go away. */
13469 current_binding_level->names = NULL_TREE;
13471 emit_line_note (input_filename, lineno);
13472 expand_end_bindings (getdecls (), keep, 0);
13473 t = poplevel (keep, 1, 0);
13478 /* Return a definition for a builtin function named NAME and whose data type
13479 is TYPE. TYPE should be a function type with argument types.
13480 FUNCTION_CODE tells later passes how to compile calls to this function.
13481 See tree.h for its possible values.
13483 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13484 the name to be called if we can't opencode the function. */
13487 builtin_function (const char *name, tree type, int function_code,
13488 enum built_in_class class,
13489 const char *library_name)
13491 tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13492 DECL_EXTERNAL (decl) = 1;
13493 TREE_PUBLIC (decl) = 1;
13495 SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
13496 make_decl_rtl (decl, NULL);
13498 DECL_BUILT_IN_CLASS (decl) = class;
13499 DECL_FUNCTION_CODE (decl) = function_code;
13504 /* Handle when a new declaration NEWDECL
13505 has the same name as an old one OLDDECL
13506 in the same binding contour.
13507 Prints an error message if appropriate.
13509 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13510 Otherwise, return 0. */
13513 duplicate_decls (tree newdecl, tree olddecl)
13515 int types_match = 1;
13516 int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13517 && DECL_INITIAL (newdecl) != 0);
13518 tree oldtype = TREE_TYPE (olddecl);
13519 tree newtype = TREE_TYPE (newdecl);
13521 if (olddecl == newdecl)
13524 if (TREE_CODE (newtype) == ERROR_MARK
13525 || TREE_CODE (oldtype) == ERROR_MARK)
13528 /* New decl is completely inconsistent with the old one =>
13529 tell caller to replace the old one.
13530 This is always an error except in the case of shadowing a builtin. */
13531 if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13534 /* For real parm decl following a forward decl,
13535 return 1 so old decl will be reused. */
13536 if (types_match && TREE_CODE (newdecl) == PARM_DECL
13537 && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13540 /* The new declaration is the same kind of object as the old one.
13541 The declarations may partially match. Print warnings if they don't
13542 match enough. Ultimately, copy most of the information from the new
13543 decl to the old one, and keep using the old one. */
13545 if (TREE_CODE (olddecl) == FUNCTION_DECL
13546 && DECL_BUILT_IN (olddecl))
13548 /* A function declaration for a built-in function. */
13549 if (!TREE_PUBLIC (newdecl))
13551 else if (!types_match)
13553 /* Accept the return type of the new declaration if same modes. */
13554 tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13555 tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13557 if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13559 /* Function types may be shared, so we can't just modify
13560 the return type of olddecl's function type. */
13562 = build_function_type (newreturntype,
13563 TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13567 TREE_TYPE (olddecl) = newtype;
13573 else if (TREE_CODE (olddecl) == FUNCTION_DECL
13574 && DECL_SOURCE_LINE (olddecl) == 0)
13576 /* A function declaration for a predeclared function
13577 that isn't actually built in. */
13578 if (!TREE_PUBLIC (newdecl))
13580 else if (!types_match)
13582 /* If the types don't match, preserve volatility indication.
13583 Later on, we will discard everything else about the
13584 default declaration. */
13585 TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13589 /* Copy all the DECL_... slots specified in the new decl
13590 except for any that we copy here from the old type.
13592 Past this point, we don't change OLDTYPE and NEWTYPE
13593 even if we change the types of NEWDECL and OLDDECL. */
13597 /* Merge the data types specified in the two decls. */
13598 if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13599 TREE_TYPE (newdecl)
13600 = TREE_TYPE (olddecl)
13601 = TREE_TYPE (newdecl);
13603 /* Lay the type out, unless already done. */
13604 if (oldtype != TREE_TYPE (newdecl))
13606 if (TREE_TYPE (newdecl) != error_mark_node)
13607 layout_type (TREE_TYPE (newdecl));
13608 if (TREE_CODE (newdecl) != FUNCTION_DECL
13609 && TREE_CODE (newdecl) != TYPE_DECL
13610 && TREE_CODE (newdecl) != CONST_DECL)
13611 layout_decl (newdecl, 0);
13615 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13616 DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13617 DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13618 if (TREE_CODE (olddecl) != FUNCTION_DECL)
13619 if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13621 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13622 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13626 /* Keep the old rtl since we can safely use it. */
13627 COPY_DECL_RTL (olddecl, newdecl);
13629 /* Merge the type qualifiers. */
13630 if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13631 && !TREE_THIS_VOLATILE (newdecl))
13632 TREE_THIS_VOLATILE (olddecl) = 0;
13633 if (TREE_READONLY (newdecl))
13634 TREE_READONLY (olddecl) = 1;
13635 if (TREE_THIS_VOLATILE (newdecl))
13637 TREE_THIS_VOLATILE (olddecl) = 1;
13638 if (TREE_CODE (newdecl) == VAR_DECL)
13639 make_var_volatile (newdecl);
13642 /* Keep source location of definition rather than declaration.
13643 Likewise, keep decl at outer scope. */
13644 if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13645 || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13647 DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13648 DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13650 if (DECL_CONTEXT (olddecl) == 0
13651 && TREE_CODE (newdecl) != FUNCTION_DECL)
13652 DECL_CONTEXT (newdecl) = 0;
13655 /* Merge the unused-warning information. */
13656 if (DECL_IN_SYSTEM_HEADER (olddecl))
13657 DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13658 else if (DECL_IN_SYSTEM_HEADER (newdecl))
13659 DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13661 /* Merge the initialization information. */
13662 if (DECL_INITIAL (newdecl) == 0)
13663 DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13665 /* Merge the section attribute.
13666 We want to issue an error if the sections conflict but that must be
13667 done later in decl_attributes since we are called before attributes
13669 if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13670 DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13673 if (TREE_CODE (newdecl) == FUNCTION_DECL)
13675 DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13676 DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13680 /* If cannot merge, then use the new type and qualifiers,
13681 and don't preserve the old rtl. */
13684 TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13685 TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13686 TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13687 TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13690 /* Merge the storage class information. */
13691 /* For functions, static overrides non-static. */
13692 if (TREE_CODE (newdecl) == FUNCTION_DECL)
13694 TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13695 /* This is since we don't automatically
13696 copy the attributes of NEWDECL into OLDDECL. */
13697 TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13698 /* If this clears `static', clear it in the identifier too. */
13699 if (! TREE_PUBLIC (olddecl))
13700 TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13702 if (DECL_EXTERNAL (newdecl))
13704 TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13705 DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13706 /* An extern decl does not override previous storage class. */
13707 TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13711 TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13712 TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13715 /* If either decl says `inline', this fn is inline,
13716 unless its definition was passed already. */
13717 if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13718 DECL_INLINE (olddecl) = 1;
13719 DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13721 /* Get rid of any built-in function if new arg types don't match it
13722 or if we have a function definition. */
13723 if (TREE_CODE (newdecl) == FUNCTION_DECL
13724 && DECL_BUILT_IN (olddecl)
13725 && (!types_match || new_is_definition))
13727 TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13728 DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13731 /* If redeclaring a builtin function, and not a definition,
13733 Also preserve various other info from the definition. */
13734 if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13736 if (DECL_BUILT_IN (olddecl))
13738 DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13739 DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13742 DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13743 DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13744 DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13745 DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13748 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13749 But preserve olddecl's DECL_UID. */
13751 register unsigned olddecl_uid = DECL_UID (olddecl);
13753 memcpy ((char *) olddecl + sizeof (struct tree_common),
13754 (char *) newdecl + sizeof (struct tree_common),
13755 sizeof (struct tree_decl) - sizeof (struct tree_common));
13756 DECL_UID (olddecl) = olddecl_uid;
13762 /* Finish processing of a declaration;
13763 install its initial value.
13764 If the length of an array type is not known before,
13765 it must be determined now, from the initial value, or it is an error. */
13768 finish_decl (tree decl, tree init, bool is_top_level)
13770 register tree type = TREE_TYPE (decl);
13771 int was_incomplete = (DECL_SIZE (decl) == 0);
13772 bool at_top_level = (current_binding_level == global_binding_level);
13773 bool top_level = is_top_level || at_top_level;
13775 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13777 assert (!is_top_level || !at_top_level);
13779 if (TREE_CODE (decl) == PARM_DECL)
13780 assert (init == NULL_TREE);
13781 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13782 overlaps DECL_ARG_TYPE. */
13783 else if (init == NULL_TREE)
13784 assert (DECL_INITIAL (decl) == NULL_TREE);
13786 assert (DECL_INITIAL (decl) == error_mark_node);
13788 if (init != NULL_TREE)
13790 if (TREE_CODE (decl) != TYPE_DECL)
13791 DECL_INITIAL (decl) = init;
13794 /* typedef foo = bar; store the type of bar as the type of foo. */
13795 TREE_TYPE (decl) = TREE_TYPE (init);
13796 DECL_INITIAL (decl) = init = 0;
13800 /* Deduce size of array from initialization, if not already known */
13802 if (TREE_CODE (type) == ARRAY_TYPE
13803 && TYPE_DOMAIN (type) == 0
13804 && TREE_CODE (decl) != TYPE_DECL)
13806 assert (top_level);
13807 assert (was_incomplete);
13809 layout_decl (decl, 0);
13812 if (TREE_CODE (decl) == VAR_DECL)
13814 if (DECL_SIZE (decl) == NULL_TREE
13815 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13816 layout_decl (decl, 0);
13818 if (DECL_SIZE (decl) == NULL_TREE
13819 && (TREE_STATIC (decl)
13821 /* A static variable with an incomplete type is an error if it is
13822 initialized. Also if it is not file scope. Otherwise, let it
13823 through, but if it is not `extern' then it may cause an error
13825 (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13827 /* An automatic variable with an incomplete type is an error. */
13828 !DECL_EXTERNAL (decl)))
13830 assert ("storage size not known" == NULL);
13834 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13835 && (DECL_SIZE (decl) != 0)
13836 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13838 assert ("storage size not constant" == NULL);
13843 /* Output the assembler code and/or RTL code for variables and functions,
13844 unless the type is an undefined structure or union. If not, it will get
13845 done when the type is completed. */
13847 if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13849 rest_of_decl_compilation (decl, NULL,
13850 DECL_CONTEXT (decl) == 0,
13853 if (DECL_CONTEXT (decl) != 0)
13855 /* Recompute the RTL of a local array now if it used to be an
13856 incomplete type. */
13858 && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13860 /* If we used it already as memory, it must stay in memory. */
13861 TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13862 /* If it's still incomplete now, no init will save it. */
13863 if (DECL_SIZE (decl) == 0)
13864 DECL_INITIAL (decl) = 0;
13865 expand_decl (decl);
13867 /* Compute and store the initial value. */
13868 if (TREE_CODE (decl) != FUNCTION_DECL)
13869 expand_decl_init (decl);
13872 else if (TREE_CODE (decl) == TYPE_DECL)
13874 rest_of_decl_compilation (decl, NULL,
13875 DECL_CONTEXT (decl) == 0,
13879 /* At the end of a declaration, throw away any variable type sizes of types
13880 defined inside that declaration. There is no use computing them in the
13881 following function definition. */
13882 if (current_binding_level == global_binding_level)
13883 get_pending_sizes ();
13886 /* Finish up a function declaration and compile that function
13887 all the way to assembler language output. The free the storage
13888 for the function definition.
13890 This is called after parsing the body of the function definition.
13892 NESTED is nonzero if the function being finished is nested in another. */
13895 finish_function (int nested)
13897 register tree fndecl = current_function_decl;
13899 assert (fndecl != NULL_TREE);
13900 if (TREE_CODE (fndecl) != ERROR_MARK)
13903 assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13905 assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13908 /* TREE_READONLY (fndecl) = 1;
13909 This caused &foo to be of type ptr-to-const-function
13910 which then got a warning when stored in a ptr-to-function variable. */
13912 poplevel (1, 0, 1);
13914 if (TREE_CODE (fndecl) != ERROR_MARK)
13916 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13918 /* Must mark the RESULT_DECL as being in this function. */
13920 DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13922 /* Obey `register' declarations if `setjmp' is called in this fn. */
13923 /* Generate rtl for function exit. */
13924 expand_function_end (input_filename, lineno, 0);
13926 /* If this is a nested function, protect the local variables in the stack
13927 above us from being collected while we're compiling this function. */
13929 ggc_push_context ();
13931 /* Run the optimizers and output the assembler code for this function. */
13932 rest_of_compilation (fndecl);
13934 /* Undo the GC context switch. */
13936 ggc_pop_context ();
13939 if (TREE_CODE (fndecl) != ERROR_MARK
13941 && DECL_SAVED_INSNS (fndecl) == 0)
13943 /* Stop pointing to the local nodes about to be freed. */
13944 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13945 function definition. */
13946 /* For a nested function, this is done in pop_f_function_context. */
13947 /* If rest_of_compilation set this to 0, leave it 0. */
13948 if (DECL_INITIAL (fndecl) != 0)
13949 DECL_INITIAL (fndecl) = error_mark_node;
13950 DECL_ARGUMENTS (fndecl) = 0;
13955 /* Let the error reporting routines know that we're outside a function.
13956 For a nested function, this value is used in pop_c_function_context
13957 and then reset via pop_function_context. */
13958 ffecom_outer_function_decl_ = current_function_decl = NULL;
13962 /* Plug-in replacement for identifying the name of a decl and, for a
13963 function, what we call it in diagnostics. For now, "program unit"
13964 should suffice, since it's a bit of a hassle to figure out which
13965 of several kinds of things it is. Note that it could conceivably
13966 be a statement function, which probably isn't really a program unit
13967 per se, but if that comes up, it should be easy to check (being a
13968 nested function and all). */
13970 static const char *
13971 lang_printable_name (tree decl, int v)
13973 /* Just to keep GCC quiet about the unused variable.
13974 In theory, differing values of V should produce different
13979 if (TREE_CODE (decl) == ERROR_MARK)
13980 return "erroneous code";
13981 return IDENTIFIER_POINTER (DECL_NAME (decl));
13985 /* g77's function to print out name of current function that caused
13990 lang_print_error_function (const char *file)
13992 static ffeglobal last_g = NULL;
13993 static ffesymbol last_s = NULL;
13998 if ((ffecom_primary_entry_ == NULL)
13999 || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14007 g = ffesymbol_global (ffecom_primary_entry_);
14008 if (ffecom_nested_entry_ == NULL)
14010 s = ffecom_primary_entry_;
14011 switch (ffesymbol_kind (s))
14013 case FFEINFO_kindFUNCTION:
14017 case FFEINFO_kindSUBROUTINE:
14018 kind = "subroutine";
14021 case FFEINFO_kindPROGRAM:
14025 case FFEINFO_kindBLOCKDATA:
14026 kind = "block-data";
14030 kind = ffeinfo_kind_message (ffesymbol_kind (s));
14036 s = ffecom_nested_entry_;
14037 kind = "statement function";
14041 if ((last_g != g) || (last_s != s))
14044 fprintf (stderr, "%s: ", file);
14047 fprintf (stderr, "Outside of any program unit:\n");
14050 const char *name = ffesymbol_text (s);
14052 fprintf (stderr, "In %s `%s':\n", kind, name);
14061 /* Similar to `lookup_name' but look only at current binding level. */
14064 lookup_name_current_level (tree name)
14068 if (current_binding_level == global_binding_level)
14069 return IDENTIFIER_GLOBAL_VALUE (name);
14071 if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14074 for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14075 if (DECL_NAME (t) == name)
14081 /* Create a new `struct binding_level'. */
14083 static struct binding_level *
14084 make_binding_level ()
14087 return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14090 /* Save and restore the variables in this file and elsewhere
14091 that keep track of the progress of compilation of the current function.
14092 Used for nested functions. */
14096 struct f_function *next;
14098 tree shadowed_labels;
14099 struct binding_level *binding_level;
14102 struct f_function *f_function_chain;
14104 /* Restore the variables used during compilation of a C function. */
14107 pop_f_function_context ()
14109 struct f_function *p = f_function_chain;
14112 /* Bring back all the labels that were shadowed. */
14113 for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14114 if (DECL_NAME (TREE_VALUE (link)) != 0)
14115 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14116 = TREE_VALUE (link);
14118 if (current_function_decl != error_mark_node
14119 && DECL_SAVED_INSNS (current_function_decl) == 0)
14121 /* Stop pointing to the local nodes about to be freed. */
14122 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14123 function definition. */
14124 DECL_INITIAL (current_function_decl) = error_mark_node;
14125 DECL_ARGUMENTS (current_function_decl) = 0;
14128 pop_function_context ();
14130 f_function_chain = p->next;
14132 named_labels = p->named_labels;
14133 shadowed_labels = p->shadowed_labels;
14134 current_binding_level = p->binding_level;
14139 /* Save and reinitialize the variables
14140 used during compilation of a C function. */
14143 push_f_function_context ()
14145 struct f_function *p
14146 = (struct f_function *) xmalloc (sizeof (struct f_function));
14148 push_function_context ();
14150 p->next = f_function_chain;
14151 f_function_chain = p;
14153 p->named_labels = named_labels;
14154 p->shadowed_labels = shadowed_labels;
14155 p->binding_level = current_binding_level;
14159 push_parm_decl (tree parm)
14161 int old_immediate_size_expand = immediate_size_expand;
14163 /* Don't try computing parm sizes now -- wait till fn is called. */
14165 immediate_size_expand = 0;
14167 /* Fill in arg stuff. */
14169 DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14170 DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14171 TREE_READONLY (parm) = 1; /* All implementation args are read-only. */
14173 parm = pushdecl (parm);
14175 immediate_size_expand = old_immediate_size_expand;
14177 finish_decl (parm, NULL_TREE, FALSE);
14180 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
14183 pushdecl_top_level (x)
14187 register struct binding_level *b = current_binding_level;
14188 register tree f = current_function_decl;
14190 current_binding_level = global_binding_level;
14191 current_function_decl = NULL_TREE;
14193 current_binding_level = b;
14194 current_function_decl = f;
14198 /* Store the list of declarations of the current level.
14199 This is done for the parameter declarations of a function being defined,
14200 after they are modified in the light of any missing parameters. */
14206 return current_binding_level->names = decls;
14209 /* Store the parameter declarations into the current function declaration.
14210 This is called after parsing the parameter declarations, before
14211 digesting the body of the function.
14213 For an old-style definition, modify the function's type
14214 to specify at least the number of arguments. */
14217 store_parm_decls (int is_main_program UNUSED)
14219 register tree fndecl = current_function_decl;
14221 if (fndecl == error_mark_node)
14224 /* This is a chain of PARM_DECLs from old-style parm declarations. */
14225 DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14227 /* Initialize the RTL code for the function. */
14229 init_function_start (fndecl, input_filename, lineno);
14231 /* Set up parameters and prepare for return, for the function. */
14233 expand_function_start (fndecl, 0);
14237 start_decl (tree decl, bool is_top_level)
14240 bool at_top_level = (current_binding_level == global_binding_level);
14241 bool top_level = is_top_level || at_top_level;
14243 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14245 assert (!is_top_level || !at_top_level);
14247 if (DECL_INITIAL (decl) != NULL_TREE)
14249 assert (DECL_INITIAL (decl) == error_mark_node);
14250 assert (!DECL_EXTERNAL (decl));
14252 else if (top_level)
14253 assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14255 /* For Fortran, we by default put things in .common when possible. */
14256 DECL_COMMON (decl) = 1;
14258 /* Add this decl to the current binding level. TEM may equal DECL or it may
14259 be a previous decl of the same name. */
14261 tem = pushdecl_top_level (decl);
14263 tem = pushdecl (decl);
14265 /* For a local variable, define the RTL now. */
14267 /* But not if this is a duplicate decl and we preserved the rtl from the
14268 previous one (which may or may not happen). */
14269 && !DECL_RTL_SET_P (tem))
14271 if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14273 else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14274 && DECL_INITIAL (tem) != 0)
14281 /* Create the FUNCTION_DECL for a function definition.
14282 DECLSPECS and DECLARATOR are the parts of the declaration;
14283 they describe the function's name and the type it returns,
14284 but twisted together in a fashion that parallels the syntax of C.
14286 This function creates a binding context for the function body
14287 as well as setting up the FUNCTION_DECL in current_function_decl.
14289 Returns 1 on success. If the DECLARATOR is not suitable for a function
14290 (it defines a datum instead), we return 0, which tells
14291 yyparse to report a parse error.
14293 NESTED is nonzero for a function nested within another function. */
14296 start_function (tree name, tree type, int nested, int public)
14300 int old_immediate_size_expand = immediate_size_expand;
14303 shadowed_labels = 0;
14305 /* Don't expand any sizes in the return type of the function. */
14306 immediate_size_expand = 0;
14311 assert (current_function_decl != NULL_TREE);
14312 assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14316 assert (current_function_decl == NULL_TREE);
14319 if (TREE_CODE (type) == ERROR_MARK)
14320 decl1 = current_function_decl = error_mark_node;
14323 decl1 = build_decl (FUNCTION_DECL,
14326 TREE_PUBLIC (decl1) = public ? 1 : 0;
14328 DECL_INLINE (decl1) = 1;
14329 TREE_STATIC (decl1) = 1;
14330 DECL_EXTERNAL (decl1) = 0;
14332 announce_function (decl1);
14334 /* Make the init_value nonzero so pushdecl knows this is not tentative.
14335 error_mark_node is replaced below (in poplevel) with the BLOCK. */
14336 DECL_INITIAL (decl1) = error_mark_node;
14338 /* Record the decl so that the function name is defined. If we already have
14339 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
14341 current_function_decl = pushdecl (decl1);
14345 ffecom_outer_function_decl_ = current_function_decl;
14348 current_binding_level->prep_state = 2;
14350 if (TREE_CODE (current_function_decl) != ERROR_MARK)
14352 make_decl_rtl (current_function_decl, NULL);
14354 restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14355 DECL_RESULT (current_function_decl)
14356 = build_decl (RESULT_DECL, NULL_TREE, restype);
14359 if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14360 TREE_ADDRESSABLE (current_function_decl) = 1;
14362 immediate_size_expand = old_immediate_size_expand;
14365 /* Here are the public functions the GNU back end needs. */
14368 convert (type, expr)
14371 register tree e = expr;
14372 register enum tree_code code = TREE_CODE (type);
14374 if (type == TREE_TYPE (e)
14375 || TREE_CODE (e) == ERROR_MARK)
14377 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14378 return fold (build1 (NOP_EXPR, type, e));
14379 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14380 || code == ERROR_MARK)
14381 return error_mark_node;
14382 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14384 assert ("void value not ignored as it ought to be" == NULL);
14385 return error_mark_node;
14387 if (code == VOID_TYPE)
14388 return build1 (CONVERT_EXPR, type, e);
14389 if ((code != RECORD_TYPE)
14390 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14391 e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14393 if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14394 return fold (convert_to_integer (type, e));
14395 if (code == POINTER_TYPE)
14396 return fold (convert_to_pointer (type, e));
14397 if (code == REAL_TYPE)
14398 return fold (convert_to_real (type, e));
14399 if (code == COMPLEX_TYPE)
14400 return fold (convert_to_complex (type, e));
14401 if (code == RECORD_TYPE)
14402 return fold (ffecom_convert_to_complex_ (type, e));
14404 assert ("conversion to non-scalar type requested" == NULL);
14405 return error_mark_node;
14408 /* integrate_decl_tree calls this function, but since we don't use the
14409 DECL_LANG_SPECIFIC field, this is a no-op. */
14412 copy_lang_decl (node)
14417 /* Return the list of declarations of the current level.
14418 Note that this list is in reverse order unless/until
14419 you nreverse it; and when you do nreverse it, you must
14420 store the result back using `storedecls' or you will lose. */
14425 return current_binding_level->names;
14428 /* Nonzero if we are currently in the global binding level. */
14431 global_bindings_p ()
14433 return current_binding_level == global_binding_level;
14436 /* Print an error message for invalid use of an incomplete type.
14437 VALUE is the expression that was used (or 0 if that isn't known)
14438 and TYPE is the type that was invalid. */
14441 incomplete_type_error (value, type)
14445 if (TREE_CODE (type) == ERROR_MARK)
14448 assert ("incomplete type?!?" == NULL);
14451 /* Mark ARG for GC. */
14453 mark_binding_level (void *arg)
14455 struct binding_level *level = *(struct binding_level **) arg;
14459 ggc_mark_tree (level->names);
14460 ggc_mark_tree (level->blocks);
14461 ggc_mark_tree (level->this_block);
14462 level = level->level_chain;
14467 init_decl_processing ()
14469 static tree *const tree_roots[] = {
14470 ¤t_function_decl,
14472 &ffecom_tree_fun_type_void,
14473 &ffecom_integer_zero_node,
14474 &ffecom_integer_one_node,
14475 &ffecom_tree_subr_type,
14476 &ffecom_tree_ptr_to_subr_type,
14477 &ffecom_tree_blockdata_type,
14478 &ffecom_tree_xargc_,
14479 &ffecom_f2c_integer_type_node,
14480 &ffecom_f2c_ptr_to_integer_type_node,
14481 &ffecom_f2c_address_type_node,
14482 &ffecom_f2c_real_type_node,
14483 &ffecom_f2c_ptr_to_real_type_node,
14484 &ffecom_f2c_doublereal_type_node,
14485 &ffecom_f2c_complex_type_node,
14486 &ffecom_f2c_doublecomplex_type_node,
14487 &ffecom_f2c_longint_type_node,
14488 &ffecom_f2c_logical_type_node,
14489 &ffecom_f2c_flag_type_node,
14490 &ffecom_f2c_ftnlen_type_node,
14491 &ffecom_f2c_ftnlen_zero_node,
14492 &ffecom_f2c_ftnlen_one_node,
14493 &ffecom_f2c_ftnlen_two_node,
14494 &ffecom_f2c_ptr_to_ftnlen_type_node,
14495 &ffecom_f2c_ftnint_type_node,
14496 &ffecom_f2c_ptr_to_ftnint_type_node,
14497 &ffecom_outer_function_decl_,
14498 &ffecom_previous_function_decl_,
14499 &ffecom_which_entrypoint_decl_,
14500 &ffecom_float_zero_,
14501 &ffecom_float_half_,
14502 &ffecom_double_zero_,
14503 &ffecom_double_half_,
14504 &ffecom_func_result_,
14505 &ffecom_func_length_,
14506 &ffecom_multi_type_node_,
14507 &ffecom_multi_retval_,
14515 /* Record our roots. */
14516 for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14517 ggc_add_tree_root (tree_roots[i], 1);
14518 ggc_add_tree_root (&ffecom_tree_type[0][0],
14519 FFEINFO_basictype*FFEINFO_kindtype);
14520 ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14521 FFEINFO_basictype*FFEINFO_kindtype);
14522 ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14523 FFEINFO_basictype*FFEINFO_kindtype);
14524 ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14525 ggc_add_root (¤t_binding_level, 1, sizeof current_binding_level,
14526 mark_binding_level);
14527 ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14528 mark_binding_level);
14529 ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14535 init_parse (filename)
14536 const char *filename;
14538 /* Open input file. */
14539 if (filename == 0 || !strcmp (filename, "-"))
14542 filename = "stdin";
14545 finput = fopen (filename, "r");
14547 fatal_io_error ("can't open %s", filename);
14549 #ifdef IO_BUFFER_SIZE
14550 setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14553 /* Make identifier nodes long enough for the language-specific slots. */
14554 set_identifier_size (sizeof (struct lang_identifier));
14555 decl_printable_name = lang_printable_name;
14557 print_error_function = lang_print_error_function;
14569 /* Delete the node BLOCK from the current binding level.
14570 This is used for the block inside a stmt expr ({...})
14571 so that the block can be reinserted where appropriate. */
14574 delete_block (block)
14578 if (current_binding_level->blocks == block)
14579 current_binding_level->blocks = TREE_CHAIN (block);
14580 for (t = current_binding_level->blocks; t;)
14582 if (TREE_CHAIN (t) == block)
14583 TREE_CHAIN (t) = TREE_CHAIN (block);
14585 t = TREE_CHAIN (t);
14587 TREE_CHAIN (block) = NULL;
14588 /* Clear TREE_USED which is always set by poplevel.
14589 The flag is set again if insert_block is called. */
14590 TREE_USED (block) = 0;
14594 insert_block (block)
14597 TREE_USED (block) = 1;
14598 current_binding_level->blocks
14599 = chainon (current_binding_level->blocks, block);
14602 /* Each front end provides its own. */
14603 static void ffe_init PARAMS ((void));
14604 static void ffe_finish PARAMS ((void));
14605 static void ffe_init_options PARAMS ((void));
14607 struct lang_hooks lang_hooks = {ffe_init,
14611 NULL /* post_options */};
14613 /* used by print-tree.c */
14616 lang_print_xnode (file, node, indent)
14626 ffe_terminate_0 ();
14628 if (ffe_is_ffedebug ())
14629 malloc_pool_display (malloc_pool_image ());
14638 /* Return the typed-based alias set for T, which may be an expression
14639 or a type. Return -1 if we don't do anything special. */
14642 lang_get_alias_set (t)
14643 tree t ATTRIBUTE_UNUSED;
14645 /* We do not wish to use alias-set based aliasing at all. Used in the
14646 extreme (every object with its own set, with equivalences recorded)
14647 it might be helpful, but there are problems when it comes to inlining.
14648 We get on ok with flag_argument_noalias, and alias-set aliasing does
14649 currently limit how stack slots can be reused, which is a lose. */
14654 ffe_init_options ()
14656 /* Set default options for Fortran. */
14657 flag_move_all_movables = 1;
14658 flag_reduce_all_givs = 1;
14659 flag_argument_noalias = 2;
14660 flag_errno_math = 0;
14661 flag_complex_divide_method = 1;
14667 /* If the file is output from cpp, it should contain a first line
14668 `# 1 "real-filename"', and the current design of gcc (toplev.c
14669 in particular and the way it sets up information relied on by
14670 INCLUDE) requires that we read this now, and store the
14671 "real-filename" info in master_input_filename. Ask the lexer
14672 to try doing this. */
14673 ffelex_hash_kludge (finput);
14677 mark_addressable (exp)
14680 register tree x = exp;
14682 switch (TREE_CODE (x))
14685 case COMPONENT_REF:
14687 x = TREE_OPERAND (x, 0);
14691 TREE_ADDRESSABLE (x) = 1;
14698 if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14699 && DECL_NONLOCAL (x))
14701 if (TREE_PUBLIC (x))
14703 assert ("address of global register var requested" == NULL);
14706 assert ("address of register variable requested" == NULL);
14708 else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14710 if (TREE_PUBLIC (x))
14712 assert ("address of global register var requested" == NULL);
14715 assert ("address of register var requested" == NULL);
14717 put_var_into_stack (x);
14720 case FUNCTION_DECL:
14721 TREE_ADDRESSABLE (x) = 1;
14722 #if 0 /* poplevel deals with this now. */
14723 if (DECL_CONTEXT (x) == 0)
14724 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14732 /* If DECL has a cleanup, build and return that cleanup here.
14733 This is a callback called by expand_expr. */
14736 maybe_build_cleanup (decl)
14739 /* There are no cleanups in Fortran. */
14743 /* Exit a binding level.
14744 Pop the level off, and restore the state of the identifier-decl mappings
14745 that were in effect when this level was entered.
14747 If KEEP is nonzero, this level had explicit declarations, so
14748 and create a "block" (a BLOCK node) for the level
14749 to record its declarations and subblocks for symbol table output.
14751 If FUNCTIONBODY is nonzero, this level is the body of a function,
14752 so create a block as if KEEP were set and also clear out all
14755 If REVERSE is nonzero, reverse the order of decls before putting
14756 them into the BLOCK. */
14759 poplevel (keep, reverse, functionbody)
14764 register tree link;
14765 /* The chain of decls was accumulated in reverse order.
14766 Put it into forward order, just for cleanliness. */
14768 tree subblocks = current_binding_level->blocks;
14771 int block_previously_created;
14773 /* Get the decls in the order they were written.
14774 Usually current_binding_level->names is in reverse order.
14775 But parameter decls were previously put in forward order. */
14778 current_binding_level->names
14779 = decls = nreverse (current_binding_level->names);
14781 decls = current_binding_level->names;
14783 /* Output any nested inline functions within this block
14784 if they weren't already output. */
14786 for (decl = decls; decl; decl = TREE_CHAIN (decl))
14787 if (TREE_CODE (decl) == FUNCTION_DECL
14788 && ! TREE_ASM_WRITTEN (decl)
14789 && DECL_INITIAL (decl) != 0
14790 && TREE_ADDRESSABLE (decl))
14792 /* If this decl was copied from a file-scope decl
14793 on account of a block-scope extern decl,
14794 propagate TREE_ADDRESSABLE to the file-scope decl.
14796 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14797 true, since then the decl goes through save_for_inline_copying. */
14798 if (DECL_ABSTRACT_ORIGIN (decl) != 0
14799 && DECL_ABSTRACT_ORIGIN (decl) != decl)
14800 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14801 else if (DECL_SAVED_INSNS (decl) != 0)
14803 push_function_context ();
14804 output_inline_function (decl);
14805 pop_function_context ();
14809 /* If there were any declarations or structure tags in that level,
14810 or if this level is a function body,
14811 create a BLOCK to record them for the life of this function. */
14814 block_previously_created = (current_binding_level->this_block != 0);
14815 if (block_previously_created)
14816 block = current_binding_level->this_block;
14817 else if (keep || functionbody)
14818 block = make_node (BLOCK);
14821 BLOCK_VARS (block) = decls;
14822 BLOCK_SUBBLOCKS (block) = subblocks;
14825 /* In each subblock, record that this is its superior. */
14827 for (link = subblocks; link; link = TREE_CHAIN (link))
14828 BLOCK_SUPERCONTEXT (link) = block;
14830 /* Clear out the meanings of the local variables of this level. */
14832 for (link = decls; link; link = TREE_CHAIN (link))
14834 if (DECL_NAME (link) != 0)
14836 /* If the ident. was used or addressed via a local extern decl,
14837 don't forget that fact. */
14838 if (DECL_EXTERNAL (link))
14840 if (TREE_USED (link))
14841 TREE_USED (DECL_NAME (link)) = 1;
14842 if (TREE_ADDRESSABLE (link))
14843 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14845 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14849 /* If the level being exited is the top level of a function,
14850 check over all the labels, and clear out the current
14851 (function local) meanings of their names. */
14855 /* If this is the top level block of a function,
14856 the vars are the function's parameters.
14857 Don't leave them in the BLOCK because they are
14858 found in the FUNCTION_DECL instead. */
14860 BLOCK_VARS (block) = 0;
14863 /* Pop the current level, and free the structure for reuse. */
14866 register struct binding_level *level = current_binding_level;
14867 current_binding_level = current_binding_level->level_chain;
14869 level->level_chain = free_binding_level;
14870 free_binding_level = level;
14873 /* Dispose of the block that we just made inside some higher level. */
14875 && current_function_decl != error_mark_node)
14876 DECL_INITIAL (current_function_decl) = block;
14879 if (!block_previously_created)
14880 current_binding_level->blocks
14881 = chainon (current_binding_level->blocks, block);
14883 /* If we did not make a block for the level just exited,
14884 any blocks made for inner levels
14885 (since they cannot be recorded as subblocks in that level)
14886 must be carried forward so they will later become subblocks
14887 of something else. */
14888 else if (subblocks)
14889 current_binding_level->blocks
14890 = chainon (current_binding_level->blocks, subblocks);
14893 TREE_USED (block) = 1;
14898 print_lang_decl (file, node, indent)
14906 print_lang_identifier (file, node, indent)
14911 print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14912 print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14916 print_lang_statistics ()
14921 print_lang_type (file, node, indent)
14928 /* Record a decl-node X as belonging to the current lexical scope.
14929 Check for errors (such as an incompatible declaration for the same
14930 name already seen in the same scope).
14932 Returns either X or an old decl for the same name.
14933 If an old decl is returned, it may have been smashed
14934 to agree with what X says. */
14941 register tree name = DECL_NAME (x);
14942 register struct binding_level *b = current_binding_level;
14944 if ((TREE_CODE (x) == FUNCTION_DECL)
14945 && (DECL_INITIAL (x) == 0)
14946 && DECL_EXTERNAL (x))
14947 DECL_CONTEXT (x) = NULL_TREE;
14949 DECL_CONTEXT (x) = current_function_decl;
14953 if (IDENTIFIER_INVENTED (name))
14956 DECL_ARTIFICIAL (x) = 1;
14958 DECL_IN_SYSTEM_HEADER (x) = 1;
14961 t = lookup_name_current_level (name);
14963 assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
14965 /* Don't push non-parms onto list for parms until we understand
14966 why we're doing this and whether it works. */
14968 assert ((b == global_binding_level)
14969 || !ffecom_transform_only_dummies_
14970 || TREE_CODE (x) == PARM_DECL);
14972 if ((t != NULL_TREE) && duplicate_decls (x, t))
14975 /* If we are processing a typedef statement, generate a whole new
14976 ..._TYPE node (which will be just an variant of the existing
14977 ..._TYPE node with identical properties) and then install the
14978 TYPE_DECL node generated to represent the typedef name as the
14979 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14981 The whole point here is to end up with a situation where each and every
14982 ..._TYPE node the compiler creates will be uniquely associated with
14983 AT MOST one node representing a typedef name. This way, even though
14984 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14985 (i.e. "typedef name") nodes very early on, later parts of the
14986 compiler can always do the reverse translation and get back the
14987 corresponding typedef name. For example, given:
14989 typedef struct S MY_TYPE; MY_TYPE object;
14991 Later parts of the compiler might only know that `object' was of type
14992 `struct S' if it were not for code just below. With this code
14993 however, later parts of the compiler see something like:
14995 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14997 And they can then deduce (from the node for type struct S') that the
14998 original object declaration was:
15002 Being able to do this is important for proper support of protoize, and
15003 also for generating precise symbolic debugging information which
15004 takes full account of the programmer's (typedef) vocabulary.
15006 Obviously, we don't want to generate a duplicate ..._TYPE node if the
15007 TYPE_DECL node that we are now processing really represents a
15008 standard built-in type.
15010 Since all standard types are effectively declared at line zero in the
15011 source file, we can easily check to see if we are working on a
15012 standard type by checking the current value of lineno. */
15014 if (TREE_CODE (x) == TYPE_DECL)
15016 if (DECL_SOURCE_LINE (x) == 0)
15018 if (TYPE_NAME (TREE_TYPE (x)) == 0)
15019 TYPE_NAME (TREE_TYPE (x)) = x;
15021 else if (TREE_TYPE (x) != error_mark_node)
15023 tree tt = TREE_TYPE (x);
15025 tt = build_type_copy (tt);
15026 TYPE_NAME (tt) = x;
15027 TREE_TYPE (x) = tt;
15031 /* This name is new in its binding level. Install the new declaration
15033 if (b == global_binding_level)
15034 IDENTIFIER_GLOBAL_VALUE (name) = x;
15036 IDENTIFIER_LOCAL_VALUE (name) = x;
15039 /* Put decls on list in reverse order. We will reverse them later if
15041 TREE_CHAIN (x) = b->names;
15047 /* Nonzero if the current level needs to have a BLOCK made. */
15054 for (decl = current_binding_level->names;
15056 decl = TREE_CHAIN (decl))
15058 if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15059 || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15060 /* Currently, there aren't supposed to be non-artificial names
15061 at other than the top block for a function -- they're
15062 believed to always be temps. But it's wise to check anyway. */
15068 /* Enter a new binding level.
15069 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15070 not for that of tags. */
15073 pushlevel (tag_transparent)
15074 int tag_transparent;
15076 register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15078 assert (! tag_transparent);
15080 if (current_binding_level == global_binding_level)
15085 /* Reuse or create a struct for this binding level. */
15087 if (free_binding_level)
15089 newlevel = free_binding_level;
15090 free_binding_level = free_binding_level->level_chain;
15094 newlevel = make_binding_level ();
15097 /* Add this level to the front of the chain (stack) of levels that
15100 *newlevel = clear_binding_level;
15101 newlevel->level_chain = current_binding_level;
15102 current_binding_level = newlevel;
15105 /* Set the BLOCK node for the innermost scope
15106 (the one we are currently in). */
15110 register tree block;
15112 current_binding_level->this_block = block;
15113 current_binding_level->names = chainon (current_binding_level->names,
15114 BLOCK_VARS (block));
15115 current_binding_level->blocks = chainon (current_binding_level->blocks,
15116 BLOCK_SUBBLOCKS (block));
15119 /* ~~gcc/tree.h *should* declare this, because toplev.c references it. */
15121 /* Can't 'yydebug' a front end not generated by yacc/bison! */
15124 set_yydebug (value)
15128 fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15132 signed_or_unsigned_type (unsignedp, type)
15138 if (! INTEGRAL_TYPE_P (type))
15140 if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15141 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15142 if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15143 return unsignedp ? unsigned_type_node : integer_type_node;
15144 if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15145 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15146 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15147 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15148 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15149 return (unsignedp ? long_long_unsigned_type_node
15150 : long_long_integer_type_node);
15152 type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15153 if (type2 == NULL_TREE)
15163 tree type1 = TYPE_MAIN_VARIANT (type);
15164 ffeinfoKindtype kt;
15167 if (type1 == unsigned_char_type_node || type1 == char_type_node)
15168 return signed_char_type_node;
15169 if (type1 == unsigned_type_node)
15170 return integer_type_node;
15171 if (type1 == short_unsigned_type_node)
15172 return short_integer_type_node;
15173 if (type1 == long_unsigned_type_node)
15174 return long_integer_type_node;
15175 if (type1 == long_long_unsigned_type_node)
15176 return long_long_integer_type_node;
15177 #if 0 /* gcc/c-* files only */
15178 if (type1 == unsigned_intDI_type_node)
15179 return intDI_type_node;
15180 if (type1 == unsigned_intSI_type_node)
15181 return intSI_type_node;
15182 if (type1 == unsigned_intHI_type_node)
15183 return intHI_type_node;
15184 if (type1 == unsigned_intQI_type_node)
15185 return intQI_type_node;
15188 type2 = type_for_size (TYPE_PRECISION (type1), 0);
15189 if (type2 != NULL_TREE)
15192 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15194 type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15196 if (type1 == type2)
15197 return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15203 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15204 or validate its data type for an `if' or `while' statement or ?..: exp.
15206 This preparation consists of taking the ordinary
15207 representation of an expression expr and producing a valid tree
15208 boolean expression describing whether expr is nonzero. We could
15209 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15210 but we optimize comparisons, &&, ||, and !.
15212 The resulting type should always be `integer_type_node'. */
15215 truthvalue_conversion (expr)
15218 if (TREE_CODE (expr) == ERROR_MARK)
15221 #if 0 /* This appears to be wrong for C++. */
15222 /* These really should return error_mark_node after 2.4 is stable.
15223 But not all callers handle ERROR_MARK properly. */
15224 switch (TREE_CODE (TREE_TYPE (expr)))
15227 error ("struct type value used where scalar is required");
15228 return integer_zero_node;
15231 error ("union type value used where scalar is required");
15232 return integer_zero_node;
15235 error ("array type value used where scalar is required");
15236 return integer_zero_node;
15243 switch (TREE_CODE (expr))
15245 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15246 or comparison expressions as truth values at this level. */
15248 case COMPONENT_REF:
15249 /* A one-bit unsigned bit-field is already acceptable. */
15250 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15251 && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15257 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15258 or comparison expressions as truth values at this level. */
15260 if (integer_zerop (TREE_OPERAND (expr, 1)))
15261 return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15263 case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15264 case TRUTH_ANDIF_EXPR:
15265 case TRUTH_ORIF_EXPR:
15266 case TRUTH_AND_EXPR:
15267 case TRUTH_OR_EXPR:
15268 case TRUTH_XOR_EXPR:
15269 TREE_TYPE (expr) = integer_type_node;
15276 return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15279 return real_zerop (expr) ? integer_zero_node : integer_one_node;
15282 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15283 return build (COMPOUND_EXPR, integer_type_node,
15284 TREE_OPERAND (expr, 0), integer_one_node);
15286 return integer_one_node;
15289 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15290 ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15292 truthvalue_conversion (TREE_OPERAND (expr, 0)),
15293 truthvalue_conversion (TREE_OPERAND (expr, 1)));
15299 /* These don't change whether an object is non-zero or zero. */
15300 return truthvalue_conversion (TREE_OPERAND (expr, 0));
15304 /* These don't change whether an object is zero or non-zero, but
15305 we can't ignore them if their second arg has side-effects. */
15306 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15307 return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15308 truthvalue_conversion (TREE_OPERAND (expr, 0)));
15310 return truthvalue_conversion (TREE_OPERAND (expr, 0));
15313 /* Distribute the conversion into the arms of a COND_EXPR. */
15314 return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15315 truthvalue_conversion (TREE_OPERAND (expr, 1)),
15316 truthvalue_conversion (TREE_OPERAND (expr, 2))));
15319 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15320 since that affects how `default_conversion' will behave. */
15321 if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15322 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15324 /* fall through... */
15326 /* If this is widening the argument, we can ignore it. */
15327 if (TYPE_PRECISION (TREE_TYPE (expr))
15328 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15329 return truthvalue_conversion (TREE_OPERAND (expr, 0));
15333 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15335 if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15336 && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15338 /* fall through... */
15340 /* This and MINUS_EXPR can be changed into a comparison of the
15342 if (TREE_TYPE (TREE_OPERAND (expr, 0))
15343 == TREE_TYPE (TREE_OPERAND (expr, 1)))
15344 return ffecom_2 (NE_EXPR, integer_type_node,
15345 TREE_OPERAND (expr, 0),
15346 TREE_OPERAND (expr, 1));
15347 return ffecom_2 (NE_EXPR, integer_type_node,
15348 TREE_OPERAND (expr, 0),
15349 fold (build1 (NOP_EXPR,
15350 TREE_TYPE (TREE_OPERAND (expr, 0)),
15351 TREE_OPERAND (expr, 1))));
15354 if (integer_onep (TREE_OPERAND (expr, 1)))
15359 #if 0 /* No such thing in Fortran. */
15360 if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15361 warning ("suggest parentheses around assignment used as truth value");
15369 if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15371 ((TREE_SIDE_EFFECTS (expr)
15372 ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15374 truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15375 TREE_TYPE (TREE_TYPE (expr)),
15377 truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15378 TREE_TYPE (TREE_TYPE (expr)),
15381 return ffecom_2 (NE_EXPR, integer_type_node,
15383 convert (TREE_TYPE (expr), integer_zero_node));
15387 type_for_mode (mode, unsignedp)
15388 enum machine_mode mode;
15395 if (mode == TYPE_MODE (integer_type_node))
15396 return unsignedp ? unsigned_type_node : integer_type_node;
15398 if (mode == TYPE_MODE (signed_char_type_node))
15399 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15401 if (mode == TYPE_MODE (short_integer_type_node))
15402 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15404 if (mode == TYPE_MODE (long_integer_type_node))
15405 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15407 if (mode == TYPE_MODE (long_long_integer_type_node))
15408 return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15410 #if HOST_BITS_PER_WIDE_INT >= 64
15411 if (mode == TYPE_MODE (intTI_type_node))
15412 return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15415 if (mode == TYPE_MODE (float_type_node))
15416 return float_type_node;
15418 if (mode == TYPE_MODE (double_type_node))
15419 return double_type_node;
15421 if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15422 return build_pointer_type (char_type_node);
15424 if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15425 return build_pointer_type (integer_type_node);
15427 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15428 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15430 if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15431 && (mode == TYPE_MODE (t)))
15433 if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15434 return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15444 type_for_size (bits, unsignedp)
15448 ffeinfoKindtype kt;
15451 if (bits == TYPE_PRECISION (integer_type_node))
15452 return unsignedp ? unsigned_type_node : integer_type_node;
15454 if (bits == TYPE_PRECISION (signed_char_type_node))
15455 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15457 if (bits == TYPE_PRECISION (short_integer_type_node))
15458 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15460 if (bits == TYPE_PRECISION (long_integer_type_node))
15461 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15463 if (bits == TYPE_PRECISION (long_long_integer_type_node))
15464 return (unsignedp ? long_long_unsigned_type_node
15465 : long_long_integer_type_node);
15467 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15469 type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15471 if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15472 return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15480 unsigned_type (type)
15483 tree type1 = TYPE_MAIN_VARIANT (type);
15484 ffeinfoKindtype kt;
15487 if (type1 == signed_char_type_node || type1 == char_type_node)
15488 return unsigned_char_type_node;
15489 if (type1 == integer_type_node)
15490 return unsigned_type_node;
15491 if (type1 == short_integer_type_node)
15492 return short_unsigned_type_node;
15493 if (type1 == long_integer_type_node)
15494 return long_unsigned_type_node;
15495 if (type1 == long_long_integer_type_node)
15496 return long_long_unsigned_type_node;
15497 #if 0 /* gcc/c-* files only */
15498 if (type1 == intDI_type_node)
15499 return unsigned_intDI_type_node;
15500 if (type1 == intSI_type_node)
15501 return unsigned_intSI_type_node;
15502 if (type1 == intHI_type_node)
15503 return unsigned_intHI_type_node;
15504 if (type1 == intQI_type_node)
15505 return unsigned_intQI_type_node;
15508 type2 = type_for_size (TYPE_PRECISION (type1), 1);
15509 if (type2 != NULL_TREE)
15512 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15514 type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15516 if (type1 == type2)
15517 return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15525 union tree_node *t ATTRIBUTE_UNUSED;
15527 if (TREE_CODE (t) == IDENTIFIER_NODE)
15529 struct lang_identifier *i = (struct lang_identifier *) t;
15530 ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15531 ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15532 ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15534 else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15535 ggc_mark (TYPE_LANG_SPECIFIC (t));
15538 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15540 #if FFECOM_GCC_INCLUDE
15542 /* From gcc/cccp.c, the code to handle -I. */
15544 /* Skip leading "./" from a directory name.
15545 This may yield the empty string, which represents the current directory. */
15547 static const char *
15548 skip_redundant_dir_prefix (const char *dir)
15550 while (dir[0] == '.' && dir[1] == '/')
15551 for (dir += 2; *dir == '/'; dir++)
15553 if (dir[0] == '.' && !dir[1])
15558 /* The file_name_map structure holds a mapping of file names for a
15559 particular directory. This mapping is read from the file named
15560 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15561 map filenames on a file system with severe filename restrictions,
15562 such as DOS. The format of the file name map file is just a series
15563 of lines with two tokens on each line. The first token is the name
15564 to map, and the second token is the actual name to use. */
15566 struct file_name_map
15568 struct file_name_map *map_next;
15573 #define FILE_NAME_MAP_FILE "header.gcc"
15575 /* Current maximum length of directory names in the search path
15576 for include files. (Altered as we get more of them.) */
15578 static int max_include_len = 0;
15580 struct file_name_list
15582 struct file_name_list *next;
15584 /* Mapping of file names for this directory. */
15585 struct file_name_map *name_map;
15586 /* Non-zero if name_map is valid. */
15590 static struct file_name_list *include = NULL; /* First dir to search */
15591 static struct file_name_list *last_include = NULL; /* Last in chain */
15593 /* I/O buffer structure.
15594 The `fname' field is nonzero for source files and #include files
15595 and for the dummy text used for -D and -U.
15596 It is zero for rescanning results of macro expansion
15597 and for expanding macro arguments. */
15598 #define INPUT_STACK_MAX 400
15599 static struct file_buf {
15601 /* Filename specified with #line command. */
15602 const char *nominal_fname;
15603 /* Record where in the search path this file was found.
15604 For #include_next. */
15605 struct file_name_list *dir;
15607 ffewhereColumn column;
15608 } instack[INPUT_STACK_MAX];
15610 static int last_error_tick = 0; /* Incremented each time we print it. */
15611 static int input_file_stack_tick = 0; /* Incremented when status changes. */
15613 /* Current nesting level of input sources.
15614 `instack[indepth]' is the level currently being read. */
15615 static int indepth = -1;
15617 typedef struct file_buf FILE_BUF;
15619 typedef unsigned char U_CHAR;
15621 /* table to tell if char can be part of a C identifier. */
15622 U_CHAR is_idchar[256];
15623 /* table to tell if char can be first char of a c identifier. */
15624 U_CHAR is_idstart[256];
15625 /* table to tell if c is horizontal space. */
15626 U_CHAR is_hor_space[256];
15627 /* table to tell if c is horizontal or vertical space. */
15628 static U_CHAR is_space[256];
15630 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15631 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15633 /* Nonzero means -I- has been seen,
15634 so don't look for #include "foo" the source-file directory. */
15635 static int ignore_srcdir;
15637 #ifndef INCLUDE_LEN_FUDGE
15638 #define INCLUDE_LEN_FUDGE 0
15641 static void append_include_chain (struct file_name_list *first,
15642 struct file_name_list *last);
15643 static FILE *open_include_file (char *filename,
15644 struct file_name_list *searchptr);
15645 static void print_containing_files (ffebadSeverity sev);
15646 static char *read_filename_string (int ch, FILE *f);
15647 static struct file_name_map *read_name_map (const char *dirname);
15649 /* Append a chain of `struct file_name_list's
15650 to the end of the main include chain.
15651 FIRST is the beginning of the chain to append, and LAST is the end. */
15654 append_include_chain (first, last)
15655 struct file_name_list *first, *last;
15657 struct file_name_list *dir;
15659 if (!first || !last)
15665 last_include->next = first;
15667 for (dir = first; ; dir = dir->next) {
15668 int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15669 if (len > max_include_len)
15670 max_include_len = len;
15676 last_include = last;
15679 /* Try to open include file FILENAME. SEARCHPTR is the directory
15680 being tried from the include file search path. This function maps
15681 filenames on file systems based on information read by
15685 open_include_file (filename, searchptr)
15687 struct file_name_list *searchptr;
15689 register struct file_name_map *map;
15690 register char *from;
15693 if (searchptr && ! searchptr->got_name_map)
15695 searchptr->name_map = read_name_map (searchptr->fname
15696 ? searchptr->fname : ".");
15697 searchptr->got_name_map = 1;
15700 /* First check the mapping for the directory we are using. */
15701 if (searchptr && searchptr->name_map)
15704 if (searchptr->fname)
15705 from += strlen (searchptr->fname) + 1;
15706 for (map = searchptr->name_map; map; map = map->map_next)
15708 if (! strcmp (map->map_from, from))
15710 /* Found a match. */
15711 return fopen (map->map_to, "r");
15716 /* Try to find a mapping file for the particular directory we are
15717 looking in. Thus #include <sys/types.h> will look up sys/types.h
15718 in /usr/include/header.gcc and look up types.h in
15719 /usr/include/sys/header.gcc. */
15720 p = strrchr (filename, '/');
15721 #ifdef DIR_SEPARATOR
15722 if (! p) p = strrchr (filename, DIR_SEPARATOR);
15724 char *tmp = strrchr (filename, DIR_SEPARATOR);
15725 if (tmp != NULL && tmp > p) p = tmp;
15731 && searchptr->fname
15732 && strlen (searchptr->fname) == (size_t) (p - filename)
15733 && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15735 /* FILENAME is in SEARCHPTR, which we've already checked. */
15736 return fopen (filename, "r");
15742 map = read_name_map (".");
15746 dir = (char *) xmalloc (p - filename + 1);
15747 memcpy (dir, filename, p - filename);
15748 dir[p - filename] = '\0';
15750 map = read_name_map (dir);
15753 for (; map; map = map->map_next)
15754 if (! strcmp (map->map_from, from))
15755 return fopen (map->map_to, "r");
15757 return fopen (filename, "r");
15760 /* Print the file names and line numbers of the #include
15761 commands which led to the current file. */
15764 print_containing_files (ffebadSeverity sev)
15766 FILE_BUF *ip = NULL;
15772 /* If stack of files hasn't changed since we last printed
15773 this info, don't repeat it. */
15774 if (last_error_tick == input_file_stack_tick)
15777 for (i = indepth; i >= 0; i--)
15778 if (instack[i].fname != NULL) {
15783 /* Give up if we don't find a source file. */
15787 /* Find the other, outer source files. */
15788 for (i--; i >= 0; i--)
15789 if (instack[i].fname != NULL)
15795 str1 = "In file included";
15807 ffebad_start_msg ("%A from %B at %0%C", sev);
15808 ffebad_here (0, ip->line, ip->column);
15809 ffebad_string (str1);
15810 ffebad_string (ip->nominal_fname);
15811 ffebad_string (str2);
15815 /* Record we have printed the status as of this time. */
15816 last_error_tick = input_file_stack_tick;
15819 /* Read a space delimited string of unlimited length from a stdio
15823 read_filename_string (ch, f)
15831 set = alloc = xmalloc (len + 1);
15832 if (! is_space[ch])
15835 while ((ch = getc (f)) != EOF && ! is_space[ch])
15837 if (set - alloc == len)
15840 alloc = xrealloc (alloc, len + 1);
15841 set = alloc + len / 2;
15851 /* Read the file name map file for DIRNAME. */
15853 static struct file_name_map *
15854 read_name_map (dirname)
15855 const char *dirname;
15857 /* This structure holds a linked list of file name maps, one per
15859 struct file_name_map_list
15861 struct file_name_map_list *map_list_next;
15862 char *map_list_name;
15863 struct file_name_map *map_list_map;
15865 static struct file_name_map_list *map_list;
15866 register struct file_name_map_list *map_list_ptr;
15870 int separator_needed;
15872 dirname = skip_redundant_dir_prefix (dirname);
15874 for (map_list_ptr = map_list; map_list_ptr;
15875 map_list_ptr = map_list_ptr->map_list_next)
15876 if (! strcmp (map_list_ptr->map_list_name, dirname))
15877 return map_list_ptr->map_list_map;
15879 map_list_ptr = ((struct file_name_map_list *)
15880 xmalloc (sizeof (struct file_name_map_list)));
15881 map_list_ptr->map_list_name = xstrdup (dirname);
15882 map_list_ptr->map_list_map = NULL;
15884 dirlen = strlen (dirname);
15885 separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15886 name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15887 strcpy (name, dirname);
15888 name[dirlen] = '/';
15889 strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15890 f = fopen (name, "r");
15893 map_list_ptr->map_list_map = NULL;
15898 while ((ch = getc (f)) != EOF)
15901 struct file_name_map *ptr;
15905 from = read_filename_string (ch, f);
15906 while ((ch = getc (f)) != EOF && is_hor_space[ch])
15908 to = read_filename_string (ch, f);
15910 ptr = ((struct file_name_map *)
15911 xmalloc (sizeof (struct file_name_map)));
15912 ptr->map_from = from;
15914 /* Make the real filename absolute. */
15919 ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15920 strcpy (ptr->map_to, dirname);
15921 ptr->map_to[dirlen] = '/';
15922 strcpy (ptr->map_to + dirlen + separator_needed, to);
15926 ptr->map_next = map_list_ptr->map_list_map;
15927 map_list_ptr->map_list_map = ptr;
15929 while ((ch = getc (f)) != '\n')
15936 map_list_ptr->map_list_next = map_list;
15937 map_list = map_list_ptr;
15939 return map_list_ptr->map_list_map;
15943 ffecom_file_ (const char *name)
15947 /* Do partial setup of input buffer for the sake of generating
15948 early #line directives (when -g is in effect). */
15950 fp = &instack[++indepth];
15951 memset ((char *) fp, 0, sizeof (FILE_BUF));
15954 fp->nominal_fname = fp->fname = name;
15957 /* Initialize syntactic classifications of characters. */
15960 ffecom_initialize_char_syntax_ ()
15965 * Set up is_idchar and is_idstart tables. These should be
15966 * faster than saying (is_alpha (c) || c == '_'), etc.
15967 * Set up these things before calling any routines tthat
15970 for (i = 'a'; i <= 'z'; i++) {
15971 is_idchar[i - 'a' + 'A'] = 1;
15973 is_idstart[i - 'a' + 'A'] = 1;
15976 for (i = '0'; i <= '9'; i++)
15978 is_idchar['_'] = 1;
15979 is_idstart['_'] = 1;
15981 /* horizontal space table */
15982 is_hor_space[' '] = 1;
15983 is_hor_space['\t'] = 1;
15984 is_hor_space['\v'] = 1;
15985 is_hor_space['\f'] = 1;
15986 is_hor_space['\r'] = 1;
15989 is_space['\t'] = 1;
15990 is_space['\v'] = 1;
15991 is_space['\f'] = 1;
15992 is_space['\n'] = 1;
15993 is_space['\r'] = 1;
15997 ffecom_close_include_ (FILE *f)
16002 input_file_stack_tick++;
16004 ffewhere_line_kill (instack[indepth].line);
16005 ffewhere_column_kill (instack[indepth].column);
16009 ffecom_decode_include_option_ (char *spec)
16011 struct file_name_list *dirtmp;
16013 if (! ignore_srcdir && !strcmp (spec, "-"))
16017 dirtmp = (struct file_name_list *)
16018 xmalloc (sizeof (struct file_name_list));
16019 dirtmp->next = 0; /* New one goes on the end */
16020 dirtmp->fname = spec;
16021 dirtmp->got_name_map = 0;
16023 error ("Directory name must immediately follow -I");
16025 append_include_chain (dirtmp, dirtmp);
16030 /* Open INCLUDEd file. */
16033 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16036 size_t flen = strlen (fbeg);
16037 struct file_name_list *search_start = include; /* Chain of dirs to search */
16038 struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16039 struct file_name_list *searchptr = 0;
16040 char *fname; /* Dynamically allocated fname buffer */
16047 dsp[0].fname = NULL;
16049 /* If -I- was specified, don't search current dir, only spec'd ones. */
16050 if (!ignore_srcdir)
16052 for (fp = &instack[indepth]; fp >= instack; fp--)
16058 if ((nam = fp->nominal_fname) != NULL)
16060 /* Found a named file. Figure out dir of the file,
16061 and put it in front of the search list. */
16062 dsp[0].next = search_start;
16063 search_start = dsp;
16065 ep = strrchr (nam, '/');
16066 #ifdef DIR_SEPARATOR
16067 if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
16069 char *tmp = strrchr (nam, DIR_SEPARATOR);
16070 if (tmp != NULL && tmp > ep) ep = tmp;
16074 ep = strrchr (nam, ']');
16075 if (ep == NULL) ep = strrchr (nam, '>');
16076 if (ep == NULL) ep = strrchr (nam, ':');
16077 if (ep != NULL) ep++;
16082 dsp[0].fname = (char *) xmalloc (n + 1);
16083 strncpy (dsp[0].fname, nam, n);
16084 dsp[0].fname[n] = '\0';
16085 if (n + INCLUDE_LEN_FUDGE > max_include_len)
16086 max_include_len = n + INCLUDE_LEN_FUDGE;
16089 dsp[0].fname = NULL; /* Current directory */
16090 dsp[0].got_name_map = 0;
16096 /* Allocate this permanently, because it gets stored in the definitions
16098 fname = xmalloc (max_include_len + flen + 4);
16099 /* + 2 above for slash and terminating null. */
16100 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16103 /* If specified file name is absolute, just open it. */
16106 #ifdef DIR_SEPARATOR
16107 || *fbeg == DIR_SEPARATOR
16111 strncpy (fname, (char *) fbeg, flen);
16113 f = open_include_file (fname, NULL);
16119 /* Search directory path, trying to open the file.
16120 Copy each filename tried into FNAME. */
16122 for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16124 if (searchptr->fname)
16126 /* The empty string in a search path is ignored.
16127 This makes it possible to turn off entirely
16128 a standard piece of the list. */
16129 if (searchptr->fname[0] == 0)
16131 strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16132 if (fname[0] && fname[strlen (fname) - 1] != '/')
16133 strcat (fname, "/");
16134 fname[strlen (fname) + flen] = 0;
16139 strncat (fname, fbeg, flen);
16141 /* Change this 1/2 Unix 1/2 VMS file specification into a
16142 full VMS file specification */
16143 if (searchptr->fname && (searchptr->fname[0] != 0))
16145 /* Fix up the filename */
16146 hack_vms_include_specification (fname);
16150 /* This is a normal VMS filespec, so use it unchanged. */
16151 strncpy (fname, (char *) fbeg, flen);
16153 #if 0 /* Not for g77. */
16154 /* if it's '#include filename', add the missing .h */
16155 if (strchr (fname, '.') == NULL)
16156 strcat (fname, ".h");
16160 f = open_include_file (fname, searchptr);
16162 if (f == NULL && errno == EACCES)
16164 print_containing_files (FFEBAD_severityWARNING);
16165 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16166 FFEBAD_severityWARNING);
16167 ffebad_string (fname);
16168 ffebad_here (0, l, c);
16179 /* A file that was not found. */
16181 strncpy (fname, (char *) fbeg, flen);
16183 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16184 ffebad_start (FFEBAD_OPEN_INCLUDE);
16185 ffebad_here (0, l, c);
16186 ffebad_string (fname);
16190 if (dsp[0].fname != NULL)
16191 free (dsp[0].fname);
16196 if (indepth >= (INPUT_STACK_MAX - 1))
16198 print_containing_files (FFEBAD_severityFATAL);
16199 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16200 FFEBAD_severityFATAL);
16201 ffebad_string (fname);
16202 ffebad_here (0, l, c);
16207 instack[indepth].line = ffewhere_line_use (l);
16208 instack[indepth].column = ffewhere_column_use (c);
16210 fp = &instack[indepth + 1];
16211 memset ((char *) fp, 0, sizeof (FILE_BUF));
16212 fp->nominal_fname = fp->fname = fname;
16213 fp->dir = searchptr;
16216 input_file_stack_tick++;
16220 #endif /* FFECOM_GCC_INCLUDE */
16222 /**INDENT* (Do not reformat this comment even with -fca option.)
16223 Data-gathering files: Given the source file listed below, compiled with
16224 f2c I obtained the output file listed after that, and from the output
16225 file I derived the above code.
16227 -------- (begin input file to f2c)
16233 double precision D1,D2
16235 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16262 c FFEINTRIN_impACOS
16263 call fooR(ACOS(R1))
16264 c FFEINTRIN_impAIMAG
16265 call fooR(AIMAG(C1))
16266 c FFEINTRIN_impAINT
16267 call fooR(AINT(R1))
16268 c FFEINTRIN_impALOG
16269 call fooR(ALOG(R1))
16270 c FFEINTRIN_impALOG10
16271 call fooR(ALOG10(R1))
16272 c FFEINTRIN_impAMAX0
16273 call fooR(AMAX0(I1,I2))
16274 c FFEINTRIN_impAMAX1
16275 call fooR(AMAX1(R1,R2))
16276 c FFEINTRIN_impAMIN0
16277 call fooR(AMIN0(I1,I2))
16278 c FFEINTRIN_impAMIN1
16279 call fooR(AMIN1(R1,R2))
16280 c FFEINTRIN_impAMOD
16281 call fooR(AMOD(R1,R2))
16282 c FFEINTRIN_impANINT
16283 call fooR(ANINT(R1))
16284 c FFEINTRIN_impASIN
16285 call fooR(ASIN(R1))
16286 c FFEINTRIN_impATAN
16287 call fooR(ATAN(R1))
16288 c FFEINTRIN_impATAN2
16289 call fooR(ATAN2(R1,R2))
16290 c FFEINTRIN_impCABS
16291 call fooR(CABS(C1))
16292 c FFEINTRIN_impCCOS
16293 call fooC(CCOS(C1))
16294 c FFEINTRIN_impCEXP
16295 call fooC(CEXP(C1))
16296 c FFEINTRIN_impCHAR
16297 call fooA(CHAR(I1))
16298 c FFEINTRIN_impCLOG
16299 call fooC(CLOG(C1))
16300 c FFEINTRIN_impCONJG
16301 call fooC(CONJG(C1))
16304 c FFEINTRIN_impCOSH
16305 call fooR(COSH(R1))
16306 c FFEINTRIN_impCSIN
16307 call fooC(CSIN(C1))
16308 c FFEINTRIN_impCSQRT
16309 call fooC(CSQRT(C1))
16310 c FFEINTRIN_impDABS
16311 call fooD(DABS(D1))
16312 c FFEINTRIN_impDACOS
16313 call fooD(DACOS(D1))
16314 c FFEINTRIN_impDASIN
16315 call fooD(DASIN(D1))
16316 c FFEINTRIN_impDATAN
16317 call fooD(DATAN(D1))
16318 c FFEINTRIN_impDATAN2
16319 call fooD(DATAN2(D1,D2))
16320 c FFEINTRIN_impDCOS
16321 call fooD(DCOS(D1))
16322 c FFEINTRIN_impDCOSH
16323 call fooD(DCOSH(D1))
16324 c FFEINTRIN_impDDIM
16325 call fooD(DDIM(D1,D2))
16326 c FFEINTRIN_impDEXP
16327 call fooD(DEXP(D1))
16329 call fooR(DIM(R1,R2))
16330 c FFEINTRIN_impDINT
16331 call fooD(DINT(D1))
16332 c FFEINTRIN_impDLOG
16333 call fooD(DLOG(D1))
16334 c FFEINTRIN_impDLOG10
16335 call fooD(DLOG10(D1))
16336 c FFEINTRIN_impDMAX1
16337 call fooD(DMAX1(D1,D2))
16338 c FFEINTRIN_impDMIN1
16339 call fooD(DMIN1(D1,D2))
16340 c FFEINTRIN_impDMOD
16341 call fooD(DMOD(D1,D2))
16342 c FFEINTRIN_impDNINT
16343 call fooD(DNINT(D1))
16344 c FFEINTRIN_impDPROD
16345 call fooD(DPROD(R1,R2))
16346 c FFEINTRIN_impDSIGN
16347 call fooD(DSIGN(D1,D2))
16348 c FFEINTRIN_impDSIN
16349 call fooD(DSIN(D1))
16350 c FFEINTRIN_impDSINH
16351 call fooD(DSINH(D1))
16352 c FFEINTRIN_impDSQRT
16353 call fooD(DSQRT(D1))
16354 c FFEINTRIN_impDTAN
16355 call fooD(DTAN(D1))
16356 c FFEINTRIN_impDTANH
16357 call fooD(DTANH(D1))
16360 c FFEINTRIN_impIABS
16361 call fooI(IABS(I1))
16362 c FFEINTRIN_impICHAR
16363 call fooI(ICHAR(A1))
16364 c FFEINTRIN_impIDIM
16365 call fooI(IDIM(I1,I2))
16366 c FFEINTRIN_impIDNINT
16367 call fooI(IDNINT(D1))
16368 c FFEINTRIN_impINDEX
16369 call fooI(INDEX(A1,A2))
16370 c FFEINTRIN_impISIGN
16371 call fooI(ISIGN(I1,I2))
16375 call fooL(LGE(A1,A2))
16377 call fooL(LGT(A1,A2))
16379 call fooL(LLE(A1,A2))
16381 call fooL(LLT(A1,A2))
16382 c FFEINTRIN_impMAX0
16383 call fooI(MAX0(I1,I2))
16384 c FFEINTRIN_impMAX1
16385 call fooI(MAX1(R1,R2))
16386 c FFEINTRIN_impMIN0
16387 call fooI(MIN0(I1,I2))
16388 c FFEINTRIN_impMIN1
16389 call fooI(MIN1(R1,R2))
16391 call fooI(MOD(I1,I2))
16392 c FFEINTRIN_impNINT
16393 call fooI(NINT(R1))
16394 c FFEINTRIN_impSIGN
16395 call fooR(SIGN(R1,R2))
16398 c FFEINTRIN_impSINH
16399 call fooR(SINH(R1))
16400 c FFEINTRIN_impSQRT
16401 call fooR(SQRT(R1))
16404 c FFEINTRIN_impTANH
16405 call fooR(TANH(R1))
16406 c FFEINTRIN_imp_CMPLX_C
16407 call fooC(cmplx(C1,C2))
16408 c FFEINTRIN_imp_CMPLX_D
16409 call fooZ(cmplx(D1,D2))
16410 c FFEINTRIN_imp_CMPLX_I
16411 call fooC(cmplx(I1,I2))
16412 c FFEINTRIN_imp_CMPLX_R
16413 call fooC(cmplx(R1,R2))
16414 c FFEINTRIN_imp_DBLE_C
16415 call fooD(dble(C1))
16416 c FFEINTRIN_imp_DBLE_D
16417 call fooD(dble(D1))
16418 c FFEINTRIN_imp_DBLE_I
16419 call fooD(dble(I1))
16420 c FFEINTRIN_imp_DBLE_R
16421 call fooD(dble(R1))
16422 c FFEINTRIN_imp_INT_C
16424 c FFEINTRIN_imp_INT_D
16426 c FFEINTRIN_imp_INT_I
16428 c FFEINTRIN_imp_INT_R
16430 c FFEINTRIN_imp_REAL_C
16431 call fooR(real(C1))
16432 c FFEINTRIN_imp_REAL_D
16433 call fooR(real(D1))
16434 c FFEINTRIN_imp_REAL_I
16435 call fooR(real(I1))
16436 c FFEINTRIN_imp_REAL_R
16437 call fooR(real(R1))
16439 c FFEINTRIN_imp_INT_D:
16441 c FFEINTRIN_specIDINT
16442 call fooI(IDINT(D1))
16444 c FFEINTRIN_imp_INT_R:
16446 c FFEINTRIN_specIFIX
16447 call fooI(IFIX(R1))
16448 c FFEINTRIN_specINT
16451 c FFEINTRIN_imp_REAL_D:
16453 c FFEINTRIN_specSNGL
16454 call fooR(SNGL(D1))
16456 c FFEINTRIN_imp_REAL_I:
16458 c FFEINTRIN_specFLOAT
16459 call fooR(FLOAT(I1))
16460 c FFEINTRIN_specREAL
16461 call fooR(REAL(I1))
16464 -------- (end input file to f2c)
16466 -------- (begin output from providing above input file as input to:
16467 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16468 -------- -e "s:^#.*$::g"')
16470 // -- translated by f2c (version 19950223).
16471 You must link the resulting object file with the libraries:
16472 -lf2c -lm (in that order)
16476 // f2c.h -- Standard Fortran to C header file //
16478 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
16480 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16485 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16486 // we assume short, float are OK //
16487 typedef long int // long int // integer;
16488 typedef char *address;
16489 typedef short int shortint;
16490 typedef float real;
16491 typedef double doublereal;
16492 typedef struct { real r, i; } complex;
16493 typedef struct { doublereal r, i; } doublecomplex;
16494 typedef long int // long int // logical;
16495 typedef short int shortlogical;
16496 typedef char logical1;
16497 typedef char integer1;
16498 // typedef long long longint; // // system-dependent //
16503 // Extern is for use with -E //
16517 typedef long int // int or long int // flag;
16518 typedef long int // int or long int // ftnlen;
16519 typedef long int // int or long int // ftnint;
16522 //external read, write//
16531 //internal read, write//
16561 //rewind, backspace, endfile//
16573 ftnint *inex; //parameters in standard's order//
16599 union Multitype { // for multiple entry points //
16610 typedef union Multitype Multitype;
16612 typedef long Long; // No longer used; formerly in Namelist //
16614 struct Vardesc { // for Namelist //
16620 typedef struct Vardesc Vardesc;
16627 typedef struct Namelist Namelist;
16636 // procedure parameter types for -A and -C++ //
16641 typedef int // Unknown procedure type // (*U_fp)();
16642 typedef shortint (*J_fp)();
16643 typedef integer (*I_fp)();
16644 typedef real (*R_fp)();
16645 typedef doublereal (*D_fp)(), (*E_fp)();
16646 typedef // Complex // void (*C_fp)();
16647 typedef // Double Complex // void (*Z_fp)();
16648 typedef logical (*L_fp)();
16649 typedef shortlogical (*K_fp)();
16650 typedef // Character // void (*H_fp)();
16651 typedef // Subroutine // int (*S_fp)();
16653 // E_fp is for real functions when -R is not specified //
16654 typedef void C_f; // complex function //
16655 typedef void H_f; // character function //
16656 typedef void Z_f; // double complex function //
16657 typedef doublereal E_f; // real function with -R not specified //
16659 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16662 // (No such symbols should be defined in a strict ANSI C compiler.
16663 We can avoid trouble with f2c-translated code by using
16664 gcc -ansi [-traditional].) //
16688 // Main program // MAIN__()
16690 // System generated locals //
16693 doublereal d__1, d__2;
16695 doublecomplex z__1, z__2, z__3;
16699 // Builtin functions //
16702 double pow_ri(), pow_di();
16706 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16707 asin(), atan(), atan2(), c_abs();
16708 void c_cos(), c_exp(), c_log(), r_cnjg();
16709 double cos(), cosh();
16710 void c_sin(), c_sqrt();
16711 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16712 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16713 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16714 logical l_ge(), l_gt(), l_le(), l_lt();
16718 // Local variables //
16719 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16720 fool_(), fooz_(), getem_();
16721 static char a1[10], a2[10];
16722 static complex c1, c2;
16723 static doublereal d1, d2;
16724 static integer i1, i2;
16725 static real r1, r2;
16728 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16736 d__1 = (doublereal) i1;
16737 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16747 c_div(&q__1, &c1, &c2);
16749 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16751 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16754 i__1 = pow_ii(&i1, &i2);
16756 r__1 = pow_ri(&r1, &i1);
16758 d__1 = pow_di(&d1, &i1);
16760 pow_ci(&q__1, &c1, &i1);
16762 d__1 = (doublereal) r1;
16763 d__2 = (doublereal) r2;
16764 r__1 = pow_dd(&d__1, &d__2);
16766 d__2 = (doublereal) r1;
16767 d__1 = pow_dd(&d__2, &d1);
16769 d__1 = pow_dd(&d1, &d2);
16771 d__2 = (doublereal) r1;
16772 d__1 = pow_dd(&d1, &d__2);
16774 z__2.r = c1.r, z__2.i = c1.i;
16775 z__3.r = c2.r, z__3.i = c2.i;
16776 pow_zz(&z__1, &z__2, &z__3);
16777 q__1.r = z__1.r, q__1.i = z__1.i;
16779 z__2.r = c1.r, z__2.i = c1.i;
16780 z__3.r = r1, z__3.i = 0.;
16781 pow_zz(&z__1, &z__2, &z__3);
16782 q__1.r = z__1.r, q__1.i = z__1.i;
16784 z__2.r = c1.r, z__2.i = c1.i;
16785 z__3.r = d1, z__3.i = 0.;
16786 pow_zz(&z__1, &z__2, &z__3);
16788 // FFEINTRIN_impABS //
16789 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16791 // FFEINTRIN_impACOS //
16794 // FFEINTRIN_impAIMAG //
16795 r__1 = r_imag(&c1);
16797 // FFEINTRIN_impAINT //
16800 // FFEINTRIN_impALOG //
16803 // FFEINTRIN_impALOG10 //
16804 r__1 = r_lg10(&r1);
16806 // FFEINTRIN_impAMAX0 //
16807 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16809 // FFEINTRIN_impAMAX1 //
16810 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16812 // FFEINTRIN_impAMIN0 //
16813 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16815 // FFEINTRIN_impAMIN1 //
16816 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16818 // FFEINTRIN_impAMOD //
16819 r__1 = r_mod(&r1, &r2);
16821 // FFEINTRIN_impANINT //
16822 r__1 = r_nint(&r1);
16824 // FFEINTRIN_impASIN //
16827 // FFEINTRIN_impATAN //
16830 // FFEINTRIN_impATAN2 //
16831 r__1 = atan2(r1, r2);
16833 // FFEINTRIN_impCABS //
16836 // FFEINTRIN_impCCOS //
16839 // FFEINTRIN_impCEXP //
16842 // FFEINTRIN_impCHAR //
16843 *(unsigned char *)&ch__1[0] = i1;
16845 // FFEINTRIN_impCLOG //
16848 // FFEINTRIN_impCONJG //
16849 r_cnjg(&q__1, &c1);
16851 // FFEINTRIN_impCOS //
16854 // FFEINTRIN_impCOSH //
16857 // FFEINTRIN_impCSIN //
16860 // FFEINTRIN_impCSQRT //
16861 c_sqrt(&q__1, &c1);
16863 // FFEINTRIN_impDABS //
16864 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16866 // FFEINTRIN_impDACOS //
16869 // FFEINTRIN_impDASIN //
16872 // FFEINTRIN_impDATAN //
16875 // FFEINTRIN_impDATAN2 //
16876 d__1 = atan2(d1, d2);
16878 // FFEINTRIN_impDCOS //
16881 // FFEINTRIN_impDCOSH //
16884 // FFEINTRIN_impDDIM //
16885 d__1 = d_dim(&d1, &d2);
16887 // FFEINTRIN_impDEXP //
16890 // FFEINTRIN_impDIM //
16891 r__1 = r_dim(&r1, &r2);
16893 // FFEINTRIN_impDINT //
16896 // FFEINTRIN_impDLOG //
16899 // FFEINTRIN_impDLOG10 //
16900 d__1 = d_lg10(&d1);
16902 // FFEINTRIN_impDMAX1 //
16903 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16905 // FFEINTRIN_impDMIN1 //
16906 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16908 // FFEINTRIN_impDMOD //
16909 d__1 = d_mod(&d1, &d2);
16911 // FFEINTRIN_impDNINT //
16912 d__1 = d_nint(&d1);
16914 // FFEINTRIN_impDPROD //
16915 d__1 = (doublereal) r1 * r2;
16917 // FFEINTRIN_impDSIGN //
16918 d__1 = d_sign(&d1, &d2);
16920 // FFEINTRIN_impDSIN //
16923 // FFEINTRIN_impDSINH //
16926 // FFEINTRIN_impDSQRT //
16929 // FFEINTRIN_impDTAN //
16932 // FFEINTRIN_impDTANH //
16935 // FFEINTRIN_impEXP //
16938 // FFEINTRIN_impIABS //
16939 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16941 // FFEINTRIN_impICHAR //
16942 i__1 = *(unsigned char *)a1;
16944 // FFEINTRIN_impIDIM //
16945 i__1 = i_dim(&i1, &i2);
16947 // FFEINTRIN_impIDNINT //
16948 i__1 = i_dnnt(&d1);
16950 // FFEINTRIN_impINDEX //
16951 i__1 = i_indx(a1, a2, 10L, 10L);
16953 // FFEINTRIN_impISIGN //
16954 i__1 = i_sign(&i1, &i2);
16956 // FFEINTRIN_impLEN //
16957 i__1 = i_len(a1, 10L);
16959 // FFEINTRIN_impLGE //
16960 L__1 = l_ge(a1, a2, 10L, 10L);
16962 // FFEINTRIN_impLGT //
16963 L__1 = l_gt(a1, a2, 10L, 10L);
16965 // FFEINTRIN_impLLE //
16966 L__1 = l_le(a1, a2, 10L, 10L);
16968 // FFEINTRIN_impLLT //
16969 L__1 = l_lt(a1, a2, 10L, 10L);
16971 // FFEINTRIN_impMAX0 //
16972 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16974 // FFEINTRIN_impMAX1 //
16975 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16977 // FFEINTRIN_impMIN0 //
16978 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16980 // FFEINTRIN_impMIN1 //
16981 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16983 // FFEINTRIN_impMOD //
16986 // FFEINTRIN_impNINT //
16987 i__1 = i_nint(&r1);
16989 // FFEINTRIN_impSIGN //
16990 r__1 = r_sign(&r1, &r2);
16992 // FFEINTRIN_impSIN //
16995 // FFEINTRIN_impSINH //
16998 // FFEINTRIN_impSQRT //
17001 // FFEINTRIN_impTAN //
17004 // FFEINTRIN_impTANH //
17007 // FFEINTRIN_imp_CMPLX_C //
17010 q__1.r = r__1, q__1.i = r__2;
17012 // FFEINTRIN_imp_CMPLX_D //
17013 z__1.r = d1, z__1.i = d2;
17015 // FFEINTRIN_imp_CMPLX_I //
17018 q__1.r = r__1, q__1.i = r__2;
17020 // FFEINTRIN_imp_CMPLX_R //
17021 q__1.r = r1, q__1.i = r2;
17023 // FFEINTRIN_imp_DBLE_C //
17024 d__1 = (doublereal) c1.r;
17026 // FFEINTRIN_imp_DBLE_D //
17029 // FFEINTRIN_imp_DBLE_I //
17030 d__1 = (doublereal) i1;
17032 // FFEINTRIN_imp_DBLE_R //
17033 d__1 = (doublereal) r1;
17035 // FFEINTRIN_imp_INT_C //
17036 i__1 = (integer) c1.r;
17038 // FFEINTRIN_imp_INT_D //
17039 i__1 = (integer) d1;
17041 // FFEINTRIN_imp_INT_I //
17044 // FFEINTRIN_imp_INT_R //
17045 i__1 = (integer) r1;
17047 // FFEINTRIN_imp_REAL_C //
17050 // FFEINTRIN_imp_REAL_D //
17053 // FFEINTRIN_imp_REAL_I //
17056 // FFEINTRIN_imp_REAL_R //
17060 // FFEINTRIN_imp_INT_D: //
17062 // FFEINTRIN_specIDINT //
17063 i__1 = (integer) d1;
17066 // FFEINTRIN_imp_INT_R: //
17068 // FFEINTRIN_specIFIX //
17069 i__1 = (integer) r1;
17071 // FFEINTRIN_specINT //
17072 i__1 = (integer) r1;
17075 // FFEINTRIN_imp_REAL_D: //
17077 // FFEINTRIN_specSNGL //
17081 // FFEINTRIN_imp_REAL_I: //
17083 // FFEINTRIN_specFLOAT //
17086 // FFEINTRIN_specREAL //
17092 -------- (end output file from f2c)