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)));
1085 result = build1 (INDIRECT_REF, TREE_TYPE (ref),
1086 save_expr (build1 (ADDR_EXPR,
1087 build_pointer_type (TREE_TYPE (ref)),
1093 return save_expr (ref);
1096 return error_mark_node;
1099 TREE_TYPE (result) = TREE_TYPE (ref);
1100 TREE_READONLY (result) = TREE_READONLY (ref);
1101 TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1102 TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1108 /* A rip-off of gcc's convert.c convert_to_complex function,
1109 reworked to handle complex implemented as C structures
1110 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1112 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1114 ffecom_convert_to_complex_ (tree type, tree expr)
1116 register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1119 assert (TREE_CODE (type) == RECORD_TYPE);
1121 subtype = TREE_TYPE (TYPE_FIELDS (type));
1123 if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1125 expr = convert (subtype, expr);
1126 return ffecom_2 (COMPLEX_EXPR, type, expr,
1127 convert (subtype, integer_zero_node));
1130 if (form == RECORD_TYPE)
1132 tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1133 if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1137 expr = save_expr (expr);
1138 return ffecom_2 (COMPLEX_EXPR,
1141 ffecom_1 (REALPART_EXPR,
1142 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1145 ffecom_1 (IMAGPART_EXPR,
1146 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1151 if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1152 error ("pointer value used where a complex was expected");
1154 error ("aggregate value used where a complex was expected");
1156 return ffecom_2 (COMPLEX_EXPR, type,
1157 convert (subtype, integer_zero_node),
1158 convert (subtype, integer_zero_node));
1162 /* Like gcc's convert(), but crashes if widening might happen. */
1164 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1166 ffecom_convert_narrow_ (type, expr)
1169 register tree e = expr;
1170 register enum tree_code code = TREE_CODE (type);
1172 if (type == TREE_TYPE (e)
1173 || TREE_CODE (e) == ERROR_MARK)
1175 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1176 return fold (build1 (NOP_EXPR, type, e));
1177 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1178 || code == ERROR_MARK)
1179 return error_mark_node;
1180 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1182 assert ("void value not ignored as it ought to be" == NULL);
1183 return error_mark_node;
1185 assert (code != VOID_TYPE);
1186 if ((code != RECORD_TYPE)
1187 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1188 assert ("converting COMPLEX to REAL" == NULL);
1189 assert (code != ENUMERAL_TYPE);
1190 if (code == INTEGER_TYPE)
1192 assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1193 && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1194 || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1195 && (TYPE_PRECISION (type)
1196 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1197 return fold (convert_to_integer (type, e));
1199 if (code == POINTER_TYPE)
1201 assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1202 return fold (convert_to_pointer (type, e));
1204 if (code == REAL_TYPE)
1206 assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1207 assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1208 return fold (convert_to_real (type, e));
1210 if (code == COMPLEX_TYPE)
1212 assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1213 assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1214 return fold (convert_to_complex (type, e));
1216 if (code == RECORD_TYPE)
1218 assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1219 /* Check that at least the first field name agrees. */
1220 assert (DECL_NAME (TYPE_FIELDS (type))
1221 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1222 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1223 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1224 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1225 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1227 return fold (ffecom_convert_to_complex_ (type, e));
1230 assert ("conversion to non-scalar type requested" == NULL);
1231 return error_mark_node;
1235 /* Like gcc's convert(), but crashes if narrowing might happen. */
1237 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1239 ffecom_convert_widen_ (type, expr)
1242 register tree e = expr;
1243 register enum tree_code code = TREE_CODE (type);
1245 if (type == TREE_TYPE (e)
1246 || TREE_CODE (e) == ERROR_MARK)
1248 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1249 return fold (build1 (NOP_EXPR, type, e));
1250 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1251 || code == ERROR_MARK)
1252 return error_mark_node;
1253 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1255 assert ("void value not ignored as it ought to be" == NULL);
1256 return error_mark_node;
1258 assert (code != VOID_TYPE);
1259 if ((code != RECORD_TYPE)
1260 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1261 assert ("narrowing COMPLEX to REAL" == NULL);
1262 assert (code != ENUMERAL_TYPE);
1263 if (code == INTEGER_TYPE)
1265 assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1266 && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1267 || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1268 && (TYPE_PRECISION (type)
1269 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1270 return fold (convert_to_integer (type, e));
1272 if (code == POINTER_TYPE)
1274 assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1275 return fold (convert_to_pointer (type, e));
1277 if (code == REAL_TYPE)
1279 assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1280 assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1281 return fold (convert_to_real (type, e));
1283 if (code == COMPLEX_TYPE)
1285 assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1286 assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1287 return fold (convert_to_complex (type, e));
1289 if (code == RECORD_TYPE)
1291 assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1292 /* Check that at least the first field name agrees. */
1293 assert (DECL_NAME (TYPE_FIELDS (type))
1294 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1295 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1296 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1297 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1298 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1300 return fold (ffecom_convert_to_complex_ (type, e));
1303 assert ("conversion to non-scalar type requested" == NULL);
1304 return error_mark_node;
1308 /* Handles making a COMPLEX type, either the standard
1309 (but buggy?) gbe way, or the safer (but less elegant?)
1312 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1314 ffecom_make_complex_type_ (tree subtype)
1320 if (ffe_is_emulate_complex ())
1322 type = make_node (RECORD_TYPE);
1323 realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1324 imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1325 TYPE_FIELDS (type) = realfield;
1330 type = make_node (COMPLEX_TYPE);
1331 TREE_TYPE (type) = subtype;
1339 /* Chooses either the gbe or the f2c way to build a
1340 complex constant. */
1342 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1344 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1348 if (ffe_is_emulate_complex ())
1350 bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1351 TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1352 bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1356 bothparts = build_complex (type, realpart, imagpart);
1363 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1365 ffecom_arglist_expr_ (const char *c, ffebld expr)
1368 tree *plist = &list;
1369 tree trail = NULL_TREE; /* Append char length args here. */
1370 tree *ptrail = &trail;
1375 tree wanted = NULL_TREE;
1376 static char zed[] = "0";
1381 while (expr != NULL)
1404 wanted = ffecom_f2c_complex_type_node;
1408 wanted = ffecom_f2c_doublereal_type_node;
1412 wanted = ffecom_f2c_doublecomplex_type_node;
1416 wanted = ffecom_f2c_real_type_node;
1420 wanted = ffecom_f2c_integer_type_node;
1424 wanted = ffecom_f2c_longint_type_node;
1428 assert ("bad argstring code" == NULL);
1434 exprh = ffebld_head (expr);
1438 if ((wanted == NULL_TREE)
1441 (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1442 [ffeinfo_kindtype (ffebld_info (exprh))])
1443 == TYPE_MODE (wanted))))
1445 = build_tree_list (NULL_TREE,
1446 ffecom_arg_ptr_to_expr (exprh,
1450 item = ffecom_arg_expr (exprh, &length);
1451 item = ffecom_convert_widen_ (wanted, item);
1454 item = ffecom_1 (ADDR_EXPR,
1455 build_pointer_type (TREE_TYPE (item)),
1459 = build_tree_list (NULL_TREE,
1463 plist = &TREE_CHAIN (*plist);
1464 expr = ffebld_trail (expr);
1465 if (length != NULL_TREE)
1467 *ptrail = build_tree_list (NULL_TREE, length);
1468 ptrail = &TREE_CHAIN (*ptrail);
1472 /* We've run out of args in the call; if the implementation expects
1473 more, supply null pointers for them, which the implementation can
1474 check to see if an arg was omitted. */
1476 while (*c != '\0' && *c != '0')
1481 assert ("missing arg to run-time routine!" == NULL);
1496 assert ("bad arg string code" == NULL);
1500 = build_tree_list (NULL_TREE,
1502 plist = &TREE_CHAIN (*plist);
1511 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1513 ffecom_widest_expr_type_ (ffebld list)
1516 ffebld widest = NULL;
1518 ffetype widest_type = NULL;
1521 for (; list != NULL; list = ffebld_trail (list))
1523 item = ffebld_head (list);
1526 if ((widest != NULL)
1527 && (ffeinfo_basictype (ffebld_info (item))
1528 != ffeinfo_basictype (ffebld_info (widest))))
1530 type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1531 ffeinfo_kindtype (ffebld_info (item)));
1532 if ((widest == FFEINFO_kindtypeNONE)
1533 || (ffetype_size (type)
1534 > ffetype_size (widest_type)))
1541 assert (widest != NULL);
1542 t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1543 [ffeinfo_kindtype (ffebld_info (widest))];
1544 assert (t != NULL_TREE);
1549 /* Check whether a partial overlap between two expressions is possible.
1551 Can *starting* to write a portion of expr1 change the value
1552 computed (perhaps already, *partially*) by expr2?
1554 Currently, this is a concern only for a COMPLEX expr1. But if it
1555 isn't in COMMON or local EQUIVALENCE, since we don't support
1556 aliasing of arguments, it isn't a concern. */
1559 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1564 switch (ffebld_op (expr1))
1566 case FFEBLD_opSYMTER:
1567 sym = ffebld_symter (expr1);
1570 case FFEBLD_opARRAYREF:
1571 if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1573 sym = ffebld_symter (ffebld_left (expr1));
1580 if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1581 && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1582 || ! (st = ffesymbol_storage (sym))
1583 || ! ffestorag_parent (st)))
1586 /* It's in COMMON or local EQUIVALENCE. */
1591 /* Check whether dest and source might overlap. ffebld versions of these
1592 might or might not be passed, will be NULL if not.
1594 The test is really whether source_tree is modifiable and, if modified,
1595 might overlap destination such that the value(s) in the destination might
1596 change before it is finally modified. dest_* are the canonized
1597 destination itself. */
1599 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1601 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1602 tree source_tree, ffebld source UNUSED,
1610 if (source_tree == NULL_TREE)
1613 switch (TREE_CODE (source_tree))
1616 case IDENTIFIER_NODE:
1627 case TRUNC_DIV_EXPR:
1629 case FLOOR_DIV_EXPR:
1630 case ROUND_DIV_EXPR:
1631 case TRUNC_MOD_EXPR:
1633 case FLOOR_MOD_EXPR:
1634 case ROUND_MOD_EXPR:
1636 case EXACT_DIV_EXPR:
1637 case FIX_TRUNC_EXPR:
1639 case FIX_FLOOR_EXPR:
1640 case FIX_ROUND_EXPR:
1655 case BIT_ANDTC_EXPR:
1657 case TRUTH_ANDIF_EXPR:
1658 case TRUTH_ORIF_EXPR:
1659 case TRUTH_AND_EXPR:
1661 case TRUTH_XOR_EXPR:
1662 case TRUTH_NOT_EXPR:
1678 return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1679 TREE_OPERAND (source_tree, 1), NULL,
1683 return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1684 TREE_OPERAND (source_tree, 0), NULL,
1689 case NON_LVALUE_EXPR:
1691 if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1694 ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1696 source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1701 ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1702 TREE_OPERAND (source_tree, 1), NULL,
1704 || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1705 TREE_OPERAND (source_tree, 2), NULL,
1710 ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1712 TREE_OPERAND (source_tree, 0));
1716 if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1719 source_decl = source_tree;
1720 source_offset = bitsize_zero_node;
1721 source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1725 case REFERENCE_EXPR:
1726 case PREDECREMENT_EXPR:
1727 case PREINCREMENT_EXPR:
1728 case POSTDECREMENT_EXPR:
1729 case POSTINCREMENT_EXPR:
1737 /* Come here when source_decl, source_offset, and source_size filled
1738 in appropriately. */
1740 if (source_decl == NULL_TREE)
1741 return FALSE; /* No decl involved, so no overlap. */
1743 if (source_decl != dest_decl)
1744 return FALSE; /* Different decl, no overlap. */
1746 if (TREE_CODE (dest_size) == ERROR_MARK)
1747 return TRUE; /* Assignment into entire assumed-size
1748 array? Shouldn't happen.... */
1750 t = ffecom_2 (LE_EXPR, integer_type_node,
1751 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1753 convert (TREE_TYPE (dest_offset),
1755 convert (TREE_TYPE (dest_offset),
1758 if (integer_onep (t))
1759 return FALSE; /* Destination precedes source. */
1762 || (source_size == NULL_TREE)
1763 || (TREE_CODE (source_size) == ERROR_MARK)
1764 || integer_zerop (source_size))
1765 return TRUE; /* No way to tell if dest follows source. */
1767 t = ffecom_2 (LE_EXPR, integer_type_node,
1768 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1770 convert (TREE_TYPE (source_offset),
1772 convert (TREE_TYPE (source_offset),
1775 if (integer_onep (t))
1776 return FALSE; /* Destination follows source. */
1778 return TRUE; /* Destination and source overlap. */
1782 /* Check whether dest might overlap any of a list of arguments or is
1783 in a COMMON area the callee might know about (and thus modify). */
1785 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1787 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1788 tree args, tree callee_commons,
1796 ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1799 if (dest_decl == NULL_TREE)
1800 return FALSE; /* Seems unlikely! */
1802 /* If the decl cannot be determined reliably, or if its in COMMON
1803 and the callee isn't known to not futz with COMMON via other
1804 means, overlap might happen. */
1806 if ((TREE_CODE (dest_decl) == ERROR_MARK)
1807 || ((callee_commons != NULL_TREE)
1808 && TREE_PUBLIC (dest_decl)))
1811 for (; args != NULL_TREE; args = TREE_CHAIN (args))
1813 if (((arg = TREE_VALUE (args)) != NULL_TREE)
1814 && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1815 arg, NULL, scalar_args))
1823 /* Build a string for a variable name as used by NAMELIST. This means that
1824 if we're using the f2c library, we build an uppercase string, since
1827 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1829 ffecom_build_f2c_string_ (int i, const char *s)
1831 if (!ffe_is_f2c_library ())
1832 return build_string (i, s);
1841 if (((size_t) i) > ARRAY_SIZE (space))
1842 tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1846 for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1847 *q = ffesrc_toupper (*p);
1850 t = build_string (i, tmp);
1852 if (((size_t) i) > ARRAY_SIZE (space))
1853 malloc_kill_ks (malloc_pool_image (), tmp, i);
1860 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1861 type to just get whatever the function returns), handling the
1862 f2c value-returning convention, if required, by prepending
1863 to the arglist a pointer to a temporary to receive the return value. */
1865 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1867 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1868 tree type, tree args, tree dest_tree,
1869 ffebld dest, bool *dest_used, tree callee_commons,
1870 bool scalar_args, tree hook)
1875 if (dest_used != NULL)
1880 if ((dest_used == NULL)
1882 || (ffeinfo_basictype (ffebld_info (dest))
1883 != FFEINFO_basictypeCOMPLEX)
1884 || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1885 || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1886 || ffecom_args_overlapping_ (dest_tree, dest, args,
1891 tempvar = ffecom_make_tempvar (ffecom_tree_type
1892 [FFEINFO_basictypeCOMPLEX][kt],
1893 FFETARGET_charactersizeNONE,
1903 tempvar = dest_tree;
1908 = build_tree_list (NULL_TREE,
1909 ffecom_1 (ADDR_EXPR,
1910 build_pointer_type (TREE_TYPE (tempvar)),
1912 TREE_CHAIN (item) = args;
1914 item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1917 if (tempvar != dest_tree)
1918 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1921 item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1924 if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1925 item = ffecom_convert_narrow_ (type, item);
1931 /* Given two arguments, transform them and make a call to the given
1932 function via ffecom_call_. */
1934 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1936 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1937 tree type, ffebld left, ffebld right,
1938 tree dest_tree, ffebld dest, bool *dest_used,
1939 tree callee_commons, bool scalar_args, bool ref, tree hook)
1948 /* Pass arguments by reference. */
1949 left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1950 right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1954 /* Pass arguments by value. */
1955 left_tree = ffecom_arg_expr (left, &left_length);
1956 right_tree = ffecom_arg_expr (right, &right_length);
1960 left_tree = build_tree_list (NULL_TREE, left_tree);
1961 right_tree = build_tree_list (NULL_TREE, right_tree);
1962 TREE_CHAIN (left_tree) = right_tree;
1964 if (left_length != NULL_TREE)
1966 left_length = build_tree_list (NULL_TREE, left_length);
1967 TREE_CHAIN (right_tree) = left_length;
1970 if (right_length != NULL_TREE)
1972 right_length = build_tree_list (NULL_TREE, right_length);
1973 if (left_length != NULL_TREE)
1974 TREE_CHAIN (left_length) = right_length;
1976 TREE_CHAIN (right_tree) = right_length;
1979 return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1980 dest_tree, dest, dest_used, callee_commons,
1985 /* Return ptr/length args for char subexpression
1987 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1988 subexpressions by constructing the appropriate trees for the ptr-to-
1989 character-text and length-of-character-text arguments in a calling
1992 Note that if with_null is TRUE, and the expression is an opCONTER,
1993 a null byte is appended to the string. */
1995 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1997 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
2001 ffetargetCharacter1 val;
2002 ffetargetCharacterSize newlen;
2004 switch (ffebld_op (expr))
2006 case FFEBLD_opCONTER:
2007 val = ffebld_constant_character1 (ffebld_conter (expr));
2008 newlen = ffetarget_length_character1 (val);
2011 /* Begin FFETARGET-NULL-KLUDGE. */
2015 *length = build_int_2 (newlen, 0);
2016 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2017 high = build_int_2 (newlen, 0);
2018 TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
2019 item = build_string (newlen,
2020 ffetarget_text_character1 (val));
2021 /* End FFETARGET-NULL-KLUDGE. */
2023 = build_type_variant
2027 (ffecom_f2c_ftnlen_type_node,
2028 ffecom_f2c_ftnlen_one_node,
2031 TREE_CONSTANT (item) = 1;
2032 TREE_STATIC (item) = 1;
2033 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
2037 case FFEBLD_opSYMTER:
2039 ffesymbol s = ffebld_symter (expr);
2041 item = ffesymbol_hook (s).decl_tree;
2042 if (item == NULL_TREE)
2044 s = ffecom_sym_transform_ (s);
2045 item = ffesymbol_hook (s).decl_tree;
2047 if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
2049 if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
2050 *length = ffesymbol_hook (s).length_tree;
2053 *length = build_int_2 (ffesymbol_size (s), 0);
2054 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2057 else if (item == error_mark_node)
2058 *length = error_mark_node;
2060 /* FFEINFO_kindFUNCTION. */
2061 *length = NULL_TREE;
2062 if (!ffesymbol_hook (s).addr
2063 && (item != error_mark_node))
2064 item = ffecom_1 (ADDR_EXPR,
2065 build_pointer_type (TREE_TYPE (item)),
2070 case FFEBLD_opARRAYREF:
2072 ffecom_char_args_ (&item, length, ffebld_left (expr));
2074 if (item == error_mark_node || *length == error_mark_node)
2076 item = *length = error_mark_node;
2080 item = ffecom_arrayref_ (item, expr, 1);
2084 case FFEBLD_opSUBSTR:
2088 ffebld thing = ffebld_right (expr);
2091 const char *char_name;
2095 assert (ffebld_op (thing) == FFEBLD_opITEM);
2096 start = ffebld_head (thing);
2097 thing = ffebld_trail (thing);
2098 assert (ffebld_trail (thing) == NULL);
2099 end = ffebld_head (thing);
2101 /* Determine name for pretty-printing range-check errors. */
2102 for (left_symter = ffebld_left (expr);
2103 left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2104 left_symter = ffebld_left (left_symter))
2106 if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2107 char_name = ffesymbol_text (ffebld_symter (left_symter));
2109 char_name = "[expr?]";
2111 ffecom_char_args_ (&item, length, ffebld_left (expr));
2113 if (item == error_mark_node || *length == error_mark_node)
2115 item = *length = error_mark_node;
2119 array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2121 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2129 end_tree = ffecom_expr (end);
2130 if (flag_bounds_check)
2131 end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2133 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2136 if (end_tree == error_mark_node)
2138 item = *length = error_mark_node;
2147 start_tree = ffecom_expr (start);
2148 if (flag_bounds_check)
2149 start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2151 start_tree = convert (ffecom_f2c_ftnlen_type_node,
2154 if (start_tree == error_mark_node)
2156 item = *length = error_mark_node;
2160 start_tree = ffecom_save_tree (start_tree);
2162 item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2164 ffecom_2 (MINUS_EXPR,
2165 TREE_TYPE (start_tree),
2167 ffecom_f2c_ftnlen_one_node));
2171 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2172 ffecom_f2c_ftnlen_one_node,
2173 ffecom_2 (MINUS_EXPR,
2174 ffecom_f2c_ftnlen_type_node,
2180 end_tree = ffecom_expr (end);
2181 if (flag_bounds_check)
2182 end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2184 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2187 if (end_tree == error_mark_node)
2189 item = *length = error_mark_node;
2193 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2194 ffecom_f2c_ftnlen_one_node,
2195 ffecom_2 (MINUS_EXPR,
2196 ffecom_f2c_ftnlen_type_node,
2197 end_tree, start_tree));
2203 case FFEBLD_opFUNCREF:
2205 ffesymbol s = ffebld_symter (ffebld_left (expr));
2208 ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2211 if (size == FFETARGET_charactersizeNONE)
2212 /* ~~Kludge alert! This should someday be fixed. */
2215 *length = build_int_2 (size, 0);
2216 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2218 if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2219 == FFEINFO_whereINTRINSIC)
2223 /* Invocation of an intrinsic returning CHARACTER*1. */
2224 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2228 ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2229 assert (ix != FFECOM_gfrt);
2230 item = ffecom_gfrt_tree_ (ix);
2235 item = ffesymbol_hook (s).decl_tree;
2236 if (item == NULL_TREE)
2238 s = ffecom_sym_transform_ (s);
2239 item = ffesymbol_hook (s).decl_tree;
2241 if (item == error_mark_node)
2243 item = *length = error_mark_node;
2247 if (!ffesymbol_hook (s).addr)
2248 item = ffecom_1_fn (item);
2252 tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2254 tempvar = ffebld_nonter_hook (expr);
2257 tempvar = ffecom_1 (ADDR_EXPR,
2258 build_pointer_type (TREE_TYPE (tempvar)),
2261 args = build_tree_list (NULL_TREE, tempvar);
2263 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) /* Sfunc args by value. */
2264 TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2267 TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2268 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2270 TREE_CHAIN (TREE_CHAIN (args))
2271 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2272 ffebld_right (expr));
2276 TREE_CHAIN (TREE_CHAIN (args))
2277 = ffecom_list_ptr_to_expr (ffebld_right (expr));
2281 item = ffecom_3s (CALL_EXPR,
2282 TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2283 item, args, NULL_TREE);
2284 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2289 case FFEBLD_opCONVERT:
2291 ffecom_char_args_ (&item, length, ffebld_left (expr));
2293 if (item == error_mark_node || *length == error_mark_node)
2295 item = *length = error_mark_node;
2299 if ((ffebld_size_known (ffebld_left (expr))
2300 == FFETARGET_charactersizeNONE)
2301 || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2302 { /* Possible blank-padding needed, copy into
2309 tempvar = ffecom_make_tempvar (char_type_node,
2310 ffebld_size (expr), -1);
2312 tempvar = ffebld_nonter_hook (expr);
2315 tempvar = ffecom_1 (ADDR_EXPR,
2316 build_pointer_type (TREE_TYPE (tempvar)),
2319 newlen = build_int_2 (ffebld_size (expr), 0);
2320 TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2322 args = build_tree_list (NULL_TREE, tempvar);
2323 TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2324 TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2325 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2326 = build_tree_list (NULL_TREE, *length);
2328 item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2329 TREE_SIDE_EFFECTS (item) = 1;
2330 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2335 { /* Just truncate the length. */
2336 *length = build_int_2 (ffebld_size (expr), 0);
2337 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2342 assert ("bad op for single char arg expr" == NULL);
2351 /* Check the size of the type to be sure it doesn't overflow the
2352 "portable" capacities of the compiler back end. `dummy' types
2353 can generally overflow the normal sizes as long as the computations
2354 themselves don't overflow. A particular target of the back end
2355 must still enforce its size requirements, though, and the back
2356 end takes care of this in stor-layout.c. */
2358 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2360 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2362 if (TREE_CODE (type) == ERROR_MARK)
2365 if (TYPE_SIZE (type) == NULL_TREE)
2368 if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2371 if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2372 || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2373 || TREE_OVERFLOW (TYPE_SIZE (type)))))
2375 ffebad_start (FFEBAD_ARRAY_LARGE);
2376 ffebad_string (ffesymbol_text (s));
2377 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2380 return error_mark_node;
2387 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2388 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2389 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2391 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2393 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2395 ffetargetCharacterSize sz = ffesymbol_size (s);
2400 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2401 tlen = NULL_TREE; /* A statement function, no length passed. */
2404 if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2405 tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2406 ffesymbol_text (s));
2408 tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2409 tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2411 DECL_ARTIFICIAL (tlen) = 1;
2415 if (sz == FFETARGET_charactersizeNONE)
2417 assert (tlen != NULL_TREE);
2418 highval = variable_size (tlen);
2422 highval = build_int_2 (sz, 0);
2423 TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2426 type = build_array_type (type,
2427 build_range_type (ffecom_f2c_ftnlen_type_node,
2428 ffecom_f2c_ftnlen_one_node,
2436 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2438 ffecomConcatList_ catlist;
2439 ffebld expr; // expr of CHARACTER basictype.
2440 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2441 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2443 Scans expr for character subexpressions, updates and returns catlist
2446 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2447 static ffecomConcatList_
2448 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2449 ffetargetCharacterSize max)
2451 ffetargetCharacterSize sz;
2453 recurse: /* :::::::::::::::::::: */
2458 if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2459 return catlist; /* Don't append any more items. */
2461 switch (ffebld_op (expr))
2463 case FFEBLD_opCONTER:
2464 case FFEBLD_opSYMTER:
2465 case FFEBLD_opARRAYREF:
2466 case FFEBLD_opFUNCREF:
2467 case FFEBLD_opSUBSTR:
2468 case FFEBLD_opCONVERT: /* Callers should strip this off beforehand
2469 if they don't need to preserve it. */
2470 if (catlist.count == catlist.max)
2471 { /* Make a (larger) list. */
2475 newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2476 newx = malloc_new_ks (malloc_pool_image (), "catlist",
2477 newmax * sizeof (newx[0]));
2478 if (catlist.max != 0)
2480 memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2481 malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2482 catlist.max * sizeof (newx[0]));
2484 catlist.max = newmax;
2485 catlist.exprs = newx;
2487 if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2488 catlist.minlen += sz;
2490 ++catlist.minlen; /* Not true for F90; can be 0 length. */
2491 if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2492 catlist.maxlen = sz;
2494 catlist.maxlen += sz;
2495 if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2496 { /* This item overlaps (or is beyond) the end
2497 of the destination. */
2498 switch (ffebld_op (expr))
2500 case FFEBLD_opCONTER:
2501 case FFEBLD_opSYMTER:
2502 case FFEBLD_opARRAYREF:
2503 case FFEBLD_opFUNCREF:
2504 case FFEBLD_opSUBSTR:
2505 /* ~~Do useful truncations here. */
2509 assert ("op changed or inconsistent switches!" == NULL);
2513 catlist.exprs[catlist.count++] = expr;
2516 case FFEBLD_opPAREN:
2517 expr = ffebld_left (expr);
2518 goto recurse; /* :::::::::::::::::::: */
2520 case FFEBLD_opCONCATENATE:
2521 catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2522 expr = ffebld_right (expr);
2523 goto recurse; /* :::::::::::::::::::: */
2525 #if 0 /* Breaks passing small actual arg to larger
2526 dummy arg of sfunc */
2527 case FFEBLD_opCONVERT:
2528 expr = ffebld_left (expr);
2530 ffetargetCharacterSize cmax;
2532 cmax = catlist.len + ffebld_size_known (expr);
2534 if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2537 goto recurse; /* :::::::::::::::::::: */
2544 assert ("bad op in _gather_" == NULL);
2550 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2552 ffecomConcatList_ catlist;
2553 ffecom_concat_list_kill_(catlist);
2555 Anything allocated within the list info is deallocated. */
2557 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2559 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2561 if (catlist.max != 0)
2562 malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2563 catlist.max * sizeof (catlist.exprs[0]));
2567 /* Make list of concatenated string exprs.
2569 Returns a flattened list of concatenated subexpressions given a
2570 tree of such expressions. */
2572 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2573 static ffecomConcatList_
2574 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2576 ffecomConcatList_ catlist;
2578 catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2579 return ffecom_concat_list_gather_ (catlist, expr, max);
2584 /* Provide some kind of useful info on member of aggregate area,
2585 since current g77/gcc technology does not provide debug info
2586 on these members. */
2588 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2590 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2591 tree member_type UNUSED, ffetargetOffset offset)
2601 for (type_id = member_type;
2602 TREE_CODE (type_id) != IDENTIFIER_NODE;
2605 switch (TREE_CODE (type_id))
2609 type_id = TYPE_NAME (type_id);
2614 type_id = TREE_TYPE (type_id);
2618 assert ("no IDENTIFIER_NODE for type!" == NULL);
2619 type_id = error_mark_node;
2625 if (ffecom_transform_only_dummies_
2626 || !ffe_is_debug_kludge ())
2627 return; /* Can't do this yet, maybe later. */
2630 + strlen (aggr_type)
2631 + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2633 + IDENTIFIER_LENGTH (type_id);
2636 if (((size_t) len) >= ARRAY_SIZE (space))
2637 buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2641 sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2643 IDENTIFIER_POINTER (DECL_NAME (aggr)),
2646 value = build_string (len, buff);
2648 = build_type_variant (build_array_type (char_type_node,
2652 build_int_2 (strlen (buff), 0))),
2654 decl = build_decl (VAR_DECL,
2655 ffecom_get_identifier_ (ffesymbol_text (member)),
2657 TREE_CONSTANT (decl) = 1;
2658 TREE_STATIC (decl) = 1;
2659 DECL_INITIAL (decl) = error_mark_node;
2660 DECL_IN_SYSTEM_HEADER (decl) = 1; /* Don't let -Wunused complain. */
2661 decl = start_decl (decl, FALSE);
2662 finish_decl (decl, value, FALSE);
2664 if (buff != &space[0])
2665 malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2669 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2671 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2672 int i; // entry# for this entrypoint (used by master fn)
2673 ffecom_do_entrypoint_(s,i);
2675 Makes a public entry point that calls our private master fn (already
2678 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2680 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2683 tree type; /* Type of function. */
2684 tree multi_retval; /* Var holding return value (union). */
2685 tree result; /* Var holding result. */
2686 ffeinfoBasictype bt;
2690 bool charfunc; /* All entry points return same type
2692 bool cmplxfunc; /* Use f2c way of returning COMPLEX. */
2693 bool multi; /* Master fn has multiple return types. */
2694 bool altreturning = FALSE; /* This entry point has alternate returns. */
2695 int old_lineno = lineno;
2696 const char *old_input_filename = input_filename;
2698 input_filename = ffesymbol_where_filename (fn);
2699 lineno = ffesymbol_where_filelinenum (fn);
2701 ffecom_doing_entry_ = TRUE; /* Don't bother with array dimensions. */
2703 switch (ffecom_primary_entry_kind_)
2705 case FFEINFO_kindFUNCTION:
2707 /* Determine actual return type for function. */
2709 gt = FFEGLOBAL_typeFUNC;
2710 bt = ffesymbol_basictype (fn);
2711 kt = ffesymbol_kindtype (fn);
2712 if (bt == FFEINFO_basictypeNONE)
2714 ffeimplic_establish_symbol (fn);
2715 if (ffesymbol_funcresult (fn) != NULL)
2716 ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2717 bt = ffesymbol_basictype (fn);
2718 kt = ffesymbol_kindtype (fn);
2721 if (bt == FFEINFO_basictypeCHARACTER)
2722 charfunc = TRUE, cmplxfunc = FALSE;
2723 else if ((bt == FFEINFO_basictypeCOMPLEX)
2724 && ffesymbol_is_f2c (fn))
2725 charfunc = FALSE, cmplxfunc = TRUE;
2727 charfunc = cmplxfunc = FALSE;
2730 type = ffecom_tree_fun_type_void;
2731 else if (ffesymbol_is_f2c (fn))
2732 type = ffecom_tree_fun_type[bt][kt];
2734 type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2736 if ((type == NULL_TREE)
2737 || (TREE_TYPE (type) == NULL_TREE))
2738 type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
2740 multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2743 case FFEINFO_kindSUBROUTINE:
2744 gt = FFEGLOBAL_typeSUBR;
2745 bt = FFEINFO_basictypeNONE;
2746 kt = FFEINFO_kindtypeNONE;
2747 if (ffecom_is_altreturning_)
2748 { /* Am _I_ altreturning? */
2749 for (item = ffesymbol_dummyargs (fn);
2751 item = ffebld_trail (item))
2753 if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2755 altreturning = TRUE;
2760 type = ffecom_tree_subr_type;
2762 type = ffecom_tree_fun_type_void;
2765 type = ffecom_tree_fun_type_void;
2772 assert ("say what??" == NULL);
2774 case FFEINFO_kindANY:
2775 gt = FFEGLOBAL_typeANY;
2776 bt = FFEINFO_basictypeNONE;
2777 kt = FFEINFO_kindtypeNONE;
2778 type = error_mark_node;
2785 /* build_decl uses the current lineno and input_filename to set the decl
2786 source info. So, I've putzed with ffestd and ffeste code to update that
2787 source info to point to the appropriate statement just before calling
2788 ffecom_do_entrypoint (which calls this fn). */
2790 start_function (ffecom_get_external_identifier_ (fn),
2792 0, /* nested/inline */
2793 1); /* TREE_PUBLIC */
2795 if (((g = ffesymbol_global (fn)) != NULL)
2796 && ((ffeglobal_type (g) == gt)
2797 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2799 ffeglobal_set_hook (g, current_function_decl);
2802 /* Reset args in master arg list so they get retransitioned. */
2804 for (item = ffecom_master_arglist_;
2806 item = ffebld_trail (item))
2811 arg = ffebld_head (item);
2812 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2813 continue; /* Alternate return or some such thing. */
2814 s = ffebld_symter (arg);
2815 ffesymbol_hook (s).decl_tree = NULL_TREE;
2816 ffesymbol_hook (s).length_tree = NULL_TREE;
2819 /* Build dummy arg list for this entry point. */
2821 if (charfunc || cmplxfunc)
2822 { /* Prepend arg for where result goes. */
2827 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2829 type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2831 result = ffecom_get_invented_identifier ("__g77_%s", "result");
2833 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2836 length = ffecom_char_enhance_arg_ (&type, fn);
2838 length = NULL_TREE; /* Not ref'd if !charfunc. */
2840 type = build_pointer_type (type);
2841 result = build_decl (PARM_DECL, result, type);
2843 push_parm_decl (result);
2844 ffecom_func_result_ = result;
2848 push_parm_decl (length);
2849 ffecom_func_length_ = length;
2853 result = DECL_RESULT (current_function_decl);
2855 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2857 store_parm_decls (0);
2859 ffecom_start_compstmt ();
2860 /* Disallow temp vars at this level. */
2861 current_binding_level->prep_state = 2;
2863 /* Make local var to hold return type for multi-type master fn. */
2867 multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2869 multi_retval = build_decl (VAR_DECL, multi_retval,
2870 ffecom_multi_type_node_);
2871 multi_retval = start_decl (multi_retval, FALSE);
2872 finish_decl (multi_retval, NULL_TREE, FALSE);
2875 multi_retval = NULL_TREE; /* Not actually ref'd if !multi. */
2877 /* Here we emit the actual code for the entry point. */
2883 tree arglist = NULL_TREE;
2884 tree *plist = &arglist;
2890 /* Prepare actual arg list based on master arg list. */
2892 for (list = ffecom_master_arglist_;
2894 list = ffebld_trail (list))
2896 arg = ffebld_head (list);
2897 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2899 s = ffebld_symter (arg);
2900 if (ffesymbol_hook (s).decl_tree == NULL_TREE
2901 || ffesymbol_hook (s).decl_tree == error_mark_node)
2902 actarg = null_pointer_node; /* We don't have this arg. */
2904 actarg = ffesymbol_hook (s).decl_tree;
2905 *plist = build_tree_list (NULL_TREE, actarg);
2906 plist = &TREE_CHAIN (*plist);
2909 /* This code appends the length arguments for character
2910 variables/arrays. */
2912 for (list = ffecom_master_arglist_;
2914 list = ffebld_trail (list))
2916 arg = ffebld_head (list);
2917 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2919 s = ffebld_symter (arg);
2920 if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2921 continue; /* Only looking for CHARACTER arguments. */
2922 if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2923 continue; /* Only looking for variables and arrays. */
2924 if (ffesymbol_hook (s).length_tree == NULL_TREE
2925 || ffesymbol_hook (s).length_tree == error_mark_node)
2926 actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2928 actarg = ffesymbol_hook (s).length_tree;
2929 *plist = build_tree_list (NULL_TREE, actarg);
2930 plist = &TREE_CHAIN (*plist);
2933 /* Prepend character-value return info to actual arg list. */
2937 prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2938 TREE_CHAIN (prepend)
2939 = build_tree_list (NULL_TREE, ffecom_func_length_);
2940 TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2944 /* Prepend multi-type return value to actual arg list. */
2949 = build_tree_list (NULL_TREE,
2950 ffecom_1 (ADDR_EXPR,
2951 build_pointer_type (TREE_TYPE (multi_retval)),
2953 TREE_CHAIN (prepend) = arglist;
2957 /* Prepend my entry-point number to the actual arg list. */
2959 prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2960 TREE_CHAIN (prepend) = arglist;
2963 /* Build the call to the master function. */
2965 master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2966 call = ffecom_3s (CALL_EXPR,
2967 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2968 master_fn, arglist, NULL_TREE);
2970 /* Decide whether the master function is a function or subroutine, and
2971 handle the return value for my entry point. */
2973 if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2976 expand_expr_stmt (call);
2977 expand_null_return ();
2979 else if (multi && cmplxfunc)
2981 expand_expr_stmt (call);
2983 = ffecom_1 (INDIRECT_REF,
2984 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2986 result = ffecom_modify (NULL_TREE, result,
2987 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2989 ffecom_multi_fields_[bt][kt]));
2990 expand_expr_stmt (result);
2991 expand_null_return ();
2995 expand_expr_stmt (call);
2997 = ffecom_modify (NULL_TREE, result,
2998 convert (TREE_TYPE (result),
2999 ffecom_2 (COMPONENT_REF,
3000 ffecom_tree_type[bt][kt],
3002 ffecom_multi_fields_[bt][kt])));
3003 expand_return (result);
3008 = ffecom_1 (INDIRECT_REF,
3009 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
3011 result = ffecom_modify (NULL_TREE, result, call);
3012 expand_expr_stmt (result);
3013 expand_null_return ();
3017 result = ffecom_modify (NULL_TREE,
3019 convert (TREE_TYPE (result),
3021 expand_return (result);
3025 ffecom_end_compstmt ();
3027 finish_function (0);
3029 lineno = old_lineno;
3030 input_filename = old_input_filename;
3032 ffecom_doing_entry_ = FALSE;
3036 /* Transform expr into gcc tree with possible destination
3038 Recursive descent on expr while making corresponding tree nodes and
3039 attaching type info and such. If destination supplied and compatible
3040 with temporary that would be made in certain cases, temporary isn't
3041 made, destination used instead, and dest_used flag set TRUE. */
3043 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3045 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
3046 bool *dest_used, bool assignp, bool widenp)
3051 ffeinfoBasictype bt;
3054 tree dt; /* decl_tree for an ffesymbol. */
3055 tree tree_type, tree_type_x;
3058 enum tree_code code;
3060 assert (expr != NULL);
3062 if (dest_used != NULL)
3065 bt = ffeinfo_basictype (ffebld_info (expr));
3066 kt = ffeinfo_kindtype (ffebld_info (expr));
3067 tree_type = ffecom_tree_type[bt][kt];
3069 /* Widen integral arithmetic as desired while preserving signedness. */
3070 tree_type_x = NULL_TREE;
3071 if (widenp && tree_type
3072 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
3073 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
3074 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
3076 switch (ffebld_op (expr))
3078 case FFEBLD_opACCTER:
3081 ffebit bits = ffebld_accter_bits (expr);
3082 ffetargetOffset source_offset = 0;
3083 ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3086 assert (dest_offset == 0
3087 || (bt == FFEINFO_basictypeCHARACTER
3088 && kt == FFEINFO_kindtypeCHARACTER1));
3093 ffebldConstantUnion cu;
3096 ffebldConstantArray ca = ffebld_accter (expr);
3098 ffebit_test (bits, source_offset, &value, &length);
3104 for (i = 0; i < length; ++i)
3106 cu = ffebld_constantarray_get (ca, bt, kt,
3109 t = ffecom_constantunion (&cu, bt, kt, tree_type);
3112 && dest_offset != 0)
3113 purpose = build_int_2 (dest_offset, 0);
3115 purpose = NULL_TREE;
3117 if (list == NULL_TREE)
3118 list = item = build_tree_list (purpose, t);
3121 TREE_CHAIN (item) = build_tree_list (purpose, t);
3122 item = TREE_CHAIN (item);
3126 source_offset += length;
3127 dest_offset += length;
3131 item = build_int_2 ((ffebld_accter_size (expr)
3132 + ffebld_accter_pad (expr)) - 1, 0);
3133 ffebit_kill (ffebld_accter_bits (expr));
3134 TREE_TYPE (item) = ffecom_integer_type_node;
3138 build_range_type (ffecom_integer_type_node,
3139 ffecom_integer_zero_node,
3141 list = build (CONSTRUCTOR, item, NULL_TREE, list);
3142 TREE_CONSTANT (list) = 1;
3143 TREE_STATIC (list) = 1;
3146 case FFEBLD_opARRTER:
3151 if (ffebld_arrter_pad (expr) == 0)
3155 assert (bt == FFEINFO_basictypeCHARACTER
3156 && kt == FFEINFO_kindtypeCHARACTER1);
3158 /* Becomes PURPOSE first time through loop. */
3159 item = build_int_2 (ffebld_arrter_pad (expr), 0);
3162 for (i = 0; i < ffebld_arrter_size (expr); ++i)
3164 ffebldConstantUnion cu
3165 = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3167 t = ffecom_constantunion (&cu, bt, kt, tree_type);
3169 if (list == NULL_TREE)
3170 /* Assume item is PURPOSE first time through loop. */
3171 list = item = build_tree_list (item, t);
3174 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3175 item = TREE_CHAIN (item);
3180 item = build_int_2 ((ffebld_arrter_size (expr)
3181 + ffebld_arrter_pad (expr)) - 1, 0);
3182 TREE_TYPE (item) = ffecom_integer_type_node;
3186 build_range_type (ffecom_integer_type_node,
3187 ffecom_integer_zero_node,
3189 list = build (CONSTRUCTOR, item, NULL_TREE, list);
3190 TREE_CONSTANT (list) = 1;
3191 TREE_STATIC (list) = 1;
3194 case FFEBLD_opCONTER:
3195 assert (ffebld_conter_pad (expr) == 0);
3197 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3201 case FFEBLD_opSYMTER:
3202 if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3203 || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3204 return ffecom_ptr_to_expr (expr); /* Same as %REF(intrinsic). */
3205 s = ffebld_symter (expr);
3206 t = ffesymbol_hook (s).decl_tree;
3209 { /* ASSIGN'ed-label expr. */
3210 if (ffe_is_ugly_assign ())
3212 /* User explicitly wants ASSIGN'ed variables to be at the same
3213 memory address as the variables when used in non-ASSIGN
3214 contexts. That can make old, arcane, non-standard code
3215 work, but don't try to do it when a pointer wouldn't fit
3216 in the normal variable (take other approach, and warn,
3221 s = ffecom_sym_transform_ (s);
3222 t = ffesymbol_hook (s).decl_tree;
3223 assert (t != NULL_TREE);
3226 if (t == error_mark_node)
3229 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3230 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3232 if (ffesymbol_hook (s).addr)
3233 t = ffecom_1 (INDIRECT_REF,
3234 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3238 if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3240 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3241 FFEBAD_severityWARNING);
3242 ffebad_string (ffesymbol_text (s));
3243 ffebad_here (0, ffesymbol_where_line (s),
3244 ffesymbol_where_column (s));
3249 /* Don't use the normal variable's tree for ASSIGN, though mark
3250 it as in the system header (housekeeping). Use an explicit,
3251 specially created sibling that is known to be wide enough
3252 to hold pointers to labels. */
3255 && TREE_CODE (t) == VAR_DECL)
3256 DECL_IN_SYSTEM_HEADER (t) = 1; /* Don't let -Wunused complain. */
3258 t = ffesymbol_hook (s).assign_tree;
3261 s = ffecom_sym_transform_assign_ (s);
3262 t = ffesymbol_hook (s).assign_tree;
3263 assert (t != NULL_TREE);
3270 s = ffecom_sym_transform_ (s);
3271 t = ffesymbol_hook (s).decl_tree;
3272 assert (t != NULL_TREE);
3274 if (ffesymbol_hook (s).addr)
3275 t = ffecom_1 (INDIRECT_REF,
3276 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3280 case FFEBLD_opARRAYREF:
3281 return ffecom_arrayref_ (NULL_TREE, expr, 0);
3283 case FFEBLD_opUPLUS:
3284 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3285 return ffecom_1 (NOP_EXPR, tree_type, left);
3287 case FFEBLD_opPAREN:
3288 /* ~~~Make sure Fortran rules respected here */
3289 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3290 return ffecom_1 (NOP_EXPR, tree_type, left);
3292 case FFEBLD_opUMINUS:
3293 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3296 tree_type = tree_type_x;
3297 left = convert (tree_type, left);
3299 return ffecom_1 (NEGATE_EXPR, tree_type, left);
3302 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3303 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3306 tree_type = tree_type_x;
3307 left = convert (tree_type, left);
3308 right = convert (tree_type, right);
3310 return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3312 case FFEBLD_opSUBTRACT:
3313 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3314 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3317 tree_type = tree_type_x;
3318 left = convert (tree_type, left);
3319 right = convert (tree_type, right);
3321 return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3323 case FFEBLD_opMULTIPLY:
3324 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3325 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3328 tree_type = tree_type_x;
3329 left = convert (tree_type, left);
3330 right = convert (tree_type, right);
3332 return ffecom_2 (MULT_EXPR, tree_type, left, right);
3334 case FFEBLD_opDIVIDE:
3335 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3336 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3339 tree_type = tree_type_x;
3340 left = convert (tree_type, left);
3341 right = convert (tree_type, right);
3343 return ffecom_tree_divide_ (tree_type, left, right,
3344 dest_tree, dest, dest_used,
3345 ffebld_nonter_hook (expr));
3347 case FFEBLD_opPOWER:
3349 ffebld left = ffebld_left (expr);
3350 ffebld right = ffebld_right (expr);
3352 ffeinfoKindtype rtkt;
3353 ffeinfoKindtype ltkt;
3356 switch (ffeinfo_basictype (ffebld_info (right)))
3359 case FFEINFO_basictypeINTEGER:
3362 item = ffecom_expr_power_integer_ (expr);
3363 if (item != NULL_TREE)
3367 rtkt = FFEINFO_kindtypeINTEGER1;
3368 switch (ffeinfo_basictype (ffebld_info (left)))
3370 case FFEINFO_basictypeINTEGER:
3371 if ((ffeinfo_kindtype (ffebld_info (left))
3372 == FFEINFO_kindtypeINTEGER4)
3373 || (ffeinfo_kindtype (ffebld_info (right))
3374 == FFEINFO_kindtypeINTEGER4))
3376 code = FFECOM_gfrtPOW_QQ;
3377 ltkt = FFEINFO_kindtypeINTEGER4;
3378 rtkt = FFEINFO_kindtypeINTEGER4;
3382 code = FFECOM_gfrtPOW_II;
3383 ltkt = FFEINFO_kindtypeINTEGER1;
3387 case FFEINFO_basictypeREAL:
3388 if (ffeinfo_kindtype (ffebld_info (left))
3389 == FFEINFO_kindtypeREAL1)
3391 code = FFECOM_gfrtPOW_RI;
3392 ltkt = FFEINFO_kindtypeREAL1;
3396 code = FFECOM_gfrtPOW_DI;
3397 ltkt = FFEINFO_kindtypeREAL2;
3401 case FFEINFO_basictypeCOMPLEX:
3402 if (ffeinfo_kindtype (ffebld_info (left))
3403 == FFEINFO_kindtypeREAL1)
3405 code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
3406 ltkt = FFEINFO_kindtypeREAL1;
3410 code = FFECOM_gfrtPOW_ZI; /* Overlapping result okay. */
3411 ltkt = FFEINFO_kindtypeREAL2;
3416 assert ("bad pow_*i" == NULL);
3417 code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
3418 ltkt = FFEINFO_kindtypeREAL1;
3421 if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3422 left = ffeexpr_convert (left, NULL, NULL,
3423 ffeinfo_basictype (ffebld_info (left)),
3425 FFETARGET_charactersizeNONE,
3426 FFEEXPR_contextLET);
3427 if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3428 right = ffeexpr_convert (right, NULL, NULL,
3429 FFEINFO_basictypeINTEGER,
3431 FFETARGET_charactersizeNONE,
3432 FFEEXPR_contextLET);
3435 case FFEINFO_basictypeREAL:
3436 if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3437 left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3438 FFEINFO_kindtypeREALDOUBLE, 0,
3439 FFETARGET_charactersizeNONE,
3440 FFEEXPR_contextLET);
3441 if (ffeinfo_kindtype (ffebld_info (right))
3442 == FFEINFO_kindtypeREAL1)
3443 right = ffeexpr_convert (right, NULL, NULL,
3444 FFEINFO_basictypeREAL,
3445 FFEINFO_kindtypeREALDOUBLE, 0,
3446 FFETARGET_charactersizeNONE,
3447 FFEEXPR_contextLET);
3448 /* We used to call FFECOM_gfrtPOW_DD here,
3449 which passes arguments by reference. */
3450 code = FFECOM_gfrtL_POW;
3451 /* Pass arguments by value. */
3455 case FFEINFO_basictypeCOMPLEX:
3456 if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3457 left = ffeexpr_convert (left, NULL, NULL,
3458 FFEINFO_basictypeCOMPLEX,
3459 FFEINFO_kindtypeREALDOUBLE, 0,
3460 FFETARGET_charactersizeNONE,
3461 FFEEXPR_contextLET);
3462 if (ffeinfo_kindtype (ffebld_info (right))
3463 == FFEINFO_kindtypeREAL1)
3464 right = ffeexpr_convert (right, NULL, NULL,
3465 FFEINFO_basictypeCOMPLEX,
3466 FFEINFO_kindtypeREALDOUBLE, 0,
3467 FFETARGET_charactersizeNONE,
3468 FFEEXPR_contextLET);
3469 code = FFECOM_gfrtPOW_ZZ; /* Overlapping result okay. */
3470 ref = TRUE; /* Pass arguments by reference. */
3474 assert ("bad pow_x*" == NULL);
3475 code = FFECOM_gfrtPOW_II;
3478 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3479 ffecom_gfrt_kindtype (code),
3480 (ffe_is_f2c_library ()
3481 && ffecom_gfrt_complex_[code]),
3482 tree_type, left, right,
3483 dest_tree, dest, dest_used,
3484 NULL_TREE, FALSE, ref,
3485 ffebld_nonter_hook (expr));
3491 case FFEINFO_basictypeLOGICAL:
3492 item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3493 return convert (tree_type, item);
3495 case FFEINFO_basictypeINTEGER:
3496 return ffecom_1 (BIT_NOT_EXPR, tree_type,
3497 ffecom_expr (ffebld_left (expr)));
3500 assert ("NOT bad basictype" == NULL);
3502 case FFEINFO_basictypeANY:
3503 return error_mark_node;
3507 case FFEBLD_opFUNCREF:
3508 assert (ffeinfo_basictype (ffebld_info (expr))
3509 != FFEINFO_basictypeCHARACTER);
3511 case FFEBLD_opSUBRREF:
3512 if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3513 == FFEINFO_whereINTRINSIC)
3514 { /* Invocation of an intrinsic. */
3515 item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3519 s = ffebld_symter (ffebld_left (expr));
3520 dt = ffesymbol_hook (s).decl_tree;
3521 if (dt == NULL_TREE)
3523 s = ffecom_sym_transform_ (s);
3524 dt = ffesymbol_hook (s).decl_tree;
3526 if (dt == error_mark_node)
3529 if (ffesymbol_hook (s).addr)
3532 item = ffecom_1_fn (dt);
3534 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3535 args = ffecom_list_expr (ffebld_right (expr));
3537 args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3539 if (args == error_mark_node)
3540 return error_mark_node;
3542 item = ffecom_call_ (item, kt,
3543 ffesymbol_is_f2c (s)
3544 && (bt == FFEINFO_basictypeCOMPLEX)
3545 && (ffesymbol_where (s)
3546 != FFEINFO_whereCONSTANT),
3549 dest_tree, dest, dest_used,
3550 error_mark_node, FALSE,
3551 ffebld_nonter_hook (expr));
3552 TREE_SIDE_EFFECTS (item) = 1;
3558 case FFEINFO_basictypeLOGICAL:
3560 = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3561 ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3562 ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3563 return convert (tree_type, item);
3565 case FFEINFO_basictypeINTEGER:
3566 return ffecom_2 (BIT_AND_EXPR, tree_type,
3567 ffecom_expr (ffebld_left (expr)),
3568 ffecom_expr (ffebld_right (expr)));
3571 assert ("AND bad basictype" == NULL);
3573 case FFEINFO_basictypeANY:
3574 return error_mark_node;
3581 case FFEINFO_basictypeLOGICAL:
3583 = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3584 ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3585 ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3586 return convert (tree_type, item);
3588 case FFEINFO_basictypeINTEGER:
3589 return ffecom_2 (BIT_IOR_EXPR, tree_type,
3590 ffecom_expr (ffebld_left (expr)),
3591 ffecom_expr (ffebld_right (expr)));
3594 assert ("OR bad basictype" == NULL);
3596 case FFEINFO_basictypeANY:
3597 return error_mark_node;
3605 case FFEINFO_basictypeLOGICAL:
3607 = ffecom_2 (NE_EXPR, integer_type_node,
3608 ffecom_expr (ffebld_left (expr)),
3609 ffecom_expr (ffebld_right (expr)));
3610 return convert (tree_type, ffecom_truth_value (item));
3612 case FFEINFO_basictypeINTEGER:
3613 return ffecom_2 (BIT_XOR_EXPR, tree_type,
3614 ffecom_expr (ffebld_left (expr)),
3615 ffecom_expr (ffebld_right (expr)));
3618 assert ("XOR/NEQV bad basictype" == NULL);
3620 case FFEINFO_basictypeANY:
3621 return error_mark_node;
3628 case FFEINFO_basictypeLOGICAL:
3630 = ffecom_2 (EQ_EXPR, integer_type_node,
3631 ffecom_expr (ffebld_left (expr)),
3632 ffecom_expr (ffebld_right (expr)));
3633 return convert (tree_type, ffecom_truth_value (item));
3635 case FFEINFO_basictypeINTEGER:
3637 ffecom_1 (BIT_NOT_EXPR, tree_type,
3638 ffecom_2 (BIT_XOR_EXPR, tree_type,
3639 ffecom_expr (ffebld_left (expr)),
3640 ffecom_expr (ffebld_right (expr))));
3643 assert ("EQV bad basictype" == NULL);
3645 case FFEINFO_basictypeANY:
3646 return error_mark_node;
3650 case FFEBLD_opCONVERT:
3651 if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3652 return error_mark_node;
3656 case FFEINFO_basictypeLOGICAL:
3657 case FFEINFO_basictypeINTEGER:
3658 case FFEINFO_basictypeREAL:
3659 return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3661 case FFEINFO_basictypeCOMPLEX:
3662 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3664 case FFEINFO_basictypeINTEGER:
3665 case FFEINFO_basictypeLOGICAL:
3666 case FFEINFO_basictypeREAL:
3667 item = ffecom_expr (ffebld_left (expr));
3668 if (item == error_mark_node)
3669 return error_mark_node;
3670 /* convert() takes care of converting to the subtype first,
3671 at least in gcc-2.7.2. */
3672 item = convert (tree_type, item);
3675 case FFEINFO_basictypeCOMPLEX:
3676 return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3679 assert ("CONVERT COMPLEX bad basictype" == NULL);
3681 case FFEINFO_basictypeANY:
3682 return error_mark_node;
3687 assert ("CONVERT bad basictype" == NULL);
3689 case FFEINFO_basictypeANY:
3690 return error_mark_node;
3696 goto relational; /* :::::::::::::::::::: */
3700 goto relational; /* :::::::::::::::::::: */
3704 goto relational; /* :::::::::::::::::::: */
3708 goto relational; /* :::::::::::::::::::: */
3712 goto relational; /* :::::::::::::::::::: */
3717 relational: /* :::::::::::::::::::: */
3718 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3720 case FFEINFO_basictypeLOGICAL:
3721 case FFEINFO_basictypeINTEGER:
3722 case FFEINFO_basictypeREAL:
3723 item = ffecom_2 (code, integer_type_node,
3724 ffecom_expr (ffebld_left (expr)),
3725 ffecom_expr (ffebld_right (expr)));
3726 return convert (tree_type, item);
3728 case FFEINFO_basictypeCOMPLEX:
3729 assert (code == EQ_EXPR || code == NE_EXPR);
3732 tree arg1 = ffecom_expr (ffebld_left (expr));
3733 tree arg2 = ffecom_expr (ffebld_right (expr));
3735 if (arg1 == error_mark_node || arg2 == error_mark_node)
3736 return error_mark_node;
3738 arg1 = ffecom_save_tree (arg1);
3739 arg2 = ffecom_save_tree (arg2);
3741 if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3743 real_type = TREE_TYPE (TREE_TYPE (arg1));
3744 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3748 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3749 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3753 = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3754 ffecom_2 (EQ_EXPR, integer_type_node,
3755 ffecom_1 (REALPART_EXPR, real_type, arg1),
3756 ffecom_1 (REALPART_EXPR, real_type, arg2)),
3757 ffecom_2 (EQ_EXPR, integer_type_node,
3758 ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3759 ffecom_1 (IMAGPART_EXPR, real_type,
3761 if (code == EQ_EXPR)
3762 item = ffecom_truth_value (item);
3764 item = ffecom_truth_value_invert (item);
3765 return convert (tree_type, item);
3768 case FFEINFO_basictypeCHARACTER:
3770 ffebld left = ffebld_left (expr);
3771 ffebld right = ffebld_right (expr);
3777 /* f2c run-time functions do the implicit blank-padding for us,
3778 so we don't usually have to implement blank-padding ourselves.
3779 (The exception is when we pass an argument to a separately
3780 compiled statement function -- if we know the arg is not the
3781 same length as the dummy, we must truncate or extend it. If
3782 we "inline" statement functions, that necessity goes away as
3785 Strip off the CONVERT operators that blank-pad. (Truncation by
3786 CONVERT shouldn't happen here, but it can happen in
3789 while (ffebld_op (left) == FFEBLD_opCONVERT)
3790 left = ffebld_left (left);
3791 while (ffebld_op (right) == FFEBLD_opCONVERT)
3792 right = ffebld_left (right);
3794 left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3795 right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3797 if (left_tree == error_mark_node || left_length == error_mark_node
3798 || right_tree == error_mark_node
3799 || right_length == error_mark_node)
3800 return error_mark_node;
3802 if ((ffebld_size_known (left) == 1)
3803 && (ffebld_size_known (right) == 1))
3806 = ffecom_1 (INDIRECT_REF,
3807 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3810 = ffecom_1 (INDIRECT_REF,
3811 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3815 = ffecom_2 (code, integer_type_node,
3816 ffecom_2 (ARRAY_REF,
3817 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3820 ffecom_2 (ARRAY_REF,
3821 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3827 item = build_tree_list (NULL_TREE, left_tree);
3828 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3829 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3831 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3832 = build_tree_list (NULL_TREE, right_length);
3833 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3834 item = ffecom_2 (code, integer_type_node,
3836 convert (TREE_TYPE (item),
3837 integer_zero_node));
3839 item = convert (tree_type, item);
3845 assert ("relational bad basictype" == NULL);
3847 case FFEINFO_basictypeANY:
3848 return error_mark_node;
3852 case FFEBLD_opPERCENT_LOC:
3853 item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3854 return convert (tree_type, item);
3858 case FFEBLD_opBOUNDS:
3859 case FFEBLD_opREPEAT:
3860 case FFEBLD_opLABTER:
3861 case FFEBLD_opLABTOK:
3862 case FFEBLD_opIMPDO:
3863 case FFEBLD_opCONCATENATE:
3864 case FFEBLD_opSUBSTR:
3866 assert ("bad op" == NULL);
3869 return error_mark_node;
3873 assert ("didn't think anything got here anymore!!" == NULL);
3875 switch (ffebld_arity (expr))
3878 TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3879 TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3880 if (TREE_OPERAND (item, 0) == error_mark_node
3881 || TREE_OPERAND (item, 1) == error_mark_node)
3882 return error_mark_node;
3886 TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3887 if (TREE_OPERAND (item, 0) == error_mark_node)
3888 return error_mark_node;
3900 /* Returns the tree that does the intrinsic invocation.
3902 Note: this function applies only to intrinsics returning
3903 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3906 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3908 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3909 ffebld dest, bool *dest_used)
3912 tree saved_expr1; /* For those who need it. */
3913 tree saved_expr2; /* For those who need it. */
3914 ffeinfoBasictype bt;
3918 tree real_type; /* REAL type corresponding to COMPLEX. */
3920 ffebld list = ffebld_right (expr); /* List of (some) args. */
3921 ffebld arg1; /* For handy reference. */
3924 ffeintrinImp codegen_imp;
3927 assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3929 if (dest_used != NULL)
3932 bt = ffeinfo_basictype (ffebld_info (expr));
3933 kt = ffeinfo_kindtype (ffebld_info (expr));
3934 tree_type = ffecom_tree_type[bt][kt];
3938 arg1 = ffebld_head (list);
3939 if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3940 return error_mark_node;
3941 if ((list = ffebld_trail (list)) != NULL)
3943 arg2 = ffebld_head (list);
3944 if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3945 return error_mark_node;
3946 if ((list = ffebld_trail (list)) != NULL)
3948 arg3 = ffebld_head (list);
3949 if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3950 return error_mark_node;
3959 arg1 = arg2 = arg3 = NULL;
3961 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3962 args. This is used by the MAX/MIN expansions. */
3965 arg1_type = ffecom_tree_type
3966 [ffeinfo_basictype (ffebld_info (arg1))]
3967 [ffeinfo_kindtype (ffebld_info (arg1))];
3969 arg1_type = NULL_TREE; /* Really not needed, but might catch bugs
3972 /* There are several ways for each of the cases in the following switch
3973 statements to exit (from simplest to use to most complicated):
3975 break; (when expr_tree == NULL)
3977 A standard call is made to the specific intrinsic just as if it had been
3978 passed in as a dummy procedure and called as any old procedure. This
3979 method can produce slower code but in some cases it's the easiest way for
3980 now. However, if a (presumably faster) direct call is available,
3981 that is used, so this is the easiest way in many more cases now.
3983 gfrt = FFECOM_gfrtWHATEVER;
3986 gfrt contains the gfrt index of a library function to call, passing the
3987 argument(s) by value rather than by reference. Used when a more
3988 careful choice of library function is needed than that provided
3989 by the vanilla `break;'.
3993 The expr_tree has been completely set up and is ready to be returned
3994 as is. No further actions are taken. Use this when the tree is not
3995 in the simple form for one of the arity_n labels. */
3997 /* For info on how the switch statement cases were written, see the files
3998 enclosed in comments below the switch statement. */
4000 codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
4001 gfrt = ffeintrin_gfrt_direct (codegen_imp);
4002 if (gfrt == FFECOM_gfrt)
4003 gfrt = ffeintrin_gfrt_indirect (codegen_imp);
4005 switch (codegen_imp)
4007 case FFEINTRIN_impABS:
4008 case FFEINTRIN_impCABS:
4009 case FFEINTRIN_impCDABS:
4010 case FFEINTRIN_impDABS:
4011 case FFEINTRIN_impIABS:
4012 if (ffeinfo_basictype (ffebld_info (arg1))
4013 == FFEINFO_basictypeCOMPLEX)
4015 if (kt == FFEINFO_kindtypeREAL1)
4016 gfrt = FFECOM_gfrtCABS;
4017 else if (kt == FFEINFO_kindtypeREAL2)
4018 gfrt = FFECOM_gfrtCDABS;
4021 return ffecom_1 (ABS_EXPR, tree_type,
4022 convert (tree_type, ffecom_expr (arg1)));
4024 case FFEINTRIN_impACOS:
4025 case FFEINTRIN_impDACOS:
4028 case FFEINTRIN_impAIMAG:
4029 case FFEINTRIN_impDIMAG:
4030 case FFEINTRIN_impIMAGPART:
4031 if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4032 arg1_type = TREE_TYPE (arg1_type);
4034 arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4038 ffecom_1 (IMAGPART_EXPR, arg1_type,
4039 ffecom_expr (arg1)));
4041 case FFEINTRIN_impAINT:
4042 case FFEINTRIN_impDINT:
4044 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
4045 return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
4046 #else /* in the meantime, must use floor to avoid range problems with ints */
4047 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
4048 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4051 ffecom_3 (COND_EXPR, double_type_node,
4053 (ffecom_2 (GE_EXPR, integer_type_node,
4056 ffecom_float_zero_))),
4057 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4058 build_tree_list (NULL_TREE,
4059 convert (double_type_node,
4062 ffecom_1 (NEGATE_EXPR, double_type_node,
4063 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4064 build_tree_list (NULL_TREE,
4065 convert (double_type_node,
4066 ffecom_1 (NEGATE_EXPR,
4074 case FFEINTRIN_impANINT:
4075 case FFEINTRIN_impDNINT:
4076 #if 0 /* This way of doing it won't handle real
4077 numbers of large magnitudes. */
4078 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4079 expr_tree = convert (tree_type,
4080 convert (integer_type_node,
4081 ffecom_3 (COND_EXPR, tree_type,
4086 ffecom_float_zero_)),
4087 ffecom_2 (PLUS_EXPR,
4090 ffecom_float_half_),
4091 ffecom_2 (MINUS_EXPR,
4094 ffecom_float_half_))));
4096 #else /* So we instead call floor. */
4097 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4098 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4101 ffecom_3 (COND_EXPR, double_type_node,
4103 (ffecom_2 (GE_EXPR, integer_type_node,
4106 ffecom_float_zero_))),
4107 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4108 build_tree_list (NULL_TREE,
4109 convert (double_type_node,
4110 ffecom_2 (PLUS_EXPR,
4114 ffecom_float_half_)))),
4116 ffecom_1 (NEGATE_EXPR, double_type_node,
4117 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4118 build_tree_list (NULL_TREE,
4119 convert (double_type_node,
4120 ffecom_2 (MINUS_EXPR,
4123 ffecom_float_half_),
4130 case FFEINTRIN_impASIN:
4131 case FFEINTRIN_impDASIN:
4132 case FFEINTRIN_impATAN:
4133 case FFEINTRIN_impDATAN:
4134 case FFEINTRIN_impATAN2:
4135 case FFEINTRIN_impDATAN2:
4138 case FFEINTRIN_impCHAR:
4139 case FFEINTRIN_impACHAR:
4141 tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4143 tempvar = ffebld_nonter_hook (expr);
4147 tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4149 expr_tree = ffecom_modify (tmv,
4150 ffecom_2 (ARRAY_REF, tmv, tempvar,
4152 convert (tmv, ffecom_expr (arg1)));
4154 expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4157 expr_tree = ffecom_1 (ADDR_EXPR,
4158 build_pointer_type (TREE_TYPE (expr_tree)),
4162 case FFEINTRIN_impCMPLX:
4163 case FFEINTRIN_impDCMPLX:
4166 convert (tree_type, ffecom_expr (arg1));
4168 real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4170 ffecom_2 (COMPLEX_EXPR, tree_type,
4171 convert (real_type, ffecom_expr (arg1)),
4173 ffecom_expr (arg2)));
4175 case FFEINTRIN_impCOMPLEX:
4177 ffecom_2 (COMPLEX_EXPR, tree_type,
4179 ffecom_expr (arg2));
4181 case FFEINTRIN_impCONJG:
4182 case FFEINTRIN_impDCONJG:
4186 real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4187 arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4189 ffecom_2 (COMPLEX_EXPR, tree_type,
4190 ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4191 ffecom_1 (NEGATE_EXPR, real_type,
4192 ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4195 case FFEINTRIN_impCOS:
4196 case FFEINTRIN_impCCOS:
4197 case FFEINTRIN_impCDCOS:
4198 case FFEINTRIN_impDCOS:
4199 if (bt == FFEINFO_basictypeCOMPLEX)
4201 if (kt == FFEINFO_kindtypeREAL1)
4202 gfrt = FFECOM_gfrtCCOS; /* Overlapping result okay. */
4203 else if (kt == FFEINFO_kindtypeREAL2)
4204 gfrt = FFECOM_gfrtCDCOS; /* Overlapping result okay. */
4208 case FFEINTRIN_impCOSH:
4209 case FFEINTRIN_impDCOSH:
4212 case FFEINTRIN_impDBLE:
4213 case FFEINTRIN_impDFLOAT:
4214 case FFEINTRIN_impDREAL:
4215 case FFEINTRIN_impFLOAT:
4216 case FFEINTRIN_impIDINT:
4217 case FFEINTRIN_impIFIX:
4218 case FFEINTRIN_impINT2:
4219 case FFEINTRIN_impINT8:
4220 case FFEINTRIN_impINT:
4221 case FFEINTRIN_impLONG:
4222 case FFEINTRIN_impREAL:
4223 case FFEINTRIN_impSHORT:
4224 case FFEINTRIN_impSNGL:
4225 return convert (tree_type, ffecom_expr (arg1));
4227 case FFEINTRIN_impDIM:
4228 case FFEINTRIN_impDDIM:
4229 case FFEINTRIN_impIDIM:
4230 saved_expr1 = ffecom_save_tree (convert (tree_type,
4231 ffecom_expr (arg1)));
4232 saved_expr2 = ffecom_save_tree (convert (tree_type,
4233 ffecom_expr (arg2)));
4235 ffecom_3 (COND_EXPR, tree_type,
4237 (ffecom_2 (GT_EXPR, integer_type_node,
4240 ffecom_2 (MINUS_EXPR, tree_type,
4243 convert (tree_type, ffecom_float_zero_));
4245 case FFEINTRIN_impDPROD:
4247 ffecom_2 (MULT_EXPR, tree_type,
4248 convert (tree_type, ffecom_expr (arg1)),
4249 convert (tree_type, ffecom_expr (arg2)));
4251 case FFEINTRIN_impEXP:
4252 case FFEINTRIN_impCDEXP:
4253 case FFEINTRIN_impCEXP:
4254 case FFEINTRIN_impDEXP:
4255 if (bt == FFEINFO_basictypeCOMPLEX)
4257 if (kt == FFEINFO_kindtypeREAL1)
4258 gfrt = FFECOM_gfrtCEXP; /* Overlapping result okay. */
4259 else if (kt == FFEINFO_kindtypeREAL2)
4260 gfrt = FFECOM_gfrtCDEXP; /* Overlapping result okay. */
4264 case FFEINTRIN_impICHAR:
4265 case FFEINTRIN_impIACHAR:
4266 #if 0 /* The simple approach. */
4267 ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4269 = ffecom_1 (INDIRECT_REF,
4270 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4273 = ffecom_2 (ARRAY_REF,
4274 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4277 return convert (tree_type, expr_tree);
4278 #else /* The more interesting (and more optimal) approach. */
4279 expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4280 expr_tree = ffecom_3 (COND_EXPR, tree_type,
4283 convert (tree_type, integer_zero_node));
4287 case FFEINTRIN_impINDEX:
4290 case FFEINTRIN_impLEN:
4292 break; /* The simple approach. */
4294 return ffecom_intrinsic_len_ (arg1); /* The more optimal approach. */
4297 case FFEINTRIN_impLGE:
4298 case FFEINTRIN_impLGT:
4299 case FFEINTRIN_impLLE:
4300 case FFEINTRIN_impLLT:
4303 case FFEINTRIN_impLOG:
4304 case FFEINTRIN_impALOG:
4305 case FFEINTRIN_impCDLOG:
4306 case FFEINTRIN_impCLOG:
4307 case FFEINTRIN_impDLOG:
4308 if (bt == FFEINFO_basictypeCOMPLEX)
4310 if (kt == FFEINFO_kindtypeREAL1)
4311 gfrt = FFECOM_gfrtCLOG; /* Overlapping result okay. */
4312 else if (kt == FFEINFO_kindtypeREAL2)
4313 gfrt = FFECOM_gfrtCDLOG; /* Overlapping result okay. */
4317 case FFEINTRIN_impLOG10:
4318 case FFEINTRIN_impALOG10:
4319 case FFEINTRIN_impDLOG10:
4320 if (gfrt != FFECOM_gfrt)
4321 break; /* Already picked one, stick with it. */
4323 if (kt == FFEINFO_kindtypeREAL1)
4324 /* We used to call FFECOM_gfrtALOG10 here. */
4325 gfrt = FFECOM_gfrtL_LOG10;
4326 else if (kt == FFEINFO_kindtypeREAL2)
4327 /* We used to call FFECOM_gfrtDLOG10 here. */
4328 gfrt = FFECOM_gfrtL_LOG10;
4331 case FFEINTRIN_impMAX:
4332 case FFEINTRIN_impAMAX0:
4333 case FFEINTRIN_impAMAX1:
4334 case FFEINTRIN_impDMAX1:
4335 case FFEINTRIN_impMAX0:
4336 case FFEINTRIN_impMAX1:
4337 if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4338 arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4340 arg1_type = tree_type;
4341 expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4342 convert (arg1_type, ffecom_expr (arg1)),
4343 convert (arg1_type, ffecom_expr (arg2)));
4344 for (; list != NULL; list = ffebld_trail (list))
4346 if ((ffebld_head (list) == NULL)
4347 || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4349 expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4352 ffecom_expr (ffebld_head (list))));
4354 return convert (tree_type, expr_tree);
4356 case FFEINTRIN_impMIN:
4357 case FFEINTRIN_impAMIN0:
4358 case FFEINTRIN_impAMIN1:
4359 case FFEINTRIN_impDMIN1:
4360 case FFEINTRIN_impMIN0:
4361 case FFEINTRIN_impMIN1:
4362 if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4363 arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4365 arg1_type = tree_type;
4366 expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4367 convert (arg1_type, ffecom_expr (arg1)),
4368 convert (arg1_type, ffecom_expr (arg2)));
4369 for (; list != NULL; list = ffebld_trail (list))
4371 if ((ffebld_head (list) == NULL)
4372 || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4374 expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4377 ffecom_expr (ffebld_head (list))));
4379 return convert (tree_type, expr_tree);
4381 case FFEINTRIN_impMOD:
4382 case FFEINTRIN_impAMOD:
4383 case FFEINTRIN_impDMOD:
4384 if (bt != FFEINFO_basictypeREAL)
4385 return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4386 convert (tree_type, ffecom_expr (arg1)),
4387 convert (tree_type, ffecom_expr (arg2)));
4389 if (kt == FFEINFO_kindtypeREAL1)
4390 /* We used to call FFECOM_gfrtAMOD here. */
4391 gfrt = FFECOM_gfrtL_FMOD;
4392 else if (kt == FFEINFO_kindtypeREAL2)
4393 /* We used to call FFECOM_gfrtDMOD here. */
4394 gfrt = FFECOM_gfrtL_FMOD;
4397 case FFEINTRIN_impNINT:
4398 case FFEINTRIN_impIDNINT:
4400 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4401 return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4403 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4404 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4406 convert (ffecom_integer_type_node,
4407 ffecom_3 (COND_EXPR, arg1_type,
4409 (ffecom_2 (GE_EXPR, integer_type_node,
4412 ffecom_float_zero_))),
4413 ffecom_2 (PLUS_EXPR, arg1_type,
4416 ffecom_float_half_)),
4417 ffecom_2 (MINUS_EXPR, arg1_type,
4420 ffecom_float_half_))));
4423 case FFEINTRIN_impSIGN:
4424 case FFEINTRIN_impDSIGN:
4425 case FFEINTRIN_impISIGN:
4427 tree arg2_tree = ffecom_expr (arg2);
4431 (ffecom_1 (ABS_EXPR, tree_type,
4433 ffecom_expr (arg1))));
4435 = ffecom_3 (COND_EXPR, tree_type,
4437 (ffecom_2 (GE_EXPR, integer_type_node,
4439 convert (TREE_TYPE (arg2_tree),
4440 integer_zero_node))),
4442 ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4443 /* Make sure SAVE_EXPRs get referenced early enough. */
4445 = ffecom_2 (COMPOUND_EXPR, tree_type,
4446 convert (void_type_node, saved_expr1),
4451 case FFEINTRIN_impSIN:
4452 case FFEINTRIN_impCDSIN:
4453 case FFEINTRIN_impCSIN:
4454 case FFEINTRIN_impDSIN:
4455 if (bt == FFEINFO_basictypeCOMPLEX)
4457 if (kt == FFEINFO_kindtypeREAL1)
4458 gfrt = FFECOM_gfrtCSIN; /* Overlapping result okay. */
4459 else if (kt == FFEINFO_kindtypeREAL2)
4460 gfrt = FFECOM_gfrtCDSIN; /* Overlapping result okay. */
4464 case FFEINTRIN_impSINH:
4465 case FFEINTRIN_impDSINH:
4468 case FFEINTRIN_impSQRT:
4469 case FFEINTRIN_impCDSQRT:
4470 case FFEINTRIN_impCSQRT:
4471 case FFEINTRIN_impDSQRT:
4472 if (bt == FFEINFO_basictypeCOMPLEX)
4474 if (kt == FFEINFO_kindtypeREAL1)
4475 gfrt = FFECOM_gfrtCSQRT; /* Overlapping result okay. */
4476 else if (kt == FFEINFO_kindtypeREAL2)
4477 gfrt = FFECOM_gfrtCDSQRT; /* Overlapping result okay. */
4481 case FFEINTRIN_impTAN:
4482 case FFEINTRIN_impDTAN:
4483 case FFEINTRIN_impTANH:
4484 case FFEINTRIN_impDTANH:
4487 case FFEINTRIN_impREALPART:
4488 if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4489 arg1_type = TREE_TYPE (arg1_type);
4491 arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4495 ffecom_1 (REALPART_EXPR, arg1_type,
4496 ffecom_expr (arg1)));
4498 case FFEINTRIN_impIAND:
4499 case FFEINTRIN_impAND:
4500 return ffecom_2 (BIT_AND_EXPR, tree_type,
4502 ffecom_expr (arg1)),
4504 ffecom_expr (arg2)));
4506 case FFEINTRIN_impIOR:
4507 case FFEINTRIN_impOR:
4508 return ffecom_2 (BIT_IOR_EXPR, tree_type,
4510 ffecom_expr (arg1)),
4512 ffecom_expr (arg2)));
4514 case FFEINTRIN_impIEOR:
4515 case FFEINTRIN_impXOR:
4516 return ffecom_2 (BIT_XOR_EXPR, tree_type,
4518 ffecom_expr (arg1)),
4520 ffecom_expr (arg2)));
4522 case FFEINTRIN_impLSHIFT:
4523 return ffecom_2 (LSHIFT_EXPR, tree_type,
4525 convert (integer_type_node,
4526 ffecom_expr (arg2)));
4528 case FFEINTRIN_impRSHIFT:
4529 return ffecom_2 (RSHIFT_EXPR, tree_type,
4531 convert (integer_type_node,
4532 ffecom_expr (arg2)));
4534 case FFEINTRIN_impNOT:
4535 return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4537 case FFEINTRIN_impBIT_SIZE:
4538 return convert (tree_type, TYPE_SIZE (arg1_type));
4540 case FFEINTRIN_impBTEST:
4542 ffetargetLogical1 true;
4543 ffetargetLogical1 false;
4547 ffetarget_logical1 (&true, TRUE);
4548 ffetarget_logical1 (&false, FALSE);
4550 true_tree = convert (tree_type, integer_one_node);
4552 true_tree = convert (tree_type, build_int_2 (true, 0));
4554 false_tree = convert (tree_type, integer_zero_node);
4556 false_tree = convert (tree_type, build_int_2 (false, 0));
4559 ffecom_3 (COND_EXPR, tree_type,
4561 (ffecom_2 (EQ_EXPR, integer_type_node,
4562 ffecom_2 (BIT_AND_EXPR, arg1_type,
4564 ffecom_2 (LSHIFT_EXPR, arg1_type,
4567 convert (integer_type_node,
4568 ffecom_expr (arg2)))),
4570 integer_zero_node))),
4575 case FFEINTRIN_impIBCLR:
4577 ffecom_2 (BIT_AND_EXPR, tree_type,
4579 ffecom_1 (BIT_NOT_EXPR, tree_type,
4580 ffecom_2 (LSHIFT_EXPR, tree_type,
4583 convert (integer_type_node,
4584 ffecom_expr (arg2)))));
4586 case FFEINTRIN_impIBITS:
4588 tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4589 ffecom_expr (arg3)));
4591 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4594 = ffecom_2 (BIT_AND_EXPR, tree_type,
4595 ffecom_2 (RSHIFT_EXPR, tree_type,
4597 convert (integer_type_node,
4598 ffecom_expr (arg2))),
4600 ffecom_2 (RSHIFT_EXPR, uns_type,
4601 ffecom_1 (BIT_NOT_EXPR,
4604 integer_zero_node)),
4605 ffecom_2 (MINUS_EXPR,
4607 TYPE_SIZE (uns_type),
4609 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4611 = ffecom_3 (COND_EXPR, tree_type,
4613 (ffecom_2 (NE_EXPR, integer_type_node,
4615 integer_zero_node)),
4617 convert (tree_type, integer_zero_node));
4622 case FFEINTRIN_impIBSET:
4624 ffecom_2 (BIT_IOR_EXPR, tree_type,
4626 ffecom_2 (LSHIFT_EXPR, tree_type,
4627 convert (tree_type, integer_one_node),
4628 convert (integer_type_node,
4629 ffecom_expr (arg2))));
4631 case FFEINTRIN_impISHFT:
4633 tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4634 tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4635 ffecom_expr (arg2)));
4637 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4640 = ffecom_3 (COND_EXPR, tree_type,
4642 (ffecom_2 (GE_EXPR, integer_type_node,
4644 integer_zero_node)),
4645 ffecom_2 (LSHIFT_EXPR, tree_type,
4649 ffecom_2 (RSHIFT_EXPR, uns_type,
4650 convert (uns_type, arg1_tree),
4651 ffecom_1 (NEGATE_EXPR,
4654 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4656 = ffecom_3 (COND_EXPR, tree_type,
4658 (ffecom_2 (NE_EXPR, integer_type_node,
4660 TYPE_SIZE (uns_type))),
4662 convert (tree_type, integer_zero_node));
4664 /* Make sure SAVE_EXPRs get referenced early enough. */
4666 = ffecom_2 (COMPOUND_EXPR, tree_type,
4667 convert (void_type_node, arg1_tree),
4668 ffecom_2 (COMPOUND_EXPR, tree_type,
4669 convert (void_type_node, arg2_tree),
4674 case FFEINTRIN_impISHFTC:
4676 tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4677 tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4678 ffecom_expr (arg2)));
4679 tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4680 : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4686 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4689 = ffecom_2 (LSHIFT_EXPR, tree_type,
4690 ffecom_1 (BIT_NOT_EXPR, tree_type,
4691 convert (tree_type, integer_zero_node)),
4693 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4695 = ffecom_3 (COND_EXPR, tree_type,
4697 (ffecom_2 (NE_EXPR, integer_type_node,
4699 TYPE_SIZE (uns_type))),
4701 convert (tree_type, integer_zero_node));
4703 mask_arg1 = ffecom_save_tree (mask_arg1);
4705 = ffecom_2 (BIT_AND_EXPR, tree_type,
4707 ffecom_1 (BIT_NOT_EXPR, tree_type,
4709 masked_arg1 = ffecom_save_tree (masked_arg1);
4711 = ffecom_2 (BIT_IOR_EXPR, tree_type,
4713 ffecom_2 (RSHIFT_EXPR, uns_type,
4714 convert (uns_type, masked_arg1),
4715 ffecom_1 (NEGATE_EXPR,
4718 ffecom_2 (LSHIFT_EXPR, tree_type,
4720 ffecom_2 (PLUS_EXPR, integer_type_node,
4724 = ffecom_2 (BIT_IOR_EXPR, tree_type,
4725 ffecom_2 (LSHIFT_EXPR, tree_type,
4729 ffecom_2 (RSHIFT_EXPR, uns_type,
4730 convert (uns_type, masked_arg1),
4731 ffecom_2 (MINUS_EXPR,
4736 = ffecom_3 (COND_EXPR, tree_type,
4738 (ffecom_2 (LT_EXPR, integer_type_node,
4740 integer_zero_node)),
4744 = ffecom_2 (BIT_IOR_EXPR, tree_type,
4745 ffecom_2 (BIT_AND_EXPR, tree_type,
4748 ffecom_2 (BIT_AND_EXPR, tree_type,
4749 ffecom_1 (BIT_NOT_EXPR, tree_type,
4753 = ffecom_3 (COND_EXPR, tree_type,
4755 (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4756 ffecom_2 (EQ_EXPR, integer_type_node,
4761 ffecom_2 (EQ_EXPR, integer_type_node,
4763 integer_zero_node))),
4766 /* Make sure SAVE_EXPRs get referenced early enough. */
4768 = ffecom_2 (COMPOUND_EXPR, tree_type,
4769 convert (void_type_node, arg1_tree),
4770 ffecom_2 (COMPOUND_EXPR, tree_type,
4771 convert (void_type_node, arg2_tree),
4772 ffecom_2 (COMPOUND_EXPR, tree_type,
4773 convert (void_type_node,
4775 ffecom_2 (COMPOUND_EXPR, tree_type,
4776 convert (void_type_node,
4780 = ffecom_2 (COMPOUND_EXPR, tree_type,
4781 convert (void_type_node,
4787 case FFEINTRIN_impLOC:
4789 tree arg1_tree = ffecom_expr (arg1);
4792 = convert (tree_type,
4793 ffecom_1 (ADDR_EXPR,
4794 build_pointer_type (TREE_TYPE (arg1_tree)),
4799 case FFEINTRIN_impMVBITS:
4804 ffebld arg4 = ffebld_head (ffebld_trail (list));
4807 ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4811 tree arg5_plus_arg3;
4813 arg2_tree = convert (integer_type_node,
4814 ffecom_expr (arg2));
4815 arg3_tree = ffecom_save_tree (convert (integer_type_node,
4816 ffecom_expr (arg3)));
4817 arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4818 arg4_type = TREE_TYPE (arg4_tree);
4820 arg1_tree = ffecom_save_tree (convert (arg4_type,
4821 ffecom_expr (arg1)));
4823 arg5_tree = ffecom_save_tree (convert (integer_type_node,
4824 ffecom_expr (arg5)));
4827 = ffecom_2 (LSHIFT_EXPR, arg4_type,
4828 ffecom_2 (BIT_AND_EXPR, arg4_type,
4829 ffecom_2 (RSHIFT_EXPR, arg4_type,
4832 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4833 ffecom_2 (LSHIFT_EXPR, arg4_type,
4834 ffecom_1 (BIT_NOT_EXPR,
4838 integer_zero_node)),
4842 = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4846 = ffecom_2 (LSHIFT_EXPR, arg4_type,
4847 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4849 integer_zero_node)),
4851 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4853 = ffecom_3 (COND_EXPR, arg4_type,
4855 (ffecom_2 (NE_EXPR, integer_type_node,
4857 convert (TREE_TYPE (arg5_plus_arg3),
4858 TYPE_SIZE (arg4_type)))),
4860 convert (arg4_type, integer_zero_node));
4863 = ffecom_2 (BIT_AND_EXPR, arg4_type,
4865 ffecom_2 (BIT_IOR_EXPR, arg4_type,
4867 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4868 ffecom_2 (LSHIFT_EXPR, arg4_type,
4869 ffecom_1 (BIT_NOT_EXPR,
4873 integer_zero_node)),
4876 = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4879 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4881 = ffecom_3 (COND_EXPR, arg4_type,
4883 (ffecom_2 (NE_EXPR, integer_type_node,
4885 convert (TREE_TYPE (arg3_tree),
4886 integer_zero_node))),
4890 = ffecom_3 (COND_EXPR, arg4_type,
4892 (ffecom_2 (NE_EXPR, integer_type_node,
4894 convert (TREE_TYPE (arg3_tree),
4895 TYPE_SIZE (arg4_type)))),
4900 = ffecom_2s (MODIFY_EXPR, void_type_node,
4903 /* Make sure SAVE_EXPRs get referenced early enough. */
4905 = ffecom_2 (COMPOUND_EXPR, void_type_node,
4907 ffecom_2 (COMPOUND_EXPR, void_type_node,
4909 ffecom_2 (COMPOUND_EXPR, void_type_node,
4911 ffecom_2 (COMPOUND_EXPR, void_type_node,
4915 = ffecom_2 (COMPOUND_EXPR, void_type_node,
4922 case FFEINTRIN_impDERF:
4923 case FFEINTRIN_impERF:
4924 case FFEINTRIN_impDERFC:
4925 case FFEINTRIN_impERFC:
4928 case FFEINTRIN_impIARGC:
4929 /* extern int xargc; i__1 = xargc - 1; */
4930 expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4932 convert (TREE_TYPE (ffecom_tree_xargc_),
4936 case FFEINTRIN_impSIGNAL_func:
4937 case FFEINTRIN_impSIGNAL_subr:
4943 arg1_tree = convert (ffecom_f2c_integer_type_node,
4944 ffecom_expr (arg1));
4945 arg1_tree = ffecom_1 (ADDR_EXPR,
4946 build_pointer_type (TREE_TYPE (arg1_tree)),
4949 /* Pass procedure as a pointer to it, anything else by value. */
4950 if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4951 arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4953 arg2_tree = ffecom_ptr_to_expr (arg2);
4954 arg2_tree = convert (TREE_TYPE (null_pointer_node),
4958 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4960 arg3_tree = NULL_TREE;
4962 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4963 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4964 TREE_CHAIN (arg1_tree) = arg2_tree;
4967 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4968 ffecom_gfrt_kindtype (gfrt),
4970 ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4974 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4975 ffebld_nonter_hook (expr));
4977 if (arg3_tree != NULL_TREE)
4979 = ffecom_modify (NULL_TREE, arg3_tree,
4980 convert (TREE_TYPE (arg3_tree),
4985 case FFEINTRIN_impALARM:
4991 arg1_tree = convert (ffecom_f2c_integer_type_node,
4992 ffecom_expr (arg1));
4993 arg1_tree = ffecom_1 (ADDR_EXPR,
4994 build_pointer_type (TREE_TYPE (arg1_tree)),
4997 /* Pass procedure as a pointer to it, anything else by value. */
4998 if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4999 arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
5001 arg2_tree = ffecom_ptr_to_expr (arg2);
5002 arg2_tree = convert (TREE_TYPE (null_pointer_node),
5006 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5008 arg3_tree = NULL_TREE;
5010 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5011 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5012 TREE_CHAIN (arg1_tree) = arg2_tree;
5015 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5016 ffecom_gfrt_kindtype (gfrt),
5020 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5021 ffebld_nonter_hook (expr));
5023 if (arg3_tree != NULL_TREE)
5025 = ffecom_modify (NULL_TREE, arg3_tree,
5026 convert (TREE_TYPE (arg3_tree),
5031 case FFEINTRIN_impCHDIR_subr:
5032 case FFEINTRIN_impFDATE_subr:
5033 case FFEINTRIN_impFGET_subr:
5034 case FFEINTRIN_impFPUT_subr:
5035 case FFEINTRIN_impGETCWD_subr:
5036 case FFEINTRIN_impHOSTNM_subr:
5037 case FFEINTRIN_impSYSTEM_subr:
5038 case FFEINTRIN_impUNLINK_subr:
5040 tree arg1_len = integer_zero_node;
5044 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5047 arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5049 arg2_tree = NULL_TREE;
5051 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5052 arg1_len = build_tree_list (NULL_TREE, arg1_len);
5053 TREE_CHAIN (arg1_tree) = arg1_len;
5056 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5057 ffecom_gfrt_kindtype (gfrt),
5061 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5062 ffebld_nonter_hook (expr));
5064 if (arg2_tree != NULL_TREE)
5066 = ffecom_modify (NULL_TREE, arg2_tree,
5067 convert (TREE_TYPE (arg2_tree),
5072 case FFEINTRIN_impEXIT:
5076 expr_tree = build_tree_list (NULL_TREE,
5077 ffecom_1 (ADDR_EXPR,
5079 (ffecom_integer_type_node),
5080 integer_zero_node));
5083 ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5084 ffecom_gfrt_kindtype (gfrt),
5088 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5089 ffebld_nonter_hook (expr));
5091 case FFEINTRIN_impFLUSH:
5093 gfrt = FFECOM_gfrtFLUSH;
5095 gfrt = FFECOM_gfrtFLUSH1;
5098 case FFEINTRIN_impCHMOD_subr:
5099 case FFEINTRIN_impLINK_subr:
5100 case FFEINTRIN_impRENAME_subr:
5101 case FFEINTRIN_impSYMLNK_subr:
5103 tree arg1_len = integer_zero_node;
5105 tree arg2_len = integer_zero_node;
5109 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5110 arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5112 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5114 arg3_tree = NULL_TREE;
5116 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5117 arg1_len = build_tree_list (NULL_TREE, arg1_len);
5118 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5119 arg2_len = build_tree_list (NULL_TREE, arg2_len);
5120 TREE_CHAIN (arg1_tree) = arg2_tree;
5121 TREE_CHAIN (arg2_tree) = arg1_len;
5122 TREE_CHAIN (arg1_len) = arg2_len;
5123 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5124 ffecom_gfrt_kindtype (gfrt),
5128 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5129 ffebld_nonter_hook (expr));
5130 if (arg3_tree != NULL_TREE)
5131 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5132 convert (TREE_TYPE (arg3_tree),
5137 case FFEINTRIN_impLSTAT_subr:
5138 case FFEINTRIN_impSTAT_subr:
5140 tree arg1_len = integer_zero_node;
5145 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5147 arg2_tree = ffecom_ptr_to_expr (arg2);
5150 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5152 arg3_tree = NULL_TREE;
5154 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5155 arg1_len = build_tree_list (NULL_TREE, arg1_len);
5156 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5157 TREE_CHAIN (arg1_tree) = arg2_tree;
5158 TREE_CHAIN (arg2_tree) = arg1_len;
5159 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5160 ffecom_gfrt_kindtype (gfrt),
5164 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5165 ffebld_nonter_hook (expr));
5166 if (arg3_tree != NULL_TREE)
5167 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5168 convert (TREE_TYPE (arg3_tree),
5173 case FFEINTRIN_impFGETC_subr:
5174 case FFEINTRIN_impFPUTC_subr:
5178 tree arg2_len = integer_zero_node;
5181 arg1_tree = convert (ffecom_f2c_integer_type_node,
5182 ffecom_expr (arg1));
5183 arg1_tree = ffecom_1 (ADDR_EXPR,
5184 build_pointer_type (TREE_TYPE (arg1_tree)),
5187 arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5189 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5191 arg3_tree = NULL_TREE;
5193 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5194 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5195 arg2_len = build_tree_list (NULL_TREE, arg2_len);
5196 TREE_CHAIN (arg1_tree) = arg2_tree;
5197 TREE_CHAIN (arg2_tree) = arg2_len;
5199 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5200 ffecom_gfrt_kindtype (gfrt),
5204 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5205 ffebld_nonter_hook (expr));
5206 if (arg3_tree != NULL_TREE)
5207 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5208 convert (TREE_TYPE (arg3_tree),
5213 case FFEINTRIN_impFSTAT_subr:
5219 arg1_tree = convert (ffecom_f2c_integer_type_node,
5220 ffecom_expr (arg1));
5221 arg1_tree = ffecom_1 (ADDR_EXPR,
5222 build_pointer_type (TREE_TYPE (arg1_tree)),
5225 arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5226 ffecom_ptr_to_expr (arg2));
5229 arg3_tree = NULL_TREE;
5231 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5233 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5234 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5235 TREE_CHAIN (arg1_tree) = arg2_tree;
5236 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5237 ffecom_gfrt_kindtype (gfrt),
5241 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5242 ffebld_nonter_hook (expr));
5243 if (arg3_tree != NULL_TREE) {
5244 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5245 convert (TREE_TYPE (arg3_tree),
5251 case FFEINTRIN_impKILL_subr:
5257 arg1_tree = convert (ffecom_f2c_integer_type_node,
5258 ffecom_expr (arg1));
5259 arg1_tree = ffecom_1 (ADDR_EXPR,
5260 build_pointer_type (TREE_TYPE (arg1_tree)),
5263 arg2_tree = convert (ffecom_f2c_integer_type_node,
5264 ffecom_expr (arg2));
5265 arg2_tree = ffecom_1 (ADDR_EXPR,
5266 build_pointer_type (TREE_TYPE (arg2_tree)),
5270 arg3_tree = NULL_TREE;
5272 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5274 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5275 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5276 TREE_CHAIN (arg1_tree) = arg2_tree;
5277 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5278 ffecom_gfrt_kindtype (gfrt),
5282 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5283 ffebld_nonter_hook (expr));
5284 if (arg3_tree != NULL_TREE) {
5285 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5286 convert (TREE_TYPE (arg3_tree),
5292 case FFEINTRIN_impCTIME_subr:
5293 case FFEINTRIN_impTTYNAM_subr:
5295 tree arg1_len = integer_zero_node;
5299 arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5301 arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5302 ffecom_f2c_longint_type_node :
5303 ffecom_f2c_integer_type_node),
5304 ffecom_expr (arg1));
5305 arg2_tree = ffecom_1 (ADDR_EXPR,
5306 build_pointer_type (TREE_TYPE (arg2_tree)),
5309 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5310 arg1_len = build_tree_list (NULL_TREE, arg1_len);
5311 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5312 TREE_CHAIN (arg1_len) = arg2_tree;
5313 TREE_CHAIN (arg1_tree) = arg1_len;
5316 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5317 ffecom_gfrt_kindtype (gfrt),
5321 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5322 ffebld_nonter_hook (expr));
5323 TREE_SIDE_EFFECTS (expr_tree) = 1;
5327 case FFEINTRIN_impIRAND:
5328 case FFEINTRIN_impRAND:
5329 /* Arg defaults to 0 (normal random case) */
5334 arg1_tree = ffecom_integer_zero_node;
5336 arg1_tree = ffecom_expr (arg1);
5337 arg1_tree = convert (ffecom_f2c_integer_type_node,
5339 arg1_tree = ffecom_1 (ADDR_EXPR,
5340 build_pointer_type (TREE_TYPE (arg1_tree)),
5342 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5344 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5345 ffecom_gfrt_kindtype (gfrt),
5347 ((codegen_imp == FFEINTRIN_impIRAND) ?
5348 ffecom_f2c_integer_type_node :
5349 ffecom_f2c_real_type_node),
5351 dest_tree, dest, dest_used,
5353 ffebld_nonter_hook (expr));
5357 case FFEINTRIN_impFTELL_subr:
5358 case FFEINTRIN_impUMASK_subr:
5363 arg1_tree = convert (ffecom_f2c_integer_type_node,
5364 ffecom_expr (arg1));
5365 arg1_tree = ffecom_1 (ADDR_EXPR,
5366 build_pointer_type (TREE_TYPE (arg1_tree)),
5370 arg2_tree = NULL_TREE;
5372 arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5374 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5375 ffecom_gfrt_kindtype (gfrt),
5378 build_tree_list (NULL_TREE, arg1_tree),
5379 NULL_TREE, NULL, NULL, NULL_TREE,
5381 ffebld_nonter_hook (expr));
5382 if (arg2_tree != NULL_TREE) {
5383 expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5384 convert (TREE_TYPE (arg2_tree),
5390 case FFEINTRIN_impCPU_TIME:
5391 case FFEINTRIN_impSECOND_subr:
5395 arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5398 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5399 ffecom_gfrt_kindtype (gfrt),
5403 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5404 ffebld_nonter_hook (expr));
5407 = ffecom_modify (NULL_TREE, arg1_tree,
5408 convert (TREE_TYPE (arg1_tree),
5413 case FFEINTRIN_impDTIME_subr:
5414 case FFEINTRIN_impETIME_subr:
5419 result_tree = ffecom_expr_w (NULL_TREE, arg2);
5421 arg1_tree = ffecom_ptr_to_expr (arg1);
5423 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5424 ffecom_gfrt_kindtype (gfrt),
5427 build_tree_list (NULL_TREE, arg1_tree),
5428 NULL_TREE, NULL, NULL, NULL_TREE,
5430 ffebld_nonter_hook (expr));
5431 expr_tree = ffecom_modify (NULL_TREE, result_tree,
5432 convert (TREE_TYPE (result_tree),
5437 /* Straightforward calls of libf2c routines: */
5438 case FFEINTRIN_impABORT:
5439 case FFEINTRIN_impACCESS:
5440 case FFEINTRIN_impBESJ0:
5441 case FFEINTRIN_impBESJ1:
5442 case FFEINTRIN_impBESJN:
5443 case FFEINTRIN_impBESY0:
5444 case FFEINTRIN_impBESY1:
5445 case FFEINTRIN_impBESYN:
5446 case FFEINTRIN_impCHDIR_func:
5447 case FFEINTRIN_impCHMOD_func:
5448 case FFEINTRIN_impDATE:
5449 case FFEINTRIN_impDATE_AND_TIME:
5450 case FFEINTRIN_impDBESJ0:
5451 case FFEINTRIN_impDBESJ1:
5452 case FFEINTRIN_impDBESJN:
5453 case FFEINTRIN_impDBESY0:
5454 case FFEINTRIN_impDBESY1:
5455 case FFEINTRIN_impDBESYN:
5456 case FFEINTRIN_impDTIME_func:
5457 case FFEINTRIN_impETIME_func:
5458 case FFEINTRIN_impFGETC_func:
5459 case FFEINTRIN_impFGET_func:
5460 case FFEINTRIN_impFNUM:
5461 case FFEINTRIN_impFPUTC_func:
5462 case FFEINTRIN_impFPUT_func:
5463 case FFEINTRIN_impFSEEK:
5464 case FFEINTRIN_impFSTAT_func:
5465 case FFEINTRIN_impFTELL_func:
5466 case FFEINTRIN_impGERROR:
5467 case FFEINTRIN_impGETARG:
5468 case FFEINTRIN_impGETCWD_func:
5469 case FFEINTRIN_impGETENV:
5470 case FFEINTRIN_impGETGID:
5471 case FFEINTRIN_impGETLOG:
5472 case FFEINTRIN_impGETPID:
5473 case FFEINTRIN_impGETUID:
5474 case FFEINTRIN_impGMTIME:
5475 case FFEINTRIN_impHOSTNM_func:
5476 case FFEINTRIN_impIDATE_unix:
5477 case FFEINTRIN_impIDATE_vxt:
5478 case FFEINTRIN_impIERRNO:
5479 case FFEINTRIN_impISATTY:
5480 case FFEINTRIN_impITIME:
5481 case FFEINTRIN_impKILL_func:
5482 case FFEINTRIN_impLINK_func:
5483 case FFEINTRIN_impLNBLNK:
5484 case FFEINTRIN_impLSTAT_func:
5485 case FFEINTRIN_impLTIME:
5486 case FFEINTRIN_impMCLOCK8:
5487 case FFEINTRIN_impMCLOCK:
5488 case FFEINTRIN_impPERROR:
5489 case FFEINTRIN_impRENAME_func:
5490 case FFEINTRIN_impSECNDS:
5491 case FFEINTRIN_impSECOND_func:
5492 case FFEINTRIN_impSLEEP:
5493 case FFEINTRIN_impSRAND:
5494 case FFEINTRIN_impSTAT_func:
5495 case FFEINTRIN_impSYMLNK_func:
5496 case FFEINTRIN_impSYSTEM_CLOCK:
5497 case FFEINTRIN_impSYSTEM_func:
5498 case FFEINTRIN_impTIME8:
5499 case FFEINTRIN_impTIME_unix:
5500 case FFEINTRIN_impTIME_vxt:
5501 case FFEINTRIN_impUMASK_func:
5502 case FFEINTRIN_impUNLINK_func:
5505 case FFEINTRIN_impCTIME_func: /* CHARACTER functions not handled here. */
5506 case FFEINTRIN_impFDATE_func: /* CHARACTER functions not handled here. */
5507 case FFEINTRIN_impTTYNAM_func: /* CHARACTER functions not handled here. */
5508 case FFEINTRIN_impNONE:
5509 case FFEINTRIN_imp: /* Hush up gcc warning. */
5510 fprintf (stderr, "No %s implementation.\n",
5511 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5512 assert ("unimplemented intrinsic" == NULL);
5513 return error_mark_node;
5516 assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5518 expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5519 ffebld_right (expr));
5521 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5522 (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5524 expr_tree, dest_tree, dest, dest_used,
5526 ffebld_nonter_hook (expr));
5528 /* See bottom of this file for f2c transforms used to determine
5529 many of the above implementations. The info seems to confuse
5530 Emacs's C mode indentation, which is why it's been moved to
5531 the bottom of this source file. */
5535 /* For power (exponentiation) where right-hand operand is type INTEGER,
5536 generate in-line code to do it the fast way (which, if the operand
5537 is a constant, might just mean a series of multiplies). */
5539 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5541 ffecom_expr_power_integer_ (ffebld expr)
5543 tree l = ffecom_expr (ffebld_left (expr));
5544 tree r = ffecom_expr (ffebld_right (expr));
5545 tree ltype = TREE_TYPE (l);
5546 tree rtype = TREE_TYPE (r);
5547 tree result = NULL_TREE;
5549 if (l == error_mark_node
5550 || r == error_mark_node)
5551 return error_mark_node;
5553 if (TREE_CODE (r) == INTEGER_CST)
5555 int sgn = tree_int_cst_sgn (r);
5558 return convert (ltype, integer_one_node);
5560 if ((TREE_CODE (ltype) == INTEGER_TYPE)
5563 /* Reciprocal of integer is either 0, -1, or 1, so after
5564 calculating that (which we leave to the back end to do
5565 or not do optimally), don't bother with any multiplying. */
5567 result = ffecom_tree_divide_ (ltype,
5568 convert (ltype, integer_one_node),
5570 NULL_TREE, NULL, NULL, NULL_TREE);
5571 r = ffecom_1 (NEGATE_EXPR,
5574 if ((TREE_INT_CST_LOW (r) & 1) == 0)
5575 result = ffecom_1 (ABS_EXPR, rtype,
5579 /* Generate appropriate series of multiplies, preceded
5580 by divide if the exponent is negative. */
5586 l = ffecom_tree_divide_ (ltype,
5587 convert (ltype, integer_one_node),
5589 NULL_TREE, NULL, NULL,
5590 ffebld_nonter_hook (expr));
5591 r = ffecom_1 (NEGATE_EXPR, rtype, r);
5592 assert (TREE_CODE (r) == INTEGER_CST);
5594 if (tree_int_cst_sgn (r) < 0)
5595 { /* The "most negative" number. */
5596 r = ffecom_1 (NEGATE_EXPR, rtype,
5597 ffecom_2 (RSHIFT_EXPR, rtype,
5601 l = ffecom_2 (MULT_EXPR, ltype,
5609 if (TREE_INT_CST_LOW (r) & 1)
5611 if (result == NULL_TREE)
5614 result = ffecom_2 (MULT_EXPR, ltype,
5619 r = ffecom_2 (RSHIFT_EXPR, rtype,
5622 if (integer_zerop (r))
5624 assert (TREE_CODE (r) == INTEGER_CST);
5627 l = ffecom_2 (MULT_EXPR, ltype,
5634 /* Though rhs isn't a constant, in-line code cannot be expanded
5635 while transforming dummies
5636 because the back end cannot be easily convinced to generate
5637 stores (MODIFY_EXPR), handle temporaries, and so on before
5638 all the appropriate rtx's have been generated for things like
5639 dummy args referenced in rhs -- which doesn't happen until
5640 store_parm_decls() is called (expand_function_start, I believe,
5641 does the actual rtx-stuffing of PARM_DECLs).
5643 So, in this case, let the caller generate the call to the
5644 run-time-library function to evaluate the power for us. */
5646 if (ffecom_transform_only_dummies_)
5649 /* Right-hand operand not a constant, expand in-line code to figure
5650 out how to do the multiplies, &c.
5652 The returned expression is expressed this way in GNU C, where l and
5655 ({ typeof (r) rtmp = r;
5656 typeof (l) ltmp = l;
5663 if ((basetypeof (l) == basetypeof (int))
5666 result = ((typeof (l)) 1) / ltmp;
5667 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5673 if ((basetypeof (l) != basetypeof (int))
5676 ltmp = ((typeof (l)) 1) / ltmp;
5680 rtmp = -(rtmp >> 1);
5688 if ((rtmp >>= 1) == 0)
5697 Note that some of the above is compile-time collapsable, such as
5698 the first part of the if statements that checks the base type of
5699 l against int. The if statements are phrased that way to suggest
5700 an easy way to generate the if/else constructs here, knowing that
5701 the back end should (and probably does) eliminate the resulting
5702 dead code (either the int case or the non-int case), something
5703 it couldn't do without the redundant phrasing, requiring explicit
5704 dead-code elimination here, which would be kind of difficult to
5711 tree basetypeof_l_is_int;
5716 = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5718 se = expand_start_stmt_expr ();
5720 ffecom_start_compstmt ();
5723 rtmp = ffecom_make_tempvar ("power_r", rtype,
5724 FFETARGET_charactersizeNONE, -1);
5725 ltmp = ffecom_make_tempvar ("power_l", ltype,
5726 FFETARGET_charactersizeNONE, -1);
5727 result = ffecom_make_tempvar ("power_res", ltype,
5728 FFETARGET_charactersizeNONE, -1);
5729 if (TREE_CODE (ltype) == COMPLEX_TYPE
5730 || TREE_CODE (ltype) == RECORD_TYPE)
5731 divide = ffecom_make_tempvar ("power_div", ltype,
5732 FFETARGET_charactersizeNONE, -1);
5739 hook = ffebld_nonter_hook (expr);
5741 assert (TREE_CODE (hook) == TREE_VEC);
5742 assert (TREE_VEC_LENGTH (hook) == 4);
5743 rtmp = TREE_VEC_ELT (hook, 0);
5744 ltmp = TREE_VEC_ELT (hook, 1);
5745 result = TREE_VEC_ELT (hook, 2);
5746 divide = TREE_VEC_ELT (hook, 3);
5747 if (TREE_CODE (ltype) == COMPLEX_TYPE
5748 || TREE_CODE (ltype) == RECORD_TYPE)
5755 expand_expr_stmt (ffecom_modify (void_type_node,
5758 expand_expr_stmt (ffecom_modify (void_type_node,
5761 expand_start_cond (ffecom_truth_value
5762 (ffecom_2 (EQ_EXPR, integer_type_node,
5764 convert (rtype, integer_zero_node))),
5766 expand_expr_stmt (ffecom_modify (void_type_node,
5768 convert (ltype, integer_one_node)));
5769 expand_start_else ();
5770 if (! integer_zerop (basetypeof_l_is_int))
5772 expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5775 integer_zero_node)),
5777 expand_expr_stmt (ffecom_modify (void_type_node,
5781 convert (ltype, integer_one_node),
5783 NULL_TREE, NULL, NULL,
5785 expand_start_cond (ffecom_truth_value
5786 (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5787 ffecom_2 (LT_EXPR, integer_type_node,
5790 integer_zero_node)),
5791 ffecom_2 (EQ_EXPR, integer_type_node,
5792 ffecom_2 (BIT_AND_EXPR,
5794 ffecom_1 (NEGATE_EXPR,
5800 integer_zero_node)))),
5802 expand_expr_stmt (ffecom_modify (void_type_node,
5804 ffecom_1 (NEGATE_EXPR,
5808 expand_start_else ();
5810 expand_expr_stmt (ffecom_modify (void_type_node,
5812 convert (ltype, integer_one_node)));
5813 expand_start_cond (ffecom_truth_value
5814 (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5815 ffecom_truth_value_invert
5816 (basetypeof_l_is_int),
5817 ffecom_2 (LT_EXPR, integer_type_node,
5820 integer_zero_node)))),
5822 expand_expr_stmt (ffecom_modify (void_type_node,
5826 convert (ltype, integer_one_node),
5828 NULL_TREE, NULL, NULL,
5830 expand_expr_stmt (ffecom_modify (void_type_node,
5832 ffecom_1 (NEGATE_EXPR, rtype,
5834 expand_start_cond (ffecom_truth_value
5835 (ffecom_2 (LT_EXPR, integer_type_node,
5837 convert (rtype, integer_zero_node))),
5839 expand_expr_stmt (ffecom_modify (void_type_node,
5841 ffecom_1 (NEGATE_EXPR, rtype,
5842 ffecom_2 (RSHIFT_EXPR,
5845 integer_one_node))));
5846 expand_expr_stmt (ffecom_modify (void_type_node,
5848 ffecom_2 (MULT_EXPR, ltype,
5853 expand_start_loop (1);
5854 expand_start_cond (ffecom_truth_value
5855 (ffecom_2 (BIT_AND_EXPR, rtype,
5857 convert (rtype, integer_one_node))),
5859 expand_expr_stmt (ffecom_modify (void_type_node,
5861 ffecom_2 (MULT_EXPR, ltype,
5865 expand_exit_loop_if_false (NULL,
5867 (ffecom_modify (rtype,
5869 ffecom_2 (RSHIFT_EXPR,
5872 integer_one_node))));
5873 expand_expr_stmt (ffecom_modify (void_type_node,
5875 ffecom_2 (MULT_EXPR, ltype,
5880 if (!integer_zerop (basetypeof_l_is_int))
5882 expand_expr_stmt (result);
5884 t = ffecom_end_compstmt ();
5886 result = expand_end_stmt_expr (se);
5888 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5890 if (TREE_CODE (t) == BLOCK)
5892 /* Make a BIND_EXPR for the BLOCK already made. */
5893 result = build (BIND_EXPR, TREE_TYPE (result),
5894 NULL_TREE, result, t);
5895 /* Remove the block from the tree at this point.
5896 It gets put back at the proper place
5897 when the BIND_EXPR is expanded. */
5908 /* ffecom_expr_transform_ -- Transform symbols in expr
5910 ffebld expr; // FFE expression.
5911 ffecom_expr_transform_ (expr);
5913 Recursive descent on expr while transforming any untransformed SYMTERs. */
5915 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5917 ffecom_expr_transform_ (ffebld expr)
5922 tail_recurse: /* :::::::::::::::::::: */
5927 switch (ffebld_op (expr))
5929 case FFEBLD_opSYMTER:
5930 s = ffebld_symter (expr);
5931 t = ffesymbol_hook (s).decl_tree;
5932 if ((t == NULL_TREE)
5933 && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5934 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5935 && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5937 s = ffecom_sym_transform_ (s);
5938 t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy,
5941 break; /* Ok if (t == NULL) here. */
5944 ffecom_expr_transform_ (ffebld_head (expr));
5945 expr = ffebld_trail (expr);
5946 goto tail_recurse; /* :::::::::::::::::::: */
5952 switch (ffebld_arity (expr))
5955 ffecom_expr_transform_ (ffebld_left (expr));
5956 expr = ffebld_right (expr);
5957 goto tail_recurse; /* :::::::::::::::::::: */
5960 expr = ffebld_left (expr);
5961 goto tail_recurse; /* :::::::::::::::::::: */
5971 /* Make a type based on info in live f2c.h file. */
5973 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5975 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5979 case FFECOM_f2ccodeCHAR:
5980 *type = make_signed_type (CHAR_TYPE_SIZE);
5983 case FFECOM_f2ccodeSHORT:
5984 *type = make_signed_type (SHORT_TYPE_SIZE);
5987 case FFECOM_f2ccodeINT:
5988 *type = make_signed_type (INT_TYPE_SIZE);
5991 case FFECOM_f2ccodeLONG:
5992 *type = make_signed_type (LONG_TYPE_SIZE);
5995 case FFECOM_f2ccodeLONGLONG:
5996 *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5999 case FFECOM_f2ccodeCHARPTR:
6000 *type = build_pointer_type (DEFAULT_SIGNED_CHAR
6001 ? signed_char_type_node
6002 : unsigned_char_type_node);
6005 case FFECOM_f2ccodeFLOAT:
6006 *type = make_node (REAL_TYPE);
6007 TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
6008 layout_type (*type);
6011 case FFECOM_f2ccodeDOUBLE:
6012 *type = make_node (REAL_TYPE);
6013 TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
6014 layout_type (*type);
6017 case FFECOM_f2ccodeLONGDOUBLE:
6018 *type = make_node (REAL_TYPE);
6019 TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
6020 layout_type (*type);
6023 case FFECOM_f2ccodeTWOREALS:
6024 *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
6027 case FFECOM_f2ccodeTWODOUBLEREALS:
6028 *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
6032 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
6033 *type = error_mark_node;
6037 pushdecl (build_decl (TYPE_DECL,
6038 ffecom_get_invented_identifier ("__g77_f2c_%s", name),
6043 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6044 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6048 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
6054 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
6055 if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
6056 && compare_tree_int (TYPE_SIZE (t), size) == 0)
6058 assert (code != -1);
6059 ffecom_f2c_typecode_[bt][j] = code;
6065 /* Finish up globals after doing all program units in file
6067 Need to handle only uninitialized COMMON areas. */
6069 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6071 ffecom_finish_global_ (ffeglobal global)
6077 if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
6080 if (ffeglobal_common_init (global))
6083 cbt = ffeglobal_hook (global);
6084 if ((cbt == NULL_TREE)
6085 || !ffeglobal_common_have_size (global))
6086 return global; /* No need to make common, never ref'd. */
6088 DECL_EXTERNAL (cbt) = 0;
6090 /* Give the array a size now. */
6092 size = build_int_2 ((ffeglobal_common_size (global)
6093 + ffeglobal_common_pad (global)) - 1,
6096 cbtype = TREE_TYPE (cbt);
6097 TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6100 if (!TREE_TYPE (size))
6101 TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6102 layout_type (cbtype);
6104 cbt = start_decl (cbt, FALSE);
6105 assert (cbt == ffeglobal_hook (global));
6107 finish_decl (cbt, NULL_TREE, FALSE);
6113 /* Finish up any untransformed symbols. */
6115 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6117 ffecom_finish_symbol_transform_ (ffesymbol s)
6119 if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6122 /* It's easy to know to transform an untransformed symbol, to make sure
6123 we put out debugging info for it. But COMMON variables, unlike
6124 EQUIVALENCE ones, aren't given declarations in addition to the
6125 tree expressions that specify offsets, because COMMON variables
6126 can be referenced in the outer scope where only dummy arguments
6127 (PARM_DECLs) should really be seen. To be safe, just don't do any
6128 VAR_DECLs for COMMON variables when we transform them for real
6129 use, and therefore we do all the VAR_DECL creating here. */
6131 if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6133 if (ffesymbol_kind (s) != FFEINFO_kindNONE
6134 || (ffesymbol_where (s) != FFEINFO_whereNONE
6135 && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6136 && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6137 /* Not transformed, and not CHARACTER*(*), and not a dummy
6138 argument, which can happen only if the entry point names
6139 it "rides in on" are all invalidated for other reasons. */
6140 s = ffecom_sym_transform_ (s);
6143 if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6144 && (ffesymbol_hook (s).decl_tree != error_mark_node))
6146 /* This isn't working, at least for dbxout. The .s file looks
6147 okay to me (burley), but in gdb 4.9 at least, the variables
6148 appear to reside somewhere outside of the common area, so
6149 it doesn't make sense to mislead anyone by generating the info
6150 on those variables until this is fixed. NOTE: Same problem
6151 with EQUIVALENCE, sadly...see similar #if later. */
6152 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6153 ffesymbol_storage (s));
6160 /* Append underscore(s) to name before calling get_identifier. "us"
6161 is nonzero if the name already contains an underscore and thus
6162 needs two underscores appended. */
6164 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6166 ffecom_get_appended_identifier_ (char us, const char *name)
6172 newname = xmalloc ((i = strlen (name)) + 1
6173 + ffe_is_underscoring ()
6175 memcpy (newname, name, i);
6177 newname[i + us] = '_';
6178 newname[i + 1 + us] = '\0';
6179 id = get_identifier (newname);
6187 /* Decide whether to append underscore to name before calling
6190 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6192 ffecom_get_external_identifier_ (ffesymbol s)
6195 const char *name = ffesymbol_text (s);
6197 /* If name is a built-in name, just return it as is. */
6199 if (!ffe_is_underscoring ()
6200 || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6201 #if FFETARGET_isENFORCED_MAIN_NAME
6202 || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6204 || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6206 || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6207 return get_identifier (name);
6209 us = ffe_is_second_underscore ()
6210 ? (strchr (name, '_') != NULL)
6213 return ffecom_get_appended_identifier_ (us, name);
6217 /* Decide whether to append underscore to internal name before calling
6220 This is for non-external, top-function-context names only. Transform
6221 identifier so it doesn't conflict with the transformed result
6222 of using a _different_ external name. E.g. if "CALL FOO" is
6223 transformed into "FOO_();", then the variable in "FOO_ = 3"
6224 must be transformed into something that does not conflict, since
6225 these two things should be independent.
6227 The transformation is as follows. If the name does not contain
6228 an underscore, there is no possible conflict, so just return.
6229 If the name does contain an underscore, then transform it just
6230 like we transform an external identifier. */
6232 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6234 ffecom_get_identifier_ (const char *name)
6236 /* If name does not contain an underscore, just return it as is. */
6238 if (!ffe_is_underscoring ()
6239 || (strchr (name, '_') == NULL))
6240 return get_identifier (name);
6242 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6247 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6250 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6251 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6252 ffesymbol_kindtype(s));
6254 Call after setting up containing function and getting trees for all
6257 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6259 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6261 ffebld expr = ffesymbol_sfexpr (s);
6265 bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6266 static bool recurse = FALSE;
6267 int old_lineno = lineno;
6268 const char *old_input_filename = input_filename;
6270 ffecom_nested_entry_ = s;
6272 /* For now, we don't have a handy pointer to where the sfunc is actually
6273 defined, though that should be easy to add to an ffesymbol. (The
6274 token/where info available might well point to the place where the type
6275 of the sfunc is declared, especially if that precedes the place where
6276 the sfunc itself is defined, which is typically the case.) We should
6277 put out a null pointer rather than point somewhere wrong, but I want to
6278 see how it works at this point. */
6280 input_filename = ffesymbol_where_filename (s);
6281 lineno = ffesymbol_where_filelinenum (s);
6283 /* Pretransform the expression so any newly discovered things belong to the
6284 outer program unit, not to the statement function. */
6286 ffecom_expr_transform_ (expr);
6288 /* Make sure no recursive invocation of this fn (a specific case of failing
6289 to pretransform an sfunc's expression, i.e. where its expression
6290 references another untransformed sfunc) happens. */
6295 push_f_function_context ();
6298 type = void_type_node;
6301 type = ffecom_tree_type[bt][kt];
6302 if (type == NULL_TREE)
6303 type = integer_type_node; /* _sym_exec_transition reports
6307 start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6308 build_function_type (type, NULL_TREE),
6309 1, /* nested/inline */
6310 0); /* TREE_PUBLIC */
6312 /* We don't worry about COMPLEX return values here, because this is
6313 entirely internal to our code, and gcc has the ability to return COMPLEX
6314 directly as a value. */
6317 { /* Prepend arg for where result goes. */
6320 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6322 result = ffecom_get_invented_identifier ("__g77_%s", "result");
6324 ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */
6326 type = build_pointer_type (type);
6327 result = build_decl (PARM_DECL, result, type);
6329 push_parm_decl (result);
6332 result = NULL_TREE; /* Not ref'd if !charfunc. */
6334 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6336 store_parm_decls (0);
6338 ffecom_start_compstmt ();
6344 ffetargetCharacterSize sz = ffesymbol_size (s);
6347 result_length = build_int_2 (sz, 0);
6348 TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6350 ffecom_prepare_let_char_ (sz, expr);
6352 ffecom_prepare_end ();
6354 ffecom_let_char_ (result, result_length, sz, expr);
6355 expand_null_return ();
6359 ffecom_prepare_expr (expr);
6361 ffecom_prepare_end ();
6363 expand_return (ffecom_modify (NULL_TREE,
6364 DECL_RESULT (current_function_decl),
6365 ffecom_expr (expr)));
6369 ffecom_end_compstmt ();
6371 func = current_function_decl;
6372 finish_function (1);
6374 pop_f_function_context ();
6378 lineno = old_lineno;
6379 input_filename = old_input_filename;
6381 ffecom_nested_entry_ = NULL;
6388 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6390 ffecom_gfrt_args_ (ffecomGfrt ix)
6392 return ffecom_gfrt_argstring_[ix];
6396 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6398 ffecom_gfrt_tree_ (ffecomGfrt ix)
6400 if (ffecom_gfrt_[ix] == NULL_TREE)
6401 ffecom_make_gfrt_ (ix);
6403 return ffecom_1 (ADDR_EXPR,
6404 build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6409 /* Return initialize-to-zero expression for this VAR_DECL. */
6411 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6412 /* A somewhat evil way to prevent the garbage collector
6413 from collecting 'tree' structures. */
6414 #define NUM_TRACKED_CHUNK 63
6415 static struct tree_ggc_tracker
6417 struct tree_ggc_tracker *next;
6418 tree trees[NUM_TRACKED_CHUNK];
6419 } *tracker_head = NULL;
6422 mark_tracker_head (void *arg)
6424 struct tree_ggc_tracker *head;
6427 for (head = * (struct tree_ggc_tracker **) arg;
6432 for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6433 ggc_mark_tree (head->trees[i]);
6438 ffecom_save_tree_forever (tree t)
6441 if (tracker_head != NULL)
6442 for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6443 if (tracker_head->trees[i] == NULL)
6445 tracker_head->trees[i] = t;
6450 /* Need to allocate a new block. */
6451 struct tree_ggc_tracker *old_head = tracker_head;
6453 tracker_head = ggc_alloc (sizeof (*tracker_head));
6454 tracker_head->next = old_head;
6455 tracker_head->trees[0] = t;
6456 for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6457 tracker_head->trees[i] = NULL;
6462 ffecom_init_zero_ (tree decl)
6465 int incremental = TREE_STATIC (decl);
6466 tree type = TREE_TYPE (decl);
6470 make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
6471 assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6474 if ((TREE_CODE (type) != ARRAY_TYPE)
6475 && (TREE_CODE (type) != RECORD_TYPE)
6476 && (TREE_CODE (type) != UNION_TYPE)
6478 init = convert (type, integer_zero_node);
6479 else if (!incremental)
6481 init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6482 TREE_CONSTANT (init) = 1;
6483 TREE_STATIC (init) = 1;
6487 assemble_zeros (int_size_in_bytes (type));
6488 init = error_mark_node;
6495 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6497 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6503 switch (ffebld_op (arg))
6505 case FFEBLD_opCONTER: /* For F90, check 0-length. */
6506 if (ffetarget_length_character1
6507 (ffebld_constant_character1
6508 (ffebld_conter (arg))) == 0)
6510 *maybe_tree = integer_zero_node;
6511 return convert (tree_type, integer_zero_node);
6514 *maybe_tree = integer_one_node;
6515 expr_tree = build_int_2 (*ffetarget_text_character1
6516 (ffebld_constant_character1
6517 (ffebld_conter (arg))),
6519 TREE_TYPE (expr_tree) = tree_type;
6522 case FFEBLD_opSYMTER:
6523 case FFEBLD_opARRAYREF:
6524 case FFEBLD_opFUNCREF:
6525 case FFEBLD_opSUBSTR:
6526 ffecom_char_args_ (&expr_tree, &length_tree, arg);
6528 if ((expr_tree == error_mark_node)
6529 || (length_tree == error_mark_node))
6531 *maybe_tree = error_mark_node;
6532 return error_mark_node;
6535 if (integer_zerop (length_tree))
6537 *maybe_tree = integer_zero_node;
6538 return convert (tree_type, integer_zero_node);
6542 = ffecom_1 (INDIRECT_REF,
6543 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6546 = ffecom_2 (ARRAY_REF,
6547 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6550 expr_tree = convert (tree_type, expr_tree);
6552 if (TREE_CODE (length_tree) == INTEGER_CST)
6553 *maybe_tree = integer_one_node;
6554 else /* Must check length at run time. */
6556 = ffecom_truth_value
6557 (ffecom_2 (GT_EXPR, integer_type_node,
6559 ffecom_f2c_ftnlen_zero_node));
6562 case FFEBLD_opPAREN:
6563 case FFEBLD_opCONVERT:
6564 if (ffeinfo_size (ffebld_info (arg)) == 0)
6566 *maybe_tree = integer_zero_node;
6567 return convert (tree_type, integer_zero_node);
6569 return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6572 case FFEBLD_opCONCATENATE:
6579 expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6581 expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6583 *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6586 expr_tree = ffecom_3 (COND_EXPR, tree_type,
6594 assert ("bad op in ICHAR" == NULL);
6595 return error_mark_node;
6600 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6604 length_arg = ffecom_intrinsic_len_ (expr);
6606 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6607 subexpressions by constructing the appropriate tree for the
6608 length-of-character-text argument in a calling sequence. */
6610 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6612 ffecom_intrinsic_len_ (ffebld expr)
6614 ffetargetCharacter1 val;
6617 switch (ffebld_op (expr))
6619 case FFEBLD_opCONTER:
6620 val = ffebld_constant_character1 (ffebld_conter (expr));
6621 length = build_int_2 (ffetarget_length_character1 (val), 0);
6622 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6625 case FFEBLD_opSYMTER:
6627 ffesymbol s = ffebld_symter (expr);
6630 item = ffesymbol_hook (s).decl_tree;
6631 if (item == NULL_TREE)
6633 s = ffecom_sym_transform_ (s);
6634 item = ffesymbol_hook (s).decl_tree;
6636 if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6638 if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6639 length = ffesymbol_hook (s).length_tree;
6642 length = build_int_2 (ffesymbol_size (s), 0);
6643 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6646 else if (item == error_mark_node)
6647 length = error_mark_node;
6648 else /* FFEINFO_kindFUNCTION: */
6653 case FFEBLD_opARRAYREF:
6654 length = ffecom_intrinsic_len_ (ffebld_left (expr));
6657 case FFEBLD_opSUBSTR:
6661 ffebld thing = ffebld_right (expr);
6665 assert (ffebld_op (thing) == FFEBLD_opITEM);
6666 start = ffebld_head (thing);
6667 thing = ffebld_trail (thing);
6668 assert (ffebld_trail (thing) == NULL);
6669 end = ffebld_head (thing);
6671 length = ffecom_intrinsic_len_ (ffebld_left (expr));
6673 if (length == error_mark_node)
6682 length = convert (ffecom_f2c_ftnlen_type_node,
6688 start_tree = convert (ffecom_f2c_ftnlen_type_node,
6689 ffecom_expr (start));
6691 if (start_tree == error_mark_node)
6693 length = error_mark_node;
6699 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6700 ffecom_f2c_ftnlen_one_node,
6701 ffecom_2 (MINUS_EXPR,
6702 ffecom_f2c_ftnlen_type_node,
6708 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6711 if (end_tree == error_mark_node)
6713 length = error_mark_node;
6717 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6718 ffecom_f2c_ftnlen_one_node,
6719 ffecom_2 (MINUS_EXPR,
6720 ffecom_f2c_ftnlen_type_node,
6721 end_tree, start_tree));
6727 case FFEBLD_opCONCATENATE:
6729 = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6730 ffecom_intrinsic_len_ (ffebld_left (expr)),
6731 ffecom_intrinsic_len_ (ffebld_right (expr)));
6734 case FFEBLD_opFUNCREF:
6735 case FFEBLD_opCONVERT:
6736 length = build_int_2 (ffebld_size (expr), 0);
6737 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6741 assert ("bad op for single char arg expr" == NULL);
6742 length = ffecom_f2c_ftnlen_zero_node;
6746 assert (length != NULL_TREE);
6752 /* Handle CHARACTER assignments.
6754 Generates code to do the assignment. Used by ordinary assignment
6755 statement handler ffecom_let_stmt and by statement-function
6756 handler to generate code for a statement function. */
6758 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6760 ffecom_let_char_ (tree dest_tree, tree dest_length,
6761 ffetargetCharacterSize dest_size, ffebld source)
6763 ffecomConcatList_ catlist;
6768 if ((dest_tree == error_mark_node)
6769 || (dest_length == error_mark_node))
6772 assert (dest_tree != NULL_TREE);
6773 assert (dest_length != NULL_TREE);
6775 /* Source might be an opCONVERT, which just means it is a different size
6776 than the destination. Since the underlying implementation here handles
6777 that (directly or via the s_copy or s_cat run-time-library functions),
6778 we don't need the "convenience" of an opCONVERT that tells us to
6779 truncate or blank-pad, particularly since the resulting implementation
6780 would probably be slower than otherwise. */
6782 while (ffebld_op (source) == FFEBLD_opCONVERT)
6783 source = ffebld_left (source);
6785 catlist = ffecom_concat_list_new_ (source, dest_size);
6786 switch (ffecom_concat_list_count_ (catlist))
6788 case 0: /* Shouldn't happen, but in case it does... */
6789 ffecom_concat_list_kill_ (catlist);
6790 source_tree = null_pointer_node;
6791 source_length = ffecom_f2c_ftnlen_zero_node;
6792 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6793 TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6794 TREE_CHAIN (TREE_CHAIN (expr_tree))
6795 = build_tree_list (NULL_TREE, dest_length);
6796 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6797 = build_tree_list (NULL_TREE, source_length);
6799 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6800 TREE_SIDE_EFFECTS (expr_tree) = 1;
6802 expand_expr_stmt (expr_tree);
6806 case 1: /* The (fairly) easy case. */
6807 ffecom_char_args_ (&source_tree, &source_length,
6808 ffecom_concat_list_expr_ (catlist, 0));
6809 ffecom_concat_list_kill_ (catlist);
6810 assert (source_tree != NULL_TREE);
6811 assert (source_length != NULL_TREE);
6813 if ((source_tree == error_mark_node)
6814 || (source_length == error_mark_node))
6820 = ffecom_1 (INDIRECT_REF,
6821 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6825 = ffecom_2 (ARRAY_REF,
6826 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6831 = ffecom_1 (INDIRECT_REF,
6832 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6836 = ffecom_2 (ARRAY_REF,
6837 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6842 expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6844 expand_expr_stmt (expr_tree);
6849 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6850 TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6851 TREE_CHAIN (TREE_CHAIN (expr_tree))
6852 = build_tree_list (NULL_TREE, dest_length);
6853 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6854 = build_tree_list (NULL_TREE, source_length);
6856 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6857 TREE_SIDE_EFFECTS (expr_tree) = 1;
6859 expand_expr_stmt (expr_tree);
6863 default: /* Must actually concatenate things. */
6867 /* Heavy-duty concatenation. */
6870 int count = ffecom_concat_list_count_ (catlist);
6882 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6883 FFETARGET_charactersizeNONE, count, TRUE);
6884 item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6885 FFETARGET_charactersizeNONE,
6891 hook = ffebld_nonter_hook (source);
6893 assert (TREE_CODE (hook) == TREE_VEC);
6894 assert (TREE_VEC_LENGTH (hook) == 2);
6895 length_array = lengths = TREE_VEC_ELT (hook, 0);
6896 item_array = items = TREE_VEC_ELT (hook, 1);
6900 for (i = 0; i < count; ++i)
6902 ffecom_char_args_ (&citem, &clength,
6903 ffecom_concat_list_expr_ (catlist, i));
6904 if ((citem == error_mark_node)
6905 || (clength == error_mark_node))
6907 ffecom_concat_list_kill_ (catlist);
6912 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6913 ffecom_modify (void_type_node,
6914 ffecom_2 (ARRAY_REF,
6915 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6917 build_int_2 (i, 0)),
6921 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6922 ffecom_modify (void_type_node,
6923 ffecom_2 (ARRAY_REF,
6924 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6926 build_int_2 (i, 0)),
6931 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6932 TREE_CHAIN (expr_tree)
6933 = build_tree_list (NULL_TREE,
6934 ffecom_1 (ADDR_EXPR,
6935 build_pointer_type (TREE_TYPE (items)),
6937 TREE_CHAIN (TREE_CHAIN (expr_tree))
6938 = build_tree_list (NULL_TREE,
6939 ffecom_1 (ADDR_EXPR,
6940 build_pointer_type (TREE_TYPE (lengths)),
6942 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6945 ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6946 convert (ffecom_f2c_ftnlen_type_node,
6947 build_int_2 (count, 0))));
6948 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6949 = build_tree_list (NULL_TREE, dest_length);
6951 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6952 TREE_SIDE_EFFECTS (expr_tree) = 1;
6954 expand_expr_stmt (expr_tree);
6957 ffecom_concat_list_kill_ (catlist);
6961 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6964 ffecom_make_gfrt_(ix);
6966 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6967 for the indicated run-time routine (ix). */
6969 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6971 ffecom_make_gfrt_ (ffecomGfrt ix)
6976 switch (ffecom_gfrt_type_[ix])
6978 case FFECOM_rttypeVOID_:
6979 ttype = void_type_node;
6982 case FFECOM_rttypeVOIDSTAR_:
6983 ttype = TREE_TYPE (null_pointer_node); /* `void *'. */
6986 case FFECOM_rttypeFTNINT_:
6987 ttype = ffecom_f2c_ftnint_type_node;
6990 case FFECOM_rttypeINTEGER_:
6991 ttype = ffecom_f2c_integer_type_node;
6994 case FFECOM_rttypeLONGINT_:
6995 ttype = ffecom_f2c_longint_type_node;
6998 case FFECOM_rttypeLOGICAL_:
6999 ttype = ffecom_f2c_logical_type_node;
7002 case FFECOM_rttypeREAL_F2C_:
7003 ttype = double_type_node;
7006 case FFECOM_rttypeREAL_GNU_:
7007 ttype = float_type_node;
7010 case FFECOM_rttypeCOMPLEX_F2C_:
7011 ttype = void_type_node;
7014 case FFECOM_rttypeCOMPLEX_GNU_:
7015 ttype = ffecom_f2c_complex_type_node;
7018 case FFECOM_rttypeDOUBLE_:
7019 ttype = double_type_node;
7022 case FFECOM_rttypeDOUBLEREAL_:
7023 ttype = ffecom_f2c_doublereal_type_node;
7026 case FFECOM_rttypeDBLCMPLX_F2C_:
7027 ttype = void_type_node;
7030 case FFECOM_rttypeDBLCMPLX_GNU_:
7031 ttype = ffecom_f2c_doublecomplex_type_node;
7034 case FFECOM_rttypeCHARACTER_:
7035 ttype = void_type_node;
7040 assert ("bad rttype" == NULL);
7044 ttype = build_function_type (ttype, NULL_TREE);
7045 t = build_decl (FUNCTION_DECL,
7046 get_identifier (ffecom_gfrt_name_[ix]),
7048 DECL_EXTERNAL (t) = 1;
7049 TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
7050 TREE_PUBLIC (t) = 1;
7051 TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
7053 /* Sanity check: A function that's const cannot be volatile. */
7055 assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
7057 /* Sanity check: A function that's const cannot return complex. */
7059 assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
7061 t = start_decl (t, TRUE);
7063 finish_decl (t, NULL_TREE, TRUE);
7065 ffecom_gfrt_[ix] = t;
7069 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
7071 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7073 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
7075 ffesymbol s = ffestorag_symbol (st);
7077 if (ffesymbol_namelisted (s))
7078 ffecom_member_namelisted_ = TRUE;
7082 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
7083 the member so debugger will see it. Otherwise nobody should be
7084 referencing the member. */
7086 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7088 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7096 || ((mt = ffestorag_hook (mst)) == NULL)
7097 || (mt == error_mark_node))
7101 || ((s = ffestorag_symbol (st)) == NULL))
7104 type = ffecom_type_localvar_ (s,
7105 ffesymbol_basictype (s),
7106 ffesymbol_kindtype (s));
7107 if (type == error_mark_node)
7110 t = build_decl (VAR_DECL,
7111 ffecom_get_identifier_ (ffesymbol_text (s)),
7114 TREE_STATIC (t) = TREE_STATIC (mt);
7115 DECL_INITIAL (t) = NULL_TREE;
7116 TREE_ASM_WRITTEN (t) = 1;
7119 = gen_rtx (MEM, TYPE_MODE (type),
7120 plus_constant (XEXP (DECL_RTL (mt), 0),
7121 ffestorag_modulo (mst)
7122 + ffestorag_offset (st)
7123 - ffestorag_offset (mst)));
7125 t = start_decl (t, FALSE);
7127 finish_decl (t, NULL_TREE, FALSE);
7131 /* Prepare source expression for assignment into a destination perhaps known
7132 to be of a specific size. */
7135 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7137 ffecomConcatList_ catlist;
7142 tree tempvar = NULL_TREE;
7144 while (ffebld_op (source) == FFEBLD_opCONVERT)
7145 source = ffebld_left (source);
7147 catlist = ffecom_concat_list_new_ (source, dest_size);
7148 count = ffecom_concat_list_count_ (catlist);
7153 = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7154 FFETARGET_charactersizeNONE, count);
7156 = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7157 FFETARGET_charactersizeNONE, count);
7159 tempvar = make_tree_vec (2);
7160 TREE_VEC_ELT (tempvar, 0) = ltmp;
7161 TREE_VEC_ELT (tempvar, 1) = itmp;
7164 for (i = 0; i < count; ++i)
7165 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7167 ffecom_concat_list_kill_ (catlist);
7171 ffebld_nonter_set_hook (source, tempvar);
7172 current_binding_level->prep_state = 1;
7176 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7178 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7179 (which generates their trees) and then their trees get push_parm_decl'd.
7181 The second arg is TRUE if the dummies are for a statement function, in
7182 which case lengths are not pushed for character arguments (since they are
7183 always known by both the caller and the callee, though the code allows
7184 for someday permitting CHAR*(*) stmtfunc dummies). */
7186 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7188 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7195 ffecom_transform_only_dummies_ = TRUE;
7197 /* First push the parms corresponding to actual dummy "contents". */
7199 for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7201 dummy = ffebld_head (dumlist);
7202 switch (ffebld_op (dummy))
7206 continue; /* Forget alternate returns. */
7211 assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7212 s = ffebld_symter (dummy);
7213 parm = ffesymbol_hook (s).decl_tree;
7214 if (parm == NULL_TREE)
7216 s = ffecom_sym_transform_ (s);
7217 parm = ffesymbol_hook (s).decl_tree;
7218 assert (parm != NULL_TREE);
7220 if (parm != error_mark_node)
7221 push_parm_decl (parm);
7224 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7226 for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7228 dummy = ffebld_head (dumlist);
7229 switch (ffebld_op (dummy))
7233 continue; /* Forget alternate returns, they mean
7239 s = ffebld_symter (dummy);
7240 if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7241 continue; /* Only looking for CHARACTER arguments. */
7242 if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7243 continue; /* Stmtfunc arg with known size needs no
7245 if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7246 continue; /* Only looking for variables and arrays. */
7247 parm = ffesymbol_hook (s).length_tree;
7248 assert (parm != NULL_TREE);
7249 if (parm != error_mark_node)
7250 push_parm_decl (parm);
7253 ffecom_transform_only_dummies_ = FALSE;
7257 /* ffecom_start_progunit_ -- Beginning of program unit
7259 Does GNU back end stuff necessary to teach it about the start of its
7260 equivalent of a Fortran program unit. */
7262 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7264 ffecom_start_progunit_ ()
7266 ffesymbol fn = ffecom_primary_entry_;
7268 tree id; /* Identifier (name) of function. */
7269 tree type; /* Type of function. */
7270 tree result; /* Result of function. */
7271 ffeinfoBasictype bt;
7275 ffeglobalType egt = FFEGLOBAL_type;
7278 bool altentries = (ffecom_num_entrypoints_ != 0);
7281 && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7282 && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7283 bool main_program = FALSE;
7284 int old_lineno = lineno;
7285 const char *old_input_filename = input_filename;
7287 assert (fn != NULL);
7288 assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7290 input_filename = ffesymbol_where_filename (fn);
7291 lineno = ffesymbol_where_filelinenum (fn);
7293 switch (ffecom_primary_entry_kind_)
7295 case FFEINFO_kindPROGRAM:
7296 main_program = TRUE;
7297 gt = FFEGLOBAL_typeMAIN;
7298 bt = FFEINFO_basictypeNONE;
7299 kt = FFEINFO_kindtypeNONE;
7300 type = ffecom_tree_fun_type_void;
7305 case FFEINFO_kindBLOCKDATA:
7306 gt = FFEGLOBAL_typeBDATA;
7307 bt = FFEINFO_basictypeNONE;
7308 kt = FFEINFO_kindtypeNONE;
7309 type = ffecom_tree_fun_type_void;
7314 case FFEINFO_kindFUNCTION:
7315 gt = FFEGLOBAL_typeFUNC;
7316 egt = FFEGLOBAL_typeEXT;
7317 bt = ffesymbol_basictype (fn);
7318 kt = ffesymbol_kindtype (fn);
7319 if (bt == FFEINFO_basictypeNONE)
7321 ffeimplic_establish_symbol (fn);
7322 if (ffesymbol_funcresult (fn) != NULL)
7323 ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7324 bt = ffesymbol_basictype (fn);
7325 kt = ffesymbol_kindtype (fn);
7329 charfunc = cmplxfunc = FALSE;
7330 else if (bt == FFEINFO_basictypeCHARACTER)
7331 charfunc = TRUE, cmplxfunc = FALSE;
7332 else if ((bt == FFEINFO_basictypeCOMPLEX)
7333 && ffesymbol_is_f2c (fn)
7335 charfunc = FALSE, cmplxfunc = TRUE;
7337 charfunc = cmplxfunc = FALSE;
7339 if (multi || charfunc)
7340 type = ffecom_tree_fun_type_void;
7341 else if (ffesymbol_is_f2c (fn) && !altentries)
7342 type = ffecom_tree_fun_type[bt][kt];
7344 type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7346 if ((type == NULL_TREE)
7347 || (TREE_TYPE (type) == NULL_TREE))
7348 type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
7351 case FFEINFO_kindSUBROUTINE:
7352 gt = FFEGLOBAL_typeSUBR;
7353 egt = FFEGLOBAL_typeEXT;
7354 bt = FFEINFO_basictypeNONE;
7355 kt = FFEINFO_kindtypeNONE;
7356 if (ffecom_is_altreturning_)
7357 type = ffecom_tree_subr_type;
7359 type = ffecom_tree_fun_type_void;
7365 assert ("say what??" == NULL);
7367 case FFEINFO_kindANY:
7368 gt = FFEGLOBAL_typeANY;
7369 bt = FFEINFO_basictypeNONE;
7370 kt = FFEINFO_kindtypeNONE;
7371 type = error_mark_node;
7379 id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7380 ffesymbol_text (fn));
7382 #if FFETARGET_isENFORCED_MAIN
7383 else if (main_program)
7384 id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7387 id = ffecom_get_external_identifier_ (fn);
7391 0, /* nested/inline */
7392 !altentries); /* TREE_PUBLIC */
7394 TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */
7397 && ((g = ffesymbol_global (fn)) != NULL)
7398 && ((ffeglobal_type (g) == gt)
7399 || (ffeglobal_type (g) == egt)))
7401 ffeglobal_set_hook (g, current_function_decl);
7404 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7405 exec-transitioning needs current_function_decl to be filled in. So we
7406 do these things in two phases. */
7409 { /* 1st arg identifies which entrypoint. */
7410 ffecom_which_entrypoint_decl_
7411 = build_decl (PARM_DECL,
7412 ffecom_get_invented_identifier ("__g77_%s",
7413 "which_entrypoint"),
7415 push_parm_decl (ffecom_which_entrypoint_decl_);
7421 { /* Arg for result (return value). */
7426 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7428 type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7430 type = ffecom_multi_type_node_;
7432 result = ffecom_get_invented_identifier ("__g77_%s", "result");
7434 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7437 length = ffecom_char_enhance_arg_ (&type, fn);
7439 length = NULL_TREE; /* Not ref'd if !charfunc. */
7441 type = build_pointer_type (type);
7442 result = build_decl (PARM_DECL, result, type);
7444 push_parm_decl (result);
7446 ffecom_multi_retval_ = result;
7448 ffecom_func_result_ = result;
7452 push_parm_decl (length);
7453 ffecom_func_length_ = length;
7457 if (ffecom_primary_entry_is_proc_)
7460 arglist = ffecom_master_arglist_;
7462 arglist = ffesymbol_dummyargs (fn);
7463 ffecom_push_dummy_decls_ (arglist, FALSE);
7466 if (TREE_CODE (current_function_decl) != ERROR_MARK)
7467 store_parm_decls (main_program ? 1 : 0);
7469 ffecom_start_compstmt ();
7470 /* Disallow temp vars at this level. */
7471 current_binding_level->prep_state = 2;
7473 lineno = old_lineno;
7474 input_filename = old_input_filename;
7476 /* This handles any symbols still untransformed, in case -g specified.
7477 This used to be done in ffecom_finish_progunit, but it turns out to
7478 be necessary to do it here so that statement functions are
7479 expanded before code. But don't bother for BLOCK DATA. */
7481 if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7482 ffesymbol_drive (ffecom_finish_symbol_transform_);
7486 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7489 ffecom_sym_transform_(s);
7491 The ffesymbol_hook info for s is updated with appropriate backend info
7494 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7496 ffecom_sym_transform_ (ffesymbol s)
7498 tree t; /* Transformed thingy. */
7499 tree tlen; /* Length if CHAR*(*). */
7500 bool addr; /* Is t the address of the thingy? */
7501 ffeinfoBasictype bt;
7504 int old_lineno = lineno;
7505 const char *old_input_filename = input_filename;
7507 /* Must ensure special ASSIGN variables are declared at top of outermost
7508 block, else they'll end up in the innermost block when their first
7509 ASSIGN is seen, which leaves them out of scope when they're the
7510 subject of a GOTO or I/O statement.
7512 We make this variable even if -fugly-assign. Just let it go unused,
7513 in case it turns out there are cases where we really want to use this
7514 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7516 if (! ffecom_transform_only_dummies_
7517 && ffesymbol_assigned (s)
7518 && ! ffesymbol_hook (s).assign_tree)
7519 s = ffecom_sym_transform_assign_ (s);
7521 if (ffesymbol_sfdummyparent (s) == NULL)
7523 input_filename = ffesymbol_where_filename (s);
7524 lineno = ffesymbol_where_filelinenum (s);
7528 ffesymbol sf = ffesymbol_sfdummyparent (s);
7530 input_filename = ffesymbol_where_filename (sf);
7531 lineno = ffesymbol_where_filelinenum (sf);
7534 bt = ffeinfo_basictype (ffebld_info (s));
7535 kt = ffeinfo_kindtype (ffebld_info (s));
7541 switch (ffesymbol_kind (s))
7543 case FFEINFO_kindNONE:
7544 switch (ffesymbol_where (s))
7546 case FFEINFO_whereDUMMY: /* Subroutine or function. */
7547 assert (ffecom_transform_only_dummies_);
7549 /* Before 0.4, this could be ENTITY/DUMMY, but see
7550 ffestu_sym_end_transition -- no longer true (in particular, if
7551 it could be an ENTITY, it _will_ be made one, so that
7552 possibility won't come through here). So we never make length
7553 arg for CHARACTER type. */
7555 t = build_decl (PARM_DECL,
7556 ffecom_get_identifier_ (ffesymbol_text (s)),
7557 ffecom_tree_ptr_to_subr_type);
7559 DECL_ARTIFICIAL (t) = 1;
7564 case FFEINFO_whereGLOBAL: /* Subroutine or function. */
7565 assert (!ffecom_transform_only_dummies_);
7567 if (((g = ffesymbol_global (s)) != NULL)
7568 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7569 || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7570 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7571 && (ffeglobal_hook (g) != NULL_TREE)
7572 && ffe_is_globals ())
7574 t = ffeglobal_hook (g);
7578 t = build_decl (FUNCTION_DECL,
7579 ffecom_get_external_identifier_ (s),
7580 ffecom_tree_subr_type); /* Assume subr. */
7581 DECL_EXTERNAL (t) = 1;
7582 TREE_PUBLIC (t) = 1;
7584 t = start_decl (t, FALSE);
7585 finish_decl (t, NULL_TREE, FALSE);
7588 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7589 || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7590 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7591 ffeglobal_set_hook (g, t);
7593 ffecom_save_tree_forever (t);
7598 assert ("NONE where unexpected" == NULL);
7600 case FFEINFO_whereANY:
7605 case FFEINFO_kindENTITY:
7606 switch (ffeinfo_where (ffesymbol_info (s)))
7609 case FFEINFO_whereCONSTANT:
7610 /* ~~Debugging info needed? */
7611 assert (!ffecom_transform_only_dummies_);
7612 t = error_mark_node; /* Shouldn't ever see this in expr. */
7615 case FFEINFO_whereLOCAL:
7616 assert (!ffecom_transform_only_dummies_);
7619 ffestorag st = ffesymbol_storage (s);
7623 && (ffestorag_size (st) == 0))
7625 t = error_mark_node;
7629 type = ffecom_type_localvar_ (s, bt, kt);
7631 if (type == error_mark_node)
7633 t = error_mark_node;
7638 && (ffestorag_parent (st) != NULL))
7639 { /* Child of EQUIVALENCE parent. */
7642 ffetargetOffset offset;
7644 est = ffestorag_parent (st);
7645 ffecom_transform_equiv_ (est);
7647 et = ffestorag_hook (est);
7648 assert (et != NULL_TREE);
7650 if (! TREE_STATIC (et))
7651 put_var_into_stack (et);
7653 offset = ffestorag_modulo (est)
7654 + ffestorag_offset (ffesymbol_storage (s))
7655 - ffestorag_offset (est);
7657 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7659 /* (t_type *) (((char *) &et) + offset) */
7661 t = convert (string_type_node, /* (char *) */
7662 ffecom_1 (ADDR_EXPR,
7663 build_pointer_type (TREE_TYPE (et)),
7665 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7667 build_int_2 (offset, 0));
7668 t = convert (build_pointer_type (type),
7670 TREE_CONSTANT (t) = staticp (et);
7677 bool init = ffesymbol_is_init (s);
7679 t = build_decl (VAR_DECL,
7680 ffecom_get_identifier_ (ffesymbol_text (s)),
7684 || ffesymbol_namelisted (s)
7685 #ifdef FFECOM_sizeMAXSTACKITEM
7687 && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7689 || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7690 && (ffecom_primary_entry_kind_
7691 != FFEINFO_kindBLOCKDATA)
7692 && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7693 TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7695 TREE_STATIC (t) = 0; /* No need to make static. */
7697 if (init || ffe_is_init_local_zero ())
7698 DECL_INITIAL (t) = error_mark_node;
7700 /* Keep -Wunused from complaining about var if it
7701 is used as sfunc arg or DATA implied-DO. */
7702 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7703 DECL_IN_SYSTEM_HEADER (t) = 1;
7705 t = start_decl (t, FALSE);
7709 if (ffesymbol_init (s) != NULL)
7710 initexpr = ffecom_expr (ffesymbol_init (s));
7712 initexpr = ffecom_init_zero_ (t);
7714 else if (ffe_is_init_local_zero ())
7715 initexpr = ffecom_init_zero_ (t);
7717 initexpr = NULL_TREE; /* Not ref'd if !init. */
7719 finish_decl (t, initexpr, FALSE);
7721 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7723 assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7724 assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7725 ffestorag_size (st)));
7731 case FFEINFO_whereRESULT:
7732 assert (!ffecom_transform_only_dummies_);
7734 if (bt == FFEINFO_basictypeCHARACTER)
7735 { /* Result is already in list of dummies, use
7737 t = ffecom_func_result_;
7738 tlen = ffecom_func_length_;
7742 if ((ffecom_num_entrypoints_ == 0)
7743 && (bt == FFEINFO_basictypeCOMPLEX)
7744 && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7745 { /* Result is already in list of dummies, use
7747 t = ffecom_func_result_;
7751 if (ffecom_func_result_ != NULL_TREE)
7753 t = ffecom_func_result_;
7756 if ((ffecom_num_entrypoints_ != 0)
7757 && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7759 assert (ffecom_multi_retval_ != NULL_TREE);
7760 t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7761 ffecom_multi_retval_);
7762 t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7763 t, ffecom_multi_fields_[bt][kt]);
7768 t = build_decl (VAR_DECL,
7769 ffecom_get_identifier_ (ffesymbol_text (s)),
7770 ffecom_tree_type[bt][kt]);
7771 TREE_STATIC (t) = 0; /* Put result on stack. */
7772 t = start_decl (t, FALSE);
7773 finish_decl (t, NULL_TREE, FALSE);
7775 ffecom_func_result_ = t;
7779 case FFEINFO_whereDUMMY:
7787 bool adjustable = FALSE; /* Conditionally adjustable? */
7789 type = ffecom_tree_type[bt][kt];
7790 if (ffesymbol_sfdummyparent (s) != NULL)
7792 if (current_function_decl == ffecom_outer_function_decl_)
7793 { /* Exec transition before sfunc
7794 context; get it later. */
7797 t = ffecom_get_identifier_ (ffesymbol_text
7798 (ffesymbol_sfdummyparent (s)));
7801 t = ffecom_get_identifier_ (ffesymbol_text (s));
7803 assert (ffecom_transform_only_dummies_);
7805 old_sizes = get_pending_sizes ();
7806 put_pending_sizes (old_sizes);
7808 if (bt == FFEINFO_basictypeCHARACTER)
7809 tlen = ffecom_char_enhance_arg_ (&type, s);
7810 type = ffecom_check_size_overflow_ (s, type, TRUE);
7812 for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7814 if (type == error_mark_node)
7817 dim = ffebld_head (dl);
7818 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7819 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7820 low = ffecom_integer_one_node;
7822 low = ffecom_expr (ffebld_left (dim));
7823 assert (ffebld_right (dim) != NULL);
7824 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7825 || ffecom_doing_entry_)
7827 /* Used to just do high=low. But for ffecom_tree_
7828 canonize_ref_, it probably is important to correctly
7829 assess the size. E.g. given COMPLEX C(*),CFUNC and
7830 C(2)=CFUNC(C), overlap can happen, while it can't
7831 for, say, C(1)=CFUNC(C(2)). */
7832 /* Even more recently used to set to INT_MAX, but that
7833 broke when some overflow checking went into the back
7834 end. Now we just leave the upper bound unspecified. */
7838 high = ffecom_expr (ffebld_right (dim));
7840 /* Determine whether array is conditionally adjustable,
7841 to decide whether back-end magic is needed.
7843 Normally the front end uses the back-end function
7844 variable_size to wrap SAVE_EXPR's around expressions
7845 affecting the size/shape of an array so that the
7846 size/shape info doesn't change during execution
7847 of the compiled code even though variables and
7848 functions referenced in those expressions might.
7850 variable_size also makes sure those saved expressions
7851 get evaluated immediately upon entry to the
7852 compiled procedure -- the front end normally doesn't
7853 have to worry about that.
7855 However, there is a problem with this that affects
7856 g77's implementation of entry points, and that is
7857 that it is _not_ true that each invocation of the
7858 compiled procedure is permitted to evaluate
7859 array size/shape info -- because it is possible
7860 that, for some invocations, that info is invalid (in
7861 which case it is "promised" -- i.e. a violation of
7862 the Fortran standard -- that the compiled code
7863 won't reference the array or its size/shape
7864 during that particular invocation).
7866 To phrase this in C terms, consider this gcc function:
7868 void foo (int *n, float (*a)[*n])
7870 // a is "pointer to array ...", fyi.
7873 Suppose that, for some invocations, it is permitted
7874 for a caller of foo to do this:
7878 Now the _written_ code for foo can take such a call
7879 into account by either testing explicitly for whether
7880 (a == NULL) || (n == NULL) -- presumably it is
7881 not permitted to reference *a in various fashions
7882 if (n == NULL) I suppose -- or it can avoid it by
7883 looking at other info (other arguments, static/global
7886 However, this won't work in gcc 2.5.8 because it'll
7887 automatically emit the code to save the "*n"
7888 expression, which'll yield a NULL dereference for
7889 the "foo (NULL, NULL)" call, something the code
7890 for foo cannot prevent.
7892 g77 definitely needs to avoid executing such
7893 code anytime the pointer to the adjustable array
7894 is NULL, because even if its bounds expressions
7895 don't have any references to possible "absent"
7896 variables like "*n" -- say all variable references
7897 are to COMMON variables, i.e. global (though in C,
7898 local static could actually make sense) -- the
7899 expressions could yield other run-time problems
7900 for allowably "dead" values in those variables.
7902 For example, let's consider a more complicated
7908 void foo (float (*a)[i/j])
7913 The above is (essentially) quite valid for Fortran
7914 but, again, for a call like "foo (NULL);", it is
7915 permitted for i and j to be undefined when the
7916 call is made. If j happened to be zero, for
7917 example, emitting the code to evaluate "i/j"
7918 could result in a run-time error.
7920 Offhand, though I don't have my F77 or F90
7921 standards handy, it might even be valid for a
7922 bounds expression to contain a function reference,
7923 in which case I doubt it is permitted for an
7924 implementation to invoke that function in the
7925 Fortran case involved here (invocation of an
7926 alternate ENTRY point that doesn't have the adjustable
7927 array as one of its arguments).
7929 So, the code that the compiler would normally emit
7930 to preevaluate the size/shape info for an
7931 adjustable array _must not_ be executed at run time
7932 in certain cases. Specifically, for Fortran,
7933 the case is when the pointer to the adjustable
7934 array == NULL. (For gnu-ish C, it might be nice
7935 for the source code itself to specify an expression
7936 that, if TRUE, inhibits execution of the code. Or
7937 reverse the sense for elegance.)
7939 (Note that g77 could use a different test than NULL,
7940 actually, since it happens to always pass an
7941 integer to the called function that specifies which
7942 entry point is being invoked. Hmm, this might
7943 solve the next problem.)
7945 One way a user could, I suppose, write "foo" so
7946 it works is to insert COND_EXPR's for the
7947 size/shape info so the dangerous stuff isn't
7948 actually done, as in:
7950 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7955 The next problem is that the front end needs to
7956 be able to tell the back end about the array's
7957 decl _before_ it tells it about the conditional
7958 expression to inhibit evaluation of size/shape info,
7961 To solve this, the front end needs to be able
7962 to give the back end the expression to inhibit
7963 generation of the preevaluation code _after_
7964 it makes the decl for the adjustable array.
7966 Until then, the above example using the COND_EXPR
7967 doesn't pass muster with gcc because the "(a == NULL)"
7968 part has a reference to "a", which is still
7969 undefined at that point.
7971 g77 will therefore use a different mechanism in the
7975 && ((TREE_CODE (low) != INTEGER_CST)
7976 || (high && TREE_CODE (high) != INTEGER_CST)))
7979 #if 0 /* Old approach -- see below. */
7980 if (TREE_CODE (low) != INTEGER_CST)
7981 low = ffecom_3 (COND_EXPR, integer_type_node,
7982 ffecom_adjarray_passed_ (s),
7984 ffecom_integer_zero_node);
7986 if (high && TREE_CODE (high) != INTEGER_CST)
7987 high = ffecom_3 (COND_EXPR, integer_type_node,
7988 ffecom_adjarray_passed_ (s),
7990 ffecom_integer_zero_node);
7993 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7994 probably. Fixes 950302-1.f. */
7996 if (TREE_CODE (low) != INTEGER_CST)
7997 low = variable_size (low);
7999 /* ~~~Similarly, this fixes dumb0.f. The C front end
8000 does this, which is why dumb0.c would work. */
8002 if (high && TREE_CODE (high) != INTEGER_CST)
8003 high = variable_size (high);
8008 build_range_type (ffecom_integer_type_node,
8010 type = ffecom_check_size_overflow_ (s, type, TRUE);
8013 if (type == error_mark_node)
8015 t = error_mark_node;
8019 if ((ffesymbol_sfdummyparent (s) == NULL)
8020 || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
8022 type = build_pointer_type (type);
8026 t = build_decl (PARM_DECL, t, type);
8028 DECL_ARTIFICIAL (t) = 1;
8031 /* If this arg is present in every entry point's list of
8032 dummy args, then we're done. */
8034 if (ffesymbol_numentries (s)
8035 == (ffecom_num_entrypoints_ + 1))
8040 /* If variable_size in stor-layout has been called during
8041 the above, then get_pending_sizes should have the
8042 yet-to-be-evaluated saved expressions pending.
8043 Make the whole lot of them get emitted, conditionally
8044 on whether the array decl ("t" above) is not NULL. */
8047 tree sizes = get_pending_sizes ();
8052 tem = TREE_CHAIN (tem))
8054 tree temv = TREE_VALUE (tem);
8060 = ffecom_2 (COMPOUND_EXPR,
8069 = ffecom_3 (COND_EXPR,
8076 convert (TREE_TYPE (sizes),
8077 integer_zero_node));
8078 sizes = ffecom_save_tree (sizes);
8081 = tree_cons (NULL_TREE, sizes, tem);
8085 put_pending_sizes (sizes);
8091 && (ffesymbol_numentries (s)
8092 != ffecom_num_entrypoints_ + 1))
8094 = ffecom_2 (NE_EXPR, integer_type_node,
8100 && (ffesymbol_numentries (s)
8101 != ffecom_num_entrypoints_ + 1))
8103 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8104 ffebad_here (0, ffesymbol_where_line (s),
8105 ffesymbol_where_column (s));
8106 ffebad_string (ffesymbol_text (s));
8115 case FFEINFO_whereCOMMON:
8120 ffestorag st = ffesymbol_storage (s);
8123 cs = ffesymbol_common (s); /* The COMMON area itself. */
8124 if (st != NULL) /* Else not laid out. */
8126 ffecom_transform_common_ (cs);
8127 st = ffesymbol_storage (s);
8130 type = ffecom_type_localvar_ (s, bt, kt);
8132 cg = ffesymbol_global (cs); /* The global COMMON info. */
8134 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8137 ct = ffeglobal_hook (cg); /* The common area's tree. */
8139 if ((ct == NULL_TREE)
8141 || (type == error_mark_node))
8142 t = error_mark_node;
8145 ffetargetOffset offset;
8148 cst = ffestorag_parent (st);
8149 assert (cst == ffesymbol_storage (cs));
8151 offset = ffestorag_modulo (cst)
8152 + ffestorag_offset (st)
8153 - ffestorag_offset (cst);
8155 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8157 /* (t_type *) (((char *) &ct) + offset) */
8159 t = convert (string_type_node, /* (char *) */
8160 ffecom_1 (ADDR_EXPR,
8161 build_pointer_type (TREE_TYPE (ct)),
8163 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8165 build_int_2 (offset, 0));
8166 t = convert (build_pointer_type (type),
8168 TREE_CONSTANT (t) = 1;
8175 case FFEINFO_whereIMMEDIATE:
8176 case FFEINFO_whereGLOBAL:
8177 case FFEINFO_whereFLEETING:
8178 case FFEINFO_whereFLEETING_CADDR:
8179 case FFEINFO_whereFLEETING_IADDR:
8180 case FFEINFO_whereINTRINSIC:
8181 case FFEINFO_whereCONSTANT_SUBOBJECT:
8183 assert ("ENTITY where unheard of" == NULL);
8185 case FFEINFO_whereANY:
8186 t = error_mark_node;
8191 case FFEINFO_kindFUNCTION:
8192 switch (ffeinfo_where (ffesymbol_info (s)))
8194 case FFEINFO_whereLOCAL: /* Me. */
8195 assert (!ffecom_transform_only_dummies_);
8196 t = current_function_decl;
8199 case FFEINFO_whereGLOBAL:
8200 assert (!ffecom_transform_only_dummies_);
8202 if (((g = ffesymbol_global (s)) != NULL)
8203 && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8204 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8205 && (ffeglobal_hook (g) != NULL_TREE)
8206 && ffe_is_globals ())
8208 t = ffeglobal_hook (g);
8212 if (ffesymbol_is_f2c (s)
8213 && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8214 t = ffecom_tree_fun_type[bt][kt];
8216 t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8218 t = build_decl (FUNCTION_DECL,
8219 ffecom_get_external_identifier_ (s),
8221 DECL_EXTERNAL (t) = 1;
8222 TREE_PUBLIC (t) = 1;
8224 t = start_decl (t, FALSE);
8225 finish_decl (t, NULL_TREE, FALSE);
8228 && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8229 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8230 ffeglobal_set_hook (g, t);
8232 ffecom_save_tree_forever (t);
8236 case FFEINFO_whereDUMMY:
8237 assert (ffecom_transform_only_dummies_);
8239 if (ffesymbol_is_f2c (s)
8240 && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8241 t = ffecom_tree_ptr_to_fun_type[bt][kt];
8243 t = build_pointer_type
8244 (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8246 t = build_decl (PARM_DECL,
8247 ffecom_get_identifier_ (ffesymbol_text (s)),
8250 DECL_ARTIFICIAL (t) = 1;
8255 case FFEINFO_whereCONSTANT: /* Statement function. */
8256 assert (!ffecom_transform_only_dummies_);
8257 t = ffecom_gen_sfuncdef_ (s, bt, kt);
8260 case FFEINFO_whereINTRINSIC:
8261 assert (!ffecom_transform_only_dummies_);
8262 break; /* Let actual references generate their
8266 assert ("FUNCTION where unheard of" == NULL);
8268 case FFEINFO_whereANY:
8269 t = error_mark_node;
8274 case FFEINFO_kindSUBROUTINE:
8275 switch (ffeinfo_where (ffesymbol_info (s)))
8277 case FFEINFO_whereLOCAL: /* Me. */
8278 assert (!ffecom_transform_only_dummies_);
8279 t = current_function_decl;
8282 case FFEINFO_whereGLOBAL:
8283 assert (!ffecom_transform_only_dummies_);
8285 if (((g = ffesymbol_global (s)) != NULL)
8286 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8287 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8288 && (ffeglobal_hook (g) != NULL_TREE)
8289 && ffe_is_globals ())
8291 t = ffeglobal_hook (g);
8295 t = build_decl (FUNCTION_DECL,
8296 ffecom_get_external_identifier_ (s),
8297 ffecom_tree_subr_type);
8298 DECL_EXTERNAL (t) = 1;
8299 TREE_PUBLIC (t) = 1;
8301 t = start_decl (t, FALSE);
8302 finish_decl (t, NULL_TREE, FALSE);
8305 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8306 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8307 ffeglobal_set_hook (g, t);
8309 ffecom_save_tree_forever (t);
8313 case FFEINFO_whereDUMMY:
8314 assert (ffecom_transform_only_dummies_);
8316 t = build_decl (PARM_DECL,
8317 ffecom_get_identifier_ (ffesymbol_text (s)),
8318 ffecom_tree_ptr_to_subr_type);
8320 DECL_ARTIFICIAL (t) = 1;
8325 case FFEINFO_whereINTRINSIC:
8326 assert (!ffecom_transform_only_dummies_);
8327 break; /* Let actual references generate their
8331 assert ("SUBROUTINE where unheard of" == NULL);
8333 case FFEINFO_whereANY:
8334 t = error_mark_node;
8339 case FFEINFO_kindPROGRAM:
8340 switch (ffeinfo_where (ffesymbol_info (s)))
8342 case FFEINFO_whereLOCAL: /* Me. */
8343 assert (!ffecom_transform_only_dummies_);
8344 t = current_function_decl;
8347 case FFEINFO_whereCOMMON:
8348 case FFEINFO_whereDUMMY:
8349 case FFEINFO_whereGLOBAL:
8350 case FFEINFO_whereRESULT:
8351 case FFEINFO_whereFLEETING:
8352 case FFEINFO_whereFLEETING_CADDR:
8353 case FFEINFO_whereFLEETING_IADDR:
8354 case FFEINFO_whereIMMEDIATE:
8355 case FFEINFO_whereINTRINSIC:
8356 case FFEINFO_whereCONSTANT:
8357 case FFEINFO_whereCONSTANT_SUBOBJECT:
8359 assert ("PROGRAM where unheard of" == NULL);
8361 case FFEINFO_whereANY:
8362 t = error_mark_node;
8367 case FFEINFO_kindBLOCKDATA:
8368 switch (ffeinfo_where (ffesymbol_info (s)))
8370 case FFEINFO_whereLOCAL: /* Me. */
8371 assert (!ffecom_transform_only_dummies_);
8372 t = current_function_decl;
8375 case FFEINFO_whereGLOBAL:
8376 assert (!ffecom_transform_only_dummies_);
8378 t = build_decl (FUNCTION_DECL,
8379 ffecom_get_external_identifier_ (s),
8380 ffecom_tree_blockdata_type);
8381 DECL_EXTERNAL (t) = 1;
8382 TREE_PUBLIC (t) = 1;
8384 t = start_decl (t, FALSE);
8385 finish_decl (t, NULL_TREE, FALSE);
8387 ffecom_save_tree_forever (t);
8391 case FFEINFO_whereCOMMON:
8392 case FFEINFO_whereDUMMY:
8393 case FFEINFO_whereRESULT:
8394 case FFEINFO_whereFLEETING:
8395 case FFEINFO_whereFLEETING_CADDR:
8396 case FFEINFO_whereFLEETING_IADDR:
8397 case FFEINFO_whereIMMEDIATE:
8398 case FFEINFO_whereINTRINSIC:
8399 case FFEINFO_whereCONSTANT:
8400 case FFEINFO_whereCONSTANT_SUBOBJECT:
8402 assert ("BLOCKDATA where unheard of" == NULL);
8404 case FFEINFO_whereANY:
8405 t = error_mark_node;
8410 case FFEINFO_kindCOMMON:
8411 switch (ffeinfo_where (ffesymbol_info (s)))
8413 case FFEINFO_whereLOCAL:
8414 assert (!ffecom_transform_only_dummies_);
8415 ffecom_transform_common_ (s);
8418 case FFEINFO_whereNONE:
8419 case FFEINFO_whereCOMMON:
8420 case FFEINFO_whereDUMMY:
8421 case FFEINFO_whereGLOBAL:
8422 case FFEINFO_whereRESULT:
8423 case FFEINFO_whereFLEETING:
8424 case FFEINFO_whereFLEETING_CADDR:
8425 case FFEINFO_whereFLEETING_IADDR:
8426 case FFEINFO_whereIMMEDIATE:
8427 case FFEINFO_whereINTRINSIC:
8428 case FFEINFO_whereCONSTANT:
8429 case FFEINFO_whereCONSTANT_SUBOBJECT:
8431 assert ("COMMON where unheard of" == NULL);
8433 case FFEINFO_whereANY:
8434 t = error_mark_node;
8439 case FFEINFO_kindCONSTRUCT:
8440 switch (ffeinfo_where (ffesymbol_info (s)))
8442 case FFEINFO_whereLOCAL:
8443 assert (!ffecom_transform_only_dummies_);
8446 case FFEINFO_whereNONE:
8447 case FFEINFO_whereCOMMON:
8448 case FFEINFO_whereDUMMY:
8449 case FFEINFO_whereGLOBAL:
8450 case FFEINFO_whereRESULT:
8451 case FFEINFO_whereFLEETING:
8452 case FFEINFO_whereFLEETING_CADDR:
8453 case FFEINFO_whereFLEETING_IADDR:
8454 case FFEINFO_whereIMMEDIATE:
8455 case FFEINFO_whereINTRINSIC:
8456 case FFEINFO_whereCONSTANT:
8457 case FFEINFO_whereCONSTANT_SUBOBJECT:
8459 assert ("CONSTRUCT where unheard of" == NULL);
8461 case FFEINFO_whereANY:
8462 t = error_mark_node;
8467 case FFEINFO_kindNAMELIST:
8468 switch (ffeinfo_where (ffesymbol_info (s)))
8470 case FFEINFO_whereLOCAL:
8471 assert (!ffecom_transform_only_dummies_);
8472 t = ffecom_transform_namelist_ (s);
8475 case FFEINFO_whereNONE:
8476 case FFEINFO_whereCOMMON:
8477 case FFEINFO_whereDUMMY:
8478 case FFEINFO_whereGLOBAL:
8479 case FFEINFO_whereRESULT:
8480 case FFEINFO_whereFLEETING:
8481 case FFEINFO_whereFLEETING_CADDR:
8482 case FFEINFO_whereFLEETING_IADDR:
8483 case FFEINFO_whereIMMEDIATE:
8484 case FFEINFO_whereINTRINSIC:
8485 case FFEINFO_whereCONSTANT:
8486 case FFEINFO_whereCONSTANT_SUBOBJECT:
8488 assert ("NAMELIST where unheard of" == NULL);
8490 case FFEINFO_whereANY:
8491 t = error_mark_node;
8497 assert ("kind unheard of" == NULL);
8499 case FFEINFO_kindANY:
8500 t = error_mark_node;
8504 ffesymbol_hook (s).decl_tree = t;
8505 ffesymbol_hook (s).length_tree = tlen;
8506 ffesymbol_hook (s).addr = addr;
8508 lineno = old_lineno;
8509 input_filename = old_input_filename;
8515 /* Transform into ASSIGNable symbol.
8517 Symbol has already been transformed, but for whatever reason, the
8518 resulting decl_tree has been deemed not usable for an ASSIGN target.
8519 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8520 another local symbol of type void * and stuff that in the assign_tree
8521 argument. The F77/F90 standards allow this implementation. */
8523 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8525 ffecom_sym_transform_assign_ (ffesymbol s)
8527 tree t; /* Transformed thingy. */
8528 int old_lineno = lineno;
8529 const char *old_input_filename = input_filename;
8531 if (ffesymbol_sfdummyparent (s) == NULL)
8533 input_filename = ffesymbol_where_filename (s);
8534 lineno = ffesymbol_where_filelinenum (s);
8538 ffesymbol sf = ffesymbol_sfdummyparent (s);
8540 input_filename = ffesymbol_where_filename (sf);
8541 lineno = ffesymbol_where_filelinenum (sf);
8544 assert (!ffecom_transform_only_dummies_);
8546 t = build_decl (VAR_DECL,
8547 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8548 ffesymbol_text (s)),
8549 TREE_TYPE (null_pointer_node));
8551 switch (ffesymbol_where (s))
8553 case FFEINFO_whereLOCAL:
8554 /* Unlike for regular vars, SAVE status is easy to determine for
8555 ASSIGNed vars, since there's no initialization, there's no
8556 effective storage association (so "SAVE J" does not apply to
8557 K even given "EQUIVALENCE (J,K)"), there's no size issue
8558 to worry about, etc. */
8559 if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8560 && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8561 && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8562 TREE_STATIC (t) = 1; /* SAVEd in proc, make static. */
8564 TREE_STATIC (t) = 0; /* No need to make static. */
8567 case FFEINFO_whereCOMMON:
8568 TREE_STATIC (t) = 1; /* Assume COMMONs always SAVEd. */
8571 case FFEINFO_whereDUMMY:
8572 /* Note that twinning a DUMMY means the caller won't see
8573 the ASSIGNed value. But both F77 and F90 allow implementations
8574 to do this, i.e. disallow Fortran code that would try and
8575 take advantage of actually putting a label into a variable
8576 via a dummy argument (or any other storage association, for
8578 TREE_STATIC (t) = 0;
8582 TREE_STATIC (t) = 0;
8586 t = start_decl (t, FALSE);
8587 finish_decl (t, NULL_TREE, FALSE);
8589 ffesymbol_hook (s).assign_tree = t;
8591 lineno = old_lineno;
8592 input_filename = old_input_filename;
8598 /* Implement COMMON area in back end.
8600 Because COMMON-based variables can be referenced in the dimension
8601 expressions of dummy (adjustable) arrays, and because dummies
8602 (in the gcc back end) need to be put in the outer binding level
8603 of a function (which has two binding levels, the outer holding
8604 the dummies and the inner holding the other vars), special care
8605 must be taken to handle COMMON areas.
8607 The current strategy is basically to always tell the back end about
8608 the COMMON area as a top-level external reference to just a block
8609 of storage of the master type of that area (e.g. integer, real,
8610 character, whatever -- not a structure). As a distinct action,
8611 if initial values are provided, tell the back end about the area
8612 as a top-level non-external (initialized) area and remember not to
8613 allow further initialization or expansion of the area. Meanwhile,
8614 if no initialization happens at all, tell the back end about
8615 the largest size we've seen declared so the space does get reserved.
8616 (This function doesn't handle all that stuff, but it does some
8617 of the important things.)
8619 Meanwhile, for COMMON variables themselves, just keep creating
8620 references like *((float *) (&common_area + offset)) each time
8621 we reference the variable. In other words, don't make a VAR_DECL
8622 or any kind of component reference (like we used to do before 0.4),
8623 though we might do that as well just for debugging purposes (and
8624 stuff the rtl with the appropriate offset expression). */
8626 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8628 ffecom_transform_common_ (ffesymbol s)
8630 ffestorag st = ffesymbol_storage (s);
8631 ffeglobal g = ffesymbol_global (s);
8636 bool is_init = ffestorag_is_init (st);
8638 assert (st != NULL);
8641 || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8644 /* First update the size of the area in global terms. */
8646 ffeglobal_size_common (s, ffestorag_size (st));
8648 if (!ffeglobal_common_init (g))
8649 is_init = FALSE; /* No explicit init, don't let erroneous joins init. */
8651 cbt = ffeglobal_hook (g);
8653 /* If we already have declared this common block for a previous program
8654 unit, and either we already initialized it or we don't have new
8655 initialization for it, just return what we have without changing it. */
8657 if ((cbt != NULL_TREE)
8659 || !DECL_EXTERNAL (cbt)))
8661 if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8665 /* Process inits. */
8669 if (ffestorag_init (st) != NULL)
8673 /* Set the padding for the expression, so ffecom_expr
8674 knows to insert that many zeros. */
8675 switch (ffebld_op (sexp = ffestorag_init (st)))
8677 case FFEBLD_opCONTER:
8678 ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8681 case FFEBLD_opARRTER:
8682 ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8685 case FFEBLD_opACCTER:
8686 ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8690 assert ("bad op for cmn init (pad)" == NULL);
8694 init = ffecom_expr (sexp);
8695 if (init == error_mark_node)
8696 { /* Hopefully the back end complained! */
8698 if (cbt != NULL_TREE)
8703 init = error_mark_node;
8708 /* cbtype must be permanently allocated! */
8710 /* Allocate the MAX of the areas so far, seen filewide. */
8711 high = build_int_2 ((ffeglobal_common_size (g)
8712 + ffeglobal_common_pad (g)) - 1, 0);
8713 TREE_TYPE (high) = ffecom_integer_type_node;
8716 cbtype = build_array_type (char_type_node,
8717 build_range_type (integer_type_node,
8721 cbtype = build_array_type (char_type_node, NULL_TREE);
8723 if (cbt == NULL_TREE)
8726 = build_decl (VAR_DECL,
8727 ffecom_get_external_identifier_ (s),
8729 TREE_STATIC (cbt) = 1;
8730 TREE_PUBLIC (cbt) = 1;
8735 TREE_TYPE (cbt) = cbtype;
8737 DECL_EXTERNAL (cbt) = init ? 0 : 1;
8738 DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8740 cbt = start_decl (cbt, TRUE);
8741 if (ffeglobal_hook (g) != NULL)
8742 assert (cbt == ffeglobal_hook (g));
8744 assert (!init || !DECL_EXTERNAL (cbt));
8746 /* Make sure that any type can live in COMMON and be referenced
8747 without getting a bus error. We could pick the most restrictive
8748 alignment of all entities actually placed in the COMMON, but
8749 this seems easy enough. */
8751 DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8752 DECL_USER_ALIGN (cbt) = 0;
8754 if (is_init && (ffestorag_init (st) == NULL))
8755 init = ffecom_init_zero_ (cbt);
8757 finish_decl (cbt, init, TRUE);
8760 ffestorag_set_init (st, ffebld_new_any ());
8764 assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8765 assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8766 assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8767 (ffeglobal_common_size (g)
8768 + ffeglobal_common_pad (g))));
8771 ffeglobal_set_hook (g, cbt);
8773 ffestorag_set_hook (st, cbt);
8775 ffecom_save_tree_forever (cbt);
8779 /* Make master area for local EQUIVALENCE. */
8781 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8783 ffecom_transform_equiv_ (ffestorag eqst)
8789 bool is_init = ffestorag_is_init (eqst);
8791 assert (eqst != NULL);
8793 eqt = ffestorag_hook (eqst);
8795 if (eqt != NULL_TREE)
8798 /* Process inits. */
8802 if (ffestorag_init (eqst) != NULL)
8806 /* Set the padding for the expression, so ffecom_expr
8807 knows to insert that many zeros. */
8808 switch (ffebld_op (sexp = ffestorag_init (eqst)))
8810 case FFEBLD_opCONTER:
8811 ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8814 case FFEBLD_opARRTER:
8815 ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8818 case FFEBLD_opACCTER:
8819 ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8823 assert ("bad op for eqv init (pad)" == NULL);
8827 init = ffecom_expr (sexp);
8828 if (init == error_mark_node)
8829 init = NULL_TREE; /* Hopefully the back end complained! */
8832 init = error_mark_node;
8834 else if (ffe_is_init_local_zero ())
8835 init = error_mark_node;
8839 ffecom_member_namelisted_ = FALSE;
8840 ffestorag_drive (ffestorag_list_equivs (eqst),
8841 &ffecom_member_phase1_,
8844 high = build_int_2 ((ffestorag_size (eqst)
8845 + ffestorag_modulo (eqst)) - 1, 0);
8846 TREE_TYPE (high) = ffecom_integer_type_node;
8848 eqtype = build_array_type (char_type_node,
8849 build_range_type (ffecom_integer_type_node,
8850 ffecom_integer_zero_node,
8853 eqt = build_decl (VAR_DECL,
8854 ffecom_get_invented_identifier ("__g77_equiv_%s",
8856 (ffestorag_symbol (eqst))),
8858 DECL_EXTERNAL (eqt) = 0;
8860 || ffecom_member_namelisted_
8861 #ifdef FFECOM_sizeMAXSTACKITEM
8862 || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8864 || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8865 && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8866 && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8867 TREE_STATIC (eqt) = 1;
8869 TREE_STATIC (eqt) = 0;
8870 TREE_PUBLIC (eqt) = 0;
8871 TREE_ADDRESSABLE (eqt) = 1; /* Ensure non-register allocation */
8872 DECL_CONTEXT (eqt) = current_function_decl;
8874 DECL_INITIAL (eqt) = error_mark_node;
8876 DECL_INITIAL (eqt) = NULL_TREE;
8878 eqt = start_decl (eqt, FALSE);
8880 /* Make sure that any type can live in EQUIVALENCE and be referenced
8881 without getting a bus error. We could pick the most restrictive
8882 alignment of all entities actually placed in the EQUIVALENCE, but
8883 this seems easy enough. */
8885 DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8886 DECL_USER_ALIGN (eqt) = 0;
8888 if ((!is_init && ffe_is_init_local_zero ())
8889 || (is_init && (ffestorag_init (eqst) == NULL)))
8890 init = ffecom_init_zero_ (eqt);
8892 finish_decl (eqt, init, FALSE);
8895 ffestorag_set_init (eqst, ffebld_new_any ());
8898 assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8899 assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8900 (ffestorag_size (eqst)
8901 + ffestorag_modulo (eqst))));
8904 ffestorag_set_hook (eqst, eqt);
8906 ffestorag_drive (ffestorag_list_equivs (eqst),
8907 &ffecom_member_phase2_,
8912 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8914 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8916 ffecom_transform_namelist_ (ffesymbol s)
8919 tree nmltype = ffecom_type_namelist_ ();
8927 static int mynumber = 0;
8929 nmlt = build_decl (VAR_DECL,
8930 ffecom_get_invented_identifier ("__g77_namelist_%d",
8933 TREE_STATIC (nmlt) = 1;
8934 DECL_INITIAL (nmlt) = error_mark_node;
8936 nmlt = start_decl (nmlt, FALSE);
8938 /* Process inits. */
8940 i = strlen (ffesymbol_text (s));
8942 high = build_int_2 (i, 0);
8943 TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8945 nameinit = ffecom_build_f2c_string_ (i + 1,
8946 ffesymbol_text (s));
8947 TREE_TYPE (nameinit)
8948 = build_type_variant
8951 build_range_type (ffecom_f2c_ftnlen_type_node,
8952 ffecom_f2c_ftnlen_one_node,
8955 TREE_CONSTANT (nameinit) = 1;
8956 TREE_STATIC (nameinit) = 1;
8957 nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8960 varsinit = ffecom_vardesc_array_ (s);
8961 varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8963 TREE_CONSTANT (varsinit) = 1;
8964 TREE_STATIC (varsinit) = 1;
8969 for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8972 nvarsinit = build_int_2 (i, 0);
8973 TREE_TYPE (nvarsinit) = integer_type_node;
8974 TREE_CONSTANT (nvarsinit) = 1;
8975 TREE_STATIC (nvarsinit) = 1;
8977 nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8978 TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8980 TREE_CHAIN (TREE_CHAIN (nmlinits))
8981 = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8983 nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8984 TREE_CONSTANT (nmlinits) = 1;
8985 TREE_STATIC (nmlinits) = 1;
8987 finish_decl (nmlt, nmlinits, FALSE);
8989 nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8996 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8997 analyzed on the assumption it is calculating a pointer to be
8998 indirected through. It must return the proper decl and offset,
8999 taking into account different units of measurements for offsets. */
9001 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9003 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
9006 switch (TREE_CODE (t))
9010 case NON_LVALUE_EXPR:
9011 ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9015 ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9016 if ((*decl == NULL_TREE)
9017 || (*decl == error_mark_node))
9020 if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
9022 /* An offset into COMMON. */
9023 *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
9024 *offset, TREE_OPERAND (t, 1)));
9025 /* Convert offset (presumably in bytes) into canonical units
9026 (presumably bits). */
9027 *offset = size_binop (MULT_EXPR,
9028 convert (bitsizetype, *offset),
9029 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
9032 /* Not a COMMON reference, so an unrecognized pattern. */
9033 *decl = error_mark_node;
9038 *offset = bitsize_zero_node;
9042 if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
9044 /* A reference to COMMON. */
9045 *decl = TREE_OPERAND (t, 0);
9046 *offset = bitsize_zero_node;
9051 /* Not a COMMON reference, so an unrecognized pattern. */
9052 *decl = error_mark_node;
9058 /* Given a tree that is possibly intended for use as an lvalue, return
9059 information representing a canonical view of that tree as a decl, an
9060 offset into that decl, and a size for the lvalue.
9062 If there's no applicable decl, NULL_TREE is returned for the decl,
9063 and the other fields are left undefined.
9065 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9066 is returned for the decl, and the other fields are left undefined.
9068 Otherwise, the decl returned currently is either a VAR_DECL or a
9071 The offset returned is always valid, but of course not necessarily
9072 a constant, and not necessarily converted into the appropriate
9073 type, leaving that up to the caller (so as to avoid that overhead
9074 if the decls being looked at are different anyway).
9076 If the size cannot be determined (e.g. an adjustable array),
9077 an ERROR_MARK node is returned for the size. Otherwise, the
9078 size returned is valid, not necessarily a constant, and not
9079 necessarily converted into the appropriate type as with the
9082 Note that the offset and size expressions are expressed in the
9083 base storage units (usually bits) rather than in the units of
9084 the type of the decl, because two decls with different types
9085 might overlap but with apparently non-overlapping array offsets,
9086 whereas converting the array offsets to consistant offsets will
9087 reveal the overlap. */
9089 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9091 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9094 /* The default path is to report a nonexistant decl. */
9100 switch (TREE_CODE (t))
9103 case IDENTIFIER_NODE:
9112 case TRUNC_DIV_EXPR:
9114 case FLOOR_DIV_EXPR:
9115 case ROUND_DIV_EXPR:
9116 case TRUNC_MOD_EXPR:
9118 case FLOOR_MOD_EXPR:
9119 case ROUND_MOD_EXPR:
9121 case EXACT_DIV_EXPR:
9122 case FIX_TRUNC_EXPR:
9124 case FIX_FLOOR_EXPR:
9125 case FIX_ROUND_EXPR:
9140 case BIT_ANDTC_EXPR:
9142 case TRUTH_ANDIF_EXPR:
9143 case TRUTH_ORIF_EXPR:
9144 case TRUTH_AND_EXPR:
9146 case TRUTH_XOR_EXPR:
9147 case TRUTH_NOT_EXPR:
9167 *offset = bitsize_zero_node;
9168 *size = TYPE_SIZE (TREE_TYPE (t));
9173 tree array = TREE_OPERAND (t, 0);
9174 tree element = TREE_OPERAND (t, 1);
9177 if ((array == NULL_TREE)
9178 || (element == NULL_TREE))
9180 *decl = error_mark_node;
9184 ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9186 if ((*decl == NULL_TREE)
9187 || (*decl == error_mark_node))
9190 /* Calculate ((element - base) * NBBY) + init_offset. */
9191 *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9193 TYPE_MIN_VALUE (TYPE_DOMAIN
9194 (TREE_TYPE (array)))));
9196 *offset = size_binop (MULT_EXPR,
9197 convert (bitsizetype, *offset),
9198 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9200 *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9202 *size = TYPE_SIZE (TREE_TYPE (t));
9208 /* Most of this code is to handle references to COMMON. And so
9209 far that is useful only for calling library functions, since
9210 external (user) functions might reference common areas. But
9211 even calling an external function, it's worthwhile to decode
9212 COMMON references because if not storing into COMMON, we don't
9213 want COMMON-based arguments to gratuitously force use of a
9216 *size = TYPE_SIZE (TREE_TYPE (t));
9218 ffecom_tree_canonize_ptr_ (decl, offset,
9219 TREE_OPERAND (t, 0));
9226 case NON_LVALUE_EXPR:
9229 case COND_EXPR: /* More cases than we can handle. */
9231 case REFERENCE_EXPR:
9232 case PREDECREMENT_EXPR:
9233 case PREINCREMENT_EXPR:
9234 case POSTDECREMENT_EXPR:
9235 case POSTINCREMENT_EXPR:
9238 *decl = error_mark_node;
9244 /* Do divide operation appropriate to type of operands. */
9246 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9248 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9249 tree dest_tree, ffebld dest, bool *dest_used,
9252 if ((left == error_mark_node)
9253 || (right == error_mark_node))
9254 return error_mark_node;
9256 switch (TREE_CODE (tree_type))
9259 return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9264 if (! optimize_size)
9265 return ffecom_2 (RDIV_EXPR, tree_type,
9271 if (TREE_TYPE (tree_type)
9272 == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9273 ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
9275 ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
9277 left = ffecom_1 (ADDR_EXPR,
9278 build_pointer_type (TREE_TYPE (left)),
9280 left = build_tree_list (NULL_TREE, left);
9281 right = ffecom_1 (ADDR_EXPR,
9282 build_pointer_type (TREE_TYPE (right)),
9284 right = build_tree_list (NULL_TREE, right);
9285 TREE_CHAIN (left) = right;
9287 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9288 ffecom_gfrt_kindtype (ix),
9289 ffe_is_f2c_library (),
9292 dest_tree, dest, dest_used,
9293 NULL_TREE, TRUE, hook);
9301 if (TREE_TYPE (TYPE_FIELDS (tree_type))
9302 == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9303 ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
9305 ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
9307 left = ffecom_1 (ADDR_EXPR,
9308 build_pointer_type (TREE_TYPE (left)),
9310 left = build_tree_list (NULL_TREE, left);
9311 right = ffecom_1 (ADDR_EXPR,
9312 build_pointer_type (TREE_TYPE (right)),
9314 right = build_tree_list (NULL_TREE, right);
9315 TREE_CHAIN (left) = right;
9317 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9318 ffecom_gfrt_kindtype (ix),
9319 ffe_is_f2c_library (),
9322 dest_tree, dest, dest_used,
9323 NULL_TREE, TRUE, hook);
9328 return ffecom_2 (RDIV_EXPR, tree_type,
9335 /* Build type info for non-dummy variable. */
9337 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9339 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9348 type = ffecom_tree_type[bt][kt];
9349 if (bt == FFEINFO_basictypeCHARACTER)
9351 hight = build_int_2 (ffesymbol_size (s), 0);
9352 TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9357 build_range_type (ffecom_f2c_ftnlen_type_node,
9358 ffecom_f2c_ftnlen_one_node,
9360 type = ffecom_check_size_overflow_ (s, type, FALSE);
9363 for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9365 if (type == error_mark_node)
9368 dim = ffebld_head (dl);
9369 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9371 if (ffebld_left (dim) == NULL)
9372 lowt = integer_one_node;
9374 lowt = ffecom_expr (ffebld_left (dim));
9376 if (TREE_CODE (lowt) != INTEGER_CST)
9377 lowt = variable_size (lowt);
9379 assert (ffebld_right (dim) != NULL);
9380 hight = ffecom_expr (ffebld_right (dim));
9382 if (TREE_CODE (hight) != INTEGER_CST)
9383 hight = variable_size (hight);
9385 type = build_array_type (type,
9386 build_range_type (ffecom_integer_type_node,
9388 type = ffecom_check_size_overflow_ (s, type, FALSE);
9395 /* Build Namelist type. */
9397 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9399 ffecom_type_namelist_ ()
9401 static tree type = NULL_TREE;
9403 if (type == NULL_TREE)
9405 static tree namefield, varsfield, nvarsfield;
9408 vardesctype = ffecom_type_vardesc_ ();
9410 type = make_node (RECORD_TYPE);
9412 vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9414 namefield = ffecom_decl_field (type, NULL_TREE, "name",
9416 varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9417 nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9420 TYPE_FIELDS (type) = namefield;
9423 ggc_add_tree_root (&type, 1);
9431 /* Build Vardesc type. */
9433 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9435 ffecom_type_vardesc_ ()
9437 static tree type = NULL_TREE;
9438 static tree namefield, addrfield, dimsfield, typefield;
9440 if (type == NULL_TREE)
9442 type = make_node (RECORD_TYPE);
9444 namefield = ffecom_decl_field (type, NULL_TREE, "name",
9446 addrfield = ffecom_decl_field (type, namefield, "addr",
9448 dimsfield = ffecom_decl_field (type, addrfield, "dims",
9449 ffecom_f2c_ptr_to_ftnlen_type_node);
9450 typefield = ffecom_decl_field (type, dimsfield, "type",
9453 TYPE_FIELDS (type) = namefield;
9456 ggc_add_tree_root (&type, 1);
9464 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9466 ffecom_vardesc_ (ffebld expr)
9470 assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9471 s = ffebld_symter (expr);
9473 if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9476 tree vardesctype = ffecom_type_vardesc_ ();
9484 static int mynumber = 0;
9486 var = build_decl (VAR_DECL,
9487 ffecom_get_invented_identifier ("__g77_vardesc_%d",
9490 TREE_STATIC (var) = 1;
9491 DECL_INITIAL (var) = error_mark_node;
9493 var = start_decl (var, FALSE);
9495 /* Process inits. */
9497 nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9499 ffesymbol_text (s));
9500 TREE_TYPE (nameinit)
9501 = build_type_variant
9504 build_range_type (integer_type_node,
9506 build_int_2 (i, 0))),
9508 TREE_CONSTANT (nameinit) = 1;
9509 TREE_STATIC (nameinit) = 1;
9510 nameinit = ffecom_1 (ADDR_EXPR,
9511 build_pointer_type (TREE_TYPE (nameinit)),
9514 addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9516 dimsinit = ffecom_vardesc_dims_ (s);
9518 if (typeinit == NULL_TREE)
9520 ffeinfoBasictype bt = ffesymbol_basictype (s);
9521 ffeinfoKindtype kt = ffesymbol_kindtype (s);
9522 int tc = ffecom_f2c_typecode (bt, kt);
9525 typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9528 typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9530 varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9532 TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9534 TREE_CHAIN (TREE_CHAIN (varinits))
9535 = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9536 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9537 = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9539 varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9540 TREE_CONSTANT (varinits) = 1;
9541 TREE_STATIC (varinits) = 1;
9543 finish_decl (var, varinits, FALSE);
9545 var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9547 ffesymbol_hook (s).vardesc_tree = var;
9550 return ffesymbol_hook (s).vardesc_tree;
9554 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9556 ffecom_vardesc_array_ (ffesymbol s)
9560 tree item = NULL_TREE;
9563 static int mynumber = 0;
9565 for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9567 b = ffebld_trail (b), ++i)
9571 t = ffecom_vardesc_ (ffebld_head (b));
9573 if (list == NULL_TREE)
9574 list = item = build_tree_list (NULL_TREE, t);
9577 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9578 item = TREE_CHAIN (item);
9582 item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9583 build_range_type (integer_type_node,
9585 build_int_2 (i, 0)));
9586 list = build (CONSTRUCTOR, item, NULL_TREE, list);
9587 TREE_CONSTANT (list) = 1;
9588 TREE_STATIC (list) = 1;
9590 var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9591 var = build_decl (VAR_DECL, var, item);
9592 TREE_STATIC (var) = 1;
9593 DECL_INITIAL (var) = error_mark_node;
9594 var = start_decl (var, FALSE);
9595 finish_decl (var, list, FALSE);
9601 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9603 ffecom_vardesc_dims_ (ffesymbol s)
9605 if (ffesymbol_dims (s) == NULL)
9606 return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9614 tree item = NULL_TREE;
9618 tree baseoff = NULL_TREE;
9619 static int mynumber = 0;
9621 numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9622 TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9624 numelem = ffecom_expr (ffesymbol_arraysize (s));
9625 TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9628 backlist = NULL_TREE;
9629 for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9631 b = ffebld_trail (b), e = ffebld_trail (e))
9637 if (ffebld_trail (b) == NULL)
9641 t = convert (ffecom_f2c_ftnlen_type_node,
9642 ffecom_expr (ffebld_head (e)));
9644 if (list == NULL_TREE)
9645 list = item = build_tree_list (NULL_TREE, t);
9648 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9649 item = TREE_CHAIN (item);
9653 if (ffebld_left (ffebld_head (b)) == NULL)
9654 low = ffecom_integer_one_node;
9656 low = ffecom_expr (ffebld_left (ffebld_head (b)));
9657 low = convert (ffecom_f2c_ftnlen_type_node, low);
9659 back = build_tree_list (low, t);
9660 TREE_CHAIN (back) = backlist;
9664 for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9666 if (TREE_VALUE (item) == NULL_TREE)
9667 baseoff = TREE_PURPOSE (item);
9669 baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9670 TREE_PURPOSE (item),
9671 ffecom_2 (MULT_EXPR,
9672 ffecom_f2c_ftnlen_type_node,
9677 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9679 baseoff = build_tree_list (NULL_TREE, baseoff);
9680 TREE_CHAIN (baseoff) = list;
9682 numelem = build_tree_list (NULL_TREE, numelem);
9683 TREE_CHAIN (numelem) = baseoff;
9685 numdim = build_tree_list (NULL_TREE, numdim);
9686 TREE_CHAIN (numdim) = numelem;
9688 item = build_array_type (ffecom_f2c_ftnlen_type_node,
9689 build_range_type (integer_type_node,
9692 ((int) ffesymbol_rank (s)
9694 list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9695 TREE_CONSTANT (list) = 1;
9696 TREE_STATIC (list) = 1;
9698 var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9699 var = build_decl (VAR_DECL, var, item);
9700 TREE_STATIC (var) = 1;
9701 DECL_INITIAL (var) = error_mark_node;
9702 var = start_decl (var, FALSE);
9703 finish_decl (var, list, FALSE);
9705 var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9712 /* Essentially does a "fold (build1 (code, type, node))" while checking
9713 for certain housekeeping things.
9715 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9716 ffecom_1_fn instead. */
9718 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9720 ffecom_1 (enum tree_code code, tree type, tree node)
9724 if ((node == error_mark_node)
9725 || (type == error_mark_node))
9726 return error_mark_node;
9728 if (code == ADDR_EXPR)
9730 if (!mark_addressable (node))
9731 assert ("can't mark_addressable this node!" == NULL);
9734 switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9739 item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9743 item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9748 if (TREE_CODE (type) != RECORD_TYPE)
9750 item = build1 (code, type, node);
9753 node = ffecom_stabilize_aggregate_ (node);
9754 realtype = TREE_TYPE (TYPE_FIELDS (type));
9756 ffecom_2 (COMPLEX_EXPR, type,
9757 ffecom_1 (NEGATE_EXPR, realtype,
9758 ffecom_1 (REALPART_EXPR, realtype,
9760 ffecom_1 (NEGATE_EXPR, realtype,
9761 ffecom_1 (IMAGPART_EXPR, realtype,
9766 item = build1 (code, type, node);
9770 if (TREE_SIDE_EFFECTS (node))
9771 TREE_SIDE_EFFECTS (item) = 1;
9772 if ((code == ADDR_EXPR) && staticp (node))
9773 TREE_CONSTANT (item) = 1;
9778 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9779 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9780 does not set TREE_ADDRESSABLE (because calling an inline
9781 function does not mean the function needs to be separately
9784 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9786 ffecom_1_fn (tree node)
9791 if (node == error_mark_node)
9792 return error_mark_node;
9794 type = build_type_variant (TREE_TYPE (node),
9795 TREE_READONLY (node),
9796 TREE_THIS_VOLATILE (node));
9797 item = build1 (ADDR_EXPR,
9798 build_pointer_type (type), node);
9799 if (TREE_SIDE_EFFECTS (node))
9800 TREE_SIDE_EFFECTS (item) = 1;
9802 TREE_CONSTANT (item) = 1;
9807 /* Essentially does a "fold (build (code, type, node1, node2))" while
9808 checking for certain housekeeping things. */
9810 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9812 ffecom_2 (enum tree_code code, tree type, tree node1,
9817 if ((node1 == error_mark_node)
9818 || (node2 == error_mark_node)
9819 || (type == error_mark_node))
9820 return error_mark_node;
9822 switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9824 tree a, b, c, d, realtype;
9827 assert ("no CONJ_EXPR support yet" == NULL);
9828 return error_mark_node;
9831 item = build_tree_list (TYPE_FIELDS (type), node1);
9832 TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9833 item = build (CONSTRUCTOR, type, NULL_TREE, item);
9837 if (TREE_CODE (type) != RECORD_TYPE)
9839 item = build (code, type, node1, node2);
9842 node1 = ffecom_stabilize_aggregate_ (node1);
9843 node2 = ffecom_stabilize_aggregate_ (node2);
9844 realtype = TREE_TYPE (TYPE_FIELDS (type));
9846 ffecom_2 (COMPLEX_EXPR, type,
9847 ffecom_2 (PLUS_EXPR, realtype,
9848 ffecom_1 (REALPART_EXPR, realtype,
9850 ffecom_1 (REALPART_EXPR, realtype,
9852 ffecom_2 (PLUS_EXPR, realtype,
9853 ffecom_1 (IMAGPART_EXPR, realtype,
9855 ffecom_1 (IMAGPART_EXPR, realtype,
9860 if (TREE_CODE (type) != RECORD_TYPE)
9862 item = build (code, type, node1, node2);
9865 node1 = ffecom_stabilize_aggregate_ (node1);
9866 node2 = ffecom_stabilize_aggregate_ (node2);
9867 realtype = TREE_TYPE (TYPE_FIELDS (type));
9869 ffecom_2 (COMPLEX_EXPR, type,
9870 ffecom_2 (MINUS_EXPR, realtype,
9871 ffecom_1 (REALPART_EXPR, realtype,
9873 ffecom_1 (REALPART_EXPR, realtype,
9875 ffecom_2 (MINUS_EXPR, realtype,
9876 ffecom_1 (IMAGPART_EXPR, realtype,
9878 ffecom_1 (IMAGPART_EXPR, realtype,
9883 if (TREE_CODE (type) != RECORD_TYPE)
9885 item = build (code, type, node1, node2);
9888 node1 = ffecom_stabilize_aggregate_ (node1);
9889 node2 = ffecom_stabilize_aggregate_ (node2);
9890 realtype = TREE_TYPE (TYPE_FIELDS (type));
9891 a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9893 b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9895 c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9897 d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9900 ffecom_2 (COMPLEX_EXPR, type,
9901 ffecom_2 (MINUS_EXPR, realtype,
9902 ffecom_2 (MULT_EXPR, realtype,
9905 ffecom_2 (MULT_EXPR, realtype,
9908 ffecom_2 (PLUS_EXPR, realtype,
9909 ffecom_2 (MULT_EXPR, realtype,
9912 ffecom_2 (MULT_EXPR, realtype,
9918 if ((TREE_CODE (node1) != RECORD_TYPE)
9919 && (TREE_CODE (node2) != RECORD_TYPE))
9921 item = build (code, type, node1, node2);
9924 assert (TREE_CODE (node1) == RECORD_TYPE);
9925 assert (TREE_CODE (node2) == RECORD_TYPE);
9926 node1 = ffecom_stabilize_aggregate_ (node1);
9927 node2 = ffecom_stabilize_aggregate_ (node2);
9928 realtype = TREE_TYPE (TYPE_FIELDS (type));
9930 ffecom_2 (TRUTH_ANDIF_EXPR, type,
9931 ffecom_2 (code, type,
9932 ffecom_1 (REALPART_EXPR, realtype,
9934 ffecom_1 (REALPART_EXPR, realtype,
9936 ffecom_2 (code, type,
9937 ffecom_1 (IMAGPART_EXPR, realtype,
9939 ffecom_1 (IMAGPART_EXPR, realtype,
9944 if ((TREE_CODE (node1) != RECORD_TYPE)
9945 && (TREE_CODE (node2) != RECORD_TYPE))
9947 item = build (code, type, node1, node2);
9950 assert (TREE_CODE (node1) == RECORD_TYPE);
9951 assert (TREE_CODE (node2) == RECORD_TYPE);
9952 node1 = ffecom_stabilize_aggregate_ (node1);
9953 node2 = ffecom_stabilize_aggregate_ (node2);
9954 realtype = TREE_TYPE (TYPE_FIELDS (type));
9956 ffecom_2 (TRUTH_ORIF_EXPR, type,
9957 ffecom_2 (code, type,
9958 ffecom_1 (REALPART_EXPR, realtype,
9960 ffecom_1 (REALPART_EXPR, realtype,
9962 ffecom_2 (code, type,
9963 ffecom_1 (IMAGPART_EXPR, realtype,
9965 ffecom_1 (IMAGPART_EXPR, realtype,
9970 item = build (code, type, node1, node2);
9974 if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9975 TREE_SIDE_EFFECTS (item) = 1;
9980 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9982 ffesymbol s; // the ENTRY point itself
9983 if (ffecom_2pass_advise_entrypoint(s))
9984 // the ENTRY point has been accepted
9986 Does whatever compiler needs to do when it learns about the entrypoint,
9987 like determine the return type of the master function, count the
9988 number of entrypoints, etc. Returns FALSE if the return type is
9989 not compatible with the return type(s) of other entrypoint(s).
9991 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9992 later (after _finish_progunit) be called with the same entrypoint(s)
9993 as passed to this fn for which TRUE was returned.
9996 Return FALSE if the return type conflicts with previous entrypoints. */
9998 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10000 ffecom_2pass_advise_entrypoint (ffesymbol entry)
10002 ffebld list; /* opITEM. */
10003 ffebld mlist; /* opITEM. */
10004 ffebld plist; /* opITEM. */
10005 ffebld arg; /* ffebld_head(opITEM). */
10006 ffebld item; /* opITEM. */
10007 ffesymbol s; /* ffebld_symter(arg). */
10008 ffeinfoBasictype bt = ffesymbol_basictype (entry);
10009 ffeinfoKindtype kt = ffesymbol_kindtype (entry);
10010 ffetargetCharacterSize size = ffesymbol_size (entry);
10013 if (ffecom_num_entrypoints_ == 0)
10014 { /* First entrypoint, make list of main
10015 arglist's dummies. */
10016 assert (ffecom_primary_entry_ != NULL);
10018 ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
10019 ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
10020 ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
10022 for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
10024 list = ffebld_trail (list))
10026 arg = ffebld_head (list);
10027 if (ffebld_op (arg) != FFEBLD_opSYMTER)
10028 continue; /* Alternate return or some such thing. */
10029 item = ffebld_new_item (arg, NULL);
10031 ffecom_master_arglist_ = item;
10033 ffebld_set_trail (plist, item);
10038 /* If necessary, scan entry arglist for alternate returns. Do this scan
10039 apparently redundantly (it's done below to UNIONize the arglists) so
10040 that we don't complain about RETURN 1 if an offending ENTRY is the only
10041 one with an alternate return. */
10043 if (!ffecom_is_altreturning_)
10045 for (list = ffesymbol_dummyargs (entry);
10047 list = ffebld_trail (list))
10049 arg = ffebld_head (list);
10050 if (ffebld_op (arg) == FFEBLD_opSTAR)
10052 ffecom_is_altreturning_ = TRUE;
10058 /* Now check type compatibility. */
10060 switch (ffecom_master_bt_)
10062 case FFEINFO_basictypeNONE:
10063 ok = (bt != FFEINFO_basictypeCHARACTER);
10066 case FFEINFO_basictypeCHARACTER:
10068 = (bt == FFEINFO_basictypeCHARACTER)
10069 && (kt == ffecom_master_kt_)
10070 && (size == ffecom_master_size_);
10073 case FFEINFO_basictypeANY:
10074 return FALSE; /* Just don't bother. */
10077 if (bt == FFEINFO_basictypeCHARACTER)
10083 if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10085 ffecom_master_bt_ = FFEINFO_basictypeNONE;
10086 ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10093 ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10094 ffest_ffebad_here_current_stmt (0);
10096 return FALSE; /* Can't handle entrypoint. */
10099 /* Entrypoint type compatible with previous types. */
10101 ++ffecom_num_entrypoints_;
10103 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10105 for (list = ffesymbol_dummyargs (entry);
10107 list = ffebld_trail (list))
10109 arg = ffebld_head (list);
10110 if (ffebld_op (arg) != FFEBLD_opSYMTER)
10111 continue; /* Alternate return or some such thing. */
10112 s = ffebld_symter (arg);
10113 for (plist = NULL, mlist = ffecom_master_arglist_;
10115 plist = mlist, mlist = ffebld_trail (mlist))
10116 { /* plist points to previous item for easy
10117 appending of arg. */
10118 if (ffebld_symter (ffebld_head (mlist)) == s)
10119 break; /* Already have this arg in the master list. */
10122 continue; /* Already have this arg in the master list. */
10124 /* Append this arg to the master list. */
10126 item = ffebld_new_item (arg, NULL);
10128 ffecom_master_arglist_ = item;
10130 ffebld_set_trail (plist, item);
10137 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10139 ffesymbol s; // the ENTRY point itself
10140 ffecom_2pass_do_entrypoint(s);
10142 Does whatever compiler needs to do to make the entrypoint actually
10143 happen. Must be called for each entrypoint after
10144 ffecom_finish_progunit is called. */
10146 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10148 ffecom_2pass_do_entrypoint (ffesymbol entry)
10150 static int mfn_num = 0;
10151 static int ent_num;
10153 if (mfn_num != ffecom_num_fns_)
10154 { /* First entrypoint for this program unit. */
10156 mfn_num = ffecom_num_fns_;
10157 ffecom_do_entry_ (ffecom_primary_entry_, 0);
10162 --ffecom_num_entrypoints_;
10164 ffecom_do_entry_ (entry, ent_num);
10169 /* Essentially does a "fold (build (code, type, node1, node2))" while
10170 checking for certain housekeeping things. Always sets
10171 TREE_SIDE_EFFECTS. */
10173 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10175 ffecom_2s (enum tree_code code, tree type, tree node1,
10180 if ((node1 == error_mark_node)
10181 || (node2 == error_mark_node)
10182 || (type == error_mark_node))
10183 return error_mark_node;
10185 item = build (code, type, node1, node2);
10186 TREE_SIDE_EFFECTS (item) = 1;
10187 return fold (item);
10191 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10192 checking for certain housekeeping things. */
10194 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10196 ffecom_3 (enum tree_code code, tree type, tree node1,
10197 tree node2, tree node3)
10201 if ((node1 == error_mark_node)
10202 || (node2 == error_mark_node)
10203 || (node3 == error_mark_node)
10204 || (type == error_mark_node))
10205 return error_mark_node;
10207 item = build (code, type, node1, node2, node3);
10208 if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10209 || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10210 TREE_SIDE_EFFECTS (item) = 1;
10211 return fold (item);
10215 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10216 checking for certain housekeeping things. Always sets
10217 TREE_SIDE_EFFECTS. */
10219 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10221 ffecom_3s (enum tree_code code, tree type, tree node1,
10222 tree node2, tree node3)
10226 if ((node1 == error_mark_node)
10227 || (node2 == error_mark_node)
10228 || (node3 == error_mark_node)
10229 || (type == error_mark_node))
10230 return error_mark_node;
10232 item = build (code, type, node1, node2, node3);
10233 TREE_SIDE_EFFECTS (item) = 1;
10234 return fold (item);
10239 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10241 See use by ffecom_list_expr.
10243 If expression is NULL, returns an integer zero tree. If it is not
10244 a CHARACTER expression, returns whatever ffecom_expr
10245 returns and sets the length return value to NULL_TREE. Otherwise
10246 generates code to evaluate the character expression, returns the proper
10247 pointer to the result, but does NOT set the length return value to a tree
10248 that specifies the length of the result. (In other words, the length
10249 variable is always set to NULL_TREE, because a length is never passed.)
10252 Don't set returned length, since nobody needs it (yet; someday if
10253 we allow CHARACTER*(*) dummies to statement functions, we'll need
10256 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10258 ffecom_arg_expr (ffebld expr, tree *length)
10262 *length = NULL_TREE;
10265 return integer_zero_node;
10267 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10268 return ffecom_expr (expr);
10270 return ffecom_arg_ptr_to_expr (expr, &ign);
10274 /* Transform expression into constant argument-pointer-to-expression tree.
10276 If the expression can be transformed into a argument-pointer-to-expression
10277 tree that is constant, that is done, and the tree returned. Else
10278 NULL_TREE is returned.
10280 That way, a caller can attempt to provide compile-time initialization
10281 of a variable and, if that fails, *then* choose to start a new block
10282 and resort to using temporaries, as appropriate. */
10285 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10288 return integer_zero_node;
10290 if (ffebld_op (expr) == FFEBLD_opANY)
10293 *length = error_mark_node;
10294 return error_mark_node;
10297 if (ffebld_arity (expr) == 0
10298 && (ffebld_op (expr) != FFEBLD_opSYMTER
10299 || ffebld_where (expr) == FFEINFO_whereCOMMON
10300 || ffebld_where (expr) == FFEINFO_whereGLOBAL
10301 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10305 t = ffecom_arg_ptr_to_expr (expr, length);
10306 assert (TREE_CONSTANT (t));
10307 assert (! length || TREE_CONSTANT (*length));
10312 && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10313 *length = build_int_2 (ffebld_size (expr), 0);
10315 *length = NULL_TREE;
10319 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10321 See use by ffecom_list_ptr_to_expr.
10323 If expression is NULL, returns an integer zero tree. If it is not
10324 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10325 returns and sets the length return value to NULL_TREE. Otherwise
10326 generates code to evaluate the character expression, returns the proper
10327 pointer to the result, AND sets the length return value to a tree that
10328 specifies the length of the result.
10330 If the length argument is NULL, this is a slightly special
10331 case of building a FORMAT expression, that is, an expression that
10332 will be used at run time without regard to length. For the current
10333 implementation, which uses the libf2c library, this means it is nice
10334 to append a null byte to the end of the expression, where feasible,
10335 to make sure any diagnostic about the FORMAT string terminates at
10338 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10339 length argument. This might even be seen as a feature, if a null
10340 byte can always be appended. */
10342 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10344 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10348 ffecomConcatList_ catlist;
10350 if (length != NULL)
10351 *length = NULL_TREE;
10354 return integer_zero_node;
10356 switch (ffebld_op (expr))
10358 case FFEBLD_opPERCENT_VAL:
10359 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10360 return ffecom_expr (ffebld_left (expr));
10365 temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10366 if (temp_exp == error_mark_node)
10367 return error_mark_node;
10369 return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10373 case FFEBLD_opPERCENT_REF:
10374 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10375 return ffecom_ptr_to_expr (ffebld_left (expr));
10376 if (length != NULL)
10378 ign_length = NULL_TREE;
10379 length = &ign_length;
10381 expr = ffebld_left (expr);
10384 case FFEBLD_opPERCENT_DESCR:
10385 switch (ffeinfo_basictype (ffebld_info (expr)))
10387 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10388 case FFEINFO_basictypeHOLLERITH:
10390 case FFEINFO_basictypeCHARACTER:
10391 break; /* Passed by descriptor anyway. */
10394 item = ffecom_ptr_to_expr (expr);
10395 if (item != error_mark_node)
10396 *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10405 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10406 if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10407 && (length != NULL))
10408 { /* Pass Hollerith by descriptor. */
10409 ffetargetHollerith h;
10411 assert (ffebld_op (expr) == FFEBLD_opCONTER);
10412 h = ffebld_cu_val_hollerith (ffebld_constant_union
10413 (ffebld_conter (expr)));
10415 = build_int_2 (h.length, 0);
10416 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10420 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10421 return ffecom_ptr_to_expr (expr);
10423 assert (ffeinfo_kindtype (ffebld_info (expr))
10424 == FFEINFO_kindtypeCHARACTER1);
10426 while (ffebld_op (expr) == FFEBLD_opPAREN)
10427 expr = ffebld_left (expr);
10429 catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10430 switch (ffecom_concat_list_count_ (catlist))
10432 case 0: /* Shouldn't happen, but in case it does... */
10433 if (length != NULL)
10435 *length = ffecom_f2c_ftnlen_zero_node;
10436 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10438 ffecom_concat_list_kill_ (catlist);
10439 return null_pointer_node;
10441 case 1: /* The (fairly) easy case. */
10442 if (length == NULL)
10443 ffecom_char_args_with_null_ (&item, &ign_length,
10444 ffecom_concat_list_expr_ (catlist, 0));
10446 ffecom_char_args_ (&item, length,
10447 ffecom_concat_list_expr_ (catlist, 0));
10448 ffecom_concat_list_kill_ (catlist);
10449 assert (item != NULL_TREE);
10452 default: /* Must actually concatenate things. */
10457 int count = ffecom_concat_list_count_ (catlist);
10468 ffetargetCharacterSize sz;
10470 sz = ffecom_concat_list_maxlen_ (catlist);
10472 assert (sz != FFETARGET_charactersizeNONE);
10477 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10478 FFETARGET_charactersizeNONE, count, TRUE);
10481 = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10482 FFETARGET_charactersizeNONE, count, TRUE);
10483 temporary = ffecom_push_tempvar (char_type_node,
10489 hook = ffebld_nonter_hook (expr);
10491 assert (TREE_CODE (hook) == TREE_VEC);
10492 assert (TREE_VEC_LENGTH (hook) == 3);
10493 length_array = lengths = TREE_VEC_ELT (hook, 0);
10494 item_array = items = TREE_VEC_ELT (hook, 1);
10495 temporary = TREE_VEC_ELT (hook, 2);
10499 known_length = ffecom_f2c_ftnlen_zero_node;
10501 for (i = 0; i < count; ++i)
10504 && (length == NULL))
10505 ffecom_char_args_with_null_ (&citem, &clength,
10506 ffecom_concat_list_expr_ (catlist, i));
10508 ffecom_char_args_ (&citem, &clength,
10509 ffecom_concat_list_expr_ (catlist, i));
10510 if ((citem == error_mark_node)
10511 || (clength == error_mark_node))
10513 ffecom_concat_list_kill_ (catlist);
10514 *length = error_mark_node;
10515 return error_mark_node;
10519 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10520 ffecom_modify (void_type_node,
10521 ffecom_2 (ARRAY_REF,
10522 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10524 build_int_2 (i, 0)),
10527 clength = ffecom_save_tree (clength);
10528 if (length != NULL)
10530 = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10534 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10535 ffecom_modify (void_type_node,
10536 ffecom_2 (ARRAY_REF,
10537 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10539 build_int_2 (i, 0)),
10544 temporary = ffecom_1 (ADDR_EXPR,
10545 build_pointer_type (TREE_TYPE (temporary)),
10548 item = build_tree_list (NULL_TREE, temporary);
10550 = build_tree_list (NULL_TREE,
10551 ffecom_1 (ADDR_EXPR,
10552 build_pointer_type (TREE_TYPE (items)),
10554 TREE_CHAIN (TREE_CHAIN (item))
10555 = build_tree_list (NULL_TREE,
10556 ffecom_1 (ADDR_EXPR,
10557 build_pointer_type (TREE_TYPE (lengths)),
10559 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10562 ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10563 convert (ffecom_f2c_ftnlen_type_node,
10564 build_int_2 (count, 0))));
10565 num = build_int_2 (sz, 0);
10566 TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10567 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10568 = build_tree_list (NULL_TREE, num);
10570 item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10571 TREE_SIDE_EFFECTS (item) = 1;
10572 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10576 if (length != NULL)
10577 *length = known_length;
10580 ffecom_concat_list_kill_ (catlist);
10581 assert (item != NULL_TREE);
10586 /* Generate call to run-time function.
10588 The first arg is the GNU Fortran Run-Time function index, the second
10589 arg is the list of arguments to pass to it. Returned is the expression
10590 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10591 result (which may be void). */
10593 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10595 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10597 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10598 ffecom_gfrt_kindtype (ix),
10599 ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10600 NULL_TREE, args, NULL_TREE, NULL,
10601 NULL, NULL_TREE, TRUE, hook);
10605 /* Transform constant-union to tree. */
10607 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10609 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10610 ffeinfoKindtype kt, tree tree_type)
10616 case FFEINFO_basictypeINTEGER:
10622 #if FFETARGET_okINTEGER1
10623 case FFEINFO_kindtypeINTEGER1:
10624 val = ffebld_cu_val_integer1 (*cu);
10628 #if FFETARGET_okINTEGER2
10629 case FFEINFO_kindtypeINTEGER2:
10630 val = ffebld_cu_val_integer2 (*cu);
10634 #if FFETARGET_okINTEGER3
10635 case FFEINFO_kindtypeINTEGER3:
10636 val = ffebld_cu_val_integer3 (*cu);
10640 #if FFETARGET_okINTEGER4
10641 case FFEINFO_kindtypeINTEGER4:
10642 val = ffebld_cu_val_integer4 (*cu);
10647 assert ("bad INTEGER constant kind type" == NULL);
10648 /* Fall through. */
10649 case FFEINFO_kindtypeANY:
10650 return error_mark_node;
10652 item = build_int_2 (val, (val < 0) ? -1 : 0);
10653 TREE_TYPE (item) = tree_type;
10657 case FFEINFO_basictypeLOGICAL:
10663 #if FFETARGET_okLOGICAL1
10664 case FFEINFO_kindtypeLOGICAL1:
10665 val = ffebld_cu_val_logical1 (*cu);
10669 #if FFETARGET_okLOGICAL2
10670 case FFEINFO_kindtypeLOGICAL2:
10671 val = ffebld_cu_val_logical2 (*cu);
10675 #if FFETARGET_okLOGICAL3
10676 case FFEINFO_kindtypeLOGICAL3:
10677 val = ffebld_cu_val_logical3 (*cu);
10681 #if FFETARGET_okLOGICAL4
10682 case FFEINFO_kindtypeLOGICAL4:
10683 val = ffebld_cu_val_logical4 (*cu);
10688 assert ("bad LOGICAL constant kind type" == NULL);
10689 /* Fall through. */
10690 case FFEINFO_kindtypeANY:
10691 return error_mark_node;
10693 item = build_int_2 (val, (val < 0) ? -1 : 0);
10694 TREE_TYPE (item) = tree_type;
10698 case FFEINFO_basictypeREAL:
10700 REAL_VALUE_TYPE val;
10704 #if FFETARGET_okREAL1
10705 case FFEINFO_kindtypeREAL1:
10706 val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10710 #if FFETARGET_okREAL2
10711 case FFEINFO_kindtypeREAL2:
10712 val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10716 #if FFETARGET_okREAL3
10717 case FFEINFO_kindtypeREAL3:
10718 val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10722 #if FFETARGET_okREAL4
10723 case FFEINFO_kindtypeREAL4:
10724 val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10729 assert ("bad REAL constant kind type" == NULL);
10730 /* Fall through. */
10731 case FFEINFO_kindtypeANY:
10732 return error_mark_node;
10734 item = build_real (tree_type, val);
10738 case FFEINFO_basictypeCOMPLEX:
10740 REAL_VALUE_TYPE real;
10741 REAL_VALUE_TYPE imag;
10742 tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10746 #if FFETARGET_okCOMPLEX1
10747 case FFEINFO_kindtypeREAL1:
10748 real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10749 imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10753 #if FFETARGET_okCOMPLEX2
10754 case FFEINFO_kindtypeREAL2:
10755 real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10756 imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10760 #if FFETARGET_okCOMPLEX3
10761 case FFEINFO_kindtypeREAL3:
10762 real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10763 imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10767 #if FFETARGET_okCOMPLEX4
10768 case FFEINFO_kindtypeREAL4:
10769 real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10770 imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10775 assert ("bad REAL constant kind type" == NULL);
10776 /* Fall through. */
10777 case FFEINFO_kindtypeANY:
10778 return error_mark_node;
10780 item = ffecom_build_complex_constant_ (tree_type,
10781 build_real (el_type, real),
10782 build_real (el_type, imag));
10786 case FFEINFO_basictypeCHARACTER:
10787 { /* Happens only in DATA and similar contexts. */
10788 ffetargetCharacter1 val;
10792 #if FFETARGET_okCHARACTER1
10793 case FFEINFO_kindtypeLOGICAL1:
10794 val = ffebld_cu_val_character1 (*cu);
10799 assert ("bad CHARACTER constant kind type" == NULL);
10800 /* Fall through. */
10801 case FFEINFO_kindtypeANY:
10802 return error_mark_node;
10804 item = build_string (ffetarget_length_character1 (val),
10805 ffetarget_text_character1 (val));
10807 = build_type_variant (build_array_type (char_type_node,
10809 (integer_type_node,
10812 (ffetarget_length_character1
10818 case FFEINFO_basictypeHOLLERITH:
10820 ffetargetHollerith h;
10822 h = ffebld_cu_val_hollerith (*cu);
10824 /* If not at least as wide as default INTEGER, widen it. */
10825 if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10826 item = build_string (h.length, h.text);
10829 char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10831 memcpy (str, h.text, h.length);
10832 memset (&str[h.length], ' ',
10833 FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10835 item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10839 = build_type_variant (build_array_type (char_type_node,
10841 (integer_type_node,
10849 case FFEINFO_basictypeTYPELESS:
10851 ffetargetInteger1 ival;
10852 ffetargetTypeless tless;
10855 tless = ffebld_cu_val_typeless (*cu);
10856 error = ffetarget_convert_integer1_typeless (&ival, tless);
10857 assert (error == FFEBAD);
10859 item = build_int_2 ((int) ival, 0);
10864 assert ("not yet on constant type" == NULL);
10865 /* Fall through. */
10866 case FFEINFO_basictypeANY:
10867 return error_mark_node;
10870 TREE_CONSTANT (item) = 1;
10877 /* Transform expression into constant tree.
10879 If the expression can be transformed into a tree that is constant,
10880 that is done, and the tree returned. Else NULL_TREE is returned.
10882 That way, a caller can attempt to provide compile-time initialization
10883 of a variable and, if that fails, *then* choose to start a new block
10884 and resort to using temporaries, as appropriate. */
10887 ffecom_const_expr (ffebld expr)
10890 return integer_zero_node;
10892 if (ffebld_op (expr) == FFEBLD_opANY)
10893 return error_mark_node;
10895 if (ffebld_arity (expr) == 0
10896 && (ffebld_op (expr) != FFEBLD_opSYMTER
10898 /* ~~Enable once common/equivalence is handled properly? */
10899 || ffebld_where (expr) == FFEINFO_whereCOMMON
10901 || ffebld_where (expr) == FFEINFO_whereGLOBAL
10902 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10906 t = ffecom_expr (expr);
10907 assert (TREE_CONSTANT (t));
10914 /* Handy way to make a field in a struct/union. */
10916 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10918 ffecom_decl_field (tree context, tree prevfield,
10919 const char *name, tree type)
10923 field = build_decl (FIELD_DECL, get_identifier (name), type);
10924 DECL_CONTEXT (field) = context;
10925 DECL_ALIGN (field) = 0;
10926 DECL_USER_ALIGN (field) = 0;
10927 if (prevfield != NULL_TREE)
10928 TREE_CHAIN (prevfield) = field;
10936 ffecom_close_include (FILE *f)
10938 #if FFECOM_GCC_INCLUDE
10939 ffecom_close_include_ (f);
10944 ffecom_decode_include_option (char *spec)
10946 #if FFECOM_GCC_INCLUDE
10947 return ffecom_decode_include_option_ (spec);
10953 /* End a compound statement (block). */
10955 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10957 ffecom_end_compstmt (void)
10959 return bison_rule_compstmt_ ();
10961 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
10963 /* ffecom_end_transition -- Perform end transition on all symbols
10965 ffecom_end_transition();
10967 Calls ffecom_sym_end_transition for each global and local symbol. */
10970 ffecom_end_transition ()
10972 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10976 if (ffe_is_ffedebug ())
10977 fprintf (dmpout, "; end_stmt_transition\n");
10979 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10980 ffecom_list_blockdata_ = NULL;
10981 ffecom_list_common_ = NULL;
10984 ffesymbol_drive (ffecom_sym_end_transition);
10985 if (ffe_is_ffedebug ())
10987 ffestorag_report ();
10988 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10989 ffesymbol_report_all ();
10993 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10994 ffecom_start_progunit_ ();
10996 for (item = ffecom_list_blockdata_;
10998 item = ffebld_trail (item))
11005 static int number = 0;
11007 callee = ffebld_head (item);
11008 s = ffebld_symter (callee);
11009 t = ffesymbol_hook (s).decl_tree;
11010 if (t == NULL_TREE)
11012 s = ffecom_sym_transform_ (s);
11013 t = ffesymbol_hook (s).decl_tree;
11016 dt = build_pointer_type (TREE_TYPE (t));
11018 var = build_decl (VAR_DECL,
11019 ffecom_get_invented_identifier ("__g77_forceload_%d",
11022 DECL_EXTERNAL (var) = 0;
11023 TREE_STATIC (var) = 1;
11024 TREE_PUBLIC (var) = 0;
11025 DECL_INITIAL (var) = error_mark_node;
11026 TREE_USED (var) = 1;
11028 var = start_decl (var, FALSE);
11030 t = ffecom_1 (ADDR_EXPR, dt, t);
11032 finish_decl (var, t, FALSE);
11035 /* This handles any COMMON areas that weren't referenced but have, for
11036 example, important initial data. */
11038 for (item = ffecom_list_common_;
11040 item = ffebld_trail (item))
11041 ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
11043 ffecom_list_common_ = NULL;
11047 /* ffecom_exec_transition -- Perform exec transition on all symbols
11049 ffecom_exec_transition();
11051 Calls ffecom_sym_exec_transition for each global and local symbol.
11052 Make sure error updating not inhibited. */
11055 ffecom_exec_transition ()
11059 if (ffe_is_ffedebug ())
11060 fprintf (dmpout, "; exec_stmt_transition\n");
11062 inhibited = ffebad_inhibit ();
11063 ffebad_set_inhibit (FALSE);
11065 ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
11066 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
11067 if (ffe_is_ffedebug ())
11069 ffestorag_report ();
11070 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11071 ffesymbol_report_all ();
11076 ffebad_set_inhibit (TRUE);
11079 /* Handle assignment statement.
11081 Convert dest and source using ffecom_expr, then join them
11082 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
11084 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11086 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11093 if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11098 /* This attempts to replicate the test below, but must not be
11099 true when the test below is false. (Always err on the side
11100 of creating unused temporaries, to avoid ICEs.) */
11101 if (ffebld_op (dest) != FFEBLD_opSYMTER
11102 || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11103 && (TREE_CODE (dest_tree) != VAR_DECL
11104 || TREE_ADDRESSABLE (dest_tree))))
11106 ffecom_prepare_expr_ (source, dest);
11111 ffecom_prepare_expr_ (source, NULL);
11115 ffecom_prepare_expr_w (NULL_TREE, dest);
11117 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11118 create a temporary through which the assignment is to take place,
11119 since MODIFY_EXPR doesn't handle partial overlap properly. */
11120 if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11121 && ffecom_possible_partial_overlap_ (dest, source))
11123 assign_temp = ffecom_make_tempvar ("complex_let",
11125 [ffebld_basictype (dest)]
11126 [ffebld_kindtype (dest)],
11127 FFETARGET_charactersizeNONE,
11131 assign_temp = NULL_TREE;
11133 ffecom_prepare_end ();
11135 dest_tree = ffecom_expr_w (NULL_TREE, dest);
11136 if (dest_tree == error_mark_node)
11139 if ((TREE_CODE (dest_tree) != VAR_DECL)
11140 || TREE_ADDRESSABLE (dest_tree))
11141 source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11145 assert (! dest_used);
11147 source_tree = ffecom_expr (source);
11149 if (source_tree == error_mark_node)
11153 expr_tree = source_tree;
11154 else if (assign_temp)
11157 /* The back end understands a conceptual move (evaluate source;
11158 store into dest), so use that, in case it can determine
11159 that it is going to use, say, two registers as temporaries
11160 anyway. So don't use the temp (and someday avoid generating
11161 it, once this code starts triggering regularly). */
11162 expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11166 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11169 expand_expr_stmt (expr_tree);
11170 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11176 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11180 expand_expr_stmt (expr_tree);
11184 ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11185 ffecom_prepare_expr_w (NULL_TREE, dest);
11187 ffecom_prepare_end ();
11189 ffecom_char_args_ (&dest_tree, &dest_length, dest);
11190 ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11195 /* ffecom_expr -- Transform expr into gcc tree
11198 ffebld expr; // FFE expression.
11199 tree = ffecom_expr(expr);
11201 Recursive descent on expr while making corresponding tree nodes and
11202 attaching type info and such. */
11204 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11206 ffecom_expr (ffebld expr)
11208 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11212 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
11214 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11216 ffecom_expr_assign (ffebld expr)
11218 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11222 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
11224 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11226 ffecom_expr_assign_w (ffebld expr)
11228 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11232 /* Transform expr for use as into read/write tree and stabilize the
11233 reference. Not for use on CHARACTER expressions.
11235 Recursive descent on expr while making corresponding tree nodes and
11236 attaching type info and such. */
11238 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11240 ffecom_expr_rw (tree type, ffebld expr)
11242 assert (expr != NULL);
11243 /* Different target types not yet supported. */
11244 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11246 return stabilize_reference (ffecom_expr (expr));
11250 /* Transform expr for use as into write tree and stabilize the
11251 reference. Not for use on CHARACTER expressions.
11253 Recursive descent on expr while making corresponding tree nodes and
11254 attaching type info and such. */
11256 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11258 ffecom_expr_w (tree type, ffebld expr)
11260 assert (expr != NULL);
11261 /* Different target types not yet supported. */
11262 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11264 return stabilize_reference (ffecom_expr (expr));
11268 /* Do global stuff. */
11270 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11272 ffecom_finish_compile ()
11274 assert (ffecom_outer_function_decl_ == NULL_TREE);
11275 assert (current_function_decl == NULL_TREE);
11277 ffeglobal_drive (ffecom_finish_global_);
11281 /* Public entry point for front end to access finish_decl. */
11283 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11285 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11287 assert (!is_top_level);
11288 finish_decl (decl, init, FALSE);
11292 /* Finish a program unit. */
11294 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11296 ffecom_finish_progunit ()
11298 ffecom_end_compstmt ();
11300 ffecom_previous_function_decl_ = current_function_decl;
11301 ffecom_which_entrypoint_decl_ = NULL_TREE;
11303 finish_function (0);
11308 /* Wrapper for get_identifier. pattern is sprintf-like. */
11310 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11312 ffecom_get_invented_identifier (const char *pattern, ...)
11318 va_start (ap, pattern);
11319 if (vasprintf (&nam, pattern, ap) == 0)
11322 decl = get_identifier (nam);
11324 IDENTIFIER_INVENTED (decl) = 1;
11329 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11331 assert (gfrt < FFECOM_gfrt);
11333 switch (ffecom_gfrt_type_[gfrt])
11335 case FFECOM_rttypeVOID_:
11336 case FFECOM_rttypeVOIDSTAR_:
11337 return FFEINFO_basictypeNONE;
11339 case FFECOM_rttypeFTNINT_:
11340 return FFEINFO_basictypeINTEGER;
11342 case FFECOM_rttypeINTEGER_:
11343 return FFEINFO_basictypeINTEGER;
11345 case FFECOM_rttypeLONGINT_:
11346 return FFEINFO_basictypeINTEGER;
11348 case FFECOM_rttypeLOGICAL_:
11349 return FFEINFO_basictypeLOGICAL;
11351 case FFECOM_rttypeREAL_F2C_:
11352 case FFECOM_rttypeREAL_GNU_:
11353 return FFEINFO_basictypeREAL;
11355 case FFECOM_rttypeCOMPLEX_F2C_:
11356 case FFECOM_rttypeCOMPLEX_GNU_:
11357 return FFEINFO_basictypeCOMPLEX;
11359 case FFECOM_rttypeDOUBLE_:
11360 case FFECOM_rttypeDOUBLEREAL_:
11361 return FFEINFO_basictypeREAL;
11363 case FFECOM_rttypeDBLCMPLX_F2C_:
11364 case FFECOM_rttypeDBLCMPLX_GNU_:
11365 return FFEINFO_basictypeCOMPLEX;
11367 case FFECOM_rttypeCHARACTER_:
11368 return FFEINFO_basictypeCHARACTER;
11371 return FFEINFO_basictypeANY;
11376 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11378 assert (gfrt < FFECOM_gfrt);
11380 switch (ffecom_gfrt_type_[gfrt])
11382 case FFECOM_rttypeVOID_:
11383 case FFECOM_rttypeVOIDSTAR_:
11384 return FFEINFO_kindtypeNONE;
11386 case FFECOM_rttypeFTNINT_:
11387 return FFEINFO_kindtypeINTEGER1;
11389 case FFECOM_rttypeINTEGER_:
11390 return FFEINFO_kindtypeINTEGER1;
11392 case FFECOM_rttypeLONGINT_:
11393 return FFEINFO_kindtypeINTEGER4;
11395 case FFECOM_rttypeLOGICAL_:
11396 return FFEINFO_kindtypeLOGICAL1;
11398 case FFECOM_rttypeREAL_F2C_:
11399 case FFECOM_rttypeREAL_GNU_:
11400 return FFEINFO_kindtypeREAL1;
11402 case FFECOM_rttypeCOMPLEX_F2C_:
11403 case FFECOM_rttypeCOMPLEX_GNU_:
11404 return FFEINFO_kindtypeREAL1;
11406 case FFECOM_rttypeDOUBLE_:
11407 case FFECOM_rttypeDOUBLEREAL_:
11408 return FFEINFO_kindtypeREAL2;
11410 case FFECOM_rttypeDBLCMPLX_F2C_:
11411 case FFECOM_rttypeDBLCMPLX_GNU_:
11412 return FFEINFO_kindtypeREAL2;
11414 case FFECOM_rttypeCHARACTER_:
11415 return FFEINFO_kindtypeCHARACTER1;
11418 return FFEINFO_kindtypeANY;
11432 tree double_ftype_double;
11433 tree float_ftype_float;
11434 tree ldouble_ftype_ldouble;
11435 tree ffecom_tree_ptr_to_fun_type_void;
11437 /* This block of code comes from the now-obsolete cktyps.c. It checks
11438 whether the compiler environment is buggy in known ways, some of which
11439 would, if not explicitly checked here, result in subtle bugs in g77. */
11441 if (ffe_is_do_internal_checks ())
11443 static char names[][12]
11445 {"bar", "bletch", "foo", "foobar"};
11450 name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11451 (int (*)(const void *, const void *)) strcmp);
11452 if (name != (char *) &names[2])
11454 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11459 ul = strtoul ("123456789", NULL, 10);
11460 if (ul != 123456789L)
11462 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11463 in proj.h" == NULL);
11467 fl = atof ("56.789");
11468 if ((fl < 56.788) || (fl > 56.79))
11470 assert ("atof not type double, fix your #include <stdio.h>"
11476 #if FFECOM_GCC_INCLUDE
11477 ffecom_initialize_char_syntax_ ();
11480 ffecom_outer_function_decl_ = NULL_TREE;
11481 current_function_decl = NULL_TREE;
11482 named_labels = NULL_TREE;
11483 current_binding_level = NULL_BINDING_LEVEL;
11484 free_binding_level = NULL_BINDING_LEVEL;
11485 /* Make the binding_level structure for global names. */
11487 global_binding_level = current_binding_level;
11488 current_binding_level->prep_state = 2;
11490 build_common_tree_nodes (1);
11492 /* Define `int' and `char' first so that dbx will output them first. */
11493 pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11494 integer_type_node));
11495 pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11497 pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11498 long_integer_type_node));
11499 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11500 unsigned_type_node));
11501 pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11502 long_unsigned_type_node));
11503 pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11504 long_long_integer_type_node));
11505 pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11506 long_long_unsigned_type_node));
11507 pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11508 short_integer_type_node));
11509 pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11510 short_unsigned_type_node));
11512 /* Set the sizetype before we make other types. This *should* be the
11513 first type we create. */
11516 (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11517 ffecom_typesize_pointer_
11518 = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11520 build_common_tree_nodes_2 (0);
11522 /* Define both `signed char' and `unsigned char'. */
11523 pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11524 signed_char_type_node));
11526 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11527 unsigned_char_type_node));
11529 pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11531 pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11532 double_type_node));
11533 pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11534 long_double_type_node));
11536 /* For now, override what build_common_tree_nodes has done. */
11537 complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11538 complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11539 complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11540 complex_long_double_type_node
11541 = ffecom_make_complex_type_ (long_double_type_node);
11543 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11544 complex_integer_type_node));
11545 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11546 complex_float_type_node));
11547 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11548 complex_double_type_node));
11549 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11550 complex_long_double_type_node));
11552 pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11554 /* We are not going to have real types in C with less than byte alignment,
11555 so we might as well not have any types that claim to have it. */
11556 TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11557 TYPE_USER_ALIGN (void_type_node) = 0;
11559 string_type_node = build_pointer_type (char_type_node);
11561 ffecom_tree_fun_type_void
11562 = build_function_type (void_type_node, NULL_TREE);
11564 ffecom_tree_ptr_to_fun_type_void
11565 = build_pointer_type (ffecom_tree_fun_type_void);
11567 endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11570 = build_function_type (float_type_node,
11571 tree_cons (NULL_TREE, float_type_node, endlink));
11573 double_ftype_double
11574 = build_function_type (double_type_node,
11575 tree_cons (NULL_TREE, double_type_node, endlink));
11577 ldouble_ftype_ldouble
11578 = build_function_type (long_double_type_node,
11579 tree_cons (NULL_TREE, long_double_type_node,
11582 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11583 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11585 ffecom_tree_type[i][j] = NULL_TREE;
11586 ffecom_tree_fun_type[i][j] = NULL_TREE;
11587 ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11588 ffecom_f2c_typecode_[i][j] = -1;
11591 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11592 to size FLOAT_TYPE_SIZE because they have to be the same size as
11593 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11594 Compiler options and other such stuff that change the ways these
11595 types are set should not affect this particular setup. */
11597 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11598 = t = make_signed_type (FLOAT_TYPE_SIZE);
11599 pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11601 type = ffetype_new ();
11603 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11605 ffetype_set_ams (type,
11606 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11607 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11608 ffetype_set_star (base_type,
11609 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11611 ffetype_set_kind (base_type, 1, type);
11612 ffecom_typesize_integer1_ = ffetype_size (type);
11613 assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11615 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11616 = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11617 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11620 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11621 = t = make_signed_type (CHAR_TYPE_SIZE);
11622 pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11624 type = ffetype_new ();
11625 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11627 ffetype_set_ams (type,
11628 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11629 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11630 ffetype_set_star (base_type,
11631 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11633 ffetype_set_kind (base_type, 3, type);
11634 assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11636 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11637 = t = make_unsigned_type (CHAR_TYPE_SIZE);
11638 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11641 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11642 = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11643 pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11645 type = ffetype_new ();
11646 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11648 ffetype_set_ams (type,
11649 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11650 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11651 ffetype_set_star (base_type,
11652 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11654 ffetype_set_kind (base_type, 6, type);
11655 assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11657 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11658 = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11659 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11662 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11663 = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11664 pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11666 type = ffetype_new ();
11667 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11669 ffetype_set_ams (type,
11670 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11671 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11672 ffetype_set_star (base_type,
11673 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11675 ffetype_set_kind (base_type, 2, type);
11676 assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11678 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11679 = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11680 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11684 if (ffe_is_do_internal_checks ()
11685 && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11686 && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11687 && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11688 && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11690 fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11695 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11696 = t = make_signed_type (FLOAT_TYPE_SIZE);
11697 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11699 type = ffetype_new ();
11701 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11703 ffetype_set_ams (type,
11704 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11705 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11706 ffetype_set_star (base_type,
11707 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11709 ffetype_set_kind (base_type, 1, type);
11710 assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11712 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11713 = t = make_signed_type (CHAR_TYPE_SIZE);
11714 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11716 type = ffetype_new ();
11717 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11719 ffetype_set_ams (type,
11720 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11721 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11722 ffetype_set_star (base_type,
11723 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11725 ffetype_set_kind (base_type, 3, type);
11726 assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11728 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11729 = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11730 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11732 type = ffetype_new ();
11733 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11735 ffetype_set_ams (type,
11736 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11737 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11738 ffetype_set_star (base_type,
11739 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11741 ffetype_set_kind (base_type, 6, type);
11742 assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11744 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11745 = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11746 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11748 type = ffetype_new ();
11749 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11751 ffetype_set_ams (type,
11752 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11753 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11754 ffetype_set_star (base_type,
11755 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11757 ffetype_set_kind (base_type, 2, type);
11758 assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11760 ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11761 = t = make_node (REAL_TYPE);
11762 TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11763 pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11766 type = ffetype_new ();
11768 ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11770 ffetype_set_ams (type,
11771 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11772 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11773 ffetype_set_star (base_type,
11774 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11776 ffetype_set_kind (base_type, 1, type);
11777 ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11778 = FFETARGET_f2cTYREAL;
11779 assert (ffetype_size (type) == sizeof (ffetargetReal1));
11781 ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11782 = t = make_node (REAL_TYPE);
11783 TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2; /* Always twice REAL. */
11784 pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11787 type = ffetype_new ();
11788 ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11790 ffetype_set_ams (type,
11791 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11792 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11793 ffetype_set_star (base_type,
11794 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11796 ffetype_set_kind (base_type, 2, type);
11797 ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11798 = FFETARGET_f2cTYDREAL;
11799 assert (ffetype_size (type) == sizeof (ffetargetReal2));
11801 ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11802 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11803 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11805 type = ffetype_new ();
11807 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11809 ffetype_set_ams (type,
11810 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11811 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11812 ffetype_set_star (base_type,
11813 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11815 ffetype_set_kind (base_type, 1, type);
11816 ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11817 = FFETARGET_f2cTYCOMPLEX;
11818 assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11820 ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11821 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11822 pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11824 type = ffetype_new ();
11825 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11827 ffetype_set_ams (type,
11828 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11829 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11830 ffetype_set_star (base_type,
11831 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11833 ffetype_set_kind (base_type, 2,
11835 ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11836 = FFETARGET_f2cTYDCOMPLEX;
11837 assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11839 /* Make function and ptr-to-function types for non-CHARACTER types. */
11841 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11842 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11844 if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11846 if (i == FFEINFO_basictypeINTEGER)
11848 /* Figure out the smallest INTEGER type that can hold
11849 a pointer on this machine. */
11850 if (GET_MODE_SIZE (TYPE_MODE (t))
11851 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11853 if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11854 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11855 > GET_MODE_SIZE (TYPE_MODE (t))))
11856 ffecom_pointer_kind_ = j;
11859 else if (i == FFEINFO_basictypeCOMPLEX)
11860 t = void_type_node;
11861 /* For f2c compatibility, REAL functions are really
11862 implemented as DOUBLE PRECISION. */
11863 else if ((i == FFEINFO_basictypeREAL)
11864 && (j == FFEINFO_kindtypeREAL1))
11865 t = ffecom_tree_type
11866 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11868 t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11870 ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11874 /* Set up pointer types. */
11876 if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11877 fatal ("no INTEGER type can hold a pointer on this configuration");
11878 else if (0 && ffe_is_do_internal_checks ())
11879 fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11880 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11881 FFEINFO_kindtypeINTEGERDEFAULT),
11883 ffeinfo_type (FFEINFO_basictypeINTEGER,
11884 ffecom_pointer_kind_));
11886 if (ffe_is_ugly_assign ())
11887 ffecom_label_kind_ = ffecom_pointer_kind_; /* Require ASSIGN etc to this. */
11889 ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11890 if (0 && ffe_is_do_internal_checks ())
11891 fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11893 ffecom_integer_type_node
11894 = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11895 ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11896 integer_zero_node);
11897 ffecom_integer_one_node = convert (ffecom_integer_type_node,
11900 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11901 Turns out that by TYLONG, runtime/libI77/lio.h really means
11902 "whatever size an ftnint is". For consistency and sanity,
11903 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11904 all are INTEGER, which we also make out of whatever back-end
11905 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11906 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11907 accommodate machines like the Alpha. Note that this suggests
11908 f2c and libf2c are missing a distinction perhaps needed on
11909 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11911 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11912 FFETARGET_f2cTYLONG);
11913 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11914 FFETARGET_f2cTYSHORT);
11915 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11916 FFETARGET_f2cTYINT1);
11917 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11918 FFETARGET_f2cTYQUAD);
11919 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11920 FFETARGET_f2cTYLOGICAL);
11921 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11922 FFETARGET_f2cTYLOGICAL2);
11923 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11924 FFETARGET_f2cTYLOGICAL1);
11925 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11926 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11927 FFETARGET_f2cTYQUAD);
11929 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11930 loop. CHARACTER items are built as arrays of unsigned char. */
11932 ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11933 [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11934 type = ffetype_new ();
11936 ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11937 FFEINFO_kindtypeCHARACTER1,
11939 ffetype_set_ams (type,
11940 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11941 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11942 ffetype_set_kind (base_type, 1, type);
11943 assert (ffetype_size (type)
11944 == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11946 ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11947 [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11948 ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11949 [FFEINFO_kindtypeCHARACTER1]
11950 = ffecom_tree_ptr_to_fun_type_void;
11951 ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11952 = FFETARGET_f2cTYCHAR;
11954 ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11957 /* Make multi-return-value type and fields. */
11959 ffecom_multi_type_node_ = make_node (UNION_TYPE);
11963 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11964 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11968 if (ffecom_tree_type[i][j] == NULL_TREE)
11969 continue; /* Not supported. */
11970 sprintf (&name[0], "bt_%s_kt_%s",
11971 ffeinfo_basictype_string ((ffeinfoBasictype) i),
11972 ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11973 ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11974 get_identifier (name),
11975 ffecom_tree_type[i][j]);
11976 DECL_CONTEXT (ffecom_multi_fields_[i][j])
11977 = ffecom_multi_type_node_;
11978 DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11979 DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11980 TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11981 field = ffecom_multi_fields_[i][j];
11984 TYPE_FIELDS (ffecom_multi_type_node_) = field;
11985 layout_type (ffecom_multi_type_node_);
11987 /* Subroutines usually return integer because they might have alternate
11990 ffecom_tree_subr_type
11991 = build_function_type (integer_type_node, NULL_TREE);
11992 ffecom_tree_ptr_to_subr_type
11993 = build_pointer_type (ffecom_tree_subr_type);
11994 ffecom_tree_blockdata_type
11995 = build_function_type (void_type_node, NULL_TREE);
11997 builtin_function ("__builtin_sqrtf", float_ftype_float,
11998 BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
11999 builtin_function ("__builtin_fsqrt", double_ftype_double,
12000 BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
12001 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
12002 BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
12003 builtin_function ("__builtin_sinf", float_ftype_float,
12004 BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
12005 builtin_function ("__builtin_sin", double_ftype_double,
12006 BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
12007 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
12008 BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
12009 builtin_function ("__builtin_cosf", float_ftype_float,
12010 BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
12011 builtin_function ("__builtin_cos", double_ftype_double,
12012 BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
12013 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
12014 BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
12017 pedantic_lvalues = FALSE;
12020 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
12023 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
12026 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
12029 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
12030 FFECOM_f2cDOUBLEREAL,
12032 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
12035 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
12036 FFECOM_f2cDOUBLECOMPLEX,
12038 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
12041 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
12044 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
12047 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
12050 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
12054 ffecom_f2c_ftnlen_zero_node
12055 = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
12057 ffecom_f2c_ftnlen_one_node
12058 = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
12060 ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
12061 TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
12063 ffecom_f2c_ptr_to_ftnlen_type_node
12064 = build_pointer_type (ffecom_f2c_ftnlen_type_node);
12066 ffecom_f2c_ptr_to_ftnint_type_node
12067 = build_pointer_type (ffecom_f2c_ftnint_type_node);
12069 ffecom_f2c_ptr_to_integer_type_node
12070 = build_pointer_type (ffecom_f2c_integer_type_node);
12072 ffecom_f2c_ptr_to_real_type_node
12073 = build_pointer_type (ffecom_f2c_real_type_node);
12075 ffecom_float_zero_ = build_real (float_type_node, dconst0);
12076 ffecom_double_zero_ = build_real (double_type_node, dconst0);
12078 REAL_VALUE_TYPE point_5;
12080 #ifdef REAL_ARITHMETIC
12081 REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12085 ffecom_float_half_ = build_real (float_type_node, point_5);
12086 ffecom_double_half_ = build_real (double_type_node, point_5);
12089 /* Do "extern int xargc;". */
12091 ffecom_tree_xargc_ = build_decl (VAR_DECL,
12092 get_identifier ("f__xargc"),
12093 integer_type_node);
12094 DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12095 TREE_STATIC (ffecom_tree_xargc_) = 1;
12096 TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12097 ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12098 finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12100 #if 0 /* This is being fixed, and seems to be working now. */
12101 if ((FLOAT_TYPE_SIZE != 32)
12102 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12104 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12105 (int) FLOAT_TYPE_SIZE);
12106 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12107 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12108 warning ("properly unless they all are 32 bits wide.");
12109 warning ("Please keep this in mind before you report bugs. g77 should");
12110 warning ("support non-32-bit machines better as of version 0.6.");
12114 #if 0 /* Code in ste.c that would crash has been commented out. */
12115 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12116 < TYPE_PRECISION (string_type_node))
12117 /* I/O will probably crash. */
12118 warning ("configuration: char * holds %d bits, but ftnlen only %d",
12119 TYPE_PRECISION (string_type_node),
12120 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12123 #if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
12124 if (TYPE_PRECISION (ffecom_integer_type_node)
12125 < TYPE_PRECISION (string_type_node))
12126 /* ASSIGN 10 TO I will crash. */
12127 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12128 ASSIGN statement might fail",
12129 TYPE_PRECISION (string_type_node),
12130 TYPE_PRECISION (ffecom_integer_type_node));
12135 /* ffecom_init_2 -- Initialize
12137 ffecom_init_2(); */
12139 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12143 assert (ffecom_outer_function_decl_ == NULL_TREE);
12144 assert (current_function_decl == NULL_TREE);
12145 assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12147 ffecom_master_arglist_ = NULL;
12149 ffecom_primary_entry_ = NULL;
12150 ffecom_is_altreturning_ = FALSE;
12151 ffecom_func_result_ = NULL_TREE;
12152 ffecom_multi_retval_ = NULL_TREE;
12156 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12159 ffebld expr; // FFE opITEM list.
12160 tree = ffecom_list_expr(expr);
12162 List of actual args is transformed into corresponding gcc backend list. */
12164 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12166 ffecom_list_expr (ffebld expr)
12169 tree *plist = &list;
12170 tree trail = NULL_TREE; /* Append char length args here. */
12171 tree *ptrail = &trail;
12174 while (expr != NULL)
12176 tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12178 if (texpr == error_mark_node)
12179 return error_mark_node;
12181 *plist = build_tree_list (NULL_TREE, texpr);
12182 plist = &TREE_CHAIN (*plist);
12183 expr = ffebld_trail (expr);
12184 if (length != NULL_TREE)
12186 *ptrail = build_tree_list (NULL_TREE, length);
12187 ptrail = &TREE_CHAIN (*ptrail);
12197 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12200 ffebld expr; // FFE opITEM list.
12201 tree = ffecom_list_ptr_to_expr(expr);
12203 List of actual args is transformed into corresponding gcc backend list for
12204 use in calling an external procedure (vs. a statement function). */
12206 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12208 ffecom_list_ptr_to_expr (ffebld expr)
12211 tree *plist = &list;
12212 tree trail = NULL_TREE; /* Append char length args here. */
12213 tree *ptrail = &trail;
12216 while (expr != NULL)
12218 tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12220 if (texpr == error_mark_node)
12221 return error_mark_node;
12223 *plist = build_tree_list (NULL_TREE, texpr);
12224 plist = &TREE_CHAIN (*plist);
12225 expr = ffebld_trail (expr);
12226 if (length != NULL_TREE)
12228 *ptrail = build_tree_list (NULL_TREE, length);
12229 ptrail = &TREE_CHAIN (*ptrail);
12239 /* Obtain gcc's LABEL_DECL tree for label. */
12241 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12243 ffecom_lookup_label (ffelab label)
12247 if (ffelab_hook (label) == NULL_TREE)
12249 char labelname[16];
12251 switch (ffelab_type (label))
12253 case FFELAB_typeLOOPEND:
12254 case FFELAB_typeNOTLOOP:
12255 case FFELAB_typeENDIF:
12256 sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12257 glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12259 DECL_CONTEXT (glabel) = current_function_decl;
12260 DECL_MODE (glabel) = VOIDmode;
12263 case FFELAB_typeFORMAT:
12264 glabel = build_decl (VAR_DECL,
12265 ffecom_get_invented_identifier
12266 ("__g77_format_%d", (int) ffelab_value (label)),
12267 build_type_variant (build_array_type
12271 TREE_CONSTANT (glabel) = 1;
12272 TREE_STATIC (glabel) = 1;
12273 DECL_CONTEXT (glabel) = 0;
12274 DECL_INITIAL (glabel) = NULL;
12275 make_decl_rtl (glabel, NULL, 0);
12276 expand_decl (glabel);
12278 ffecom_save_tree_forever (glabel);
12282 case FFELAB_typeANY:
12283 glabel = error_mark_node;
12287 assert ("bad label type" == NULL);
12291 ffelab_set_hook (label, glabel);
12295 glabel = ffelab_hook (label);
12302 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12303 a single source specification (as in the fourth argument of MVBITS).
12304 If the type is NULL_TREE, the type of lhs is used to make the type of
12305 the MODIFY_EXPR. */
12307 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12309 ffecom_modify (tree newtype, tree lhs,
12312 if (lhs == error_mark_node || rhs == error_mark_node)
12313 return error_mark_node;
12315 if (newtype == NULL_TREE)
12316 newtype = TREE_TYPE (lhs);
12318 if (TREE_SIDE_EFFECTS (lhs))
12319 lhs = stabilize_reference (lhs);
12321 return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12326 /* Register source file name. */
12329 ffecom_file (const char *name)
12331 #if FFECOM_GCC_INCLUDE
12332 ffecom_file_ (name);
12336 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12339 ffecom_notify_init_storage(st);
12341 Gets called when all possible units in an aggregate storage area (a LOCAL
12342 with equivalences or a COMMON) have been initialized. The initialization
12343 info either is in ffestorag_init or, if that is NULL,
12344 ffestorag_accretion:
12346 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12347 even for an array if the array is one element in length!
12349 ffestorag_accretion will contain an opACCTER. It is much like an
12350 opARRTER except it has an ffebit object in it instead of just a size.
12351 The back end can use the info in the ffebit object, if it wants, to
12352 reduce the amount of actual initialization, but in any case it should
12353 kill the ffebit object when done. Also, set accretion to NULL but
12354 init to a non-NULL value.
12356 After performing initialization, DO NOT set init to NULL, because that'll
12357 tell the front end it is ok for more initialization to happen. Instead,
12358 set init to an opANY expression or some such thing that you can use to
12359 tell that you've already initialized the object.
12362 Support two-pass FFE. */
12365 ffecom_notify_init_storage (ffestorag st)
12367 ffebld init; /* The initialization expression. */
12368 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12369 ffetargetOffset size; /* The size of the entity. */
12370 ffetargetAlign pad; /* Its initial padding. */
12373 if (ffestorag_init (st) == NULL)
12375 init = ffestorag_accretion (st);
12376 assert (init != NULL);
12377 ffestorag_set_accretion (st, NULL);
12378 ffestorag_set_accretes (st, 0);
12380 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12381 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12382 size = ffebld_accter_size (init);
12383 pad = ffebld_accter_pad (init);
12384 ffebit_kill (ffebld_accter_bits (init));
12385 ffebld_set_op (init, FFEBLD_opARRTER);
12386 ffebld_set_arrter (init, ffebld_accter (init));
12387 ffebld_arrter_set_size (init, size);
12388 ffebld_arrter_set_pad (init, size);
12392 ffestorag_set_init (st, init);
12397 init = ffestorag_init (st);
12400 #if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
12401 ffestorag_set_init (st, ffebld_new_any ());
12403 if (ffebld_op (init) == FFEBLD_opANY)
12404 return; /* Oh, we already did this! */
12406 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12410 if (ffestorag_symbol (st) != NULL)
12411 s = ffestorag_symbol (st);
12413 s = ffestorag_typesymbol (st);
12415 fprintf (dmpout, "= initialize_storage \"%s\" ",
12416 (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12417 ffebld_dump (init);
12418 fputc ('\n', dmpout);
12422 #endif /* if FFECOM_ONEPASS */
12425 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12428 ffecom_notify_init_symbol(s);
12430 Gets called when all possible units in a symbol (not placed in COMMON
12431 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12432 have been initialized. The initialization info either is in
12433 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12435 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12436 even for an array if the array is one element in length!
12438 ffesymbol_accretion will contain an opACCTER. It is much like an
12439 opARRTER except it has an ffebit object in it instead of just a size.
12440 The back end can use the info in the ffebit object, if it wants, to
12441 reduce the amount of actual initialization, but in any case it should
12442 kill the ffebit object when done. Also, set accretion to NULL but
12443 init to a non-NULL value.
12445 After performing initialization, DO NOT set init to NULL, because that'll
12446 tell the front end it is ok for more initialization to happen. Instead,
12447 set init to an opANY expression or some such thing that you can use to
12448 tell that you've already initialized the object.
12451 Support two-pass FFE. */
12454 ffecom_notify_init_symbol (ffesymbol s)
12456 ffebld init; /* The initialization expression. */
12457 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12458 ffetargetOffset size; /* The size of the entity. */
12459 ffetargetAlign pad; /* Its initial padding. */
12462 if (ffesymbol_storage (s) == NULL)
12463 return; /* Do nothing until COMMON/EQUIVALENCE
12464 possibilities checked. */
12466 if ((ffesymbol_init (s) == NULL)
12467 && ((init = ffesymbol_accretion (s)) != NULL))
12469 ffesymbol_set_accretion (s, NULL);
12470 ffesymbol_set_accretes (s, 0);
12472 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12473 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12474 size = ffebld_accter_size (init);
12475 pad = ffebld_accter_pad (init);
12476 ffebit_kill (ffebld_accter_bits (init));
12477 ffebld_set_op (init, FFEBLD_opARRTER);
12478 ffebld_set_arrter (init, ffebld_accter (init));
12479 ffebld_arrter_set_size (init, size);
12480 ffebld_arrter_set_pad (init, size);
12484 ffesymbol_set_init (s, init);
12489 init = ffesymbol_init (s);
12493 ffesymbol_set_init (s, ffebld_new_any ());
12495 if (ffebld_op (init) == FFEBLD_opANY)
12496 return; /* Oh, we already did this! */
12498 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12499 fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12500 ffebld_dump (init);
12501 fputc ('\n', dmpout);
12504 #endif /* if FFECOM_ONEPASS */
12507 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12510 ffecom_notify_primary_entry(s);
12512 Gets called when implicit or explicit PROGRAM statement seen or when
12513 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12514 global symbol that serves as the entry point. */
12517 ffecom_notify_primary_entry (ffesymbol s)
12519 ffecom_primary_entry_ = s;
12520 ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12522 if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12523 || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12524 ffecom_primary_entry_is_proc_ = TRUE;
12526 ffecom_primary_entry_is_proc_ = FALSE;
12528 if (!ffe_is_silent ())
12530 if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12531 fprintf (stderr, "%s:\n", ffesymbol_text (s));
12533 fprintf (stderr, " %s:\n", ffesymbol_text (s));
12536 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12537 if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12542 for (list = ffesymbol_dummyargs (s);
12544 list = ffebld_trail (list))
12546 arg = ffebld_head (list);
12547 if (ffebld_op (arg) == FFEBLD_opSTAR)
12549 ffecom_is_altreturning_ = TRUE;
12558 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12560 #if FFECOM_GCC_INCLUDE
12561 return ffecom_open_include_ (name, l, c);
12563 return fopen (name, "r");
12567 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12570 ffebld expr; // FFE expression.
12571 tree = ffecom_ptr_to_expr(expr);
12573 Like ffecom_expr, but sticks address-of in front of most things. */
12575 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12577 ffecom_ptr_to_expr (ffebld expr)
12580 ffeinfoBasictype bt;
12581 ffeinfoKindtype kt;
12584 assert (expr != NULL);
12586 switch (ffebld_op (expr))
12588 case FFEBLD_opSYMTER:
12589 s = ffebld_symter (expr);
12590 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12594 ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12595 assert (ix != FFECOM_gfrt);
12596 if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12598 ffecom_make_gfrt_ (ix);
12599 item = ffecom_gfrt_[ix];
12604 item = ffesymbol_hook (s).decl_tree;
12605 if (item == NULL_TREE)
12607 s = ffecom_sym_transform_ (s);
12608 item = ffesymbol_hook (s).decl_tree;
12611 assert (item != NULL);
12612 if (item == error_mark_node)
12614 if (!ffesymbol_hook (s).addr)
12615 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12619 case FFEBLD_opARRAYREF:
12620 return ffecom_arrayref_ (NULL_TREE, expr, 1);
12622 case FFEBLD_opCONTER:
12624 bt = ffeinfo_basictype (ffebld_info (expr));
12625 kt = ffeinfo_kindtype (ffebld_info (expr));
12627 item = ffecom_constantunion (&ffebld_constant_union
12628 (ffebld_conter (expr)), bt, kt,
12629 ffecom_tree_type[bt][kt]);
12630 if (item == error_mark_node)
12631 return error_mark_node;
12632 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12637 return error_mark_node;
12640 bt = ffeinfo_basictype (ffebld_info (expr));
12641 kt = ffeinfo_kindtype (ffebld_info (expr));
12643 item = ffecom_expr (expr);
12644 if (item == error_mark_node)
12645 return error_mark_node;
12647 /* The back end currently optimizes a bit too zealously for us, in that
12648 we fail JCB001 if the following block of code is omitted. It checks
12649 to see if the transformed expression is a symbol or array reference,
12650 and encloses it in a SAVE_EXPR if that is the case. */
12653 if ((TREE_CODE (item) == VAR_DECL)
12654 || (TREE_CODE (item) == PARM_DECL)
12655 || (TREE_CODE (item) == RESULT_DECL)
12656 || (TREE_CODE (item) == INDIRECT_REF)
12657 || (TREE_CODE (item) == ARRAY_REF)
12658 || (TREE_CODE (item) == COMPONENT_REF)
12660 || (TREE_CODE (item) == OFFSET_REF)
12662 || (TREE_CODE (item) == BUFFER_REF)
12663 || (TREE_CODE (item) == REALPART_EXPR)
12664 || (TREE_CODE (item) == IMAGPART_EXPR))
12666 item = ffecom_save_tree (item);
12669 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12674 assert ("fall-through error" == NULL);
12675 return error_mark_node;
12679 /* Obtain a temp var with given data type.
12681 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12682 or >= 0 for a CHARACTER type.
12684 elements is -1 for a scalar or > 0 for an array of type. */
12686 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12688 ffecom_make_tempvar (const char *commentary, tree type,
12689 ffetargetCharacterSize size, int elements)
12692 static int mynumber;
12694 assert (current_binding_level->prep_state < 2);
12696 if (type == error_mark_node)
12697 return error_mark_node;
12699 if (size != FFETARGET_charactersizeNONE)
12700 type = build_array_type (type,
12701 build_range_type (ffecom_f2c_ftnlen_type_node,
12702 ffecom_f2c_ftnlen_one_node,
12703 build_int_2 (size, 0)));
12704 if (elements != -1)
12705 type = build_array_type (type,
12706 build_range_type (integer_type_node,
12708 build_int_2 (elements - 1,
12710 t = build_decl (VAR_DECL,
12711 ffecom_get_invented_identifier ("__g77_%s_%d",
12716 t = start_decl (t, FALSE);
12717 finish_decl (t, NULL_TREE, FALSE);
12723 /* Prepare argument pointer to expression.
12725 Like ffecom_prepare_expr, except for expressions to be evaluated
12726 via ffecom_arg_ptr_to_expr. */
12729 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12731 /* ~~For now, it seems to be the same thing. */
12732 ffecom_prepare_expr (expr);
12736 /* End of preparations. */
12739 ffecom_prepare_end (void)
12741 int prep_state = current_binding_level->prep_state;
12743 assert (prep_state < 2);
12744 current_binding_level->prep_state = 2;
12746 return (prep_state == 1) ? TRUE : FALSE;
12749 /* Prepare expression.
12751 This is called before any code is generated for the current block.
12752 It scans the expression, declares any temporaries that might be needed
12753 during evaluation of the expression, and stores those temporaries in
12754 the appropriate "hook" fields of the expression. `dest', if not NULL,
12755 specifies the destination that ffecom_expr_ will see, in case that
12756 helps avoid generating unused temporaries.
12758 ~~Improve to avoid allocating unused temporaries by taking `dest'
12759 into account vis-a-vis aliasing requirements of complex/character
12763 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12765 ffeinfoBasictype bt;
12766 ffeinfoKindtype kt;
12767 ffetargetCharacterSize sz;
12768 tree tempvar = NULL_TREE;
12770 assert (current_binding_level->prep_state < 2);
12775 bt = ffeinfo_basictype (ffebld_info (expr));
12776 kt = ffeinfo_kindtype (ffebld_info (expr));
12777 sz = ffeinfo_size (ffebld_info (expr));
12779 /* Generate whatever temporaries are needed to represent the result
12780 of the expression. */
12782 if (bt == FFEINFO_basictypeCHARACTER)
12784 while (ffebld_op (expr) == FFEBLD_opPAREN)
12785 expr = ffebld_left (expr);
12788 switch (ffebld_op (expr))
12791 /* Don't make temps for SYMTER, CONTER, etc. */
12792 if (ffebld_arity (expr) == 0)
12797 case FFEINFO_basictypeCOMPLEX:
12798 if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12802 if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12805 s = ffebld_symter (ffebld_left (expr));
12806 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12807 || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12808 && ! ffesymbol_is_f2c (s))
12809 || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12810 && ! ffe_is_f2c_library ()))
12813 else if (ffebld_op (expr) == FFEBLD_opPOWER)
12815 /* Requires special treatment. There's no POW_CC function
12816 in libg2c, so POW_ZZ is used, which means we always
12817 need a double-complex temp, not a single-complex. */
12818 kt = FFEINFO_kindtypeREAL2;
12820 else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12821 /* The other ops don't need temps for complex operands. */
12824 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12825 REAL(C). See 19990325-0.f, routine `check', for cases. */
12826 tempvar = ffecom_make_tempvar ("complex",
12828 [FFEINFO_basictypeCOMPLEX][kt],
12829 FFETARGET_charactersizeNONE,
12833 case FFEINFO_basictypeCHARACTER:
12834 if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12837 if (sz == FFETARGET_charactersizeNONE)
12838 /* ~~Kludge alert! This should someday be fixed. */
12841 tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12850 case FFEBLD_opPOWER:
12853 tree rtmp, ltmp, result;
12855 ltype = ffecom_type_expr (ffebld_left (expr));
12856 rtype = ffecom_type_expr (ffebld_right (expr));
12858 rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12859 ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12860 result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12862 tempvar = make_tree_vec (3);
12863 TREE_VEC_ELT (tempvar, 0) = rtmp;
12864 TREE_VEC_ELT (tempvar, 1) = ltmp;
12865 TREE_VEC_ELT (tempvar, 2) = result;
12870 case FFEBLD_opCONCATENATE:
12872 /* This gets special handling, because only one set of temps
12873 is needed for a tree of these -- the tree is treated as
12874 a flattened list of concatenations when generating code. */
12876 ffecomConcatList_ catlist;
12877 tree ltmp, itmp, result;
12881 catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12882 count = ffecom_concat_list_count_ (catlist);
12887 = ffecom_make_tempvar ("concat_len",
12888 ffecom_f2c_ftnlen_type_node,
12889 FFETARGET_charactersizeNONE, count);
12891 = ffecom_make_tempvar ("concat_item",
12892 ffecom_f2c_address_type_node,
12893 FFETARGET_charactersizeNONE, count);
12895 = ffecom_make_tempvar ("concat_res",
12897 ffecom_concat_list_maxlen_ (catlist),
12900 tempvar = make_tree_vec (3);
12901 TREE_VEC_ELT (tempvar, 0) = ltmp;
12902 TREE_VEC_ELT (tempvar, 1) = itmp;
12903 TREE_VEC_ELT (tempvar, 2) = result;
12906 for (i = 0; i < count; ++i)
12907 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12910 ffecom_concat_list_kill_ (catlist);
12914 ffebld_nonter_set_hook (expr, tempvar);
12915 current_binding_level->prep_state = 1;
12920 case FFEBLD_opCONVERT:
12921 if (bt == FFEINFO_basictypeCHARACTER
12922 && ((ffebld_size_known (ffebld_left (expr))
12923 == FFETARGET_charactersizeNONE)
12924 || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12925 tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12931 ffebld_nonter_set_hook (expr, tempvar);
12932 current_binding_level->prep_state = 1;
12935 /* Prepare subexpressions for this expr. */
12937 switch (ffebld_op (expr))
12939 case FFEBLD_opPERCENT_LOC:
12940 ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12943 case FFEBLD_opPERCENT_VAL:
12944 case FFEBLD_opPERCENT_REF:
12945 ffecom_prepare_expr (ffebld_left (expr));
12948 case FFEBLD_opPERCENT_DESCR:
12949 ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12952 case FFEBLD_opITEM:
12958 item = ffebld_trail (item))
12959 if (ffebld_head (item) != NULL)
12960 ffecom_prepare_expr (ffebld_head (item));
12965 /* Need to handle character conversion specially. */
12966 switch (ffebld_arity (expr))
12969 ffecom_prepare_expr (ffebld_left (expr));
12970 ffecom_prepare_expr (ffebld_right (expr));
12974 ffecom_prepare_expr (ffebld_left (expr));
12985 /* Prepare expression for reading and writing.
12987 Like ffecom_prepare_expr, except for expressions to be evaluated
12988 via ffecom_expr_rw. */
12991 ffecom_prepare_expr_rw (tree type, ffebld expr)
12993 /* This is all we support for now. */
12994 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12996 /* ~~For now, it seems to be the same thing. */
12997 ffecom_prepare_expr (expr);
13001 /* Prepare expression for writing.
13003 Like ffecom_prepare_expr, except for expressions to be evaluated
13004 via ffecom_expr_w. */
13007 ffecom_prepare_expr_w (tree type, ffebld expr)
13009 /* This is all we support for now. */
13010 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13012 /* ~~For now, it seems to be the same thing. */
13013 ffecom_prepare_expr (expr);
13017 /* Prepare expression for returning.
13019 Like ffecom_prepare_expr, except for expressions to be evaluated
13020 via ffecom_return_expr. */
13023 ffecom_prepare_return_expr (ffebld expr)
13025 assert (current_binding_level->prep_state < 2);
13027 if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
13028 && ffecom_is_altreturning_
13030 ffecom_prepare_expr (expr);
13033 /* Prepare pointer to expression.
13035 Like ffecom_prepare_expr, except for expressions to be evaluated
13036 via ffecom_ptr_to_expr. */
13039 ffecom_prepare_ptr_to_expr (ffebld expr)
13041 /* ~~For now, it seems to be the same thing. */
13042 ffecom_prepare_expr (expr);
13046 /* Transform expression into constant pointer-to-expression tree.
13048 If the expression can be transformed into a pointer-to-expression tree
13049 that is constant, that is done, and the tree returned. Else NULL_TREE
13052 That way, a caller can attempt to provide compile-time initialization
13053 of a variable and, if that fails, *then* choose to start a new block
13054 and resort to using temporaries, as appropriate. */
13057 ffecom_ptr_to_const_expr (ffebld expr)
13060 return integer_zero_node;
13062 if (ffebld_op (expr) == FFEBLD_opANY)
13063 return error_mark_node;
13065 if (ffebld_arity (expr) == 0
13066 && (ffebld_op (expr) != FFEBLD_opSYMTER
13067 || ffebld_where (expr) == FFEINFO_whereCOMMON
13068 || ffebld_where (expr) == FFEINFO_whereGLOBAL
13069 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
13073 t = ffecom_ptr_to_expr (expr);
13074 assert (TREE_CONSTANT (t));
13081 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13083 tree rtn; // NULL_TREE means use expand_null_return()
13084 ffebld expr; // NULL if no alt return expr to RETURN stmt
13085 rtn = ffecom_return_expr(expr);
13087 Based on the program unit type and other info (like return function
13088 type, return master function type when alternate ENTRY points,
13089 whether subroutine has any alternate RETURN points, etc), returns the
13090 appropriate expression to be returned to the caller, or NULL_TREE
13091 meaning no return value or the caller expects it to be returned somewhere
13092 else (which is handled by other parts of this module). */
13094 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13096 ffecom_return_expr (ffebld expr)
13100 switch (ffecom_primary_entry_kind_)
13102 case FFEINFO_kindPROGRAM:
13103 case FFEINFO_kindBLOCKDATA:
13107 case FFEINFO_kindSUBROUTINE:
13108 if (!ffecom_is_altreturning_)
13109 rtn = NULL_TREE; /* No alt returns, never an expr. */
13110 else if (expr == NULL)
13111 rtn = integer_zero_node;
13113 rtn = ffecom_expr (expr);
13116 case FFEINFO_kindFUNCTION:
13117 if ((ffecom_multi_retval_ != NULL_TREE)
13118 || (ffesymbol_basictype (ffecom_primary_entry_)
13119 == FFEINFO_basictypeCHARACTER)
13120 || ((ffesymbol_basictype (ffecom_primary_entry_)
13121 == FFEINFO_basictypeCOMPLEX)
13122 && (ffecom_num_entrypoints_ == 0)
13123 && ffesymbol_is_f2c (ffecom_primary_entry_)))
13124 { /* Value is returned by direct assignment
13125 into (implicit) dummy. */
13129 rtn = ffecom_func_result_;
13131 /* Spurious error if RETURN happens before first reference! So elide
13132 this code. In particular, for debugging registry, rtn should always
13133 be non-null after all, but TREE_USED won't be set until we encounter
13134 a reference in the code. Perfectly okay (but weird) code that,
13135 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13136 this diagnostic for no reason. Have people use -O -Wuninitialized
13137 and leave it to the back end to find obviously weird cases. */
13139 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13140 situation; if the return value has never been referenced, it won't
13141 have a tree under 2pass mode. */
13142 if ((rtn == NULL_TREE)
13143 || !TREE_USED (rtn))
13145 ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13146 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13147 ffesymbol_where_column (ffecom_primary_entry_));
13148 ffebad_string (ffesymbol_text (ffesymbol_funcresult
13149 (ffecom_primary_entry_)));
13156 assert ("bad unit kind" == NULL);
13157 case FFEINFO_kindANY:
13158 rtn = error_mark_node;
13166 /* Do save_expr only if tree is not error_mark_node. */
13168 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13170 ffecom_save_tree (tree t)
13172 return save_expr (t);
13176 /* Start a compound statement (block). */
13178 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13180 ffecom_start_compstmt (void)
13182 bison_rule_pushlevel_ ();
13184 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13186 /* Public entry point for front end to access start_decl. */
13188 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13190 ffecom_start_decl (tree decl, bool is_initialized)
13192 DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13193 return start_decl (decl, FALSE);
13197 /* ffecom_sym_commit -- Symbol's state being committed to reality
13200 ffecom_sym_commit(s);
13202 Does whatever the backend needs when a symbol is committed after having
13203 been backtrackable for a period of time. */
13205 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13207 ffecom_sym_commit (ffesymbol s UNUSED)
13209 assert (!ffesymbol_retractable ());
13213 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13215 ffecom_sym_end_transition();
13217 Does backend-specific stuff and also calls ffest_sym_end_transition
13218 to do the necessary FFE stuff.
13220 Backtracking is never enabled when this fn is called, so don't worry
13224 ffecom_sym_end_transition (ffesymbol s)
13228 assert (!ffesymbol_retractable ());
13230 s = ffest_sym_end_transition (s);
13232 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13233 if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13234 && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13236 ffecom_list_blockdata_
13237 = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13238 FFEINTRIN_specNONE,
13239 FFEINTRIN_impNONE),
13240 ffecom_list_blockdata_);
13244 /* This is where we finally notice that a symbol has partial initialization
13245 and finalize it. */
13247 if (ffesymbol_accretion (s) != NULL)
13249 assert (ffesymbol_init (s) == NULL);
13250 ffecom_notify_init_symbol (s);
13252 else if (((st = ffesymbol_storage (s)) != NULL)
13253 && ((st = ffestorag_parent (st)) != NULL)
13254 && (ffestorag_accretion (st) != NULL))
13256 assert (ffestorag_init (st) == NULL);
13257 ffecom_notify_init_storage (st);
13260 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13261 if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13262 && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13263 && (ffesymbol_storage (s) != NULL))
13265 ffecom_list_common_
13266 = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13267 FFEINTRIN_specNONE,
13268 FFEINTRIN_impNONE),
13269 ffecom_list_common_);
13276 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13278 ffecom_sym_exec_transition();
13280 Does backend-specific stuff and also calls ffest_sym_exec_transition
13281 to do the necessary FFE stuff.
13283 See the long-winded description in ffecom_sym_learned for info
13284 on handling the situation where backtracking is inhibited. */
13287 ffecom_sym_exec_transition (ffesymbol s)
13289 s = ffest_sym_exec_transition (s);
13294 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13297 s = ffecom_sym_learned(s);
13299 Called when a new symbol is seen after the exec transition or when more
13300 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
13301 it arrives here is that all its latest info is updated already, so its
13302 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13303 field filled in if its gone through here or exec_transition first, and
13306 The backend probably wants to check ffesymbol_retractable() to see if
13307 backtracking is in effect. If so, the FFE's changes to the symbol may
13308 be retracted (undone) or committed (ratified), at which time the
13309 appropriate ffecom_sym_retract or _commit function will be called
13312 If the backend has its own backtracking mechanism, great, use it so that
13313 committal is a simple operation. Though it doesn't make much difference,
13314 I suppose: the reason for tentative symbol evolution in the FFE is to
13315 enable error detection in weird incorrect statements early and to disable
13316 incorrect error detection on a correct statement. The backend is not
13317 likely to introduce any information that'll get involved in these
13318 considerations, so it is probably just fine that the implementation
13319 model for this fn and for _exec_transition is to not do anything
13320 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13321 and instead wait until ffecom_sym_commit is called (which it never
13322 will be as long as we're using ambiguity-detecting statement analysis in
13323 the FFE, which we are initially to shake out the code, but don't depend
13324 on this), otherwise go ahead and do whatever is needed.
13326 In essence, then, when this fn and _exec_transition get called while
13327 backtracking is enabled, a general mechanism would be to flag which (or
13328 both) of these were called (and in what order? neat question as to what
13329 might happen that I'm too lame to think through right now) and then when
13330 _commit is called reproduce the original calling sequence, if any, for
13331 the two fns (at which point backtracking will, of course, be disabled). */
13334 ffecom_sym_learned (ffesymbol s)
13336 ffestorag_exec_layout (s);
13341 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13344 ffecom_sym_retract(s);
13346 Does whatever the backend needs when a symbol is retracted after having
13347 been backtrackable for a period of time. */
13349 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13351 ffecom_sym_retract (ffesymbol s UNUSED)
13353 assert (!ffesymbol_retractable ());
13355 #if 0 /* GCC doesn't commit any backtrackable sins,
13356 so nothing needed here. */
13357 switch (ffesymbol_hook (s).state)
13359 case 0: /* nothing happened yet. */
13362 case 1: /* exec transition happened. */
13365 case 2: /* learned happened. */
13368 case 3: /* learned then exec. */
13371 case 4: /* exec then learned. */
13375 assert ("bad hook state" == NULL);
13382 /* Create temporary gcc label. */
13384 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13386 ffecom_temp_label ()
13389 static int mynumber = 0;
13391 glabel = build_decl (LABEL_DECL,
13392 ffecom_get_invented_identifier ("__g77_label_%d",
13395 DECL_CONTEXT (glabel) = current_function_decl;
13396 DECL_MODE (glabel) = VOIDmode;
13402 /* Return an expression that is usable as an arg in a conditional context
13403 (IF, DO WHILE, .NOT., and so on).
13405 Use the one provided for the back end as of >2.6.0. */
13407 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13409 ffecom_truth_value (tree expr)
13411 return truthvalue_conversion (expr);
13415 /* Return the inversion of a truth value (the inversion of what
13416 ffecom_truth_value builds).
13418 Apparently invert_truthvalue, which is properly in the back end, is
13419 enough for now, so just use it. */
13421 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13423 ffecom_truth_value_invert (tree expr)
13425 return invert_truthvalue (ffecom_truth_value (expr));
13430 /* Return the tree that is the type of the expression, as would be
13431 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13432 transforming the expression, generating temporaries, etc. */
13435 ffecom_type_expr (ffebld expr)
13437 ffeinfoBasictype bt;
13438 ffeinfoKindtype kt;
13441 assert (expr != NULL);
13443 bt = ffeinfo_basictype (ffebld_info (expr));
13444 kt = ffeinfo_kindtype (ffebld_info (expr));
13445 tree_type = ffecom_tree_type[bt][kt];
13447 switch (ffebld_op (expr))
13449 case FFEBLD_opCONTER:
13450 case FFEBLD_opSYMTER:
13451 case FFEBLD_opARRAYREF:
13452 case FFEBLD_opUPLUS:
13453 case FFEBLD_opPAREN:
13454 case FFEBLD_opUMINUS:
13456 case FFEBLD_opSUBTRACT:
13457 case FFEBLD_opMULTIPLY:
13458 case FFEBLD_opDIVIDE:
13459 case FFEBLD_opPOWER:
13461 case FFEBLD_opFUNCREF:
13462 case FFEBLD_opSUBRREF:
13466 case FFEBLD_opNEQV:
13468 case FFEBLD_opCONVERT:
13475 case FFEBLD_opPERCENT_LOC:
13478 case FFEBLD_opACCTER:
13479 case FFEBLD_opARRTER:
13480 case FFEBLD_opITEM:
13481 case FFEBLD_opSTAR:
13482 case FFEBLD_opBOUNDS:
13483 case FFEBLD_opREPEAT:
13484 case FFEBLD_opLABTER:
13485 case FFEBLD_opLABTOK:
13486 case FFEBLD_opIMPDO:
13487 case FFEBLD_opCONCATENATE:
13488 case FFEBLD_opSUBSTR:
13490 assert ("bad op for ffecom_type_expr" == NULL);
13491 /* Fall through. */
13493 return error_mark_node;
13497 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13499 If the PARM_DECL already exists, return it, else create it. It's an
13500 integer_type_node argument for the master function that implements a
13501 subroutine or function with more than one entrypoint and is bound at
13502 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13503 first ENTRY statement, and so on). */
13505 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13507 ffecom_which_entrypoint_decl ()
13509 assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13511 return ffecom_which_entrypoint_decl_;
13516 /* The following sections consists of private and public functions
13517 that have the same names and perform roughly the same functions
13518 as counterparts in the C front end. Changes in the C front end
13519 might affect how things should be done here. Only functions
13520 needed by the back end should be public here; the rest should
13521 be private (static in the C sense). Functions needed by other
13522 g77 front-end modules should be accessed by them via public
13523 ffecom_* names, which should themselves call private versions
13524 in this section so the private versions are easy to recognize
13525 when upgrading to a new gcc and finding interesting changes
13528 Functions named after rule "foo:" in c-parse.y are named
13529 "bison_rule_foo_" so they are easy to find. */
13531 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13534 bison_rule_pushlevel_ ()
13536 emit_line_note (input_filename, lineno);
13538 clear_last_expr ();
13539 expand_start_bindings (0);
13543 bison_rule_compstmt_ ()
13546 int keep = kept_level_p ();
13548 /* Make the temps go away. */
13550 current_binding_level->names = NULL_TREE;
13552 emit_line_note (input_filename, lineno);
13553 expand_end_bindings (getdecls (), keep, 0);
13554 t = poplevel (keep, 1, 0);
13559 /* Return a definition for a builtin function named NAME and whose data type
13560 is TYPE. TYPE should be a function type with argument types.
13561 FUNCTION_CODE tells later passes how to compile calls to this function.
13562 See tree.h for its possible values.
13564 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13565 the name to be called if we can't opencode the function. */
13568 builtin_function (const char *name, tree type, int function_code,
13569 enum built_in_class class,
13570 const char *library_name)
13572 tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13573 DECL_EXTERNAL (decl) = 1;
13574 TREE_PUBLIC (decl) = 1;
13576 DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13577 make_decl_rtl (decl, NULL_PTR, 1);
13579 DECL_BUILT_IN_CLASS (decl) = class;
13580 DECL_FUNCTION_CODE (decl) = function_code;
13585 /* Handle when a new declaration NEWDECL
13586 has the same name as an old one OLDDECL
13587 in the same binding contour.
13588 Prints an error message if appropriate.
13590 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13591 Otherwise, return 0. */
13594 duplicate_decls (tree newdecl, tree olddecl)
13596 int types_match = 1;
13597 int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13598 && DECL_INITIAL (newdecl) != 0);
13599 tree oldtype = TREE_TYPE (olddecl);
13600 tree newtype = TREE_TYPE (newdecl);
13602 if (olddecl == newdecl)
13605 if (TREE_CODE (newtype) == ERROR_MARK
13606 || TREE_CODE (oldtype) == ERROR_MARK)
13609 /* New decl is completely inconsistent with the old one =>
13610 tell caller to replace the old one.
13611 This is always an error except in the case of shadowing a builtin. */
13612 if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13615 /* For real parm decl following a forward decl,
13616 return 1 so old decl will be reused. */
13617 if (types_match && TREE_CODE (newdecl) == PARM_DECL
13618 && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13621 /* The new declaration is the same kind of object as the old one.
13622 The declarations may partially match. Print warnings if they don't
13623 match enough. Ultimately, copy most of the information from the new
13624 decl to the old one, and keep using the old one. */
13626 if (TREE_CODE (olddecl) == FUNCTION_DECL
13627 && DECL_BUILT_IN (olddecl))
13629 /* A function declaration for a built-in function. */
13630 if (!TREE_PUBLIC (newdecl))
13632 else if (!types_match)
13634 /* Accept the return type of the new declaration if same modes. */
13635 tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13636 tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13638 if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13640 /* Function types may be shared, so we can't just modify
13641 the return type of olddecl's function type. */
13643 = build_function_type (newreturntype,
13644 TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13648 TREE_TYPE (olddecl) = newtype;
13654 else if (TREE_CODE (olddecl) == FUNCTION_DECL
13655 && DECL_SOURCE_LINE (olddecl) == 0)
13657 /* A function declaration for a predeclared function
13658 that isn't actually built in. */
13659 if (!TREE_PUBLIC (newdecl))
13661 else if (!types_match)
13663 /* If the types don't match, preserve volatility indication.
13664 Later on, we will discard everything else about the
13665 default declaration. */
13666 TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13670 /* Copy all the DECL_... slots specified in the new decl
13671 except for any that we copy here from the old type.
13673 Past this point, we don't change OLDTYPE and NEWTYPE
13674 even if we change the types of NEWDECL and OLDDECL. */
13678 /* Merge the data types specified in the two decls. */
13679 if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13680 TREE_TYPE (newdecl)
13681 = TREE_TYPE (olddecl)
13682 = TREE_TYPE (newdecl);
13684 /* Lay the type out, unless already done. */
13685 if (oldtype != TREE_TYPE (newdecl))
13687 if (TREE_TYPE (newdecl) != error_mark_node)
13688 layout_type (TREE_TYPE (newdecl));
13689 if (TREE_CODE (newdecl) != FUNCTION_DECL
13690 && TREE_CODE (newdecl) != TYPE_DECL
13691 && TREE_CODE (newdecl) != CONST_DECL)
13692 layout_decl (newdecl, 0);
13696 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13697 DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13698 DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13699 if (TREE_CODE (olddecl) != FUNCTION_DECL)
13700 if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13702 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13703 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13707 /* Keep the old rtl since we can safely use it. */
13708 DECL_RTL (newdecl) = DECL_RTL (olddecl);
13710 /* Merge the type qualifiers. */
13711 if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13712 && !TREE_THIS_VOLATILE (newdecl))
13713 TREE_THIS_VOLATILE (olddecl) = 0;
13714 if (TREE_READONLY (newdecl))
13715 TREE_READONLY (olddecl) = 1;
13716 if (TREE_THIS_VOLATILE (newdecl))
13718 TREE_THIS_VOLATILE (olddecl) = 1;
13719 if (TREE_CODE (newdecl) == VAR_DECL)
13720 make_var_volatile (newdecl);
13723 /* Keep source location of definition rather than declaration.
13724 Likewise, keep decl at outer scope. */
13725 if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13726 || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13728 DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13729 DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13731 if (DECL_CONTEXT (olddecl) == 0
13732 && TREE_CODE (newdecl) != FUNCTION_DECL)
13733 DECL_CONTEXT (newdecl) = 0;
13736 /* Merge the unused-warning information. */
13737 if (DECL_IN_SYSTEM_HEADER (olddecl))
13738 DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13739 else if (DECL_IN_SYSTEM_HEADER (newdecl))
13740 DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13742 /* Merge the initialization information. */
13743 if (DECL_INITIAL (newdecl) == 0)
13744 DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13746 /* Merge the section attribute.
13747 We want to issue an error if the sections conflict but that must be
13748 done later in decl_attributes since we are called before attributes
13750 if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13751 DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13754 if (TREE_CODE (newdecl) == FUNCTION_DECL)
13756 DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13757 DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13761 /* If cannot merge, then use the new type and qualifiers,
13762 and don't preserve the old rtl. */
13765 TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13766 TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13767 TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13768 TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13771 /* Merge the storage class information. */
13772 /* For functions, static overrides non-static. */
13773 if (TREE_CODE (newdecl) == FUNCTION_DECL)
13775 TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13776 /* This is since we don't automatically
13777 copy the attributes of NEWDECL into OLDDECL. */
13778 TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13779 /* If this clears `static', clear it in the identifier too. */
13780 if (! TREE_PUBLIC (olddecl))
13781 TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13783 if (DECL_EXTERNAL (newdecl))
13785 TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13786 DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13787 /* An extern decl does not override previous storage class. */
13788 TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13792 TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13793 TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13796 /* If either decl says `inline', this fn is inline,
13797 unless its definition was passed already. */
13798 if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13799 DECL_INLINE (olddecl) = 1;
13800 DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13802 /* Get rid of any built-in function if new arg types don't match it
13803 or if we have a function definition. */
13804 if (TREE_CODE (newdecl) == FUNCTION_DECL
13805 && DECL_BUILT_IN (olddecl)
13806 && (!types_match || new_is_definition))
13808 TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13809 DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13812 /* If redeclaring a builtin function, and not a definition,
13814 Also preserve various other info from the definition. */
13815 if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13817 if (DECL_BUILT_IN (olddecl))
13819 DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13820 DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13823 DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
13825 DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13826 DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13827 DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13828 DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13831 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13832 But preserve olddecl's DECL_UID. */
13834 register unsigned olddecl_uid = DECL_UID (olddecl);
13836 memcpy ((char *) olddecl + sizeof (struct tree_common),
13837 (char *) newdecl + sizeof (struct tree_common),
13838 sizeof (struct tree_decl) - sizeof (struct tree_common));
13839 DECL_UID (olddecl) = olddecl_uid;
13845 /* Finish processing of a declaration;
13846 install its initial value.
13847 If the length of an array type is not known before,
13848 it must be determined now, from the initial value, or it is an error. */
13851 finish_decl (tree decl, tree init, bool is_top_level)
13853 register tree type = TREE_TYPE (decl);
13854 int was_incomplete = (DECL_SIZE (decl) == 0);
13855 bool at_top_level = (current_binding_level == global_binding_level);
13856 bool top_level = is_top_level || at_top_level;
13858 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13860 assert (!is_top_level || !at_top_level);
13862 if (TREE_CODE (decl) == PARM_DECL)
13863 assert (init == NULL_TREE);
13864 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13865 overlaps DECL_ARG_TYPE. */
13866 else if (init == NULL_TREE)
13867 assert (DECL_INITIAL (decl) == NULL_TREE);
13869 assert (DECL_INITIAL (decl) == error_mark_node);
13871 if (init != NULL_TREE)
13873 if (TREE_CODE (decl) != TYPE_DECL)
13874 DECL_INITIAL (decl) = init;
13877 /* typedef foo = bar; store the type of bar as the type of foo. */
13878 TREE_TYPE (decl) = TREE_TYPE (init);
13879 DECL_INITIAL (decl) = init = 0;
13883 /* Deduce size of array from initialization, if not already known */
13885 if (TREE_CODE (type) == ARRAY_TYPE
13886 && TYPE_DOMAIN (type) == 0
13887 && TREE_CODE (decl) != TYPE_DECL)
13889 assert (top_level);
13890 assert (was_incomplete);
13892 layout_decl (decl, 0);
13895 if (TREE_CODE (decl) == VAR_DECL)
13897 if (DECL_SIZE (decl) == NULL_TREE
13898 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13899 layout_decl (decl, 0);
13901 if (DECL_SIZE (decl) == NULL_TREE
13902 && (TREE_STATIC (decl)
13904 /* A static variable with an incomplete type is an error if it is
13905 initialized. Also if it is not file scope. Otherwise, let it
13906 through, but if it is not `extern' then it may cause an error
13908 (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13910 /* An automatic variable with an incomplete type is an error. */
13911 !DECL_EXTERNAL (decl)))
13913 assert ("storage size not known" == NULL);
13917 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13918 && (DECL_SIZE (decl) != 0)
13919 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13921 assert ("storage size not constant" == NULL);
13926 /* Output the assembler code and/or RTL code for variables and functions,
13927 unless the type is an undefined structure or union. If not, it will get
13928 done when the type is completed. */
13930 if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13932 rest_of_decl_compilation (decl, NULL,
13933 DECL_CONTEXT (decl) == 0,
13936 if (DECL_CONTEXT (decl) != 0)
13938 /* Recompute the RTL of a local array now if it used to be an
13939 incomplete type. */
13941 && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13943 /* If we used it already as memory, it must stay in memory. */
13944 TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13945 /* If it's still incomplete now, no init will save it. */
13946 if (DECL_SIZE (decl) == 0)
13947 DECL_INITIAL (decl) = 0;
13948 expand_decl (decl);
13950 /* Compute and store the initial value. */
13951 if (TREE_CODE (decl) != FUNCTION_DECL)
13952 expand_decl_init (decl);
13955 else if (TREE_CODE (decl) == TYPE_DECL)
13957 rest_of_decl_compilation (decl, NULL_PTR,
13958 DECL_CONTEXT (decl) == 0,
13962 /* At the end of a declaration, throw away any variable type sizes of types
13963 defined inside that declaration. There is no use computing them in the
13964 following function definition. */
13965 if (current_binding_level == global_binding_level)
13966 get_pending_sizes ();
13969 /* Finish up a function declaration and compile that function
13970 all the way to assembler language output. The free the storage
13971 for the function definition.
13973 This is called after parsing the body of the function definition.
13975 NESTED is nonzero if the function being finished is nested in another. */
13978 finish_function (int nested)
13980 register tree fndecl = current_function_decl;
13982 assert (fndecl != NULL_TREE);
13983 if (TREE_CODE (fndecl) != ERROR_MARK)
13986 assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13988 assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13991 /* TREE_READONLY (fndecl) = 1;
13992 This caused &foo to be of type ptr-to-const-function
13993 which then got a warning when stored in a ptr-to-function variable. */
13995 poplevel (1, 0, 1);
13997 if (TREE_CODE (fndecl) != ERROR_MARK)
13999 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
14001 /* Must mark the RESULT_DECL as being in this function. */
14003 DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
14005 /* Obey `register' declarations if `setjmp' is called in this fn. */
14006 /* Generate rtl for function exit. */
14007 expand_function_end (input_filename, lineno, 0);
14009 /* If this is a nested function, protect the local variables in the stack
14010 above us from being collected while we're compiling this function. */
14012 ggc_push_context ();
14014 /* Run the optimizers and output the assembler code for this function. */
14015 rest_of_compilation (fndecl);
14017 /* Undo the GC context switch. */
14019 ggc_pop_context ();
14022 if (TREE_CODE (fndecl) != ERROR_MARK
14024 && DECL_SAVED_INSNS (fndecl) == 0)
14026 /* Stop pointing to the local nodes about to be freed. */
14027 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14028 function definition. */
14029 /* For a nested function, this is done in pop_f_function_context. */
14030 /* If rest_of_compilation set this to 0, leave it 0. */
14031 if (DECL_INITIAL (fndecl) != 0)
14032 DECL_INITIAL (fndecl) = error_mark_node;
14033 DECL_ARGUMENTS (fndecl) = 0;
14038 /* Let the error reporting routines know that we're outside a function.
14039 For a nested function, this value is used in pop_c_function_context
14040 and then reset via pop_function_context. */
14041 ffecom_outer_function_decl_ = current_function_decl = NULL;
14045 /* Plug-in replacement for identifying the name of a decl and, for a
14046 function, what we call it in diagnostics. For now, "program unit"
14047 should suffice, since it's a bit of a hassle to figure out which
14048 of several kinds of things it is. Note that it could conceivably
14049 be a statement function, which probably isn't really a program unit
14050 per se, but if that comes up, it should be easy to check (being a
14051 nested function and all). */
14053 static const char *
14054 lang_printable_name (tree decl, int v)
14056 /* Just to keep GCC quiet about the unused variable.
14057 In theory, differing values of V should produce different
14062 if (TREE_CODE (decl) == ERROR_MARK)
14063 return "erroneous code";
14064 return IDENTIFIER_POINTER (DECL_NAME (decl));
14068 /* g77's function to print out name of current function that caused
14073 lang_print_error_function (const char *file)
14075 static ffeglobal last_g = NULL;
14076 static ffesymbol last_s = NULL;
14081 if ((ffecom_primary_entry_ == NULL)
14082 || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14090 g = ffesymbol_global (ffecom_primary_entry_);
14091 if (ffecom_nested_entry_ == NULL)
14093 s = ffecom_primary_entry_;
14094 switch (ffesymbol_kind (s))
14096 case FFEINFO_kindFUNCTION:
14100 case FFEINFO_kindSUBROUTINE:
14101 kind = "subroutine";
14104 case FFEINFO_kindPROGRAM:
14108 case FFEINFO_kindBLOCKDATA:
14109 kind = "block-data";
14113 kind = ffeinfo_kind_message (ffesymbol_kind (s));
14119 s = ffecom_nested_entry_;
14120 kind = "statement function";
14124 if ((last_g != g) || (last_s != s))
14127 fprintf (stderr, "%s: ", file);
14130 fprintf (stderr, "Outside of any program unit:\n");
14133 const char *name = ffesymbol_text (s);
14135 fprintf (stderr, "In %s `%s':\n", kind, name);
14144 /* Similar to `lookup_name' but look only at current binding level. */
14147 lookup_name_current_level (tree name)
14151 if (current_binding_level == global_binding_level)
14152 return IDENTIFIER_GLOBAL_VALUE (name);
14154 if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14157 for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14158 if (DECL_NAME (t) == name)
14164 /* Create a new `struct binding_level'. */
14166 static struct binding_level *
14167 make_binding_level ()
14170 return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14173 /* Save and restore the variables in this file and elsewhere
14174 that keep track of the progress of compilation of the current function.
14175 Used for nested functions. */
14179 struct f_function *next;
14181 tree shadowed_labels;
14182 struct binding_level *binding_level;
14185 struct f_function *f_function_chain;
14187 /* Restore the variables used during compilation of a C function. */
14190 pop_f_function_context ()
14192 struct f_function *p = f_function_chain;
14195 /* Bring back all the labels that were shadowed. */
14196 for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14197 if (DECL_NAME (TREE_VALUE (link)) != 0)
14198 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14199 = TREE_VALUE (link);
14201 if (current_function_decl != error_mark_node
14202 && DECL_SAVED_INSNS (current_function_decl) == 0)
14204 /* Stop pointing to the local nodes about to be freed. */
14205 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14206 function definition. */
14207 DECL_INITIAL (current_function_decl) = error_mark_node;
14208 DECL_ARGUMENTS (current_function_decl) = 0;
14211 pop_function_context ();
14213 f_function_chain = p->next;
14215 named_labels = p->named_labels;
14216 shadowed_labels = p->shadowed_labels;
14217 current_binding_level = p->binding_level;
14222 /* Save and reinitialize the variables
14223 used during compilation of a C function. */
14226 push_f_function_context ()
14228 struct f_function *p
14229 = (struct f_function *) xmalloc (sizeof (struct f_function));
14231 push_function_context ();
14233 p->next = f_function_chain;
14234 f_function_chain = p;
14236 p->named_labels = named_labels;
14237 p->shadowed_labels = shadowed_labels;
14238 p->binding_level = current_binding_level;
14242 push_parm_decl (tree parm)
14244 int old_immediate_size_expand = immediate_size_expand;
14246 /* Don't try computing parm sizes now -- wait till fn is called. */
14248 immediate_size_expand = 0;
14250 /* Fill in arg stuff. */
14252 DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14253 DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14254 TREE_READONLY (parm) = 1; /* All implementation args are read-only. */
14256 parm = pushdecl (parm);
14258 immediate_size_expand = old_immediate_size_expand;
14260 finish_decl (parm, NULL_TREE, FALSE);
14263 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
14266 pushdecl_top_level (x)
14270 register struct binding_level *b = current_binding_level;
14271 register tree f = current_function_decl;
14273 current_binding_level = global_binding_level;
14274 current_function_decl = NULL_TREE;
14276 current_binding_level = b;
14277 current_function_decl = f;
14281 /* Store the list of declarations of the current level.
14282 This is done for the parameter declarations of a function being defined,
14283 after they are modified in the light of any missing parameters. */
14289 return current_binding_level->names = decls;
14292 /* Store the parameter declarations into the current function declaration.
14293 This is called after parsing the parameter declarations, before
14294 digesting the body of the function.
14296 For an old-style definition, modify the function's type
14297 to specify at least the number of arguments. */
14300 store_parm_decls (int is_main_program UNUSED)
14302 register tree fndecl = current_function_decl;
14304 if (fndecl == error_mark_node)
14307 /* This is a chain of PARM_DECLs from old-style parm declarations. */
14308 DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14310 /* Initialize the RTL code for the function. */
14312 init_function_start (fndecl, input_filename, lineno);
14314 /* Set up parameters and prepare for return, for the function. */
14316 expand_function_start (fndecl, 0);
14320 start_decl (tree decl, bool is_top_level)
14323 bool at_top_level = (current_binding_level == global_binding_level);
14324 bool top_level = is_top_level || at_top_level;
14326 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14328 assert (!is_top_level || !at_top_level);
14330 if (DECL_INITIAL (decl) != NULL_TREE)
14332 assert (DECL_INITIAL (decl) == error_mark_node);
14333 assert (!DECL_EXTERNAL (decl));
14335 else if (top_level)
14336 assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14338 /* For Fortran, we by default put things in .common when possible. */
14339 DECL_COMMON (decl) = 1;
14341 /* Add this decl to the current binding level. TEM may equal DECL or it may
14342 be a previous decl of the same name. */
14344 tem = pushdecl_top_level (decl);
14346 tem = pushdecl (decl);
14348 /* For a local variable, define the RTL now. */
14350 /* But not if this is a duplicate decl and we preserved the rtl from the
14351 previous one (which may or may not happen). */
14352 && DECL_RTL (tem) == 0)
14354 if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14356 else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14357 && DECL_INITIAL (tem) != 0)
14364 /* Create the FUNCTION_DECL for a function definition.
14365 DECLSPECS and DECLARATOR are the parts of the declaration;
14366 they describe the function's name and the type it returns,
14367 but twisted together in a fashion that parallels the syntax of C.
14369 This function creates a binding context for the function body
14370 as well as setting up the FUNCTION_DECL in current_function_decl.
14372 Returns 1 on success. If the DECLARATOR is not suitable for a function
14373 (it defines a datum instead), we return 0, which tells
14374 yyparse to report a parse error.
14376 NESTED is nonzero for a function nested within another function. */
14379 start_function (tree name, tree type, int nested, int public)
14383 int old_immediate_size_expand = immediate_size_expand;
14386 shadowed_labels = 0;
14388 /* Don't expand any sizes in the return type of the function. */
14389 immediate_size_expand = 0;
14394 assert (current_function_decl != NULL_TREE);
14395 assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14399 assert (current_function_decl == NULL_TREE);
14402 if (TREE_CODE (type) == ERROR_MARK)
14403 decl1 = current_function_decl = error_mark_node;
14406 decl1 = build_decl (FUNCTION_DECL,
14409 TREE_PUBLIC (decl1) = public ? 1 : 0;
14411 DECL_INLINE (decl1) = 1;
14412 TREE_STATIC (decl1) = 1;
14413 DECL_EXTERNAL (decl1) = 0;
14415 announce_function (decl1);
14417 /* Make the init_value nonzero so pushdecl knows this is not tentative.
14418 error_mark_node is replaced below (in poplevel) with the BLOCK. */
14419 DECL_INITIAL (decl1) = error_mark_node;
14421 /* Record the decl so that the function name is defined. If we already have
14422 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
14424 current_function_decl = pushdecl (decl1);
14428 ffecom_outer_function_decl_ = current_function_decl;
14431 current_binding_level->prep_state = 2;
14433 if (TREE_CODE (current_function_decl) != ERROR_MARK)
14435 make_function_rtl (current_function_decl);
14437 restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14438 DECL_RESULT (current_function_decl)
14439 = build_decl (RESULT_DECL, NULL_TREE, restype);
14442 if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14443 TREE_ADDRESSABLE (current_function_decl) = 1;
14445 immediate_size_expand = old_immediate_size_expand;
14448 /* Here are the public functions the GNU back end needs. */
14451 convert (type, expr)
14454 register tree e = expr;
14455 register enum tree_code code = TREE_CODE (type);
14457 if (type == TREE_TYPE (e)
14458 || TREE_CODE (e) == ERROR_MARK)
14460 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14461 return fold (build1 (NOP_EXPR, type, e));
14462 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14463 || code == ERROR_MARK)
14464 return error_mark_node;
14465 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14467 assert ("void value not ignored as it ought to be" == NULL);
14468 return error_mark_node;
14470 if (code == VOID_TYPE)
14471 return build1 (CONVERT_EXPR, type, e);
14472 if ((code != RECORD_TYPE)
14473 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14474 e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14476 if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14477 return fold (convert_to_integer (type, e));
14478 if (code == POINTER_TYPE)
14479 return fold (convert_to_pointer (type, e));
14480 if (code == REAL_TYPE)
14481 return fold (convert_to_real (type, e));
14482 if (code == COMPLEX_TYPE)
14483 return fold (convert_to_complex (type, e));
14484 if (code == RECORD_TYPE)
14485 return fold (ffecom_convert_to_complex_ (type, e));
14487 assert ("conversion to non-scalar type requested" == NULL);
14488 return error_mark_node;
14491 /* integrate_decl_tree calls this function, but since we don't use the
14492 DECL_LANG_SPECIFIC field, this is a no-op. */
14495 copy_lang_decl (node)
14500 /* Return the list of declarations of the current level.
14501 Note that this list is in reverse order unless/until
14502 you nreverse it; and when you do nreverse it, you must
14503 store the result back using `storedecls' or you will lose. */
14508 return current_binding_level->names;
14511 /* Nonzero if we are currently in the global binding level. */
14514 global_bindings_p ()
14516 return current_binding_level == global_binding_level;
14519 /* Print an error message for invalid use of an incomplete type.
14520 VALUE is the expression that was used (or 0 if that isn't known)
14521 and TYPE is the type that was invalid. */
14524 incomplete_type_error (value, type)
14528 if (TREE_CODE (type) == ERROR_MARK)
14531 assert ("incomplete type?!?" == NULL);
14534 /* Mark ARG for GC. */
14536 mark_binding_level (void *arg)
14538 struct binding_level *level = *(struct binding_level **) arg;
14542 ggc_mark_tree (level->names);
14543 ggc_mark_tree (level->blocks);
14544 ggc_mark_tree (level->this_block);
14545 level = level->level_chain;
14550 init_decl_processing ()
14552 static tree *const tree_roots[] = {
14553 ¤t_function_decl,
14555 &ffecom_tree_fun_type_void,
14556 &ffecom_integer_zero_node,
14557 &ffecom_integer_one_node,
14558 &ffecom_tree_subr_type,
14559 &ffecom_tree_ptr_to_subr_type,
14560 &ffecom_tree_blockdata_type,
14561 &ffecom_tree_xargc_,
14562 &ffecom_f2c_integer_type_node,
14563 &ffecom_f2c_ptr_to_integer_type_node,
14564 &ffecom_f2c_address_type_node,
14565 &ffecom_f2c_real_type_node,
14566 &ffecom_f2c_ptr_to_real_type_node,
14567 &ffecom_f2c_doublereal_type_node,
14568 &ffecom_f2c_complex_type_node,
14569 &ffecom_f2c_doublecomplex_type_node,
14570 &ffecom_f2c_longint_type_node,
14571 &ffecom_f2c_logical_type_node,
14572 &ffecom_f2c_flag_type_node,
14573 &ffecom_f2c_ftnlen_type_node,
14574 &ffecom_f2c_ftnlen_zero_node,
14575 &ffecom_f2c_ftnlen_one_node,
14576 &ffecom_f2c_ftnlen_two_node,
14577 &ffecom_f2c_ptr_to_ftnlen_type_node,
14578 &ffecom_f2c_ftnint_type_node,
14579 &ffecom_f2c_ptr_to_ftnint_type_node,
14580 &ffecom_outer_function_decl_,
14581 &ffecom_previous_function_decl_,
14582 &ffecom_which_entrypoint_decl_,
14583 &ffecom_float_zero_,
14584 &ffecom_float_half_,
14585 &ffecom_double_zero_,
14586 &ffecom_double_half_,
14587 &ffecom_func_result_,
14588 &ffecom_func_length_,
14589 &ffecom_multi_type_node_,
14590 &ffecom_multi_retval_,
14598 /* Record our roots. */
14599 for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14600 ggc_add_tree_root (tree_roots[i], 1);
14601 ggc_add_tree_root (&ffecom_tree_type[0][0],
14602 FFEINFO_basictype*FFEINFO_kindtype);
14603 ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14604 FFEINFO_basictype*FFEINFO_kindtype);
14605 ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14606 FFEINFO_basictype*FFEINFO_kindtype);
14607 ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14608 ggc_add_root (¤t_binding_level, 1, sizeof current_binding_level,
14609 mark_binding_level);
14610 ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14611 mark_binding_level);
14612 ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14618 init_parse (filename)
14619 const char *filename;
14621 /* Open input file. */
14622 if (filename == 0 || !strcmp (filename, "-"))
14625 filename = "stdin";
14628 finput = fopen (filename, "r");
14630 pfatal_with_name (filename);
14632 #ifdef IO_BUFFER_SIZE
14633 setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14636 /* Make identifier nodes long enough for the language-specific slots. */
14637 set_identifier_size (sizeof (struct lang_identifier));
14638 decl_printable_name = lang_printable_name;
14640 print_error_function = lang_print_error_function;
14652 /* Delete the node BLOCK from the current binding level.
14653 This is used for the block inside a stmt expr ({...})
14654 so that the block can be reinserted where appropriate. */
14657 delete_block (block)
14661 if (current_binding_level->blocks == block)
14662 current_binding_level->blocks = TREE_CHAIN (block);
14663 for (t = current_binding_level->blocks; t;)
14665 if (TREE_CHAIN (t) == block)
14666 TREE_CHAIN (t) = TREE_CHAIN (block);
14668 t = TREE_CHAIN (t);
14670 TREE_CHAIN (block) = NULL;
14671 /* Clear TREE_USED which is always set by poplevel.
14672 The flag is set again if insert_block is called. */
14673 TREE_USED (block) = 0;
14677 insert_block (block)
14680 TREE_USED (block) = 1;
14681 current_binding_level->blocks
14682 = chainon (current_binding_level->blocks, block);
14686 lang_decode_option (argc, argv)
14690 return ffe_decode_option (argc, argv);
14693 /* used by print-tree.c */
14696 lang_print_xnode (file, node, indent)
14706 ffe_terminate_0 ();
14708 if (ffe_is_ffedebug ())
14709 malloc_pool_display (malloc_pool_image ());
14718 /* Return the typed-based alias set for T, which may be an expression
14719 or a type. Return -1 if we don't do anything special. */
14722 lang_get_alias_set (t)
14723 tree t ATTRIBUTE_UNUSED;
14725 /* We do not wish to use alias-set based aliasing at all. Used in the
14726 extreme (every object with its own set, with equivalences recorded)
14727 it might be helpful, but there are problems when it comes to inlining.
14728 We get on ok with flag_argument_noalias, and alias-set aliasing does
14729 currently limit how stack slots can be reused, which is a lose. */
14734 lang_init_options ()
14736 /* Set default options for Fortran. */
14737 flag_move_all_movables = 1;
14738 flag_reduce_all_givs = 1;
14739 flag_argument_noalias = 2;
14740 flag_errno_math = 0;
14741 flag_complex_divide_method = 1;
14747 /* If the file is output from cpp, it should contain a first line
14748 `# 1 "real-filename"', and the current design of gcc (toplev.c
14749 in particular and the way it sets up information relied on by
14750 INCLUDE) requires that we read this now, and store the
14751 "real-filename" info in master_input_filename. Ask the lexer
14752 to try doing this. */
14753 ffelex_hash_kludge (finput);
14757 mark_addressable (exp)
14760 register tree x = exp;
14762 switch (TREE_CODE (x))
14765 case COMPONENT_REF:
14767 x = TREE_OPERAND (x, 0);
14771 TREE_ADDRESSABLE (x) = 1;
14778 if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14779 && DECL_NONLOCAL (x))
14781 if (TREE_PUBLIC (x))
14783 assert ("address of global register var requested" == NULL);
14786 assert ("address of register variable requested" == NULL);
14788 else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14790 if (TREE_PUBLIC (x))
14792 assert ("address of global register var requested" == NULL);
14795 assert ("address of register var requested" == NULL);
14797 put_var_into_stack (x);
14800 case FUNCTION_DECL:
14801 TREE_ADDRESSABLE (x) = 1;
14802 #if 0 /* poplevel deals with this now. */
14803 if (DECL_CONTEXT (x) == 0)
14804 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14812 /* If DECL has a cleanup, build and return that cleanup here.
14813 This is a callback called by expand_expr. */
14816 maybe_build_cleanup (decl)
14819 /* There are no cleanups in Fortran. */
14823 /* Exit a binding level.
14824 Pop the level off, and restore the state of the identifier-decl mappings
14825 that were in effect when this level was entered.
14827 If KEEP is nonzero, this level had explicit declarations, so
14828 and create a "block" (a BLOCK node) for the level
14829 to record its declarations and subblocks for symbol table output.
14831 If FUNCTIONBODY is nonzero, this level is the body of a function,
14832 so create a block as if KEEP were set and also clear out all
14835 If REVERSE is nonzero, reverse the order of decls before putting
14836 them into the BLOCK. */
14839 poplevel (keep, reverse, functionbody)
14844 register tree link;
14845 /* The chain of decls was accumulated in reverse order.
14846 Put it into forward order, just for cleanliness. */
14848 tree subblocks = current_binding_level->blocks;
14851 int block_previously_created;
14853 /* Get the decls in the order they were written.
14854 Usually current_binding_level->names is in reverse order.
14855 But parameter decls were previously put in forward order. */
14858 current_binding_level->names
14859 = decls = nreverse (current_binding_level->names);
14861 decls = current_binding_level->names;
14863 /* Output any nested inline functions within this block
14864 if they weren't already output. */
14866 for (decl = decls; decl; decl = TREE_CHAIN (decl))
14867 if (TREE_CODE (decl) == FUNCTION_DECL
14868 && ! TREE_ASM_WRITTEN (decl)
14869 && DECL_INITIAL (decl) != 0
14870 && TREE_ADDRESSABLE (decl))
14872 /* If this decl was copied from a file-scope decl
14873 on account of a block-scope extern decl,
14874 propagate TREE_ADDRESSABLE to the file-scope decl.
14876 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14877 true, since then the decl goes through save_for_inline_copying. */
14878 if (DECL_ABSTRACT_ORIGIN (decl) != 0
14879 && DECL_ABSTRACT_ORIGIN (decl) != decl)
14880 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14881 else if (DECL_SAVED_INSNS (decl) != 0)
14883 push_function_context ();
14884 output_inline_function (decl);
14885 pop_function_context ();
14889 /* If there were any declarations or structure tags in that level,
14890 or if this level is a function body,
14891 create a BLOCK to record them for the life of this function. */
14894 block_previously_created = (current_binding_level->this_block != 0);
14895 if (block_previously_created)
14896 block = current_binding_level->this_block;
14897 else if (keep || functionbody)
14898 block = make_node (BLOCK);
14901 BLOCK_VARS (block) = decls;
14902 BLOCK_SUBBLOCKS (block) = subblocks;
14905 /* In each subblock, record that this is its superior. */
14907 for (link = subblocks; link; link = TREE_CHAIN (link))
14908 BLOCK_SUPERCONTEXT (link) = block;
14910 /* Clear out the meanings of the local variables of this level. */
14912 for (link = decls; link; link = TREE_CHAIN (link))
14914 if (DECL_NAME (link) != 0)
14916 /* If the ident. was used or addressed via a local extern decl,
14917 don't forget that fact. */
14918 if (DECL_EXTERNAL (link))
14920 if (TREE_USED (link))
14921 TREE_USED (DECL_NAME (link)) = 1;
14922 if (TREE_ADDRESSABLE (link))
14923 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14925 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14929 /* If the level being exited is the top level of a function,
14930 check over all the labels, and clear out the current
14931 (function local) meanings of their names. */
14935 /* If this is the top level block of a function,
14936 the vars are the function's parameters.
14937 Don't leave them in the BLOCK because they are
14938 found in the FUNCTION_DECL instead. */
14940 BLOCK_VARS (block) = 0;
14943 /* Pop the current level, and free the structure for reuse. */
14946 register struct binding_level *level = current_binding_level;
14947 current_binding_level = current_binding_level->level_chain;
14949 level->level_chain = free_binding_level;
14950 free_binding_level = level;
14953 /* Dispose of the block that we just made inside some higher level. */
14955 && current_function_decl != error_mark_node)
14956 DECL_INITIAL (current_function_decl) = block;
14959 if (!block_previously_created)
14960 current_binding_level->blocks
14961 = chainon (current_binding_level->blocks, block);
14963 /* If we did not make a block for the level just exited,
14964 any blocks made for inner levels
14965 (since they cannot be recorded as subblocks in that level)
14966 must be carried forward so they will later become subblocks
14967 of something else. */
14968 else if (subblocks)
14969 current_binding_level->blocks
14970 = chainon (current_binding_level->blocks, subblocks);
14973 TREE_USED (block) = 1;
14978 print_lang_decl (file, node, indent)
14986 print_lang_identifier (file, node, indent)
14991 print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14992 print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14996 print_lang_statistics ()
15001 print_lang_type (file, node, indent)
15008 /* Record a decl-node X as belonging to the current lexical scope.
15009 Check for errors (such as an incompatible declaration for the same
15010 name already seen in the same scope).
15012 Returns either X or an old decl for the same name.
15013 If an old decl is returned, it may have been smashed
15014 to agree with what X says. */
15021 register tree name = DECL_NAME (x);
15022 register struct binding_level *b = current_binding_level;
15024 if ((TREE_CODE (x) == FUNCTION_DECL)
15025 && (DECL_INITIAL (x) == 0)
15026 && DECL_EXTERNAL (x))
15027 DECL_CONTEXT (x) = NULL_TREE;
15029 DECL_CONTEXT (x) = current_function_decl;
15033 if (IDENTIFIER_INVENTED (name))
15036 DECL_ARTIFICIAL (x) = 1;
15038 DECL_IN_SYSTEM_HEADER (x) = 1;
15041 t = lookup_name_current_level (name);
15043 assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
15045 /* Don't push non-parms onto list for parms until we understand
15046 why we're doing this and whether it works. */
15048 assert ((b == global_binding_level)
15049 || !ffecom_transform_only_dummies_
15050 || TREE_CODE (x) == PARM_DECL);
15052 if ((t != NULL_TREE) && duplicate_decls (x, t))
15055 /* If we are processing a typedef statement, generate a whole new
15056 ..._TYPE node (which will be just an variant of the existing
15057 ..._TYPE node with identical properties) and then install the
15058 TYPE_DECL node generated to represent the typedef name as the
15059 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15061 The whole point here is to end up with a situation where each and every
15062 ..._TYPE node the compiler creates will be uniquely associated with
15063 AT MOST one node representing a typedef name. This way, even though
15064 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15065 (i.e. "typedef name") nodes very early on, later parts of the
15066 compiler can always do the reverse translation and get back the
15067 corresponding typedef name. For example, given:
15069 typedef struct S MY_TYPE; MY_TYPE object;
15071 Later parts of the compiler might only know that `object' was of type
15072 `struct S' if it were not for code just below. With this code
15073 however, later parts of the compiler see something like:
15075 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15077 And they can then deduce (from the node for type struct S') that the
15078 original object declaration was:
15082 Being able to do this is important for proper support of protoize, and
15083 also for generating precise symbolic debugging information which
15084 takes full account of the programmer's (typedef) vocabulary.
15086 Obviously, we don't want to generate a duplicate ..._TYPE node if the
15087 TYPE_DECL node that we are now processing really represents a
15088 standard built-in type.
15090 Since all standard types are effectively declared at line zero in the
15091 source file, we can easily check to see if we are working on a
15092 standard type by checking the current value of lineno. */
15094 if (TREE_CODE (x) == TYPE_DECL)
15096 if (DECL_SOURCE_LINE (x) == 0)
15098 if (TYPE_NAME (TREE_TYPE (x)) == 0)
15099 TYPE_NAME (TREE_TYPE (x)) = x;
15101 else if (TREE_TYPE (x) != error_mark_node)
15103 tree tt = TREE_TYPE (x);
15105 tt = build_type_copy (tt);
15106 TYPE_NAME (tt) = x;
15107 TREE_TYPE (x) = tt;
15111 /* This name is new in its binding level. Install the new declaration
15113 if (b == global_binding_level)
15114 IDENTIFIER_GLOBAL_VALUE (name) = x;
15116 IDENTIFIER_LOCAL_VALUE (name) = x;
15119 /* Put decls on list in reverse order. We will reverse them later if
15121 TREE_CHAIN (x) = b->names;
15127 /* Nonzero if the current level needs to have a BLOCK made. */
15134 for (decl = current_binding_level->names;
15136 decl = TREE_CHAIN (decl))
15138 if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15139 || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15140 /* Currently, there aren't supposed to be non-artificial names
15141 at other than the top block for a function -- they're
15142 believed to always be temps. But it's wise to check anyway. */
15148 /* Enter a new binding level.
15149 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15150 not for that of tags. */
15153 pushlevel (tag_transparent)
15154 int tag_transparent;
15156 register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15158 assert (! tag_transparent);
15160 if (current_binding_level == global_binding_level)
15165 /* Reuse or create a struct for this binding level. */
15167 if (free_binding_level)
15169 newlevel = free_binding_level;
15170 free_binding_level = free_binding_level->level_chain;
15174 newlevel = make_binding_level ();
15177 /* Add this level to the front of the chain (stack) of levels that
15180 *newlevel = clear_binding_level;
15181 newlevel->level_chain = current_binding_level;
15182 current_binding_level = newlevel;
15185 /* Set the BLOCK node for the innermost scope
15186 (the one we are currently in). */
15190 register tree block;
15192 current_binding_level->this_block = block;
15195 /* ~~gcc/tree.h *should* declare this, because toplev.c references it. */
15197 /* Can't 'yydebug' a front end not generated by yacc/bison! */
15200 set_yydebug (value)
15204 fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15208 signed_or_unsigned_type (unsignedp, type)
15214 if (! INTEGRAL_TYPE_P (type))
15216 if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15217 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15218 if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15219 return unsignedp ? unsigned_type_node : integer_type_node;
15220 if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15221 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15222 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15223 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15224 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15225 return (unsignedp ? long_long_unsigned_type_node
15226 : long_long_integer_type_node);
15228 type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15229 if (type2 == NULL_TREE)
15239 tree type1 = TYPE_MAIN_VARIANT (type);
15240 ffeinfoKindtype kt;
15243 if (type1 == unsigned_char_type_node || type1 == char_type_node)
15244 return signed_char_type_node;
15245 if (type1 == unsigned_type_node)
15246 return integer_type_node;
15247 if (type1 == short_unsigned_type_node)
15248 return short_integer_type_node;
15249 if (type1 == long_unsigned_type_node)
15250 return long_integer_type_node;
15251 if (type1 == long_long_unsigned_type_node)
15252 return long_long_integer_type_node;
15253 #if 0 /* gcc/c-* files only */
15254 if (type1 == unsigned_intDI_type_node)
15255 return intDI_type_node;
15256 if (type1 == unsigned_intSI_type_node)
15257 return intSI_type_node;
15258 if (type1 == unsigned_intHI_type_node)
15259 return intHI_type_node;
15260 if (type1 == unsigned_intQI_type_node)
15261 return intQI_type_node;
15264 type2 = type_for_size (TYPE_PRECISION (type1), 0);
15265 if (type2 != NULL_TREE)
15268 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15270 type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15272 if (type1 == type2)
15273 return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15279 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15280 or validate its data type for an `if' or `while' statement or ?..: exp.
15282 This preparation consists of taking the ordinary
15283 representation of an expression expr and producing a valid tree
15284 boolean expression describing whether expr is nonzero. We could
15285 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15286 but we optimize comparisons, &&, ||, and !.
15288 The resulting type should always be `integer_type_node'. */
15291 truthvalue_conversion (expr)
15294 if (TREE_CODE (expr) == ERROR_MARK)
15297 #if 0 /* This appears to be wrong for C++. */
15298 /* These really should return error_mark_node after 2.4 is stable.
15299 But not all callers handle ERROR_MARK properly. */
15300 switch (TREE_CODE (TREE_TYPE (expr)))
15303 error ("struct type value used where scalar is required");
15304 return integer_zero_node;
15307 error ("union type value used where scalar is required");
15308 return integer_zero_node;
15311 error ("array type value used where scalar is required");
15312 return integer_zero_node;
15319 switch (TREE_CODE (expr))
15321 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15322 or comparison expressions as truth values at this level. */
15324 case COMPONENT_REF:
15325 /* A one-bit unsigned bit-field is already acceptable. */
15326 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15327 && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15333 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15334 or comparison expressions as truth values at this level. */
15336 if (integer_zerop (TREE_OPERAND (expr, 1)))
15337 return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15339 case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15340 case TRUTH_ANDIF_EXPR:
15341 case TRUTH_ORIF_EXPR:
15342 case TRUTH_AND_EXPR:
15343 case TRUTH_OR_EXPR:
15344 case TRUTH_XOR_EXPR:
15345 TREE_TYPE (expr) = integer_type_node;
15352 return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15355 return real_zerop (expr) ? integer_zero_node : integer_one_node;
15358 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15359 return build (COMPOUND_EXPR, integer_type_node,
15360 TREE_OPERAND (expr, 0), integer_one_node);
15362 return integer_one_node;
15365 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15366 ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15368 truthvalue_conversion (TREE_OPERAND (expr, 0)),
15369 truthvalue_conversion (TREE_OPERAND (expr, 1)));
15375 /* These don't change whether an object is non-zero or zero. */
15376 return truthvalue_conversion (TREE_OPERAND (expr, 0));
15380 /* These don't change whether an object is zero or non-zero, but
15381 we can't ignore them if their second arg has side-effects. */
15382 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15383 return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15384 truthvalue_conversion (TREE_OPERAND (expr, 0)));
15386 return truthvalue_conversion (TREE_OPERAND (expr, 0));
15389 /* Distribute the conversion into the arms of a COND_EXPR. */
15390 return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15391 truthvalue_conversion (TREE_OPERAND (expr, 1)),
15392 truthvalue_conversion (TREE_OPERAND (expr, 2))));
15395 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15396 since that affects how `default_conversion' will behave. */
15397 if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15398 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15400 /* fall through... */
15402 /* If this is widening the argument, we can ignore it. */
15403 if (TYPE_PRECISION (TREE_TYPE (expr))
15404 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15405 return truthvalue_conversion (TREE_OPERAND (expr, 0));
15409 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15411 if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15412 && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15414 /* fall through... */
15416 /* This and MINUS_EXPR can be changed into a comparison of the
15418 if (TREE_TYPE (TREE_OPERAND (expr, 0))
15419 == TREE_TYPE (TREE_OPERAND (expr, 1)))
15420 return ffecom_2 (NE_EXPR, integer_type_node,
15421 TREE_OPERAND (expr, 0),
15422 TREE_OPERAND (expr, 1));
15423 return ffecom_2 (NE_EXPR, integer_type_node,
15424 TREE_OPERAND (expr, 0),
15425 fold (build1 (NOP_EXPR,
15426 TREE_TYPE (TREE_OPERAND (expr, 0)),
15427 TREE_OPERAND (expr, 1))));
15430 if (integer_onep (TREE_OPERAND (expr, 1)))
15435 #if 0 /* No such thing in Fortran. */
15436 if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15437 warning ("suggest parentheses around assignment used as truth value");
15445 if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15447 ((TREE_SIDE_EFFECTS (expr)
15448 ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15450 truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15451 TREE_TYPE (TREE_TYPE (expr)),
15453 truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15454 TREE_TYPE (TREE_TYPE (expr)),
15457 return ffecom_2 (NE_EXPR, integer_type_node,
15459 convert (TREE_TYPE (expr), integer_zero_node));
15463 type_for_mode (mode, unsignedp)
15464 enum machine_mode mode;
15471 if (mode == TYPE_MODE (integer_type_node))
15472 return unsignedp ? unsigned_type_node : integer_type_node;
15474 if (mode == TYPE_MODE (signed_char_type_node))
15475 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15477 if (mode == TYPE_MODE (short_integer_type_node))
15478 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15480 if (mode == TYPE_MODE (long_integer_type_node))
15481 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15483 if (mode == TYPE_MODE (long_long_integer_type_node))
15484 return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15486 #if HOST_BITS_PER_WIDE_INT >= 64
15487 if (mode == TYPE_MODE (intTI_type_node))
15488 return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15491 if (mode == TYPE_MODE (float_type_node))
15492 return float_type_node;
15494 if (mode == TYPE_MODE (double_type_node))
15495 return double_type_node;
15497 if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15498 return build_pointer_type (char_type_node);
15500 if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15501 return build_pointer_type (integer_type_node);
15503 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15504 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15506 if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15507 && (mode == TYPE_MODE (t)))
15509 if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15510 return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15520 type_for_size (bits, unsignedp)
15524 ffeinfoKindtype kt;
15527 if (bits == TYPE_PRECISION (integer_type_node))
15528 return unsignedp ? unsigned_type_node : integer_type_node;
15530 if (bits == TYPE_PRECISION (signed_char_type_node))
15531 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15533 if (bits == TYPE_PRECISION (short_integer_type_node))
15534 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15536 if (bits == TYPE_PRECISION (long_integer_type_node))
15537 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15539 if (bits == TYPE_PRECISION (long_long_integer_type_node))
15540 return (unsignedp ? long_long_unsigned_type_node
15541 : long_long_integer_type_node);
15543 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15545 type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15547 if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15548 return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15556 unsigned_type (type)
15559 tree type1 = TYPE_MAIN_VARIANT (type);
15560 ffeinfoKindtype kt;
15563 if (type1 == signed_char_type_node || type1 == char_type_node)
15564 return unsigned_char_type_node;
15565 if (type1 == integer_type_node)
15566 return unsigned_type_node;
15567 if (type1 == short_integer_type_node)
15568 return short_unsigned_type_node;
15569 if (type1 == long_integer_type_node)
15570 return long_unsigned_type_node;
15571 if (type1 == long_long_integer_type_node)
15572 return long_long_unsigned_type_node;
15573 #if 0 /* gcc/c-* files only */
15574 if (type1 == intDI_type_node)
15575 return unsigned_intDI_type_node;
15576 if (type1 == intSI_type_node)
15577 return unsigned_intSI_type_node;
15578 if (type1 == intHI_type_node)
15579 return unsigned_intHI_type_node;
15580 if (type1 == intQI_type_node)
15581 return unsigned_intQI_type_node;
15584 type2 = type_for_size (TYPE_PRECISION (type1), 1);
15585 if (type2 != NULL_TREE)
15588 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15590 type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15592 if (type1 == type2)
15593 return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15601 union tree_node *t ATTRIBUTE_UNUSED;
15603 if (TREE_CODE (t) == IDENTIFIER_NODE)
15605 struct lang_identifier *i = (struct lang_identifier *) t;
15606 ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15607 ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15608 ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15610 else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15611 ggc_mark (TYPE_LANG_SPECIFIC (t));
15614 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15616 #if FFECOM_GCC_INCLUDE
15618 /* From gcc/cccp.c, the code to handle -I. */
15620 /* Skip leading "./" from a directory name.
15621 This may yield the empty string, which represents the current directory. */
15623 static const char *
15624 skip_redundant_dir_prefix (const char *dir)
15626 while (dir[0] == '.' && dir[1] == '/')
15627 for (dir += 2; *dir == '/'; dir++)
15629 if (dir[0] == '.' && !dir[1])
15634 /* The file_name_map structure holds a mapping of file names for a
15635 particular directory. This mapping is read from the file named
15636 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15637 map filenames on a file system with severe filename restrictions,
15638 such as DOS. The format of the file name map file is just a series
15639 of lines with two tokens on each line. The first token is the name
15640 to map, and the second token is the actual name to use. */
15642 struct file_name_map
15644 struct file_name_map *map_next;
15649 #define FILE_NAME_MAP_FILE "header.gcc"
15651 /* Current maximum length of directory names in the search path
15652 for include files. (Altered as we get more of them.) */
15654 static int max_include_len = 0;
15656 struct file_name_list
15658 struct file_name_list *next;
15660 /* Mapping of file names for this directory. */
15661 struct file_name_map *name_map;
15662 /* Non-zero if name_map is valid. */
15666 static struct file_name_list *include = NULL; /* First dir to search */
15667 static struct file_name_list *last_include = NULL; /* Last in chain */
15669 /* I/O buffer structure.
15670 The `fname' field is nonzero for source files and #include files
15671 and for the dummy text used for -D and -U.
15672 It is zero for rescanning results of macro expansion
15673 and for expanding macro arguments. */
15674 #define INPUT_STACK_MAX 400
15675 static struct file_buf {
15677 /* Filename specified with #line command. */
15678 const char *nominal_fname;
15679 /* Record where in the search path this file was found.
15680 For #include_next. */
15681 struct file_name_list *dir;
15683 ffewhereColumn column;
15684 } instack[INPUT_STACK_MAX];
15686 static int last_error_tick = 0; /* Incremented each time we print it. */
15687 static int input_file_stack_tick = 0; /* Incremented when status changes. */
15689 /* Current nesting level of input sources.
15690 `instack[indepth]' is the level currently being read. */
15691 static int indepth = -1;
15693 typedef struct file_buf FILE_BUF;
15695 typedef unsigned char U_CHAR;
15697 /* table to tell if char can be part of a C identifier. */
15698 U_CHAR is_idchar[256];
15699 /* table to tell if char can be first char of a c identifier. */
15700 U_CHAR is_idstart[256];
15701 /* table to tell if c is horizontal space. */
15702 U_CHAR is_hor_space[256];
15703 /* table to tell if c is horizontal or vertical space. */
15704 static U_CHAR is_space[256];
15706 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15707 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15709 /* Nonzero means -I- has been seen,
15710 so don't look for #include "foo" the source-file directory. */
15711 static int ignore_srcdir;
15713 #ifndef INCLUDE_LEN_FUDGE
15714 #define INCLUDE_LEN_FUDGE 0
15717 static void append_include_chain (struct file_name_list *first,
15718 struct file_name_list *last);
15719 static FILE *open_include_file (char *filename,
15720 struct file_name_list *searchptr);
15721 static void print_containing_files (ffebadSeverity sev);
15722 static const char *skip_redundant_dir_prefix (const char *);
15723 static char *read_filename_string (int ch, FILE *f);
15724 static struct file_name_map *read_name_map (const char *dirname);
15726 /* Append a chain of `struct file_name_list's
15727 to the end of the main include chain.
15728 FIRST is the beginning of the chain to append, and LAST is the end. */
15731 append_include_chain (first, last)
15732 struct file_name_list *first, *last;
15734 struct file_name_list *dir;
15736 if (!first || !last)
15742 last_include->next = first;
15744 for (dir = first; ; dir = dir->next) {
15745 int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15746 if (len > max_include_len)
15747 max_include_len = len;
15753 last_include = last;
15756 /* Try to open include file FILENAME. SEARCHPTR is the directory
15757 being tried from the include file search path. This function maps
15758 filenames on file systems based on information read by
15762 open_include_file (filename, searchptr)
15764 struct file_name_list *searchptr;
15766 register struct file_name_map *map;
15767 register char *from;
15770 if (searchptr && ! searchptr->got_name_map)
15772 searchptr->name_map = read_name_map (searchptr->fname
15773 ? searchptr->fname : ".");
15774 searchptr->got_name_map = 1;
15777 /* First check the mapping for the directory we are using. */
15778 if (searchptr && searchptr->name_map)
15781 if (searchptr->fname)
15782 from += strlen (searchptr->fname) + 1;
15783 for (map = searchptr->name_map; map; map = map->map_next)
15785 if (! strcmp (map->map_from, from))
15787 /* Found a match. */
15788 return fopen (map->map_to, "r");
15793 /* Try to find a mapping file for the particular directory we are
15794 looking in. Thus #include <sys/types.h> will look up sys/types.h
15795 in /usr/include/header.gcc and look up types.h in
15796 /usr/include/sys/header.gcc. */
15797 p = rindex (filename, '/');
15798 #ifdef DIR_SEPARATOR
15799 if (! p) p = rindex (filename, DIR_SEPARATOR);
15801 char *tmp = rindex (filename, DIR_SEPARATOR);
15802 if (tmp != NULL && tmp > p) p = tmp;
15808 && searchptr->fname
15809 && strlen (searchptr->fname) == (size_t) (p - filename)
15810 && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15812 /* FILENAME is in SEARCHPTR, which we've already checked. */
15813 return fopen (filename, "r");
15819 map = read_name_map (".");
15823 dir = (char *) xmalloc (p - filename + 1);
15824 memcpy (dir, filename, p - filename);
15825 dir[p - filename] = '\0';
15827 map = read_name_map (dir);
15830 for (; map; map = map->map_next)
15831 if (! strcmp (map->map_from, from))
15832 return fopen (map->map_to, "r");
15834 return fopen (filename, "r");
15837 /* Print the file names and line numbers of the #include
15838 commands which led to the current file. */
15841 print_containing_files (ffebadSeverity sev)
15843 FILE_BUF *ip = NULL;
15849 /* If stack of files hasn't changed since we last printed
15850 this info, don't repeat it. */
15851 if (last_error_tick == input_file_stack_tick)
15854 for (i = indepth; i >= 0; i--)
15855 if (instack[i].fname != NULL) {
15860 /* Give up if we don't find a source file. */
15864 /* Find the other, outer source files. */
15865 for (i--; i >= 0; i--)
15866 if (instack[i].fname != NULL)
15872 str1 = "In file included";
15884 ffebad_start_msg ("%A from %B at %0%C", sev);
15885 ffebad_here (0, ip->line, ip->column);
15886 ffebad_string (str1);
15887 ffebad_string (ip->nominal_fname);
15888 ffebad_string (str2);
15892 /* Record we have printed the status as of this time. */
15893 last_error_tick = input_file_stack_tick;
15896 /* Read a space delimited string of unlimited length from a stdio
15900 read_filename_string (ch, f)
15908 set = alloc = xmalloc (len + 1);
15909 if (! is_space[ch])
15912 while ((ch = getc (f)) != EOF && ! is_space[ch])
15914 if (set - alloc == len)
15917 alloc = xrealloc (alloc, len + 1);
15918 set = alloc + len / 2;
15928 /* Read the file name map file for DIRNAME. */
15930 static struct file_name_map *
15931 read_name_map (dirname)
15932 const char *dirname;
15934 /* This structure holds a linked list of file name maps, one per
15936 struct file_name_map_list
15938 struct file_name_map_list *map_list_next;
15939 char *map_list_name;
15940 struct file_name_map *map_list_map;
15942 static struct file_name_map_list *map_list;
15943 register struct file_name_map_list *map_list_ptr;
15947 int separator_needed;
15949 dirname = skip_redundant_dir_prefix (dirname);
15951 for (map_list_ptr = map_list; map_list_ptr;
15952 map_list_ptr = map_list_ptr->map_list_next)
15953 if (! strcmp (map_list_ptr->map_list_name, dirname))
15954 return map_list_ptr->map_list_map;
15956 map_list_ptr = ((struct file_name_map_list *)
15957 xmalloc (sizeof (struct file_name_map_list)));
15958 map_list_ptr->map_list_name = xstrdup (dirname);
15959 map_list_ptr->map_list_map = NULL;
15961 dirlen = strlen (dirname);
15962 separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15963 name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15964 strcpy (name, dirname);
15965 name[dirlen] = '/';
15966 strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15967 f = fopen (name, "r");
15970 map_list_ptr->map_list_map = NULL;
15975 while ((ch = getc (f)) != EOF)
15978 struct file_name_map *ptr;
15982 from = read_filename_string (ch, f);
15983 while ((ch = getc (f)) != EOF && is_hor_space[ch])
15985 to = read_filename_string (ch, f);
15987 ptr = ((struct file_name_map *)
15988 xmalloc (sizeof (struct file_name_map)));
15989 ptr->map_from = from;
15991 /* Make the real filename absolute. */
15996 ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15997 strcpy (ptr->map_to, dirname);
15998 ptr->map_to[dirlen] = '/';
15999 strcpy (ptr->map_to + dirlen + separator_needed, to);
16003 ptr->map_next = map_list_ptr->map_list_map;
16004 map_list_ptr->map_list_map = ptr;
16006 while ((ch = getc (f)) != '\n')
16013 map_list_ptr->map_list_next = map_list;
16014 map_list = map_list_ptr;
16016 return map_list_ptr->map_list_map;
16020 ffecom_file_ (const char *name)
16024 /* Do partial setup of input buffer for the sake of generating
16025 early #line directives (when -g is in effect). */
16027 fp = &instack[++indepth];
16028 memset ((char *) fp, 0, sizeof (FILE_BUF));
16031 fp->nominal_fname = fp->fname = name;
16034 /* Initialize syntactic classifications of characters. */
16037 ffecom_initialize_char_syntax_ ()
16042 * Set up is_idchar and is_idstart tables. These should be
16043 * faster than saying (is_alpha (c) || c == '_'), etc.
16044 * Set up these things before calling any routines tthat
16047 for (i = 'a'; i <= 'z'; i++) {
16048 is_idchar[i - 'a' + 'A'] = 1;
16050 is_idstart[i - 'a' + 'A'] = 1;
16053 for (i = '0'; i <= '9'; i++)
16055 is_idchar['_'] = 1;
16056 is_idstart['_'] = 1;
16058 /* horizontal space table */
16059 is_hor_space[' '] = 1;
16060 is_hor_space['\t'] = 1;
16061 is_hor_space['\v'] = 1;
16062 is_hor_space['\f'] = 1;
16063 is_hor_space['\r'] = 1;
16066 is_space['\t'] = 1;
16067 is_space['\v'] = 1;
16068 is_space['\f'] = 1;
16069 is_space['\n'] = 1;
16070 is_space['\r'] = 1;
16074 ffecom_close_include_ (FILE *f)
16079 input_file_stack_tick++;
16081 ffewhere_line_kill (instack[indepth].line);
16082 ffewhere_column_kill (instack[indepth].column);
16086 ffecom_decode_include_option_ (char *spec)
16088 struct file_name_list *dirtmp;
16090 if (! ignore_srcdir && !strcmp (spec, "-"))
16094 dirtmp = (struct file_name_list *)
16095 xmalloc (sizeof (struct file_name_list));
16096 dirtmp->next = 0; /* New one goes on the end */
16098 dirtmp->fname = spec;
16100 fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16101 dirtmp->got_name_map = 0;
16102 append_include_chain (dirtmp, dirtmp);
16107 /* Open INCLUDEd file. */
16110 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16113 size_t flen = strlen (fbeg);
16114 struct file_name_list *search_start = include; /* Chain of dirs to search */
16115 struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16116 struct file_name_list *searchptr = 0;
16117 char *fname; /* Dynamically allocated fname buffer */
16124 dsp[0].fname = NULL;
16126 /* If -I- was specified, don't search current dir, only spec'd ones. */
16127 if (!ignore_srcdir)
16129 for (fp = &instack[indepth]; fp >= instack; fp--)
16135 if ((nam = fp->nominal_fname) != NULL)
16137 /* Found a named file. Figure out dir of the file,
16138 and put it in front of the search list. */
16139 dsp[0].next = search_start;
16140 search_start = dsp;
16142 ep = rindex (nam, '/');
16143 #ifdef DIR_SEPARATOR
16144 if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR);
16146 char *tmp = rindex (nam, DIR_SEPARATOR);
16147 if (tmp != NULL && tmp > ep) ep = tmp;
16151 ep = rindex (nam, ']');
16152 if (ep == NULL) ep = rindex (nam, '>');
16153 if (ep == NULL) ep = rindex (nam, ':');
16154 if (ep != NULL) ep++;
16159 dsp[0].fname = (char *) xmalloc (n + 1);
16160 strncpy (dsp[0].fname, nam, n);
16161 dsp[0].fname[n] = '\0';
16162 if (n + INCLUDE_LEN_FUDGE > max_include_len)
16163 max_include_len = n + INCLUDE_LEN_FUDGE;
16166 dsp[0].fname = NULL; /* Current directory */
16167 dsp[0].got_name_map = 0;
16173 /* Allocate this permanently, because it gets stored in the definitions
16175 fname = xmalloc (max_include_len + flen + 4);
16176 /* + 2 above for slash and terminating null. */
16177 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16180 /* If specified file name is absolute, just open it. */
16183 #ifdef DIR_SEPARATOR
16184 || *fbeg == DIR_SEPARATOR
16188 strncpy (fname, (char *) fbeg, flen);
16190 f = open_include_file (fname, NULL_PTR);
16196 /* Search directory path, trying to open the file.
16197 Copy each filename tried into FNAME. */
16199 for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16201 if (searchptr->fname)
16203 /* The empty string in a search path is ignored.
16204 This makes it possible to turn off entirely
16205 a standard piece of the list. */
16206 if (searchptr->fname[0] == 0)
16208 strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16209 if (fname[0] && fname[strlen (fname) - 1] != '/')
16210 strcat (fname, "/");
16211 fname[strlen (fname) + flen] = 0;
16216 strncat (fname, fbeg, flen);
16218 /* Change this 1/2 Unix 1/2 VMS file specification into a
16219 full VMS file specification */
16220 if (searchptr->fname && (searchptr->fname[0] != 0))
16222 /* Fix up the filename */
16223 hack_vms_include_specification (fname);
16227 /* This is a normal VMS filespec, so use it unchanged. */
16228 strncpy (fname, (char *) fbeg, flen);
16230 #if 0 /* Not for g77. */
16231 /* if it's '#include filename', add the missing .h */
16232 if (index (fname, '.') == NULL)
16233 strcat (fname, ".h");
16237 f = open_include_file (fname, searchptr);
16239 if (f == NULL && errno == EACCES)
16241 print_containing_files (FFEBAD_severityWARNING);
16242 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16243 FFEBAD_severityWARNING);
16244 ffebad_string (fname);
16245 ffebad_here (0, l, c);
16256 /* A file that was not found. */
16258 strncpy (fname, (char *) fbeg, flen);
16260 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16261 ffebad_start (FFEBAD_OPEN_INCLUDE);
16262 ffebad_here (0, l, c);
16263 ffebad_string (fname);
16267 if (dsp[0].fname != NULL)
16268 free (dsp[0].fname);
16273 if (indepth >= (INPUT_STACK_MAX - 1))
16275 print_containing_files (FFEBAD_severityFATAL);
16276 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16277 FFEBAD_severityFATAL);
16278 ffebad_string (fname);
16279 ffebad_here (0, l, c);
16284 instack[indepth].line = ffewhere_line_use (l);
16285 instack[indepth].column = ffewhere_column_use (c);
16287 fp = &instack[indepth + 1];
16288 memset ((char *) fp, 0, sizeof (FILE_BUF));
16289 fp->nominal_fname = fp->fname = fname;
16290 fp->dir = searchptr;
16293 input_file_stack_tick++;
16297 #endif /* FFECOM_GCC_INCLUDE */
16299 /**INDENT* (Do not reformat this comment even with -fca option.)
16300 Data-gathering files: Given the source file listed below, compiled with
16301 f2c I obtained the output file listed after that, and from the output
16302 file I derived the above code.
16304 -------- (begin input file to f2c)
16310 double precision D1,D2
16312 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16339 c FFEINTRIN_impACOS
16340 call fooR(ACOS(R1))
16341 c FFEINTRIN_impAIMAG
16342 call fooR(AIMAG(C1))
16343 c FFEINTRIN_impAINT
16344 call fooR(AINT(R1))
16345 c FFEINTRIN_impALOG
16346 call fooR(ALOG(R1))
16347 c FFEINTRIN_impALOG10
16348 call fooR(ALOG10(R1))
16349 c FFEINTRIN_impAMAX0
16350 call fooR(AMAX0(I1,I2))
16351 c FFEINTRIN_impAMAX1
16352 call fooR(AMAX1(R1,R2))
16353 c FFEINTRIN_impAMIN0
16354 call fooR(AMIN0(I1,I2))
16355 c FFEINTRIN_impAMIN1
16356 call fooR(AMIN1(R1,R2))
16357 c FFEINTRIN_impAMOD
16358 call fooR(AMOD(R1,R2))
16359 c FFEINTRIN_impANINT
16360 call fooR(ANINT(R1))
16361 c FFEINTRIN_impASIN
16362 call fooR(ASIN(R1))
16363 c FFEINTRIN_impATAN
16364 call fooR(ATAN(R1))
16365 c FFEINTRIN_impATAN2
16366 call fooR(ATAN2(R1,R2))
16367 c FFEINTRIN_impCABS
16368 call fooR(CABS(C1))
16369 c FFEINTRIN_impCCOS
16370 call fooC(CCOS(C1))
16371 c FFEINTRIN_impCEXP
16372 call fooC(CEXP(C1))
16373 c FFEINTRIN_impCHAR
16374 call fooA(CHAR(I1))
16375 c FFEINTRIN_impCLOG
16376 call fooC(CLOG(C1))
16377 c FFEINTRIN_impCONJG
16378 call fooC(CONJG(C1))
16381 c FFEINTRIN_impCOSH
16382 call fooR(COSH(R1))
16383 c FFEINTRIN_impCSIN
16384 call fooC(CSIN(C1))
16385 c FFEINTRIN_impCSQRT
16386 call fooC(CSQRT(C1))
16387 c FFEINTRIN_impDABS
16388 call fooD(DABS(D1))
16389 c FFEINTRIN_impDACOS
16390 call fooD(DACOS(D1))
16391 c FFEINTRIN_impDASIN
16392 call fooD(DASIN(D1))
16393 c FFEINTRIN_impDATAN
16394 call fooD(DATAN(D1))
16395 c FFEINTRIN_impDATAN2
16396 call fooD(DATAN2(D1,D2))
16397 c FFEINTRIN_impDCOS
16398 call fooD(DCOS(D1))
16399 c FFEINTRIN_impDCOSH
16400 call fooD(DCOSH(D1))
16401 c FFEINTRIN_impDDIM
16402 call fooD(DDIM(D1,D2))
16403 c FFEINTRIN_impDEXP
16404 call fooD(DEXP(D1))
16406 call fooR(DIM(R1,R2))
16407 c FFEINTRIN_impDINT
16408 call fooD(DINT(D1))
16409 c FFEINTRIN_impDLOG
16410 call fooD(DLOG(D1))
16411 c FFEINTRIN_impDLOG10
16412 call fooD(DLOG10(D1))
16413 c FFEINTRIN_impDMAX1
16414 call fooD(DMAX1(D1,D2))
16415 c FFEINTRIN_impDMIN1
16416 call fooD(DMIN1(D1,D2))
16417 c FFEINTRIN_impDMOD
16418 call fooD(DMOD(D1,D2))
16419 c FFEINTRIN_impDNINT
16420 call fooD(DNINT(D1))
16421 c FFEINTRIN_impDPROD
16422 call fooD(DPROD(R1,R2))
16423 c FFEINTRIN_impDSIGN
16424 call fooD(DSIGN(D1,D2))
16425 c FFEINTRIN_impDSIN
16426 call fooD(DSIN(D1))
16427 c FFEINTRIN_impDSINH
16428 call fooD(DSINH(D1))
16429 c FFEINTRIN_impDSQRT
16430 call fooD(DSQRT(D1))
16431 c FFEINTRIN_impDTAN
16432 call fooD(DTAN(D1))
16433 c FFEINTRIN_impDTANH
16434 call fooD(DTANH(D1))
16437 c FFEINTRIN_impIABS
16438 call fooI(IABS(I1))
16439 c FFEINTRIN_impICHAR
16440 call fooI(ICHAR(A1))
16441 c FFEINTRIN_impIDIM
16442 call fooI(IDIM(I1,I2))
16443 c FFEINTRIN_impIDNINT
16444 call fooI(IDNINT(D1))
16445 c FFEINTRIN_impINDEX
16446 call fooI(INDEX(A1,A2))
16447 c FFEINTRIN_impISIGN
16448 call fooI(ISIGN(I1,I2))
16452 call fooL(LGE(A1,A2))
16454 call fooL(LGT(A1,A2))
16456 call fooL(LLE(A1,A2))
16458 call fooL(LLT(A1,A2))
16459 c FFEINTRIN_impMAX0
16460 call fooI(MAX0(I1,I2))
16461 c FFEINTRIN_impMAX1
16462 call fooI(MAX1(R1,R2))
16463 c FFEINTRIN_impMIN0
16464 call fooI(MIN0(I1,I2))
16465 c FFEINTRIN_impMIN1
16466 call fooI(MIN1(R1,R2))
16468 call fooI(MOD(I1,I2))
16469 c FFEINTRIN_impNINT
16470 call fooI(NINT(R1))
16471 c FFEINTRIN_impSIGN
16472 call fooR(SIGN(R1,R2))
16475 c FFEINTRIN_impSINH
16476 call fooR(SINH(R1))
16477 c FFEINTRIN_impSQRT
16478 call fooR(SQRT(R1))
16481 c FFEINTRIN_impTANH
16482 call fooR(TANH(R1))
16483 c FFEINTRIN_imp_CMPLX_C
16484 call fooC(cmplx(C1,C2))
16485 c FFEINTRIN_imp_CMPLX_D
16486 call fooZ(cmplx(D1,D2))
16487 c FFEINTRIN_imp_CMPLX_I
16488 call fooC(cmplx(I1,I2))
16489 c FFEINTRIN_imp_CMPLX_R
16490 call fooC(cmplx(R1,R2))
16491 c FFEINTRIN_imp_DBLE_C
16492 call fooD(dble(C1))
16493 c FFEINTRIN_imp_DBLE_D
16494 call fooD(dble(D1))
16495 c FFEINTRIN_imp_DBLE_I
16496 call fooD(dble(I1))
16497 c FFEINTRIN_imp_DBLE_R
16498 call fooD(dble(R1))
16499 c FFEINTRIN_imp_INT_C
16501 c FFEINTRIN_imp_INT_D
16503 c FFEINTRIN_imp_INT_I
16505 c FFEINTRIN_imp_INT_R
16507 c FFEINTRIN_imp_REAL_C
16508 call fooR(real(C1))
16509 c FFEINTRIN_imp_REAL_D
16510 call fooR(real(D1))
16511 c FFEINTRIN_imp_REAL_I
16512 call fooR(real(I1))
16513 c FFEINTRIN_imp_REAL_R
16514 call fooR(real(R1))
16516 c FFEINTRIN_imp_INT_D:
16518 c FFEINTRIN_specIDINT
16519 call fooI(IDINT(D1))
16521 c FFEINTRIN_imp_INT_R:
16523 c FFEINTRIN_specIFIX
16524 call fooI(IFIX(R1))
16525 c FFEINTRIN_specINT
16528 c FFEINTRIN_imp_REAL_D:
16530 c FFEINTRIN_specSNGL
16531 call fooR(SNGL(D1))
16533 c FFEINTRIN_imp_REAL_I:
16535 c FFEINTRIN_specFLOAT
16536 call fooR(FLOAT(I1))
16537 c FFEINTRIN_specREAL
16538 call fooR(REAL(I1))
16541 -------- (end input file to f2c)
16543 -------- (begin output from providing above input file as input to:
16544 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16545 -------- -e "s:^#.*$::g"')
16547 // -- translated by f2c (version 19950223).
16548 You must link the resulting object file with the libraries:
16549 -lf2c -lm (in that order)
16553 // f2c.h -- Standard Fortran to C header file //
16555 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
16557 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16562 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16563 // we assume short, float are OK //
16564 typedef long int // long int // integer;
16565 typedef char *address;
16566 typedef short int shortint;
16567 typedef float real;
16568 typedef double doublereal;
16569 typedef struct { real r, i; } complex;
16570 typedef struct { doublereal r, i; } doublecomplex;
16571 typedef long int // long int // logical;
16572 typedef short int shortlogical;
16573 typedef char logical1;
16574 typedef char integer1;
16575 // typedef long long longint; // // system-dependent //
16580 // Extern is for use with -E //
16594 typedef long int // int or long int // flag;
16595 typedef long int // int or long int // ftnlen;
16596 typedef long int // int or long int // ftnint;
16599 //external read, write//
16608 //internal read, write//
16638 //rewind, backspace, endfile//
16650 ftnint *inex; //parameters in standard's order//
16676 union Multitype { // for multiple entry points //
16687 typedef union Multitype Multitype;
16689 typedef long Long; // No longer used; formerly in Namelist //
16691 struct Vardesc { // for Namelist //
16697 typedef struct Vardesc Vardesc;
16704 typedef struct Namelist Namelist;
16713 // procedure parameter types for -A and -C++ //
16718 typedef int // Unknown procedure type // (*U_fp)();
16719 typedef shortint (*J_fp)();
16720 typedef integer (*I_fp)();
16721 typedef real (*R_fp)();
16722 typedef doublereal (*D_fp)(), (*E_fp)();
16723 typedef // Complex // void (*C_fp)();
16724 typedef // Double Complex // void (*Z_fp)();
16725 typedef logical (*L_fp)();
16726 typedef shortlogical (*K_fp)();
16727 typedef // Character // void (*H_fp)();
16728 typedef // Subroutine // int (*S_fp)();
16730 // E_fp is for real functions when -R is not specified //
16731 typedef void C_f; // complex function //
16732 typedef void H_f; // character function //
16733 typedef void Z_f; // double complex function //
16734 typedef doublereal E_f; // real function with -R not specified //
16736 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16739 // (No such symbols should be defined in a strict ANSI C compiler.
16740 We can avoid trouble with f2c-translated code by using
16741 gcc -ansi [-traditional].) //
16765 // Main program // MAIN__()
16767 // System generated locals //
16770 doublereal d__1, d__2;
16772 doublecomplex z__1, z__2, z__3;
16776 // Builtin functions //
16779 double pow_ri(), pow_di();
16783 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16784 asin(), atan(), atan2(), c_abs();
16785 void c_cos(), c_exp(), c_log(), r_cnjg();
16786 double cos(), cosh();
16787 void c_sin(), c_sqrt();
16788 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16789 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16790 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16791 logical l_ge(), l_gt(), l_le(), l_lt();
16795 // Local variables //
16796 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16797 fool_(), fooz_(), getem_();
16798 static char a1[10], a2[10];
16799 static complex c1, c2;
16800 static doublereal d1, d2;
16801 static integer i1, i2;
16802 static real r1, r2;
16805 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16813 d__1 = (doublereal) i1;
16814 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16824 c_div(&q__1, &c1, &c2);
16826 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16828 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16831 i__1 = pow_ii(&i1, &i2);
16833 r__1 = pow_ri(&r1, &i1);
16835 d__1 = pow_di(&d1, &i1);
16837 pow_ci(&q__1, &c1, &i1);
16839 d__1 = (doublereal) r1;
16840 d__2 = (doublereal) r2;
16841 r__1 = pow_dd(&d__1, &d__2);
16843 d__2 = (doublereal) r1;
16844 d__1 = pow_dd(&d__2, &d1);
16846 d__1 = pow_dd(&d1, &d2);
16848 d__2 = (doublereal) r1;
16849 d__1 = pow_dd(&d1, &d__2);
16851 z__2.r = c1.r, z__2.i = c1.i;
16852 z__3.r = c2.r, z__3.i = c2.i;
16853 pow_zz(&z__1, &z__2, &z__3);
16854 q__1.r = z__1.r, q__1.i = z__1.i;
16856 z__2.r = c1.r, z__2.i = c1.i;
16857 z__3.r = r1, z__3.i = 0.;
16858 pow_zz(&z__1, &z__2, &z__3);
16859 q__1.r = z__1.r, q__1.i = z__1.i;
16861 z__2.r = c1.r, z__2.i = c1.i;
16862 z__3.r = d1, z__3.i = 0.;
16863 pow_zz(&z__1, &z__2, &z__3);
16865 // FFEINTRIN_impABS //
16866 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16868 // FFEINTRIN_impACOS //
16871 // FFEINTRIN_impAIMAG //
16872 r__1 = r_imag(&c1);
16874 // FFEINTRIN_impAINT //
16877 // FFEINTRIN_impALOG //
16880 // FFEINTRIN_impALOG10 //
16881 r__1 = r_lg10(&r1);
16883 // FFEINTRIN_impAMAX0 //
16884 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16886 // FFEINTRIN_impAMAX1 //
16887 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16889 // FFEINTRIN_impAMIN0 //
16890 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16892 // FFEINTRIN_impAMIN1 //
16893 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16895 // FFEINTRIN_impAMOD //
16896 r__1 = r_mod(&r1, &r2);
16898 // FFEINTRIN_impANINT //
16899 r__1 = r_nint(&r1);
16901 // FFEINTRIN_impASIN //
16904 // FFEINTRIN_impATAN //
16907 // FFEINTRIN_impATAN2 //
16908 r__1 = atan2(r1, r2);
16910 // FFEINTRIN_impCABS //
16913 // FFEINTRIN_impCCOS //
16916 // FFEINTRIN_impCEXP //
16919 // FFEINTRIN_impCHAR //
16920 *(unsigned char *)&ch__1[0] = i1;
16922 // FFEINTRIN_impCLOG //
16925 // FFEINTRIN_impCONJG //
16926 r_cnjg(&q__1, &c1);
16928 // FFEINTRIN_impCOS //
16931 // FFEINTRIN_impCOSH //
16934 // FFEINTRIN_impCSIN //
16937 // FFEINTRIN_impCSQRT //
16938 c_sqrt(&q__1, &c1);
16940 // FFEINTRIN_impDABS //
16941 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16943 // FFEINTRIN_impDACOS //
16946 // FFEINTRIN_impDASIN //
16949 // FFEINTRIN_impDATAN //
16952 // FFEINTRIN_impDATAN2 //
16953 d__1 = atan2(d1, d2);
16955 // FFEINTRIN_impDCOS //
16958 // FFEINTRIN_impDCOSH //
16961 // FFEINTRIN_impDDIM //
16962 d__1 = d_dim(&d1, &d2);
16964 // FFEINTRIN_impDEXP //
16967 // FFEINTRIN_impDIM //
16968 r__1 = r_dim(&r1, &r2);
16970 // FFEINTRIN_impDINT //
16973 // FFEINTRIN_impDLOG //
16976 // FFEINTRIN_impDLOG10 //
16977 d__1 = d_lg10(&d1);
16979 // FFEINTRIN_impDMAX1 //
16980 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16982 // FFEINTRIN_impDMIN1 //
16983 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16985 // FFEINTRIN_impDMOD //
16986 d__1 = d_mod(&d1, &d2);
16988 // FFEINTRIN_impDNINT //
16989 d__1 = d_nint(&d1);
16991 // FFEINTRIN_impDPROD //
16992 d__1 = (doublereal) r1 * r2;
16994 // FFEINTRIN_impDSIGN //
16995 d__1 = d_sign(&d1, &d2);
16997 // FFEINTRIN_impDSIN //
17000 // FFEINTRIN_impDSINH //
17003 // FFEINTRIN_impDSQRT //
17006 // FFEINTRIN_impDTAN //
17009 // FFEINTRIN_impDTANH //
17012 // FFEINTRIN_impEXP //
17015 // FFEINTRIN_impIABS //
17016 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
17018 // FFEINTRIN_impICHAR //
17019 i__1 = *(unsigned char *)a1;
17021 // FFEINTRIN_impIDIM //
17022 i__1 = i_dim(&i1, &i2);
17024 // FFEINTRIN_impIDNINT //
17025 i__1 = i_dnnt(&d1);
17027 // FFEINTRIN_impINDEX //
17028 i__1 = i_indx(a1, a2, 10L, 10L);
17030 // FFEINTRIN_impISIGN //
17031 i__1 = i_sign(&i1, &i2);
17033 // FFEINTRIN_impLEN //
17034 i__1 = i_len(a1, 10L);
17036 // FFEINTRIN_impLGE //
17037 L__1 = l_ge(a1, a2, 10L, 10L);
17039 // FFEINTRIN_impLGT //
17040 L__1 = l_gt(a1, a2, 10L, 10L);
17042 // FFEINTRIN_impLLE //
17043 L__1 = l_le(a1, a2, 10L, 10L);
17045 // FFEINTRIN_impLLT //
17046 L__1 = l_lt(a1, a2, 10L, 10L);
17048 // FFEINTRIN_impMAX0 //
17049 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17051 // FFEINTRIN_impMAX1 //
17052 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
17054 // FFEINTRIN_impMIN0 //
17055 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17057 // FFEINTRIN_impMIN1 //
17058 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
17060 // FFEINTRIN_impMOD //
17063 // FFEINTRIN_impNINT //
17064 i__1 = i_nint(&r1);
17066 // FFEINTRIN_impSIGN //
17067 r__1 = r_sign(&r1, &r2);
17069 // FFEINTRIN_impSIN //
17072 // FFEINTRIN_impSINH //
17075 // FFEINTRIN_impSQRT //
17078 // FFEINTRIN_impTAN //
17081 // FFEINTRIN_impTANH //
17084 // FFEINTRIN_imp_CMPLX_C //
17087 q__1.r = r__1, q__1.i = r__2;
17089 // FFEINTRIN_imp_CMPLX_D //
17090 z__1.r = d1, z__1.i = d2;
17092 // FFEINTRIN_imp_CMPLX_I //
17095 q__1.r = r__1, q__1.i = r__2;
17097 // FFEINTRIN_imp_CMPLX_R //
17098 q__1.r = r1, q__1.i = r2;
17100 // FFEINTRIN_imp_DBLE_C //
17101 d__1 = (doublereal) c1.r;
17103 // FFEINTRIN_imp_DBLE_D //
17106 // FFEINTRIN_imp_DBLE_I //
17107 d__1 = (doublereal) i1;
17109 // FFEINTRIN_imp_DBLE_R //
17110 d__1 = (doublereal) r1;
17112 // FFEINTRIN_imp_INT_C //
17113 i__1 = (integer) c1.r;
17115 // FFEINTRIN_imp_INT_D //
17116 i__1 = (integer) d1;
17118 // FFEINTRIN_imp_INT_I //
17121 // FFEINTRIN_imp_INT_R //
17122 i__1 = (integer) r1;
17124 // FFEINTRIN_imp_REAL_C //
17127 // FFEINTRIN_imp_REAL_D //
17130 // FFEINTRIN_imp_REAL_I //
17133 // FFEINTRIN_imp_REAL_R //
17137 // FFEINTRIN_imp_INT_D: //
17139 // FFEINTRIN_specIDINT //
17140 i__1 = (integer) d1;
17143 // FFEINTRIN_imp_INT_R: //
17145 // FFEINTRIN_specIFIX //
17146 i__1 = (integer) r1;
17148 // FFEINTRIN_specINT //
17149 i__1 = (integer) r1;
17152 // FFEINTRIN_imp_REAL_D: //
17154 // FFEINTRIN_specSNGL //
17158 // FFEINTRIN_imp_REAL_I: //
17160 // FFEINTRIN_specFLOAT //
17163 // FFEINTRIN_specREAL //
17169 -------- (end output file from f2c)