1 /* com.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
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! */
93 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
95 #define FFECOM_GCC_INCLUDE 1 /* Enable -I. */
97 /* BEGIN stuff from gcc/cccp.c. */
99 /* The following symbols should be autoconfigured:
106 In the mean time, we'll get by with approximations based
107 on existing GCC configuration symbols. */
110 # ifndef HAVE_STDLIB_H
111 # define HAVE_STDLIB_H 1
113 # ifndef HAVE_UNISTD_H
114 # define HAVE_UNISTD_H 1
116 # ifndef STDC_HEADERS
117 # define STDC_HEADERS 1
119 #endif /* defined (POSIX) */
121 #if defined (POSIX) || (defined (USG) && !defined (VMS))
122 # ifndef HAVE_FCNTL_H
123 # define HAVE_FCNTL_H 1
130 # if TIME_WITH_SYS_TIME
131 # include <sys/time.h>
135 # include <sys/time.h>
140 # include <sys/resource.h>
147 /* This defines "errno" properly for VMS, and gives us EACCES. */
160 /* VMS-specific definitions */
163 #define O_RDONLY 0 /* Open arg for Read/Only */
164 #define O_WRONLY 1 /* Open arg for Write/Only */
165 #define read(fd,buf,size) VMS_read (fd,buf,size)
166 #define write(fd,buf,size) VMS_write (fd,buf,size)
167 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
168 #define fopen(fname,mode) VMS_fopen (fname,mode)
169 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
170 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
171 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
172 static int VMS_fstat (), VMS_stat ();
173 static char * VMS_strncat ();
174 static int VMS_read ();
175 static int VMS_write ();
176 static int VMS_open ();
177 static FILE * VMS_fopen ();
178 static FILE * VMS_freopen ();
179 static void hack_vms_include_specification ();
180 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
181 #define ino_t vms_ino_t
182 #define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */
184 #define BSTRING /* VMS/GCC supplies the bstring routines */
185 #endif /* __GNUC__ */
192 /* END stuff from gcc/cccp.c. */
194 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
211 /* Externals defined here. */
213 #if FFECOM_targetCURRENT == FFECOM_targetGCC
215 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
218 const char * const language_string = "GNU F77";
220 /* Stream for reading from the input file. */
223 /* These definitions parallel those in c-decl.c so that code from that
224 module can be used pretty much as is. Much of these defs aren't
225 otherwise used, i.e. by g77 code per se, except some of them are used
226 to build some of them that are. The ones that are global (i.e. not
227 "static") are those that ste.c and such might use (directly
228 or by using com macros that reference them in their definitions). */
230 tree string_type_node;
232 /* The rest of these are inventions for g77, though there might be
233 similar things in the C front end. As they are found, these
234 inventions should be renamed to be canonical. Note that only
235 the ones currently required to be global are so. */
237 static tree ffecom_tree_fun_type_void;
239 tree ffecom_integer_type_node; /* Abbrev for _tree_type[blah][blah]. */
240 tree ffecom_integer_zero_node; /* Like *_*_* with g77's integer type. */
241 tree ffecom_integer_one_node; /* " */
242 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
244 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
245 just use build_function_type and build_pointer_type on the
246 appropriate _tree_type array element. */
248 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
249 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
250 static tree ffecom_tree_subr_type;
251 static tree ffecom_tree_ptr_to_subr_type;
252 static tree ffecom_tree_blockdata_type;
254 static tree ffecom_tree_xargc_;
256 ffecomSymbol ffecom_symbol_null_
265 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
266 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
268 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
269 tree ffecom_f2c_integer_type_node;
270 tree ffecom_f2c_ptr_to_integer_type_node;
271 tree ffecom_f2c_address_type_node;
272 tree ffecom_f2c_real_type_node;
273 tree ffecom_f2c_ptr_to_real_type_node;
274 tree ffecom_f2c_doublereal_type_node;
275 tree ffecom_f2c_complex_type_node;
276 tree ffecom_f2c_doublecomplex_type_node;
277 tree ffecom_f2c_longint_type_node;
278 tree ffecom_f2c_logical_type_node;
279 tree ffecom_f2c_flag_type_node;
280 tree ffecom_f2c_ftnlen_type_node;
281 tree ffecom_f2c_ftnlen_zero_node;
282 tree ffecom_f2c_ftnlen_one_node;
283 tree ffecom_f2c_ftnlen_two_node;
284 tree ffecom_f2c_ptr_to_ftnlen_type_node;
285 tree ffecom_f2c_ftnint_type_node;
286 tree ffecom_f2c_ptr_to_ftnint_type_node;
287 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
289 /* Simple definitions and enumerations. */
291 #ifndef FFECOM_sizeMAXSTACKITEM
292 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
293 larger than this # bytes
294 off stack if possible. */
297 /* For systems that have large enough stacks, they should define
298 this to 0, and here, for ease of use later on, we just undefine
301 #if FFECOM_sizeMAXSTACKITEM == 0
302 #undef FFECOM_sizeMAXSTACKITEM
308 FFECOM_rttypeVOIDSTAR_, /* C's `void *' type. */
309 FFECOM_rttypeFTNINT_, /* f2c's `ftnint' type. */
310 FFECOM_rttypeINTEGER_, /* f2c's `integer' type. */
311 FFECOM_rttypeLONGINT_, /* f2c's `longint' type. */
312 FFECOM_rttypeLOGICAL_, /* f2c's `logical' type. */
313 FFECOM_rttypeREAL_F2C_, /* f2c's `real' returned as `double'. */
314 FFECOM_rttypeREAL_GNU_, /* `real' returned as such. */
315 FFECOM_rttypeCOMPLEX_F2C_, /* f2c's `complex' returned via 1st arg. */
316 FFECOM_rttypeCOMPLEX_GNU_, /* f2c's `complex' returned directly. */
317 FFECOM_rttypeDOUBLE_, /* C's `double' type. */
318 FFECOM_rttypeDOUBLEREAL_, /* f2c's `doublereal' type. */
319 FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
320 FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
321 FFECOM_rttypeCHARACTER_, /* f2c `char *'/`ftnlen' pair. */
325 /* Internal typedefs. */
327 #if FFECOM_targetCURRENT == FFECOM_targetGCC
328 typedef struct _ffecom_concat_list_ ffecomConcatList_;
329 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
331 /* Private include files. */
334 /* Internal structure definitions. */
336 #if FFECOM_targetCURRENT == FFECOM_targetGCC
337 struct _ffecom_concat_list_
342 ffetargetCharacterSize minlen;
343 ffetargetCharacterSize maxlen;
345 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
347 /* Static functions (internal). */
349 #if FFECOM_targetCURRENT == FFECOM_targetGCC
350 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
351 static tree ffecom_widest_expr_type_ (ffebld list);
352 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
353 tree dest_size, tree source_tree,
354 ffebld source, bool scalar_arg);
355 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
356 tree args, tree callee_commons,
358 static tree ffecom_build_f2c_string_ (int i, const char *s);
359 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
360 bool is_f2c_complex, tree type,
361 tree args, tree dest_tree,
362 ffebld dest, bool *dest_used,
363 tree callee_commons, bool scalar_args, tree hook);
364 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
365 bool is_f2c_complex, tree type,
366 ffebld left, ffebld right,
367 tree dest_tree, ffebld dest,
368 bool *dest_used, tree callee_commons,
369 bool scalar_args, bool ref, tree hook);
370 static void ffecom_char_args_x_ (tree *xitem, tree *length,
371 ffebld expr, bool with_null);
372 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
373 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
374 static ffecomConcatList_
375 ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
377 ffetargetCharacterSize max);
378 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
379 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
380 ffetargetCharacterSize max);
381 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
382 ffesymbol member, tree member_type,
383 ffetargetOffset offset);
384 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
385 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
386 bool *dest_used, bool assignp, bool widenp);
387 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
388 ffebld dest, bool *dest_used);
389 static tree ffecom_expr_power_integer_ (ffebld expr);
390 static void ffecom_expr_transform_ (ffebld expr);
391 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
392 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
394 static ffeglobal ffecom_finish_global_ (ffeglobal global);
395 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
396 static tree ffecom_get_appended_identifier_ (char us, const char *text);
397 static tree ffecom_get_external_identifier_ (ffesymbol s);
398 static tree ffecom_get_identifier_ (const char *text);
399 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
402 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
403 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
404 static tree ffecom_init_zero_ (tree decl);
405 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
407 static tree ffecom_intrinsic_len_ (ffebld expr);
408 static void ffecom_let_char_ (tree dest_tree,
410 ffetargetCharacterSize dest_size,
412 static void ffecom_make_gfrt_ (ffecomGfrt ix);
413 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
414 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
415 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
417 static void ffecom_push_dummy_decls_ (ffebld dumlist,
419 static void ffecom_start_progunit_ (void);
420 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
421 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
422 static void ffecom_transform_common_ (ffesymbol s);
423 static void ffecom_transform_equiv_ (ffestorag st);
424 static tree ffecom_transform_namelist_ (ffesymbol s);
425 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
427 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
428 tree *size, tree tree);
429 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
430 tree dest_tree, ffebld dest,
431 bool *dest_used, tree hook);
432 static tree ffecom_type_localvar_ (ffesymbol s,
435 static tree ffecom_type_namelist_ (void);
436 static tree ffecom_type_vardesc_ (void);
437 static tree ffecom_vardesc_ (ffebld expr);
438 static tree ffecom_vardesc_array_ (ffesymbol s);
439 static tree ffecom_vardesc_dims_ (ffesymbol s);
440 static tree ffecom_convert_narrow_ (tree type, tree expr);
441 static tree ffecom_convert_widen_ (tree type, tree expr);
442 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
444 /* These are static functions that parallel those found in the C front
445 end and thus have the same names. */
447 #if FFECOM_targetCURRENT == FFECOM_targetGCC
448 static tree bison_rule_compstmt_ (void);
449 static void bison_rule_pushlevel_ (void);
450 static void delete_block (tree block);
451 static int duplicate_decls (tree newdecl, tree olddecl);
452 static void finish_decl (tree decl, tree init, bool is_top_level);
453 static void finish_function (int nested);
454 static const char *lang_printable_name (tree decl, int v);
455 static tree lookup_name_current_level (tree name);
456 static struct binding_level *make_binding_level (void);
457 static void pop_f_function_context (void);
458 static void push_f_function_context (void);
459 static void push_parm_decl (tree parm);
460 static tree pushdecl_top_level (tree decl);
461 static int kept_level_p (void);
462 static tree storedecls (tree decls);
463 static void store_parm_decls (int is_main_program);
464 static tree start_decl (tree decl, bool is_top_level);
465 static void start_function (tree name, tree type, int nested, int public);
466 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
467 #if FFECOM_GCC_INCLUDE
468 static void ffecom_file_ (const char *name);
469 static void ffecom_initialize_char_syntax_ (void);
470 static void ffecom_close_include_ (FILE *f);
471 static int ffecom_decode_include_option_ (char *spec);
472 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
474 #endif /* FFECOM_GCC_INCLUDE */
476 /* Static objects accessed by functions in this module. */
478 static ffesymbol ffecom_primary_entry_ = NULL;
479 static ffesymbol ffecom_nested_entry_ = NULL;
480 static ffeinfoKind ffecom_primary_entry_kind_;
481 static bool ffecom_primary_entry_is_proc_;
482 #if FFECOM_targetCURRENT == FFECOM_targetGCC
483 static tree ffecom_outer_function_decl_;
484 static tree ffecom_previous_function_decl_;
485 static tree ffecom_which_entrypoint_decl_;
486 static tree ffecom_float_zero_ = NULL_TREE;
487 static tree ffecom_float_half_ = NULL_TREE;
488 static tree ffecom_double_zero_ = NULL_TREE;
489 static tree ffecom_double_half_ = NULL_TREE;
490 static tree ffecom_func_result_;/* For functions. */
491 static tree ffecom_func_length_;/* For CHARACTER fns. */
492 static ffebld ffecom_list_blockdata_;
493 static ffebld ffecom_list_common_;
494 static ffebld ffecom_master_arglist_;
495 static ffeinfoBasictype ffecom_master_bt_;
496 static ffeinfoKindtype ffecom_master_kt_;
497 static ffetargetCharacterSize ffecom_master_size_;
498 static int ffecom_num_fns_ = 0;
499 static int ffecom_num_entrypoints_ = 0;
500 static bool ffecom_is_altreturning_ = FALSE;
501 static tree ffecom_multi_type_node_;
502 static tree ffecom_multi_retval_;
504 ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
505 static bool ffecom_member_namelisted_; /* _member_phase1_ namelisted? */
506 static bool ffecom_doing_entry_ = FALSE;
507 static bool ffecom_transform_only_dummies_ = FALSE;
508 static int ffecom_typesize_pointer_;
509 static int ffecom_typesize_integer1_;
511 /* Holds pointer-to-function expressions. */
513 static tree ffecom_gfrt_[FFECOM_gfrt]
516 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
517 #include "com-rt.def"
521 /* Holds the external names of the functions. */
523 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
526 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
527 #include "com-rt.def"
531 /* Whether the function returns. */
533 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
536 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
537 #include "com-rt.def"
541 /* Whether the function returns type complex. */
543 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
546 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
547 #include "com-rt.def"
551 /* Whether the function is const
552 (i.e., has no side effects and only depends on its arguments). */
554 static bool ffecom_gfrt_const_[FFECOM_gfrt]
557 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
558 #include "com-rt.def"
562 /* Type code for the function return value. */
564 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
567 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
568 #include "com-rt.def"
572 /* String of codes for the function's arguments. */
574 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
577 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
578 #include "com-rt.def"
581 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
583 /* Internal macros. */
585 #if FFECOM_targetCURRENT == FFECOM_targetGCC
587 /* We let tm.h override the types used here, to handle trivial differences
588 such as the choice of unsigned int or long unsigned int for size_t.
589 When machines start needing nontrivial differences in the size type,
590 it would be best to do something here to figure out automatically
591 from other information what type to use. */
594 #define SIZE_TYPE "long unsigned int"
597 #define ffecom_concat_list_count_(catlist) ((catlist).count)
598 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
599 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
600 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
602 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
603 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
605 /* For each binding contour we allocate a binding_level structure
606 * which records the names defined in that contour.
609 * 1) one for each function definition,
610 * where internal declarations of the parameters appear.
612 * The current meaning of a name can be found by searching the levels from
613 * the current one out to the global one.
616 /* Note that the information in the `names' component of the global contour
617 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
621 /* A chain of _DECL nodes for all variables, constants, functions,
622 and typedef types. These are in the reverse of the order supplied.
626 /* For each level (except not the global one),
627 a chain of BLOCK nodes for all the levels
628 that were entered and exited one level down. */
631 /* The BLOCK node for this level, if one has been preallocated.
632 If 0, the BLOCK is allocated (if needed) when the level is popped. */
635 /* The binding level which this one is contained in (inherits from). */
636 struct binding_level *level_chain;
638 /* 0: no ffecom_prepare_* functions called at this level yet;
639 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
640 2: ffecom_prepare_end called. */
644 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
646 /* The binding level currently in effect. */
648 static struct binding_level *current_binding_level;
650 /* A chain of binding_level structures awaiting reuse. */
652 static struct binding_level *free_binding_level;
654 /* The outermost binding level, for names of file scope.
655 This is created when the compiler is started and exists
656 through the entire run. */
658 static struct binding_level *global_binding_level;
660 /* Binding level structures are initialized by copying this one. */
662 static struct binding_level clear_binding_level
664 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
666 /* Language-dependent contents of an identifier. */
668 struct lang_identifier
670 struct tree_identifier ignore;
671 tree global_value, local_value, label_value;
675 /* Macros for access to language-specific slots in an identifier. */
676 /* Each of these slots contains a DECL node or null. */
678 /* This represents the value which the identifier has in the
679 file-scope namespace. */
680 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
681 (((struct lang_identifier *)(NODE))->global_value)
682 /* This represents the value which the identifier has in the current
684 #define IDENTIFIER_LOCAL_VALUE(NODE) \
685 (((struct lang_identifier *)(NODE))->local_value)
686 /* This represents the value which the identifier has as a label in
687 the current label scope. */
688 #define IDENTIFIER_LABEL_VALUE(NODE) \
689 (((struct lang_identifier *)(NODE))->label_value)
690 /* This is nonzero if the identifier was "made up" by g77 code. */
691 #define IDENTIFIER_INVENTED(NODE) \
692 (((struct lang_identifier *)(NODE))->invented)
694 /* In identifiers, C uses the following fields in a special way:
695 TREE_PUBLIC to record that there was a previous local extern decl.
696 TREE_USED to record that such a decl was used.
697 TREE_ADDRESSABLE to record that the address of such a decl was used. */
699 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
700 that have names. Here so we can clear out their names' definitions
701 at the end of the function. */
703 static tree named_labels;
705 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
707 static tree shadowed_labels;
709 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
711 /* Return the subscript expression, modified to do range-checking.
713 `array' is the array to be checked against.
714 `element' is the subscript expression to check.
715 `dim' is the dimension number (starting at 0).
716 `total_dims' is the total number of dimensions (0 for CHARACTER substring).
720 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
721 const char *array_name)
723 tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
724 tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
729 if (element == error_mark_node)
732 if (TREE_TYPE (low) != TREE_TYPE (element))
734 if (TYPE_PRECISION (TREE_TYPE (low))
735 > TYPE_PRECISION (TREE_TYPE (element)))
736 element = convert (TREE_TYPE (low), element);
739 low = convert (TREE_TYPE (element), low);
741 high = convert (TREE_TYPE (element), high);
745 element = ffecom_save_tree (element);
746 cond = ffecom_2 (LE_EXPR, integer_type_node,
751 cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
753 ffecom_2 (LE_EXPR, integer_type_node,
770 var = xmalloc (strlen (array_name) + 20);
771 sprintf (var, "%s[%s-substring]",
773 dim ? "end" : "start");
774 len = strlen (var) + 1;
775 arg1 = build_string (len, var);
780 len = strlen (array_name) + 1;
781 arg1 = build_string (len, array_name);
785 var = xmalloc (strlen (array_name) + 40);
786 sprintf (var, "%s[subscript-%d-of-%d]",
788 dim + 1, total_dims);
789 len = strlen (var) + 1;
790 arg1 = build_string (len, var);
796 = build_type_variant (build_array_type (char_type_node,
800 build_int_2 (len, 0))),
802 TREE_CONSTANT (arg1) = 1;
803 TREE_STATIC (arg1) = 1;
804 arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
807 /* s_rnge adds one to the element to print it, so bias against
808 that -- want to print a faithful *subscript* value. */
809 arg2 = convert (ffecom_f2c_ftnint_type_node,
810 ffecom_2 (MINUS_EXPR,
813 convert (TREE_TYPE (element),
816 proc = xmalloc ((len = strlen (input_filename)
817 + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl))
820 sprintf (&proc[0], "%s/%s",
822 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
823 arg3 = build_string (len, proc);
828 = build_type_variant (build_array_type (char_type_node,
832 build_int_2 (len, 0))),
834 TREE_CONSTANT (arg3) = 1;
835 TREE_STATIC (arg3) = 1;
836 arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
839 arg4 = convert (ffecom_f2c_ftnint_type_node,
840 build_int_2 (lineno, 0));
842 arg1 = build_tree_list (NULL_TREE, arg1);
843 arg2 = build_tree_list (NULL_TREE, arg2);
844 arg3 = build_tree_list (NULL_TREE, arg3);
845 arg4 = build_tree_list (NULL_TREE, arg4);
846 TREE_CHAIN (arg3) = arg4;
847 TREE_CHAIN (arg2) = arg3;
848 TREE_CHAIN (arg1) = arg2;
852 die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
854 TREE_SIDE_EFFECTS (die) = 1;
856 element = ffecom_3 (COND_EXPR,
865 /* Return the computed element of an array reference.
867 `item' is NULL_TREE, or the transformed pointer to the array.
868 `expr' is the original opARRAYREF expression, which is transformed
869 if `item' is NULL_TREE.
870 `want_ptr' is non-zero if a pointer to the element, instead of
871 the element itself, is to be returned. */
874 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
876 ffebld dims[FFECOM_dimensionsMAX];
879 int flatten = ffe_is_flatten_arrays ();
885 const char *array_name;
889 if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
890 array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
892 array_name = "[expr?]";
894 /* Build up ARRAY_REFs in reverse order (since we're column major
895 here in Fortran land). */
897 for (i = 0, list = ffebld_right (expr);
899 ++i, list = ffebld_trail (list))
901 dims[i] = ffebld_head (list);
902 type = ffeinfo_type (ffebld_basictype (dims[i]),
903 ffebld_kindtype (dims[i]));
905 && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
906 && ffetype_size (type) > ffecom_typesize_integer1_)
907 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
908 pointers and 32-bit integers. Do the full 64-bit pointer
909 arithmetic, for codes using arrays for nonstandard heap-like
916 need_ptr = want_ptr || flatten;
921 item = ffecom_ptr_to_expr (ffebld_left (expr));
923 item = ffecom_expr (ffebld_left (expr));
925 if (item == error_mark_node)
928 if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
929 && ! mark_addressable (item))
930 return error_mark_node;
933 if (item == error_mark_node)
940 for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
942 --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
944 min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
945 element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
946 if (flag_bounds_check)
947 element = ffecom_subscript_check_ (array, element, i, total_dims,
949 if (element == error_mark_node)
952 /* Widen integral arithmetic as desired while preserving
954 tree_type = TREE_TYPE (element);
955 tree_type_x = tree_type;
957 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
958 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
959 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
961 if (TREE_TYPE (min) != tree_type_x)
962 min = convert (tree_type_x, min);
963 if (TREE_TYPE (element) != tree_type_x)
964 element = convert (tree_type_x, element);
966 item = ffecom_2 (PLUS_EXPR,
967 build_pointer_type (TREE_TYPE (array)),
969 size_binop (MULT_EXPR,
970 size_in_bytes (TREE_TYPE (array)),
972 fold (build (MINUS_EXPR,
978 item = ffecom_1 (INDIRECT_REF,
979 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
989 array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
991 element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
992 if (flag_bounds_check)
993 element = ffecom_subscript_check_ (array, element, i, total_dims,
995 if (element == error_mark_node)
998 /* Widen integral arithmetic as desired while preserving
1000 tree_type = TREE_TYPE (element);
1001 tree_type_x = tree_type;
1003 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
1004 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
1005 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
1007 element = convert (tree_type_x, element);
1009 item = ffecom_2 (ARRAY_REF,
1010 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
1019 /* This is like gcc's stabilize_reference -- in fact, most of the code
1020 comes from that -- but it handles the situation where the reference
1021 is going to have its subparts picked at, and it shouldn't change
1022 (or trigger extra invocations of functions in the subtrees) due to
1023 this. save_expr is a bit overzealous, because we don't need the
1024 entire thing calculated and saved like a temp. So, for DECLs, no
1025 change is needed, because these are stable aggregates, and ARRAY_REF
1026 and such might well be stable too, but for things like calculations,
1027 we do need to calculate a snapshot of a value before picking at it. */
1029 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1031 ffecom_stabilize_aggregate_ (tree ref)
1034 enum tree_code code = TREE_CODE (ref);
1041 /* No action is needed in this case. */
1047 case FIX_TRUNC_EXPR:
1048 case FIX_FLOOR_EXPR:
1049 case FIX_ROUND_EXPR:
1051 result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1055 result = build_nt (INDIRECT_REF,
1056 stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1060 result = build_nt (COMPONENT_REF,
1061 stabilize_reference (TREE_OPERAND (ref, 0)),
1062 TREE_OPERAND (ref, 1));
1066 result = build_nt (BIT_FIELD_REF,
1067 stabilize_reference (TREE_OPERAND (ref, 0)),
1068 stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1069 stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1073 result = build_nt (ARRAY_REF,
1074 stabilize_reference (TREE_OPERAND (ref, 0)),
1075 stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1079 result = build_nt (COMPOUND_EXPR,
1080 stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1081 stabilize_reference (TREE_OPERAND (ref, 1)));
1089 return save_expr (ref);
1092 return error_mark_node;
1095 TREE_TYPE (result) = TREE_TYPE (ref);
1096 TREE_READONLY (result) = TREE_READONLY (ref);
1097 TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1098 TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1104 /* A rip-off of gcc's convert.c convert_to_complex function,
1105 reworked to handle complex implemented as C structures
1106 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1108 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1110 ffecom_convert_to_complex_ (tree type, tree expr)
1112 register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1115 assert (TREE_CODE (type) == RECORD_TYPE);
1117 subtype = TREE_TYPE (TYPE_FIELDS (type));
1119 if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1121 expr = convert (subtype, expr);
1122 return ffecom_2 (COMPLEX_EXPR, type, expr,
1123 convert (subtype, integer_zero_node));
1126 if (form == RECORD_TYPE)
1128 tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1129 if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1133 expr = save_expr (expr);
1134 return ffecom_2 (COMPLEX_EXPR,
1137 ffecom_1 (REALPART_EXPR,
1138 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1141 ffecom_1 (IMAGPART_EXPR,
1142 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1147 if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1148 error ("pointer value used where a complex was expected");
1150 error ("aggregate value used where a complex was expected");
1152 return ffecom_2 (COMPLEX_EXPR, type,
1153 convert (subtype, integer_zero_node),
1154 convert (subtype, integer_zero_node));
1158 /* Like gcc's convert(), but crashes if widening might happen. */
1160 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1162 ffecom_convert_narrow_ (type, expr)
1165 register tree e = expr;
1166 register enum tree_code code = TREE_CODE (type);
1168 if (type == TREE_TYPE (e)
1169 || TREE_CODE (e) == ERROR_MARK)
1171 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1172 return fold (build1 (NOP_EXPR, type, e));
1173 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1174 || code == ERROR_MARK)
1175 return error_mark_node;
1176 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1178 assert ("void value not ignored as it ought to be" == NULL);
1179 return error_mark_node;
1181 assert (code != VOID_TYPE);
1182 if ((code != RECORD_TYPE)
1183 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1184 assert ("converting COMPLEX to REAL" == NULL);
1185 assert (code != ENUMERAL_TYPE);
1186 if (code == INTEGER_TYPE)
1188 assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1189 && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1190 || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1191 && (TYPE_PRECISION (type)
1192 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1193 return fold (convert_to_integer (type, e));
1195 if (code == POINTER_TYPE)
1197 assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1198 return fold (convert_to_pointer (type, e));
1200 if (code == REAL_TYPE)
1202 assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1203 assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1204 return fold (convert_to_real (type, e));
1206 if (code == COMPLEX_TYPE)
1208 assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1209 assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1210 return fold (convert_to_complex (type, e));
1212 if (code == RECORD_TYPE)
1214 assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1215 /* Check that at least the first field name agrees. */
1216 assert (DECL_NAME (TYPE_FIELDS (type))
1217 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1218 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1219 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1220 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1221 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1223 return fold (ffecom_convert_to_complex_ (type, e));
1226 assert ("conversion to non-scalar type requested" == NULL);
1227 return error_mark_node;
1231 /* Like gcc's convert(), but crashes if narrowing might happen. */
1233 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1235 ffecom_convert_widen_ (type, expr)
1238 register tree e = expr;
1239 register enum tree_code code = TREE_CODE (type);
1241 if (type == TREE_TYPE (e)
1242 || TREE_CODE (e) == ERROR_MARK)
1244 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1245 return fold (build1 (NOP_EXPR, type, e));
1246 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1247 || code == ERROR_MARK)
1248 return error_mark_node;
1249 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1251 assert ("void value not ignored as it ought to be" == NULL);
1252 return error_mark_node;
1254 assert (code != VOID_TYPE);
1255 if ((code != RECORD_TYPE)
1256 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1257 assert ("narrowing COMPLEX to REAL" == NULL);
1258 assert (code != ENUMERAL_TYPE);
1259 if (code == INTEGER_TYPE)
1261 assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1262 && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1263 || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1264 && (TYPE_PRECISION (type)
1265 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1266 return fold (convert_to_integer (type, e));
1268 if (code == POINTER_TYPE)
1270 assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1271 return fold (convert_to_pointer (type, e));
1273 if (code == REAL_TYPE)
1275 assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1276 assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1277 return fold (convert_to_real (type, e));
1279 if (code == COMPLEX_TYPE)
1281 assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1282 assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1283 return fold (convert_to_complex (type, e));
1285 if (code == RECORD_TYPE)
1287 assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1288 /* Check that at least the first field name agrees. */
1289 assert (DECL_NAME (TYPE_FIELDS (type))
1290 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1291 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1292 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1293 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1294 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1296 return fold (ffecom_convert_to_complex_ (type, e));
1299 assert ("conversion to non-scalar type requested" == NULL);
1300 return error_mark_node;
1304 /* Handles making a COMPLEX type, either the standard
1305 (but buggy?) gbe way, or the safer (but less elegant?)
1308 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1310 ffecom_make_complex_type_ (tree subtype)
1316 if (ffe_is_emulate_complex ())
1318 type = make_node (RECORD_TYPE);
1319 realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1320 imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1321 TYPE_FIELDS (type) = realfield;
1326 type = make_node (COMPLEX_TYPE);
1327 TREE_TYPE (type) = subtype;
1335 /* Chooses either the gbe or the f2c way to build a
1336 complex constant. */
1338 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1340 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1344 if (ffe_is_emulate_complex ())
1346 bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1347 TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1348 bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1352 bothparts = build_complex (type, realpart, imagpart);
1359 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1361 ffecom_arglist_expr_ (const char *c, ffebld expr)
1364 tree *plist = &list;
1365 tree trail = NULL_TREE; /* Append char length args here. */
1366 tree *ptrail = &trail;
1371 tree wanted = NULL_TREE;
1372 static char zed[] = "0";
1377 while (expr != NULL)
1400 wanted = ffecom_f2c_complex_type_node;
1404 wanted = ffecom_f2c_doublereal_type_node;
1408 wanted = ffecom_f2c_doublecomplex_type_node;
1412 wanted = ffecom_f2c_real_type_node;
1416 wanted = ffecom_f2c_integer_type_node;
1420 wanted = ffecom_f2c_longint_type_node;
1424 assert ("bad argstring code" == NULL);
1430 exprh = ffebld_head (expr);
1434 if ((wanted == NULL_TREE)
1437 (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1438 [ffeinfo_kindtype (ffebld_info (exprh))])
1439 == TYPE_MODE (wanted))))
1441 = build_tree_list (NULL_TREE,
1442 ffecom_arg_ptr_to_expr (exprh,
1446 item = ffecom_arg_expr (exprh, &length);
1447 item = ffecom_convert_widen_ (wanted, item);
1450 item = ffecom_1 (ADDR_EXPR,
1451 build_pointer_type (TREE_TYPE (item)),
1455 = build_tree_list (NULL_TREE,
1459 plist = &TREE_CHAIN (*plist);
1460 expr = ffebld_trail (expr);
1461 if (length != NULL_TREE)
1463 *ptrail = build_tree_list (NULL_TREE, length);
1464 ptrail = &TREE_CHAIN (*ptrail);
1468 /* We've run out of args in the call; if the implementation expects
1469 more, supply null pointers for them, which the implementation can
1470 check to see if an arg was omitted. */
1472 while (*c != '\0' && *c != '0')
1477 assert ("missing arg to run-time routine!" == NULL);
1492 assert ("bad arg string code" == NULL);
1496 = build_tree_list (NULL_TREE,
1498 plist = &TREE_CHAIN (*plist);
1507 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1509 ffecom_widest_expr_type_ (ffebld list)
1512 ffebld widest = NULL;
1514 ffetype widest_type = NULL;
1517 for (; list != NULL; list = ffebld_trail (list))
1519 item = ffebld_head (list);
1522 if ((widest != NULL)
1523 && (ffeinfo_basictype (ffebld_info (item))
1524 != ffeinfo_basictype (ffebld_info (widest))))
1526 type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1527 ffeinfo_kindtype (ffebld_info (item)));
1528 if ((widest == FFEINFO_kindtypeNONE)
1529 || (ffetype_size (type)
1530 > ffetype_size (widest_type)))
1537 assert (widest != NULL);
1538 t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1539 [ffeinfo_kindtype (ffebld_info (widest))];
1540 assert (t != NULL_TREE);
1545 /* Check whether a partial overlap between two expressions is possible.
1547 Can *starting* to write a portion of expr1 change the value
1548 computed (perhaps already, *partially*) by expr2?
1550 Currently, this is a concern only for a COMPLEX expr1. But if it
1551 isn't in COMMON or local EQUIVALENCE, since we don't support
1552 aliasing of arguments, it isn't a concern. */
1555 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1560 switch (ffebld_op (expr1))
1562 case FFEBLD_opSYMTER:
1563 sym = ffebld_symter (expr1);
1566 case FFEBLD_opARRAYREF:
1567 if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1569 sym = ffebld_symter (ffebld_left (expr1));
1576 if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1577 && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1578 || ! (st = ffesymbol_storage (sym))
1579 || ! ffestorag_parent (st)))
1582 /* It's in COMMON or local EQUIVALENCE. */
1587 /* Check whether dest and source might overlap. ffebld versions of these
1588 might or might not be passed, will be NULL if not.
1590 The test is really whether source_tree is modifiable and, if modified,
1591 might overlap destination such that the value(s) in the destination might
1592 change before it is finally modified. dest_* are the canonized
1593 destination itself. */
1595 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1597 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1598 tree source_tree, ffebld source UNUSED,
1606 if (source_tree == NULL_TREE)
1609 switch (TREE_CODE (source_tree))
1612 case IDENTIFIER_NODE:
1623 case TRUNC_DIV_EXPR:
1625 case FLOOR_DIV_EXPR:
1626 case ROUND_DIV_EXPR:
1627 case TRUNC_MOD_EXPR:
1629 case FLOOR_MOD_EXPR:
1630 case ROUND_MOD_EXPR:
1632 case EXACT_DIV_EXPR:
1633 case FIX_TRUNC_EXPR:
1635 case FIX_FLOOR_EXPR:
1636 case FIX_ROUND_EXPR:
1651 case BIT_ANDTC_EXPR:
1653 case TRUTH_ANDIF_EXPR:
1654 case TRUTH_ORIF_EXPR:
1655 case TRUTH_AND_EXPR:
1657 case TRUTH_XOR_EXPR:
1658 case TRUTH_NOT_EXPR:
1674 return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1675 TREE_OPERAND (source_tree, 1), NULL,
1679 return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1680 TREE_OPERAND (source_tree, 0), NULL,
1685 case NON_LVALUE_EXPR:
1687 if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1690 ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1692 source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1697 ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1698 TREE_OPERAND (source_tree, 1), NULL,
1700 || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1701 TREE_OPERAND (source_tree, 2), NULL,
1706 ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1708 TREE_OPERAND (source_tree, 0));
1712 if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1715 source_decl = source_tree;
1716 source_offset = bitsize_zero_node;
1717 source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1721 case REFERENCE_EXPR:
1722 case PREDECREMENT_EXPR:
1723 case PREINCREMENT_EXPR:
1724 case POSTDECREMENT_EXPR:
1725 case POSTINCREMENT_EXPR:
1733 /* Come here when source_decl, source_offset, and source_size filled
1734 in appropriately. */
1736 if (source_decl == NULL_TREE)
1737 return FALSE; /* No decl involved, so no overlap. */
1739 if (source_decl != dest_decl)
1740 return FALSE; /* Different decl, no overlap. */
1742 if (TREE_CODE (dest_size) == ERROR_MARK)
1743 return TRUE; /* Assignment into entire assumed-size
1744 array? Shouldn't happen.... */
1746 t = ffecom_2 (LE_EXPR, integer_type_node,
1747 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1749 convert (TREE_TYPE (dest_offset),
1751 convert (TREE_TYPE (dest_offset),
1754 if (integer_onep (t))
1755 return FALSE; /* Destination precedes source. */
1758 || (source_size == NULL_TREE)
1759 || (TREE_CODE (source_size) == ERROR_MARK)
1760 || integer_zerop (source_size))
1761 return TRUE; /* No way to tell if dest follows source. */
1763 t = ffecom_2 (LE_EXPR, integer_type_node,
1764 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1766 convert (TREE_TYPE (source_offset),
1768 convert (TREE_TYPE (source_offset),
1771 if (integer_onep (t))
1772 return FALSE; /* Destination follows source. */
1774 return TRUE; /* Destination and source overlap. */
1778 /* Check whether dest might overlap any of a list of arguments or is
1779 in a COMMON area the callee might know about (and thus modify). */
1781 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1783 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1784 tree args, tree callee_commons,
1792 ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1795 if (dest_decl == NULL_TREE)
1796 return FALSE; /* Seems unlikely! */
1798 /* If the decl cannot be determined reliably, or if its in COMMON
1799 and the callee isn't known to not futz with COMMON via other
1800 means, overlap might happen. */
1802 if ((TREE_CODE (dest_decl) == ERROR_MARK)
1803 || ((callee_commons != NULL_TREE)
1804 && TREE_PUBLIC (dest_decl)))
1807 for (; args != NULL_TREE; args = TREE_CHAIN (args))
1809 if (((arg = TREE_VALUE (args)) != NULL_TREE)
1810 && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1811 arg, NULL, scalar_args))
1819 /* Build a string for a variable name as used by NAMELIST. This means that
1820 if we're using the f2c library, we build an uppercase string, since
1823 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1825 ffecom_build_f2c_string_ (int i, const char *s)
1827 if (!ffe_is_f2c_library ())
1828 return build_string (i, s);
1837 if (((size_t) i) > ARRAY_SIZE (space))
1838 tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1842 for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1843 *q = ffesrc_toupper (*p);
1846 t = build_string (i, tmp);
1848 if (((size_t) i) > ARRAY_SIZE (space))
1849 malloc_kill_ks (malloc_pool_image (), tmp, i);
1856 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1857 type to just get whatever the function returns), handling the
1858 f2c value-returning convention, if required, by prepending
1859 to the arglist a pointer to a temporary to receive the return value. */
1861 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1863 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1864 tree type, tree args, tree dest_tree,
1865 ffebld dest, bool *dest_used, tree callee_commons,
1866 bool scalar_args, tree hook)
1871 if (dest_used != NULL)
1876 if ((dest_used == NULL)
1878 || (ffeinfo_basictype (ffebld_info (dest))
1879 != FFEINFO_basictypeCOMPLEX)
1880 || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1881 || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1882 || ffecom_args_overlapping_ (dest_tree, dest, args,
1887 tempvar = ffecom_make_tempvar (ffecom_tree_type
1888 [FFEINFO_basictypeCOMPLEX][kt],
1889 FFETARGET_charactersizeNONE,
1899 tempvar = dest_tree;
1904 = build_tree_list (NULL_TREE,
1905 ffecom_1 (ADDR_EXPR,
1906 build_pointer_type (TREE_TYPE (tempvar)),
1908 TREE_CHAIN (item) = args;
1910 item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1913 if (tempvar != dest_tree)
1914 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1917 item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1920 if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1921 item = ffecom_convert_narrow_ (type, item);
1927 /* Given two arguments, transform them and make a call to the given
1928 function via ffecom_call_. */
1930 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1932 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1933 tree type, ffebld left, ffebld right,
1934 tree dest_tree, ffebld dest, bool *dest_used,
1935 tree callee_commons, bool scalar_args, bool ref, tree hook)
1944 /* Pass arguments by reference. */
1945 left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1946 right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1950 /* Pass arguments by value. */
1951 left_tree = ffecom_arg_expr (left, &left_length);
1952 right_tree = ffecom_arg_expr (right, &right_length);
1956 left_tree = build_tree_list (NULL_TREE, left_tree);
1957 right_tree = build_tree_list (NULL_TREE, right_tree);
1958 TREE_CHAIN (left_tree) = right_tree;
1960 if (left_length != NULL_TREE)
1962 left_length = build_tree_list (NULL_TREE, left_length);
1963 TREE_CHAIN (right_tree) = left_length;
1966 if (right_length != NULL_TREE)
1968 right_length = build_tree_list (NULL_TREE, right_length);
1969 if (left_length != NULL_TREE)
1970 TREE_CHAIN (left_length) = right_length;
1972 TREE_CHAIN (right_tree) = right_length;
1975 return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1976 dest_tree, dest, dest_used, callee_commons,
1981 /* Return ptr/length args for char subexpression
1983 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1984 subexpressions by constructing the appropriate trees for the ptr-to-
1985 character-text and length-of-character-text arguments in a calling
1988 Note that if with_null is TRUE, and the expression is an opCONTER,
1989 a null byte is appended to the string. */
1991 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1993 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1997 ffetargetCharacter1 val;
1998 ffetargetCharacterSize newlen;
2000 switch (ffebld_op (expr))
2002 case FFEBLD_opCONTER:
2003 val = ffebld_constant_character1 (ffebld_conter (expr));
2004 newlen = ffetarget_length_character1 (val);
2007 /* Begin FFETARGET-NULL-KLUDGE. */
2011 *length = build_int_2 (newlen, 0);
2012 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2013 high = build_int_2 (newlen, 0);
2014 TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
2015 item = build_string (newlen,
2016 ffetarget_text_character1 (val));
2017 /* End FFETARGET-NULL-KLUDGE. */
2019 = build_type_variant
2023 (ffecom_f2c_ftnlen_type_node,
2024 ffecom_f2c_ftnlen_one_node,
2027 TREE_CONSTANT (item) = 1;
2028 TREE_STATIC (item) = 1;
2029 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
2033 case FFEBLD_opSYMTER:
2035 ffesymbol s = ffebld_symter (expr);
2037 item = ffesymbol_hook (s).decl_tree;
2038 if (item == NULL_TREE)
2040 s = ffecom_sym_transform_ (s);
2041 item = ffesymbol_hook (s).decl_tree;
2043 if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
2045 if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
2046 *length = ffesymbol_hook (s).length_tree;
2049 *length = build_int_2 (ffesymbol_size (s), 0);
2050 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2053 else if (item == error_mark_node)
2054 *length = error_mark_node;
2056 /* FFEINFO_kindFUNCTION. */
2057 *length = NULL_TREE;
2058 if (!ffesymbol_hook (s).addr
2059 && (item != error_mark_node))
2060 item = ffecom_1 (ADDR_EXPR,
2061 build_pointer_type (TREE_TYPE (item)),
2066 case FFEBLD_opARRAYREF:
2068 ffecom_char_args_ (&item, length, ffebld_left (expr));
2070 if (item == error_mark_node || *length == error_mark_node)
2072 item = *length = error_mark_node;
2076 item = ffecom_arrayref_ (item, expr, 1);
2080 case FFEBLD_opSUBSTR:
2084 ffebld thing = ffebld_right (expr);
2087 const char *char_name;
2091 assert (ffebld_op (thing) == FFEBLD_opITEM);
2092 start = ffebld_head (thing);
2093 thing = ffebld_trail (thing);
2094 assert (ffebld_trail (thing) == NULL);
2095 end = ffebld_head (thing);
2097 /* Determine name for pretty-printing range-check errors. */
2098 for (left_symter = ffebld_left (expr);
2099 left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2100 left_symter = ffebld_left (left_symter))
2102 if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2103 char_name = ffesymbol_text (ffebld_symter (left_symter));
2105 char_name = "[expr?]";
2107 ffecom_char_args_ (&item, length, ffebld_left (expr));
2109 if (item == error_mark_node || *length == error_mark_node)
2111 item = *length = error_mark_node;
2115 array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2117 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2125 end_tree = ffecom_expr (end);
2126 if (flag_bounds_check)
2127 end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2129 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2132 if (end_tree == error_mark_node)
2134 item = *length = error_mark_node;
2143 start_tree = ffecom_expr (start);
2144 if (flag_bounds_check)
2145 start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2147 start_tree = convert (ffecom_f2c_ftnlen_type_node,
2150 if (start_tree == error_mark_node)
2152 item = *length = error_mark_node;
2156 start_tree = ffecom_save_tree (start_tree);
2158 item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2160 ffecom_2 (MINUS_EXPR,
2161 TREE_TYPE (start_tree),
2163 ffecom_f2c_ftnlen_one_node));
2167 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2168 ffecom_f2c_ftnlen_one_node,
2169 ffecom_2 (MINUS_EXPR,
2170 ffecom_f2c_ftnlen_type_node,
2176 end_tree = ffecom_expr (end);
2177 if (flag_bounds_check)
2178 end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2180 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2183 if (end_tree == error_mark_node)
2185 item = *length = error_mark_node;
2189 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2190 ffecom_f2c_ftnlen_one_node,
2191 ffecom_2 (MINUS_EXPR,
2192 ffecom_f2c_ftnlen_type_node,
2193 end_tree, start_tree));
2199 case FFEBLD_opFUNCREF:
2201 ffesymbol s = ffebld_symter (ffebld_left (expr));
2204 ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2207 if (size == FFETARGET_charactersizeNONE)
2208 /* ~~Kludge alert! This should someday be fixed. */
2211 *length = build_int_2 (size, 0);
2212 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2214 if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2215 == FFEINFO_whereINTRINSIC)
2219 /* Invocation of an intrinsic returning CHARACTER*1. */
2220 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2224 ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2225 assert (ix != FFECOM_gfrt);
2226 item = ffecom_gfrt_tree_ (ix);
2231 item = ffesymbol_hook (s).decl_tree;
2232 if (item == NULL_TREE)
2234 s = ffecom_sym_transform_ (s);
2235 item = ffesymbol_hook (s).decl_tree;
2237 if (item == error_mark_node)
2239 item = *length = error_mark_node;
2243 if (!ffesymbol_hook (s).addr)
2244 item = ffecom_1_fn (item);
2248 tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2250 tempvar = ffebld_nonter_hook (expr);
2253 tempvar = ffecom_1 (ADDR_EXPR,
2254 build_pointer_type (TREE_TYPE (tempvar)),
2257 args = build_tree_list (NULL_TREE, tempvar);
2259 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) /* Sfunc args by value. */
2260 TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2263 TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2264 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2266 TREE_CHAIN (TREE_CHAIN (args))
2267 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2268 ffebld_right (expr));
2272 TREE_CHAIN (TREE_CHAIN (args))
2273 = ffecom_list_ptr_to_expr (ffebld_right (expr));
2277 item = ffecom_3s (CALL_EXPR,
2278 TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2279 item, args, NULL_TREE);
2280 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2285 case FFEBLD_opCONVERT:
2287 ffecom_char_args_ (&item, length, ffebld_left (expr));
2289 if (item == error_mark_node || *length == error_mark_node)
2291 item = *length = error_mark_node;
2295 if ((ffebld_size_known (ffebld_left (expr))
2296 == FFETARGET_charactersizeNONE)
2297 || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2298 { /* Possible blank-padding needed, copy into
2305 tempvar = ffecom_make_tempvar (char_type_node,
2306 ffebld_size (expr), -1);
2308 tempvar = ffebld_nonter_hook (expr);
2311 tempvar = ffecom_1 (ADDR_EXPR,
2312 build_pointer_type (TREE_TYPE (tempvar)),
2315 newlen = build_int_2 (ffebld_size (expr), 0);
2316 TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2318 args = build_tree_list (NULL_TREE, tempvar);
2319 TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2320 TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2321 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2322 = build_tree_list (NULL_TREE, *length);
2324 item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2325 TREE_SIDE_EFFECTS (item) = 1;
2326 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2331 { /* Just truncate the length. */
2332 *length = build_int_2 (ffebld_size (expr), 0);
2333 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2338 assert ("bad op for single char arg expr" == NULL);
2347 /* Check the size of the type to be sure it doesn't overflow the
2348 "portable" capacities of the compiler back end. `dummy' types
2349 can generally overflow the normal sizes as long as the computations
2350 themselves don't overflow. A particular target of the back end
2351 must still enforce its size requirements, though, and the back
2352 end takes care of this in stor-layout.c. */
2354 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2356 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2358 if (TREE_CODE (type) == ERROR_MARK)
2361 if (TYPE_SIZE (type) == NULL_TREE)
2364 if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2367 if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2368 || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2369 || TREE_OVERFLOW (TYPE_SIZE (type)))))
2371 ffebad_start (FFEBAD_ARRAY_LARGE);
2372 ffebad_string (ffesymbol_text (s));
2373 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2376 return error_mark_node;
2383 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2384 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2385 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2387 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2389 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2391 ffetargetCharacterSize sz = ffesymbol_size (s);
2396 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2397 tlen = NULL_TREE; /* A statement function, no length passed. */
2400 if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2401 tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2402 ffesymbol_text (s));
2404 tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2405 tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2407 DECL_ARTIFICIAL (tlen) = 1;
2411 if (sz == FFETARGET_charactersizeNONE)
2413 assert (tlen != NULL_TREE);
2414 highval = variable_size (tlen);
2418 highval = build_int_2 (sz, 0);
2419 TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2422 type = build_array_type (type,
2423 build_range_type (ffecom_f2c_ftnlen_type_node,
2424 ffecom_f2c_ftnlen_one_node,
2432 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2434 ffecomConcatList_ catlist;
2435 ffebld expr; // expr of CHARACTER basictype.
2436 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2437 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2439 Scans expr for character subexpressions, updates and returns catlist
2442 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2443 static ffecomConcatList_
2444 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2445 ffetargetCharacterSize max)
2447 ffetargetCharacterSize sz;
2449 recurse: /* :::::::::::::::::::: */
2454 if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2455 return catlist; /* Don't append any more items. */
2457 switch (ffebld_op (expr))
2459 case FFEBLD_opCONTER:
2460 case FFEBLD_opSYMTER:
2461 case FFEBLD_opARRAYREF:
2462 case FFEBLD_opFUNCREF:
2463 case FFEBLD_opSUBSTR:
2464 case FFEBLD_opCONVERT: /* Callers should strip this off beforehand
2465 if they don't need to preserve it. */
2466 if (catlist.count == catlist.max)
2467 { /* Make a (larger) list. */
2471 newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2472 newx = malloc_new_ks (malloc_pool_image (), "catlist",
2473 newmax * sizeof (newx[0]));
2474 if (catlist.max != 0)
2476 memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2477 malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2478 catlist.max * sizeof (newx[0]));
2480 catlist.max = newmax;
2481 catlist.exprs = newx;
2483 if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2484 catlist.minlen += sz;
2486 ++catlist.minlen; /* Not true for F90; can be 0 length. */
2487 if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2488 catlist.maxlen = sz;
2490 catlist.maxlen += sz;
2491 if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2492 { /* This item overlaps (or is beyond) the end
2493 of the destination. */
2494 switch (ffebld_op (expr))
2496 case FFEBLD_opCONTER:
2497 case FFEBLD_opSYMTER:
2498 case FFEBLD_opARRAYREF:
2499 case FFEBLD_opFUNCREF:
2500 case FFEBLD_opSUBSTR:
2501 /* ~~Do useful truncations here. */
2505 assert ("op changed or inconsistent switches!" == NULL);
2509 catlist.exprs[catlist.count++] = expr;
2512 case FFEBLD_opPAREN:
2513 expr = ffebld_left (expr);
2514 goto recurse; /* :::::::::::::::::::: */
2516 case FFEBLD_opCONCATENATE:
2517 catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2518 expr = ffebld_right (expr);
2519 goto recurse; /* :::::::::::::::::::: */
2521 #if 0 /* Breaks passing small actual arg to larger
2522 dummy arg of sfunc */
2523 case FFEBLD_opCONVERT:
2524 expr = ffebld_left (expr);
2526 ffetargetCharacterSize cmax;
2528 cmax = catlist.len + ffebld_size_known (expr);
2530 if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2533 goto recurse; /* :::::::::::::::::::: */
2540 assert ("bad op in _gather_" == NULL);
2546 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2548 ffecomConcatList_ catlist;
2549 ffecom_concat_list_kill_(catlist);
2551 Anything allocated within the list info is deallocated. */
2553 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2555 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2557 if (catlist.max != 0)
2558 malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2559 catlist.max * sizeof (catlist.exprs[0]));
2563 /* Make list of concatenated string exprs.
2565 Returns a flattened list of concatenated subexpressions given a
2566 tree of such expressions. */
2568 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2569 static ffecomConcatList_
2570 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2572 ffecomConcatList_ catlist;
2574 catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2575 return ffecom_concat_list_gather_ (catlist, expr, max);
2580 /* Provide some kind of useful info on member of aggregate area,
2581 since current g77/gcc technology does not provide debug info
2582 on these members. */
2584 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2586 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2587 tree member_type UNUSED, ffetargetOffset offset)
2597 for (type_id = member_type;
2598 TREE_CODE (type_id) != IDENTIFIER_NODE;
2601 switch (TREE_CODE (type_id))
2605 type_id = TYPE_NAME (type_id);
2610 type_id = TREE_TYPE (type_id);
2614 assert ("no IDENTIFIER_NODE for type!" == NULL);
2615 type_id = error_mark_node;
2621 if (ffecom_transform_only_dummies_
2622 || !ffe_is_debug_kludge ())
2623 return; /* Can't do this yet, maybe later. */
2626 + strlen (aggr_type)
2627 + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2629 + IDENTIFIER_LENGTH (type_id);
2632 if (((size_t) len) >= ARRAY_SIZE (space))
2633 buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2637 sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2639 IDENTIFIER_POINTER (DECL_NAME (aggr)),
2642 value = build_string (len, buff);
2644 = build_type_variant (build_array_type (char_type_node,
2648 build_int_2 (strlen (buff), 0))),
2650 decl = build_decl (VAR_DECL,
2651 ffecom_get_identifier_ (ffesymbol_text (member)),
2653 TREE_CONSTANT (decl) = 1;
2654 TREE_STATIC (decl) = 1;
2655 DECL_INITIAL (decl) = error_mark_node;
2656 DECL_IN_SYSTEM_HEADER (decl) = 1; /* Don't let -Wunused complain. */
2657 decl = start_decl (decl, FALSE);
2658 finish_decl (decl, value, FALSE);
2660 if (buff != &space[0])
2661 malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2665 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2667 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2668 int i; // entry# for this entrypoint (used by master fn)
2669 ffecom_do_entrypoint_(s,i);
2671 Makes a public entry point that calls our private master fn (already
2674 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2676 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2679 tree type; /* Type of function. */
2680 tree multi_retval; /* Var holding return value (union). */
2681 tree result; /* Var holding result. */
2682 ffeinfoBasictype bt;
2686 bool charfunc; /* All entry points return same type
2688 bool cmplxfunc; /* Use f2c way of returning COMPLEX. */
2689 bool multi; /* Master fn has multiple return types. */
2690 bool altreturning = FALSE; /* This entry point has alternate returns. */
2691 int old_lineno = lineno;
2692 const char *old_input_filename = input_filename;
2694 input_filename = ffesymbol_where_filename (fn);
2695 lineno = ffesymbol_where_filelinenum (fn);
2697 ffecom_doing_entry_ = TRUE; /* Don't bother with array dimensions. */
2699 switch (ffecom_primary_entry_kind_)
2701 case FFEINFO_kindFUNCTION:
2703 /* Determine actual return type for function. */
2705 gt = FFEGLOBAL_typeFUNC;
2706 bt = ffesymbol_basictype (fn);
2707 kt = ffesymbol_kindtype (fn);
2708 if (bt == FFEINFO_basictypeNONE)
2710 ffeimplic_establish_symbol (fn);
2711 if (ffesymbol_funcresult (fn) != NULL)
2712 ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2713 bt = ffesymbol_basictype (fn);
2714 kt = ffesymbol_kindtype (fn);
2717 if (bt == FFEINFO_basictypeCHARACTER)
2718 charfunc = TRUE, cmplxfunc = FALSE;
2719 else if ((bt == FFEINFO_basictypeCOMPLEX)
2720 && ffesymbol_is_f2c (fn))
2721 charfunc = FALSE, cmplxfunc = TRUE;
2723 charfunc = cmplxfunc = FALSE;
2726 type = ffecom_tree_fun_type_void;
2727 else if (ffesymbol_is_f2c (fn))
2728 type = ffecom_tree_fun_type[bt][kt];
2730 type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2732 if ((type == NULL_TREE)
2733 || (TREE_TYPE (type) == NULL_TREE))
2734 type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
2736 multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2739 case FFEINFO_kindSUBROUTINE:
2740 gt = FFEGLOBAL_typeSUBR;
2741 bt = FFEINFO_basictypeNONE;
2742 kt = FFEINFO_kindtypeNONE;
2743 if (ffecom_is_altreturning_)
2744 { /* Am _I_ altreturning? */
2745 for (item = ffesymbol_dummyargs (fn);
2747 item = ffebld_trail (item))
2749 if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2751 altreturning = TRUE;
2756 type = ffecom_tree_subr_type;
2758 type = ffecom_tree_fun_type_void;
2761 type = ffecom_tree_fun_type_void;
2768 assert ("say what??" == NULL);
2770 case FFEINFO_kindANY:
2771 gt = FFEGLOBAL_typeANY;
2772 bt = FFEINFO_basictypeNONE;
2773 kt = FFEINFO_kindtypeNONE;
2774 type = error_mark_node;
2781 /* build_decl uses the current lineno and input_filename to set the decl
2782 source info. So, I've putzed with ffestd and ffeste code to update that
2783 source info to point to the appropriate statement just before calling
2784 ffecom_do_entrypoint (which calls this fn). */
2786 start_function (ffecom_get_external_identifier_ (fn),
2788 0, /* nested/inline */
2789 1); /* TREE_PUBLIC */
2791 if (((g = ffesymbol_global (fn)) != NULL)
2792 && ((ffeglobal_type (g) == gt)
2793 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2795 ffeglobal_set_hook (g, current_function_decl);
2798 /* Reset args in master arg list so they get retransitioned. */
2800 for (item = ffecom_master_arglist_;
2802 item = ffebld_trail (item))
2807 arg = ffebld_head (item);
2808 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2809 continue; /* Alternate return or some such thing. */
2810 s = ffebld_symter (arg);
2811 ffesymbol_hook (s).decl_tree = NULL_TREE;
2812 ffesymbol_hook (s).length_tree = NULL_TREE;
2815 /* Build dummy arg list for this entry point. */
2817 if (charfunc || cmplxfunc)
2818 { /* Prepend arg for where result goes. */
2823 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2825 type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2827 result = ffecom_get_invented_identifier ("__g77_%s", "result");
2829 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2832 length = ffecom_char_enhance_arg_ (&type, fn);
2834 length = NULL_TREE; /* Not ref'd if !charfunc. */
2836 type = build_pointer_type (type);
2837 result = build_decl (PARM_DECL, result, type);
2839 push_parm_decl (result);
2840 ffecom_func_result_ = result;
2844 push_parm_decl (length);
2845 ffecom_func_length_ = length;
2849 result = DECL_RESULT (current_function_decl);
2851 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2853 store_parm_decls (0);
2855 ffecom_start_compstmt ();
2856 /* Disallow temp vars at this level. */
2857 current_binding_level->prep_state = 2;
2859 /* Make local var to hold return type for multi-type master fn. */
2863 multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2865 multi_retval = build_decl (VAR_DECL, multi_retval,
2866 ffecom_multi_type_node_);
2867 multi_retval = start_decl (multi_retval, FALSE);
2868 finish_decl (multi_retval, NULL_TREE, FALSE);
2871 multi_retval = NULL_TREE; /* Not actually ref'd if !multi. */
2873 /* Here we emit the actual code for the entry point. */
2879 tree arglist = NULL_TREE;
2880 tree *plist = &arglist;
2886 /* Prepare actual arg list based on master arg list. */
2888 for (list = ffecom_master_arglist_;
2890 list = ffebld_trail (list))
2892 arg = ffebld_head (list);
2893 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2895 s = ffebld_symter (arg);
2896 if (ffesymbol_hook (s).decl_tree == NULL_TREE
2897 || ffesymbol_hook (s).decl_tree == error_mark_node)
2898 actarg = null_pointer_node; /* We don't have this arg. */
2900 actarg = ffesymbol_hook (s).decl_tree;
2901 *plist = build_tree_list (NULL_TREE, actarg);
2902 plist = &TREE_CHAIN (*plist);
2905 /* This code appends the length arguments for character
2906 variables/arrays. */
2908 for (list = ffecom_master_arglist_;
2910 list = ffebld_trail (list))
2912 arg = ffebld_head (list);
2913 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2915 s = ffebld_symter (arg);
2916 if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2917 continue; /* Only looking for CHARACTER arguments. */
2918 if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2919 continue; /* Only looking for variables and arrays. */
2920 if (ffesymbol_hook (s).length_tree == NULL_TREE
2921 || ffesymbol_hook (s).length_tree == error_mark_node)
2922 actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2924 actarg = ffesymbol_hook (s).length_tree;
2925 *plist = build_tree_list (NULL_TREE, actarg);
2926 plist = &TREE_CHAIN (*plist);
2929 /* Prepend character-value return info to actual arg list. */
2933 prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2934 TREE_CHAIN (prepend)
2935 = build_tree_list (NULL_TREE, ffecom_func_length_);
2936 TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2940 /* Prepend multi-type return value to actual arg list. */
2945 = build_tree_list (NULL_TREE,
2946 ffecom_1 (ADDR_EXPR,
2947 build_pointer_type (TREE_TYPE (multi_retval)),
2949 TREE_CHAIN (prepend) = arglist;
2953 /* Prepend my entry-point number to the actual arg list. */
2955 prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2956 TREE_CHAIN (prepend) = arglist;
2959 /* Build the call to the master function. */
2961 master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2962 call = ffecom_3s (CALL_EXPR,
2963 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2964 master_fn, arglist, NULL_TREE);
2966 /* Decide whether the master function is a function or subroutine, and
2967 handle the return value for my entry point. */
2969 if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2972 expand_expr_stmt (call);
2973 expand_null_return ();
2975 else if (multi && cmplxfunc)
2977 expand_expr_stmt (call);
2979 = ffecom_1 (INDIRECT_REF,
2980 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2982 result = ffecom_modify (NULL_TREE, result,
2983 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2985 ffecom_multi_fields_[bt][kt]));
2986 expand_expr_stmt (result);
2987 expand_null_return ();
2991 expand_expr_stmt (call);
2993 = ffecom_modify (NULL_TREE, result,
2994 convert (TREE_TYPE (result),
2995 ffecom_2 (COMPONENT_REF,
2996 ffecom_tree_type[bt][kt],
2998 ffecom_multi_fields_[bt][kt])));
2999 expand_return (result);
3004 = ffecom_1 (INDIRECT_REF,
3005 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
3007 result = ffecom_modify (NULL_TREE, result, call);
3008 expand_expr_stmt (result);
3009 expand_null_return ();
3013 result = ffecom_modify (NULL_TREE,
3015 convert (TREE_TYPE (result),
3017 expand_return (result);
3021 ffecom_end_compstmt ();
3023 finish_function (0);
3025 lineno = old_lineno;
3026 input_filename = old_input_filename;
3028 ffecom_doing_entry_ = FALSE;
3032 /* Transform expr into gcc tree with possible destination
3034 Recursive descent on expr while making corresponding tree nodes and
3035 attaching type info and such. If destination supplied and compatible
3036 with temporary that would be made in certain cases, temporary isn't
3037 made, destination used instead, and dest_used flag set TRUE. */
3039 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3041 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
3042 bool *dest_used, bool assignp, bool widenp)
3047 ffeinfoBasictype bt;
3050 tree dt; /* decl_tree for an ffesymbol. */
3051 tree tree_type, tree_type_x;
3054 enum tree_code code;
3056 assert (expr != NULL);
3058 if (dest_used != NULL)
3061 bt = ffeinfo_basictype (ffebld_info (expr));
3062 kt = ffeinfo_kindtype (ffebld_info (expr));
3063 tree_type = ffecom_tree_type[bt][kt];
3065 /* Widen integral arithmetic as desired while preserving signedness. */
3066 tree_type_x = NULL_TREE;
3067 if (widenp && tree_type
3068 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
3069 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
3070 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
3072 switch (ffebld_op (expr))
3074 case FFEBLD_opACCTER:
3077 ffebit bits = ffebld_accter_bits (expr);
3078 ffetargetOffset source_offset = 0;
3079 ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3082 assert (dest_offset == 0
3083 || (bt == FFEINFO_basictypeCHARACTER
3084 && kt == FFEINFO_kindtypeCHARACTER1));
3089 ffebldConstantUnion cu;
3092 ffebldConstantArray ca = ffebld_accter (expr);
3094 ffebit_test (bits, source_offset, &value, &length);
3100 for (i = 0; i < length; ++i)
3102 cu = ffebld_constantarray_get (ca, bt, kt,
3105 t = ffecom_constantunion (&cu, bt, kt, tree_type);
3108 && dest_offset != 0)
3109 purpose = build_int_2 (dest_offset, 0);
3111 purpose = NULL_TREE;
3113 if (list == NULL_TREE)
3114 list = item = build_tree_list (purpose, t);
3117 TREE_CHAIN (item) = build_tree_list (purpose, t);
3118 item = TREE_CHAIN (item);
3122 source_offset += length;
3123 dest_offset += length;
3127 item = build_int_2 ((ffebld_accter_size (expr)
3128 + ffebld_accter_pad (expr)) - 1, 0);
3129 ffebit_kill (ffebld_accter_bits (expr));
3130 TREE_TYPE (item) = ffecom_integer_type_node;
3134 build_range_type (ffecom_integer_type_node,
3135 ffecom_integer_zero_node,
3137 list = build (CONSTRUCTOR, item, NULL_TREE, list);
3138 TREE_CONSTANT (list) = 1;
3139 TREE_STATIC (list) = 1;
3142 case FFEBLD_opARRTER:
3147 if (ffebld_arrter_pad (expr) == 0)
3151 assert (bt == FFEINFO_basictypeCHARACTER
3152 && kt == FFEINFO_kindtypeCHARACTER1);
3154 /* Becomes PURPOSE first time through loop. */
3155 item = build_int_2 (ffebld_arrter_pad (expr), 0);
3158 for (i = 0; i < ffebld_arrter_size (expr); ++i)
3160 ffebldConstantUnion cu
3161 = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3163 t = ffecom_constantunion (&cu, bt, kt, tree_type);
3165 if (list == NULL_TREE)
3166 /* Assume item is PURPOSE first time through loop. */
3167 list = item = build_tree_list (item, t);
3170 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3171 item = TREE_CHAIN (item);
3176 item = build_int_2 ((ffebld_arrter_size (expr)
3177 + ffebld_arrter_pad (expr)) - 1, 0);
3178 TREE_TYPE (item) = ffecom_integer_type_node;
3182 build_range_type (ffecom_integer_type_node,
3183 ffecom_integer_zero_node,
3185 list = build (CONSTRUCTOR, item, NULL_TREE, list);
3186 TREE_CONSTANT (list) = 1;
3187 TREE_STATIC (list) = 1;
3190 case FFEBLD_opCONTER:
3191 assert (ffebld_conter_pad (expr) == 0);
3193 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3197 case FFEBLD_opSYMTER:
3198 if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3199 || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3200 return ffecom_ptr_to_expr (expr); /* Same as %REF(intrinsic). */
3201 s = ffebld_symter (expr);
3202 t = ffesymbol_hook (s).decl_tree;
3205 { /* ASSIGN'ed-label expr. */
3206 if (ffe_is_ugly_assign ())
3208 /* User explicitly wants ASSIGN'ed variables to be at the same
3209 memory address as the variables when used in non-ASSIGN
3210 contexts. That can make old, arcane, non-standard code
3211 work, but don't try to do it when a pointer wouldn't fit
3212 in the normal variable (take other approach, and warn,
3217 s = ffecom_sym_transform_ (s);
3218 t = ffesymbol_hook (s).decl_tree;
3219 assert (t != NULL_TREE);
3222 if (t == error_mark_node)
3225 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3226 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3228 if (ffesymbol_hook (s).addr)
3229 t = ffecom_1 (INDIRECT_REF,
3230 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3234 if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3236 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3237 FFEBAD_severityWARNING);
3238 ffebad_string (ffesymbol_text (s));
3239 ffebad_here (0, ffesymbol_where_line (s),
3240 ffesymbol_where_column (s));
3245 /* Don't use the normal variable's tree for ASSIGN, though mark
3246 it as in the system header (housekeeping). Use an explicit,
3247 specially created sibling that is known to be wide enough
3248 to hold pointers to labels. */
3251 && TREE_CODE (t) == VAR_DECL)
3252 DECL_IN_SYSTEM_HEADER (t) = 1; /* Don't let -Wunused complain. */
3254 t = ffesymbol_hook (s).assign_tree;
3257 s = ffecom_sym_transform_assign_ (s);
3258 t = ffesymbol_hook (s).assign_tree;
3259 assert (t != NULL_TREE);
3266 s = ffecom_sym_transform_ (s);
3267 t = ffesymbol_hook (s).decl_tree;
3268 assert (t != NULL_TREE);
3270 if (ffesymbol_hook (s).addr)
3271 t = ffecom_1 (INDIRECT_REF,
3272 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3276 case FFEBLD_opARRAYREF:
3277 return ffecom_arrayref_ (NULL_TREE, expr, 0);
3279 case FFEBLD_opUPLUS:
3280 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3281 return ffecom_1 (NOP_EXPR, tree_type, left);
3283 case FFEBLD_opPAREN:
3284 /* ~~~Make sure Fortran rules respected here */
3285 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3286 return ffecom_1 (NOP_EXPR, tree_type, left);
3288 case FFEBLD_opUMINUS:
3289 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3292 tree_type = tree_type_x;
3293 left = convert (tree_type, left);
3295 return ffecom_1 (NEGATE_EXPR, tree_type, left);
3298 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3299 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3302 tree_type = tree_type_x;
3303 left = convert (tree_type, left);
3304 right = convert (tree_type, right);
3306 return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3308 case FFEBLD_opSUBTRACT:
3309 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3310 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3313 tree_type = tree_type_x;
3314 left = convert (tree_type, left);
3315 right = convert (tree_type, right);
3317 return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3319 case FFEBLD_opMULTIPLY:
3320 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3321 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3324 tree_type = tree_type_x;
3325 left = convert (tree_type, left);
3326 right = convert (tree_type, right);
3328 return ffecom_2 (MULT_EXPR, tree_type, left, right);
3330 case FFEBLD_opDIVIDE:
3331 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3332 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3335 tree_type = tree_type_x;
3336 left = convert (tree_type, left);
3337 right = convert (tree_type, right);
3339 return ffecom_tree_divide_ (tree_type, left, right,
3340 dest_tree, dest, dest_used,
3341 ffebld_nonter_hook (expr));
3343 case FFEBLD_opPOWER:
3345 ffebld left = ffebld_left (expr);
3346 ffebld right = ffebld_right (expr);
3348 ffeinfoKindtype rtkt;
3349 ffeinfoKindtype ltkt;
3352 switch (ffeinfo_basictype (ffebld_info (right)))
3355 case FFEINFO_basictypeINTEGER:
3358 item = ffecom_expr_power_integer_ (expr);
3359 if (item != NULL_TREE)
3363 rtkt = FFEINFO_kindtypeINTEGER1;
3364 switch (ffeinfo_basictype (ffebld_info (left)))
3366 case FFEINFO_basictypeINTEGER:
3367 if ((ffeinfo_kindtype (ffebld_info (left))
3368 == FFEINFO_kindtypeINTEGER4)
3369 || (ffeinfo_kindtype (ffebld_info (right))
3370 == FFEINFO_kindtypeINTEGER4))
3372 code = FFECOM_gfrtPOW_QQ;
3373 ltkt = FFEINFO_kindtypeINTEGER4;
3374 rtkt = FFEINFO_kindtypeINTEGER4;
3378 code = FFECOM_gfrtPOW_II;
3379 ltkt = FFEINFO_kindtypeINTEGER1;
3383 case FFEINFO_basictypeREAL:
3384 if (ffeinfo_kindtype (ffebld_info (left))
3385 == FFEINFO_kindtypeREAL1)
3387 code = FFECOM_gfrtPOW_RI;
3388 ltkt = FFEINFO_kindtypeREAL1;
3392 code = FFECOM_gfrtPOW_DI;
3393 ltkt = FFEINFO_kindtypeREAL2;
3397 case FFEINFO_basictypeCOMPLEX:
3398 if (ffeinfo_kindtype (ffebld_info (left))
3399 == FFEINFO_kindtypeREAL1)
3401 code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
3402 ltkt = FFEINFO_kindtypeREAL1;
3406 code = FFECOM_gfrtPOW_ZI; /* Overlapping result okay. */
3407 ltkt = FFEINFO_kindtypeREAL2;
3412 assert ("bad pow_*i" == NULL);
3413 code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
3414 ltkt = FFEINFO_kindtypeREAL1;
3417 if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3418 left = ffeexpr_convert (left, NULL, NULL,
3419 ffeinfo_basictype (ffebld_info (left)),
3421 FFETARGET_charactersizeNONE,
3422 FFEEXPR_contextLET);
3423 if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3424 right = ffeexpr_convert (right, NULL, NULL,
3425 FFEINFO_basictypeINTEGER,
3427 FFETARGET_charactersizeNONE,
3428 FFEEXPR_contextLET);
3431 case FFEINFO_basictypeREAL:
3432 if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3433 left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3434 FFEINFO_kindtypeREALDOUBLE, 0,
3435 FFETARGET_charactersizeNONE,
3436 FFEEXPR_contextLET);
3437 if (ffeinfo_kindtype (ffebld_info (right))
3438 == FFEINFO_kindtypeREAL1)
3439 right = ffeexpr_convert (right, NULL, NULL,
3440 FFEINFO_basictypeREAL,
3441 FFEINFO_kindtypeREALDOUBLE, 0,
3442 FFETARGET_charactersizeNONE,
3443 FFEEXPR_contextLET);
3444 /* We used to call FFECOM_gfrtPOW_DD here,
3445 which passes arguments by reference. */
3446 code = FFECOM_gfrtL_POW;
3447 /* Pass arguments by value. */
3451 case FFEINFO_basictypeCOMPLEX:
3452 if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3453 left = ffeexpr_convert (left, NULL, NULL,
3454 FFEINFO_basictypeCOMPLEX,
3455 FFEINFO_kindtypeREALDOUBLE, 0,
3456 FFETARGET_charactersizeNONE,
3457 FFEEXPR_contextLET);
3458 if (ffeinfo_kindtype (ffebld_info (right))
3459 == FFEINFO_kindtypeREAL1)
3460 right = ffeexpr_convert (right, NULL, NULL,
3461 FFEINFO_basictypeCOMPLEX,
3462 FFEINFO_kindtypeREALDOUBLE, 0,
3463 FFETARGET_charactersizeNONE,
3464 FFEEXPR_contextLET);
3465 code = FFECOM_gfrtPOW_ZZ; /* Overlapping result okay. */
3466 ref = TRUE; /* Pass arguments by reference. */
3470 assert ("bad pow_x*" == NULL);
3471 code = FFECOM_gfrtPOW_II;
3474 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3475 ffecom_gfrt_kindtype (code),
3476 (ffe_is_f2c_library ()
3477 && ffecom_gfrt_complex_[code]),
3478 tree_type, left, right,
3479 dest_tree, dest, dest_used,
3480 NULL_TREE, FALSE, ref,
3481 ffebld_nonter_hook (expr));
3487 case FFEINFO_basictypeLOGICAL:
3488 item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3489 return convert (tree_type, item);
3491 case FFEINFO_basictypeINTEGER:
3492 return ffecom_1 (BIT_NOT_EXPR, tree_type,
3493 ffecom_expr (ffebld_left (expr)));
3496 assert ("NOT bad basictype" == NULL);
3498 case FFEINFO_basictypeANY:
3499 return error_mark_node;
3503 case FFEBLD_opFUNCREF:
3504 assert (ffeinfo_basictype (ffebld_info (expr))
3505 != FFEINFO_basictypeCHARACTER);
3507 case FFEBLD_opSUBRREF:
3508 if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3509 == FFEINFO_whereINTRINSIC)
3510 { /* Invocation of an intrinsic. */
3511 item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3515 s = ffebld_symter (ffebld_left (expr));
3516 dt = ffesymbol_hook (s).decl_tree;
3517 if (dt == NULL_TREE)
3519 s = ffecom_sym_transform_ (s);
3520 dt = ffesymbol_hook (s).decl_tree;
3522 if (dt == error_mark_node)
3525 if (ffesymbol_hook (s).addr)
3528 item = ffecom_1_fn (dt);
3530 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3531 args = ffecom_list_expr (ffebld_right (expr));
3533 args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3535 if (args == error_mark_node)
3536 return error_mark_node;
3538 item = ffecom_call_ (item, kt,
3539 ffesymbol_is_f2c (s)
3540 && (bt == FFEINFO_basictypeCOMPLEX)
3541 && (ffesymbol_where (s)
3542 != FFEINFO_whereCONSTANT),
3545 dest_tree, dest, dest_used,
3546 error_mark_node, FALSE,
3547 ffebld_nonter_hook (expr));
3548 TREE_SIDE_EFFECTS (item) = 1;
3554 case FFEINFO_basictypeLOGICAL:
3556 = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3557 ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3558 ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3559 return convert (tree_type, item);
3561 case FFEINFO_basictypeINTEGER:
3562 return ffecom_2 (BIT_AND_EXPR, tree_type,
3563 ffecom_expr (ffebld_left (expr)),
3564 ffecom_expr (ffebld_right (expr)));
3567 assert ("AND bad basictype" == NULL);
3569 case FFEINFO_basictypeANY:
3570 return error_mark_node;
3577 case FFEINFO_basictypeLOGICAL:
3579 = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3580 ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3581 ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3582 return convert (tree_type, item);
3584 case FFEINFO_basictypeINTEGER:
3585 return ffecom_2 (BIT_IOR_EXPR, tree_type,
3586 ffecom_expr (ffebld_left (expr)),
3587 ffecom_expr (ffebld_right (expr)));
3590 assert ("OR bad basictype" == NULL);
3592 case FFEINFO_basictypeANY:
3593 return error_mark_node;
3601 case FFEINFO_basictypeLOGICAL:
3603 = ffecom_2 (NE_EXPR, integer_type_node,
3604 ffecom_expr (ffebld_left (expr)),
3605 ffecom_expr (ffebld_right (expr)));
3606 return convert (tree_type, ffecom_truth_value (item));
3608 case FFEINFO_basictypeINTEGER:
3609 return ffecom_2 (BIT_XOR_EXPR, tree_type,
3610 ffecom_expr (ffebld_left (expr)),
3611 ffecom_expr (ffebld_right (expr)));
3614 assert ("XOR/NEQV bad basictype" == NULL);
3616 case FFEINFO_basictypeANY:
3617 return error_mark_node;
3624 case FFEINFO_basictypeLOGICAL:
3626 = ffecom_2 (EQ_EXPR, integer_type_node,
3627 ffecom_expr (ffebld_left (expr)),
3628 ffecom_expr (ffebld_right (expr)));
3629 return convert (tree_type, ffecom_truth_value (item));
3631 case FFEINFO_basictypeINTEGER:
3633 ffecom_1 (BIT_NOT_EXPR, tree_type,
3634 ffecom_2 (BIT_XOR_EXPR, tree_type,
3635 ffecom_expr (ffebld_left (expr)),
3636 ffecom_expr (ffebld_right (expr))));
3639 assert ("EQV bad basictype" == NULL);
3641 case FFEINFO_basictypeANY:
3642 return error_mark_node;
3646 case FFEBLD_opCONVERT:
3647 if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3648 return error_mark_node;
3652 case FFEINFO_basictypeLOGICAL:
3653 case FFEINFO_basictypeINTEGER:
3654 case FFEINFO_basictypeREAL:
3655 return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3657 case FFEINFO_basictypeCOMPLEX:
3658 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3660 case FFEINFO_basictypeINTEGER:
3661 case FFEINFO_basictypeLOGICAL:
3662 case FFEINFO_basictypeREAL:
3663 item = ffecom_expr (ffebld_left (expr));
3664 if (item == error_mark_node)
3665 return error_mark_node;
3666 /* convert() takes care of converting to the subtype first,
3667 at least in gcc-2.7.2. */
3668 item = convert (tree_type, item);
3671 case FFEINFO_basictypeCOMPLEX:
3672 return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3675 assert ("CONVERT COMPLEX bad basictype" == NULL);
3677 case FFEINFO_basictypeANY:
3678 return error_mark_node;
3683 assert ("CONVERT bad basictype" == NULL);
3685 case FFEINFO_basictypeANY:
3686 return error_mark_node;
3692 goto relational; /* :::::::::::::::::::: */
3696 goto relational; /* :::::::::::::::::::: */
3700 goto relational; /* :::::::::::::::::::: */
3704 goto relational; /* :::::::::::::::::::: */
3708 goto relational; /* :::::::::::::::::::: */
3713 relational: /* :::::::::::::::::::: */
3714 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3716 case FFEINFO_basictypeLOGICAL:
3717 case FFEINFO_basictypeINTEGER:
3718 case FFEINFO_basictypeREAL:
3719 item = ffecom_2 (code, integer_type_node,
3720 ffecom_expr (ffebld_left (expr)),
3721 ffecom_expr (ffebld_right (expr)));
3722 return convert (tree_type, item);
3724 case FFEINFO_basictypeCOMPLEX:
3725 assert (code == EQ_EXPR || code == NE_EXPR);
3728 tree arg1 = ffecom_expr (ffebld_left (expr));
3729 tree arg2 = ffecom_expr (ffebld_right (expr));
3731 if (arg1 == error_mark_node || arg2 == error_mark_node)
3732 return error_mark_node;
3734 arg1 = ffecom_save_tree (arg1);
3735 arg2 = ffecom_save_tree (arg2);
3737 if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3739 real_type = TREE_TYPE (TREE_TYPE (arg1));
3740 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3744 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3745 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3749 = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3750 ffecom_2 (EQ_EXPR, integer_type_node,
3751 ffecom_1 (REALPART_EXPR, real_type, arg1),
3752 ffecom_1 (REALPART_EXPR, real_type, arg2)),
3753 ffecom_2 (EQ_EXPR, integer_type_node,
3754 ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3755 ffecom_1 (IMAGPART_EXPR, real_type,
3757 if (code == EQ_EXPR)
3758 item = ffecom_truth_value (item);
3760 item = ffecom_truth_value_invert (item);
3761 return convert (tree_type, item);
3764 case FFEINFO_basictypeCHARACTER:
3766 ffebld left = ffebld_left (expr);
3767 ffebld right = ffebld_right (expr);
3773 /* f2c run-time functions do the implicit blank-padding for us,
3774 so we don't usually have to implement blank-padding ourselves.
3775 (The exception is when we pass an argument to a separately
3776 compiled statement function -- if we know the arg is not the
3777 same length as the dummy, we must truncate or extend it. If
3778 we "inline" statement functions, that necessity goes away as
3781 Strip off the CONVERT operators that blank-pad. (Truncation by
3782 CONVERT shouldn't happen here, but it can happen in
3785 while (ffebld_op (left) == FFEBLD_opCONVERT)
3786 left = ffebld_left (left);
3787 while (ffebld_op (right) == FFEBLD_opCONVERT)
3788 right = ffebld_left (right);
3790 left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3791 right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3793 if (left_tree == error_mark_node || left_length == error_mark_node
3794 || right_tree == error_mark_node
3795 || right_length == error_mark_node)
3796 return error_mark_node;
3798 if ((ffebld_size_known (left) == 1)
3799 && (ffebld_size_known (right) == 1))
3802 = ffecom_1 (INDIRECT_REF,
3803 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3806 = ffecom_1 (INDIRECT_REF,
3807 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3811 = ffecom_2 (code, integer_type_node,
3812 ffecom_2 (ARRAY_REF,
3813 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3816 ffecom_2 (ARRAY_REF,
3817 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3823 item = build_tree_list (NULL_TREE, left_tree);
3824 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3825 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3827 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3828 = build_tree_list (NULL_TREE, right_length);
3829 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3830 item = ffecom_2 (code, integer_type_node,
3832 convert (TREE_TYPE (item),
3833 integer_zero_node));
3835 item = convert (tree_type, item);
3841 assert ("relational bad basictype" == NULL);
3843 case FFEINFO_basictypeANY:
3844 return error_mark_node;
3848 case FFEBLD_opPERCENT_LOC:
3849 item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3850 return convert (tree_type, item);
3854 case FFEBLD_opBOUNDS:
3855 case FFEBLD_opREPEAT:
3856 case FFEBLD_opLABTER:
3857 case FFEBLD_opLABTOK:
3858 case FFEBLD_opIMPDO:
3859 case FFEBLD_opCONCATENATE:
3860 case FFEBLD_opSUBSTR:
3862 assert ("bad op" == NULL);
3865 return error_mark_node;
3869 assert ("didn't think anything got here anymore!!" == NULL);
3871 switch (ffebld_arity (expr))
3874 TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3875 TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3876 if (TREE_OPERAND (item, 0) == error_mark_node
3877 || TREE_OPERAND (item, 1) == error_mark_node)
3878 return error_mark_node;
3882 TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3883 if (TREE_OPERAND (item, 0) == error_mark_node)
3884 return error_mark_node;
3896 /* Returns the tree that does the intrinsic invocation.
3898 Note: this function applies only to intrinsics returning
3899 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3902 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3904 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3905 ffebld dest, bool *dest_used)
3908 tree saved_expr1; /* For those who need it. */
3909 tree saved_expr2; /* For those who need it. */
3910 ffeinfoBasictype bt;
3914 tree real_type; /* REAL type corresponding to COMPLEX. */
3916 ffebld list = ffebld_right (expr); /* List of (some) args. */
3917 ffebld arg1; /* For handy reference. */
3920 ffeintrinImp codegen_imp;
3923 assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3925 if (dest_used != NULL)
3928 bt = ffeinfo_basictype (ffebld_info (expr));
3929 kt = ffeinfo_kindtype (ffebld_info (expr));
3930 tree_type = ffecom_tree_type[bt][kt];
3934 arg1 = ffebld_head (list);
3935 if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3936 return error_mark_node;
3937 if ((list = ffebld_trail (list)) != NULL)
3939 arg2 = ffebld_head (list);
3940 if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3941 return error_mark_node;
3942 if ((list = ffebld_trail (list)) != NULL)
3944 arg3 = ffebld_head (list);
3945 if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3946 return error_mark_node;
3955 arg1 = arg2 = arg3 = NULL;
3957 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3958 args. This is used by the MAX/MIN expansions. */
3961 arg1_type = ffecom_tree_type
3962 [ffeinfo_basictype (ffebld_info (arg1))]
3963 [ffeinfo_kindtype (ffebld_info (arg1))];
3965 arg1_type = NULL_TREE; /* Really not needed, but might catch bugs
3968 /* There are several ways for each of the cases in the following switch
3969 statements to exit (from simplest to use to most complicated):
3971 break; (when expr_tree == NULL)
3973 A standard call is made to the specific intrinsic just as if it had been
3974 passed in as a dummy procedure and called as any old procedure. This
3975 method can produce slower code but in some cases it's the easiest way for
3976 now. However, if a (presumably faster) direct call is available,
3977 that is used, so this is the easiest way in many more cases now.
3979 gfrt = FFECOM_gfrtWHATEVER;
3982 gfrt contains the gfrt index of a library function to call, passing the
3983 argument(s) by value rather than by reference. Used when a more
3984 careful choice of library function is needed than that provided
3985 by the vanilla `break;'.
3989 The expr_tree has been completely set up and is ready to be returned
3990 as is. No further actions are taken. Use this when the tree is not
3991 in the simple form for one of the arity_n labels. */
3993 /* For info on how the switch statement cases were written, see the files
3994 enclosed in comments below the switch statement. */
3996 codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3997 gfrt = ffeintrin_gfrt_direct (codegen_imp);
3998 if (gfrt == FFECOM_gfrt)
3999 gfrt = ffeintrin_gfrt_indirect (codegen_imp);
4001 switch (codegen_imp)
4003 case FFEINTRIN_impABS:
4004 case FFEINTRIN_impCABS:
4005 case FFEINTRIN_impCDABS:
4006 case FFEINTRIN_impDABS:
4007 case FFEINTRIN_impIABS:
4008 if (ffeinfo_basictype (ffebld_info (arg1))
4009 == FFEINFO_basictypeCOMPLEX)
4011 if (kt == FFEINFO_kindtypeREAL1)
4012 gfrt = FFECOM_gfrtCABS;
4013 else if (kt == FFEINFO_kindtypeREAL2)
4014 gfrt = FFECOM_gfrtCDABS;
4017 return ffecom_1 (ABS_EXPR, tree_type,
4018 convert (tree_type, ffecom_expr (arg1)));
4020 case FFEINTRIN_impACOS:
4021 case FFEINTRIN_impDACOS:
4024 case FFEINTRIN_impAIMAG:
4025 case FFEINTRIN_impDIMAG:
4026 case FFEINTRIN_impIMAGPART:
4027 if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4028 arg1_type = TREE_TYPE (arg1_type);
4030 arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4034 ffecom_1 (IMAGPART_EXPR, arg1_type,
4035 ffecom_expr (arg1)));
4037 case FFEINTRIN_impAINT:
4038 case FFEINTRIN_impDINT:
4040 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
4041 return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
4042 #else /* in the meantime, must use floor to avoid range problems with ints */
4043 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
4044 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4047 ffecom_3 (COND_EXPR, double_type_node,
4049 (ffecom_2 (GE_EXPR, integer_type_node,
4052 ffecom_float_zero_))),
4053 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4054 build_tree_list (NULL_TREE,
4055 convert (double_type_node,
4058 ffecom_1 (NEGATE_EXPR, double_type_node,
4059 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4060 build_tree_list (NULL_TREE,
4061 convert (double_type_node,
4062 ffecom_1 (NEGATE_EXPR,
4070 case FFEINTRIN_impANINT:
4071 case FFEINTRIN_impDNINT:
4072 #if 0 /* This way of doing it won't handle real
4073 numbers of large magnitudes. */
4074 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4075 expr_tree = convert (tree_type,
4076 convert (integer_type_node,
4077 ffecom_3 (COND_EXPR, tree_type,
4082 ffecom_float_zero_)),
4083 ffecom_2 (PLUS_EXPR,
4086 ffecom_float_half_),
4087 ffecom_2 (MINUS_EXPR,
4090 ffecom_float_half_))));
4092 #else /* So we instead call floor. */
4093 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4094 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4097 ffecom_3 (COND_EXPR, double_type_node,
4099 (ffecom_2 (GE_EXPR, integer_type_node,
4102 ffecom_float_zero_))),
4103 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4104 build_tree_list (NULL_TREE,
4105 convert (double_type_node,
4106 ffecom_2 (PLUS_EXPR,
4110 ffecom_float_half_)))),
4112 ffecom_1 (NEGATE_EXPR, double_type_node,
4113 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4114 build_tree_list (NULL_TREE,
4115 convert (double_type_node,
4116 ffecom_2 (MINUS_EXPR,
4119 ffecom_float_half_),
4126 case FFEINTRIN_impASIN:
4127 case FFEINTRIN_impDASIN:
4128 case FFEINTRIN_impATAN:
4129 case FFEINTRIN_impDATAN:
4130 case FFEINTRIN_impATAN2:
4131 case FFEINTRIN_impDATAN2:
4134 case FFEINTRIN_impCHAR:
4135 case FFEINTRIN_impACHAR:
4137 tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4139 tempvar = ffebld_nonter_hook (expr);
4143 tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4145 expr_tree = ffecom_modify (tmv,
4146 ffecom_2 (ARRAY_REF, tmv, tempvar,
4148 convert (tmv, ffecom_expr (arg1)));
4150 expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4153 expr_tree = ffecom_1 (ADDR_EXPR,
4154 build_pointer_type (TREE_TYPE (expr_tree)),
4158 case FFEINTRIN_impCMPLX:
4159 case FFEINTRIN_impDCMPLX:
4162 convert (tree_type, ffecom_expr (arg1));
4164 real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4166 ffecom_2 (COMPLEX_EXPR, tree_type,
4167 convert (real_type, ffecom_expr (arg1)),
4169 ffecom_expr (arg2)));
4171 case FFEINTRIN_impCOMPLEX:
4173 ffecom_2 (COMPLEX_EXPR, tree_type,
4175 ffecom_expr (arg2));
4177 case FFEINTRIN_impCONJG:
4178 case FFEINTRIN_impDCONJG:
4182 real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4183 arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4185 ffecom_2 (COMPLEX_EXPR, tree_type,
4186 ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4187 ffecom_1 (NEGATE_EXPR, real_type,
4188 ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4191 case FFEINTRIN_impCOS:
4192 case FFEINTRIN_impCCOS:
4193 case FFEINTRIN_impCDCOS:
4194 case FFEINTRIN_impDCOS:
4195 if (bt == FFEINFO_basictypeCOMPLEX)
4197 if (kt == FFEINFO_kindtypeREAL1)
4198 gfrt = FFECOM_gfrtCCOS; /* Overlapping result okay. */
4199 else if (kt == FFEINFO_kindtypeREAL2)
4200 gfrt = FFECOM_gfrtCDCOS; /* Overlapping result okay. */
4204 case FFEINTRIN_impCOSH:
4205 case FFEINTRIN_impDCOSH:
4208 case FFEINTRIN_impDBLE:
4209 case FFEINTRIN_impDFLOAT:
4210 case FFEINTRIN_impDREAL:
4211 case FFEINTRIN_impFLOAT:
4212 case FFEINTRIN_impIDINT:
4213 case FFEINTRIN_impIFIX:
4214 case FFEINTRIN_impINT2:
4215 case FFEINTRIN_impINT8:
4216 case FFEINTRIN_impINT:
4217 case FFEINTRIN_impLONG:
4218 case FFEINTRIN_impREAL:
4219 case FFEINTRIN_impSHORT:
4220 case FFEINTRIN_impSNGL:
4221 return convert (tree_type, ffecom_expr (arg1));
4223 case FFEINTRIN_impDIM:
4224 case FFEINTRIN_impDDIM:
4225 case FFEINTRIN_impIDIM:
4226 saved_expr1 = ffecom_save_tree (convert (tree_type,
4227 ffecom_expr (arg1)));
4228 saved_expr2 = ffecom_save_tree (convert (tree_type,
4229 ffecom_expr (arg2)));
4231 ffecom_3 (COND_EXPR, tree_type,
4233 (ffecom_2 (GT_EXPR, integer_type_node,
4236 ffecom_2 (MINUS_EXPR, tree_type,
4239 convert (tree_type, ffecom_float_zero_));
4241 case FFEINTRIN_impDPROD:
4243 ffecom_2 (MULT_EXPR, tree_type,
4244 convert (tree_type, ffecom_expr (arg1)),
4245 convert (tree_type, ffecom_expr (arg2)));
4247 case FFEINTRIN_impEXP:
4248 case FFEINTRIN_impCDEXP:
4249 case FFEINTRIN_impCEXP:
4250 case FFEINTRIN_impDEXP:
4251 if (bt == FFEINFO_basictypeCOMPLEX)
4253 if (kt == FFEINFO_kindtypeREAL1)
4254 gfrt = FFECOM_gfrtCEXP; /* Overlapping result okay. */
4255 else if (kt == FFEINFO_kindtypeREAL2)
4256 gfrt = FFECOM_gfrtCDEXP; /* Overlapping result okay. */
4260 case FFEINTRIN_impICHAR:
4261 case FFEINTRIN_impIACHAR:
4262 #if 0 /* The simple approach. */
4263 ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4265 = ffecom_1 (INDIRECT_REF,
4266 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4269 = ffecom_2 (ARRAY_REF,
4270 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4273 return convert (tree_type, expr_tree);
4274 #else /* The more interesting (and more optimal) approach. */
4275 expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4276 expr_tree = ffecom_3 (COND_EXPR, tree_type,
4279 convert (tree_type, integer_zero_node));
4283 case FFEINTRIN_impINDEX:
4286 case FFEINTRIN_impLEN:
4288 break; /* The simple approach. */
4290 return ffecom_intrinsic_len_ (arg1); /* The more optimal approach. */
4293 case FFEINTRIN_impLGE:
4294 case FFEINTRIN_impLGT:
4295 case FFEINTRIN_impLLE:
4296 case FFEINTRIN_impLLT:
4299 case FFEINTRIN_impLOG:
4300 case FFEINTRIN_impALOG:
4301 case FFEINTRIN_impCDLOG:
4302 case FFEINTRIN_impCLOG:
4303 case FFEINTRIN_impDLOG:
4304 if (bt == FFEINFO_basictypeCOMPLEX)
4306 if (kt == FFEINFO_kindtypeREAL1)
4307 gfrt = FFECOM_gfrtCLOG; /* Overlapping result okay. */
4308 else if (kt == FFEINFO_kindtypeREAL2)
4309 gfrt = FFECOM_gfrtCDLOG; /* Overlapping result okay. */
4313 case FFEINTRIN_impLOG10:
4314 case FFEINTRIN_impALOG10:
4315 case FFEINTRIN_impDLOG10:
4316 if (gfrt != FFECOM_gfrt)
4317 break; /* Already picked one, stick with it. */
4319 if (kt == FFEINFO_kindtypeREAL1)
4320 /* We used to call FFECOM_gfrtALOG10 here. */
4321 gfrt = FFECOM_gfrtL_LOG10;
4322 else if (kt == FFEINFO_kindtypeREAL2)
4323 /* We used to call FFECOM_gfrtDLOG10 here. */
4324 gfrt = FFECOM_gfrtL_LOG10;
4327 case FFEINTRIN_impMAX:
4328 case FFEINTRIN_impAMAX0:
4329 case FFEINTRIN_impAMAX1:
4330 case FFEINTRIN_impDMAX1:
4331 case FFEINTRIN_impMAX0:
4332 case FFEINTRIN_impMAX1:
4333 if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4334 arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4336 arg1_type = tree_type;
4337 expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4338 convert (arg1_type, ffecom_expr (arg1)),
4339 convert (arg1_type, ffecom_expr (arg2)));
4340 for (; list != NULL; list = ffebld_trail (list))
4342 if ((ffebld_head (list) == NULL)
4343 || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4345 expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4348 ffecom_expr (ffebld_head (list))));
4350 return convert (tree_type, expr_tree);
4352 case FFEINTRIN_impMIN:
4353 case FFEINTRIN_impAMIN0:
4354 case FFEINTRIN_impAMIN1:
4355 case FFEINTRIN_impDMIN1:
4356 case FFEINTRIN_impMIN0:
4357 case FFEINTRIN_impMIN1:
4358 if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4359 arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4361 arg1_type = tree_type;
4362 expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4363 convert (arg1_type, ffecom_expr (arg1)),
4364 convert (arg1_type, ffecom_expr (arg2)));
4365 for (; list != NULL; list = ffebld_trail (list))
4367 if ((ffebld_head (list) == NULL)
4368 || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4370 expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4373 ffecom_expr (ffebld_head (list))));
4375 return convert (tree_type, expr_tree);
4377 case FFEINTRIN_impMOD:
4378 case FFEINTRIN_impAMOD:
4379 case FFEINTRIN_impDMOD:
4380 if (bt != FFEINFO_basictypeREAL)
4381 return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4382 convert (tree_type, ffecom_expr (arg1)),
4383 convert (tree_type, ffecom_expr (arg2)));
4385 if (kt == FFEINFO_kindtypeREAL1)
4386 /* We used to call FFECOM_gfrtAMOD here. */
4387 gfrt = FFECOM_gfrtL_FMOD;
4388 else if (kt == FFEINFO_kindtypeREAL2)
4389 /* We used to call FFECOM_gfrtDMOD here. */
4390 gfrt = FFECOM_gfrtL_FMOD;
4393 case FFEINTRIN_impNINT:
4394 case FFEINTRIN_impIDNINT:
4396 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4397 return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4399 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4400 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4402 convert (ffecom_integer_type_node,
4403 ffecom_3 (COND_EXPR, arg1_type,
4405 (ffecom_2 (GE_EXPR, integer_type_node,
4408 ffecom_float_zero_))),
4409 ffecom_2 (PLUS_EXPR, arg1_type,
4412 ffecom_float_half_)),
4413 ffecom_2 (MINUS_EXPR, arg1_type,
4416 ffecom_float_half_))));
4419 case FFEINTRIN_impSIGN:
4420 case FFEINTRIN_impDSIGN:
4421 case FFEINTRIN_impISIGN:
4423 tree arg2_tree = ffecom_expr (arg2);
4427 (ffecom_1 (ABS_EXPR, tree_type,
4429 ffecom_expr (arg1))));
4431 = ffecom_3 (COND_EXPR, tree_type,
4433 (ffecom_2 (GE_EXPR, integer_type_node,
4435 convert (TREE_TYPE (arg2_tree),
4436 integer_zero_node))),
4438 ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4439 /* Make sure SAVE_EXPRs get referenced early enough. */
4441 = ffecom_2 (COMPOUND_EXPR, tree_type,
4442 convert (void_type_node, saved_expr1),
4447 case FFEINTRIN_impSIN:
4448 case FFEINTRIN_impCDSIN:
4449 case FFEINTRIN_impCSIN:
4450 case FFEINTRIN_impDSIN:
4451 if (bt == FFEINFO_basictypeCOMPLEX)
4453 if (kt == FFEINFO_kindtypeREAL1)
4454 gfrt = FFECOM_gfrtCSIN; /* Overlapping result okay. */
4455 else if (kt == FFEINFO_kindtypeREAL2)
4456 gfrt = FFECOM_gfrtCDSIN; /* Overlapping result okay. */
4460 case FFEINTRIN_impSINH:
4461 case FFEINTRIN_impDSINH:
4464 case FFEINTRIN_impSQRT:
4465 case FFEINTRIN_impCDSQRT:
4466 case FFEINTRIN_impCSQRT:
4467 case FFEINTRIN_impDSQRT:
4468 if (bt == FFEINFO_basictypeCOMPLEX)
4470 if (kt == FFEINFO_kindtypeREAL1)
4471 gfrt = FFECOM_gfrtCSQRT; /* Overlapping result okay. */
4472 else if (kt == FFEINFO_kindtypeREAL2)
4473 gfrt = FFECOM_gfrtCDSQRT; /* Overlapping result okay. */
4477 case FFEINTRIN_impTAN:
4478 case FFEINTRIN_impDTAN:
4479 case FFEINTRIN_impTANH:
4480 case FFEINTRIN_impDTANH:
4483 case FFEINTRIN_impREALPART:
4484 if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4485 arg1_type = TREE_TYPE (arg1_type);
4487 arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4491 ffecom_1 (REALPART_EXPR, arg1_type,
4492 ffecom_expr (arg1)));
4494 case FFEINTRIN_impIAND:
4495 case FFEINTRIN_impAND:
4496 return ffecom_2 (BIT_AND_EXPR, tree_type,
4498 ffecom_expr (arg1)),
4500 ffecom_expr (arg2)));
4502 case FFEINTRIN_impIOR:
4503 case FFEINTRIN_impOR:
4504 return ffecom_2 (BIT_IOR_EXPR, tree_type,
4506 ffecom_expr (arg1)),
4508 ffecom_expr (arg2)));
4510 case FFEINTRIN_impIEOR:
4511 case FFEINTRIN_impXOR:
4512 return ffecom_2 (BIT_XOR_EXPR, tree_type,
4514 ffecom_expr (arg1)),
4516 ffecom_expr (arg2)));
4518 case FFEINTRIN_impLSHIFT:
4519 return ffecom_2 (LSHIFT_EXPR, tree_type,
4521 convert (integer_type_node,
4522 ffecom_expr (arg2)));
4524 case FFEINTRIN_impRSHIFT:
4525 return ffecom_2 (RSHIFT_EXPR, tree_type,
4527 convert (integer_type_node,
4528 ffecom_expr (arg2)));
4530 case FFEINTRIN_impNOT:
4531 return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4533 case FFEINTRIN_impBIT_SIZE:
4534 return convert (tree_type, TYPE_SIZE (arg1_type));
4536 case FFEINTRIN_impBTEST:
4538 ffetargetLogical1 true;
4539 ffetargetLogical1 false;
4543 ffetarget_logical1 (&true, TRUE);
4544 ffetarget_logical1 (&false, FALSE);
4546 true_tree = convert (tree_type, integer_one_node);
4548 true_tree = convert (tree_type, build_int_2 (true, 0));
4550 false_tree = convert (tree_type, integer_zero_node);
4552 false_tree = convert (tree_type, build_int_2 (false, 0));
4555 ffecom_3 (COND_EXPR, tree_type,
4557 (ffecom_2 (EQ_EXPR, integer_type_node,
4558 ffecom_2 (BIT_AND_EXPR, arg1_type,
4560 ffecom_2 (LSHIFT_EXPR, arg1_type,
4563 convert (integer_type_node,
4564 ffecom_expr (arg2)))),
4566 integer_zero_node))),
4571 case FFEINTRIN_impIBCLR:
4573 ffecom_2 (BIT_AND_EXPR, tree_type,
4575 ffecom_1 (BIT_NOT_EXPR, tree_type,
4576 ffecom_2 (LSHIFT_EXPR, tree_type,
4579 convert (integer_type_node,
4580 ffecom_expr (arg2)))));
4582 case FFEINTRIN_impIBITS:
4584 tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4585 ffecom_expr (arg3)));
4587 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4590 = ffecom_2 (BIT_AND_EXPR, tree_type,
4591 ffecom_2 (RSHIFT_EXPR, tree_type,
4593 convert (integer_type_node,
4594 ffecom_expr (arg2))),
4596 ffecom_2 (RSHIFT_EXPR, uns_type,
4597 ffecom_1 (BIT_NOT_EXPR,
4600 integer_zero_node)),
4601 ffecom_2 (MINUS_EXPR,
4603 TYPE_SIZE (uns_type),
4605 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4607 = ffecom_3 (COND_EXPR, tree_type,
4609 (ffecom_2 (NE_EXPR, integer_type_node,
4611 integer_zero_node)),
4613 convert (tree_type, integer_zero_node));
4618 case FFEINTRIN_impIBSET:
4620 ffecom_2 (BIT_IOR_EXPR, tree_type,
4622 ffecom_2 (LSHIFT_EXPR, tree_type,
4623 convert (tree_type, integer_one_node),
4624 convert (integer_type_node,
4625 ffecom_expr (arg2))));
4627 case FFEINTRIN_impISHFT:
4629 tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4630 tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4631 ffecom_expr (arg2)));
4633 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4636 = ffecom_3 (COND_EXPR, tree_type,
4638 (ffecom_2 (GE_EXPR, integer_type_node,
4640 integer_zero_node)),
4641 ffecom_2 (LSHIFT_EXPR, tree_type,
4645 ffecom_2 (RSHIFT_EXPR, uns_type,
4646 convert (uns_type, arg1_tree),
4647 ffecom_1 (NEGATE_EXPR,
4650 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4652 = ffecom_3 (COND_EXPR, tree_type,
4654 (ffecom_2 (NE_EXPR, integer_type_node,
4656 TYPE_SIZE (uns_type))),
4658 convert (tree_type, integer_zero_node));
4660 /* Make sure SAVE_EXPRs get referenced early enough. */
4662 = ffecom_2 (COMPOUND_EXPR, tree_type,
4663 convert (void_type_node, arg1_tree),
4664 ffecom_2 (COMPOUND_EXPR, tree_type,
4665 convert (void_type_node, arg2_tree),
4670 case FFEINTRIN_impISHFTC:
4672 tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4673 tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4674 ffecom_expr (arg2)));
4675 tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4676 : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4682 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4685 = ffecom_2 (LSHIFT_EXPR, tree_type,
4686 ffecom_1 (BIT_NOT_EXPR, tree_type,
4687 convert (tree_type, integer_zero_node)),
4689 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4691 = ffecom_3 (COND_EXPR, tree_type,
4693 (ffecom_2 (NE_EXPR, integer_type_node,
4695 TYPE_SIZE (uns_type))),
4697 convert (tree_type, integer_zero_node));
4699 mask_arg1 = ffecom_save_tree (mask_arg1);
4701 = ffecom_2 (BIT_AND_EXPR, tree_type,
4703 ffecom_1 (BIT_NOT_EXPR, tree_type,
4705 masked_arg1 = ffecom_save_tree (masked_arg1);
4707 = ffecom_2 (BIT_IOR_EXPR, tree_type,
4709 ffecom_2 (RSHIFT_EXPR, uns_type,
4710 convert (uns_type, masked_arg1),
4711 ffecom_1 (NEGATE_EXPR,
4714 ffecom_2 (LSHIFT_EXPR, tree_type,
4716 ffecom_2 (PLUS_EXPR, integer_type_node,
4720 = ffecom_2 (BIT_IOR_EXPR, tree_type,
4721 ffecom_2 (LSHIFT_EXPR, tree_type,
4725 ffecom_2 (RSHIFT_EXPR, uns_type,
4726 convert (uns_type, masked_arg1),
4727 ffecom_2 (MINUS_EXPR,
4732 = ffecom_3 (COND_EXPR, tree_type,
4734 (ffecom_2 (LT_EXPR, integer_type_node,
4736 integer_zero_node)),
4740 = ffecom_2 (BIT_IOR_EXPR, tree_type,
4741 ffecom_2 (BIT_AND_EXPR, tree_type,
4744 ffecom_2 (BIT_AND_EXPR, tree_type,
4745 ffecom_1 (BIT_NOT_EXPR, tree_type,
4749 = ffecom_3 (COND_EXPR, tree_type,
4751 (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4752 ffecom_2 (EQ_EXPR, integer_type_node,
4757 ffecom_2 (EQ_EXPR, integer_type_node,
4759 integer_zero_node))),
4762 /* Make sure SAVE_EXPRs get referenced early enough. */
4764 = ffecom_2 (COMPOUND_EXPR, tree_type,
4765 convert (void_type_node, arg1_tree),
4766 ffecom_2 (COMPOUND_EXPR, tree_type,
4767 convert (void_type_node, arg2_tree),
4768 ffecom_2 (COMPOUND_EXPR, tree_type,
4769 convert (void_type_node,
4771 ffecom_2 (COMPOUND_EXPR, tree_type,
4772 convert (void_type_node,
4776 = ffecom_2 (COMPOUND_EXPR, tree_type,
4777 convert (void_type_node,
4783 case FFEINTRIN_impLOC:
4785 tree arg1_tree = ffecom_expr (arg1);
4788 = convert (tree_type,
4789 ffecom_1 (ADDR_EXPR,
4790 build_pointer_type (TREE_TYPE (arg1_tree)),
4795 case FFEINTRIN_impMVBITS:
4800 ffebld arg4 = ffebld_head (ffebld_trail (list));
4803 ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4807 tree arg5_plus_arg3;
4809 arg2_tree = convert (integer_type_node,
4810 ffecom_expr (arg2));
4811 arg3_tree = ffecom_save_tree (convert (integer_type_node,
4812 ffecom_expr (arg3)));
4813 arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4814 arg4_type = TREE_TYPE (arg4_tree);
4816 arg1_tree = ffecom_save_tree (convert (arg4_type,
4817 ffecom_expr (arg1)));
4819 arg5_tree = ffecom_save_tree (convert (integer_type_node,
4820 ffecom_expr (arg5)));
4823 = ffecom_2 (LSHIFT_EXPR, arg4_type,
4824 ffecom_2 (BIT_AND_EXPR, arg4_type,
4825 ffecom_2 (RSHIFT_EXPR, arg4_type,
4828 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4829 ffecom_2 (LSHIFT_EXPR, arg4_type,
4830 ffecom_1 (BIT_NOT_EXPR,
4834 integer_zero_node)),
4838 = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4842 = ffecom_2 (LSHIFT_EXPR, arg4_type,
4843 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4845 integer_zero_node)),
4847 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4849 = ffecom_3 (COND_EXPR, arg4_type,
4851 (ffecom_2 (NE_EXPR, integer_type_node,
4853 convert (TREE_TYPE (arg5_plus_arg3),
4854 TYPE_SIZE (arg4_type)))),
4856 convert (arg4_type, integer_zero_node));
4859 = ffecom_2 (BIT_AND_EXPR, arg4_type,
4861 ffecom_2 (BIT_IOR_EXPR, arg4_type,
4863 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4864 ffecom_2 (LSHIFT_EXPR, arg4_type,
4865 ffecom_1 (BIT_NOT_EXPR,
4869 integer_zero_node)),
4872 = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4875 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4877 = ffecom_3 (COND_EXPR, arg4_type,
4879 (ffecom_2 (NE_EXPR, integer_type_node,
4881 convert (TREE_TYPE (arg3_tree),
4882 integer_zero_node))),
4886 = ffecom_3 (COND_EXPR, arg4_type,
4888 (ffecom_2 (NE_EXPR, integer_type_node,
4890 convert (TREE_TYPE (arg3_tree),
4891 TYPE_SIZE (arg4_type)))),
4896 = ffecom_2s (MODIFY_EXPR, void_type_node,
4899 /* Make sure SAVE_EXPRs get referenced early enough. */
4901 = ffecom_2 (COMPOUND_EXPR, void_type_node,
4903 ffecom_2 (COMPOUND_EXPR, void_type_node,
4905 ffecom_2 (COMPOUND_EXPR, void_type_node,
4907 ffecom_2 (COMPOUND_EXPR, void_type_node,
4911 = ffecom_2 (COMPOUND_EXPR, void_type_node,
4918 case FFEINTRIN_impDERF:
4919 case FFEINTRIN_impERF:
4920 case FFEINTRIN_impDERFC:
4921 case FFEINTRIN_impERFC:
4924 case FFEINTRIN_impIARGC:
4925 /* extern int xargc; i__1 = xargc - 1; */
4926 expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4928 convert (TREE_TYPE (ffecom_tree_xargc_),
4932 case FFEINTRIN_impSIGNAL_func:
4933 case FFEINTRIN_impSIGNAL_subr:
4939 arg1_tree = convert (ffecom_f2c_integer_type_node,
4940 ffecom_expr (arg1));
4941 arg1_tree = ffecom_1 (ADDR_EXPR,
4942 build_pointer_type (TREE_TYPE (arg1_tree)),
4945 /* Pass procedure as a pointer to it, anything else by value. */
4946 if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4947 arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4949 arg2_tree = ffecom_ptr_to_expr (arg2);
4950 arg2_tree = convert (TREE_TYPE (null_pointer_node),
4954 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4956 arg3_tree = NULL_TREE;
4958 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4959 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4960 TREE_CHAIN (arg1_tree) = arg2_tree;
4963 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4964 ffecom_gfrt_kindtype (gfrt),
4966 ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4970 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4971 ffebld_nonter_hook (expr));
4973 if (arg3_tree != NULL_TREE)
4975 = ffecom_modify (NULL_TREE, arg3_tree,
4976 convert (TREE_TYPE (arg3_tree),
4981 case FFEINTRIN_impALARM:
4987 arg1_tree = convert (ffecom_f2c_integer_type_node,
4988 ffecom_expr (arg1));
4989 arg1_tree = ffecom_1 (ADDR_EXPR,
4990 build_pointer_type (TREE_TYPE (arg1_tree)),
4993 /* Pass procedure as a pointer to it, anything else by value. */
4994 if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4995 arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4997 arg2_tree = ffecom_ptr_to_expr (arg2);
4998 arg2_tree = convert (TREE_TYPE (null_pointer_node),
5002 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5004 arg3_tree = NULL_TREE;
5006 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5007 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5008 TREE_CHAIN (arg1_tree) = arg2_tree;
5011 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5012 ffecom_gfrt_kindtype (gfrt),
5016 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5017 ffebld_nonter_hook (expr));
5019 if (arg3_tree != NULL_TREE)
5021 = ffecom_modify (NULL_TREE, arg3_tree,
5022 convert (TREE_TYPE (arg3_tree),
5027 case FFEINTRIN_impCHDIR_subr:
5028 case FFEINTRIN_impFDATE_subr:
5029 case FFEINTRIN_impFGET_subr:
5030 case FFEINTRIN_impFPUT_subr:
5031 case FFEINTRIN_impGETCWD_subr:
5032 case FFEINTRIN_impHOSTNM_subr:
5033 case FFEINTRIN_impSYSTEM_subr:
5034 case FFEINTRIN_impUNLINK_subr:
5036 tree arg1_len = integer_zero_node;
5040 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5043 arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5045 arg2_tree = NULL_TREE;
5047 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5048 arg1_len = build_tree_list (NULL_TREE, arg1_len);
5049 TREE_CHAIN (arg1_tree) = arg1_len;
5052 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5053 ffecom_gfrt_kindtype (gfrt),
5057 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5058 ffebld_nonter_hook (expr));
5060 if (arg2_tree != NULL_TREE)
5062 = ffecom_modify (NULL_TREE, arg2_tree,
5063 convert (TREE_TYPE (arg2_tree),
5068 case FFEINTRIN_impEXIT:
5072 expr_tree = build_tree_list (NULL_TREE,
5073 ffecom_1 (ADDR_EXPR,
5075 (ffecom_integer_type_node),
5076 integer_zero_node));
5079 ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5080 ffecom_gfrt_kindtype (gfrt),
5084 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5085 ffebld_nonter_hook (expr));
5087 case FFEINTRIN_impFLUSH:
5089 gfrt = FFECOM_gfrtFLUSH;
5091 gfrt = FFECOM_gfrtFLUSH1;
5094 case FFEINTRIN_impCHMOD_subr:
5095 case FFEINTRIN_impLINK_subr:
5096 case FFEINTRIN_impRENAME_subr:
5097 case FFEINTRIN_impSYMLNK_subr:
5099 tree arg1_len = integer_zero_node;
5101 tree arg2_len = integer_zero_node;
5105 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5106 arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5108 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5110 arg3_tree = NULL_TREE;
5112 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5113 arg1_len = build_tree_list (NULL_TREE, arg1_len);
5114 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5115 arg2_len = build_tree_list (NULL_TREE, arg2_len);
5116 TREE_CHAIN (arg1_tree) = arg2_tree;
5117 TREE_CHAIN (arg2_tree) = arg1_len;
5118 TREE_CHAIN (arg1_len) = arg2_len;
5119 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5120 ffecom_gfrt_kindtype (gfrt),
5124 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5125 ffebld_nonter_hook (expr));
5126 if (arg3_tree != NULL_TREE)
5127 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5128 convert (TREE_TYPE (arg3_tree),
5133 case FFEINTRIN_impLSTAT_subr:
5134 case FFEINTRIN_impSTAT_subr:
5136 tree arg1_len = integer_zero_node;
5141 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5143 arg2_tree = ffecom_ptr_to_expr (arg2);
5146 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5148 arg3_tree = NULL_TREE;
5150 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5151 arg1_len = build_tree_list (NULL_TREE, arg1_len);
5152 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5153 TREE_CHAIN (arg1_tree) = arg2_tree;
5154 TREE_CHAIN (arg2_tree) = arg1_len;
5155 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5156 ffecom_gfrt_kindtype (gfrt),
5160 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5161 ffebld_nonter_hook (expr));
5162 if (arg3_tree != NULL_TREE)
5163 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5164 convert (TREE_TYPE (arg3_tree),
5169 case FFEINTRIN_impFGETC_subr:
5170 case FFEINTRIN_impFPUTC_subr:
5174 tree arg2_len = integer_zero_node;
5177 arg1_tree = convert (ffecom_f2c_integer_type_node,
5178 ffecom_expr (arg1));
5179 arg1_tree = ffecom_1 (ADDR_EXPR,
5180 build_pointer_type (TREE_TYPE (arg1_tree)),
5183 arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5185 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5187 arg3_tree = NULL_TREE;
5189 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5190 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5191 arg2_len = build_tree_list (NULL_TREE, arg2_len);
5192 TREE_CHAIN (arg1_tree) = arg2_tree;
5193 TREE_CHAIN (arg2_tree) = arg2_len;
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),
5209 case FFEINTRIN_impFSTAT_subr:
5215 arg1_tree = convert (ffecom_f2c_integer_type_node,
5216 ffecom_expr (arg1));
5217 arg1_tree = ffecom_1 (ADDR_EXPR,
5218 build_pointer_type (TREE_TYPE (arg1_tree)),
5221 arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5222 ffecom_ptr_to_expr (arg2));
5225 arg3_tree = NULL_TREE;
5227 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5229 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5230 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5231 TREE_CHAIN (arg1_tree) = arg2_tree;
5232 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5233 ffecom_gfrt_kindtype (gfrt),
5237 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5238 ffebld_nonter_hook (expr));
5239 if (arg3_tree != NULL_TREE) {
5240 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5241 convert (TREE_TYPE (arg3_tree),
5247 case FFEINTRIN_impKILL_subr:
5253 arg1_tree = convert (ffecom_f2c_integer_type_node,
5254 ffecom_expr (arg1));
5255 arg1_tree = ffecom_1 (ADDR_EXPR,
5256 build_pointer_type (TREE_TYPE (arg1_tree)),
5259 arg2_tree = convert (ffecom_f2c_integer_type_node,
5260 ffecom_expr (arg2));
5261 arg2_tree = ffecom_1 (ADDR_EXPR,
5262 build_pointer_type (TREE_TYPE (arg2_tree)),
5266 arg3_tree = NULL_TREE;
5268 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5270 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5271 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5272 TREE_CHAIN (arg1_tree) = arg2_tree;
5273 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5274 ffecom_gfrt_kindtype (gfrt),
5278 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5279 ffebld_nonter_hook (expr));
5280 if (arg3_tree != NULL_TREE) {
5281 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5282 convert (TREE_TYPE (arg3_tree),
5288 case FFEINTRIN_impCTIME_subr:
5289 case FFEINTRIN_impTTYNAM_subr:
5291 tree arg1_len = integer_zero_node;
5295 arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5297 arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5298 ffecom_f2c_longint_type_node :
5299 ffecom_f2c_integer_type_node),
5300 ffecom_expr (arg1));
5301 arg2_tree = ffecom_1 (ADDR_EXPR,
5302 build_pointer_type (TREE_TYPE (arg2_tree)),
5305 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5306 arg1_len = build_tree_list (NULL_TREE, arg1_len);
5307 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5308 TREE_CHAIN (arg1_len) = arg2_tree;
5309 TREE_CHAIN (arg1_tree) = arg1_len;
5312 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5313 ffecom_gfrt_kindtype (gfrt),
5317 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5318 ffebld_nonter_hook (expr));
5319 TREE_SIDE_EFFECTS (expr_tree) = 1;
5323 case FFEINTRIN_impIRAND:
5324 case FFEINTRIN_impRAND:
5325 /* Arg defaults to 0 (normal random case) */
5330 arg1_tree = ffecom_integer_zero_node;
5332 arg1_tree = ffecom_expr (arg1);
5333 arg1_tree = convert (ffecom_f2c_integer_type_node,
5335 arg1_tree = ffecom_1 (ADDR_EXPR,
5336 build_pointer_type (TREE_TYPE (arg1_tree)),
5338 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5340 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5341 ffecom_gfrt_kindtype (gfrt),
5343 ((codegen_imp == FFEINTRIN_impIRAND) ?
5344 ffecom_f2c_integer_type_node :
5345 ffecom_f2c_real_type_node),
5347 dest_tree, dest, dest_used,
5349 ffebld_nonter_hook (expr));
5353 case FFEINTRIN_impFTELL_subr:
5354 case FFEINTRIN_impUMASK_subr:
5359 arg1_tree = convert (ffecom_f2c_integer_type_node,
5360 ffecom_expr (arg1));
5361 arg1_tree = ffecom_1 (ADDR_EXPR,
5362 build_pointer_type (TREE_TYPE (arg1_tree)),
5366 arg2_tree = NULL_TREE;
5368 arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5370 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5371 ffecom_gfrt_kindtype (gfrt),
5374 build_tree_list (NULL_TREE, arg1_tree),
5375 NULL_TREE, NULL, NULL, NULL_TREE,
5377 ffebld_nonter_hook (expr));
5378 if (arg2_tree != NULL_TREE) {
5379 expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5380 convert (TREE_TYPE (arg2_tree),
5386 case FFEINTRIN_impCPU_TIME:
5387 case FFEINTRIN_impSECOND_subr:
5391 arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5394 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5395 ffecom_gfrt_kindtype (gfrt),
5399 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5400 ffebld_nonter_hook (expr));
5403 = ffecom_modify (NULL_TREE, arg1_tree,
5404 convert (TREE_TYPE (arg1_tree),
5409 case FFEINTRIN_impDTIME_subr:
5410 case FFEINTRIN_impETIME_subr:
5415 result_tree = ffecom_expr_w (NULL_TREE, arg2);
5417 arg1_tree = ffecom_ptr_to_expr (arg1);
5419 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5420 ffecom_gfrt_kindtype (gfrt),
5423 build_tree_list (NULL_TREE, arg1_tree),
5424 NULL_TREE, NULL, NULL, NULL_TREE,
5426 ffebld_nonter_hook (expr));
5427 expr_tree = ffecom_modify (NULL_TREE, result_tree,
5428 convert (TREE_TYPE (result_tree),
5433 /* Straightforward calls of libf2c routines: */
5434 case FFEINTRIN_impABORT:
5435 case FFEINTRIN_impACCESS:
5436 case FFEINTRIN_impBESJ0:
5437 case FFEINTRIN_impBESJ1:
5438 case FFEINTRIN_impBESJN:
5439 case FFEINTRIN_impBESY0:
5440 case FFEINTRIN_impBESY1:
5441 case FFEINTRIN_impBESYN:
5442 case FFEINTRIN_impCHDIR_func:
5443 case FFEINTRIN_impCHMOD_func:
5444 case FFEINTRIN_impDATE:
5445 case FFEINTRIN_impDATE_AND_TIME:
5446 case FFEINTRIN_impDBESJ0:
5447 case FFEINTRIN_impDBESJ1:
5448 case FFEINTRIN_impDBESJN:
5449 case FFEINTRIN_impDBESY0:
5450 case FFEINTRIN_impDBESY1:
5451 case FFEINTRIN_impDBESYN:
5452 case FFEINTRIN_impDTIME_func:
5453 case FFEINTRIN_impETIME_func:
5454 case FFEINTRIN_impFGETC_func:
5455 case FFEINTRIN_impFGET_func:
5456 case FFEINTRIN_impFNUM:
5457 case FFEINTRIN_impFPUTC_func:
5458 case FFEINTRIN_impFPUT_func:
5459 case FFEINTRIN_impFSEEK:
5460 case FFEINTRIN_impFSTAT_func:
5461 case FFEINTRIN_impFTELL_func:
5462 case FFEINTRIN_impGERROR:
5463 case FFEINTRIN_impGETARG:
5464 case FFEINTRIN_impGETCWD_func:
5465 case FFEINTRIN_impGETENV:
5466 case FFEINTRIN_impGETGID:
5467 case FFEINTRIN_impGETLOG:
5468 case FFEINTRIN_impGETPID:
5469 case FFEINTRIN_impGETUID:
5470 case FFEINTRIN_impGMTIME:
5471 case FFEINTRIN_impHOSTNM_func:
5472 case FFEINTRIN_impIDATE_unix:
5473 case FFEINTRIN_impIDATE_vxt:
5474 case FFEINTRIN_impIERRNO:
5475 case FFEINTRIN_impISATTY:
5476 case FFEINTRIN_impITIME:
5477 case FFEINTRIN_impKILL_func:
5478 case FFEINTRIN_impLINK_func:
5479 case FFEINTRIN_impLNBLNK:
5480 case FFEINTRIN_impLSTAT_func:
5481 case FFEINTRIN_impLTIME:
5482 case FFEINTRIN_impMCLOCK8:
5483 case FFEINTRIN_impMCLOCK:
5484 case FFEINTRIN_impPERROR:
5485 case FFEINTRIN_impRENAME_func:
5486 case FFEINTRIN_impSECNDS:
5487 case FFEINTRIN_impSECOND_func:
5488 case FFEINTRIN_impSLEEP:
5489 case FFEINTRIN_impSRAND:
5490 case FFEINTRIN_impSTAT_func:
5491 case FFEINTRIN_impSYMLNK_func:
5492 case FFEINTRIN_impSYSTEM_CLOCK:
5493 case FFEINTRIN_impSYSTEM_func:
5494 case FFEINTRIN_impTIME8:
5495 case FFEINTRIN_impTIME_unix:
5496 case FFEINTRIN_impTIME_vxt:
5497 case FFEINTRIN_impUMASK_func:
5498 case FFEINTRIN_impUNLINK_func:
5501 case FFEINTRIN_impCTIME_func: /* CHARACTER functions not handled here. */
5502 case FFEINTRIN_impFDATE_func: /* CHARACTER functions not handled here. */
5503 case FFEINTRIN_impTTYNAM_func: /* CHARACTER functions not handled here. */
5504 case FFEINTRIN_impNONE:
5505 case FFEINTRIN_imp: /* Hush up gcc warning. */
5506 fprintf (stderr, "No %s implementation.\n",
5507 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5508 assert ("unimplemented intrinsic" == NULL);
5509 return error_mark_node;
5512 assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5514 expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5515 ffebld_right (expr));
5517 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5518 (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5520 expr_tree, dest_tree, dest, dest_used,
5522 ffebld_nonter_hook (expr));
5524 /* See bottom of this file for f2c transforms used to determine
5525 many of the above implementations. The info seems to confuse
5526 Emacs's C mode indentation, which is why it's been moved to
5527 the bottom of this source file. */
5531 /* For power (exponentiation) where right-hand operand is type INTEGER,
5532 generate in-line code to do it the fast way (which, if the operand
5533 is a constant, might just mean a series of multiplies). */
5535 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5537 ffecom_expr_power_integer_ (ffebld expr)
5539 tree l = ffecom_expr (ffebld_left (expr));
5540 tree r = ffecom_expr (ffebld_right (expr));
5541 tree ltype = TREE_TYPE (l);
5542 tree rtype = TREE_TYPE (r);
5543 tree result = NULL_TREE;
5545 if (l == error_mark_node
5546 || r == error_mark_node)
5547 return error_mark_node;
5549 if (TREE_CODE (r) == INTEGER_CST)
5551 int sgn = tree_int_cst_sgn (r);
5554 return convert (ltype, integer_one_node);
5556 if ((TREE_CODE (ltype) == INTEGER_TYPE)
5559 /* Reciprocal of integer is either 0, -1, or 1, so after
5560 calculating that (which we leave to the back end to do
5561 or not do optimally), don't bother with any multiplying. */
5563 result = ffecom_tree_divide_ (ltype,
5564 convert (ltype, integer_one_node),
5566 NULL_TREE, NULL, NULL, NULL_TREE);
5567 r = ffecom_1 (NEGATE_EXPR,
5570 if ((TREE_INT_CST_LOW (r) & 1) == 0)
5571 result = ffecom_1 (ABS_EXPR, rtype,
5575 /* Generate appropriate series of multiplies, preceded
5576 by divide if the exponent is negative. */
5582 l = ffecom_tree_divide_ (ltype,
5583 convert (ltype, integer_one_node),
5585 NULL_TREE, NULL, NULL,
5586 ffebld_nonter_hook (expr));
5587 r = ffecom_1 (NEGATE_EXPR, rtype, r);
5588 assert (TREE_CODE (r) == INTEGER_CST);
5590 if (tree_int_cst_sgn (r) < 0)
5591 { /* The "most negative" number. */
5592 r = ffecom_1 (NEGATE_EXPR, rtype,
5593 ffecom_2 (RSHIFT_EXPR, rtype,
5597 l = ffecom_2 (MULT_EXPR, ltype,
5605 if (TREE_INT_CST_LOW (r) & 1)
5607 if (result == NULL_TREE)
5610 result = ffecom_2 (MULT_EXPR, ltype,
5615 r = ffecom_2 (RSHIFT_EXPR, rtype,
5618 if (integer_zerop (r))
5620 assert (TREE_CODE (r) == INTEGER_CST);
5623 l = ffecom_2 (MULT_EXPR, ltype,
5630 /* Though rhs isn't a constant, in-line code cannot be expanded
5631 while transforming dummies
5632 because the back end cannot be easily convinced to generate
5633 stores (MODIFY_EXPR), handle temporaries, and so on before
5634 all the appropriate rtx's have been generated for things like
5635 dummy args referenced in rhs -- which doesn't happen until
5636 store_parm_decls() is called (expand_function_start, I believe,
5637 does the actual rtx-stuffing of PARM_DECLs).
5639 So, in this case, let the caller generate the call to the
5640 run-time-library function to evaluate the power for us. */
5642 if (ffecom_transform_only_dummies_)
5645 /* Right-hand operand not a constant, expand in-line code to figure
5646 out how to do the multiplies, &c.
5648 The returned expression is expressed this way in GNU C, where l and
5651 ({ typeof (r) rtmp = r;
5652 typeof (l) ltmp = l;
5659 if ((basetypeof (l) == basetypeof (int))
5662 result = ((typeof (l)) 1) / ltmp;
5663 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5669 if ((basetypeof (l) != basetypeof (int))
5672 ltmp = ((typeof (l)) 1) / ltmp;
5676 rtmp = -(rtmp >> 1);
5684 if ((rtmp >>= 1) == 0)
5693 Note that some of the above is compile-time collapsable, such as
5694 the first part of the if statements that checks the base type of
5695 l against int. The if statements are phrased that way to suggest
5696 an easy way to generate the if/else constructs here, knowing that
5697 the back end should (and probably does) eliminate the resulting
5698 dead code (either the int case or the non-int case), something
5699 it couldn't do without the redundant phrasing, requiring explicit
5700 dead-code elimination here, which would be kind of difficult to
5707 tree basetypeof_l_is_int;
5712 = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5714 se = expand_start_stmt_expr ();
5716 ffecom_start_compstmt ();
5719 rtmp = ffecom_make_tempvar ("power_r", rtype,
5720 FFETARGET_charactersizeNONE, -1);
5721 ltmp = ffecom_make_tempvar ("power_l", ltype,
5722 FFETARGET_charactersizeNONE, -1);
5723 result = ffecom_make_tempvar ("power_res", ltype,
5724 FFETARGET_charactersizeNONE, -1);
5725 if (TREE_CODE (ltype) == COMPLEX_TYPE
5726 || TREE_CODE (ltype) == RECORD_TYPE)
5727 divide = ffecom_make_tempvar ("power_div", ltype,
5728 FFETARGET_charactersizeNONE, -1);
5735 hook = ffebld_nonter_hook (expr);
5737 assert (TREE_CODE (hook) == TREE_VEC);
5738 assert (TREE_VEC_LENGTH (hook) == 4);
5739 rtmp = TREE_VEC_ELT (hook, 0);
5740 ltmp = TREE_VEC_ELT (hook, 1);
5741 result = TREE_VEC_ELT (hook, 2);
5742 divide = TREE_VEC_ELT (hook, 3);
5743 if (TREE_CODE (ltype) == COMPLEX_TYPE
5744 || TREE_CODE (ltype) == RECORD_TYPE)
5751 expand_expr_stmt (ffecom_modify (void_type_node,
5754 expand_expr_stmt (ffecom_modify (void_type_node,
5757 expand_start_cond (ffecom_truth_value
5758 (ffecom_2 (EQ_EXPR, integer_type_node,
5760 convert (rtype, integer_zero_node))),
5762 expand_expr_stmt (ffecom_modify (void_type_node,
5764 convert (ltype, integer_one_node)));
5765 expand_start_else ();
5766 if (! integer_zerop (basetypeof_l_is_int))
5768 expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5771 integer_zero_node)),
5773 expand_expr_stmt (ffecom_modify (void_type_node,
5777 convert (ltype, integer_one_node),
5779 NULL_TREE, NULL, NULL,
5781 expand_start_cond (ffecom_truth_value
5782 (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5783 ffecom_2 (LT_EXPR, integer_type_node,
5786 integer_zero_node)),
5787 ffecom_2 (EQ_EXPR, integer_type_node,
5788 ffecom_2 (BIT_AND_EXPR,
5790 ffecom_1 (NEGATE_EXPR,
5796 integer_zero_node)))),
5798 expand_expr_stmt (ffecom_modify (void_type_node,
5800 ffecom_1 (NEGATE_EXPR,
5804 expand_start_else ();
5806 expand_expr_stmt (ffecom_modify (void_type_node,
5808 convert (ltype, integer_one_node)));
5809 expand_start_cond (ffecom_truth_value
5810 (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5811 ffecom_truth_value_invert
5812 (basetypeof_l_is_int),
5813 ffecom_2 (LT_EXPR, integer_type_node,
5816 integer_zero_node)))),
5818 expand_expr_stmt (ffecom_modify (void_type_node,
5822 convert (ltype, integer_one_node),
5824 NULL_TREE, NULL, NULL,
5826 expand_expr_stmt (ffecom_modify (void_type_node,
5828 ffecom_1 (NEGATE_EXPR, rtype,
5830 expand_start_cond (ffecom_truth_value
5831 (ffecom_2 (LT_EXPR, integer_type_node,
5833 convert (rtype, integer_zero_node))),
5835 expand_expr_stmt (ffecom_modify (void_type_node,
5837 ffecom_1 (NEGATE_EXPR, rtype,
5838 ffecom_2 (RSHIFT_EXPR,
5841 integer_one_node))));
5842 expand_expr_stmt (ffecom_modify (void_type_node,
5844 ffecom_2 (MULT_EXPR, ltype,
5849 expand_start_loop (1);
5850 expand_start_cond (ffecom_truth_value
5851 (ffecom_2 (BIT_AND_EXPR, rtype,
5853 convert (rtype, integer_one_node))),
5855 expand_expr_stmt (ffecom_modify (void_type_node,
5857 ffecom_2 (MULT_EXPR, ltype,
5861 expand_exit_loop_if_false (NULL,
5863 (ffecom_modify (rtype,
5865 ffecom_2 (RSHIFT_EXPR,
5868 integer_one_node))));
5869 expand_expr_stmt (ffecom_modify (void_type_node,
5871 ffecom_2 (MULT_EXPR, ltype,
5876 if (!integer_zerop (basetypeof_l_is_int))
5878 expand_expr_stmt (result);
5880 t = ffecom_end_compstmt ();
5882 result = expand_end_stmt_expr (se);
5884 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5886 if (TREE_CODE (t) == BLOCK)
5888 /* Make a BIND_EXPR for the BLOCK already made. */
5889 result = build (BIND_EXPR, TREE_TYPE (result),
5890 NULL_TREE, result, t);
5891 /* Remove the block from the tree at this point.
5892 It gets put back at the proper place
5893 when the BIND_EXPR is expanded. */
5904 /* ffecom_expr_transform_ -- Transform symbols in expr
5906 ffebld expr; // FFE expression.
5907 ffecom_expr_transform_ (expr);
5909 Recursive descent on expr while transforming any untransformed SYMTERs. */
5911 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5913 ffecom_expr_transform_ (ffebld expr)
5918 tail_recurse: /* :::::::::::::::::::: */
5923 switch (ffebld_op (expr))
5925 case FFEBLD_opSYMTER:
5926 s = ffebld_symter (expr);
5927 t = ffesymbol_hook (s).decl_tree;
5928 if ((t == NULL_TREE)
5929 && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5930 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5931 && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5933 s = ffecom_sym_transform_ (s);
5934 t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy,
5937 break; /* Ok if (t == NULL) here. */
5940 ffecom_expr_transform_ (ffebld_head (expr));
5941 expr = ffebld_trail (expr);
5942 goto tail_recurse; /* :::::::::::::::::::: */
5948 switch (ffebld_arity (expr))
5951 ffecom_expr_transform_ (ffebld_left (expr));
5952 expr = ffebld_right (expr);
5953 goto tail_recurse; /* :::::::::::::::::::: */
5956 expr = ffebld_left (expr);
5957 goto tail_recurse; /* :::::::::::::::::::: */
5967 /* Make a type based on info in live f2c.h file. */
5969 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5971 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5975 case FFECOM_f2ccodeCHAR:
5976 *type = make_signed_type (CHAR_TYPE_SIZE);
5979 case FFECOM_f2ccodeSHORT:
5980 *type = make_signed_type (SHORT_TYPE_SIZE);
5983 case FFECOM_f2ccodeINT:
5984 *type = make_signed_type (INT_TYPE_SIZE);
5987 case FFECOM_f2ccodeLONG:
5988 *type = make_signed_type (LONG_TYPE_SIZE);
5991 case FFECOM_f2ccodeLONGLONG:
5992 *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5995 case FFECOM_f2ccodeCHARPTR:
5996 *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5997 ? signed_char_type_node
5998 : unsigned_char_type_node);
6001 case FFECOM_f2ccodeFLOAT:
6002 *type = make_node (REAL_TYPE);
6003 TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
6004 layout_type (*type);
6007 case FFECOM_f2ccodeDOUBLE:
6008 *type = make_node (REAL_TYPE);
6009 TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
6010 layout_type (*type);
6013 case FFECOM_f2ccodeLONGDOUBLE:
6014 *type = make_node (REAL_TYPE);
6015 TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
6016 layout_type (*type);
6019 case FFECOM_f2ccodeTWOREALS:
6020 *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
6023 case FFECOM_f2ccodeTWODOUBLEREALS:
6024 *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
6028 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
6029 *type = error_mark_node;
6033 pushdecl (build_decl (TYPE_DECL,
6034 ffecom_get_invented_identifier ("__g77_f2c_%s", name),
6039 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6040 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6044 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
6050 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
6051 if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
6052 && compare_tree_int (TYPE_SIZE (t), size) == 0)
6054 assert (code != -1);
6055 ffecom_f2c_typecode_[bt][j] = code;
6061 /* Finish up globals after doing all program units in file
6063 Need to handle only uninitialized COMMON areas. */
6065 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6067 ffecom_finish_global_ (ffeglobal global)
6073 if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
6076 if (ffeglobal_common_init (global))
6079 cbt = ffeglobal_hook (global);
6080 if ((cbt == NULL_TREE)
6081 || !ffeglobal_common_have_size (global))
6082 return global; /* No need to make common, never ref'd. */
6084 DECL_EXTERNAL (cbt) = 0;
6086 /* Give the array a size now. */
6088 size = build_int_2 ((ffeglobal_common_size (global)
6089 + ffeglobal_common_pad (global)) - 1,
6092 cbtype = TREE_TYPE (cbt);
6093 TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6096 if (!TREE_TYPE (size))
6097 TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6098 layout_type (cbtype);
6100 cbt = start_decl (cbt, FALSE);
6101 assert (cbt == ffeglobal_hook (global));
6103 finish_decl (cbt, NULL_TREE, FALSE);
6109 /* Finish up any untransformed symbols. */
6111 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6113 ffecom_finish_symbol_transform_ (ffesymbol s)
6115 if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6118 /* It's easy to know to transform an untransformed symbol, to make sure
6119 we put out debugging info for it. But COMMON variables, unlike
6120 EQUIVALENCE ones, aren't given declarations in addition to the
6121 tree expressions that specify offsets, because COMMON variables
6122 can be referenced in the outer scope where only dummy arguments
6123 (PARM_DECLs) should really be seen. To be safe, just don't do any
6124 VAR_DECLs for COMMON variables when we transform them for real
6125 use, and therefore we do all the VAR_DECL creating here. */
6127 if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6129 if (ffesymbol_kind (s) != FFEINFO_kindNONE
6130 || (ffesymbol_where (s) != FFEINFO_whereNONE
6131 && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6132 && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6133 /* Not transformed, and not CHARACTER*(*), and not a dummy
6134 argument, which can happen only if the entry point names
6135 it "rides in on" are all invalidated for other reasons. */
6136 s = ffecom_sym_transform_ (s);
6139 if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6140 && (ffesymbol_hook (s).decl_tree != error_mark_node))
6142 /* This isn't working, at least for dbxout. The .s file looks
6143 okay to me (burley), but in gdb 4.9 at least, the variables
6144 appear to reside somewhere outside of the common area, so
6145 it doesn't make sense to mislead anyone by generating the info
6146 on those variables until this is fixed. NOTE: Same problem
6147 with EQUIVALENCE, sadly...see similar #if later. */
6148 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6149 ffesymbol_storage (s));
6156 /* Append underscore(s) to name before calling get_identifier. "us"
6157 is nonzero if the name already contains an underscore and thus
6158 needs two underscores appended. */
6160 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6162 ffecom_get_appended_identifier_ (char us, const char *name)
6168 newname = xmalloc ((i = strlen (name)) + 1
6169 + ffe_is_underscoring ()
6171 memcpy (newname, name, i);
6173 newname[i + us] = '_';
6174 newname[i + 1 + us] = '\0';
6175 id = get_identifier (newname);
6183 /* Decide whether to append underscore to name before calling
6186 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6188 ffecom_get_external_identifier_ (ffesymbol s)
6191 const char *name = ffesymbol_text (s);
6193 /* If name is a built-in name, just return it as is. */
6195 if (!ffe_is_underscoring ()
6196 || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6197 #if FFETARGET_isENFORCED_MAIN_NAME
6198 || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6200 || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6202 || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6203 return get_identifier (name);
6205 us = ffe_is_second_underscore ()
6206 ? (strchr (name, '_') != NULL)
6209 return ffecom_get_appended_identifier_ (us, name);
6213 /* Decide whether to append underscore to internal name before calling
6216 This is for non-external, top-function-context names only. Transform
6217 identifier so it doesn't conflict with the transformed result
6218 of using a _different_ external name. E.g. if "CALL FOO" is
6219 transformed into "FOO_();", then the variable in "FOO_ = 3"
6220 must be transformed into something that does not conflict, since
6221 these two things should be independent.
6223 The transformation is as follows. If the name does not contain
6224 an underscore, there is no possible conflict, so just return.
6225 If the name does contain an underscore, then transform it just
6226 like we transform an external identifier. */
6228 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6230 ffecom_get_identifier_ (const char *name)
6232 /* If name does not contain an underscore, just return it as is. */
6234 if (!ffe_is_underscoring ()
6235 || (strchr (name, '_') == NULL))
6236 return get_identifier (name);
6238 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6243 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6246 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6247 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6248 ffesymbol_kindtype(s));
6250 Call after setting up containing function and getting trees for all
6253 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6255 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6257 ffebld expr = ffesymbol_sfexpr (s);
6261 bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6262 static bool recurse = FALSE;
6263 int old_lineno = lineno;
6264 const char *old_input_filename = input_filename;
6266 ffecom_nested_entry_ = s;
6268 /* For now, we don't have a handy pointer to where the sfunc is actually
6269 defined, though that should be easy to add to an ffesymbol. (The
6270 token/where info available might well point to the place where the type
6271 of the sfunc is declared, especially if that precedes the place where
6272 the sfunc itself is defined, which is typically the case.) We should
6273 put out a null pointer rather than point somewhere wrong, but I want to
6274 see how it works at this point. */
6276 input_filename = ffesymbol_where_filename (s);
6277 lineno = ffesymbol_where_filelinenum (s);
6279 /* Pretransform the expression so any newly discovered things belong to the
6280 outer program unit, not to the statement function. */
6282 ffecom_expr_transform_ (expr);
6284 /* Make sure no recursive invocation of this fn (a specific case of failing
6285 to pretransform an sfunc's expression, i.e. where its expression
6286 references another untransformed sfunc) happens. */
6291 push_f_function_context ();
6294 type = void_type_node;
6297 type = ffecom_tree_type[bt][kt];
6298 if (type == NULL_TREE)
6299 type = integer_type_node; /* _sym_exec_transition reports
6303 start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6304 build_function_type (type, NULL_TREE),
6305 1, /* nested/inline */
6306 0); /* TREE_PUBLIC */
6308 /* We don't worry about COMPLEX return values here, because this is
6309 entirely internal to our code, and gcc has the ability to return COMPLEX
6310 directly as a value. */
6313 { /* Prepend arg for where result goes. */
6316 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6318 result = ffecom_get_invented_identifier ("__g77_%s", "result");
6320 ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */
6322 type = build_pointer_type (type);
6323 result = build_decl (PARM_DECL, result, type);
6325 push_parm_decl (result);
6328 result = NULL_TREE; /* Not ref'd if !charfunc. */
6330 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6332 store_parm_decls (0);
6334 ffecom_start_compstmt ();
6340 ffetargetCharacterSize sz = ffesymbol_size (s);
6343 result_length = build_int_2 (sz, 0);
6344 TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6346 ffecom_prepare_let_char_ (sz, expr);
6348 ffecom_prepare_end ();
6350 ffecom_let_char_ (result, result_length, sz, expr);
6351 expand_null_return ();
6355 ffecom_prepare_expr (expr);
6357 ffecom_prepare_end ();
6359 expand_return (ffecom_modify (NULL_TREE,
6360 DECL_RESULT (current_function_decl),
6361 ffecom_expr (expr)));
6365 ffecom_end_compstmt ();
6367 func = current_function_decl;
6368 finish_function (1);
6370 pop_f_function_context ();
6374 lineno = old_lineno;
6375 input_filename = old_input_filename;
6377 ffecom_nested_entry_ = NULL;
6384 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6386 ffecom_gfrt_args_ (ffecomGfrt ix)
6388 return ffecom_gfrt_argstring_[ix];
6392 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6394 ffecom_gfrt_tree_ (ffecomGfrt ix)
6396 if (ffecom_gfrt_[ix] == NULL_TREE)
6397 ffecom_make_gfrt_ (ix);
6399 return ffecom_1 (ADDR_EXPR,
6400 build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6405 /* Return initialize-to-zero expression for this VAR_DECL. */
6407 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6408 /* A somewhat evil way to prevent the garbage collector
6409 from collecting 'tree' structures. */
6410 #define NUM_TRACKED_CHUNK 63
6411 static struct tree_ggc_tracker
6413 struct tree_ggc_tracker *next;
6414 tree trees[NUM_TRACKED_CHUNK];
6415 } *tracker_head = NULL;
6418 mark_tracker_head (void *arg)
6420 struct tree_ggc_tracker *head;
6423 for (head = * (struct tree_ggc_tracker **) arg;
6428 for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6429 ggc_mark_tree (head->trees[i]);
6434 ffecom_save_tree_forever (tree t)
6437 if (tracker_head != NULL)
6438 for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6439 if (tracker_head->trees[i] == NULL)
6441 tracker_head->trees[i] = t;
6446 /* Need to allocate a new block. */
6447 struct tree_ggc_tracker *old_head = tracker_head;
6449 tracker_head = ggc_alloc (sizeof (*tracker_head));
6450 tracker_head->next = old_head;
6451 tracker_head->trees[0] = t;
6452 for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6453 tracker_head->trees[i] = NULL;
6458 ffecom_init_zero_ (tree decl)
6461 int incremental = TREE_STATIC (decl);
6462 tree type = TREE_TYPE (decl);
6466 make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
6467 assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6470 if ((TREE_CODE (type) != ARRAY_TYPE)
6471 && (TREE_CODE (type) != RECORD_TYPE)
6472 && (TREE_CODE (type) != UNION_TYPE)
6474 init = convert (type, integer_zero_node);
6475 else if (!incremental)
6477 init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6478 TREE_CONSTANT (init) = 1;
6479 TREE_STATIC (init) = 1;
6483 assemble_zeros (int_size_in_bytes (type));
6484 init = error_mark_node;
6491 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6493 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6499 switch (ffebld_op (arg))
6501 case FFEBLD_opCONTER: /* For F90, check 0-length. */
6502 if (ffetarget_length_character1
6503 (ffebld_constant_character1
6504 (ffebld_conter (arg))) == 0)
6506 *maybe_tree = integer_zero_node;
6507 return convert (tree_type, integer_zero_node);
6510 *maybe_tree = integer_one_node;
6511 expr_tree = build_int_2 (*ffetarget_text_character1
6512 (ffebld_constant_character1
6513 (ffebld_conter (arg))),
6515 TREE_TYPE (expr_tree) = tree_type;
6518 case FFEBLD_opSYMTER:
6519 case FFEBLD_opARRAYREF:
6520 case FFEBLD_opFUNCREF:
6521 case FFEBLD_opSUBSTR:
6522 ffecom_char_args_ (&expr_tree, &length_tree, arg);
6524 if ((expr_tree == error_mark_node)
6525 || (length_tree == error_mark_node))
6527 *maybe_tree = error_mark_node;
6528 return error_mark_node;
6531 if (integer_zerop (length_tree))
6533 *maybe_tree = integer_zero_node;
6534 return convert (tree_type, integer_zero_node);
6538 = ffecom_1 (INDIRECT_REF,
6539 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6542 = ffecom_2 (ARRAY_REF,
6543 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6546 expr_tree = convert (tree_type, expr_tree);
6548 if (TREE_CODE (length_tree) == INTEGER_CST)
6549 *maybe_tree = integer_one_node;
6550 else /* Must check length at run time. */
6552 = ffecom_truth_value
6553 (ffecom_2 (GT_EXPR, integer_type_node,
6555 ffecom_f2c_ftnlen_zero_node));
6558 case FFEBLD_opPAREN:
6559 case FFEBLD_opCONVERT:
6560 if (ffeinfo_size (ffebld_info (arg)) == 0)
6562 *maybe_tree = integer_zero_node;
6563 return convert (tree_type, integer_zero_node);
6565 return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6568 case FFEBLD_opCONCATENATE:
6575 expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6577 expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6579 *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6582 expr_tree = ffecom_3 (COND_EXPR, tree_type,
6590 assert ("bad op in ICHAR" == NULL);
6591 return error_mark_node;
6596 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6600 length_arg = ffecom_intrinsic_len_ (expr);
6602 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6603 subexpressions by constructing the appropriate tree for the
6604 length-of-character-text argument in a calling sequence. */
6606 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6608 ffecom_intrinsic_len_ (ffebld expr)
6610 ffetargetCharacter1 val;
6613 switch (ffebld_op (expr))
6615 case FFEBLD_opCONTER:
6616 val = ffebld_constant_character1 (ffebld_conter (expr));
6617 length = build_int_2 (ffetarget_length_character1 (val), 0);
6618 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6621 case FFEBLD_opSYMTER:
6623 ffesymbol s = ffebld_symter (expr);
6626 item = ffesymbol_hook (s).decl_tree;
6627 if (item == NULL_TREE)
6629 s = ffecom_sym_transform_ (s);
6630 item = ffesymbol_hook (s).decl_tree;
6632 if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6634 if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6635 length = ffesymbol_hook (s).length_tree;
6638 length = build_int_2 (ffesymbol_size (s), 0);
6639 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6642 else if (item == error_mark_node)
6643 length = error_mark_node;
6644 else /* FFEINFO_kindFUNCTION: */
6649 case FFEBLD_opARRAYREF:
6650 length = ffecom_intrinsic_len_ (ffebld_left (expr));
6653 case FFEBLD_opSUBSTR:
6657 ffebld thing = ffebld_right (expr);
6661 assert (ffebld_op (thing) == FFEBLD_opITEM);
6662 start = ffebld_head (thing);
6663 thing = ffebld_trail (thing);
6664 assert (ffebld_trail (thing) == NULL);
6665 end = ffebld_head (thing);
6667 length = ffecom_intrinsic_len_ (ffebld_left (expr));
6669 if (length == error_mark_node)
6678 length = convert (ffecom_f2c_ftnlen_type_node,
6684 start_tree = convert (ffecom_f2c_ftnlen_type_node,
6685 ffecom_expr (start));
6687 if (start_tree == error_mark_node)
6689 length = error_mark_node;
6695 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6696 ffecom_f2c_ftnlen_one_node,
6697 ffecom_2 (MINUS_EXPR,
6698 ffecom_f2c_ftnlen_type_node,
6704 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6707 if (end_tree == error_mark_node)
6709 length = error_mark_node;
6713 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6714 ffecom_f2c_ftnlen_one_node,
6715 ffecom_2 (MINUS_EXPR,
6716 ffecom_f2c_ftnlen_type_node,
6717 end_tree, start_tree));
6723 case FFEBLD_opCONCATENATE:
6725 = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6726 ffecom_intrinsic_len_ (ffebld_left (expr)),
6727 ffecom_intrinsic_len_ (ffebld_right (expr)));
6730 case FFEBLD_opFUNCREF:
6731 case FFEBLD_opCONVERT:
6732 length = build_int_2 (ffebld_size (expr), 0);
6733 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6737 assert ("bad op for single char arg expr" == NULL);
6738 length = ffecom_f2c_ftnlen_zero_node;
6742 assert (length != NULL_TREE);
6748 /* Handle CHARACTER assignments.
6750 Generates code to do the assignment. Used by ordinary assignment
6751 statement handler ffecom_let_stmt and by statement-function
6752 handler to generate code for a statement function. */
6754 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6756 ffecom_let_char_ (tree dest_tree, tree dest_length,
6757 ffetargetCharacterSize dest_size, ffebld source)
6759 ffecomConcatList_ catlist;
6764 if ((dest_tree == error_mark_node)
6765 || (dest_length == error_mark_node))
6768 assert (dest_tree != NULL_TREE);
6769 assert (dest_length != NULL_TREE);
6771 /* Source might be an opCONVERT, which just means it is a different size
6772 than the destination. Since the underlying implementation here handles
6773 that (directly or via the s_copy or s_cat run-time-library functions),
6774 we don't need the "convenience" of an opCONVERT that tells us to
6775 truncate or blank-pad, particularly since the resulting implementation
6776 would probably be slower than otherwise. */
6778 while (ffebld_op (source) == FFEBLD_opCONVERT)
6779 source = ffebld_left (source);
6781 catlist = ffecom_concat_list_new_ (source, dest_size);
6782 switch (ffecom_concat_list_count_ (catlist))
6784 case 0: /* Shouldn't happen, but in case it does... */
6785 ffecom_concat_list_kill_ (catlist);
6786 source_tree = null_pointer_node;
6787 source_length = ffecom_f2c_ftnlen_zero_node;
6788 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6789 TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6790 TREE_CHAIN (TREE_CHAIN (expr_tree))
6791 = build_tree_list (NULL_TREE, dest_length);
6792 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6793 = build_tree_list (NULL_TREE, source_length);
6795 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6796 TREE_SIDE_EFFECTS (expr_tree) = 1;
6798 expand_expr_stmt (expr_tree);
6802 case 1: /* The (fairly) easy case. */
6803 ffecom_char_args_ (&source_tree, &source_length,
6804 ffecom_concat_list_expr_ (catlist, 0));
6805 ffecom_concat_list_kill_ (catlist);
6806 assert (source_tree != NULL_TREE);
6807 assert (source_length != NULL_TREE);
6809 if ((source_tree == error_mark_node)
6810 || (source_length == error_mark_node))
6816 = ffecom_1 (INDIRECT_REF,
6817 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6821 = ffecom_2 (ARRAY_REF,
6822 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6827 = ffecom_1 (INDIRECT_REF,
6828 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6832 = ffecom_2 (ARRAY_REF,
6833 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6838 expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6840 expand_expr_stmt (expr_tree);
6845 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6846 TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6847 TREE_CHAIN (TREE_CHAIN (expr_tree))
6848 = build_tree_list (NULL_TREE, dest_length);
6849 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6850 = build_tree_list (NULL_TREE, source_length);
6852 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6853 TREE_SIDE_EFFECTS (expr_tree) = 1;
6855 expand_expr_stmt (expr_tree);
6859 default: /* Must actually concatenate things. */
6863 /* Heavy-duty concatenation. */
6866 int count = ffecom_concat_list_count_ (catlist);
6878 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6879 FFETARGET_charactersizeNONE, count, TRUE);
6880 item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6881 FFETARGET_charactersizeNONE,
6887 hook = ffebld_nonter_hook (source);
6889 assert (TREE_CODE (hook) == TREE_VEC);
6890 assert (TREE_VEC_LENGTH (hook) == 2);
6891 length_array = lengths = TREE_VEC_ELT (hook, 0);
6892 item_array = items = TREE_VEC_ELT (hook, 1);
6896 for (i = 0; i < count; ++i)
6898 ffecom_char_args_ (&citem, &clength,
6899 ffecom_concat_list_expr_ (catlist, i));
6900 if ((citem == error_mark_node)
6901 || (clength == error_mark_node))
6903 ffecom_concat_list_kill_ (catlist);
6908 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6909 ffecom_modify (void_type_node,
6910 ffecom_2 (ARRAY_REF,
6911 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6913 build_int_2 (i, 0)),
6917 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6918 ffecom_modify (void_type_node,
6919 ffecom_2 (ARRAY_REF,
6920 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6922 build_int_2 (i, 0)),
6927 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6928 TREE_CHAIN (expr_tree)
6929 = build_tree_list (NULL_TREE,
6930 ffecom_1 (ADDR_EXPR,
6931 build_pointer_type (TREE_TYPE (items)),
6933 TREE_CHAIN (TREE_CHAIN (expr_tree))
6934 = build_tree_list (NULL_TREE,
6935 ffecom_1 (ADDR_EXPR,
6936 build_pointer_type (TREE_TYPE (lengths)),
6938 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6941 ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6942 convert (ffecom_f2c_ftnlen_type_node,
6943 build_int_2 (count, 0))));
6944 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6945 = build_tree_list (NULL_TREE, dest_length);
6947 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6948 TREE_SIDE_EFFECTS (expr_tree) = 1;
6950 expand_expr_stmt (expr_tree);
6953 ffecom_concat_list_kill_ (catlist);
6957 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6960 ffecom_make_gfrt_(ix);
6962 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6963 for the indicated run-time routine (ix). */
6965 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6967 ffecom_make_gfrt_ (ffecomGfrt ix)
6972 switch (ffecom_gfrt_type_[ix])
6974 case FFECOM_rttypeVOID_:
6975 ttype = void_type_node;
6978 case FFECOM_rttypeVOIDSTAR_:
6979 ttype = TREE_TYPE (null_pointer_node); /* `void *'. */
6982 case FFECOM_rttypeFTNINT_:
6983 ttype = ffecom_f2c_ftnint_type_node;
6986 case FFECOM_rttypeINTEGER_:
6987 ttype = ffecom_f2c_integer_type_node;
6990 case FFECOM_rttypeLONGINT_:
6991 ttype = ffecom_f2c_longint_type_node;
6994 case FFECOM_rttypeLOGICAL_:
6995 ttype = ffecom_f2c_logical_type_node;
6998 case FFECOM_rttypeREAL_F2C_:
6999 ttype = double_type_node;
7002 case FFECOM_rttypeREAL_GNU_:
7003 ttype = float_type_node;
7006 case FFECOM_rttypeCOMPLEX_F2C_:
7007 ttype = void_type_node;
7010 case FFECOM_rttypeCOMPLEX_GNU_:
7011 ttype = ffecom_f2c_complex_type_node;
7014 case FFECOM_rttypeDOUBLE_:
7015 ttype = double_type_node;
7018 case FFECOM_rttypeDOUBLEREAL_:
7019 ttype = ffecom_f2c_doublereal_type_node;
7022 case FFECOM_rttypeDBLCMPLX_F2C_:
7023 ttype = void_type_node;
7026 case FFECOM_rttypeDBLCMPLX_GNU_:
7027 ttype = ffecom_f2c_doublecomplex_type_node;
7030 case FFECOM_rttypeCHARACTER_:
7031 ttype = void_type_node;
7036 assert ("bad rttype" == NULL);
7040 ttype = build_function_type (ttype, NULL_TREE);
7041 t = build_decl (FUNCTION_DECL,
7042 get_identifier (ffecom_gfrt_name_[ix]),
7044 DECL_EXTERNAL (t) = 1;
7045 TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
7046 TREE_PUBLIC (t) = 1;
7047 TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
7049 /* Sanity check: A function that's const cannot be volatile. */
7051 assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
7053 /* Sanity check: A function that's const cannot return complex. */
7055 assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
7057 t = start_decl (t, TRUE);
7059 finish_decl (t, NULL_TREE, TRUE);
7061 ffecom_gfrt_[ix] = t;
7065 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
7067 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7069 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
7071 ffesymbol s = ffestorag_symbol (st);
7073 if (ffesymbol_namelisted (s))
7074 ffecom_member_namelisted_ = TRUE;
7078 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
7079 the member so debugger will see it. Otherwise nobody should be
7080 referencing the member. */
7082 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7084 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7092 || ((mt = ffestorag_hook (mst)) == NULL)
7093 || (mt == error_mark_node))
7097 || ((s = ffestorag_symbol (st)) == NULL))
7100 type = ffecom_type_localvar_ (s,
7101 ffesymbol_basictype (s),
7102 ffesymbol_kindtype (s));
7103 if (type == error_mark_node)
7106 t = build_decl (VAR_DECL,
7107 ffecom_get_identifier_ (ffesymbol_text (s)),
7110 TREE_STATIC (t) = TREE_STATIC (mt);
7111 DECL_INITIAL (t) = NULL_TREE;
7112 TREE_ASM_WRITTEN (t) = 1;
7116 = gen_rtx (MEM, TYPE_MODE (type),
7117 plus_constant (XEXP (DECL_RTL (mt), 0),
7118 ffestorag_modulo (mst)
7119 + ffestorag_offset (st)
7120 - ffestorag_offset (mst)));
7122 t = start_decl (t, FALSE);
7124 finish_decl (t, NULL_TREE, FALSE);
7128 /* Prepare source expression for assignment into a destination perhaps known
7129 to be of a specific size. */
7132 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7134 ffecomConcatList_ catlist;
7139 tree tempvar = NULL_TREE;
7141 while (ffebld_op (source) == FFEBLD_opCONVERT)
7142 source = ffebld_left (source);
7144 catlist = ffecom_concat_list_new_ (source, dest_size);
7145 count = ffecom_concat_list_count_ (catlist);
7150 = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7151 FFETARGET_charactersizeNONE, count);
7153 = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7154 FFETARGET_charactersizeNONE, count);
7156 tempvar = make_tree_vec (2);
7157 TREE_VEC_ELT (tempvar, 0) = ltmp;
7158 TREE_VEC_ELT (tempvar, 1) = itmp;
7161 for (i = 0; i < count; ++i)
7162 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7164 ffecom_concat_list_kill_ (catlist);
7168 ffebld_nonter_set_hook (source, tempvar);
7169 current_binding_level->prep_state = 1;
7173 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7175 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7176 (which generates their trees) and then their trees get push_parm_decl'd.
7178 The second arg is TRUE if the dummies are for a statement function, in
7179 which case lengths are not pushed for character arguments (since they are
7180 always known by both the caller and the callee, though the code allows
7181 for someday permitting CHAR*(*) stmtfunc dummies). */
7183 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7185 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7192 ffecom_transform_only_dummies_ = TRUE;
7194 /* First push the parms corresponding to actual dummy "contents". */
7196 for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7198 dummy = ffebld_head (dumlist);
7199 switch (ffebld_op (dummy))
7203 continue; /* Forget alternate returns. */
7208 assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7209 s = ffebld_symter (dummy);
7210 parm = ffesymbol_hook (s).decl_tree;
7211 if (parm == NULL_TREE)
7213 s = ffecom_sym_transform_ (s);
7214 parm = ffesymbol_hook (s).decl_tree;
7215 assert (parm != NULL_TREE);
7217 if (parm != error_mark_node)
7218 push_parm_decl (parm);
7221 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7223 for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7225 dummy = ffebld_head (dumlist);
7226 switch (ffebld_op (dummy))
7230 continue; /* Forget alternate returns, they mean
7236 s = ffebld_symter (dummy);
7237 if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7238 continue; /* Only looking for CHARACTER arguments. */
7239 if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7240 continue; /* Stmtfunc arg with known size needs no
7242 if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7243 continue; /* Only looking for variables and arrays. */
7244 parm = ffesymbol_hook (s).length_tree;
7245 assert (parm != NULL_TREE);
7246 if (parm != error_mark_node)
7247 push_parm_decl (parm);
7250 ffecom_transform_only_dummies_ = FALSE;
7254 /* ffecom_start_progunit_ -- Beginning of program unit
7256 Does GNU back end stuff necessary to teach it about the start of its
7257 equivalent of a Fortran program unit. */
7259 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7261 ffecom_start_progunit_ ()
7263 ffesymbol fn = ffecom_primary_entry_;
7265 tree id; /* Identifier (name) of function. */
7266 tree type; /* Type of function. */
7267 tree result; /* Result of function. */
7268 ffeinfoBasictype bt;
7272 ffeglobalType egt = FFEGLOBAL_type;
7275 bool altentries = (ffecom_num_entrypoints_ != 0);
7278 && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7279 && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7280 bool main_program = FALSE;
7281 int old_lineno = lineno;
7282 const char *old_input_filename = input_filename;
7284 assert (fn != NULL);
7285 assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7287 input_filename = ffesymbol_where_filename (fn);
7288 lineno = ffesymbol_where_filelinenum (fn);
7290 switch (ffecom_primary_entry_kind_)
7292 case FFEINFO_kindPROGRAM:
7293 main_program = TRUE;
7294 gt = FFEGLOBAL_typeMAIN;
7295 bt = FFEINFO_basictypeNONE;
7296 kt = FFEINFO_kindtypeNONE;
7297 type = ffecom_tree_fun_type_void;
7302 case FFEINFO_kindBLOCKDATA:
7303 gt = FFEGLOBAL_typeBDATA;
7304 bt = FFEINFO_basictypeNONE;
7305 kt = FFEINFO_kindtypeNONE;
7306 type = ffecom_tree_fun_type_void;
7311 case FFEINFO_kindFUNCTION:
7312 gt = FFEGLOBAL_typeFUNC;
7313 egt = FFEGLOBAL_typeEXT;
7314 bt = ffesymbol_basictype (fn);
7315 kt = ffesymbol_kindtype (fn);
7316 if (bt == FFEINFO_basictypeNONE)
7318 ffeimplic_establish_symbol (fn);
7319 if (ffesymbol_funcresult (fn) != NULL)
7320 ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7321 bt = ffesymbol_basictype (fn);
7322 kt = ffesymbol_kindtype (fn);
7326 charfunc = cmplxfunc = FALSE;
7327 else if (bt == FFEINFO_basictypeCHARACTER)
7328 charfunc = TRUE, cmplxfunc = FALSE;
7329 else if ((bt == FFEINFO_basictypeCOMPLEX)
7330 && ffesymbol_is_f2c (fn)
7332 charfunc = FALSE, cmplxfunc = TRUE;
7334 charfunc = cmplxfunc = FALSE;
7336 if (multi || charfunc)
7337 type = ffecom_tree_fun_type_void;
7338 else if (ffesymbol_is_f2c (fn) && !altentries)
7339 type = ffecom_tree_fun_type[bt][kt];
7341 type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7343 if ((type == NULL_TREE)
7344 || (TREE_TYPE (type) == NULL_TREE))
7345 type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
7348 case FFEINFO_kindSUBROUTINE:
7349 gt = FFEGLOBAL_typeSUBR;
7350 egt = FFEGLOBAL_typeEXT;
7351 bt = FFEINFO_basictypeNONE;
7352 kt = FFEINFO_kindtypeNONE;
7353 if (ffecom_is_altreturning_)
7354 type = ffecom_tree_subr_type;
7356 type = ffecom_tree_fun_type_void;
7362 assert ("say what??" == NULL);
7364 case FFEINFO_kindANY:
7365 gt = FFEGLOBAL_typeANY;
7366 bt = FFEINFO_basictypeNONE;
7367 kt = FFEINFO_kindtypeNONE;
7368 type = error_mark_node;
7376 id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7377 ffesymbol_text (fn));
7379 #if FFETARGET_isENFORCED_MAIN
7380 else if (main_program)
7381 id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7384 id = ffecom_get_external_identifier_ (fn);
7388 0, /* nested/inline */
7389 !altentries); /* TREE_PUBLIC */
7391 TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */
7394 && ((g = ffesymbol_global (fn)) != NULL)
7395 && ((ffeglobal_type (g) == gt)
7396 || (ffeglobal_type (g) == egt)))
7398 ffeglobal_set_hook (g, current_function_decl);
7401 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7402 exec-transitioning needs current_function_decl to be filled in. So we
7403 do these things in two phases. */
7406 { /* 1st arg identifies which entrypoint. */
7407 ffecom_which_entrypoint_decl_
7408 = build_decl (PARM_DECL,
7409 ffecom_get_invented_identifier ("__g77_%s",
7410 "which_entrypoint"),
7412 push_parm_decl (ffecom_which_entrypoint_decl_);
7418 { /* Arg for result (return value). */
7423 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7425 type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7427 type = ffecom_multi_type_node_;
7429 result = ffecom_get_invented_identifier ("__g77_%s", "result");
7431 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7434 length = ffecom_char_enhance_arg_ (&type, fn);
7436 length = NULL_TREE; /* Not ref'd if !charfunc. */
7438 type = build_pointer_type (type);
7439 result = build_decl (PARM_DECL, result, type);
7441 push_parm_decl (result);
7443 ffecom_multi_retval_ = result;
7445 ffecom_func_result_ = result;
7449 push_parm_decl (length);
7450 ffecom_func_length_ = length;
7454 if (ffecom_primary_entry_is_proc_)
7457 arglist = ffecom_master_arglist_;
7459 arglist = ffesymbol_dummyargs (fn);
7460 ffecom_push_dummy_decls_ (arglist, FALSE);
7463 if (TREE_CODE (current_function_decl) != ERROR_MARK)
7464 store_parm_decls (main_program ? 1 : 0);
7466 ffecom_start_compstmt ();
7467 /* Disallow temp vars at this level. */
7468 current_binding_level->prep_state = 2;
7470 lineno = old_lineno;
7471 input_filename = old_input_filename;
7473 /* This handles any symbols still untransformed, in case -g specified.
7474 This used to be done in ffecom_finish_progunit, but it turns out to
7475 be necessary to do it here so that statement functions are
7476 expanded before code. But don't bother for BLOCK DATA. */
7478 if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7479 ffesymbol_drive (ffecom_finish_symbol_transform_);
7483 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7486 ffecom_sym_transform_(s);
7488 The ffesymbol_hook info for s is updated with appropriate backend info
7491 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7493 ffecom_sym_transform_ (ffesymbol s)
7495 tree t; /* Transformed thingy. */
7496 tree tlen; /* Length if CHAR*(*). */
7497 bool addr; /* Is t the address of the thingy? */
7498 ffeinfoBasictype bt;
7501 int old_lineno = lineno;
7502 const char *old_input_filename = input_filename;
7504 /* Must ensure special ASSIGN variables are declared at top of outermost
7505 block, else they'll end up in the innermost block when their first
7506 ASSIGN is seen, which leaves them out of scope when they're the
7507 subject of a GOTO or I/O statement.
7509 We make this variable even if -fugly-assign. Just let it go unused,
7510 in case it turns out there are cases where we really want to use this
7511 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7513 if (! ffecom_transform_only_dummies_
7514 && ffesymbol_assigned (s)
7515 && ! ffesymbol_hook (s).assign_tree)
7516 s = ffecom_sym_transform_assign_ (s);
7518 if (ffesymbol_sfdummyparent (s) == NULL)
7520 input_filename = ffesymbol_where_filename (s);
7521 lineno = ffesymbol_where_filelinenum (s);
7525 ffesymbol sf = ffesymbol_sfdummyparent (s);
7527 input_filename = ffesymbol_where_filename (sf);
7528 lineno = ffesymbol_where_filelinenum (sf);
7531 bt = ffeinfo_basictype (ffebld_info (s));
7532 kt = ffeinfo_kindtype (ffebld_info (s));
7538 switch (ffesymbol_kind (s))
7540 case FFEINFO_kindNONE:
7541 switch (ffesymbol_where (s))
7543 case FFEINFO_whereDUMMY: /* Subroutine or function. */
7544 assert (ffecom_transform_only_dummies_);
7546 /* Before 0.4, this could be ENTITY/DUMMY, but see
7547 ffestu_sym_end_transition -- no longer true (in particular, if
7548 it could be an ENTITY, it _will_ be made one, so that
7549 possibility won't come through here). So we never make length
7550 arg for CHARACTER type. */
7552 t = build_decl (PARM_DECL,
7553 ffecom_get_identifier_ (ffesymbol_text (s)),
7554 ffecom_tree_ptr_to_subr_type);
7556 DECL_ARTIFICIAL (t) = 1;
7561 case FFEINFO_whereGLOBAL: /* Subroutine or function. */
7562 assert (!ffecom_transform_only_dummies_);
7564 if (((g = ffesymbol_global (s)) != NULL)
7565 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7566 || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7567 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7568 && (ffeglobal_hook (g) != NULL_TREE)
7569 && ffe_is_globals ())
7571 t = ffeglobal_hook (g);
7575 t = build_decl (FUNCTION_DECL,
7576 ffecom_get_external_identifier_ (s),
7577 ffecom_tree_subr_type); /* Assume subr. */
7578 DECL_EXTERNAL (t) = 1;
7579 TREE_PUBLIC (t) = 1;
7581 t = start_decl (t, FALSE);
7582 finish_decl (t, NULL_TREE, FALSE);
7585 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7586 || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7587 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7588 ffeglobal_set_hook (g, t);
7590 ffecom_save_tree_forever (t);
7595 assert ("NONE where unexpected" == NULL);
7597 case FFEINFO_whereANY:
7602 case FFEINFO_kindENTITY:
7603 switch (ffeinfo_where (ffesymbol_info (s)))
7606 case FFEINFO_whereCONSTANT:
7607 /* ~~Debugging info needed? */
7608 assert (!ffecom_transform_only_dummies_);
7609 t = error_mark_node; /* Shouldn't ever see this in expr. */
7612 case FFEINFO_whereLOCAL:
7613 assert (!ffecom_transform_only_dummies_);
7616 ffestorag st = ffesymbol_storage (s);
7620 && (ffestorag_size (st) == 0))
7622 t = error_mark_node;
7626 type = ffecom_type_localvar_ (s, bt, kt);
7628 if (type == error_mark_node)
7630 t = error_mark_node;
7635 && (ffestorag_parent (st) != NULL))
7636 { /* Child of EQUIVALENCE parent. */
7639 ffetargetOffset offset;
7641 est = ffestorag_parent (st);
7642 ffecom_transform_equiv_ (est);
7644 et = ffestorag_hook (est);
7645 assert (et != NULL_TREE);
7647 if (! TREE_STATIC (et))
7648 put_var_into_stack (et);
7650 offset = ffestorag_modulo (est)
7651 + ffestorag_offset (ffesymbol_storage (s))
7652 - ffestorag_offset (est);
7654 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7656 /* (t_type *) (((char *) &et) + offset) */
7658 t = convert (string_type_node, /* (char *) */
7659 ffecom_1 (ADDR_EXPR,
7660 build_pointer_type (TREE_TYPE (et)),
7662 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7664 build_int_2 (offset, 0));
7665 t = convert (build_pointer_type (type),
7667 TREE_CONSTANT (t) = staticp (et);
7674 bool init = ffesymbol_is_init (s);
7676 t = build_decl (VAR_DECL,
7677 ffecom_get_identifier_ (ffesymbol_text (s)),
7681 || ffesymbol_namelisted (s)
7682 #ifdef FFECOM_sizeMAXSTACKITEM
7684 && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7686 || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7687 && (ffecom_primary_entry_kind_
7688 != FFEINFO_kindBLOCKDATA)
7689 && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7690 TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7692 TREE_STATIC (t) = 0; /* No need to make static. */
7694 if (init || ffe_is_init_local_zero ())
7695 DECL_INITIAL (t) = error_mark_node;
7697 /* Keep -Wunused from complaining about var if it
7698 is used as sfunc arg or DATA implied-DO. */
7699 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7700 DECL_IN_SYSTEM_HEADER (t) = 1;
7702 t = start_decl (t, FALSE);
7706 if (ffesymbol_init (s) != NULL)
7707 initexpr = ffecom_expr (ffesymbol_init (s));
7709 initexpr = ffecom_init_zero_ (t);
7711 else if (ffe_is_init_local_zero ())
7712 initexpr = ffecom_init_zero_ (t);
7714 initexpr = NULL_TREE; /* Not ref'd if !init. */
7716 finish_decl (t, initexpr, FALSE);
7718 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7720 assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7721 assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7722 ffestorag_size (st)));
7728 case FFEINFO_whereRESULT:
7729 assert (!ffecom_transform_only_dummies_);
7731 if (bt == FFEINFO_basictypeCHARACTER)
7732 { /* Result is already in list of dummies, use
7734 t = ffecom_func_result_;
7735 tlen = ffecom_func_length_;
7739 if ((ffecom_num_entrypoints_ == 0)
7740 && (bt == FFEINFO_basictypeCOMPLEX)
7741 && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7742 { /* Result is already in list of dummies, use
7744 t = ffecom_func_result_;
7748 if (ffecom_func_result_ != NULL_TREE)
7750 t = ffecom_func_result_;
7753 if ((ffecom_num_entrypoints_ != 0)
7754 && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7756 assert (ffecom_multi_retval_ != NULL_TREE);
7757 t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7758 ffecom_multi_retval_);
7759 t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7760 t, ffecom_multi_fields_[bt][kt]);
7765 t = build_decl (VAR_DECL,
7766 ffecom_get_identifier_ (ffesymbol_text (s)),
7767 ffecom_tree_type[bt][kt]);
7768 TREE_STATIC (t) = 0; /* Put result on stack. */
7769 t = start_decl (t, FALSE);
7770 finish_decl (t, NULL_TREE, FALSE);
7772 ffecom_func_result_ = t;
7776 case FFEINFO_whereDUMMY:
7784 bool adjustable = FALSE; /* Conditionally adjustable? */
7786 type = ffecom_tree_type[bt][kt];
7787 if (ffesymbol_sfdummyparent (s) != NULL)
7789 if (current_function_decl == ffecom_outer_function_decl_)
7790 { /* Exec transition before sfunc
7791 context; get it later. */
7794 t = ffecom_get_identifier_ (ffesymbol_text
7795 (ffesymbol_sfdummyparent (s)));
7798 t = ffecom_get_identifier_ (ffesymbol_text (s));
7800 assert (ffecom_transform_only_dummies_);
7802 old_sizes = get_pending_sizes ();
7803 put_pending_sizes (old_sizes);
7805 if (bt == FFEINFO_basictypeCHARACTER)
7806 tlen = ffecom_char_enhance_arg_ (&type, s);
7807 type = ffecom_check_size_overflow_ (s, type, TRUE);
7809 for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7811 if (type == error_mark_node)
7814 dim = ffebld_head (dl);
7815 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7816 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7817 low = ffecom_integer_one_node;
7819 low = ffecom_expr (ffebld_left (dim));
7820 assert (ffebld_right (dim) != NULL);
7821 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7822 || ffecom_doing_entry_)
7824 /* Used to just do high=low. But for ffecom_tree_
7825 canonize_ref_, it probably is important to correctly
7826 assess the size. E.g. given COMPLEX C(*),CFUNC and
7827 C(2)=CFUNC(C), overlap can happen, while it can't
7828 for, say, C(1)=CFUNC(C(2)). */
7829 /* Even more recently used to set to INT_MAX, but that
7830 broke when some overflow checking went into the back
7831 end. Now we just leave the upper bound unspecified. */
7835 high = ffecom_expr (ffebld_right (dim));
7837 /* Determine whether array is conditionally adjustable,
7838 to decide whether back-end magic is needed.
7840 Normally the front end uses the back-end function
7841 variable_size to wrap SAVE_EXPR's around expressions
7842 affecting the size/shape of an array so that the
7843 size/shape info doesn't change during execution
7844 of the compiled code even though variables and
7845 functions referenced in those expressions might.
7847 variable_size also makes sure those saved expressions
7848 get evaluated immediately upon entry to the
7849 compiled procedure -- the front end normally doesn't
7850 have to worry about that.
7852 However, there is a problem with this that affects
7853 g77's implementation of entry points, and that is
7854 that it is _not_ true that each invocation of the
7855 compiled procedure is permitted to evaluate
7856 array size/shape info -- because it is possible
7857 that, for some invocations, that info is invalid (in
7858 which case it is "promised" -- i.e. a violation of
7859 the Fortran standard -- that the compiled code
7860 won't reference the array or its size/shape
7861 during that particular invocation).
7863 To phrase this in C terms, consider this gcc function:
7865 void foo (int *n, float (*a)[*n])
7867 // a is "pointer to array ...", fyi.
7870 Suppose that, for some invocations, it is permitted
7871 for a caller of foo to do this:
7875 Now the _written_ code for foo can take such a call
7876 into account by either testing explicitly for whether
7877 (a == NULL) || (n == NULL) -- presumably it is
7878 not permitted to reference *a in various fashions
7879 if (n == NULL) I suppose -- or it can avoid it by
7880 looking at other info (other arguments, static/global
7883 However, this won't work in gcc 2.5.8 because it'll
7884 automatically emit the code to save the "*n"
7885 expression, which'll yield a NULL dereference for
7886 the "foo (NULL, NULL)" call, something the code
7887 for foo cannot prevent.
7889 g77 definitely needs to avoid executing such
7890 code anytime the pointer to the adjustable array
7891 is NULL, because even if its bounds expressions
7892 don't have any references to possible "absent"
7893 variables like "*n" -- say all variable references
7894 are to COMMON variables, i.e. global (though in C,
7895 local static could actually make sense) -- the
7896 expressions could yield other run-time problems
7897 for allowably "dead" values in those variables.
7899 For example, let's consider a more complicated
7905 void foo (float (*a)[i/j])
7910 The above is (essentially) quite valid for Fortran
7911 but, again, for a call like "foo (NULL);", it is
7912 permitted for i and j to be undefined when the
7913 call is made. If j happened to be zero, for
7914 example, emitting the code to evaluate "i/j"
7915 could result in a run-time error.
7917 Offhand, though I don't have my F77 or F90
7918 standards handy, it might even be valid for a
7919 bounds expression to contain a function reference,
7920 in which case I doubt it is permitted for an
7921 implementation to invoke that function in the
7922 Fortran case involved here (invocation of an
7923 alternate ENTRY point that doesn't have the adjustable
7924 array as one of its arguments).
7926 So, the code that the compiler would normally emit
7927 to preevaluate the size/shape info for an
7928 adjustable array _must not_ be executed at run time
7929 in certain cases. Specifically, for Fortran,
7930 the case is when the pointer to the adjustable
7931 array == NULL. (For gnu-ish C, it might be nice
7932 for the source code itself to specify an expression
7933 that, if TRUE, inhibits execution of the code. Or
7934 reverse the sense for elegance.)
7936 (Note that g77 could use a different test than NULL,
7937 actually, since it happens to always pass an
7938 integer to the called function that specifies which
7939 entry point is being invoked. Hmm, this might
7940 solve the next problem.)
7942 One way a user could, I suppose, write "foo" so
7943 it works is to insert COND_EXPR's for the
7944 size/shape info so the dangerous stuff isn't
7945 actually done, as in:
7947 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7952 The next problem is that the front end needs to
7953 be able to tell the back end about the array's
7954 decl _before_ it tells it about the conditional
7955 expression to inhibit evaluation of size/shape info,
7958 To solve this, the front end needs to be able
7959 to give the back end the expression to inhibit
7960 generation of the preevaluation code _after_
7961 it makes the decl for the adjustable array.
7963 Until then, the above example using the COND_EXPR
7964 doesn't pass muster with gcc because the "(a == NULL)"
7965 part has a reference to "a", which is still
7966 undefined at that point.
7968 g77 will therefore use a different mechanism in the
7972 && ((TREE_CODE (low) != INTEGER_CST)
7973 || (high && TREE_CODE (high) != INTEGER_CST)))
7976 #if 0 /* Old approach -- see below. */
7977 if (TREE_CODE (low) != INTEGER_CST)
7978 low = ffecom_3 (COND_EXPR, integer_type_node,
7979 ffecom_adjarray_passed_ (s),
7981 ffecom_integer_zero_node);
7983 if (high && TREE_CODE (high) != INTEGER_CST)
7984 high = ffecom_3 (COND_EXPR, integer_type_node,
7985 ffecom_adjarray_passed_ (s),
7987 ffecom_integer_zero_node);
7990 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7991 probably. Fixes 950302-1.f. */
7993 if (TREE_CODE (low) != INTEGER_CST)
7994 low = variable_size (low);
7996 /* ~~~Similarly, this fixes dumb0.f. The C front end
7997 does this, which is why dumb0.c would work. */
7999 if (high && TREE_CODE (high) != INTEGER_CST)
8000 high = variable_size (high);
8005 build_range_type (ffecom_integer_type_node,
8007 type = ffecom_check_size_overflow_ (s, type, TRUE);
8010 if (type == error_mark_node)
8012 t = error_mark_node;
8016 if ((ffesymbol_sfdummyparent (s) == NULL)
8017 || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
8019 type = build_pointer_type (type);
8023 t = build_decl (PARM_DECL, t, type);
8025 DECL_ARTIFICIAL (t) = 1;
8028 /* If this arg is present in every entry point's list of
8029 dummy args, then we're done. */
8031 if (ffesymbol_numentries (s)
8032 == (ffecom_num_entrypoints_ + 1))
8037 /* If variable_size in stor-layout has been called during
8038 the above, then get_pending_sizes should have the
8039 yet-to-be-evaluated saved expressions pending.
8040 Make the whole lot of them get emitted, conditionally
8041 on whether the array decl ("t" above) is not NULL. */
8044 tree sizes = get_pending_sizes ();
8049 tem = TREE_CHAIN (tem))
8051 tree temv = TREE_VALUE (tem);
8057 = ffecom_2 (COMPOUND_EXPR,
8066 = ffecom_3 (COND_EXPR,
8073 convert (TREE_TYPE (sizes),
8074 integer_zero_node));
8075 sizes = ffecom_save_tree (sizes);
8078 = tree_cons (NULL_TREE, sizes, tem);
8082 put_pending_sizes (sizes);
8088 && (ffesymbol_numentries (s)
8089 != ffecom_num_entrypoints_ + 1))
8091 = ffecom_2 (NE_EXPR, integer_type_node,
8097 && (ffesymbol_numentries (s)
8098 != ffecom_num_entrypoints_ + 1))
8100 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8101 ffebad_here (0, ffesymbol_where_line (s),
8102 ffesymbol_where_column (s));
8103 ffebad_string (ffesymbol_text (s));
8112 case FFEINFO_whereCOMMON:
8117 ffestorag st = ffesymbol_storage (s);
8120 cs = ffesymbol_common (s); /* The COMMON area itself. */
8121 if (st != NULL) /* Else not laid out. */
8123 ffecom_transform_common_ (cs);
8124 st = ffesymbol_storage (s);
8127 type = ffecom_type_localvar_ (s, bt, kt);
8129 cg = ffesymbol_global (cs); /* The global COMMON info. */
8131 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8134 ct = ffeglobal_hook (cg); /* The common area's tree. */
8136 if ((ct == NULL_TREE)
8138 || (type == error_mark_node))
8139 t = error_mark_node;
8142 ffetargetOffset offset;
8145 cst = ffestorag_parent (st);
8146 assert (cst == ffesymbol_storage (cs));
8148 offset = ffestorag_modulo (cst)
8149 + ffestorag_offset (st)
8150 - ffestorag_offset (cst);
8152 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8154 /* (t_type *) (((char *) &ct) + offset) */
8156 t = convert (string_type_node, /* (char *) */
8157 ffecom_1 (ADDR_EXPR,
8158 build_pointer_type (TREE_TYPE (ct)),
8160 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8162 build_int_2 (offset, 0));
8163 t = convert (build_pointer_type (type),
8165 TREE_CONSTANT (t) = 1;
8172 case FFEINFO_whereIMMEDIATE:
8173 case FFEINFO_whereGLOBAL:
8174 case FFEINFO_whereFLEETING:
8175 case FFEINFO_whereFLEETING_CADDR:
8176 case FFEINFO_whereFLEETING_IADDR:
8177 case FFEINFO_whereINTRINSIC:
8178 case FFEINFO_whereCONSTANT_SUBOBJECT:
8180 assert ("ENTITY where unheard of" == NULL);
8182 case FFEINFO_whereANY:
8183 t = error_mark_node;
8188 case FFEINFO_kindFUNCTION:
8189 switch (ffeinfo_where (ffesymbol_info (s)))
8191 case FFEINFO_whereLOCAL: /* Me. */
8192 assert (!ffecom_transform_only_dummies_);
8193 t = current_function_decl;
8196 case FFEINFO_whereGLOBAL:
8197 assert (!ffecom_transform_only_dummies_);
8199 if (((g = ffesymbol_global (s)) != NULL)
8200 && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8201 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8202 && (ffeglobal_hook (g) != NULL_TREE)
8203 && ffe_is_globals ())
8205 t = ffeglobal_hook (g);
8209 if (ffesymbol_is_f2c (s)
8210 && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8211 t = ffecom_tree_fun_type[bt][kt];
8213 t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8215 t = build_decl (FUNCTION_DECL,
8216 ffecom_get_external_identifier_ (s),
8218 DECL_EXTERNAL (t) = 1;
8219 TREE_PUBLIC (t) = 1;
8221 t = start_decl (t, FALSE);
8222 finish_decl (t, NULL_TREE, FALSE);
8225 && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8226 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8227 ffeglobal_set_hook (g, t);
8229 ffecom_save_tree_forever (t);
8233 case FFEINFO_whereDUMMY:
8234 assert (ffecom_transform_only_dummies_);
8236 if (ffesymbol_is_f2c (s)
8237 && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8238 t = ffecom_tree_ptr_to_fun_type[bt][kt];
8240 t = build_pointer_type
8241 (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8243 t = build_decl (PARM_DECL,
8244 ffecom_get_identifier_ (ffesymbol_text (s)),
8247 DECL_ARTIFICIAL (t) = 1;
8252 case FFEINFO_whereCONSTANT: /* Statement function. */
8253 assert (!ffecom_transform_only_dummies_);
8254 t = ffecom_gen_sfuncdef_ (s, bt, kt);
8257 case FFEINFO_whereINTRINSIC:
8258 assert (!ffecom_transform_only_dummies_);
8259 break; /* Let actual references generate their
8263 assert ("FUNCTION where unheard of" == NULL);
8265 case FFEINFO_whereANY:
8266 t = error_mark_node;
8271 case FFEINFO_kindSUBROUTINE:
8272 switch (ffeinfo_where (ffesymbol_info (s)))
8274 case FFEINFO_whereLOCAL: /* Me. */
8275 assert (!ffecom_transform_only_dummies_);
8276 t = current_function_decl;
8279 case FFEINFO_whereGLOBAL:
8280 assert (!ffecom_transform_only_dummies_);
8282 if (((g = ffesymbol_global (s)) != NULL)
8283 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8284 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8285 && (ffeglobal_hook (g) != NULL_TREE)
8286 && ffe_is_globals ())
8288 t = ffeglobal_hook (g);
8292 t = build_decl (FUNCTION_DECL,
8293 ffecom_get_external_identifier_ (s),
8294 ffecom_tree_subr_type);
8295 DECL_EXTERNAL (t) = 1;
8296 TREE_PUBLIC (t) = 1;
8298 t = start_decl (t, FALSE);
8299 finish_decl (t, NULL_TREE, FALSE);
8302 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8303 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8304 ffeglobal_set_hook (g, t);
8306 ffecom_save_tree_forever (t);
8310 case FFEINFO_whereDUMMY:
8311 assert (ffecom_transform_only_dummies_);
8313 t = build_decl (PARM_DECL,
8314 ffecom_get_identifier_ (ffesymbol_text (s)),
8315 ffecom_tree_ptr_to_subr_type);
8317 DECL_ARTIFICIAL (t) = 1;
8322 case FFEINFO_whereINTRINSIC:
8323 assert (!ffecom_transform_only_dummies_);
8324 break; /* Let actual references generate their
8328 assert ("SUBROUTINE where unheard of" == NULL);
8330 case FFEINFO_whereANY:
8331 t = error_mark_node;
8336 case FFEINFO_kindPROGRAM:
8337 switch (ffeinfo_where (ffesymbol_info (s)))
8339 case FFEINFO_whereLOCAL: /* Me. */
8340 assert (!ffecom_transform_only_dummies_);
8341 t = current_function_decl;
8344 case FFEINFO_whereCOMMON:
8345 case FFEINFO_whereDUMMY:
8346 case FFEINFO_whereGLOBAL:
8347 case FFEINFO_whereRESULT:
8348 case FFEINFO_whereFLEETING:
8349 case FFEINFO_whereFLEETING_CADDR:
8350 case FFEINFO_whereFLEETING_IADDR:
8351 case FFEINFO_whereIMMEDIATE:
8352 case FFEINFO_whereINTRINSIC:
8353 case FFEINFO_whereCONSTANT:
8354 case FFEINFO_whereCONSTANT_SUBOBJECT:
8356 assert ("PROGRAM where unheard of" == NULL);
8358 case FFEINFO_whereANY:
8359 t = error_mark_node;
8364 case FFEINFO_kindBLOCKDATA:
8365 switch (ffeinfo_where (ffesymbol_info (s)))
8367 case FFEINFO_whereLOCAL: /* Me. */
8368 assert (!ffecom_transform_only_dummies_);
8369 t = current_function_decl;
8372 case FFEINFO_whereGLOBAL:
8373 assert (!ffecom_transform_only_dummies_);
8375 t = build_decl (FUNCTION_DECL,
8376 ffecom_get_external_identifier_ (s),
8377 ffecom_tree_blockdata_type);
8378 DECL_EXTERNAL (t) = 1;
8379 TREE_PUBLIC (t) = 1;
8381 t = start_decl (t, FALSE);
8382 finish_decl (t, NULL_TREE, FALSE);
8384 ffecom_save_tree_forever (t);
8388 case FFEINFO_whereCOMMON:
8389 case FFEINFO_whereDUMMY:
8390 case FFEINFO_whereRESULT:
8391 case FFEINFO_whereFLEETING:
8392 case FFEINFO_whereFLEETING_CADDR:
8393 case FFEINFO_whereFLEETING_IADDR:
8394 case FFEINFO_whereIMMEDIATE:
8395 case FFEINFO_whereINTRINSIC:
8396 case FFEINFO_whereCONSTANT:
8397 case FFEINFO_whereCONSTANT_SUBOBJECT:
8399 assert ("BLOCKDATA where unheard of" == NULL);
8401 case FFEINFO_whereANY:
8402 t = error_mark_node;
8407 case FFEINFO_kindCOMMON:
8408 switch (ffeinfo_where (ffesymbol_info (s)))
8410 case FFEINFO_whereLOCAL:
8411 assert (!ffecom_transform_only_dummies_);
8412 ffecom_transform_common_ (s);
8415 case FFEINFO_whereNONE:
8416 case FFEINFO_whereCOMMON:
8417 case FFEINFO_whereDUMMY:
8418 case FFEINFO_whereGLOBAL:
8419 case FFEINFO_whereRESULT:
8420 case FFEINFO_whereFLEETING:
8421 case FFEINFO_whereFLEETING_CADDR:
8422 case FFEINFO_whereFLEETING_IADDR:
8423 case FFEINFO_whereIMMEDIATE:
8424 case FFEINFO_whereINTRINSIC:
8425 case FFEINFO_whereCONSTANT:
8426 case FFEINFO_whereCONSTANT_SUBOBJECT:
8428 assert ("COMMON where unheard of" == NULL);
8430 case FFEINFO_whereANY:
8431 t = error_mark_node;
8436 case FFEINFO_kindCONSTRUCT:
8437 switch (ffeinfo_where (ffesymbol_info (s)))
8439 case FFEINFO_whereLOCAL:
8440 assert (!ffecom_transform_only_dummies_);
8443 case FFEINFO_whereNONE:
8444 case FFEINFO_whereCOMMON:
8445 case FFEINFO_whereDUMMY:
8446 case FFEINFO_whereGLOBAL:
8447 case FFEINFO_whereRESULT:
8448 case FFEINFO_whereFLEETING:
8449 case FFEINFO_whereFLEETING_CADDR:
8450 case FFEINFO_whereFLEETING_IADDR:
8451 case FFEINFO_whereIMMEDIATE:
8452 case FFEINFO_whereINTRINSIC:
8453 case FFEINFO_whereCONSTANT:
8454 case FFEINFO_whereCONSTANT_SUBOBJECT:
8456 assert ("CONSTRUCT where unheard of" == NULL);
8458 case FFEINFO_whereANY:
8459 t = error_mark_node;
8464 case FFEINFO_kindNAMELIST:
8465 switch (ffeinfo_where (ffesymbol_info (s)))
8467 case FFEINFO_whereLOCAL:
8468 assert (!ffecom_transform_only_dummies_);
8469 t = ffecom_transform_namelist_ (s);
8472 case FFEINFO_whereNONE:
8473 case FFEINFO_whereCOMMON:
8474 case FFEINFO_whereDUMMY:
8475 case FFEINFO_whereGLOBAL:
8476 case FFEINFO_whereRESULT:
8477 case FFEINFO_whereFLEETING:
8478 case FFEINFO_whereFLEETING_CADDR:
8479 case FFEINFO_whereFLEETING_IADDR:
8480 case FFEINFO_whereIMMEDIATE:
8481 case FFEINFO_whereINTRINSIC:
8482 case FFEINFO_whereCONSTANT:
8483 case FFEINFO_whereCONSTANT_SUBOBJECT:
8485 assert ("NAMELIST where unheard of" == NULL);
8487 case FFEINFO_whereANY:
8488 t = error_mark_node;
8494 assert ("kind unheard of" == NULL);
8496 case FFEINFO_kindANY:
8497 t = error_mark_node;
8501 ffesymbol_hook (s).decl_tree = t;
8502 ffesymbol_hook (s).length_tree = tlen;
8503 ffesymbol_hook (s).addr = addr;
8505 lineno = old_lineno;
8506 input_filename = old_input_filename;
8512 /* Transform into ASSIGNable symbol.
8514 Symbol has already been transformed, but for whatever reason, the
8515 resulting decl_tree has been deemed not usable for an ASSIGN target.
8516 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8517 another local symbol of type void * and stuff that in the assign_tree
8518 argument. The F77/F90 standards allow this implementation. */
8520 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8522 ffecom_sym_transform_assign_ (ffesymbol s)
8524 tree t; /* Transformed thingy. */
8525 int old_lineno = lineno;
8526 const char *old_input_filename = input_filename;
8528 if (ffesymbol_sfdummyparent (s) == NULL)
8530 input_filename = ffesymbol_where_filename (s);
8531 lineno = ffesymbol_where_filelinenum (s);
8535 ffesymbol sf = ffesymbol_sfdummyparent (s);
8537 input_filename = ffesymbol_where_filename (sf);
8538 lineno = ffesymbol_where_filelinenum (sf);
8541 assert (!ffecom_transform_only_dummies_);
8543 t = build_decl (VAR_DECL,
8544 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8545 ffesymbol_text (s)),
8546 TREE_TYPE (null_pointer_node));
8548 switch (ffesymbol_where (s))
8550 case FFEINFO_whereLOCAL:
8551 /* Unlike for regular vars, SAVE status is easy to determine for
8552 ASSIGNed vars, since there's no initialization, there's no
8553 effective storage association (so "SAVE J" does not apply to
8554 K even given "EQUIVALENCE (J,K)"), there's no size issue
8555 to worry about, etc. */
8556 if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8557 && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8558 && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8559 TREE_STATIC (t) = 1; /* SAVEd in proc, make static. */
8561 TREE_STATIC (t) = 0; /* No need to make static. */
8564 case FFEINFO_whereCOMMON:
8565 TREE_STATIC (t) = 1; /* Assume COMMONs always SAVEd. */
8568 case FFEINFO_whereDUMMY:
8569 /* Note that twinning a DUMMY means the caller won't see
8570 the ASSIGNed value. But both F77 and F90 allow implementations
8571 to do this, i.e. disallow Fortran code that would try and
8572 take advantage of actually putting a label into a variable
8573 via a dummy argument (or any other storage association, for
8575 TREE_STATIC (t) = 0;
8579 TREE_STATIC (t) = 0;
8583 t = start_decl (t, FALSE);
8584 finish_decl (t, NULL_TREE, FALSE);
8586 ffesymbol_hook (s).assign_tree = t;
8588 lineno = old_lineno;
8589 input_filename = old_input_filename;
8595 /* Implement COMMON area in back end.
8597 Because COMMON-based variables can be referenced in the dimension
8598 expressions of dummy (adjustable) arrays, and because dummies
8599 (in the gcc back end) need to be put in the outer binding level
8600 of a function (which has two binding levels, the outer holding
8601 the dummies and the inner holding the other vars), special care
8602 must be taken to handle COMMON areas.
8604 The current strategy is basically to always tell the back end about
8605 the COMMON area as a top-level external reference to just a block
8606 of storage of the master type of that area (e.g. integer, real,
8607 character, whatever -- not a structure). As a distinct action,
8608 if initial values are provided, tell the back end about the area
8609 as a top-level non-external (initialized) area and remember not to
8610 allow further initialization or expansion of the area. Meanwhile,
8611 if no initialization happens at all, tell the back end about
8612 the largest size we've seen declared so the space does get reserved.
8613 (This function doesn't handle all that stuff, but it does some
8614 of the important things.)
8616 Meanwhile, for COMMON variables themselves, just keep creating
8617 references like *((float *) (&common_area + offset)) each time
8618 we reference the variable. In other words, don't make a VAR_DECL
8619 or any kind of component reference (like we used to do before 0.4),
8620 though we might do that as well just for debugging purposes (and
8621 stuff the rtl with the appropriate offset expression). */
8623 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8625 ffecom_transform_common_ (ffesymbol s)
8627 ffestorag st = ffesymbol_storage (s);
8628 ffeglobal g = ffesymbol_global (s);
8633 bool is_init = ffestorag_is_init (st);
8635 assert (st != NULL);
8638 || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8641 /* First update the size of the area in global terms. */
8643 ffeglobal_size_common (s, ffestorag_size (st));
8645 if (!ffeglobal_common_init (g))
8646 is_init = FALSE; /* No explicit init, don't let erroneous joins init. */
8648 cbt = ffeglobal_hook (g);
8650 /* If we already have declared this common block for a previous program
8651 unit, and either we already initialized it or we don't have new
8652 initialization for it, just return what we have without changing it. */
8654 if ((cbt != NULL_TREE)
8656 || !DECL_EXTERNAL (cbt)))
8658 if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8662 /* Process inits. */
8666 if (ffestorag_init (st) != NULL)
8670 /* Set the padding for the expression, so ffecom_expr
8671 knows to insert that many zeros. */
8672 switch (ffebld_op (sexp = ffestorag_init (st)))
8674 case FFEBLD_opCONTER:
8675 ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8678 case FFEBLD_opARRTER:
8679 ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8682 case FFEBLD_opACCTER:
8683 ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8687 assert ("bad op for cmn init (pad)" == NULL);
8691 init = ffecom_expr (sexp);
8692 if (init == error_mark_node)
8693 { /* Hopefully the back end complained! */
8695 if (cbt != NULL_TREE)
8700 init = error_mark_node;
8705 /* cbtype must be permanently allocated! */
8707 /* Allocate the MAX of the areas so far, seen filewide. */
8708 high = build_int_2 ((ffeglobal_common_size (g)
8709 + ffeglobal_common_pad (g)) - 1, 0);
8710 TREE_TYPE (high) = ffecom_integer_type_node;
8713 cbtype = build_array_type (char_type_node,
8714 build_range_type (integer_type_node,
8718 cbtype = build_array_type (char_type_node, NULL_TREE);
8720 if (cbt == NULL_TREE)
8723 = build_decl (VAR_DECL,
8724 ffecom_get_external_identifier_ (s),
8726 TREE_STATIC (cbt) = 1;
8727 TREE_PUBLIC (cbt) = 1;
8732 TREE_TYPE (cbt) = cbtype;
8734 DECL_EXTERNAL (cbt) = init ? 0 : 1;
8735 DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8737 cbt = start_decl (cbt, TRUE);
8738 if (ffeglobal_hook (g) != NULL)
8739 assert (cbt == ffeglobal_hook (g));
8741 assert (!init || !DECL_EXTERNAL (cbt));
8743 /* Make sure that any type can live in COMMON and be referenced
8744 without getting a bus error. We could pick the most restrictive
8745 alignment of all entities actually placed in the COMMON, but
8746 this seems easy enough. */
8748 DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8749 DECL_USER_ALIGN (cbt) = 0;
8751 if (is_init && (ffestorag_init (st) == NULL))
8752 init = ffecom_init_zero_ (cbt);
8754 finish_decl (cbt, init, TRUE);
8757 ffestorag_set_init (st, ffebld_new_any ());
8761 assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8762 assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8763 assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8764 (ffeglobal_common_size (g)
8765 + ffeglobal_common_pad (g))));
8768 ffeglobal_set_hook (g, cbt);
8770 ffestorag_set_hook (st, cbt);
8772 ffecom_save_tree_forever (cbt);
8776 /* Make master area for local EQUIVALENCE. */
8778 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8780 ffecom_transform_equiv_ (ffestorag eqst)
8786 bool is_init = ffestorag_is_init (eqst);
8788 assert (eqst != NULL);
8790 eqt = ffestorag_hook (eqst);
8792 if (eqt != NULL_TREE)
8795 /* Process inits. */
8799 if (ffestorag_init (eqst) != NULL)
8803 /* Set the padding for the expression, so ffecom_expr
8804 knows to insert that many zeros. */
8805 switch (ffebld_op (sexp = ffestorag_init (eqst)))
8807 case FFEBLD_opCONTER:
8808 ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8811 case FFEBLD_opARRTER:
8812 ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8815 case FFEBLD_opACCTER:
8816 ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8820 assert ("bad op for eqv init (pad)" == NULL);
8824 init = ffecom_expr (sexp);
8825 if (init == error_mark_node)
8826 init = NULL_TREE; /* Hopefully the back end complained! */
8829 init = error_mark_node;
8831 else if (ffe_is_init_local_zero ())
8832 init = error_mark_node;
8836 ffecom_member_namelisted_ = FALSE;
8837 ffestorag_drive (ffestorag_list_equivs (eqst),
8838 &ffecom_member_phase1_,
8841 high = build_int_2 ((ffestorag_size (eqst)
8842 + ffestorag_modulo (eqst)) - 1, 0);
8843 TREE_TYPE (high) = ffecom_integer_type_node;
8845 eqtype = build_array_type (char_type_node,
8846 build_range_type (ffecom_integer_type_node,
8847 ffecom_integer_zero_node,
8850 eqt = build_decl (VAR_DECL,
8851 ffecom_get_invented_identifier ("__g77_equiv_%s",
8853 (ffestorag_symbol (eqst))),
8855 DECL_EXTERNAL (eqt) = 0;
8857 || ffecom_member_namelisted_
8858 #ifdef FFECOM_sizeMAXSTACKITEM
8859 || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8861 || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8862 && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8863 && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8864 TREE_STATIC (eqt) = 1;
8866 TREE_STATIC (eqt) = 0;
8867 TREE_PUBLIC (eqt) = 0;
8868 TREE_ADDRESSABLE (eqt) = 1; /* Ensure non-register allocation */
8869 DECL_CONTEXT (eqt) = current_function_decl;
8871 DECL_INITIAL (eqt) = error_mark_node;
8873 DECL_INITIAL (eqt) = NULL_TREE;
8875 eqt = start_decl (eqt, FALSE);
8877 /* Make sure that any type can live in EQUIVALENCE and be referenced
8878 without getting a bus error. We could pick the most restrictive
8879 alignment of all entities actually placed in the EQUIVALENCE, but
8880 this seems easy enough. */
8882 DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8883 DECL_USER_ALIGN (eqt) = 0;
8885 if ((!is_init && ffe_is_init_local_zero ())
8886 || (is_init && (ffestorag_init (eqst) == NULL)))
8887 init = ffecom_init_zero_ (eqt);
8889 finish_decl (eqt, init, FALSE);
8892 ffestorag_set_init (eqst, ffebld_new_any ());
8895 assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8896 assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8897 (ffestorag_size (eqst)
8898 + ffestorag_modulo (eqst))));
8901 ffestorag_set_hook (eqst, eqt);
8903 ffestorag_drive (ffestorag_list_equivs (eqst),
8904 &ffecom_member_phase2_,
8909 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8911 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8913 ffecom_transform_namelist_ (ffesymbol s)
8916 tree nmltype = ffecom_type_namelist_ ();
8924 static int mynumber = 0;
8926 nmlt = build_decl (VAR_DECL,
8927 ffecom_get_invented_identifier ("__g77_namelist_%d",
8930 TREE_STATIC (nmlt) = 1;
8931 DECL_INITIAL (nmlt) = error_mark_node;
8933 nmlt = start_decl (nmlt, FALSE);
8935 /* Process inits. */
8937 i = strlen (ffesymbol_text (s));
8939 high = build_int_2 (i, 0);
8940 TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8942 nameinit = ffecom_build_f2c_string_ (i + 1,
8943 ffesymbol_text (s));
8944 TREE_TYPE (nameinit)
8945 = build_type_variant
8948 build_range_type (ffecom_f2c_ftnlen_type_node,
8949 ffecom_f2c_ftnlen_one_node,
8952 TREE_CONSTANT (nameinit) = 1;
8953 TREE_STATIC (nameinit) = 1;
8954 nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8957 varsinit = ffecom_vardesc_array_ (s);
8958 varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8960 TREE_CONSTANT (varsinit) = 1;
8961 TREE_STATIC (varsinit) = 1;
8966 for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8969 nvarsinit = build_int_2 (i, 0);
8970 TREE_TYPE (nvarsinit) = integer_type_node;
8971 TREE_CONSTANT (nvarsinit) = 1;
8972 TREE_STATIC (nvarsinit) = 1;
8974 nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8975 TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8977 TREE_CHAIN (TREE_CHAIN (nmlinits))
8978 = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8980 nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8981 TREE_CONSTANT (nmlinits) = 1;
8982 TREE_STATIC (nmlinits) = 1;
8984 finish_decl (nmlt, nmlinits, FALSE);
8986 nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8993 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8994 analyzed on the assumption it is calculating a pointer to be
8995 indirected through. It must return the proper decl and offset,
8996 taking into account different units of measurements for offsets. */
8998 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9000 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
9003 switch (TREE_CODE (t))
9007 case NON_LVALUE_EXPR:
9008 ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9012 ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9013 if ((*decl == NULL_TREE)
9014 || (*decl == error_mark_node))
9017 if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
9019 /* An offset into COMMON. */
9020 *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
9021 *offset, TREE_OPERAND (t, 1)));
9022 /* Convert offset (presumably in bytes) into canonical units
9023 (presumably bits). */
9024 *offset = size_binop (MULT_EXPR,
9025 convert (bitsizetype, *offset),
9026 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
9029 /* Not a COMMON reference, so an unrecognized pattern. */
9030 *decl = error_mark_node;
9035 *offset = bitsize_zero_node;
9039 if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
9041 /* A reference to COMMON. */
9042 *decl = TREE_OPERAND (t, 0);
9043 *offset = bitsize_zero_node;
9048 /* Not a COMMON reference, so an unrecognized pattern. */
9049 *decl = error_mark_node;
9055 /* Given a tree that is possibly intended for use as an lvalue, return
9056 information representing a canonical view of that tree as a decl, an
9057 offset into that decl, and a size for the lvalue.
9059 If there's no applicable decl, NULL_TREE is returned for the decl,
9060 and the other fields are left undefined.
9062 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9063 is returned for the decl, and the other fields are left undefined.
9065 Otherwise, the decl returned currently is either a VAR_DECL or a
9068 The offset returned is always valid, but of course not necessarily
9069 a constant, and not necessarily converted into the appropriate
9070 type, leaving that up to the caller (so as to avoid that overhead
9071 if the decls being looked at are different anyway).
9073 If the size cannot be determined (e.g. an adjustable array),
9074 an ERROR_MARK node is returned for the size. Otherwise, the
9075 size returned is valid, not necessarily a constant, and not
9076 necessarily converted into the appropriate type as with the
9079 Note that the offset and size expressions are expressed in the
9080 base storage units (usually bits) rather than in the units of
9081 the type of the decl, because two decls with different types
9082 might overlap but with apparently non-overlapping array offsets,
9083 whereas converting the array offsets to consistant offsets will
9084 reveal the overlap. */
9086 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9088 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9091 /* The default path is to report a nonexistant decl. */
9097 switch (TREE_CODE (t))
9100 case IDENTIFIER_NODE:
9109 case TRUNC_DIV_EXPR:
9111 case FLOOR_DIV_EXPR:
9112 case ROUND_DIV_EXPR:
9113 case TRUNC_MOD_EXPR:
9115 case FLOOR_MOD_EXPR:
9116 case ROUND_MOD_EXPR:
9118 case EXACT_DIV_EXPR:
9119 case FIX_TRUNC_EXPR:
9121 case FIX_FLOOR_EXPR:
9122 case FIX_ROUND_EXPR:
9137 case BIT_ANDTC_EXPR:
9139 case TRUTH_ANDIF_EXPR:
9140 case TRUTH_ORIF_EXPR:
9141 case TRUTH_AND_EXPR:
9143 case TRUTH_XOR_EXPR:
9144 case TRUTH_NOT_EXPR:
9164 *offset = bitsize_zero_node;
9165 *size = TYPE_SIZE (TREE_TYPE (t));
9170 tree array = TREE_OPERAND (t, 0);
9171 tree element = TREE_OPERAND (t, 1);
9174 if ((array == NULL_TREE)
9175 || (element == NULL_TREE))
9177 *decl = error_mark_node;
9181 ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9183 if ((*decl == NULL_TREE)
9184 || (*decl == error_mark_node))
9187 /* Calculate ((element - base) * NBBY) + init_offset. */
9188 *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9190 TYPE_MIN_VALUE (TYPE_DOMAIN
9191 (TREE_TYPE (array)))));
9193 *offset = size_binop (MULT_EXPR,
9194 convert (bitsizetype, *offset),
9195 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9197 *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9199 *size = TYPE_SIZE (TREE_TYPE (t));
9205 /* Most of this code is to handle references to COMMON. And so
9206 far that is useful only for calling library functions, since
9207 external (user) functions might reference common areas. But
9208 even calling an external function, it's worthwhile to decode
9209 COMMON references because if not storing into COMMON, we don't
9210 want COMMON-based arguments to gratuitously force use of a
9213 *size = TYPE_SIZE (TREE_TYPE (t));
9215 ffecom_tree_canonize_ptr_ (decl, offset,
9216 TREE_OPERAND (t, 0));
9223 case NON_LVALUE_EXPR:
9226 case COND_EXPR: /* More cases than we can handle. */
9228 case REFERENCE_EXPR:
9229 case PREDECREMENT_EXPR:
9230 case PREINCREMENT_EXPR:
9231 case POSTDECREMENT_EXPR:
9232 case POSTINCREMENT_EXPR:
9235 *decl = error_mark_node;
9241 /* Do divide operation appropriate to type of operands. */
9243 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9245 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9246 tree dest_tree, ffebld dest, bool *dest_used,
9249 if ((left == error_mark_node)
9250 || (right == error_mark_node))
9251 return error_mark_node;
9253 switch (TREE_CODE (tree_type))
9256 return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9261 if (! optimize_size)
9262 return ffecom_2 (RDIV_EXPR, tree_type,
9268 if (TREE_TYPE (tree_type)
9269 == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9270 ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
9272 ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
9274 left = ffecom_1 (ADDR_EXPR,
9275 build_pointer_type (TREE_TYPE (left)),
9277 left = build_tree_list (NULL_TREE, left);
9278 right = ffecom_1 (ADDR_EXPR,
9279 build_pointer_type (TREE_TYPE (right)),
9281 right = build_tree_list (NULL_TREE, right);
9282 TREE_CHAIN (left) = right;
9284 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9285 ffecom_gfrt_kindtype (ix),
9286 ffe_is_f2c_library (),
9289 dest_tree, dest, dest_used,
9290 NULL_TREE, TRUE, hook);
9298 if (TREE_TYPE (TYPE_FIELDS (tree_type))
9299 == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9300 ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
9302 ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
9304 left = ffecom_1 (ADDR_EXPR,
9305 build_pointer_type (TREE_TYPE (left)),
9307 left = build_tree_list (NULL_TREE, left);
9308 right = ffecom_1 (ADDR_EXPR,
9309 build_pointer_type (TREE_TYPE (right)),
9311 right = build_tree_list (NULL_TREE, right);
9312 TREE_CHAIN (left) = right;
9314 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9315 ffecom_gfrt_kindtype (ix),
9316 ffe_is_f2c_library (),
9319 dest_tree, dest, dest_used,
9320 NULL_TREE, TRUE, hook);
9325 return ffecom_2 (RDIV_EXPR, tree_type,
9332 /* Build type info for non-dummy variable. */
9334 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9336 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9345 type = ffecom_tree_type[bt][kt];
9346 if (bt == FFEINFO_basictypeCHARACTER)
9348 hight = build_int_2 (ffesymbol_size (s), 0);
9349 TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9354 build_range_type (ffecom_f2c_ftnlen_type_node,
9355 ffecom_f2c_ftnlen_one_node,
9357 type = ffecom_check_size_overflow_ (s, type, FALSE);
9360 for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9362 if (type == error_mark_node)
9365 dim = ffebld_head (dl);
9366 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9368 if (ffebld_left (dim) == NULL)
9369 lowt = integer_one_node;
9371 lowt = ffecom_expr (ffebld_left (dim));
9373 if (TREE_CODE (lowt) != INTEGER_CST)
9374 lowt = variable_size (lowt);
9376 assert (ffebld_right (dim) != NULL);
9377 hight = ffecom_expr (ffebld_right (dim));
9379 if (TREE_CODE (hight) != INTEGER_CST)
9380 hight = variable_size (hight);
9382 type = build_array_type (type,
9383 build_range_type (ffecom_integer_type_node,
9385 type = ffecom_check_size_overflow_ (s, type, FALSE);
9392 /* Build Namelist type. */
9394 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9396 ffecom_type_namelist_ ()
9398 static tree type = NULL_TREE;
9400 if (type == NULL_TREE)
9402 static tree namefield, varsfield, nvarsfield;
9405 vardesctype = ffecom_type_vardesc_ ();
9407 type = make_node (RECORD_TYPE);
9409 vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9411 namefield = ffecom_decl_field (type, NULL_TREE, "name",
9413 varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9414 nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9417 TYPE_FIELDS (type) = namefield;
9420 ggc_add_tree_root (&type, 1);
9428 /* Build Vardesc type. */
9430 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9432 ffecom_type_vardesc_ ()
9434 static tree type = NULL_TREE;
9435 static tree namefield, addrfield, dimsfield, typefield;
9437 if (type == NULL_TREE)
9439 type = make_node (RECORD_TYPE);
9441 namefield = ffecom_decl_field (type, NULL_TREE, "name",
9443 addrfield = ffecom_decl_field (type, namefield, "addr",
9445 dimsfield = ffecom_decl_field (type, addrfield, "dims",
9446 ffecom_f2c_ptr_to_ftnlen_type_node);
9447 typefield = ffecom_decl_field (type, dimsfield, "type",
9450 TYPE_FIELDS (type) = namefield;
9453 ggc_add_tree_root (&type, 1);
9461 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9463 ffecom_vardesc_ (ffebld expr)
9467 assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9468 s = ffebld_symter (expr);
9470 if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9473 tree vardesctype = ffecom_type_vardesc_ ();
9481 static int mynumber = 0;
9483 var = build_decl (VAR_DECL,
9484 ffecom_get_invented_identifier ("__g77_vardesc_%d",
9487 TREE_STATIC (var) = 1;
9488 DECL_INITIAL (var) = error_mark_node;
9490 var = start_decl (var, FALSE);
9492 /* Process inits. */
9494 nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9496 ffesymbol_text (s));
9497 TREE_TYPE (nameinit)
9498 = build_type_variant
9501 build_range_type (integer_type_node,
9503 build_int_2 (i, 0))),
9505 TREE_CONSTANT (nameinit) = 1;
9506 TREE_STATIC (nameinit) = 1;
9507 nameinit = ffecom_1 (ADDR_EXPR,
9508 build_pointer_type (TREE_TYPE (nameinit)),
9511 addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9513 dimsinit = ffecom_vardesc_dims_ (s);
9515 if (typeinit == NULL_TREE)
9517 ffeinfoBasictype bt = ffesymbol_basictype (s);
9518 ffeinfoKindtype kt = ffesymbol_kindtype (s);
9519 int tc = ffecom_f2c_typecode (bt, kt);
9522 typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9525 typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9527 varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9529 TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9531 TREE_CHAIN (TREE_CHAIN (varinits))
9532 = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9533 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9534 = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9536 varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9537 TREE_CONSTANT (varinits) = 1;
9538 TREE_STATIC (varinits) = 1;
9540 finish_decl (var, varinits, FALSE);
9542 var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9544 ffesymbol_hook (s).vardesc_tree = var;
9547 return ffesymbol_hook (s).vardesc_tree;
9551 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9553 ffecom_vardesc_array_ (ffesymbol s)
9557 tree item = NULL_TREE;
9560 static int mynumber = 0;
9562 for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9564 b = ffebld_trail (b), ++i)
9568 t = ffecom_vardesc_ (ffebld_head (b));
9570 if (list == NULL_TREE)
9571 list = item = build_tree_list (NULL_TREE, t);
9574 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9575 item = TREE_CHAIN (item);
9579 item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9580 build_range_type (integer_type_node,
9582 build_int_2 (i, 0)));
9583 list = build (CONSTRUCTOR, item, NULL_TREE, list);
9584 TREE_CONSTANT (list) = 1;
9585 TREE_STATIC (list) = 1;
9587 var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9588 var = build_decl (VAR_DECL, var, item);
9589 TREE_STATIC (var) = 1;
9590 DECL_INITIAL (var) = error_mark_node;
9591 var = start_decl (var, FALSE);
9592 finish_decl (var, list, FALSE);
9598 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9600 ffecom_vardesc_dims_ (ffesymbol s)
9602 if (ffesymbol_dims (s) == NULL)
9603 return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9611 tree item = NULL_TREE;
9615 tree baseoff = NULL_TREE;
9616 static int mynumber = 0;
9618 numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9619 TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9621 numelem = ffecom_expr (ffesymbol_arraysize (s));
9622 TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9625 backlist = NULL_TREE;
9626 for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9628 b = ffebld_trail (b), e = ffebld_trail (e))
9634 if (ffebld_trail (b) == NULL)
9638 t = convert (ffecom_f2c_ftnlen_type_node,
9639 ffecom_expr (ffebld_head (e)));
9641 if (list == NULL_TREE)
9642 list = item = build_tree_list (NULL_TREE, t);
9645 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9646 item = TREE_CHAIN (item);
9650 if (ffebld_left (ffebld_head (b)) == NULL)
9651 low = ffecom_integer_one_node;
9653 low = ffecom_expr (ffebld_left (ffebld_head (b)));
9654 low = convert (ffecom_f2c_ftnlen_type_node, low);
9656 back = build_tree_list (low, t);
9657 TREE_CHAIN (back) = backlist;
9661 for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9663 if (TREE_VALUE (item) == NULL_TREE)
9664 baseoff = TREE_PURPOSE (item);
9666 baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9667 TREE_PURPOSE (item),
9668 ffecom_2 (MULT_EXPR,
9669 ffecom_f2c_ftnlen_type_node,
9674 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9676 baseoff = build_tree_list (NULL_TREE, baseoff);
9677 TREE_CHAIN (baseoff) = list;
9679 numelem = build_tree_list (NULL_TREE, numelem);
9680 TREE_CHAIN (numelem) = baseoff;
9682 numdim = build_tree_list (NULL_TREE, numdim);
9683 TREE_CHAIN (numdim) = numelem;
9685 item = build_array_type (ffecom_f2c_ftnlen_type_node,
9686 build_range_type (integer_type_node,
9689 ((int) ffesymbol_rank (s)
9691 list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9692 TREE_CONSTANT (list) = 1;
9693 TREE_STATIC (list) = 1;
9695 var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9696 var = build_decl (VAR_DECL, var, item);
9697 TREE_STATIC (var) = 1;
9698 DECL_INITIAL (var) = error_mark_node;
9699 var = start_decl (var, FALSE);
9700 finish_decl (var, list, FALSE);
9702 var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9709 /* Essentially does a "fold (build1 (code, type, node))" while checking
9710 for certain housekeeping things.
9712 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9713 ffecom_1_fn instead. */
9715 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9717 ffecom_1 (enum tree_code code, tree type, tree node)
9721 if ((node == error_mark_node)
9722 || (type == error_mark_node))
9723 return error_mark_node;
9725 if (code == ADDR_EXPR)
9727 if (!mark_addressable (node))
9728 assert ("can't mark_addressable this node!" == NULL);
9731 switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9736 item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9740 item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9745 if (TREE_CODE (type) != RECORD_TYPE)
9747 item = build1 (code, type, node);
9750 node = ffecom_stabilize_aggregate_ (node);
9751 realtype = TREE_TYPE (TYPE_FIELDS (type));
9753 ffecom_2 (COMPLEX_EXPR, type,
9754 ffecom_1 (NEGATE_EXPR, realtype,
9755 ffecom_1 (REALPART_EXPR, realtype,
9757 ffecom_1 (NEGATE_EXPR, realtype,
9758 ffecom_1 (IMAGPART_EXPR, realtype,
9763 item = build1 (code, type, node);
9767 if (TREE_SIDE_EFFECTS (node))
9768 TREE_SIDE_EFFECTS (item) = 1;
9769 if ((code == ADDR_EXPR) && staticp (node))
9770 TREE_CONSTANT (item) = 1;
9775 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9776 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9777 does not set TREE_ADDRESSABLE (because calling an inline
9778 function does not mean the function needs to be separately
9781 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9783 ffecom_1_fn (tree node)
9788 if (node == error_mark_node)
9789 return error_mark_node;
9791 type = build_type_variant (TREE_TYPE (node),
9792 TREE_READONLY (node),
9793 TREE_THIS_VOLATILE (node));
9794 item = build1 (ADDR_EXPR,
9795 build_pointer_type (type), node);
9796 if (TREE_SIDE_EFFECTS (node))
9797 TREE_SIDE_EFFECTS (item) = 1;
9799 TREE_CONSTANT (item) = 1;
9804 /* Essentially does a "fold (build (code, type, node1, node2))" while
9805 checking for certain housekeeping things. */
9807 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9809 ffecom_2 (enum tree_code code, tree type, tree node1,
9814 if ((node1 == error_mark_node)
9815 || (node2 == error_mark_node)
9816 || (type == error_mark_node))
9817 return error_mark_node;
9819 switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9821 tree a, b, c, d, realtype;
9824 assert ("no CONJ_EXPR support yet" == NULL);
9825 return error_mark_node;
9828 item = build_tree_list (TYPE_FIELDS (type), node1);
9829 TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9830 item = build (CONSTRUCTOR, type, NULL_TREE, item);
9834 if (TREE_CODE (type) != RECORD_TYPE)
9836 item = build (code, type, node1, node2);
9839 node1 = ffecom_stabilize_aggregate_ (node1);
9840 node2 = ffecom_stabilize_aggregate_ (node2);
9841 realtype = TREE_TYPE (TYPE_FIELDS (type));
9843 ffecom_2 (COMPLEX_EXPR, type,
9844 ffecom_2 (PLUS_EXPR, realtype,
9845 ffecom_1 (REALPART_EXPR, realtype,
9847 ffecom_1 (REALPART_EXPR, realtype,
9849 ffecom_2 (PLUS_EXPR, realtype,
9850 ffecom_1 (IMAGPART_EXPR, realtype,
9852 ffecom_1 (IMAGPART_EXPR, realtype,
9857 if (TREE_CODE (type) != RECORD_TYPE)
9859 item = build (code, type, node1, node2);
9862 node1 = ffecom_stabilize_aggregate_ (node1);
9863 node2 = ffecom_stabilize_aggregate_ (node2);
9864 realtype = TREE_TYPE (TYPE_FIELDS (type));
9866 ffecom_2 (COMPLEX_EXPR, type,
9867 ffecom_2 (MINUS_EXPR, realtype,
9868 ffecom_1 (REALPART_EXPR, realtype,
9870 ffecom_1 (REALPART_EXPR, realtype,
9872 ffecom_2 (MINUS_EXPR, realtype,
9873 ffecom_1 (IMAGPART_EXPR, realtype,
9875 ffecom_1 (IMAGPART_EXPR, realtype,
9880 if (TREE_CODE (type) != RECORD_TYPE)
9882 item = build (code, type, node1, node2);
9885 node1 = ffecom_stabilize_aggregate_ (node1);
9886 node2 = ffecom_stabilize_aggregate_ (node2);
9887 realtype = TREE_TYPE (TYPE_FIELDS (type));
9888 a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9890 b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9892 c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9894 d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9897 ffecom_2 (COMPLEX_EXPR, type,
9898 ffecom_2 (MINUS_EXPR, realtype,
9899 ffecom_2 (MULT_EXPR, realtype,
9902 ffecom_2 (MULT_EXPR, realtype,
9905 ffecom_2 (PLUS_EXPR, realtype,
9906 ffecom_2 (MULT_EXPR, realtype,
9909 ffecom_2 (MULT_EXPR, realtype,
9915 if ((TREE_CODE (node1) != RECORD_TYPE)
9916 && (TREE_CODE (node2) != RECORD_TYPE))
9918 item = build (code, type, node1, node2);
9921 assert (TREE_CODE (node1) == RECORD_TYPE);
9922 assert (TREE_CODE (node2) == RECORD_TYPE);
9923 node1 = ffecom_stabilize_aggregate_ (node1);
9924 node2 = ffecom_stabilize_aggregate_ (node2);
9925 realtype = TREE_TYPE (TYPE_FIELDS (type));
9927 ffecom_2 (TRUTH_ANDIF_EXPR, type,
9928 ffecom_2 (code, type,
9929 ffecom_1 (REALPART_EXPR, realtype,
9931 ffecom_1 (REALPART_EXPR, realtype,
9933 ffecom_2 (code, type,
9934 ffecom_1 (IMAGPART_EXPR, realtype,
9936 ffecom_1 (IMAGPART_EXPR, realtype,
9941 if ((TREE_CODE (node1) != RECORD_TYPE)
9942 && (TREE_CODE (node2) != RECORD_TYPE))
9944 item = build (code, type, node1, node2);
9947 assert (TREE_CODE (node1) == RECORD_TYPE);
9948 assert (TREE_CODE (node2) == RECORD_TYPE);
9949 node1 = ffecom_stabilize_aggregate_ (node1);
9950 node2 = ffecom_stabilize_aggregate_ (node2);
9951 realtype = TREE_TYPE (TYPE_FIELDS (type));
9953 ffecom_2 (TRUTH_ORIF_EXPR, type,
9954 ffecom_2 (code, type,
9955 ffecom_1 (REALPART_EXPR, realtype,
9957 ffecom_1 (REALPART_EXPR, realtype,
9959 ffecom_2 (code, type,
9960 ffecom_1 (IMAGPART_EXPR, realtype,
9962 ffecom_1 (IMAGPART_EXPR, realtype,
9967 item = build (code, type, node1, node2);
9971 if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9972 TREE_SIDE_EFFECTS (item) = 1;
9977 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9979 ffesymbol s; // the ENTRY point itself
9980 if (ffecom_2pass_advise_entrypoint(s))
9981 // the ENTRY point has been accepted
9983 Does whatever compiler needs to do when it learns about the entrypoint,
9984 like determine the return type of the master function, count the
9985 number of entrypoints, etc. Returns FALSE if the return type is
9986 not compatible with the return type(s) of other entrypoint(s).
9988 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9989 later (after _finish_progunit) be called with the same entrypoint(s)
9990 as passed to this fn for which TRUE was returned.
9993 Return FALSE if the return type conflicts with previous entrypoints. */
9995 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9997 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9999 ffebld list; /* opITEM. */
10000 ffebld mlist; /* opITEM. */
10001 ffebld plist; /* opITEM. */
10002 ffebld arg; /* ffebld_head(opITEM). */
10003 ffebld item; /* opITEM. */
10004 ffesymbol s; /* ffebld_symter(arg). */
10005 ffeinfoBasictype bt = ffesymbol_basictype (entry);
10006 ffeinfoKindtype kt = ffesymbol_kindtype (entry);
10007 ffetargetCharacterSize size = ffesymbol_size (entry);
10010 if (ffecom_num_entrypoints_ == 0)
10011 { /* First entrypoint, make list of main
10012 arglist's dummies. */
10013 assert (ffecom_primary_entry_ != NULL);
10015 ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
10016 ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
10017 ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
10019 for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
10021 list = ffebld_trail (list))
10023 arg = ffebld_head (list);
10024 if (ffebld_op (arg) != FFEBLD_opSYMTER)
10025 continue; /* Alternate return or some such thing. */
10026 item = ffebld_new_item (arg, NULL);
10028 ffecom_master_arglist_ = item;
10030 ffebld_set_trail (plist, item);
10035 /* If necessary, scan entry arglist for alternate returns. Do this scan
10036 apparently redundantly (it's done below to UNIONize the arglists) so
10037 that we don't complain about RETURN 1 if an offending ENTRY is the only
10038 one with an alternate return. */
10040 if (!ffecom_is_altreturning_)
10042 for (list = ffesymbol_dummyargs (entry);
10044 list = ffebld_trail (list))
10046 arg = ffebld_head (list);
10047 if (ffebld_op (arg) == FFEBLD_opSTAR)
10049 ffecom_is_altreturning_ = TRUE;
10055 /* Now check type compatibility. */
10057 switch (ffecom_master_bt_)
10059 case FFEINFO_basictypeNONE:
10060 ok = (bt != FFEINFO_basictypeCHARACTER);
10063 case FFEINFO_basictypeCHARACTER:
10065 = (bt == FFEINFO_basictypeCHARACTER)
10066 && (kt == ffecom_master_kt_)
10067 && (size == ffecom_master_size_);
10070 case FFEINFO_basictypeANY:
10071 return FALSE; /* Just don't bother. */
10074 if (bt == FFEINFO_basictypeCHARACTER)
10080 if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10082 ffecom_master_bt_ = FFEINFO_basictypeNONE;
10083 ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10090 ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10091 ffest_ffebad_here_current_stmt (0);
10093 return FALSE; /* Can't handle entrypoint. */
10096 /* Entrypoint type compatible with previous types. */
10098 ++ffecom_num_entrypoints_;
10100 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10102 for (list = ffesymbol_dummyargs (entry);
10104 list = ffebld_trail (list))
10106 arg = ffebld_head (list);
10107 if (ffebld_op (arg) != FFEBLD_opSYMTER)
10108 continue; /* Alternate return or some such thing. */
10109 s = ffebld_symter (arg);
10110 for (plist = NULL, mlist = ffecom_master_arglist_;
10112 plist = mlist, mlist = ffebld_trail (mlist))
10113 { /* plist points to previous item for easy
10114 appending of arg. */
10115 if (ffebld_symter (ffebld_head (mlist)) == s)
10116 break; /* Already have this arg in the master list. */
10119 continue; /* Already have this arg in the master list. */
10121 /* Append this arg to the master list. */
10123 item = ffebld_new_item (arg, NULL);
10125 ffecom_master_arglist_ = item;
10127 ffebld_set_trail (plist, item);
10134 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10136 ffesymbol s; // the ENTRY point itself
10137 ffecom_2pass_do_entrypoint(s);
10139 Does whatever compiler needs to do to make the entrypoint actually
10140 happen. Must be called for each entrypoint after
10141 ffecom_finish_progunit is called. */
10143 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10145 ffecom_2pass_do_entrypoint (ffesymbol entry)
10147 static int mfn_num = 0;
10148 static int ent_num;
10150 if (mfn_num != ffecom_num_fns_)
10151 { /* First entrypoint for this program unit. */
10153 mfn_num = ffecom_num_fns_;
10154 ffecom_do_entry_ (ffecom_primary_entry_, 0);
10159 --ffecom_num_entrypoints_;
10161 ffecom_do_entry_ (entry, ent_num);
10166 /* Essentially does a "fold (build (code, type, node1, node2))" while
10167 checking for certain housekeeping things. Always sets
10168 TREE_SIDE_EFFECTS. */
10170 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10172 ffecom_2s (enum tree_code code, tree type, tree node1,
10177 if ((node1 == error_mark_node)
10178 || (node2 == error_mark_node)
10179 || (type == error_mark_node))
10180 return error_mark_node;
10182 item = build (code, type, node1, node2);
10183 TREE_SIDE_EFFECTS (item) = 1;
10184 return fold (item);
10188 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10189 checking for certain housekeeping things. */
10191 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10193 ffecom_3 (enum tree_code code, tree type, tree node1,
10194 tree node2, tree node3)
10198 if ((node1 == error_mark_node)
10199 || (node2 == error_mark_node)
10200 || (node3 == error_mark_node)
10201 || (type == error_mark_node))
10202 return error_mark_node;
10204 item = build (code, type, node1, node2, node3);
10205 if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10206 || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10207 TREE_SIDE_EFFECTS (item) = 1;
10208 return fold (item);
10212 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10213 checking for certain housekeeping things. Always sets
10214 TREE_SIDE_EFFECTS. */
10216 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10218 ffecom_3s (enum tree_code code, tree type, tree node1,
10219 tree node2, tree node3)
10223 if ((node1 == error_mark_node)
10224 || (node2 == error_mark_node)
10225 || (node3 == error_mark_node)
10226 || (type == error_mark_node))
10227 return error_mark_node;
10229 item = build (code, type, node1, node2, node3);
10230 TREE_SIDE_EFFECTS (item) = 1;
10231 return fold (item);
10236 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10238 See use by ffecom_list_expr.
10240 If expression is NULL, returns an integer zero tree. If it is not
10241 a CHARACTER expression, returns whatever ffecom_expr
10242 returns and sets the length return value to NULL_TREE. Otherwise
10243 generates code to evaluate the character expression, returns the proper
10244 pointer to the result, but does NOT set the length return value to a tree
10245 that specifies the length of the result. (In other words, the length
10246 variable is always set to NULL_TREE, because a length is never passed.)
10249 Don't set returned length, since nobody needs it (yet; someday if
10250 we allow CHARACTER*(*) dummies to statement functions, we'll need
10253 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10255 ffecom_arg_expr (ffebld expr, tree *length)
10259 *length = NULL_TREE;
10262 return integer_zero_node;
10264 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10265 return ffecom_expr (expr);
10267 return ffecom_arg_ptr_to_expr (expr, &ign);
10271 /* Transform expression into constant argument-pointer-to-expression tree.
10273 If the expression can be transformed into a argument-pointer-to-expression
10274 tree that is constant, that is done, and the tree returned. Else
10275 NULL_TREE is returned.
10277 That way, a caller can attempt to provide compile-time initialization
10278 of a variable and, if that fails, *then* choose to start a new block
10279 and resort to using temporaries, as appropriate. */
10282 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10285 return integer_zero_node;
10287 if (ffebld_op (expr) == FFEBLD_opANY)
10290 *length = error_mark_node;
10291 return error_mark_node;
10294 if (ffebld_arity (expr) == 0
10295 && (ffebld_op (expr) != FFEBLD_opSYMTER
10296 || ffebld_where (expr) == FFEINFO_whereCOMMON
10297 || ffebld_where (expr) == FFEINFO_whereGLOBAL
10298 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10302 t = ffecom_arg_ptr_to_expr (expr, length);
10303 assert (TREE_CONSTANT (t));
10304 assert (! length || TREE_CONSTANT (*length));
10309 && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10310 *length = build_int_2 (ffebld_size (expr), 0);
10312 *length = NULL_TREE;
10316 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10318 See use by ffecom_list_ptr_to_expr.
10320 If expression is NULL, returns an integer zero tree. If it is not
10321 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10322 returns and sets the length return value to NULL_TREE. Otherwise
10323 generates code to evaluate the character expression, returns the proper
10324 pointer to the result, AND sets the length return value to a tree that
10325 specifies the length of the result.
10327 If the length argument is NULL, this is a slightly special
10328 case of building a FORMAT expression, that is, an expression that
10329 will be used at run time without regard to length. For the current
10330 implementation, which uses the libf2c library, this means it is nice
10331 to append a null byte to the end of the expression, where feasible,
10332 to make sure any diagnostic about the FORMAT string terminates at
10335 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10336 length argument. This might even be seen as a feature, if a null
10337 byte can always be appended. */
10339 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10341 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10345 ffecomConcatList_ catlist;
10347 if (length != NULL)
10348 *length = NULL_TREE;
10351 return integer_zero_node;
10353 switch (ffebld_op (expr))
10355 case FFEBLD_opPERCENT_VAL:
10356 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10357 return ffecom_expr (ffebld_left (expr));
10362 temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10363 if (temp_exp == error_mark_node)
10364 return error_mark_node;
10366 return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10370 case FFEBLD_opPERCENT_REF:
10371 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10372 return ffecom_ptr_to_expr (ffebld_left (expr));
10373 if (length != NULL)
10375 ign_length = NULL_TREE;
10376 length = &ign_length;
10378 expr = ffebld_left (expr);
10381 case FFEBLD_opPERCENT_DESCR:
10382 switch (ffeinfo_basictype (ffebld_info (expr)))
10384 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10385 case FFEINFO_basictypeHOLLERITH:
10387 case FFEINFO_basictypeCHARACTER:
10388 break; /* Passed by descriptor anyway. */
10391 item = ffecom_ptr_to_expr (expr);
10392 if (item != error_mark_node)
10393 *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10402 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10403 if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10404 && (length != NULL))
10405 { /* Pass Hollerith by descriptor. */
10406 ffetargetHollerith h;
10408 assert (ffebld_op (expr) == FFEBLD_opCONTER);
10409 h = ffebld_cu_val_hollerith (ffebld_constant_union
10410 (ffebld_conter (expr)));
10412 = build_int_2 (h.length, 0);
10413 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10417 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10418 return ffecom_ptr_to_expr (expr);
10420 assert (ffeinfo_kindtype (ffebld_info (expr))
10421 == FFEINFO_kindtypeCHARACTER1);
10423 while (ffebld_op (expr) == FFEBLD_opPAREN)
10424 expr = ffebld_left (expr);
10426 catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10427 switch (ffecom_concat_list_count_ (catlist))
10429 case 0: /* Shouldn't happen, but in case it does... */
10430 if (length != NULL)
10432 *length = ffecom_f2c_ftnlen_zero_node;
10433 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10435 ffecom_concat_list_kill_ (catlist);
10436 return null_pointer_node;
10438 case 1: /* The (fairly) easy case. */
10439 if (length == NULL)
10440 ffecom_char_args_with_null_ (&item, &ign_length,
10441 ffecom_concat_list_expr_ (catlist, 0));
10443 ffecom_char_args_ (&item, length,
10444 ffecom_concat_list_expr_ (catlist, 0));
10445 ffecom_concat_list_kill_ (catlist);
10446 assert (item != NULL_TREE);
10449 default: /* Must actually concatenate things. */
10454 int count = ffecom_concat_list_count_ (catlist);
10465 ffetargetCharacterSize sz;
10467 sz = ffecom_concat_list_maxlen_ (catlist);
10469 assert (sz != FFETARGET_charactersizeNONE);
10474 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10475 FFETARGET_charactersizeNONE, count, TRUE);
10478 = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10479 FFETARGET_charactersizeNONE, count, TRUE);
10480 temporary = ffecom_push_tempvar (char_type_node,
10486 hook = ffebld_nonter_hook (expr);
10488 assert (TREE_CODE (hook) == TREE_VEC);
10489 assert (TREE_VEC_LENGTH (hook) == 3);
10490 length_array = lengths = TREE_VEC_ELT (hook, 0);
10491 item_array = items = TREE_VEC_ELT (hook, 1);
10492 temporary = TREE_VEC_ELT (hook, 2);
10496 known_length = ffecom_f2c_ftnlen_zero_node;
10498 for (i = 0; i < count; ++i)
10501 && (length == NULL))
10502 ffecom_char_args_with_null_ (&citem, &clength,
10503 ffecom_concat_list_expr_ (catlist, i));
10505 ffecom_char_args_ (&citem, &clength,
10506 ffecom_concat_list_expr_ (catlist, i));
10507 if ((citem == error_mark_node)
10508 || (clength == error_mark_node))
10510 ffecom_concat_list_kill_ (catlist);
10511 *length = error_mark_node;
10512 return error_mark_node;
10516 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10517 ffecom_modify (void_type_node,
10518 ffecom_2 (ARRAY_REF,
10519 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10521 build_int_2 (i, 0)),
10524 clength = ffecom_save_tree (clength);
10525 if (length != NULL)
10527 = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10531 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10532 ffecom_modify (void_type_node,
10533 ffecom_2 (ARRAY_REF,
10534 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10536 build_int_2 (i, 0)),
10541 temporary = ffecom_1 (ADDR_EXPR,
10542 build_pointer_type (TREE_TYPE (temporary)),
10545 item = build_tree_list (NULL_TREE, temporary);
10547 = build_tree_list (NULL_TREE,
10548 ffecom_1 (ADDR_EXPR,
10549 build_pointer_type (TREE_TYPE (items)),
10551 TREE_CHAIN (TREE_CHAIN (item))
10552 = build_tree_list (NULL_TREE,
10553 ffecom_1 (ADDR_EXPR,
10554 build_pointer_type (TREE_TYPE (lengths)),
10556 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10559 ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10560 convert (ffecom_f2c_ftnlen_type_node,
10561 build_int_2 (count, 0))));
10562 num = build_int_2 (sz, 0);
10563 TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10564 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10565 = build_tree_list (NULL_TREE, num);
10567 item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10568 TREE_SIDE_EFFECTS (item) = 1;
10569 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10573 if (length != NULL)
10574 *length = known_length;
10577 ffecom_concat_list_kill_ (catlist);
10578 assert (item != NULL_TREE);
10583 /* Generate call to run-time function.
10585 The first arg is the GNU Fortran Run-Time function index, the second
10586 arg is the list of arguments to pass to it. Returned is the expression
10587 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10588 result (which may be void). */
10590 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10592 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10594 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10595 ffecom_gfrt_kindtype (ix),
10596 ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10597 NULL_TREE, args, NULL_TREE, NULL,
10598 NULL, NULL_TREE, TRUE, hook);
10602 /* Transform constant-union to tree. */
10604 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10606 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10607 ffeinfoKindtype kt, tree tree_type)
10613 case FFEINFO_basictypeINTEGER:
10619 #if FFETARGET_okINTEGER1
10620 case FFEINFO_kindtypeINTEGER1:
10621 val = ffebld_cu_val_integer1 (*cu);
10625 #if FFETARGET_okINTEGER2
10626 case FFEINFO_kindtypeINTEGER2:
10627 val = ffebld_cu_val_integer2 (*cu);
10631 #if FFETARGET_okINTEGER3
10632 case FFEINFO_kindtypeINTEGER3:
10633 val = ffebld_cu_val_integer3 (*cu);
10637 #if FFETARGET_okINTEGER4
10638 case FFEINFO_kindtypeINTEGER4:
10639 val = ffebld_cu_val_integer4 (*cu);
10644 assert ("bad INTEGER constant kind type" == NULL);
10645 /* Fall through. */
10646 case FFEINFO_kindtypeANY:
10647 return error_mark_node;
10649 item = build_int_2 (val, (val < 0) ? -1 : 0);
10650 TREE_TYPE (item) = tree_type;
10654 case FFEINFO_basictypeLOGICAL:
10660 #if FFETARGET_okLOGICAL1
10661 case FFEINFO_kindtypeLOGICAL1:
10662 val = ffebld_cu_val_logical1 (*cu);
10666 #if FFETARGET_okLOGICAL2
10667 case FFEINFO_kindtypeLOGICAL2:
10668 val = ffebld_cu_val_logical2 (*cu);
10672 #if FFETARGET_okLOGICAL3
10673 case FFEINFO_kindtypeLOGICAL3:
10674 val = ffebld_cu_val_logical3 (*cu);
10678 #if FFETARGET_okLOGICAL4
10679 case FFEINFO_kindtypeLOGICAL4:
10680 val = ffebld_cu_val_logical4 (*cu);
10685 assert ("bad LOGICAL constant kind type" == NULL);
10686 /* Fall through. */
10687 case FFEINFO_kindtypeANY:
10688 return error_mark_node;
10690 item = build_int_2 (val, (val < 0) ? -1 : 0);
10691 TREE_TYPE (item) = tree_type;
10695 case FFEINFO_basictypeREAL:
10697 REAL_VALUE_TYPE val;
10701 #if FFETARGET_okREAL1
10702 case FFEINFO_kindtypeREAL1:
10703 val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10707 #if FFETARGET_okREAL2
10708 case FFEINFO_kindtypeREAL2:
10709 val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10713 #if FFETARGET_okREAL3
10714 case FFEINFO_kindtypeREAL3:
10715 val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10719 #if FFETARGET_okREAL4
10720 case FFEINFO_kindtypeREAL4:
10721 val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10726 assert ("bad REAL constant kind type" == NULL);
10727 /* Fall through. */
10728 case FFEINFO_kindtypeANY:
10729 return error_mark_node;
10731 item = build_real (tree_type, val);
10735 case FFEINFO_basictypeCOMPLEX:
10737 REAL_VALUE_TYPE real;
10738 REAL_VALUE_TYPE imag;
10739 tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10743 #if FFETARGET_okCOMPLEX1
10744 case FFEINFO_kindtypeREAL1:
10745 real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10746 imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10750 #if FFETARGET_okCOMPLEX2
10751 case FFEINFO_kindtypeREAL2:
10752 real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10753 imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10757 #if FFETARGET_okCOMPLEX3
10758 case FFEINFO_kindtypeREAL3:
10759 real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10760 imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10764 #if FFETARGET_okCOMPLEX4
10765 case FFEINFO_kindtypeREAL4:
10766 real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10767 imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10772 assert ("bad REAL constant kind type" == NULL);
10773 /* Fall through. */
10774 case FFEINFO_kindtypeANY:
10775 return error_mark_node;
10777 item = ffecom_build_complex_constant_ (tree_type,
10778 build_real (el_type, real),
10779 build_real (el_type, imag));
10783 case FFEINFO_basictypeCHARACTER:
10784 { /* Happens only in DATA and similar contexts. */
10785 ffetargetCharacter1 val;
10789 #if FFETARGET_okCHARACTER1
10790 case FFEINFO_kindtypeLOGICAL1:
10791 val = ffebld_cu_val_character1 (*cu);
10796 assert ("bad CHARACTER constant kind type" == NULL);
10797 /* Fall through. */
10798 case FFEINFO_kindtypeANY:
10799 return error_mark_node;
10801 item = build_string (ffetarget_length_character1 (val),
10802 ffetarget_text_character1 (val));
10804 = build_type_variant (build_array_type (char_type_node,
10806 (integer_type_node,
10809 (ffetarget_length_character1
10815 case FFEINFO_basictypeHOLLERITH:
10817 ffetargetHollerith h;
10819 h = ffebld_cu_val_hollerith (*cu);
10821 /* If not at least as wide as default INTEGER, widen it. */
10822 if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10823 item = build_string (h.length, h.text);
10826 char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10828 memcpy (str, h.text, h.length);
10829 memset (&str[h.length], ' ',
10830 FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10832 item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10836 = build_type_variant (build_array_type (char_type_node,
10838 (integer_type_node,
10846 case FFEINFO_basictypeTYPELESS:
10848 ffetargetInteger1 ival;
10849 ffetargetTypeless tless;
10852 tless = ffebld_cu_val_typeless (*cu);
10853 error = ffetarget_convert_integer1_typeless (&ival, tless);
10854 assert (error == FFEBAD);
10856 item = build_int_2 ((int) ival, 0);
10861 assert ("not yet on constant type" == NULL);
10862 /* Fall through. */
10863 case FFEINFO_basictypeANY:
10864 return error_mark_node;
10867 TREE_CONSTANT (item) = 1;
10874 /* Transform expression into constant tree.
10876 If the expression can be transformed into a tree that is constant,
10877 that is done, and the tree returned. Else NULL_TREE is returned.
10879 That way, a caller can attempt to provide compile-time initialization
10880 of a variable and, if that fails, *then* choose to start a new block
10881 and resort to using temporaries, as appropriate. */
10884 ffecom_const_expr (ffebld expr)
10887 return integer_zero_node;
10889 if (ffebld_op (expr) == FFEBLD_opANY)
10890 return error_mark_node;
10892 if (ffebld_arity (expr) == 0
10893 && (ffebld_op (expr) != FFEBLD_opSYMTER
10895 /* ~~Enable once common/equivalence is handled properly? */
10896 || ffebld_where (expr) == FFEINFO_whereCOMMON
10898 || ffebld_where (expr) == FFEINFO_whereGLOBAL
10899 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10903 t = ffecom_expr (expr);
10904 assert (TREE_CONSTANT (t));
10911 /* Handy way to make a field in a struct/union. */
10913 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10915 ffecom_decl_field (tree context, tree prevfield,
10916 const char *name, tree type)
10920 field = build_decl (FIELD_DECL, get_identifier (name), type);
10921 DECL_CONTEXT (field) = context;
10922 DECL_ALIGN (field) = 0;
10923 DECL_USER_ALIGN (field) = 0;
10924 if (prevfield != NULL_TREE)
10925 TREE_CHAIN (prevfield) = field;
10933 ffecom_close_include (FILE *f)
10935 #if FFECOM_GCC_INCLUDE
10936 ffecom_close_include_ (f);
10941 ffecom_decode_include_option (char *spec)
10943 #if FFECOM_GCC_INCLUDE
10944 return ffecom_decode_include_option_ (spec);
10950 /* End a compound statement (block). */
10952 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10954 ffecom_end_compstmt (void)
10956 return bison_rule_compstmt_ ();
10958 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
10960 /* ffecom_end_transition -- Perform end transition on all symbols
10962 ffecom_end_transition();
10964 Calls ffecom_sym_end_transition for each global and local symbol. */
10967 ffecom_end_transition ()
10969 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10973 if (ffe_is_ffedebug ())
10974 fprintf (dmpout, "; end_stmt_transition\n");
10976 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10977 ffecom_list_blockdata_ = NULL;
10978 ffecom_list_common_ = NULL;
10981 ffesymbol_drive (ffecom_sym_end_transition);
10982 if (ffe_is_ffedebug ())
10984 ffestorag_report ();
10985 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10986 ffesymbol_report_all ();
10990 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10991 ffecom_start_progunit_ ();
10993 for (item = ffecom_list_blockdata_;
10995 item = ffebld_trail (item))
11002 static int number = 0;
11004 callee = ffebld_head (item);
11005 s = ffebld_symter (callee);
11006 t = ffesymbol_hook (s).decl_tree;
11007 if (t == NULL_TREE)
11009 s = ffecom_sym_transform_ (s);
11010 t = ffesymbol_hook (s).decl_tree;
11013 dt = build_pointer_type (TREE_TYPE (t));
11015 var = build_decl (VAR_DECL,
11016 ffecom_get_invented_identifier ("__g77_forceload_%d",
11019 DECL_EXTERNAL (var) = 0;
11020 TREE_STATIC (var) = 1;
11021 TREE_PUBLIC (var) = 0;
11022 DECL_INITIAL (var) = error_mark_node;
11023 TREE_USED (var) = 1;
11025 var = start_decl (var, FALSE);
11027 t = ffecom_1 (ADDR_EXPR, dt, t);
11029 finish_decl (var, t, FALSE);
11032 /* This handles any COMMON areas that weren't referenced but have, for
11033 example, important initial data. */
11035 for (item = ffecom_list_common_;
11037 item = ffebld_trail (item))
11038 ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
11040 ffecom_list_common_ = NULL;
11044 /* ffecom_exec_transition -- Perform exec transition on all symbols
11046 ffecom_exec_transition();
11048 Calls ffecom_sym_exec_transition for each global and local symbol.
11049 Make sure error updating not inhibited. */
11052 ffecom_exec_transition ()
11056 if (ffe_is_ffedebug ())
11057 fprintf (dmpout, "; exec_stmt_transition\n");
11059 inhibited = ffebad_inhibit ();
11060 ffebad_set_inhibit (FALSE);
11062 ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
11063 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
11064 if (ffe_is_ffedebug ())
11066 ffestorag_report ();
11067 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11068 ffesymbol_report_all ();
11073 ffebad_set_inhibit (TRUE);
11076 /* Handle assignment statement.
11078 Convert dest and source using ffecom_expr, then join them
11079 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
11081 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11083 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11090 if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11095 /* This attempts to replicate the test below, but must not be
11096 true when the test below is false. (Always err on the side
11097 of creating unused temporaries, to avoid ICEs.) */
11098 if (ffebld_op (dest) != FFEBLD_opSYMTER
11099 || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11100 && (TREE_CODE (dest_tree) != VAR_DECL
11101 || TREE_ADDRESSABLE (dest_tree))))
11103 ffecom_prepare_expr_ (source, dest);
11108 ffecom_prepare_expr_ (source, NULL);
11112 ffecom_prepare_expr_w (NULL_TREE, dest);
11114 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11115 create a temporary through which the assignment is to take place,
11116 since MODIFY_EXPR doesn't handle partial overlap properly. */
11117 if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11118 && ffecom_possible_partial_overlap_ (dest, source))
11120 assign_temp = ffecom_make_tempvar ("complex_let",
11122 [ffebld_basictype (dest)]
11123 [ffebld_kindtype (dest)],
11124 FFETARGET_charactersizeNONE,
11128 assign_temp = NULL_TREE;
11130 ffecom_prepare_end ();
11132 dest_tree = ffecom_expr_w (NULL_TREE, dest);
11133 if (dest_tree == error_mark_node)
11136 if ((TREE_CODE (dest_tree) != VAR_DECL)
11137 || TREE_ADDRESSABLE (dest_tree))
11138 source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11142 assert (! dest_used);
11144 source_tree = ffecom_expr (source);
11146 if (source_tree == error_mark_node)
11150 expr_tree = source_tree;
11151 else if (assign_temp)
11154 /* The back end understands a conceptual move (evaluate source;
11155 store into dest), so use that, in case it can determine
11156 that it is going to use, say, two registers as temporaries
11157 anyway. So don't use the temp (and someday avoid generating
11158 it, once this code starts triggering regularly). */
11159 expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11163 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11166 expand_expr_stmt (expr_tree);
11167 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11173 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11177 expand_expr_stmt (expr_tree);
11181 ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11182 ffecom_prepare_expr_w (NULL_TREE, dest);
11184 ffecom_prepare_end ();
11186 ffecom_char_args_ (&dest_tree, &dest_length, dest);
11187 ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11192 /* ffecom_expr -- Transform expr into gcc tree
11195 ffebld expr; // FFE expression.
11196 tree = ffecom_expr(expr);
11198 Recursive descent on expr while making corresponding tree nodes and
11199 attaching type info and such. */
11201 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11203 ffecom_expr (ffebld expr)
11205 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11209 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
11211 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11213 ffecom_expr_assign (ffebld expr)
11215 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11219 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
11221 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11223 ffecom_expr_assign_w (ffebld expr)
11225 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11229 /* Transform expr for use as into read/write tree and stabilize the
11230 reference. Not for use on CHARACTER expressions.
11232 Recursive descent on expr while making corresponding tree nodes and
11233 attaching type info and such. */
11235 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11237 ffecom_expr_rw (tree type, ffebld expr)
11239 assert (expr != NULL);
11240 /* Different target types not yet supported. */
11241 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11243 return stabilize_reference (ffecom_expr (expr));
11247 /* Transform expr for use as into write tree and stabilize the
11248 reference. Not for use on CHARACTER expressions.
11250 Recursive descent on expr while making corresponding tree nodes and
11251 attaching type info and such. */
11253 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11255 ffecom_expr_w (tree type, ffebld expr)
11257 assert (expr != NULL);
11258 /* Different target types not yet supported. */
11259 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11261 return stabilize_reference (ffecom_expr (expr));
11265 /* Do global stuff. */
11267 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11269 ffecom_finish_compile ()
11271 assert (ffecom_outer_function_decl_ == NULL_TREE);
11272 assert (current_function_decl == NULL_TREE);
11274 ffeglobal_drive (ffecom_finish_global_);
11278 /* Public entry point for front end to access finish_decl. */
11280 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11282 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11284 assert (!is_top_level);
11285 finish_decl (decl, init, FALSE);
11289 /* Finish a program unit. */
11291 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11293 ffecom_finish_progunit ()
11295 ffecom_end_compstmt ();
11297 ffecom_previous_function_decl_ = current_function_decl;
11298 ffecom_which_entrypoint_decl_ = NULL_TREE;
11300 finish_function (0);
11305 /* Wrapper for get_identifier. pattern is sprintf-like. */
11307 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11309 ffecom_get_invented_identifier (const char *pattern, ...)
11315 va_start (ap, pattern);
11316 if (vasprintf (&nam, pattern, ap) == 0)
11319 decl = get_identifier (nam);
11321 IDENTIFIER_INVENTED (decl) = 1;
11326 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11328 assert (gfrt < FFECOM_gfrt);
11330 switch (ffecom_gfrt_type_[gfrt])
11332 case FFECOM_rttypeVOID_:
11333 case FFECOM_rttypeVOIDSTAR_:
11334 return FFEINFO_basictypeNONE;
11336 case FFECOM_rttypeFTNINT_:
11337 return FFEINFO_basictypeINTEGER;
11339 case FFECOM_rttypeINTEGER_:
11340 return FFEINFO_basictypeINTEGER;
11342 case FFECOM_rttypeLONGINT_:
11343 return FFEINFO_basictypeINTEGER;
11345 case FFECOM_rttypeLOGICAL_:
11346 return FFEINFO_basictypeLOGICAL;
11348 case FFECOM_rttypeREAL_F2C_:
11349 case FFECOM_rttypeREAL_GNU_:
11350 return FFEINFO_basictypeREAL;
11352 case FFECOM_rttypeCOMPLEX_F2C_:
11353 case FFECOM_rttypeCOMPLEX_GNU_:
11354 return FFEINFO_basictypeCOMPLEX;
11356 case FFECOM_rttypeDOUBLE_:
11357 case FFECOM_rttypeDOUBLEREAL_:
11358 return FFEINFO_basictypeREAL;
11360 case FFECOM_rttypeDBLCMPLX_F2C_:
11361 case FFECOM_rttypeDBLCMPLX_GNU_:
11362 return FFEINFO_basictypeCOMPLEX;
11364 case FFECOM_rttypeCHARACTER_:
11365 return FFEINFO_basictypeCHARACTER;
11368 return FFEINFO_basictypeANY;
11373 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11375 assert (gfrt < FFECOM_gfrt);
11377 switch (ffecom_gfrt_type_[gfrt])
11379 case FFECOM_rttypeVOID_:
11380 case FFECOM_rttypeVOIDSTAR_:
11381 return FFEINFO_kindtypeNONE;
11383 case FFECOM_rttypeFTNINT_:
11384 return FFEINFO_kindtypeINTEGER1;
11386 case FFECOM_rttypeINTEGER_:
11387 return FFEINFO_kindtypeINTEGER1;
11389 case FFECOM_rttypeLONGINT_:
11390 return FFEINFO_kindtypeINTEGER4;
11392 case FFECOM_rttypeLOGICAL_:
11393 return FFEINFO_kindtypeLOGICAL1;
11395 case FFECOM_rttypeREAL_F2C_:
11396 case FFECOM_rttypeREAL_GNU_:
11397 return FFEINFO_kindtypeREAL1;
11399 case FFECOM_rttypeCOMPLEX_F2C_:
11400 case FFECOM_rttypeCOMPLEX_GNU_:
11401 return FFEINFO_kindtypeREAL1;
11403 case FFECOM_rttypeDOUBLE_:
11404 case FFECOM_rttypeDOUBLEREAL_:
11405 return FFEINFO_kindtypeREAL2;
11407 case FFECOM_rttypeDBLCMPLX_F2C_:
11408 case FFECOM_rttypeDBLCMPLX_GNU_:
11409 return FFEINFO_kindtypeREAL2;
11411 case FFECOM_rttypeCHARACTER_:
11412 return FFEINFO_kindtypeCHARACTER1;
11415 return FFEINFO_kindtypeANY;
11429 tree double_ftype_double;
11430 tree float_ftype_float;
11431 tree ldouble_ftype_ldouble;
11432 tree ffecom_tree_ptr_to_fun_type_void;
11434 /* This block of code comes from the now-obsolete cktyps.c. It checks
11435 whether the compiler environment is buggy in known ways, some of which
11436 would, if not explicitly checked here, result in subtle bugs in g77. */
11438 if (ffe_is_do_internal_checks ())
11440 static char names[][12]
11442 {"bar", "bletch", "foo", "foobar"};
11447 name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11448 (int (*)(const void *, const void *)) strcmp);
11449 if (name != (char *) &names[2])
11451 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11456 ul = strtoul ("123456789", NULL, 10);
11457 if (ul != 123456789L)
11459 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11460 in proj.h" == NULL);
11464 fl = atof ("56.789");
11465 if ((fl < 56.788) || (fl > 56.79))
11467 assert ("atof not type double, fix your #include <stdio.h>"
11473 #if FFECOM_GCC_INCLUDE
11474 ffecom_initialize_char_syntax_ ();
11477 ffecom_outer_function_decl_ = NULL_TREE;
11478 current_function_decl = NULL_TREE;
11479 named_labels = NULL_TREE;
11480 current_binding_level = NULL_BINDING_LEVEL;
11481 free_binding_level = NULL_BINDING_LEVEL;
11482 /* Make the binding_level structure for global names. */
11484 global_binding_level = current_binding_level;
11485 current_binding_level->prep_state = 2;
11487 build_common_tree_nodes (1);
11489 /* Define `int' and `char' first so that dbx will output them first. */
11490 pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11491 integer_type_node));
11492 pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11494 pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11495 long_integer_type_node));
11496 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11497 unsigned_type_node));
11498 pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11499 long_unsigned_type_node));
11500 pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11501 long_long_integer_type_node));
11502 pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11503 long_long_unsigned_type_node));
11504 pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11505 short_integer_type_node));
11506 pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11507 short_unsigned_type_node));
11509 /* Set the sizetype before we make other types. This *should* be the
11510 first type we create. */
11513 (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11514 ffecom_typesize_pointer_
11515 = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11517 build_common_tree_nodes_2 (0);
11519 /* Define both `signed char' and `unsigned char'. */
11520 pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11521 signed_char_type_node));
11523 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11524 unsigned_char_type_node));
11526 pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11528 pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11529 double_type_node));
11530 pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11531 long_double_type_node));
11533 /* For now, override what build_common_tree_nodes has done. */
11534 complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11535 complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11536 complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11537 complex_long_double_type_node
11538 = ffecom_make_complex_type_ (long_double_type_node);
11540 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11541 complex_integer_type_node));
11542 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11543 complex_float_type_node));
11544 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11545 complex_double_type_node));
11546 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11547 complex_long_double_type_node));
11549 pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11551 /* We are not going to have real types in C with less than byte alignment,
11552 so we might as well not have any types that claim to have it. */
11553 TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11554 TYPE_USER_ALIGN (void_type_node) = 0;
11556 string_type_node = build_pointer_type (char_type_node);
11558 ffecom_tree_fun_type_void
11559 = build_function_type (void_type_node, NULL_TREE);
11561 ffecom_tree_ptr_to_fun_type_void
11562 = build_pointer_type (ffecom_tree_fun_type_void);
11564 endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11567 = build_function_type (float_type_node,
11568 tree_cons (NULL_TREE, float_type_node, endlink));
11570 double_ftype_double
11571 = build_function_type (double_type_node,
11572 tree_cons (NULL_TREE, double_type_node, endlink));
11574 ldouble_ftype_ldouble
11575 = build_function_type (long_double_type_node,
11576 tree_cons (NULL_TREE, long_double_type_node,
11579 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11580 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11582 ffecom_tree_type[i][j] = NULL_TREE;
11583 ffecom_tree_fun_type[i][j] = NULL_TREE;
11584 ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11585 ffecom_f2c_typecode_[i][j] = -1;
11588 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11589 to size FLOAT_TYPE_SIZE because they have to be the same size as
11590 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11591 Compiler options and other such stuff that change the ways these
11592 types are set should not affect this particular setup. */
11594 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11595 = t = make_signed_type (FLOAT_TYPE_SIZE);
11596 pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11598 type = ffetype_new ();
11600 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11602 ffetype_set_ams (type,
11603 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11604 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11605 ffetype_set_star (base_type,
11606 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11608 ffetype_set_kind (base_type, 1, type);
11609 ffecom_typesize_integer1_ = ffetype_size (type);
11610 assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11612 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11613 = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11614 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11617 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11618 = t = make_signed_type (CHAR_TYPE_SIZE);
11619 pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11621 type = ffetype_new ();
11622 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11624 ffetype_set_ams (type,
11625 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11626 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11627 ffetype_set_star (base_type,
11628 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11630 ffetype_set_kind (base_type, 3, type);
11631 assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11633 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11634 = t = make_unsigned_type (CHAR_TYPE_SIZE);
11635 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11638 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11639 = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11640 pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11642 type = ffetype_new ();
11643 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11645 ffetype_set_ams (type,
11646 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11647 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11648 ffetype_set_star (base_type,
11649 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11651 ffetype_set_kind (base_type, 6, type);
11652 assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11654 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11655 = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11656 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11659 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11660 = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11661 pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11663 type = ffetype_new ();
11664 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11666 ffetype_set_ams (type,
11667 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11668 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11669 ffetype_set_star (base_type,
11670 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11672 ffetype_set_kind (base_type, 2, type);
11673 assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11675 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11676 = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11677 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11681 if (ffe_is_do_internal_checks ()
11682 && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11683 && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11684 && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11685 && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11687 fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11692 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11693 = t = make_signed_type (FLOAT_TYPE_SIZE);
11694 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11696 type = ffetype_new ();
11698 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11700 ffetype_set_ams (type,
11701 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11702 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11703 ffetype_set_star (base_type,
11704 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11706 ffetype_set_kind (base_type, 1, type);
11707 assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11709 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11710 = t = make_signed_type (CHAR_TYPE_SIZE);
11711 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11713 type = ffetype_new ();
11714 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11716 ffetype_set_ams (type,
11717 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11718 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11719 ffetype_set_star (base_type,
11720 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11722 ffetype_set_kind (base_type, 3, type);
11723 assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11725 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11726 = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11727 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11729 type = ffetype_new ();
11730 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11732 ffetype_set_ams (type,
11733 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11734 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11735 ffetype_set_star (base_type,
11736 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11738 ffetype_set_kind (base_type, 6, type);
11739 assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11741 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11742 = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11743 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11745 type = ffetype_new ();
11746 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11748 ffetype_set_ams (type,
11749 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11750 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11751 ffetype_set_star (base_type,
11752 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11754 ffetype_set_kind (base_type, 2, type);
11755 assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11757 ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11758 = t = make_node (REAL_TYPE);
11759 TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11760 pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11763 type = ffetype_new ();
11765 ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11767 ffetype_set_ams (type,
11768 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11769 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11770 ffetype_set_star (base_type,
11771 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11773 ffetype_set_kind (base_type, 1, type);
11774 ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11775 = FFETARGET_f2cTYREAL;
11776 assert (ffetype_size (type) == sizeof (ffetargetReal1));
11778 ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11779 = t = make_node (REAL_TYPE);
11780 TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2; /* Always twice REAL. */
11781 pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11784 type = ffetype_new ();
11785 ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11787 ffetype_set_ams (type,
11788 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11789 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11790 ffetype_set_star (base_type,
11791 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11793 ffetype_set_kind (base_type, 2, type);
11794 ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11795 = FFETARGET_f2cTYDREAL;
11796 assert (ffetype_size (type) == sizeof (ffetargetReal2));
11798 ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11799 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11800 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11802 type = ffetype_new ();
11804 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11806 ffetype_set_ams (type,
11807 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11808 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11809 ffetype_set_star (base_type,
11810 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11812 ffetype_set_kind (base_type, 1, type);
11813 ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11814 = FFETARGET_f2cTYCOMPLEX;
11815 assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11817 ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11818 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11819 pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11821 type = ffetype_new ();
11822 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11824 ffetype_set_ams (type,
11825 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11826 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11827 ffetype_set_star (base_type,
11828 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11830 ffetype_set_kind (base_type, 2,
11832 ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11833 = FFETARGET_f2cTYDCOMPLEX;
11834 assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11836 /* Make function and ptr-to-function types for non-CHARACTER types. */
11838 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11839 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11841 if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11843 if (i == FFEINFO_basictypeINTEGER)
11845 /* Figure out the smallest INTEGER type that can hold
11846 a pointer on this machine. */
11847 if (GET_MODE_SIZE (TYPE_MODE (t))
11848 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11850 if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11851 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11852 > GET_MODE_SIZE (TYPE_MODE (t))))
11853 ffecom_pointer_kind_ = j;
11856 else if (i == FFEINFO_basictypeCOMPLEX)
11857 t = void_type_node;
11858 /* For f2c compatibility, REAL functions are really
11859 implemented as DOUBLE PRECISION. */
11860 else if ((i == FFEINFO_basictypeREAL)
11861 && (j == FFEINFO_kindtypeREAL1))
11862 t = ffecom_tree_type
11863 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11865 t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11867 ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11871 /* Set up pointer types. */
11873 if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11874 fatal ("no INTEGER type can hold a pointer on this configuration");
11875 else if (0 && ffe_is_do_internal_checks ())
11876 fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11877 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11878 FFEINFO_kindtypeINTEGERDEFAULT),
11880 ffeinfo_type (FFEINFO_basictypeINTEGER,
11881 ffecom_pointer_kind_));
11883 if (ffe_is_ugly_assign ())
11884 ffecom_label_kind_ = ffecom_pointer_kind_; /* Require ASSIGN etc to this. */
11886 ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11887 if (0 && ffe_is_do_internal_checks ())
11888 fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11890 ffecom_integer_type_node
11891 = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11892 ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11893 integer_zero_node);
11894 ffecom_integer_one_node = convert (ffecom_integer_type_node,
11897 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11898 Turns out that by TYLONG, runtime/libI77/lio.h really means
11899 "whatever size an ftnint is". For consistency and sanity,
11900 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11901 all are INTEGER, which we also make out of whatever back-end
11902 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11903 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11904 accommodate machines like the Alpha. Note that this suggests
11905 f2c and libf2c are missing a distinction perhaps needed on
11906 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11908 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11909 FFETARGET_f2cTYLONG);
11910 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11911 FFETARGET_f2cTYSHORT);
11912 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11913 FFETARGET_f2cTYINT1);
11914 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11915 FFETARGET_f2cTYQUAD);
11916 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11917 FFETARGET_f2cTYLOGICAL);
11918 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11919 FFETARGET_f2cTYLOGICAL2);
11920 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11921 FFETARGET_f2cTYLOGICAL1);
11922 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11923 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11924 FFETARGET_f2cTYQUAD);
11926 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11927 loop. CHARACTER items are built as arrays of unsigned char. */
11929 ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11930 [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11931 type = ffetype_new ();
11933 ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11934 FFEINFO_kindtypeCHARACTER1,
11936 ffetype_set_ams (type,
11937 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11938 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11939 ffetype_set_kind (base_type, 1, type);
11940 assert (ffetype_size (type)
11941 == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11943 ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11944 [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11945 ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11946 [FFEINFO_kindtypeCHARACTER1]
11947 = ffecom_tree_ptr_to_fun_type_void;
11948 ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11949 = FFETARGET_f2cTYCHAR;
11951 ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11954 /* Make multi-return-value type and fields. */
11956 ffecom_multi_type_node_ = make_node (UNION_TYPE);
11960 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11961 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11965 if (ffecom_tree_type[i][j] == NULL_TREE)
11966 continue; /* Not supported. */
11967 sprintf (&name[0], "bt_%s_kt_%s",
11968 ffeinfo_basictype_string ((ffeinfoBasictype) i),
11969 ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11970 ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11971 get_identifier (name),
11972 ffecom_tree_type[i][j]);
11973 DECL_CONTEXT (ffecom_multi_fields_[i][j])
11974 = ffecom_multi_type_node_;
11975 DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11976 DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11977 TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11978 field = ffecom_multi_fields_[i][j];
11981 TYPE_FIELDS (ffecom_multi_type_node_) = field;
11982 layout_type (ffecom_multi_type_node_);
11984 /* Subroutines usually return integer because they might have alternate
11987 ffecom_tree_subr_type
11988 = build_function_type (integer_type_node, NULL_TREE);
11989 ffecom_tree_ptr_to_subr_type
11990 = build_pointer_type (ffecom_tree_subr_type);
11991 ffecom_tree_blockdata_type
11992 = build_function_type (void_type_node, NULL_TREE);
11994 builtin_function ("__builtin_sqrtf", float_ftype_float,
11995 BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
11996 builtin_function ("__builtin_fsqrt", double_ftype_double,
11997 BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
11998 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11999 BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
12000 builtin_function ("__builtin_sinf", float_ftype_float,
12001 BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
12002 builtin_function ("__builtin_sin", double_ftype_double,
12003 BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
12004 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
12005 BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
12006 builtin_function ("__builtin_cosf", float_ftype_float,
12007 BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
12008 builtin_function ("__builtin_cos", double_ftype_double,
12009 BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
12010 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
12011 BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
12014 pedantic_lvalues = FALSE;
12017 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
12020 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
12023 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
12026 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
12027 FFECOM_f2cDOUBLEREAL,
12029 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
12032 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
12033 FFECOM_f2cDOUBLECOMPLEX,
12035 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
12038 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
12041 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
12044 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
12047 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
12051 ffecom_f2c_ftnlen_zero_node
12052 = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
12054 ffecom_f2c_ftnlen_one_node
12055 = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
12057 ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
12058 TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
12060 ffecom_f2c_ptr_to_ftnlen_type_node
12061 = build_pointer_type (ffecom_f2c_ftnlen_type_node);
12063 ffecom_f2c_ptr_to_ftnint_type_node
12064 = build_pointer_type (ffecom_f2c_ftnint_type_node);
12066 ffecom_f2c_ptr_to_integer_type_node
12067 = build_pointer_type (ffecom_f2c_integer_type_node);
12069 ffecom_f2c_ptr_to_real_type_node
12070 = build_pointer_type (ffecom_f2c_real_type_node);
12072 ffecom_float_zero_ = build_real (float_type_node, dconst0);
12073 ffecom_double_zero_ = build_real (double_type_node, dconst0);
12075 REAL_VALUE_TYPE point_5;
12077 #ifdef REAL_ARITHMETIC
12078 REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12082 ffecom_float_half_ = build_real (float_type_node, point_5);
12083 ffecom_double_half_ = build_real (double_type_node, point_5);
12086 /* Do "extern int xargc;". */
12088 ffecom_tree_xargc_ = build_decl (VAR_DECL,
12089 get_identifier ("f__xargc"),
12090 integer_type_node);
12091 DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12092 TREE_STATIC (ffecom_tree_xargc_) = 1;
12093 TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12094 ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12095 finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12097 #if 0 /* This is being fixed, and seems to be working now. */
12098 if ((FLOAT_TYPE_SIZE != 32)
12099 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12101 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12102 (int) FLOAT_TYPE_SIZE);
12103 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12104 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12105 warning ("properly unless they all are 32 bits wide.");
12106 warning ("Please keep this in mind before you report bugs. g77 should");
12107 warning ("support non-32-bit machines better as of version 0.6.");
12111 #if 0 /* Code in ste.c that would crash has been commented out. */
12112 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12113 < TYPE_PRECISION (string_type_node))
12114 /* I/O will probably crash. */
12115 warning ("configuration: char * holds %d bits, but ftnlen only %d",
12116 TYPE_PRECISION (string_type_node),
12117 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12120 #if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
12121 if (TYPE_PRECISION (ffecom_integer_type_node)
12122 < TYPE_PRECISION (string_type_node))
12123 /* ASSIGN 10 TO I will crash. */
12124 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12125 ASSIGN statement might fail",
12126 TYPE_PRECISION (string_type_node),
12127 TYPE_PRECISION (ffecom_integer_type_node));
12132 /* ffecom_init_2 -- Initialize
12134 ffecom_init_2(); */
12136 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12140 assert (ffecom_outer_function_decl_ == NULL_TREE);
12141 assert (current_function_decl == NULL_TREE);
12142 assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12144 ffecom_master_arglist_ = NULL;
12146 ffecom_primary_entry_ = NULL;
12147 ffecom_is_altreturning_ = FALSE;
12148 ffecom_func_result_ = NULL_TREE;
12149 ffecom_multi_retval_ = NULL_TREE;
12153 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12156 ffebld expr; // FFE opITEM list.
12157 tree = ffecom_list_expr(expr);
12159 List of actual args is transformed into corresponding gcc backend list. */
12161 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12163 ffecom_list_expr (ffebld expr)
12166 tree *plist = &list;
12167 tree trail = NULL_TREE; /* Append char length args here. */
12168 tree *ptrail = &trail;
12171 while (expr != NULL)
12173 tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12175 if (texpr == error_mark_node)
12176 return error_mark_node;
12178 *plist = build_tree_list (NULL_TREE, texpr);
12179 plist = &TREE_CHAIN (*plist);
12180 expr = ffebld_trail (expr);
12181 if (length != NULL_TREE)
12183 *ptrail = build_tree_list (NULL_TREE, length);
12184 ptrail = &TREE_CHAIN (*ptrail);
12194 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12197 ffebld expr; // FFE opITEM list.
12198 tree = ffecom_list_ptr_to_expr(expr);
12200 List of actual args is transformed into corresponding gcc backend list for
12201 use in calling an external procedure (vs. a statement function). */
12203 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12205 ffecom_list_ptr_to_expr (ffebld expr)
12208 tree *plist = &list;
12209 tree trail = NULL_TREE; /* Append char length args here. */
12210 tree *ptrail = &trail;
12213 while (expr != NULL)
12215 tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12217 if (texpr == error_mark_node)
12218 return error_mark_node;
12220 *plist = build_tree_list (NULL_TREE, texpr);
12221 plist = &TREE_CHAIN (*plist);
12222 expr = ffebld_trail (expr);
12223 if (length != NULL_TREE)
12225 *ptrail = build_tree_list (NULL_TREE, length);
12226 ptrail = &TREE_CHAIN (*ptrail);
12236 /* Obtain gcc's LABEL_DECL tree for label. */
12238 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12240 ffecom_lookup_label (ffelab label)
12244 if (ffelab_hook (label) == NULL_TREE)
12246 char labelname[16];
12248 switch (ffelab_type (label))
12250 case FFELAB_typeLOOPEND:
12251 case FFELAB_typeNOTLOOP:
12252 case FFELAB_typeENDIF:
12253 sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12254 glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12256 DECL_CONTEXT (glabel) = current_function_decl;
12257 DECL_MODE (glabel) = VOIDmode;
12260 case FFELAB_typeFORMAT:
12261 glabel = build_decl (VAR_DECL,
12262 ffecom_get_invented_identifier
12263 ("__g77_format_%d", (int) ffelab_value (label)),
12264 build_type_variant (build_array_type
12268 TREE_CONSTANT (glabel) = 1;
12269 TREE_STATIC (glabel) = 1;
12270 DECL_CONTEXT (glabel) = 0;
12271 DECL_INITIAL (glabel) = NULL;
12272 make_decl_rtl (glabel, NULL, 0);
12273 expand_decl (glabel);
12275 ffecom_save_tree_forever (glabel);
12279 case FFELAB_typeANY:
12280 glabel = error_mark_node;
12284 assert ("bad label type" == NULL);
12288 ffelab_set_hook (label, glabel);
12292 glabel = ffelab_hook (label);
12299 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12300 a single source specification (as in the fourth argument of MVBITS).
12301 If the type is NULL_TREE, the type of lhs is used to make the type of
12302 the MODIFY_EXPR. */
12304 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12306 ffecom_modify (tree newtype, tree lhs,
12309 if (lhs == error_mark_node || rhs == error_mark_node)
12310 return error_mark_node;
12312 if (newtype == NULL_TREE)
12313 newtype = TREE_TYPE (lhs);
12315 if (TREE_SIDE_EFFECTS (lhs))
12316 lhs = stabilize_reference (lhs);
12318 return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12323 /* Register source file name. */
12326 ffecom_file (const char *name)
12328 #if FFECOM_GCC_INCLUDE
12329 ffecom_file_ (name);
12333 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12336 ffecom_notify_init_storage(st);
12338 Gets called when all possible units in an aggregate storage area (a LOCAL
12339 with equivalences or a COMMON) have been initialized. The initialization
12340 info either is in ffestorag_init or, if that is NULL,
12341 ffestorag_accretion:
12343 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12344 even for an array if the array is one element in length!
12346 ffestorag_accretion will contain an opACCTER. It is much like an
12347 opARRTER except it has an ffebit object in it instead of just a size.
12348 The back end can use the info in the ffebit object, if it wants, to
12349 reduce the amount of actual initialization, but in any case it should
12350 kill the ffebit object when done. Also, set accretion to NULL but
12351 init to a non-NULL value.
12353 After performing initialization, DO NOT set init to NULL, because that'll
12354 tell the front end it is ok for more initialization to happen. Instead,
12355 set init to an opANY expression or some such thing that you can use to
12356 tell that you've already initialized the object.
12359 Support two-pass FFE. */
12362 ffecom_notify_init_storage (ffestorag st)
12364 ffebld init; /* The initialization expression. */
12365 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12366 ffetargetOffset size; /* The size of the entity. */
12367 ffetargetAlign pad; /* Its initial padding. */
12370 if (ffestorag_init (st) == NULL)
12372 init = ffestorag_accretion (st);
12373 assert (init != NULL);
12374 ffestorag_set_accretion (st, NULL);
12375 ffestorag_set_accretes (st, 0);
12377 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12378 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12379 size = ffebld_accter_size (init);
12380 pad = ffebld_accter_pad (init);
12381 ffebit_kill (ffebld_accter_bits (init));
12382 ffebld_set_op (init, FFEBLD_opARRTER);
12383 ffebld_set_arrter (init, ffebld_accter (init));
12384 ffebld_arrter_set_size (init, size);
12385 ffebld_arrter_set_pad (init, size);
12389 ffestorag_set_init (st, init);
12394 init = ffestorag_init (st);
12397 #if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
12398 ffestorag_set_init (st, ffebld_new_any ());
12400 if (ffebld_op (init) == FFEBLD_opANY)
12401 return; /* Oh, we already did this! */
12403 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12407 if (ffestorag_symbol (st) != NULL)
12408 s = ffestorag_symbol (st);
12410 s = ffestorag_typesymbol (st);
12412 fprintf (dmpout, "= initialize_storage \"%s\" ",
12413 (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12414 ffebld_dump (init);
12415 fputc ('\n', dmpout);
12419 #endif /* if FFECOM_ONEPASS */
12422 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12425 ffecom_notify_init_symbol(s);
12427 Gets called when all possible units in a symbol (not placed in COMMON
12428 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12429 have been initialized. The initialization info either is in
12430 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12432 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12433 even for an array if the array is one element in length!
12435 ffesymbol_accretion will contain an opACCTER. It is much like an
12436 opARRTER except it has an ffebit object in it instead of just a size.
12437 The back end can use the info in the ffebit object, if it wants, to
12438 reduce the amount of actual initialization, but in any case it should
12439 kill the ffebit object when done. Also, set accretion to NULL but
12440 init to a non-NULL value.
12442 After performing initialization, DO NOT set init to NULL, because that'll
12443 tell the front end it is ok for more initialization to happen. Instead,
12444 set init to an opANY expression or some such thing that you can use to
12445 tell that you've already initialized the object.
12448 Support two-pass FFE. */
12451 ffecom_notify_init_symbol (ffesymbol s)
12453 ffebld init; /* The initialization expression. */
12454 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12455 ffetargetOffset size; /* The size of the entity. */
12456 ffetargetAlign pad; /* Its initial padding. */
12459 if (ffesymbol_storage (s) == NULL)
12460 return; /* Do nothing until COMMON/EQUIVALENCE
12461 possibilities checked. */
12463 if ((ffesymbol_init (s) == NULL)
12464 && ((init = ffesymbol_accretion (s)) != NULL))
12466 ffesymbol_set_accretion (s, NULL);
12467 ffesymbol_set_accretes (s, 0);
12469 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12470 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12471 size = ffebld_accter_size (init);
12472 pad = ffebld_accter_pad (init);
12473 ffebit_kill (ffebld_accter_bits (init));
12474 ffebld_set_op (init, FFEBLD_opARRTER);
12475 ffebld_set_arrter (init, ffebld_accter (init));
12476 ffebld_arrter_set_size (init, size);
12477 ffebld_arrter_set_pad (init, size);
12481 ffesymbol_set_init (s, init);
12486 init = ffesymbol_init (s);
12490 ffesymbol_set_init (s, ffebld_new_any ());
12492 if (ffebld_op (init) == FFEBLD_opANY)
12493 return; /* Oh, we already did this! */
12495 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12496 fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12497 ffebld_dump (init);
12498 fputc ('\n', dmpout);
12501 #endif /* if FFECOM_ONEPASS */
12504 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12507 ffecom_notify_primary_entry(s);
12509 Gets called when implicit or explicit PROGRAM statement seen or when
12510 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12511 global symbol that serves as the entry point. */
12514 ffecom_notify_primary_entry (ffesymbol s)
12516 ffecom_primary_entry_ = s;
12517 ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12519 if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12520 || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12521 ffecom_primary_entry_is_proc_ = TRUE;
12523 ffecom_primary_entry_is_proc_ = FALSE;
12525 if (!ffe_is_silent ())
12527 if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12528 fprintf (stderr, "%s:\n", ffesymbol_text (s));
12530 fprintf (stderr, " %s:\n", ffesymbol_text (s));
12533 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12534 if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12539 for (list = ffesymbol_dummyargs (s);
12541 list = ffebld_trail (list))
12543 arg = ffebld_head (list);
12544 if (ffebld_op (arg) == FFEBLD_opSTAR)
12546 ffecom_is_altreturning_ = TRUE;
12555 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12557 #if FFECOM_GCC_INCLUDE
12558 return ffecom_open_include_ (name, l, c);
12560 return fopen (name, "r");
12564 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12567 ffebld expr; // FFE expression.
12568 tree = ffecom_ptr_to_expr(expr);
12570 Like ffecom_expr, but sticks address-of in front of most things. */
12572 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12574 ffecom_ptr_to_expr (ffebld expr)
12577 ffeinfoBasictype bt;
12578 ffeinfoKindtype kt;
12581 assert (expr != NULL);
12583 switch (ffebld_op (expr))
12585 case FFEBLD_opSYMTER:
12586 s = ffebld_symter (expr);
12587 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12591 ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12592 assert (ix != FFECOM_gfrt);
12593 if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12595 ffecom_make_gfrt_ (ix);
12596 item = ffecom_gfrt_[ix];
12601 item = ffesymbol_hook (s).decl_tree;
12602 if (item == NULL_TREE)
12604 s = ffecom_sym_transform_ (s);
12605 item = ffesymbol_hook (s).decl_tree;
12608 assert (item != NULL);
12609 if (item == error_mark_node)
12611 if (!ffesymbol_hook (s).addr)
12612 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12616 case FFEBLD_opARRAYREF:
12617 return ffecom_arrayref_ (NULL_TREE, expr, 1);
12619 case FFEBLD_opCONTER:
12621 bt = ffeinfo_basictype (ffebld_info (expr));
12622 kt = ffeinfo_kindtype (ffebld_info (expr));
12624 item = ffecom_constantunion (&ffebld_constant_union
12625 (ffebld_conter (expr)), bt, kt,
12626 ffecom_tree_type[bt][kt]);
12627 if (item == error_mark_node)
12628 return error_mark_node;
12629 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12634 return error_mark_node;
12637 bt = ffeinfo_basictype (ffebld_info (expr));
12638 kt = ffeinfo_kindtype (ffebld_info (expr));
12640 item = ffecom_expr (expr);
12641 if (item == error_mark_node)
12642 return error_mark_node;
12644 /* The back end currently optimizes a bit too zealously for us, in that
12645 we fail JCB001 if the following block of code is omitted. It checks
12646 to see if the transformed expression is a symbol or array reference,
12647 and encloses it in a SAVE_EXPR if that is the case. */
12650 if ((TREE_CODE (item) == VAR_DECL)
12651 || (TREE_CODE (item) == PARM_DECL)
12652 || (TREE_CODE (item) == RESULT_DECL)
12653 || (TREE_CODE (item) == INDIRECT_REF)
12654 || (TREE_CODE (item) == ARRAY_REF)
12655 || (TREE_CODE (item) == COMPONENT_REF)
12657 || (TREE_CODE (item) == OFFSET_REF)
12659 || (TREE_CODE (item) == BUFFER_REF)
12660 || (TREE_CODE (item) == REALPART_EXPR)
12661 || (TREE_CODE (item) == IMAGPART_EXPR))
12663 item = ffecom_save_tree (item);
12666 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12671 assert ("fall-through error" == NULL);
12672 return error_mark_node;
12676 /* Obtain a temp var with given data type.
12678 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12679 or >= 0 for a CHARACTER type.
12681 elements is -1 for a scalar or > 0 for an array of type. */
12683 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12685 ffecom_make_tempvar (const char *commentary, tree type,
12686 ffetargetCharacterSize size, int elements)
12689 static int mynumber;
12691 assert (current_binding_level->prep_state < 2);
12693 if (type == error_mark_node)
12694 return error_mark_node;
12696 if (size != FFETARGET_charactersizeNONE)
12697 type = build_array_type (type,
12698 build_range_type (ffecom_f2c_ftnlen_type_node,
12699 ffecom_f2c_ftnlen_one_node,
12700 build_int_2 (size, 0)));
12701 if (elements != -1)
12702 type = build_array_type (type,
12703 build_range_type (integer_type_node,
12705 build_int_2 (elements - 1,
12707 t = build_decl (VAR_DECL,
12708 ffecom_get_invented_identifier ("__g77_%s_%d",
12713 t = start_decl (t, FALSE);
12714 finish_decl (t, NULL_TREE, FALSE);
12720 /* Prepare argument pointer to expression.
12722 Like ffecom_prepare_expr, except for expressions to be evaluated
12723 via ffecom_arg_ptr_to_expr. */
12726 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12728 /* ~~For now, it seems to be the same thing. */
12729 ffecom_prepare_expr (expr);
12733 /* End of preparations. */
12736 ffecom_prepare_end (void)
12738 int prep_state = current_binding_level->prep_state;
12740 assert (prep_state < 2);
12741 current_binding_level->prep_state = 2;
12743 return (prep_state == 1) ? TRUE : FALSE;
12746 /* Prepare expression.
12748 This is called before any code is generated for the current block.
12749 It scans the expression, declares any temporaries that might be needed
12750 during evaluation of the expression, and stores those temporaries in
12751 the appropriate "hook" fields of the expression. `dest', if not NULL,
12752 specifies the destination that ffecom_expr_ will see, in case that
12753 helps avoid generating unused temporaries.
12755 ~~Improve to avoid allocating unused temporaries by taking `dest'
12756 into account vis-a-vis aliasing requirements of complex/character
12760 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12762 ffeinfoBasictype bt;
12763 ffeinfoKindtype kt;
12764 ffetargetCharacterSize sz;
12765 tree tempvar = NULL_TREE;
12767 assert (current_binding_level->prep_state < 2);
12772 bt = ffeinfo_basictype (ffebld_info (expr));
12773 kt = ffeinfo_kindtype (ffebld_info (expr));
12774 sz = ffeinfo_size (ffebld_info (expr));
12776 /* Generate whatever temporaries are needed to represent the result
12777 of the expression. */
12779 if (bt == FFEINFO_basictypeCHARACTER)
12781 while (ffebld_op (expr) == FFEBLD_opPAREN)
12782 expr = ffebld_left (expr);
12785 switch (ffebld_op (expr))
12788 /* Don't make temps for SYMTER, CONTER, etc. */
12789 if (ffebld_arity (expr) == 0)
12794 case FFEINFO_basictypeCOMPLEX:
12795 if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12799 if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12802 s = ffebld_symter (ffebld_left (expr));
12803 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12804 || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12805 && ! ffesymbol_is_f2c (s))
12806 || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12807 && ! ffe_is_f2c_library ()))
12810 else if (ffebld_op (expr) == FFEBLD_opPOWER)
12812 /* Requires special treatment. There's no POW_CC function
12813 in libg2c, so POW_ZZ is used, which means we always
12814 need a double-complex temp, not a single-complex. */
12815 kt = FFEINFO_kindtypeREAL2;
12817 else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12818 /* The other ops don't need temps for complex operands. */
12821 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12822 REAL(C). See 19990325-0.f, routine `check', for cases. */
12823 tempvar = ffecom_make_tempvar ("complex",
12825 [FFEINFO_basictypeCOMPLEX][kt],
12826 FFETARGET_charactersizeNONE,
12830 case FFEINFO_basictypeCHARACTER:
12831 if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12834 if (sz == FFETARGET_charactersizeNONE)
12835 /* ~~Kludge alert! This should someday be fixed. */
12838 tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12847 case FFEBLD_opPOWER:
12850 tree rtmp, ltmp, result;
12852 ltype = ffecom_type_expr (ffebld_left (expr));
12853 rtype = ffecom_type_expr (ffebld_right (expr));
12855 rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12856 ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12857 result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12859 tempvar = make_tree_vec (3);
12860 TREE_VEC_ELT (tempvar, 0) = rtmp;
12861 TREE_VEC_ELT (tempvar, 1) = ltmp;
12862 TREE_VEC_ELT (tempvar, 2) = result;
12867 case FFEBLD_opCONCATENATE:
12869 /* This gets special handling, because only one set of temps
12870 is needed for a tree of these -- the tree is treated as
12871 a flattened list of concatenations when generating code. */
12873 ffecomConcatList_ catlist;
12874 tree ltmp, itmp, result;
12878 catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12879 count = ffecom_concat_list_count_ (catlist);
12884 = ffecom_make_tempvar ("concat_len",
12885 ffecom_f2c_ftnlen_type_node,
12886 FFETARGET_charactersizeNONE, count);
12888 = ffecom_make_tempvar ("concat_item",
12889 ffecom_f2c_address_type_node,
12890 FFETARGET_charactersizeNONE, count);
12892 = ffecom_make_tempvar ("concat_res",
12894 ffecom_concat_list_maxlen_ (catlist),
12897 tempvar = make_tree_vec (3);
12898 TREE_VEC_ELT (tempvar, 0) = ltmp;
12899 TREE_VEC_ELT (tempvar, 1) = itmp;
12900 TREE_VEC_ELT (tempvar, 2) = result;
12903 for (i = 0; i < count; ++i)
12904 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12907 ffecom_concat_list_kill_ (catlist);
12911 ffebld_nonter_set_hook (expr, tempvar);
12912 current_binding_level->prep_state = 1;
12917 case FFEBLD_opCONVERT:
12918 if (bt == FFEINFO_basictypeCHARACTER
12919 && ((ffebld_size_known (ffebld_left (expr))
12920 == FFETARGET_charactersizeNONE)
12921 || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12922 tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12928 ffebld_nonter_set_hook (expr, tempvar);
12929 current_binding_level->prep_state = 1;
12932 /* Prepare subexpressions for this expr. */
12934 switch (ffebld_op (expr))
12936 case FFEBLD_opPERCENT_LOC:
12937 ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12940 case FFEBLD_opPERCENT_VAL:
12941 case FFEBLD_opPERCENT_REF:
12942 ffecom_prepare_expr (ffebld_left (expr));
12945 case FFEBLD_opPERCENT_DESCR:
12946 ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12949 case FFEBLD_opITEM:
12955 item = ffebld_trail (item))
12956 if (ffebld_head (item) != NULL)
12957 ffecom_prepare_expr (ffebld_head (item));
12962 /* Need to handle character conversion specially. */
12963 switch (ffebld_arity (expr))
12966 ffecom_prepare_expr (ffebld_left (expr));
12967 ffecom_prepare_expr (ffebld_right (expr));
12971 ffecom_prepare_expr (ffebld_left (expr));
12982 /* Prepare expression for reading and writing.
12984 Like ffecom_prepare_expr, except for expressions to be evaluated
12985 via ffecom_expr_rw. */
12988 ffecom_prepare_expr_rw (tree type, ffebld expr)
12990 /* This is all we support for now. */
12991 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12993 /* ~~For now, it seems to be the same thing. */
12994 ffecom_prepare_expr (expr);
12998 /* Prepare expression for writing.
13000 Like ffecom_prepare_expr, except for expressions to be evaluated
13001 via ffecom_expr_w. */
13004 ffecom_prepare_expr_w (tree type, ffebld expr)
13006 /* This is all we support for now. */
13007 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13009 /* ~~For now, it seems to be the same thing. */
13010 ffecom_prepare_expr (expr);
13014 /* Prepare expression for returning.
13016 Like ffecom_prepare_expr, except for expressions to be evaluated
13017 via ffecom_return_expr. */
13020 ffecom_prepare_return_expr (ffebld expr)
13022 assert (current_binding_level->prep_state < 2);
13024 if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
13025 && ffecom_is_altreturning_
13027 ffecom_prepare_expr (expr);
13030 /* Prepare pointer to expression.
13032 Like ffecom_prepare_expr, except for expressions to be evaluated
13033 via ffecom_ptr_to_expr. */
13036 ffecom_prepare_ptr_to_expr (ffebld expr)
13038 /* ~~For now, it seems to be the same thing. */
13039 ffecom_prepare_expr (expr);
13043 /* Transform expression into constant pointer-to-expression tree.
13045 If the expression can be transformed into a pointer-to-expression tree
13046 that is constant, that is done, and the tree returned. Else NULL_TREE
13049 That way, a caller can attempt to provide compile-time initialization
13050 of a variable and, if that fails, *then* choose to start a new block
13051 and resort to using temporaries, as appropriate. */
13054 ffecom_ptr_to_const_expr (ffebld expr)
13057 return integer_zero_node;
13059 if (ffebld_op (expr) == FFEBLD_opANY)
13060 return error_mark_node;
13062 if (ffebld_arity (expr) == 0
13063 && (ffebld_op (expr) != FFEBLD_opSYMTER
13064 || ffebld_where (expr) == FFEINFO_whereCOMMON
13065 || ffebld_where (expr) == FFEINFO_whereGLOBAL
13066 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
13070 t = ffecom_ptr_to_expr (expr);
13071 assert (TREE_CONSTANT (t));
13078 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13080 tree rtn; // NULL_TREE means use expand_null_return()
13081 ffebld expr; // NULL if no alt return expr to RETURN stmt
13082 rtn = ffecom_return_expr(expr);
13084 Based on the program unit type and other info (like return function
13085 type, return master function type when alternate ENTRY points,
13086 whether subroutine has any alternate RETURN points, etc), returns the
13087 appropriate expression to be returned to the caller, or NULL_TREE
13088 meaning no return value or the caller expects it to be returned somewhere
13089 else (which is handled by other parts of this module). */
13091 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13093 ffecom_return_expr (ffebld expr)
13097 switch (ffecom_primary_entry_kind_)
13099 case FFEINFO_kindPROGRAM:
13100 case FFEINFO_kindBLOCKDATA:
13104 case FFEINFO_kindSUBROUTINE:
13105 if (!ffecom_is_altreturning_)
13106 rtn = NULL_TREE; /* No alt returns, never an expr. */
13107 else if (expr == NULL)
13108 rtn = integer_zero_node;
13110 rtn = ffecom_expr (expr);
13113 case FFEINFO_kindFUNCTION:
13114 if ((ffecom_multi_retval_ != NULL_TREE)
13115 || (ffesymbol_basictype (ffecom_primary_entry_)
13116 == FFEINFO_basictypeCHARACTER)
13117 || ((ffesymbol_basictype (ffecom_primary_entry_)
13118 == FFEINFO_basictypeCOMPLEX)
13119 && (ffecom_num_entrypoints_ == 0)
13120 && ffesymbol_is_f2c (ffecom_primary_entry_)))
13121 { /* Value is returned by direct assignment
13122 into (implicit) dummy. */
13126 rtn = ffecom_func_result_;
13128 /* Spurious error if RETURN happens before first reference! So elide
13129 this code. In particular, for debugging registry, rtn should always
13130 be non-null after all, but TREE_USED won't be set until we encounter
13131 a reference in the code. Perfectly okay (but weird) code that,
13132 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13133 this diagnostic for no reason. Have people use -O -Wuninitialized
13134 and leave it to the back end to find obviously weird cases. */
13136 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13137 situation; if the return value has never been referenced, it won't
13138 have a tree under 2pass mode. */
13139 if ((rtn == NULL_TREE)
13140 || !TREE_USED (rtn))
13142 ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13143 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13144 ffesymbol_where_column (ffecom_primary_entry_));
13145 ffebad_string (ffesymbol_text (ffesymbol_funcresult
13146 (ffecom_primary_entry_)));
13153 assert ("bad unit kind" == NULL);
13154 case FFEINFO_kindANY:
13155 rtn = error_mark_node;
13163 /* Do save_expr only if tree is not error_mark_node. */
13165 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13167 ffecom_save_tree (tree t)
13169 return save_expr (t);
13173 /* Start a compound statement (block). */
13175 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13177 ffecom_start_compstmt (void)
13179 bison_rule_pushlevel_ ();
13181 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13183 /* Public entry point for front end to access start_decl. */
13185 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13187 ffecom_start_decl (tree decl, bool is_initialized)
13189 DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13190 return start_decl (decl, FALSE);
13194 /* ffecom_sym_commit -- Symbol's state being committed to reality
13197 ffecom_sym_commit(s);
13199 Does whatever the backend needs when a symbol is committed after having
13200 been backtrackable for a period of time. */
13202 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13204 ffecom_sym_commit (ffesymbol s UNUSED)
13206 assert (!ffesymbol_retractable ());
13210 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13212 ffecom_sym_end_transition();
13214 Does backend-specific stuff and also calls ffest_sym_end_transition
13215 to do the necessary FFE stuff.
13217 Backtracking is never enabled when this fn is called, so don't worry
13221 ffecom_sym_end_transition (ffesymbol s)
13225 assert (!ffesymbol_retractable ());
13227 s = ffest_sym_end_transition (s);
13229 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13230 if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13231 && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13233 ffecom_list_blockdata_
13234 = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13235 FFEINTRIN_specNONE,
13236 FFEINTRIN_impNONE),
13237 ffecom_list_blockdata_);
13241 /* This is where we finally notice that a symbol has partial initialization
13242 and finalize it. */
13244 if (ffesymbol_accretion (s) != NULL)
13246 assert (ffesymbol_init (s) == NULL);
13247 ffecom_notify_init_symbol (s);
13249 else if (((st = ffesymbol_storage (s)) != NULL)
13250 && ((st = ffestorag_parent (st)) != NULL)
13251 && (ffestorag_accretion (st) != NULL))
13253 assert (ffestorag_init (st) == NULL);
13254 ffecom_notify_init_storage (st);
13257 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13258 if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13259 && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13260 && (ffesymbol_storage (s) != NULL))
13262 ffecom_list_common_
13263 = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13264 FFEINTRIN_specNONE,
13265 FFEINTRIN_impNONE),
13266 ffecom_list_common_);
13273 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13275 ffecom_sym_exec_transition();
13277 Does backend-specific stuff and also calls ffest_sym_exec_transition
13278 to do the necessary FFE stuff.
13280 See the long-winded description in ffecom_sym_learned for info
13281 on handling the situation where backtracking is inhibited. */
13284 ffecom_sym_exec_transition (ffesymbol s)
13286 s = ffest_sym_exec_transition (s);
13291 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13294 s = ffecom_sym_learned(s);
13296 Called when a new symbol is seen after the exec transition or when more
13297 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
13298 it arrives here is that all its latest info is updated already, so its
13299 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13300 field filled in if its gone through here or exec_transition first, and
13303 The backend probably wants to check ffesymbol_retractable() to see if
13304 backtracking is in effect. If so, the FFE's changes to the symbol may
13305 be retracted (undone) or committed (ratified), at which time the
13306 appropriate ffecom_sym_retract or _commit function will be called
13309 If the backend has its own backtracking mechanism, great, use it so that
13310 committal is a simple operation. Though it doesn't make much difference,
13311 I suppose: the reason for tentative symbol evolution in the FFE is to
13312 enable error detection in weird incorrect statements early and to disable
13313 incorrect error detection on a correct statement. The backend is not
13314 likely to introduce any information that'll get involved in these
13315 considerations, so it is probably just fine that the implementation
13316 model for this fn and for _exec_transition is to not do anything
13317 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13318 and instead wait until ffecom_sym_commit is called (which it never
13319 will be as long as we're using ambiguity-detecting statement analysis in
13320 the FFE, which we are initially to shake out the code, but don't depend
13321 on this), otherwise go ahead and do whatever is needed.
13323 In essence, then, when this fn and _exec_transition get called while
13324 backtracking is enabled, a general mechanism would be to flag which (or
13325 both) of these were called (and in what order? neat question as to what
13326 might happen that I'm too lame to think through right now) and then when
13327 _commit is called reproduce the original calling sequence, if any, for
13328 the two fns (at which point backtracking will, of course, be disabled). */
13331 ffecom_sym_learned (ffesymbol s)
13333 ffestorag_exec_layout (s);
13338 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13341 ffecom_sym_retract(s);
13343 Does whatever the backend needs when a symbol is retracted after having
13344 been backtrackable for a period of time. */
13346 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13348 ffecom_sym_retract (ffesymbol s UNUSED)
13350 assert (!ffesymbol_retractable ());
13352 #if 0 /* GCC doesn't commit any backtrackable sins,
13353 so nothing needed here. */
13354 switch (ffesymbol_hook (s).state)
13356 case 0: /* nothing happened yet. */
13359 case 1: /* exec transition happened. */
13362 case 2: /* learned happened. */
13365 case 3: /* learned then exec. */
13368 case 4: /* exec then learned. */
13372 assert ("bad hook state" == NULL);
13379 /* Create temporary gcc label. */
13381 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13383 ffecom_temp_label ()
13386 static int mynumber = 0;
13388 glabel = build_decl (LABEL_DECL,
13389 ffecom_get_invented_identifier ("__g77_label_%d",
13392 DECL_CONTEXT (glabel) = current_function_decl;
13393 DECL_MODE (glabel) = VOIDmode;
13399 /* Return an expression that is usable as an arg in a conditional context
13400 (IF, DO WHILE, .NOT., and so on).
13402 Use the one provided for the back end as of >2.6.0. */
13404 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13406 ffecom_truth_value (tree expr)
13408 return truthvalue_conversion (expr);
13412 /* Return the inversion of a truth value (the inversion of what
13413 ffecom_truth_value builds).
13415 Apparently invert_truthvalue, which is properly in the back end, is
13416 enough for now, so just use it. */
13418 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13420 ffecom_truth_value_invert (tree expr)
13422 return invert_truthvalue (ffecom_truth_value (expr));
13427 /* Return the tree that is the type of the expression, as would be
13428 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13429 transforming the expression, generating temporaries, etc. */
13432 ffecom_type_expr (ffebld expr)
13434 ffeinfoBasictype bt;
13435 ffeinfoKindtype kt;
13438 assert (expr != NULL);
13440 bt = ffeinfo_basictype (ffebld_info (expr));
13441 kt = ffeinfo_kindtype (ffebld_info (expr));
13442 tree_type = ffecom_tree_type[bt][kt];
13444 switch (ffebld_op (expr))
13446 case FFEBLD_opCONTER:
13447 case FFEBLD_opSYMTER:
13448 case FFEBLD_opARRAYREF:
13449 case FFEBLD_opUPLUS:
13450 case FFEBLD_opPAREN:
13451 case FFEBLD_opUMINUS:
13453 case FFEBLD_opSUBTRACT:
13454 case FFEBLD_opMULTIPLY:
13455 case FFEBLD_opDIVIDE:
13456 case FFEBLD_opPOWER:
13458 case FFEBLD_opFUNCREF:
13459 case FFEBLD_opSUBRREF:
13463 case FFEBLD_opNEQV:
13465 case FFEBLD_opCONVERT:
13472 case FFEBLD_opPERCENT_LOC:
13475 case FFEBLD_opACCTER:
13476 case FFEBLD_opARRTER:
13477 case FFEBLD_opITEM:
13478 case FFEBLD_opSTAR:
13479 case FFEBLD_opBOUNDS:
13480 case FFEBLD_opREPEAT:
13481 case FFEBLD_opLABTER:
13482 case FFEBLD_opLABTOK:
13483 case FFEBLD_opIMPDO:
13484 case FFEBLD_opCONCATENATE:
13485 case FFEBLD_opSUBSTR:
13487 assert ("bad op for ffecom_type_expr" == NULL);
13488 /* Fall through. */
13490 return error_mark_node;
13494 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13496 If the PARM_DECL already exists, return it, else create it. It's an
13497 integer_type_node argument for the master function that implements a
13498 subroutine or function with more than one entrypoint and is bound at
13499 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13500 first ENTRY statement, and so on). */
13502 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13504 ffecom_which_entrypoint_decl ()
13506 assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13508 return ffecom_which_entrypoint_decl_;
13513 /* The following sections consists of private and public functions
13514 that have the same names and perform roughly the same functions
13515 as counterparts in the C front end. Changes in the C front end
13516 might affect how things should be done here. Only functions
13517 needed by the back end should be public here; the rest should
13518 be private (static in the C sense). Functions needed by other
13519 g77 front-end modules should be accessed by them via public
13520 ffecom_* names, which should themselves call private versions
13521 in this section so the private versions are easy to recognize
13522 when upgrading to a new gcc and finding interesting changes
13525 Functions named after rule "foo:" in c-parse.y are named
13526 "bison_rule_foo_" so they are easy to find. */
13528 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13531 bison_rule_pushlevel_ ()
13533 emit_line_note (input_filename, lineno);
13535 clear_last_expr ();
13536 expand_start_bindings (0);
13540 bison_rule_compstmt_ ()
13543 int keep = kept_level_p ();
13545 /* Make the temps go away. */
13547 current_binding_level->names = NULL_TREE;
13549 emit_line_note (input_filename, lineno);
13550 expand_end_bindings (getdecls (), keep, 0);
13551 t = poplevel (keep, 1, 0);
13556 /* Return a definition for a builtin function named NAME and whose data type
13557 is TYPE. TYPE should be a function type with argument types.
13558 FUNCTION_CODE tells later passes how to compile calls to this function.
13559 See tree.h for its possible values.
13561 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13562 the name to be called if we can't opencode the function. */
13565 builtin_function (const char *name, tree type, int function_code,
13566 enum built_in_class class,
13567 const char *library_name)
13569 tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13570 DECL_EXTERNAL (decl) = 1;
13571 TREE_PUBLIC (decl) = 1;
13573 DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13574 make_decl_rtl (decl, NULL_PTR, 1);
13576 DECL_BUILT_IN_CLASS (decl) = class;
13577 DECL_FUNCTION_CODE (decl) = function_code;
13582 /* Handle when a new declaration NEWDECL
13583 has the same name as an old one OLDDECL
13584 in the same binding contour.
13585 Prints an error message if appropriate.
13587 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13588 Otherwise, return 0. */
13591 duplicate_decls (tree newdecl, tree olddecl)
13593 int types_match = 1;
13594 int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13595 && DECL_INITIAL (newdecl) != 0);
13596 tree oldtype = TREE_TYPE (olddecl);
13597 tree newtype = TREE_TYPE (newdecl);
13599 if (olddecl == newdecl)
13602 if (TREE_CODE (newtype) == ERROR_MARK
13603 || TREE_CODE (oldtype) == ERROR_MARK)
13606 /* New decl is completely inconsistent with the old one =>
13607 tell caller to replace the old one.
13608 This is always an error except in the case of shadowing a builtin. */
13609 if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13612 /* For real parm decl following a forward decl,
13613 return 1 so old decl will be reused. */
13614 if (types_match && TREE_CODE (newdecl) == PARM_DECL
13615 && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13618 /* The new declaration is the same kind of object as the old one.
13619 The declarations may partially match. Print warnings if they don't
13620 match enough. Ultimately, copy most of the information from the new
13621 decl to the old one, and keep using the old one. */
13623 if (TREE_CODE (olddecl) == FUNCTION_DECL
13624 && DECL_BUILT_IN (olddecl))
13626 /* A function declaration for a built-in function. */
13627 if (!TREE_PUBLIC (newdecl))
13629 else if (!types_match)
13631 /* Accept the return type of the new declaration if same modes. */
13632 tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13633 tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13635 if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13637 /* Function types may be shared, so we can't just modify
13638 the return type of olddecl's function type. */
13640 = build_function_type (newreturntype,
13641 TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13645 TREE_TYPE (olddecl) = newtype;
13651 else if (TREE_CODE (olddecl) == FUNCTION_DECL
13652 && DECL_SOURCE_LINE (olddecl) == 0)
13654 /* A function declaration for a predeclared function
13655 that isn't actually built in. */
13656 if (!TREE_PUBLIC (newdecl))
13658 else if (!types_match)
13660 /* If the types don't match, preserve volatility indication.
13661 Later on, we will discard everything else about the
13662 default declaration. */
13663 TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13667 /* Copy all the DECL_... slots specified in the new decl
13668 except for any that we copy here from the old type.
13670 Past this point, we don't change OLDTYPE and NEWTYPE
13671 even if we change the types of NEWDECL and OLDDECL. */
13675 /* Merge the data types specified in the two decls. */
13676 if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13677 TREE_TYPE (newdecl)
13678 = TREE_TYPE (olddecl)
13679 = TREE_TYPE (newdecl);
13681 /* Lay the type out, unless already done. */
13682 if (oldtype != TREE_TYPE (newdecl))
13684 if (TREE_TYPE (newdecl) != error_mark_node)
13685 layout_type (TREE_TYPE (newdecl));
13686 if (TREE_CODE (newdecl) != FUNCTION_DECL
13687 && TREE_CODE (newdecl) != TYPE_DECL
13688 && TREE_CODE (newdecl) != CONST_DECL)
13689 layout_decl (newdecl, 0);
13693 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13694 DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13695 DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13696 if (TREE_CODE (olddecl) != FUNCTION_DECL)
13697 if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13699 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13700 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13704 /* Keep the old rtl since we can safely use it. */
13705 DECL_RTL (newdecl) = DECL_RTL (olddecl);
13707 /* Merge the type qualifiers. */
13708 if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13709 && !TREE_THIS_VOLATILE (newdecl))
13710 TREE_THIS_VOLATILE (olddecl) = 0;
13711 if (TREE_READONLY (newdecl))
13712 TREE_READONLY (olddecl) = 1;
13713 if (TREE_THIS_VOLATILE (newdecl))
13715 TREE_THIS_VOLATILE (olddecl) = 1;
13716 if (TREE_CODE (newdecl) == VAR_DECL)
13717 make_var_volatile (newdecl);
13720 /* Keep source location of definition rather than declaration.
13721 Likewise, keep decl at outer scope. */
13722 if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13723 || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13725 DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13726 DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13728 if (DECL_CONTEXT (olddecl) == 0
13729 && TREE_CODE (newdecl) != FUNCTION_DECL)
13730 DECL_CONTEXT (newdecl) = 0;
13733 /* Merge the unused-warning information. */
13734 if (DECL_IN_SYSTEM_HEADER (olddecl))
13735 DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13736 else if (DECL_IN_SYSTEM_HEADER (newdecl))
13737 DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13739 /* Merge the initialization information. */
13740 if (DECL_INITIAL (newdecl) == 0)
13741 DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13743 /* Merge the section attribute.
13744 We want to issue an error if the sections conflict but that must be
13745 done later in decl_attributes since we are called before attributes
13747 if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13748 DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13751 if (TREE_CODE (newdecl) == FUNCTION_DECL)
13753 DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13754 DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13758 /* If cannot merge, then use the new type and qualifiers,
13759 and don't preserve the old rtl. */
13762 TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13763 TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13764 TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13765 TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13768 /* Merge the storage class information. */
13769 /* For functions, static overrides non-static. */
13770 if (TREE_CODE (newdecl) == FUNCTION_DECL)
13772 TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13773 /* This is since we don't automatically
13774 copy the attributes of NEWDECL into OLDDECL. */
13775 TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13776 /* If this clears `static', clear it in the identifier too. */
13777 if (! TREE_PUBLIC (olddecl))
13778 TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13780 if (DECL_EXTERNAL (newdecl))
13782 TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13783 DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13784 /* An extern decl does not override previous storage class. */
13785 TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13789 TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13790 TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13793 /* If either decl says `inline', this fn is inline,
13794 unless its definition was passed already. */
13795 if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13796 DECL_INLINE (olddecl) = 1;
13797 DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13799 /* Get rid of any built-in function if new arg types don't match it
13800 or if we have a function definition. */
13801 if (TREE_CODE (newdecl) == FUNCTION_DECL
13802 && DECL_BUILT_IN (olddecl)
13803 && (!types_match || new_is_definition))
13805 TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13806 DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13809 /* If redeclaring a builtin function, and not a definition,
13811 Also preserve various other info from the definition. */
13812 if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13814 if (DECL_BUILT_IN (olddecl))
13816 DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13817 DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13820 DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
13822 DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13823 DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13824 DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13825 DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13828 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13829 But preserve olddecl's DECL_UID. */
13831 register unsigned olddecl_uid = DECL_UID (olddecl);
13833 memcpy ((char *) olddecl + sizeof (struct tree_common),
13834 (char *) newdecl + sizeof (struct tree_common),
13835 sizeof (struct tree_decl) - sizeof (struct tree_common));
13836 DECL_UID (olddecl) = olddecl_uid;
13842 /* Finish processing of a declaration;
13843 install its initial value.
13844 If the length of an array type is not known before,
13845 it must be determined now, from the initial value, or it is an error. */
13848 finish_decl (tree decl, tree init, bool is_top_level)
13850 register tree type = TREE_TYPE (decl);
13851 int was_incomplete = (DECL_SIZE (decl) == 0);
13852 bool at_top_level = (current_binding_level == global_binding_level);
13853 bool top_level = is_top_level || at_top_level;
13855 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13857 assert (!is_top_level || !at_top_level);
13859 if (TREE_CODE (decl) == PARM_DECL)
13860 assert (init == NULL_TREE);
13861 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13862 overlaps DECL_ARG_TYPE. */
13863 else if (init == NULL_TREE)
13864 assert (DECL_INITIAL (decl) == NULL_TREE);
13866 assert (DECL_INITIAL (decl) == error_mark_node);
13868 if (init != NULL_TREE)
13870 if (TREE_CODE (decl) != TYPE_DECL)
13871 DECL_INITIAL (decl) = init;
13874 /* typedef foo = bar; store the type of bar as the type of foo. */
13875 TREE_TYPE (decl) = TREE_TYPE (init);
13876 DECL_INITIAL (decl) = init = 0;
13880 /* Deduce size of array from initialization, if not already known */
13882 if (TREE_CODE (type) == ARRAY_TYPE
13883 && TYPE_DOMAIN (type) == 0
13884 && TREE_CODE (decl) != TYPE_DECL)
13886 assert (top_level);
13887 assert (was_incomplete);
13889 layout_decl (decl, 0);
13892 if (TREE_CODE (decl) == VAR_DECL)
13894 if (DECL_SIZE (decl) == NULL_TREE
13895 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13896 layout_decl (decl, 0);
13898 if (DECL_SIZE (decl) == NULL_TREE
13899 && (TREE_STATIC (decl)
13901 /* A static variable with an incomplete type is an error if it is
13902 initialized. Also if it is not file scope. Otherwise, let it
13903 through, but if it is not `extern' then it may cause an error
13905 (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13907 /* An automatic variable with an incomplete type is an error. */
13908 !DECL_EXTERNAL (decl)))
13910 assert ("storage size not known" == NULL);
13914 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13915 && (DECL_SIZE (decl) != 0)
13916 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13918 assert ("storage size not constant" == NULL);
13923 /* Output the assembler code and/or RTL code for variables and functions,
13924 unless the type is an undefined structure or union. If not, it will get
13925 done when the type is completed. */
13927 if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13929 rest_of_decl_compilation (decl, NULL,
13930 DECL_CONTEXT (decl) == 0,
13933 if (DECL_CONTEXT (decl) != 0)
13935 /* Recompute the RTL of a local array now if it used to be an
13936 incomplete type. */
13938 && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13940 /* If we used it already as memory, it must stay in memory. */
13941 TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13942 /* If it's still incomplete now, no init will save it. */
13943 if (DECL_SIZE (decl) == 0)
13944 DECL_INITIAL (decl) = 0;
13945 expand_decl (decl);
13947 /* Compute and store the initial value. */
13948 if (TREE_CODE (decl) != FUNCTION_DECL)
13949 expand_decl_init (decl);
13952 else if (TREE_CODE (decl) == TYPE_DECL)
13954 rest_of_decl_compilation (decl, NULL_PTR,
13955 DECL_CONTEXT (decl) == 0,
13959 /* At the end of a declaration, throw away any variable type sizes of types
13960 defined inside that declaration. There is no use computing them in the
13961 following function definition. */
13962 if (current_binding_level == global_binding_level)
13963 get_pending_sizes ();
13966 /* Finish up a function declaration and compile that function
13967 all the way to assembler language output. The free the storage
13968 for the function definition.
13970 This is called after parsing the body of the function definition.
13972 NESTED is nonzero if the function being finished is nested in another. */
13975 finish_function (int nested)
13977 register tree fndecl = current_function_decl;
13979 assert (fndecl != NULL_TREE);
13980 if (TREE_CODE (fndecl) != ERROR_MARK)
13983 assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13985 assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13988 /* TREE_READONLY (fndecl) = 1;
13989 This caused &foo to be of type ptr-to-const-function
13990 which then got a warning when stored in a ptr-to-function variable. */
13992 poplevel (1, 0, 1);
13994 if (TREE_CODE (fndecl) != ERROR_MARK)
13996 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13998 /* Must mark the RESULT_DECL as being in this function. */
14000 DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
14002 /* Obey `register' declarations if `setjmp' is called in this fn. */
14003 /* Generate rtl for function exit. */
14004 expand_function_end (input_filename, lineno, 0);
14006 /* If this is a nested function, protect the local variables in the stack
14007 above us from being collected while we're compiling this function. */
14009 ggc_push_context ();
14011 /* Run the optimizers and output the assembler code for this function. */
14012 rest_of_compilation (fndecl);
14014 /* Undo the GC context switch. */
14016 ggc_pop_context ();
14019 if (TREE_CODE (fndecl) != ERROR_MARK
14021 && DECL_SAVED_INSNS (fndecl) == 0)
14023 /* Stop pointing to the local nodes about to be freed. */
14024 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14025 function definition. */
14026 /* For a nested function, this is done in pop_f_function_context. */
14027 /* If rest_of_compilation set this to 0, leave it 0. */
14028 if (DECL_INITIAL (fndecl) != 0)
14029 DECL_INITIAL (fndecl) = error_mark_node;
14030 DECL_ARGUMENTS (fndecl) = 0;
14035 /* Let the error reporting routines know that we're outside a function.
14036 For a nested function, this value is used in pop_c_function_context
14037 and then reset via pop_function_context. */
14038 ffecom_outer_function_decl_ = current_function_decl = NULL;
14042 /* Plug-in replacement for identifying the name of a decl and, for a
14043 function, what we call it in diagnostics. For now, "program unit"
14044 should suffice, since it's a bit of a hassle to figure out which
14045 of several kinds of things it is. Note that it could conceivably
14046 be a statement function, which probably isn't really a program unit
14047 per se, but if that comes up, it should be easy to check (being a
14048 nested function and all). */
14050 static const char *
14051 lang_printable_name (tree decl, int v)
14053 /* Just to keep GCC quiet about the unused variable.
14054 In theory, differing values of V should produce different
14059 if (TREE_CODE (decl) == ERROR_MARK)
14060 return "erroneous code";
14061 return IDENTIFIER_POINTER (DECL_NAME (decl));
14065 /* g77's function to print out name of current function that caused
14070 lang_print_error_function (const char *file)
14072 static ffeglobal last_g = NULL;
14073 static ffesymbol last_s = NULL;
14078 if ((ffecom_primary_entry_ == NULL)
14079 || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14087 g = ffesymbol_global (ffecom_primary_entry_);
14088 if (ffecom_nested_entry_ == NULL)
14090 s = ffecom_primary_entry_;
14091 switch (ffesymbol_kind (s))
14093 case FFEINFO_kindFUNCTION:
14097 case FFEINFO_kindSUBROUTINE:
14098 kind = "subroutine";
14101 case FFEINFO_kindPROGRAM:
14105 case FFEINFO_kindBLOCKDATA:
14106 kind = "block-data";
14110 kind = ffeinfo_kind_message (ffesymbol_kind (s));
14116 s = ffecom_nested_entry_;
14117 kind = "statement function";
14121 if ((last_g != g) || (last_s != s))
14124 fprintf (stderr, "%s: ", file);
14127 fprintf (stderr, "Outside of any program unit:\n");
14130 const char *name = ffesymbol_text (s);
14132 fprintf (stderr, "In %s `%s':\n", kind, name);
14141 /* Similar to `lookup_name' but look only at current binding level. */
14144 lookup_name_current_level (tree name)
14148 if (current_binding_level == global_binding_level)
14149 return IDENTIFIER_GLOBAL_VALUE (name);
14151 if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14154 for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14155 if (DECL_NAME (t) == name)
14161 /* Create a new `struct binding_level'. */
14163 static struct binding_level *
14164 make_binding_level ()
14167 return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14170 /* Save and restore the variables in this file and elsewhere
14171 that keep track of the progress of compilation of the current function.
14172 Used for nested functions. */
14176 struct f_function *next;
14178 tree shadowed_labels;
14179 struct binding_level *binding_level;
14182 struct f_function *f_function_chain;
14184 /* Restore the variables used during compilation of a C function. */
14187 pop_f_function_context ()
14189 struct f_function *p = f_function_chain;
14192 /* Bring back all the labels that were shadowed. */
14193 for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14194 if (DECL_NAME (TREE_VALUE (link)) != 0)
14195 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14196 = TREE_VALUE (link);
14198 if (current_function_decl != error_mark_node
14199 && DECL_SAVED_INSNS (current_function_decl) == 0)
14201 /* Stop pointing to the local nodes about to be freed. */
14202 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14203 function definition. */
14204 DECL_INITIAL (current_function_decl) = error_mark_node;
14205 DECL_ARGUMENTS (current_function_decl) = 0;
14208 pop_function_context ();
14210 f_function_chain = p->next;
14212 named_labels = p->named_labels;
14213 shadowed_labels = p->shadowed_labels;
14214 current_binding_level = p->binding_level;
14219 /* Save and reinitialize the variables
14220 used during compilation of a C function. */
14223 push_f_function_context ()
14225 struct f_function *p
14226 = (struct f_function *) xmalloc (sizeof (struct f_function));
14228 push_function_context ();
14230 p->next = f_function_chain;
14231 f_function_chain = p;
14233 p->named_labels = named_labels;
14234 p->shadowed_labels = shadowed_labels;
14235 p->binding_level = current_binding_level;
14239 push_parm_decl (tree parm)
14241 int old_immediate_size_expand = immediate_size_expand;
14243 /* Don't try computing parm sizes now -- wait till fn is called. */
14245 immediate_size_expand = 0;
14247 /* Fill in arg stuff. */
14249 DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14250 DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14251 TREE_READONLY (parm) = 1; /* All implementation args are read-only. */
14253 parm = pushdecl (parm);
14255 immediate_size_expand = old_immediate_size_expand;
14257 finish_decl (parm, NULL_TREE, FALSE);
14260 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
14263 pushdecl_top_level (x)
14267 register struct binding_level *b = current_binding_level;
14268 register tree f = current_function_decl;
14270 current_binding_level = global_binding_level;
14271 current_function_decl = NULL_TREE;
14273 current_binding_level = b;
14274 current_function_decl = f;
14278 /* Store the list of declarations of the current level.
14279 This is done for the parameter declarations of a function being defined,
14280 after they are modified in the light of any missing parameters. */
14286 return current_binding_level->names = decls;
14289 /* Store the parameter declarations into the current function declaration.
14290 This is called after parsing the parameter declarations, before
14291 digesting the body of the function.
14293 For an old-style definition, modify the function's type
14294 to specify at least the number of arguments. */
14297 store_parm_decls (int is_main_program UNUSED)
14299 register tree fndecl = current_function_decl;
14301 if (fndecl == error_mark_node)
14304 /* This is a chain of PARM_DECLs from old-style parm declarations. */
14305 DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14307 /* Initialize the RTL code for the function. */
14309 init_function_start (fndecl, input_filename, lineno);
14311 /* Set up parameters and prepare for return, for the function. */
14313 expand_function_start (fndecl, 0);
14317 start_decl (tree decl, bool is_top_level)
14320 bool at_top_level = (current_binding_level == global_binding_level);
14321 bool top_level = is_top_level || at_top_level;
14323 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14325 assert (!is_top_level || !at_top_level);
14327 if (DECL_INITIAL (decl) != NULL_TREE)
14329 assert (DECL_INITIAL (decl) == error_mark_node);
14330 assert (!DECL_EXTERNAL (decl));
14332 else if (top_level)
14333 assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14335 /* For Fortran, we by default put things in .common when possible. */
14336 DECL_COMMON (decl) = 1;
14338 /* Add this decl to the current binding level. TEM may equal DECL or it may
14339 be a previous decl of the same name. */
14341 tem = pushdecl_top_level (decl);
14343 tem = pushdecl (decl);
14345 /* For a local variable, define the RTL now. */
14347 /* But not if this is a duplicate decl and we preserved the rtl from the
14348 previous one (which may or may not happen). */
14349 && DECL_RTL (tem) == 0)
14351 if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14353 else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14354 && DECL_INITIAL (tem) != 0)
14361 /* Create the FUNCTION_DECL for a function definition.
14362 DECLSPECS and DECLARATOR are the parts of the declaration;
14363 they describe the function's name and the type it returns,
14364 but twisted together in a fashion that parallels the syntax of C.
14366 This function creates a binding context for the function body
14367 as well as setting up the FUNCTION_DECL in current_function_decl.
14369 Returns 1 on success. If the DECLARATOR is not suitable for a function
14370 (it defines a datum instead), we return 0, which tells
14371 yyparse to report a parse error.
14373 NESTED is nonzero for a function nested within another function. */
14376 start_function (tree name, tree type, int nested, int public)
14380 int old_immediate_size_expand = immediate_size_expand;
14383 shadowed_labels = 0;
14385 /* Don't expand any sizes in the return type of the function. */
14386 immediate_size_expand = 0;
14391 assert (current_function_decl != NULL_TREE);
14392 assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14396 assert (current_function_decl == NULL_TREE);
14399 if (TREE_CODE (type) == ERROR_MARK)
14400 decl1 = current_function_decl = error_mark_node;
14403 decl1 = build_decl (FUNCTION_DECL,
14406 TREE_PUBLIC (decl1) = public ? 1 : 0;
14408 DECL_INLINE (decl1) = 1;
14409 TREE_STATIC (decl1) = 1;
14410 DECL_EXTERNAL (decl1) = 0;
14412 announce_function (decl1);
14414 /* Make the init_value nonzero so pushdecl knows this is not tentative.
14415 error_mark_node is replaced below (in poplevel) with the BLOCK. */
14416 DECL_INITIAL (decl1) = error_mark_node;
14418 /* Record the decl so that the function name is defined. If we already have
14419 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
14421 current_function_decl = pushdecl (decl1);
14425 ffecom_outer_function_decl_ = current_function_decl;
14428 current_binding_level->prep_state = 2;
14430 if (TREE_CODE (current_function_decl) != ERROR_MARK)
14432 make_function_rtl (current_function_decl);
14434 restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14435 DECL_RESULT (current_function_decl)
14436 = build_decl (RESULT_DECL, NULL_TREE, restype);
14439 if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14440 TREE_ADDRESSABLE (current_function_decl) = 1;
14442 immediate_size_expand = old_immediate_size_expand;
14445 /* Here are the public functions the GNU back end needs. */
14448 convert (type, expr)
14451 register tree e = expr;
14452 register enum tree_code code = TREE_CODE (type);
14454 if (type == TREE_TYPE (e)
14455 || TREE_CODE (e) == ERROR_MARK)
14457 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14458 return fold (build1 (NOP_EXPR, type, e));
14459 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14460 || code == ERROR_MARK)
14461 return error_mark_node;
14462 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14464 assert ("void value not ignored as it ought to be" == NULL);
14465 return error_mark_node;
14467 if (code == VOID_TYPE)
14468 return build1 (CONVERT_EXPR, type, e);
14469 if ((code != RECORD_TYPE)
14470 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14471 e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14473 if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14474 return fold (convert_to_integer (type, e));
14475 if (code == POINTER_TYPE)
14476 return fold (convert_to_pointer (type, e));
14477 if (code == REAL_TYPE)
14478 return fold (convert_to_real (type, e));
14479 if (code == COMPLEX_TYPE)
14480 return fold (convert_to_complex (type, e));
14481 if (code == RECORD_TYPE)
14482 return fold (ffecom_convert_to_complex_ (type, e));
14484 assert ("conversion to non-scalar type requested" == NULL);
14485 return error_mark_node;
14488 /* integrate_decl_tree calls this function, but since we don't use the
14489 DECL_LANG_SPECIFIC field, this is a no-op. */
14492 copy_lang_decl (node)
14497 /* Return the list of declarations of the current level.
14498 Note that this list is in reverse order unless/until
14499 you nreverse it; and when you do nreverse it, you must
14500 store the result back using `storedecls' or you will lose. */
14505 return current_binding_level->names;
14508 /* Nonzero if we are currently in the global binding level. */
14511 global_bindings_p ()
14513 return current_binding_level == global_binding_level;
14516 /* Print an error message for invalid use of an incomplete type.
14517 VALUE is the expression that was used (or 0 if that isn't known)
14518 and TYPE is the type that was invalid. */
14521 incomplete_type_error (value, type)
14525 if (TREE_CODE (type) == ERROR_MARK)
14528 assert ("incomplete type?!?" == NULL);
14531 /* Mark ARG for GC. */
14533 mark_binding_level (void *arg)
14535 struct binding_level *level = *(struct binding_level **) arg;
14539 ggc_mark_tree (level->names);
14540 ggc_mark_tree (level->blocks);
14541 ggc_mark_tree (level->this_block);
14542 level = level->level_chain;
14547 init_decl_processing ()
14549 static tree *const tree_roots[] = {
14550 ¤t_function_decl,
14552 &ffecom_tree_fun_type_void,
14553 &ffecom_integer_zero_node,
14554 &ffecom_integer_one_node,
14555 &ffecom_tree_subr_type,
14556 &ffecom_tree_ptr_to_subr_type,
14557 &ffecom_tree_blockdata_type,
14558 &ffecom_tree_xargc_,
14559 &ffecom_f2c_integer_type_node,
14560 &ffecom_f2c_ptr_to_integer_type_node,
14561 &ffecom_f2c_address_type_node,
14562 &ffecom_f2c_real_type_node,
14563 &ffecom_f2c_ptr_to_real_type_node,
14564 &ffecom_f2c_doublereal_type_node,
14565 &ffecom_f2c_complex_type_node,
14566 &ffecom_f2c_doublecomplex_type_node,
14567 &ffecom_f2c_longint_type_node,
14568 &ffecom_f2c_logical_type_node,
14569 &ffecom_f2c_flag_type_node,
14570 &ffecom_f2c_ftnlen_type_node,
14571 &ffecom_f2c_ftnlen_zero_node,
14572 &ffecom_f2c_ftnlen_one_node,
14573 &ffecom_f2c_ftnlen_two_node,
14574 &ffecom_f2c_ptr_to_ftnlen_type_node,
14575 &ffecom_f2c_ftnint_type_node,
14576 &ffecom_f2c_ptr_to_ftnint_type_node,
14577 &ffecom_outer_function_decl_,
14578 &ffecom_previous_function_decl_,
14579 &ffecom_which_entrypoint_decl_,
14580 &ffecom_float_zero_,
14581 &ffecom_float_half_,
14582 &ffecom_double_zero_,
14583 &ffecom_double_half_,
14584 &ffecom_func_result_,
14585 &ffecom_func_length_,
14586 &ffecom_multi_type_node_,
14587 &ffecom_multi_retval_,
14595 /* Record our roots. */
14596 for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14597 ggc_add_tree_root (tree_roots[i], 1);
14598 ggc_add_tree_root (&ffecom_tree_type[0][0],
14599 FFEINFO_basictype*FFEINFO_kindtype);
14600 ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14601 FFEINFO_basictype*FFEINFO_kindtype);
14602 ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14603 FFEINFO_basictype*FFEINFO_kindtype);
14604 ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14605 ggc_add_root (¤t_binding_level, 1, sizeof current_binding_level,
14606 mark_binding_level);
14607 ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14608 mark_binding_level);
14609 ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14615 init_parse (filename)
14616 const char *filename;
14618 /* Open input file. */
14619 if (filename == 0 || !strcmp (filename, "-"))
14622 filename = "stdin";
14625 finput = fopen (filename, "r");
14627 pfatal_with_name (filename);
14629 #ifdef IO_BUFFER_SIZE
14630 setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14633 /* Make identifier nodes long enough for the language-specific slots. */
14634 set_identifier_size (sizeof (struct lang_identifier));
14635 decl_printable_name = lang_printable_name;
14637 print_error_function = lang_print_error_function;
14649 /* Delete the node BLOCK from the current binding level.
14650 This is used for the block inside a stmt expr ({...})
14651 so that the block can be reinserted where appropriate. */
14654 delete_block (block)
14658 if (current_binding_level->blocks == block)
14659 current_binding_level->blocks = TREE_CHAIN (block);
14660 for (t = current_binding_level->blocks; t;)
14662 if (TREE_CHAIN (t) == block)
14663 TREE_CHAIN (t) = TREE_CHAIN (block);
14665 t = TREE_CHAIN (t);
14667 TREE_CHAIN (block) = NULL;
14668 /* Clear TREE_USED which is always set by poplevel.
14669 The flag is set again if insert_block is called. */
14670 TREE_USED (block) = 0;
14674 insert_block (block)
14677 TREE_USED (block) = 1;
14678 current_binding_level->blocks
14679 = chainon (current_binding_level->blocks, block);
14683 lang_decode_option (argc, argv)
14687 return ffe_decode_option (argc, argv);
14690 /* used by print-tree.c */
14693 lang_print_xnode (file, node, indent)
14703 ffe_terminate_0 ();
14705 if (ffe_is_ffedebug ())
14706 malloc_pool_display (malloc_pool_image ());
14715 /* Return the typed-based alias set for T, which may be an expression
14716 or a type. Return -1 if we don't do anything special. */
14719 lang_get_alias_set (t)
14720 tree t ATTRIBUTE_UNUSED;
14722 /* We do not wish to use alias-set based aliasing at all. Used in the
14723 extreme (every object with its own set, with equivalences recorded)
14724 it might be helpful, but there are problems when it comes to inlining.
14725 We get on ok with flag_argument_noalias, and alias-set aliasing does
14726 currently limit how stack slots can be reused, which is a lose. */
14731 lang_init_options ()
14733 /* Set default options for Fortran. */
14734 flag_move_all_movables = 1;
14735 flag_reduce_all_givs = 1;
14736 flag_argument_noalias = 2;
14737 flag_errno_math = 0;
14738 flag_complex_divide_method = 1;
14744 /* If the file is output from cpp, it should contain a first line
14745 `# 1 "real-filename"', and the current design of gcc (toplev.c
14746 in particular and the way it sets up information relied on by
14747 INCLUDE) requires that we read this now, and store the
14748 "real-filename" info in master_input_filename. Ask the lexer
14749 to try doing this. */
14750 ffelex_hash_kludge (finput);
14754 mark_addressable (exp)
14757 register tree x = exp;
14759 switch (TREE_CODE (x))
14762 case COMPONENT_REF:
14764 x = TREE_OPERAND (x, 0);
14768 TREE_ADDRESSABLE (x) = 1;
14775 if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14776 && DECL_NONLOCAL (x))
14778 if (TREE_PUBLIC (x))
14780 assert ("address of global register var requested" == NULL);
14783 assert ("address of register variable requested" == NULL);
14785 else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14787 if (TREE_PUBLIC (x))
14789 assert ("address of global register var requested" == NULL);
14792 assert ("address of register var requested" == NULL);
14794 put_var_into_stack (x);
14797 case FUNCTION_DECL:
14798 TREE_ADDRESSABLE (x) = 1;
14799 #if 0 /* poplevel deals with this now. */
14800 if (DECL_CONTEXT (x) == 0)
14801 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14809 /* If DECL has a cleanup, build and return that cleanup here.
14810 This is a callback called by expand_expr. */
14813 maybe_build_cleanup (decl)
14816 /* There are no cleanups in Fortran. */
14820 /* Exit a binding level.
14821 Pop the level off, and restore the state of the identifier-decl mappings
14822 that were in effect when this level was entered.
14824 If KEEP is nonzero, this level had explicit declarations, so
14825 and create a "block" (a BLOCK node) for the level
14826 to record its declarations and subblocks for symbol table output.
14828 If FUNCTIONBODY is nonzero, this level is the body of a function,
14829 so create a block as if KEEP were set and also clear out all
14832 If REVERSE is nonzero, reverse the order of decls before putting
14833 them into the BLOCK. */
14836 poplevel (keep, reverse, functionbody)
14841 register tree link;
14842 /* The chain of decls was accumulated in reverse order.
14843 Put it into forward order, just for cleanliness. */
14845 tree subblocks = current_binding_level->blocks;
14848 int block_previously_created;
14850 /* Get the decls in the order they were written.
14851 Usually current_binding_level->names is in reverse order.
14852 But parameter decls were previously put in forward order. */
14855 current_binding_level->names
14856 = decls = nreverse (current_binding_level->names);
14858 decls = current_binding_level->names;
14860 /* Output any nested inline functions within this block
14861 if they weren't already output. */
14863 for (decl = decls; decl; decl = TREE_CHAIN (decl))
14864 if (TREE_CODE (decl) == FUNCTION_DECL
14865 && ! TREE_ASM_WRITTEN (decl)
14866 && DECL_INITIAL (decl) != 0
14867 && TREE_ADDRESSABLE (decl))
14869 /* If this decl was copied from a file-scope decl
14870 on account of a block-scope extern decl,
14871 propagate TREE_ADDRESSABLE to the file-scope decl.
14873 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14874 true, since then the decl goes through save_for_inline_copying. */
14875 if (DECL_ABSTRACT_ORIGIN (decl) != 0
14876 && DECL_ABSTRACT_ORIGIN (decl) != decl)
14877 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14878 else if (DECL_SAVED_INSNS (decl) != 0)
14880 push_function_context ();
14881 output_inline_function (decl);
14882 pop_function_context ();
14886 /* If there were any declarations or structure tags in that level,
14887 or if this level is a function body,
14888 create a BLOCK to record them for the life of this function. */
14891 block_previously_created = (current_binding_level->this_block != 0);
14892 if (block_previously_created)
14893 block = current_binding_level->this_block;
14894 else if (keep || functionbody)
14895 block = make_node (BLOCK);
14898 BLOCK_VARS (block) = decls;
14899 BLOCK_SUBBLOCKS (block) = subblocks;
14902 /* In each subblock, record that this is its superior. */
14904 for (link = subblocks; link; link = TREE_CHAIN (link))
14905 BLOCK_SUPERCONTEXT (link) = block;
14907 /* Clear out the meanings of the local variables of this level. */
14909 for (link = decls; link; link = TREE_CHAIN (link))
14911 if (DECL_NAME (link) != 0)
14913 /* If the ident. was used or addressed via a local extern decl,
14914 don't forget that fact. */
14915 if (DECL_EXTERNAL (link))
14917 if (TREE_USED (link))
14918 TREE_USED (DECL_NAME (link)) = 1;
14919 if (TREE_ADDRESSABLE (link))
14920 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14922 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14926 /* If the level being exited is the top level of a function,
14927 check over all the labels, and clear out the current
14928 (function local) meanings of their names. */
14932 /* If this is the top level block of a function,
14933 the vars are the function's parameters.
14934 Don't leave them in the BLOCK because they are
14935 found in the FUNCTION_DECL instead. */
14937 BLOCK_VARS (block) = 0;
14940 /* Pop the current level, and free the structure for reuse. */
14943 register struct binding_level *level = current_binding_level;
14944 current_binding_level = current_binding_level->level_chain;
14946 level->level_chain = free_binding_level;
14947 free_binding_level = level;
14950 /* Dispose of the block that we just made inside some higher level. */
14952 && current_function_decl != error_mark_node)
14953 DECL_INITIAL (current_function_decl) = block;
14956 if (!block_previously_created)
14957 current_binding_level->blocks
14958 = chainon (current_binding_level->blocks, block);
14960 /* If we did not make a block for the level just exited,
14961 any blocks made for inner levels
14962 (since they cannot be recorded as subblocks in that level)
14963 must be carried forward so they will later become subblocks
14964 of something else. */
14965 else if (subblocks)
14966 current_binding_level->blocks
14967 = chainon (current_binding_level->blocks, subblocks);
14970 TREE_USED (block) = 1;
14975 print_lang_decl (file, node, indent)
14983 print_lang_identifier (file, node, indent)
14988 print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14989 print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14993 print_lang_statistics ()
14998 print_lang_type (file, node, indent)
15005 /* Record a decl-node X as belonging to the current lexical scope.
15006 Check for errors (such as an incompatible declaration for the same
15007 name already seen in the same scope).
15009 Returns either X or an old decl for the same name.
15010 If an old decl is returned, it may have been smashed
15011 to agree with what X says. */
15018 register tree name = DECL_NAME (x);
15019 register struct binding_level *b = current_binding_level;
15021 if ((TREE_CODE (x) == FUNCTION_DECL)
15022 && (DECL_INITIAL (x) == 0)
15023 && DECL_EXTERNAL (x))
15024 DECL_CONTEXT (x) = NULL_TREE;
15026 DECL_CONTEXT (x) = current_function_decl;
15030 if (IDENTIFIER_INVENTED (name))
15033 DECL_ARTIFICIAL (x) = 1;
15035 DECL_IN_SYSTEM_HEADER (x) = 1;
15038 t = lookup_name_current_level (name);
15040 assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
15042 /* Don't push non-parms onto list for parms until we understand
15043 why we're doing this and whether it works. */
15045 assert ((b == global_binding_level)
15046 || !ffecom_transform_only_dummies_
15047 || TREE_CODE (x) == PARM_DECL);
15049 if ((t != NULL_TREE) && duplicate_decls (x, t))
15052 /* If we are processing a typedef statement, generate a whole new
15053 ..._TYPE node (which will be just an variant of the existing
15054 ..._TYPE node with identical properties) and then install the
15055 TYPE_DECL node generated to represent the typedef name as the
15056 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15058 The whole point here is to end up with a situation where each and every
15059 ..._TYPE node the compiler creates will be uniquely associated with
15060 AT MOST one node representing a typedef name. This way, even though
15061 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15062 (i.e. "typedef name") nodes very early on, later parts of the
15063 compiler can always do the reverse translation and get back the
15064 corresponding typedef name. For example, given:
15066 typedef struct S MY_TYPE; MY_TYPE object;
15068 Later parts of the compiler might only know that `object' was of type
15069 `struct S' if it were not for code just below. With this code
15070 however, later parts of the compiler see something like:
15072 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15074 And they can then deduce (from the node for type struct S') that the
15075 original object declaration was:
15079 Being able to do this is important for proper support of protoize, and
15080 also for generating precise symbolic debugging information which
15081 takes full account of the programmer's (typedef) vocabulary.
15083 Obviously, we don't want to generate a duplicate ..._TYPE node if the
15084 TYPE_DECL node that we are now processing really represents a
15085 standard built-in type.
15087 Since all standard types are effectively declared at line zero in the
15088 source file, we can easily check to see if we are working on a
15089 standard type by checking the current value of lineno. */
15091 if (TREE_CODE (x) == TYPE_DECL)
15093 if (DECL_SOURCE_LINE (x) == 0)
15095 if (TYPE_NAME (TREE_TYPE (x)) == 0)
15096 TYPE_NAME (TREE_TYPE (x)) = x;
15098 else if (TREE_TYPE (x) != error_mark_node)
15100 tree tt = TREE_TYPE (x);
15102 tt = build_type_copy (tt);
15103 TYPE_NAME (tt) = x;
15104 TREE_TYPE (x) = tt;
15108 /* This name is new in its binding level. Install the new declaration
15110 if (b == global_binding_level)
15111 IDENTIFIER_GLOBAL_VALUE (name) = x;
15113 IDENTIFIER_LOCAL_VALUE (name) = x;
15116 /* Put decls on list in reverse order. We will reverse them later if
15118 TREE_CHAIN (x) = b->names;
15124 /* Nonzero if the current level needs to have a BLOCK made. */
15131 for (decl = current_binding_level->names;
15133 decl = TREE_CHAIN (decl))
15135 if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15136 || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15137 /* Currently, there aren't supposed to be non-artificial names
15138 at other than the top block for a function -- they're
15139 believed to always be temps. But it's wise to check anyway. */
15145 /* Enter a new binding level.
15146 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15147 not for that of tags. */
15150 pushlevel (tag_transparent)
15151 int tag_transparent;
15153 register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15155 assert (! tag_transparent);
15157 if (current_binding_level == global_binding_level)
15162 /* Reuse or create a struct for this binding level. */
15164 if (free_binding_level)
15166 newlevel = free_binding_level;
15167 free_binding_level = free_binding_level->level_chain;
15171 newlevel = make_binding_level ();
15174 /* Add this level to the front of the chain (stack) of levels that
15177 *newlevel = clear_binding_level;
15178 newlevel->level_chain = current_binding_level;
15179 current_binding_level = newlevel;
15182 /* Set the BLOCK node for the innermost scope
15183 (the one we are currently in). */
15187 register tree block;
15189 current_binding_level->this_block = block;
15192 /* ~~gcc/tree.h *should* declare this, because toplev.c references it. */
15194 /* Can't 'yydebug' a front end not generated by yacc/bison! */
15197 set_yydebug (value)
15201 fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15205 signed_or_unsigned_type (unsignedp, type)
15211 if (! INTEGRAL_TYPE_P (type))
15213 if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15214 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15215 if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15216 return unsignedp ? unsigned_type_node : integer_type_node;
15217 if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15218 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15219 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15220 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15221 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15222 return (unsignedp ? long_long_unsigned_type_node
15223 : long_long_integer_type_node);
15225 type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15226 if (type2 == NULL_TREE)
15236 tree type1 = TYPE_MAIN_VARIANT (type);
15237 ffeinfoKindtype kt;
15240 if (type1 == unsigned_char_type_node || type1 == char_type_node)
15241 return signed_char_type_node;
15242 if (type1 == unsigned_type_node)
15243 return integer_type_node;
15244 if (type1 == short_unsigned_type_node)
15245 return short_integer_type_node;
15246 if (type1 == long_unsigned_type_node)
15247 return long_integer_type_node;
15248 if (type1 == long_long_unsigned_type_node)
15249 return long_long_integer_type_node;
15250 #if 0 /* gcc/c-* files only */
15251 if (type1 == unsigned_intDI_type_node)
15252 return intDI_type_node;
15253 if (type1 == unsigned_intSI_type_node)
15254 return intSI_type_node;
15255 if (type1 == unsigned_intHI_type_node)
15256 return intHI_type_node;
15257 if (type1 == unsigned_intQI_type_node)
15258 return intQI_type_node;
15261 type2 = type_for_size (TYPE_PRECISION (type1), 0);
15262 if (type2 != NULL_TREE)
15265 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15267 type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15269 if (type1 == type2)
15270 return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15276 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15277 or validate its data type for an `if' or `while' statement or ?..: exp.
15279 This preparation consists of taking the ordinary
15280 representation of an expression expr and producing a valid tree
15281 boolean expression describing whether expr is nonzero. We could
15282 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15283 but we optimize comparisons, &&, ||, and !.
15285 The resulting type should always be `integer_type_node'. */
15288 truthvalue_conversion (expr)
15291 if (TREE_CODE (expr) == ERROR_MARK)
15294 #if 0 /* This appears to be wrong for C++. */
15295 /* These really should return error_mark_node after 2.4 is stable.
15296 But not all callers handle ERROR_MARK properly. */
15297 switch (TREE_CODE (TREE_TYPE (expr)))
15300 error ("struct type value used where scalar is required");
15301 return integer_zero_node;
15304 error ("union type value used where scalar is required");
15305 return integer_zero_node;
15308 error ("array type value used where scalar is required");
15309 return integer_zero_node;
15316 switch (TREE_CODE (expr))
15318 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15319 or comparison expressions as truth values at this level. */
15321 case COMPONENT_REF:
15322 /* A one-bit unsigned bit-field is already acceptable. */
15323 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15324 && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15330 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15331 or comparison expressions as truth values at this level. */
15333 if (integer_zerop (TREE_OPERAND (expr, 1)))
15334 return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15336 case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15337 case TRUTH_ANDIF_EXPR:
15338 case TRUTH_ORIF_EXPR:
15339 case TRUTH_AND_EXPR:
15340 case TRUTH_OR_EXPR:
15341 case TRUTH_XOR_EXPR:
15342 TREE_TYPE (expr) = integer_type_node;
15349 return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15352 return real_zerop (expr) ? integer_zero_node : integer_one_node;
15355 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15356 return build (COMPOUND_EXPR, integer_type_node,
15357 TREE_OPERAND (expr, 0), integer_one_node);
15359 return integer_one_node;
15362 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15363 ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15365 truthvalue_conversion (TREE_OPERAND (expr, 0)),
15366 truthvalue_conversion (TREE_OPERAND (expr, 1)));
15372 /* These don't change whether an object is non-zero or zero. */
15373 return truthvalue_conversion (TREE_OPERAND (expr, 0));
15377 /* These don't change whether an object is zero or non-zero, but
15378 we can't ignore them if their second arg has side-effects. */
15379 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15380 return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15381 truthvalue_conversion (TREE_OPERAND (expr, 0)));
15383 return truthvalue_conversion (TREE_OPERAND (expr, 0));
15386 /* Distribute the conversion into the arms of a COND_EXPR. */
15387 return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15388 truthvalue_conversion (TREE_OPERAND (expr, 1)),
15389 truthvalue_conversion (TREE_OPERAND (expr, 2))));
15392 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15393 since that affects how `default_conversion' will behave. */
15394 if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15395 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15397 /* fall through... */
15399 /* If this is widening the argument, we can ignore it. */
15400 if (TYPE_PRECISION (TREE_TYPE (expr))
15401 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15402 return truthvalue_conversion (TREE_OPERAND (expr, 0));
15406 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15408 if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15409 && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15411 /* fall through... */
15413 /* This and MINUS_EXPR can be changed into a comparison of the
15415 if (TREE_TYPE (TREE_OPERAND (expr, 0))
15416 == TREE_TYPE (TREE_OPERAND (expr, 1)))
15417 return ffecom_2 (NE_EXPR, integer_type_node,
15418 TREE_OPERAND (expr, 0),
15419 TREE_OPERAND (expr, 1));
15420 return ffecom_2 (NE_EXPR, integer_type_node,
15421 TREE_OPERAND (expr, 0),
15422 fold (build1 (NOP_EXPR,
15423 TREE_TYPE (TREE_OPERAND (expr, 0)),
15424 TREE_OPERAND (expr, 1))));
15427 if (integer_onep (TREE_OPERAND (expr, 1)))
15432 #if 0 /* No such thing in Fortran. */
15433 if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15434 warning ("suggest parentheses around assignment used as truth value");
15442 if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15444 ((TREE_SIDE_EFFECTS (expr)
15445 ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15447 truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15448 TREE_TYPE (TREE_TYPE (expr)),
15450 truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15451 TREE_TYPE (TREE_TYPE (expr)),
15454 return ffecom_2 (NE_EXPR, integer_type_node,
15456 convert (TREE_TYPE (expr), integer_zero_node));
15460 type_for_mode (mode, unsignedp)
15461 enum machine_mode mode;
15468 if (mode == TYPE_MODE (integer_type_node))
15469 return unsignedp ? unsigned_type_node : integer_type_node;
15471 if (mode == TYPE_MODE (signed_char_type_node))
15472 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15474 if (mode == TYPE_MODE (short_integer_type_node))
15475 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15477 if (mode == TYPE_MODE (long_integer_type_node))
15478 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15480 if (mode == TYPE_MODE (long_long_integer_type_node))
15481 return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15483 #if HOST_BITS_PER_WIDE_INT >= 64
15484 if (mode == TYPE_MODE (intTI_type_node))
15485 return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15488 if (mode == TYPE_MODE (float_type_node))
15489 return float_type_node;
15491 if (mode == TYPE_MODE (double_type_node))
15492 return double_type_node;
15494 if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15495 return build_pointer_type (char_type_node);
15497 if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15498 return build_pointer_type (integer_type_node);
15500 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15501 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15503 if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15504 && (mode == TYPE_MODE (t)))
15506 if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15507 return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15517 type_for_size (bits, unsignedp)
15521 ffeinfoKindtype kt;
15524 if (bits == TYPE_PRECISION (integer_type_node))
15525 return unsignedp ? unsigned_type_node : integer_type_node;
15527 if (bits == TYPE_PRECISION (signed_char_type_node))
15528 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15530 if (bits == TYPE_PRECISION (short_integer_type_node))
15531 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15533 if (bits == TYPE_PRECISION (long_integer_type_node))
15534 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15536 if (bits == TYPE_PRECISION (long_long_integer_type_node))
15537 return (unsignedp ? long_long_unsigned_type_node
15538 : long_long_integer_type_node);
15540 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15542 type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15544 if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15545 return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15553 unsigned_type (type)
15556 tree type1 = TYPE_MAIN_VARIANT (type);
15557 ffeinfoKindtype kt;
15560 if (type1 == signed_char_type_node || type1 == char_type_node)
15561 return unsigned_char_type_node;
15562 if (type1 == integer_type_node)
15563 return unsigned_type_node;
15564 if (type1 == short_integer_type_node)
15565 return short_unsigned_type_node;
15566 if (type1 == long_integer_type_node)
15567 return long_unsigned_type_node;
15568 if (type1 == long_long_integer_type_node)
15569 return long_long_unsigned_type_node;
15570 #if 0 /* gcc/c-* files only */
15571 if (type1 == intDI_type_node)
15572 return unsigned_intDI_type_node;
15573 if (type1 == intSI_type_node)
15574 return unsigned_intSI_type_node;
15575 if (type1 == intHI_type_node)
15576 return unsigned_intHI_type_node;
15577 if (type1 == intQI_type_node)
15578 return unsigned_intQI_type_node;
15581 type2 = type_for_size (TYPE_PRECISION (type1), 1);
15582 if (type2 != NULL_TREE)
15585 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15587 type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15589 if (type1 == type2)
15590 return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15598 union tree_node *t ATTRIBUTE_UNUSED;
15600 if (TREE_CODE (t) == IDENTIFIER_NODE)
15602 struct lang_identifier *i = (struct lang_identifier *) t;
15603 ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15604 ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15605 ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15607 else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15608 ggc_mark (TYPE_LANG_SPECIFIC (t));
15611 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15613 #if FFECOM_GCC_INCLUDE
15615 /* From gcc/cccp.c, the code to handle -I. */
15617 /* Skip leading "./" from a directory name.
15618 This may yield the empty string, which represents the current directory. */
15620 static const char *
15621 skip_redundant_dir_prefix (const char *dir)
15623 while (dir[0] == '.' && dir[1] == '/')
15624 for (dir += 2; *dir == '/'; dir++)
15626 if (dir[0] == '.' && !dir[1])
15631 /* The file_name_map structure holds a mapping of file names for a
15632 particular directory. This mapping is read from the file named
15633 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15634 map filenames on a file system with severe filename restrictions,
15635 such as DOS. The format of the file name map file is just a series
15636 of lines with two tokens on each line. The first token is the name
15637 to map, and the second token is the actual name to use. */
15639 struct file_name_map
15641 struct file_name_map *map_next;
15646 #define FILE_NAME_MAP_FILE "header.gcc"
15648 /* Current maximum length of directory names in the search path
15649 for include files. (Altered as we get more of them.) */
15651 static int max_include_len = 0;
15653 struct file_name_list
15655 struct file_name_list *next;
15657 /* Mapping of file names for this directory. */
15658 struct file_name_map *name_map;
15659 /* Non-zero if name_map is valid. */
15663 static struct file_name_list *include = NULL; /* First dir to search */
15664 static struct file_name_list *last_include = NULL; /* Last in chain */
15666 /* I/O buffer structure.
15667 The `fname' field is nonzero for source files and #include files
15668 and for the dummy text used for -D and -U.
15669 It is zero for rescanning results of macro expansion
15670 and for expanding macro arguments. */
15671 #define INPUT_STACK_MAX 400
15672 static struct file_buf {
15674 /* Filename specified with #line command. */
15675 const char *nominal_fname;
15676 /* Record where in the search path this file was found.
15677 For #include_next. */
15678 struct file_name_list *dir;
15680 ffewhereColumn column;
15681 } instack[INPUT_STACK_MAX];
15683 static int last_error_tick = 0; /* Incremented each time we print it. */
15684 static int input_file_stack_tick = 0; /* Incremented when status changes. */
15686 /* Current nesting level of input sources.
15687 `instack[indepth]' is the level currently being read. */
15688 static int indepth = -1;
15690 typedef struct file_buf FILE_BUF;
15692 typedef unsigned char U_CHAR;
15694 /* table to tell if char can be part of a C identifier. */
15695 U_CHAR is_idchar[256];
15696 /* table to tell if char can be first char of a c identifier. */
15697 U_CHAR is_idstart[256];
15698 /* table to tell if c is horizontal space. */
15699 U_CHAR is_hor_space[256];
15700 /* table to tell if c is horizontal or vertical space. */
15701 static U_CHAR is_space[256];
15703 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15704 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15706 /* Nonzero means -I- has been seen,
15707 so don't look for #include "foo" the source-file directory. */
15708 static int ignore_srcdir;
15710 #ifndef INCLUDE_LEN_FUDGE
15711 #define INCLUDE_LEN_FUDGE 0
15714 static void append_include_chain (struct file_name_list *first,
15715 struct file_name_list *last);
15716 static FILE *open_include_file (char *filename,
15717 struct file_name_list *searchptr);
15718 static void print_containing_files (ffebadSeverity sev);
15719 static const char *skip_redundant_dir_prefix (const char *);
15720 static char *read_filename_string (int ch, FILE *f);
15721 static struct file_name_map *read_name_map (const char *dirname);
15723 /* Append a chain of `struct file_name_list's
15724 to the end of the main include chain.
15725 FIRST is the beginning of the chain to append, and LAST is the end. */
15728 append_include_chain (first, last)
15729 struct file_name_list *first, *last;
15731 struct file_name_list *dir;
15733 if (!first || !last)
15739 last_include->next = first;
15741 for (dir = first; ; dir = dir->next) {
15742 int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15743 if (len > max_include_len)
15744 max_include_len = len;
15750 last_include = last;
15753 /* Try to open include file FILENAME. SEARCHPTR is the directory
15754 being tried from the include file search path. This function maps
15755 filenames on file systems based on information read by
15759 open_include_file (filename, searchptr)
15761 struct file_name_list *searchptr;
15763 register struct file_name_map *map;
15764 register char *from;
15767 if (searchptr && ! searchptr->got_name_map)
15769 searchptr->name_map = read_name_map (searchptr->fname
15770 ? searchptr->fname : ".");
15771 searchptr->got_name_map = 1;
15774 /* First check the mapping for the directory we are using. */
15775 if (searchptr && searchptr->name_map)
15778 if (searchptr->fname)
15779 from += strlen (searchptr->fname) + 1;
15780 for (map = searchptr->name_map; map; map = map->map_next)
15782 if (! strcmp (map->map_from, from))
15784 /* Found a match. */
15785 return fopen (map->map_to, "r");
15790 /* Try to find a mapping file for the particular directory we are
15791 looking in. Thus #include <sys/types.h> will look up sys/types.h
15792 in /usr/include/header.gcc and look up types.h in
15793 /usr/include/sys/header.gcc. */
15794 p = strrchr (filename, '/');
15795 #ifdef DIR_SEPARATOR
15796 if (! p) p = strrchr (filename, DIR_SEPARATOR);
15798 char *tmp = strrchr (filename, DIR_SEPARATOR);
15799 if (tmp != NULL && tmp > p) p = tmp;
15805 && searchptr->fname
15806 && strlen (searchptr->fname) == (size_t) (p - filename)
15807 && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15809 /* FILENAME is in SEARCHPTR, which we've already checked. */
15810 return fopen (filename, "r");
15816 map = read_name_map (".");
15820 dir = (char *) xmalloc (p - filename + 1);
15821 memcpy (dir, filename, p - filename);
15822 dir[p - filename] = '\0';
15824 map = read_name_map (dir);
15827 for (; map; map = map->map_next)
15828 if (! strcmp (map->map_from, from))
15829 return fopen (map->map_to, "r");
15831 return fopen (filename, "r");
15834 /* Print the file names and line numbers of the #include
15835 commands which led to the current file. */
15838 print_containing_files (ffebadSeverity sev)
15840 FILE_BUF *ip = NULL;
15846 /* If stack of files hasn't changed since we last printed
15847 this info, don't repeat it. */
15848 if (last_error_tick == input_file_stack_tick)
15851 for (i = indepth; i >= 0; i--)
15852 if (instack[i].fname != NULL) {
15857 /* Give up if we don't find a source file. */
15861 /* Find the other, outer source files. */
15862 for (i--; i >= 0; i--)
15863 if (instack[i].fname != NULL)
15869 str1 = "In file included";
15881 ffebad_start_msg ("%A from %B at %0%C", sev);
15882 ffebad_here (0, ip->line, ip->column);
15883 ffebad_string (str1);
15884 ffebad_string (ip->nominal_fname);
15885 ffebad_string (str2);
15889 /* Record we have printed the status as of this time. */
15890 last_error_tick = input_file_stack_tick;
15893 /* Read a space delimited string of unlimited length from a stdio
15897 read_filename_string (ch, f)
15905 set = alloc = xmalloc (len + 1);
15906 if (! is_space[ch])
15909 while ((ch = getc (f)) != EOF && ! is_space[ch])
15911 if (set - alloc == len)
15914 alloc = xrealloc (alloc, len + 1);
15915 set = alloc + len / 2;
15925 /* Read the file name map file for DIRNAME. */
15927 static struct file_name_map *
15928 read_name_map (dirname)
15929 const char *dirname;
15931 /* This structure holds a linked list of file name maps, one per
15933 struct file_name_map_list
15935 struct file_name_map_list *map_list_next;
15936 char *map_list_name;
15937 struct file_name_map *map_list_map;
15939 static struct file_name_map_list *map_list;
15940 register struct file_name_map_list *map_list_ptr;
15944 int separator_needed;
15946 dirname = skip_redundant_dir_prefix (dirname);
15948 for (map_list_ptr = map_list; map_list_ptr;
15949 map_list_ptr = map_list_ptr->map_list_next)
15950 if (! strcmp (map_list_ptr->map_list_name, dirname))
15951 return map_list_ptr->map_list_map;
15953 map_list_ptr = ((struct file_name_map_list *)
15954 xmalloc (sizeof (struct file_name_map_list)));
15955 map_list_ptr->map_list_name = xstrdup (dirname);
15956 map_list_ptr->map_list_map = NULL;
15958 dirlen = strlen (dirname);
15959 separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15960 name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15961 strcpy (name, dirname);
15962 name[dirlen] = '/';
15963 strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15964 f = fopen (name, "r");
15967 map_list_ptr->map_list_map = NULL;
15972 while ((ch = getc (f)) != EOF)
15975 struct file_name_map *ptr;
15979 from = read_filename_string (ch, f);
15980 while ((ch = getc (f)) != EOF && is_hor_space[ch])
15982 to = read_filename_string (ch, f);
15984 ptr = ((struct file_name_map *)
15985 xmalloc (sizeof (struct file_name_map)));
15986 ptr->map_from = from;
15988 /* Make the real filename absolute. */
15993 ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15994 strcpy (ptr->map_to, dirname);
15995 ptr->map_to[dirlen] = '/';
15996 strcpy (ptr->map_to + dirlen + separator_needed, to);
16000 ptr->map_next = map_list_ptr->map_list_map;
16001 map_list_ptr->map_list_map = ptr;
16003 while ((ch = getc (f)) != '\n')
16010 map_list_ptr->map_list_next = map_list;
16011 map_list = map_list_ptr;
16013 return map_list_ptr->map_list_map;
16017 ffecom_file_ (const char *name)
16021 /* Do partial setup of input buffer for the sake of generating
16022 early #line directives (when -g is in effect). */
16024 fp = &instack[++indepth];
16025 memset ((char *) fp, 0, sizeof (FILE_BUF));
16028 fp->nominal_fname = fp->fname = name;
16031 /* Initialize syntactic classifications of characters. */
16034 ffecom_initialize_char_syntax_ ()
16039 * Set up is_idchar and is_idstart tables. These should be
16040 * faster than saying (is_alpha (c) || c == '_'), etc.
16041 * Set up these things before calling any routines tthat
16044 for (i = 'a'; i <= 'z'; i++) {
16045 is_idchar[i - 'a' + 'A'] = 1;
16047 is_idstart[i - 'a' + 'A'] = 1;
16050 for (i = '0'; i <= '9'; i++)
16052 is_idchar['_'] = 1;
16053 is_idstart['_'] = 1;
16055 /* horizontal space table */
16056 is_hor_space[' '] = 1;
16057 is_hor_space['\t'] = 1;
16058 is_hor_space['\v'] = 1;
16059 is_hor_space['\f'] = 1;
16060 is_hor_space['\r'] = 1;
16063 is_space['\t'] = 1;
16064 is_space['\v'] = 1;
16065 is_space['\f'] = 1;
16066 is_space['\n'] = 1;
16067 is_space['\r'] = 1;
16071 ffecom_close_include_ (FILE *f)
16076 input_file_stack_tick++;
16078 ffewhere_line_kill (instack[indepth].line);
16079 ffewhere_column_kill (instack[indepth].column);
16083 ffecom_decode_include_option_ (char *spec)
16085 struct file_name_list *dirtmp;
16087 if (! ignore_srcdir && !strcmp (spec, "-"))
16091 dirtmp = (struct file_name_list *)
16092 xmalloc (sizeof (struct file_name_list));
16093 dirtmp->next = 0; /* New one goes on the end */
16095 dirtmp->fname = spec;
16097 fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16098 dirtmp->got_name_map = 0;
16099 append_include_chain (dirtmp, dirtmp);
16104 /* Open INCLUDEd file. */
16107 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16110 size_t flen = strlen (fbeg);
16111 struct file_name_list *search_start = include; /* Chain of dirs to search */
16112 struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16113 struct file_name_list *searchptr = 0;
16114 char *fname; /* Dynamically allocated fname buffer */
16121 dsp[0].fname = NULL;
16123 /* If -I- was specified, don't search current dir, only spec'd ones. */
16124 if (!ignore_srcdir)
16126 for (fp = &instack[indepth]; fp >= instack; fp--)
16132 if ((nam = fp->nominal_fname) != NULL)
16134 /* Found a named file. Figure out dir of the file,
16135 and put it in front of the search list. */
16136 dsp[0].next = search_start;
16137 search_start = dsp;
16139 ep = strrchr (nam, '/');
16140 #ifdef DIR_SEPARATOR
16141 if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
16143 char *tmp = strrchr (nam, DIR_SEPARATOR);
16144 if (tmp != NULL && tmp > ep) ep = tmp;
16148 ep = strrchr (nam, ']');
16149 if (ep == NULL) ep = strrchr (nam, '>');
16150 if (ep == NULL) ep = strrchr (nam, ':');
16151 if (ep != NULL) ep++;
16156 dsp[0].fname = (char *) xmalloc (n + 1);
16157 strncpy (dsp[0].fname, nam, n);
16158 dsp[0].fname[n] = '\0';
16159 if (n + INCLUDE_LEN_FUDGE > max_include_len)
16160 max_include_len = n + INCLUDE_LEN_FUDGE;
16163 dsp[0].fname = NULL; /* Current directory */
16164 dsp[0].got_name_map = 0;
16170 /* Allocate this permanently, because it gets stored in the definitions
16172 fname = xmalloc (max_include_len + flen + 4);
16173 /* + 2 above for slash and terminating null. */
16174 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16177 /* If specified file name is absolute, just open it. */
16180 #ifdef DIR_SEPARATOR
16181 || *fbeg == DIR_SEPARATOR
16185 strncpy (fname, (char *) fbeg, flen);
16187 f = open_include_file (fname, NULL_PTR);
16193 /* Search directory path, trying to open the file.
16194 Copy each filename tried into FNAME. */
16196 for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16198 if (searchptr->fname)
16200 /* The empty string in a search path is ignored.
16201 This makes it possible to turn off entirely
16202 a standard piece of the list. */
16203 if (searchptr->fname[0] == 0)
16205 strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16206 if (fname[0] && fname[strlen (fname) - 1] != '/')
16207 strcat (fname, "/");
16208 fname[strlen (fname) + flen] = 0;
16213 strncat (fname, fbeg, flen);
16215 /* Change this 1/2 Unix 1/2 VMS file specification into a
16216 full VMS file specification */
16217 if (searchptr->fname && (searchptr->fname[0] != 0))
16219 /* Fix up the filename */
16220 hack_vms_include_specification (fname);
16224 /* This is a normal VMS filespec, so use it unchanged. */
16225 strncpy (fname, (char *) fbeg, flen);
16227 #if 0 /* Not for g77. */
16228 /* if it's '#include filename', add the missing .h */
16229 if (strchr (fname, '.') == NULL)
16230 strcat (fname, ".h");
16234 f = open_include_file (fname, searchptr);
16236 if (f == NULL && errno == EACCES)
16238 print_containing_files (FFEBAD_severityWARNING);
16239 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16240 FFEBAD_severityWARNING);
16241 ffebad_string (fname);
16242 ffebad_here (0, l, c);
16253 /* A file that was not found. */
16255 strncpy (fname, (char *) fbeg, flen);
16257 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16258 ffebad_start (FFEBAD_OPEN_INCLUDE);
16259 ffebad_here (0, l, c);
16260 ffebad_string (fname);
16264 if (dsp[0].fname != NULL)
16265 free (dsp[0].fname);
16270 if (indepth >= (INPUT_STACK_MAX - 1))
16272 print_containing_files (FFEBAD_severityFATAL);
16273 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16274 FFEBAD_severityFATAL);
16275 ffebad_string (fname);
16276 ffebad_here (0, l, c);
16281 instack[indepth].line = ffewhere_line_use (l);
16282 instack[indepth].column = ffewhere_column_use (c);
16284 fp = &instack[indepth + 1];
16285 memset ((char *) fp, 0, sizeof (FILE_BUF));
16286 fp->nominal_fname = fp->fname = fname;
16287 fp->dir = searchptr;
16290 input_file_stack_tick++;
16294 #endif /* FFECOM_GCC_INCLUDE */
16296 /**INDENT* (Do not reformat this comment even with -fca option.)
16297 Data-gathering files: Given the source file listed below, compiled with
16298 f2c I obtained the output file listed after that, and from the output
16299 file I derived the above code.
16301 -------- (begin input file to f2c)
16307 double precision D1,D2
16309 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16336 c FFEINTRIN_impACOS
16337 call fooR(ACOS(R1))
16338 c FFEINTRIN_impAIMAG
16339 call fooR(AIMAG(C1))
16340 c FFEINTRIN_impAINT
16341 call fooR(AINT(R1))
16342 c FFEINTRIN_impALOG
16343 call fooR(ALOG(R1))
16344 c FFEINTRIN_impALOG10
16345 call fooR(ALOG10(R1))
16346 c FFEINTRIN_impAMAX0
16347 call fooR(AMAX0(I1,I2))
16348 c FFEINTRIN_impAMAX1
16349 call fooR(AMAX1(R1,R2))
16350 c FFEINTRIN_impAMIN0
16351 call fooR(AMIN0(I1,I2))
16352 c FFEINTRIN_impAMIN1
16353 call fooR(AMIN1(R1,R2))
16354 c FFEINTRIN_impAMOD
16355 call fooR(AMOD(R1,R2))
16356 c FFEINTRIN_impANINT
16357 call fooR(ANINT(R1))
16358 c FFEINTRIN_impASIN
16359 call fooR(ASIN(R1))
16360 c FFEINTRIN_impATAN
16361 call fooR(ATAN(R1))
16362 c FFEINTRIN_impATAN2
16363 call fooR(ATAN2(R1,R2))
16364 c FFEINTRIN_impCABS
16365 call fooR(CABS(C1))
16366 c FFEINTRIN_impCCOS
16367 call fooC(CCOS(C1))
16368 c FFEINTRIN_impCEXP
16369 call fooC(CEXP(C1))
16370 c FFEINTRIN_impCHAR
16371 call fooA(CHAR(I1))
16372 c FFEINTRIN_impCLOG
16373 call fooC(CLOG(C1))
16374 c FFEINTRIN_impCONJG
16375 call fooC(CONJG(C1))
16378 c FFEINTRIN_impCOSH
16379 call fooR(COSH(R1))
16380 c FFEINTRIN_impCSIN
16381 call fooC(CSIN(C1))
16382 c FFEINTRIN_impCSQRT
16383 call fooC(CSQRT(C1))
16384 c FFEINTRIN_impDABS
16385 call fooD(DABS(D1))
16386 c FFEINTRIN_impDACOS
16387 call fooD(DACOS(D1))
16388 c FFEINTRIN_impDASIN
16389 call fooD(DASIN(D1))
16390 c FFEINTRIN_impDATAN
16391 call fooD(DATAN(D1))
16392 c FFEINTRIN_impDATAN2
16393 call fooD(DATAN2(D1,D2))
16394 c FFEINTRIN_impDCOS
16395 call fooD(DCOS(D1))
16396 c FFEINTRIN_impDCOSH
16397 call fooD(DCOSH(D1))
16398 c FFEINTRIN_impDDIM
16399 call fooD(DDIM(D1,D2))
16400 c FFEINTRIN_impDEXP
16401 call fooD(DEXP(D1))
16403 call fooR(DIM(R1,R2))
16404 c FFEINTRIN_impDINT
16405 call fooD(DINT(D1))
16406 c FFEINTRIN_impDLOG
16407 call fooD(DLOG(D1))
16408 c FFEINTRIN_impDLOG10
16409 call fooD(DLOG10(D1))
16410 c FFEINTRIN_impDMAX1
16411 call fooD(DMAX1(D1,D2))
16412 c FFEINTRIN_impDMIN1
16413 call fooD(DMIN1(D1,D2))
16414 c FFEINTRIN_impDMOD
16415 call fooD(DMOD(D1,D2))
16416 c FFEINTRIN_impDNINT
16417 call fooD(DNINT(D1))
16418 c FFEINTRIN_impDPROD
16419 call fooD(DPROD(R1,R2))
16420 c FFEINTRIN_impDSIGN
16421 call fooD(DSIGN(D1,D2))
16422 c FFEINTRIN_impDSIN
16423 call fooD(DSIN(D1))
16424 c FFEINTRIN_impDSINH
16425 call fooD(DSINH(D1))
16426 c FFEINTRIN_impDSQRT
16427 call fooD(DSQRT(D1))
16428 c FFEINTRIN_impDTAN
16429 call fooD(DTAN(D1))
16430 c FFEINTRIN_impDTANH
16431 call fooD(DTANH(D1))
16434 c FFEINTRIN_impIABS
16435 call fooI(IABS(I1))
16436 c FFEINTRIN_impICHAR
16437 call fooI(ICHAR(A1))
16438 c FFEINTRIN_impIDIM
16439 call fooI(IDIM(I1,I2))
16440 c FFEINTRIN_impIDNINT
16441 call fooI(IDNINT(D1))
16442 c FFEINTRIN_impINDEX
16443 call fooI(INDEX(A1,A2))
16444 c FFEINTRIN_impISIGN
16445 call fooI(ISIGN(I1,I2))
16449 call fooL(LGE(A1,A2))
16451 call fooL(LGT(A1,A2))
16453 call fooL(LLE(A1,A2))
16455 call fooL(LLT(A1,A2))
16456 c FFEINTRIN_impMAX0
16457 call fooI(MAX0(I1,I2))
16458 c FFEINTRIN_impMAX1
16459 call fooI(MAX1(R1,R2))
16460 c FFEINTRIN_impMIN0
16461 call fooI(MIN0(I1,I2))
16462 c FFEINTRIN_impMIN1
16463 call fooI(MIN1(R1,R2))
16465 call fooI(MOD(I1,I2))
16466 c FFEINTRIN_impNINT
16467 call fooI(NINT(R1))
16468 c FFEINTRIN_impSIGN
16469 call fooR(SIGN(R1,R2))
16472 c FFEINTRIN_impSINH
16473 call fooR(SINH(R1))
16474 c FFEINTRIN_impSQRT
16475 call fooR(SQRT(R1))
16478 c FFEINTRIN_impTANH
16479 call fooR(TANH(R1))
16480 c FFEINTRIN_imp_CMPLX_C
16481 call fooC(cmplx(C1,C2))
16482 c FFEINTRIN_imp_CMPLX_D
16483 call fooZ(cmplx(D1,D2))
16484 c FFEINTRIN_imp_CMPLX_I
16485 call fooC(cmplx(I1,I2))
16486 c FFEINTRIN_imp_CMPLX_R
16487 call fooC(cmplx(R1,R2))
16488 c FFEINTRIN_imp_DBLE_C
16489 call fooD(dble(C1))
16490 c FFEINTRIN_imp_DBLE_D
16491 call fooD(dble(D1))
16492 c FFEINTRIN_imp_DBLE_I
16493 call fooD(dble(I1))
16494 c FFEINTRIN_imp_DBLE_R
16495 call fooD(dble(R1))
16496 c FFEINTRIN_imp_INT_C
16498 c FFEINTRIN_imp_INT_D
16500 c FFEINTRIN_imp_INT_I
16502 c FFEINTRIN_imp_INT_R
16504 c FFEINTRIN_imp_REAL_C
16505 call fooR(real(C1))
16506 c FFEINTRIN_imp_REAL_D
16507 call fooR(real(D1))
16508 c FFEINTRIN_imp_REAL_I
16509 call fooR(real(I1))
16510 c FFEINTRIN_imp_REAL_R
16511 call fooR(real(R1))
16513 c FFEINTRIN_imp_INT_D:
16515 c FFEINTRIN_specIDINT
16516 call fooI(IDINT(D1))
16518 c FFEINTRIN_imp_INT_R:
16520 c FFEINTRIN_specIFIX
16521 call fooI(IFIX(R1))
16522 c FFEINTRIN_specINT
16525 c FFEINTRIN_imp_REAL_D:
16527 c FFEINTRIN_specSNGL
16528 call fooR(SNGL(D1))
16530 c FFEINTRIN_imp_REAL_I:
16532 c FFEINTRIN_specFLOAT
16533 call fooR(FLOAT(I1))
16534 c FFEINTRIN_specREAL
16535 call fooR(REAL(I1))
16538 -------- (end input file to f2c)
16540 -------- (begin output from providing above input file as input to:
16541 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16542 -------- -e "s:^#.*$::g"')
16544 // -- translated by f2c (version 19950223).
16545 You must link the resulting object file with the libraries:
16546 -lf2c -lm (in that order)
16550 // f2c.h -- Standard Fortran to C header file //
16552 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
16554 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16559 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16560 // we assume short, float are OK //
16561 typedef long int // long int // integer;
16562 typedef char *address;
16563 typedef short int shortint;
16564 typedef float real;
16565 typedef double doublereal;
16566 typedef struct { real r, i; } complex;
16567 typedef struct { doublereal r, i; } doublecomplex;
16568 typedef long int // long int // logical;
16569 typedef short int shortlogical;
16570 typedef char logical1;
16571 typedef char integer1;
16572 // typedef long long longint; // // system-dependent //
16577 // Extern is for use with -E //
16591 typedef long int // int or long int // flag;
16592 typedef long int // int or long int // ftnlen;
16593 typedef long int // int or long int // ftnint;
16596 //external read, write//
16605 //internal read, write//
16635 //rewind, backspace, endfile//
16647 ftnint *inex; //parameters in standard's order//
16673 union Multitype { // for multiple entry points //
16684 typedef union Multitype Multitype;
16686 typedef long Long; // No longer used; formerly in Namelist //
16688 struct Vardesc { // for Namelist //
16694 typedef struct Vardesc Vardesc;
16701 typedef struct Namelist Namelist;
16710 // procedure parameter types for -A and -C++ //
16715 typedef int // Unknown procedure type // (*U_fp)();
16716 typedef shortint (*J_fp)();
16717 typedef integer (*I_fp)();
16718 typedef real (*R_fp)();
16719 typedef doublereal (*D_fp)(), (*E_fp)();
16720 typedef // Complex // void (*C_fp)();
16721 typedef // Double Complex // void (*Z_fp)();
16722 typedef logical (*L_fp)();
16723 typedef shortlogical (*K_fp)();
16724 typedef // Character // void (*H_fp)();
16725 typedef // Subroutine // int (*S_fp)();
16727 // E_fp is for real functions when -R is not specified //
16728 typedef void C_f; // complex function //
16729 typedef void H_f; // character function //
16730 typedef void Z_f; // double complex function //
16731 typedef doublereal E_f; // real function with -R not specified //
16733 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16736 // (No such symbols should be defined in a strict ANSI C compiler.
16737 We can avoid trouble with f2c-translated code by using
16738 gcc -ansi [-traditional].) //
16762 // Main program // MAIN__()
16764 // System generated locals //
16767 doublereal d__1, d__2;
16769 doublecomplex z__1, z__2, z__3;
16773 // Builtin functions //
16776 double pow_ri(), pow_di();
16780 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16781 asin(), atan(), atan2(), c_abs();
16782 void c_cos(), c_exp(), c_log(), r_cnjg();
16783 double cos(), cosh();
16784 void c_sin(), c_sqrt();
16785 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16786 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16787 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16788 logical l_ge(), l_gt(), l_le(), l_lt();
16792 // Local variables //
16793 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16794 fool_(), fooz_(), getem_();
16795 static char a1[10], a2[10];
16796 static complex c1, c2;
16797 static doublereal d1, d2;
16798 static integer i1, i2;
16799 static real r1, r2;
16802 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16810 d__1 = (doublereal) i1;
16811 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16821 c_div(&q__1, &c1, &c2);
16823 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16825 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16828 i__1 = pow_ii(&i1, &i2);
16830 r__1 = pow_ri(&r1, &i1);
16832 d__1 = pow_di(&d1, &i1);
16834 pow_ci(&q__1, &c1, &i1);
16836 d__1 = (doublereal) r1;
16837 d__2 = (doublereal) r2;
16838 r__1 = pow_dd(&d__1, &d__2);
16840 d__2 = (doublereal) r1;
16841 d__1 = pow_dd(&d__2, &d1);
16843 d__1 = pow_dd(&d1, &d2);
16845 d__2 = (doublereal) r1;
16846 d__1 = pow_dd(&d1, &d__2);
16848 z__2.r = c1.r, z__2.i = c1.i;
16849 z__3.r = c2.r, z__3.i = c2.i;
16850 pow_zz(&z__1, &z__2, &z__3);
16851 q__1.r = z__1.r, q__1.i = z__1.i;
16853 z__2.r = c1.r, z__2.i = c1.i;
16854 z__3.r = r1, z__3.i = 0.;
16855 pow_zz(&z__1, &z__2, &z__3);
16856 q__1.r = z__1.r, q__1.i = z__1.i;
16858 z__2.r = c1.r, z__2.i = c1.i;
16859 z__3.r = d1, z__3.i = 0.;
16860 pow_zz(&z__1, &z__2, &z__3);
16862 // FFEINTRIN_impABS //
16863 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16865 // FFEINTRIN_impACOS //
16868 // FFEINTRIN_impAIMAG //
16869 r__1 = r_imag(&c1);
16871 // FFEINTRIN_impAINT //
16874 // FFEINTRIN_impALOG //
16877 // FFEINTRIN_impALOG10 //
16878 r__1 = r_lg10(&r1);
16880 // FFEINTRIN_impAMAX0 //
16881 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16883 // FFEINTRIN_impAMAX1 //
16884 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16886 // FFEINTRIN_impAMIN0 //
16887 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16889 // FFEINTRIN_impAMIN1 //
16890 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16892 // FFEINTRIN_impAMOD //
16893 r__1 = r_mod(&r1, &r2);
16895 // FFEINTRIN_impANINT //
16896 r__1 = r_nint(&r1);
16898 // FFEINTRIN_impASIN //
16901 // FFEINTRIN_impATAN //
16904 // FFEINTRIN_impATAN2 //
16905 r__1 = atan2(r1, r2);
16907 // FFEINTRIN_impCABS //
16910 // FFEINTRIN_impCCOS //
16913 // FFEINTRIN_impCEXP //
16916 // FFEINTRIN_impCHAR //
16917 *(unsigned char *)&ch__1[0] = i1;
16919 // FFEINTRIN_impCLOG //
16922 // FFEINTRIN_impCONJG //
16923 r_cnjg(&q__1, &c1);
16925 // FFEINTRIN_impCOS //
16928 // FFEINTRIN_impCOSH //
16931 // FFEINTRIN_impCSIN //
16934 // FFEINTRIN_impCSQRT //
16935 c_sqrt(&q__1, &c1);
16937 // FFEINTRIN_impDABS //
16938 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16940 // FFEINTRIN_impDACOS //
16943 // FFEINTRIN_impDASIN //
16946 // FFEINTRIN_impDATAN //
16949 // FFEINTRIN_impDATAN2 //
16950 d__1 = atan2(d1, d2);
16952 // FFEINTRIN_impDCOS //
16955 // FFEINTRIN_impDCOSH //
16958 // FFEINTRIN_impDDIM //
16959 d__1 = d_dim(&d1, &d2);
16961 // FFEINTRIN_impDEXP //
16964 // FFEINTRIN_impDIM //
16965 r__1 = r_dim(&r1, &r2);
16967 // FFEINTRIN_impDINT //
16970 // FFEINTRIN_impDLOG //
16973 // FFEINTRIN_impDLOG10 //
16974 d__1 = d_lg10(&d1);
16976 // FFEINTRIN_impDMAX1 //
16977 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16979 // FFEINTRIN_impDMIN1 //
16980 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16982 // FFEINTRIN_impDMOD //
16983 d__1 = d_mod(&d1, &d2);
16985 // FFEINTRIN_impDNINT //
16986 d__1 = d_nint(&d1);
16988 // FFEINTRIN_impDPROD //
16989 d__1 = (doublereal) r1 * r2;
16991 // FFEINTRIN_impDSIGN //
16992 d__1 = d_sign(&d1, &d2);
16994 // FFEINTRIN_impDSIN //
16997 // FFEINTRIN_impDSINH //
17000 // FFEINTRIN_impDSQRT //
17003 // FFEINTRIN_impDTAN //
17006 // FFEINTRIN_impDTANH //
17009 // FFEINTRIN_impEXP //
17012 // FFEINTRIN_impIABS //
17013 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
17015 // FFEINTRIN_impICHAR //
17016 i__1 = *(unsigned char *)a1;
17018 // FFEINTRIN_impIDIM //
17019 i__1 = i_dim(&i1, &i2);
17021 // FFEINTRIN_impIDNINT //
17022 i__1 = i_dnnt(&d1);
17024 // FFEINTRIN_impINDEX //
17025 i__1 = i_indx(a1, a2, 10L, 10L);
17027 // FFEINTRIN_impISIGN //
17028 i__1 = i_sign(&i1, &i2);
17030 // FFEINTRIN_impLEN //
17031 i__1 = i_len(a1, 10L);
17033 // FFEINTRIN_impLGE //
17034 L__1 = l_ge(a1, a2, 10L, 10L);
17036 // FFEINTRIN_impLGT //
17037 L__1 = l_gt(a1, a2, 10L, 10L);
17039 // FFEINTRIN_impLLE //
17040 L__1 = l_le(a1, a2, 10L, 10L);
17042 // FFEINTRIN_impLLT //
17043 L__1 = l_lt(a1, a2, 10L, 10L);
17045 // FFEINTRIN_impMAX0 //
17046 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17048 // FFEINTRIN_impMAX1 //
17049 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
17051 // FFEINTRIN_impMIN0 //
17052 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17054 // FFEINTRIN_impMIN1 //
17055 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
17057 // FFEINTRIN_impMOD //
17060 // FFEINTRIN_impNINT //
17061 i__1 = i_nint(&r1);
17063 // FFEINTRIN_impSIGN //
17064 r__1 = r_sign(&r1, &r2);
17066 // FFEINTRIN_impSIN //
17069 // FFEINTRIN_impSINH //
17072 // FFEINTRIN_impSQRT //
17075 // FFEINTRIN_impTAN //
17078 // FFEINTRIN_impTANH //
17081 // FFEINTRIN_imp_CMPLX_C //
17084 q__1.r = r__1, q__1.i = r__2;
17086 // FFEINTRIN_imp_CMPLX_D //
17087 z__1.r = d1, z__1.i = d2;
17089 // FFEINTRIN_imp_CMPLX_I //
17092 q__1.r = r__1, q__1.i = r__2;
17094 // FFEINTRIN_imp_CMPLX_R //
17095 q__1.r = r1, q__1.i = r2;
17097 // FFEINTRIN_imp_DBLE_C //
17098 d__1 = (doublereal) c1.r;
17100 // FFEINTRIN_imp_DBLE_D //
17103 // FFEINTRIN_imp_DBLE_I //
17104 d__1 = (doublereal) i1;
17106 // FFEINTRIN_imp_DBLE_R //
17107 d__1 = (doublereal) r1;
17109 // FFEINTRIN_imp_INT_C //
17110 i__1 = (integer) c1.r;
17112 // FFEINTRIN_imp_INT_D //
17113 i__1 = (integer) d1;
17115 // FFEINTRIN_imp_INT_I //
17118 // FFEINTRIN_imp_INT_R //
17119 i__1 = (integer) r1;
17121 // FFEINTRIN_imp_REAL_C //
17124 // FFEINTRIN_imp_REAL_D //
17127 // FFEINTRIN_imp_REAL_I //
17130 // FFEINTRIN_imp_REAL_R //
17134 // FFEINTRIN_imp_INT_D: //
17136 // FFEINTRIN_specIDINT //
17137 i__1 = (integer) d1;
17140 // FFEINTRIN_imp_INT_R: //
17142 // FFEINTRIN_specIFIX //
17143 i__1 = (integer) r1;
17145 // FFEINTRIN_specINT //
17146 i__1 = (integer) r1;
17149 // FFEINTRIN_imp_REAL_D: //
17151 // FFEINTRIN_specSNGL //
17155 // FFEINTRIN_imp_REAL_I: //
17157 // FFEINTRIN_specFLOAT //
17160 // FFEINTRIN_specREAL //
17166 -------- (end output file from f2c)