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):
58 yes = suspend_momentary ();
59 if (is_nested) push_f_function_context ();
60 start_function (get_identifier ("function_name"), function_type,
61 is_nested, is_public);
62 // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
63 store_parm_decls (is_main_program);
64 ffecom_start_compstmt ();
65 // for stmts and decls inside function, do appropriate things;
66 ffecom_end_compstmt ();
67 finish_function (is_nested);
68 if (is_nested) pop_f_function_context ();
69 if (is_nested) resume_momentary (yes);
75 yes = suspend_momentary ();
76 // fill in external, public, static, &c for decl, and
77 // set DECL_INITIAL to error_mark_node if going to initialize
78 // set is_top_level TRUE only if not at top level and decl
79 // must go in top level (i.e. not within current function decl context)
80 d = start_decl (decl, is_top_level);
81 init = ...; // if have initializer
82 finish_decl (d, init, is_top_level);
83 resume_momentary (yes);
90 #if FFECOM_targetCURRENT == FFECOM_targetGCC
95 #include "output.h" /* Must follow tree.h so TREE_CODE is defined! */
99 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
101 #define FFECOM_GCC_INCLUDE 1 /* Enable -I. */
103 /* BEGIN stuff from gcc/cccp.c. */
105 /* The following symbols should be autoconfigured:
112 In the mean time, we'll get by with approximations based
113 on existing GCC configuration symbols. */
116 # ifndef HAVE_STDLIB_H
117 # define HAVE_STDLIB_H 1
119 # ifndef HAVE_UNISTD_H
120 # define HAVE_UNISTD_H 1
122 # ifndef STDC_HEADERS
123 # define STDC_HEADERS 1
125 #endif /* defined (POSIX) */
127 #if defined (POSIX) || (defined (USG) && !defined (VMS))
128 # ifndef HAVE_FCNTL_H
129 # define HAVE_FCNTL_H 1
136 # if TIME_WITH_SYS_TIME
137 # include <sys/time.h>
141 # include <sys/time.h>
146 # include <sys/resource.h>
153 /* This defines "errno" properly for VMS, and gives us EACCES. */
166 /* VMS-specific definitions */
169 #define O_RDONLY 0 /* Open arg for Read/Only */
170 #define O_WRONLY 1 /* Open arg for Write/Only */
171 #define read(fd,buf,size) VMS_read (fd,buf,size)
172 #define write(fd,buf,size) VMS_write (fd,buf,size)
173 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
174 #define fopen(fname,mode) VMS_fopen (fname,mode)
175 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
176 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
177 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
178 static int VMS_fstat (), VMS_stat ();
179 static char * VMS_strncat ();
180 static int VMS_read ();
181 static int VMS_write ();
182 static int VMS_open ();
183 static FILE * VMS_fopen ();
184 static FILE * VMS_freopen ();
185 static void hack_vms_include_specification ();
186 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
187 #define ino_t vms_ino_t
188 #define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */
190 #define BSTRING /* VMS/GCC supplies the bstring routines */
191 #endif /* __GNUC__ */
198 /* END stuff from gcc/cccp.c. */
200 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
217 /* Externals defined here. */
219 #if FFECOM_targetCURRENT == FFECOM_targetGCC
221 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
224 const char * const language_string = "GNU F77";
226 /* Stream for reading from the input file. */
229 /* These definitions parallel those in c-decl.c so that code from that
230 module can be used pretty much as is. Much of these defs aren't
231 otherwise used, i.e. by g77 code per se, except some of them are used
232 to build some of them that are. The ones that are global (i.e. not
233 "static") are those that ste.c and such might use (directly
234 or by using com macros that reference them in their definitions). */
236 tree string_type_node;
238 /* The rest of these are inventions for g77, though there might be
239 similar things in the C front end. As they are found, these
240 inventions should be renamed to be canonical. Note that only
241 the ones currently required to be global are so. */
243 static tree ffecom_tree_fun_type_void;
245 tree ffecom_integer_type_node; /* Abbrev for _tree_type[blah][blah]. */
246 tree ffecom_integer_zero_node; /* Like *_*_* with g77's integer type. */
247 tree ffecom_integer_one_node; /* " */
248 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
250 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
251 just use build_function_type and build_pointer_type on the
252 appropriate _tree_type array element. */
254 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
255 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
256 static tree ffecom_tree_subr_type;
257 static tree ffecom_tree_ptr_to_subr_type;
258 static tree ffecom_tree_blockdata_type;
260 static tree ffecom_tree_xargc_;
262 ffecomSymbol ffecom_symbol_null_
271 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
272 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
274 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
275 tree ffecom_f2c_integer_type_node;
276 tree ffecom_f2c_ptr_to_integer_type_node;
277 tree ffecom_f2c_address_type_node;
278 tree ffecom_f2c_real_type_node;
279 tree ffecom_f2c_ptr_to_real_type_node;
280 tree ffecom_f2c_doublereal_type_node;
281 tree ffecom_f2c_complex_type_node;
282 tree ffecom_f2c_doublecomplex_type_node;
283 tree ffecom_f2c_longint_type_node;
284 tree ffecom_f2c_logical_type_node;
285 tree ffecom_f2c_flag_type_node;
286 tree ffecom_f2c_ftnlen_type_node;
287 tree ffecom_f2c_ftnlen_zero_node;
288 tree ffecom_f2c_ftnlen_one_node;
289 tree ffecom_f2c_ftnlen_two_node;
290 tree ffecom_f2c_ptr_to_ftnlen_type_node;
291 tree ffecom_f2c_ftnint_type_node;
292 tree ffecom_f2c_ptr_to_ftnint_type_node;
293 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
295 /* Simple definitions and enumerations. */
297 #ifndef FFECOM_sizeMAXSTACKITEM
298 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
299 larger than this # bytes
300 off stack if possible. */
303 /* For systems that have large enough stacks, they should define
304 this to 0, and here, for ease of use later on, we just undefine
307 #if FFECOM_sizeMAXSTACKITEM == 0
308 #undef FFECOM_sizeMAXSTACKITEM
314 FFECOM_rttypeVOIDSTAR_, /* C's `void *' type. */
315 FFECOM_rttypeFTNINT_, /* f2c's `ftnint' type. */
316 FFECOM_rttypeINTEGER_, /* f2c's `integer' type. */
317 FFECOM_rttypeLONGINT_, /* f2c's `longint' type. */
318 FFECOM_rttypeLOGICAL_, /* f2c's `logical' type. */
319 FFECOM_rttypeREAL_F2C_, /* f2c's `real' returned as `double'. */
320 FFECOM_rttypeREAL_GNU_, /* `real' returned as such. */
321 FFECOM_rttypeCOMPLEX_F2C_, /* f2c's `complex' returned via 1st arg. */
322 FFECOM_rttypeCOMPLEX_GNU_, /* f2c's `complex' returned directly. */
323 FFECOM_rttypeDOUBLE_, /* C's `double' type. */
324 FFECOM_rttypeDOUBLEREAL_, /* f2c's `doublereal' type. */
325 FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
326 FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
327 FFECOM_rttypeCHARACTER_, /* f2c `char *'/`ftnlen' pair. */
331 /* Internal typedefs. */
333 #if FFECOM_targetCURRENT == FFECOM_targetGCC
334 typedef struct _ffecom_concat_list_ ffecomConcatList_;
335 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
337 /* Private include files. */
340 /* Internal structure definitions. */
342 #if FFECOM_targetCURRENT == FFECOM_targetGCC
343 struct _ffecom_concat_list_
348 ffetargetCharacterSize minlen;
349 ffetargetCharacterSize maxlen;
351 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
353 /* Static functions (internal). */
355 #if FFECOM_targetCURRENT == FFECOM_targetGCC
356 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
357 static tree ffecom_widest_expr_type_ (ffebld list);
358 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
359 tree dest_size, tree source_tree,
360 ffebld source, bool scalar_arg);
361 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
362 tree args, tree callee_commons,
364 static tree ffecom_build_f2c_string_ (int i, const char *s);
365 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
366 bool is_f2c_complex, tree type,
367 tree args, tree dest_tree,
368 ffebld dest, bool *dest_used,
369 tree callee_commons, bool scalar_args, tree hook);
370 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
371 bool is_f2c_complex, tree type,
372 ffebld left, ffebld right,
373 tree dest_tree, ffebld dest,
374 bool *dest_used, tree callee_commons,
375 bool scalar_args, bool ref, tree hook);
376 static void ffecom_char_args_x_ (tree *xitem, tree *length,
377 ffebld expr, bool with_null);
378 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
379 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
380 static ffecomConcatList_
381 ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
383 ffetargetCharacterSize max);
384 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
385 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
386 ffetargetCharacterSize max);
387 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
388 ffesymbol member, tree member_type,
389 ffetargetOffset offset);
390 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
391 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
392 bool *dest_used, bool assignp, bool widenp);
393 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
394 ffebld dest, bool *dest_used);
395 static tree ffecom_expr_power_integer_ (ffebld expr);
396 static void ffecom_expr_transform_ (ffebld expr);
397 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
398 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
400 static ffeglobal ffecom_finish_global_ (ffeglobal global);
401 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
402 static tree ffecom_get_appended_identifier_ (char us, const char *text);
403 static tree ffecom_get_external_identifier_ (ffesymbol s);
404 static tree ffecom_get_identifier_ (const char *text);
405 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
408 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
409 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
410 static tree ffecom_init_zero_ (tree decl);
411 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
413 static tree ffecom_intrinsic_len_ (ffebld expr);
414 static void ffecom_let_char_ (tree dest_tree,
416 ffetargetCharacterSize dest_size,
418 static void ffecom_make_gfrt_ (ffecomGfrt ix);
419 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
420 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
421 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
423 static void ffecom_push_dummy_decls_ (ffebld dumlist,
425 static void ffecom_start_progunit_ (void);
426 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
427 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
428 static void ffecom_transform_common_ (ffesymbol s);
429 static void ffecom_transform_equiv_ (ffestorag st);
430 static tree ffecom_transform_namelist_ (ffesymbol s);
431 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
433 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
434 tree *size, tree tree);
435 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
436 tree dest_tree, ffebld dest,
437 bool *dest_used, tree hook);
438 static tree ffecom_type_localvar_ (ffesymbol s,
441 static tree ffecom_type_namelist_ (void);
442 static tree ffecom_type_vardesc_ (void);
443 static tree ffecom_vardesc_ (ffebld expr);
444 static tree ffecom_vardesc_array_ (ffesymbol s);
445 static tree ffecom_vardesc_dims_ (ffesymbol s);
446 static tree ffecom_convert_narrow_ (tree type, tree expr);
447 static tree ffecom_convert_widen_ (tree type, tree expr);
448 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
450 /* These are static functions that parallel those found in the C front
451 end and thus have the same names. */
453 #if FFECOM_targetCURRENT == FFECOM_targetGCC
454 static tree bison_rule_compstmt_ (void);
455 static void bison_rule_pushlevel_ (void);
456 static void delete_block (tree block);
457 static int duplicate_decls (tree newdecl, tree olddecl);
458 static void finish_decl (tree decl, tree init, bool is_top_level);
459 static void finish_function (int nested);
460 static const char *lang_printable_name (tree decl, int v);
461 static tree lookup_name_current_level (tree name);
462 static struct binding_level *make_binding_level (void);
463 static void pop_f_function_context (void);
464 static void push_f_function_context (void);
465 static void push_parm_decl (tree parm);
466 static tree pushdecl_top_level (tree decl);
467 static int kept_level_p (void);
468 static tree storedecls (tree decls);
469 static void store_parm_decls (int is_main_program);
470 static tree start_decl (tree decl, bool is_top_level);
471 static void start_function (tree name, tree type, int nested, int public);
472 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
473 #if FFECOM_GCC_INCLUDE
474 static void ffecom_file_ (const char *name);
475 static void ffecom_initialize_char_syntax_ (void);
476 static void ffecom_close_include_ (FILE *f);
477 static int ffecom_decode_include_option_ (char *spec);
478 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
480 #endif /* FFECOM_GCC_INCLUDE */
482 /* Static objects accessed by functions in this module. */
484 static ffesymbol ffecom_primary_entry_ = NULL;
485 static ffesymbol ffecom_nested_entry_ = NULL;
486 static ffeinfoKind ffecom_primary_entry_kind_;
487 static bool ffecom_primary_entry_is_proc_;
488 #if FFECOM_targetCURRENT == FFECOM_targetGCC
489 static tree ffecom_outer_function_decl_;
490 static tree ffecom_previous_function_decl_;
491 static tree ffecom_which_entrypoint_decl_;
492 static tree ffecom_float_zero_ = NULL_TREE;
493 static tree ffecom_float_half_ = NULL_TREE;
494 static tree ffecom_double_zero_ = NULL_TREE;
495 static tree ffecom_double_half_ = NULL_TREE;
496 static tree ffecom_func_result_;/* For functions. */
497 static tree ffecom_func_length_;/* For CHARACTER fns. */
498 static ffebld ffecom_list_blockdata_;
499 static ffebld ffecom_list_common_;
500 static ffebld ffecom_master_arglist_;
501 static ffeinfoBasictype ffecom_master_bt_;
502 static ffeinfoKindtype ffecom_master_kt_;
503 static ffetargetCharacterSize ffecom_master_size_;
504 static int ffecom_num_fns_ = 0;
505 static int ffecom_num_entrypoints_ = 0;
506 static bool ffecom_is_altreturning_ = FALSE;
507 static tree ffecom_multi_type_node_;
508 static tree ffecom_multi_retval_;
510 ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
511 static bool ffecom_member_namelisted_; /* _member_phase1_ namelisted? */
512 static bool ffecom_doing_entry_ = FALSE;
513 static bool ffecom_transform_only_dummies_ = FALSE;
514 static int ffecom_typesize_pointer_;
515 static int ffecom_typesize_integer1_;
517 /* Holds pointer-to-function expressions. */
519 static tree ffecom_gfrt_[FFECOM_gfrt]
522 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
523 #include "com-rt.def"
527 /* Holds the external names of the functions. */
529 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
532 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
533 #include "com-rt.def"
537 /* Whether the function returns. */
539 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
542 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
543 #include "com-rt.def"
547 /* Whether the function returns type complex. */
549 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
552 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
553 #include "com-rt.def"
557 /* Whether the function is const
558 (i.e., has no side effects and only depends on its arguments). */
560 static bool ffecom_gfrt_const_[FFECOM_gfrt]
563 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
564 #include "com-rt.def"
568 /* Type code for the function return value. */
570 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
573 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
574 #include "com-rt.def"
578 /* String of codes for the function's arguments. */
580 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
583 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
584 #include "com-rt.def"
587 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
589 /* Internal macros. */
591 #if FFECOM_targetCURRENT == FFECOM_targetGCC
593 /* We let tm.h override the types used here, to handle trivial differences
594 such as the choice of unsigned int or long unsigned int for size_t.
595 When machines start needing nontrivial differences in the size type,
596 it would be best to do something here to figure out automatically
597 from other information what type to use. */
600 #define SIZE_TYPE "long unsigned int"
603 #define ffecom_concat_list_count_(catlist) ((catlist).count)
604 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
605 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
606 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
608 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
609 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
611 /* For each binding contour we allocate a binding_level structure
612 * which records the names defined in that contour.
615 * 1) one for each function definition,
616 * where internal declarations of the parameters appear.
618 * The current meaning of a name can be found by searching the levels from
619 * the current one out to the global one.
622 /* Note that the information in the `names' component of the global contour
623 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
627 /* A chain of _DECL nodes for all variables, constants, functions,
628 and typedef types. These are in the reverse of the order supplied.
632 /* For each level (except not the global one),
633 a chain of BLOCK nodes for all the levels
634 that were entered and exited one level down. */
637 /* The BLOCK node for this level, if one has been preallocated.
638 If 0, the BLOCK is allocated (if needed) when the level is popped. */
641 /* The binding level which this one is contained in (inherits from). */
642 struct binding_level *level_chain;
644 /* 0: no ffecom_prepare_* functions called at this level yet;
645 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
646 2: ffecom_prepare_end called. */
650 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
652 /* The binding level currently in effect. */
654 static struct binding_level *current_binding_level;
656 /* A chain of binding_level structures awaiting reuse. */
658 static struct binding_level *free_binding_level;
660 /* The outermost binding level, for names of file scope.
661 This is created when the compiler is started and exists
662 through the entire run. */
664 static struct binding_level *global_binding_level;
666 /* Binding level structures are initialized by copying this one. */
668 static struct binding_level clear_binding_level
670 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
672 /* Language-dependent contents of an identifier. */
674 struct lang_identifier
676 struct tree_identifier ignore;
677 tree global_value, local_value, label_value;
681 /* Macros for access to language-specific slots in an identifier. */
682 /* Each of these slots contains a DECL node or null. */
684 /* This represents the value which the identifier has in the
685 file-scope namespace. */
686 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
687 (((struct lang_identifier *)(NODE))->global_value)
688 /* This represents the value which the identifier has in the current
690 #define IDENTIFIER_LOCAL_VALUE(NODE) \
691 (((struct lang_identifier *)(NODE))->local_value)
692 /* This represents the value which the identifier has as a label in
693 the current label scope. */
694 #define IDENTIFIER_LABEL_VALUE(NODE) \
695 (((struct lang_identifier *)(NODE))->label_value)
696 /* This is nonzero if the identifier was "made up" by g77 code. */
697 #define IDENTIFIER_INVENTED(NODE) \
698 (((struct lang_identifier *)(NODE))->invented)
700 /* In identifiers, C uses the following fields in a special way:
701 TREE_PUBLIC to record that there was a previous local extern decl.
702 TREE_USED to record that such a decl was used.
703 TREE_ADDRESSABLE to record that the address of such a decl was used. */
705 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
706 that have names. Here so we can clear out their names' definitions
707 at the end of the function. */
709 static tree named_labels;
711 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
713 static tree shadowed_labels;
715 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
717 /* Return the subscript expression, modified to do range-checking.
719 `array' is the array to be checked against.
720 `element' is the subscript expression to check.
721 `dim' is the dimension number (starting at 0).
722 `total_dims' is the total number of dimensions (0 for CHARACTER substring).
726 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
727 const char *array_name)
729 tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
730 tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
735 if (element == error_mark_node)
738 if (TREE_TYPE (low) != TREE_TYPE (element))
740 if (TYPE_PRECISION (TREE_TYPE (low))
741 > TYPE_PRECISION (TREE_TYPE (element)))
742 element = convert (TREE_TYPE (low), element);
745 low = convert (TREE_TYPE (element), low);
747 high = convert (TREE_TYPE (element), high);
751 element = ffecom_save_tree (element);
752 cond = ffecom_2 (LE_EXPR, integer_type_node,
757 cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
759 ffecom_2 (LE_EXPR, integer_type_node,
776 var = xmalloc (strlen (array_name) + 20);
777 sprintf (var, "%s[%s-substring]",
779 dim ? "end" : "start");
780 len = strlen (var) + 1;
781 arg1 = build_string (len, var);
786 len = strlen (array_name) + 1;
787 arg1 = build_string (len, array_name);
791 var = xmalloc (strlen (array_name) + 40);
792 sprintf (var, "%s[subscript-%d-of-%d]",
794 dim + 1, total_dims);
795 len = strlen (var) + 1;
796 arg1 = build_string (len, var);
802 = build_type_variant (build_array_type (char_type_node,
806 build_int_2 (len, 0))),
808 TREE_CONSTANT (arg1) = 1;
809 TREE_STATIC (arg1) = 1;
810 arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
813 /* s_rnge adds one to the element to print it, so bias against
814 that -- want to print a faithful *subscript* value. */
815 arg2 = convert (ffecom_f2c_ftnint_type_node,
816 ffecom_2 (MINUS_EXPR,
819 convert (TREE_TYPE (element),
822 proc = xmalloc ((len = strlen (input_filename)
823 + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl))
826 sprintf (&proc[0], "%s/%s",
828 IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
829 arg3 = build_string (len, proc);
834 = build_type_variant (build_array_type (char_type_node,
838 build_int_2 (len, 0))),
840 TREE_CONSTANT (arg3) = 1;
841 TREE_STATIC (arg3) = 1;
842 arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
845 arg4 = convert (ffecom_f2c_ftnint_type_node,
846 build_int_2 (lineno, 0));
848 arg1 = build_tree_list (NULL_TREE, arg1);
849 arg2 = build_tree_list (NULL_TREE, arg2);
850 arg3 = build_tree_list (NULL_TREE, arg3);
851 arg4 = build_tree_list (NULL_TREE, arg4);
852 TREE_CHAIN (arg3) = arg4;
853 TREE_CHAIN (arg2) = arg3;
854 TREE_CHAIN (arg1) = arg2;
858 die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
860 TREE_SIDE_EFFECTS (die) = 1;
862 element = ffecom_3 (COND_EXPR,
871 /* Return the computed element of an array reference.
873 `item' is NULL_TREE, or the transformed pointer to the array.
874 `expr' is the original opARRAYREF expression, which is transformed
875 if `item' is NULL_TREE.
876 `want_ptr' is non-zero if a pointer to the element, instead of
877 the element itself, is to be returned. */
880 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
882 ffebld dims[FFECOM_dimensionsMAX];
885 int flatten = ffe_is_flatten_arrays ();
891 const char *array_name;
895 if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
896 array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
898 array_name = "[expr?]";
900 /* Build up ARRAY_REFs in reverse order (since we're column major
901 here in Fortran land). */
903 for (i = 0, list = ffebld_right (expr);
905 ++i, list = ffebld_trail (list))
907 dims[i] = ffebld_head (list);
908 type = ffeinfo_type (ffebld_basictype (dims[i]),
909 ffebld_kindtype (dims[i]));
911 && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
912 && ffetype_size (type) > ffecom_typesize_integer1_)
913 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
914 pointers and 32-bit integers. Do the full 64-bit pointer
915 arithmetic, for codes using arrays for nonstandard heap-like
922 need_ptr = want_ptr || flatten;
927 item = ffecom_ptr_to_expr (ffebld_left (expr));
929 item = ffecom_expr (ffebld_left (expr));
931 if (item == error_mark_node)
934 if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
935 && ! mark_addressable (item))
936 return error_mark_node;
939 if (item == error_mark_node)
946 for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
948 --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
950 min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
951 element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
952 if (flag_bounds_check)
953 element = ffecom_subscript_check_ (array, element, i, total_dims,
955 if (element == error_mark_node)
958 /* Widen integral arithmetic as desired while preserving
960 tree_type = TREE_TYPE (element);
961 tree_type_x = tree_type;
963 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
964 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
965 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
967 if (TREE_TYPE (min) != tree_type_x)
968 min = convert (tree_type_x, min);
969 if (TREE_TYPE (element) != tree_type_x)
970 element = convert (tree_type_x, element);
972 item = ffecom_2 (PLUS_EXPR,
973 build_pointer_type (TREE_TYPE (array)),
975 size_binop (MULT_EXPR,
976 size_in_bytes (TREE_TYPE (array)),
978 fold (build (MINUS_EXPR,
984 item = ffecom_1 (INDIRECT_REF,
985 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
995 array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
997 element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
998 if (flag_bounds_check)
999 element = ffecom_subscript_check_ (array, element, i, total_dims,
1001 if (element == error_mark_node)
1004 /* Widen integral arithmetic as desired while preserving
1006 tree_type = TREE_TYPE (element);
1007 tree_type_x = tree_type;
1009 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
1010 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
1011 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
1013 element = convert (tree_type_x, element);
1015 item = ffecom_2 (ARRAY_REF,
1016 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
1025 /* This is like gcc's stabilize_reference -- in fact, most of the code
1026 comes from that -- but it handles the situation where the reference
1027 is going to have its subparts picked at, and it shouldn't change
1028 (or trigger extra invocations of functions in the subtrees) due to
1029 this. save_expr is a bit overzealous, because we don't need the
1030 entire thing calculated and saved like a temp. So, for DECLs, no
1031 change is needed, because these are stable aggregates, and ARRAY_REF
1032 and such might well be stable too, but for things like calculations,
1033 we do need to calculate a snapshot of a value before picking at it. */
1035 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1037 ffecom_stabilize_aggregate_ (tree ref)
1040 enum tree_code code = TREE_CODE (ref);
1047 /* No action is needed in this case. */
1053 case FIX_TRUNC_EXPR:
1054 case FIX_FLOOR_EXPR:
1055 case FIX_ROUND_EXPR:
1057 result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1061 result = build_nt (INDIRECT_REF,
1062 stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1066 result = build_nt (COMPONENT_REF,
1067 stabilize_reference (TREE_OPERAND (ref, 0)),
1068 TREE_OPERAND (ref, 1));
1072 result = build_nt (BIT_FIELD_REF,
1073 stabilize_reference (TREE_OPERAND (ref, 0)),
1074 stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1075 stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1079 result = build_nt (ARRAY_REF,
1080 stabilize_reference (TREE_OPERAND (ref, 0)),
1081 stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1085 result = build_nt (COMPOUND_EXPR,
1086 stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1087 stabilize_reference (TREE_OPERAND (ref, 1)));
1091 result = build1 (INDIRECT_REF, TREE_TYPE (ref),
1092 save_expr (build1 (ADDR_EXPR,
1093 build_pointer_type (TREE_TYPE (ref)),
1099 return save_expr (ref);
1102 return error_mark_node;
1105 TREE_TYPE (result) = TREE_TYPE (ref);
1106 TREE_READONLY (result) = TREE_READONLY (ref);
1107 TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1108 TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1114 /* A rip-off of gcc's convert.c convert_to_complex function,
1115 reworked to handle complex implemented as C structures
1116 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1118 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1120 ffecom_convert_to_complex_ (tree type, tree expr)
1122 register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1125 assert (TREE_CODE (type) == RECORD_TYPE);
1127 subtype = TREE_TYPE (TYPE_FIELDS (type));
1129 if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1131 expr = convert (subtype, expr);
1132 return ffecom_2 (COMPLEX_EXPR, type, expr,
1133 convert (subtype, integer_zero_node));
1136 if (form == RECORD_TYPE)
1138 tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1139 if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1143 expr = save_expr (expr);
1144 return ffecom_2 (COMPLEX_EXPR,
1147 ffecom_1 (REALPART_EXPR,
1148 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1151 ffecom_1 (IMAGPART_EXPR,
1152 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1157 if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1158 error ("pointer value used where a complex was expected");
1160 error ("aggregate value used where a complex was expected");
1162 return ffecom_2 (COMPLEX_EXPR, type,
1163 convert (subtype, integer_zero_node),
1164 convert (subtype, integer_zero_node));
1168 /* Like gcc's convert(), but crashes if widening might happen. */
1170 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1172 ffecom_convert_narrow_ (type, expr)
1175 register tree e = expr;
1176 register enum tree_code code = TREE_CODE (type);
1178 if (type == TREE_TYPE (e)
1179 || TREE_CODE (e) == ERROR_MARK)
1181 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1182 return fold (build1 (NOP_EXPR, type, e));
1183 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1184 || code == ERROR_MARK)
1185 return error_mark_node;
1186 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1188 assert ("void value not ignored as it ought to be" == NULL);
1189 return error_mark_node;
1191 assert (code != VOID_TYPE);
1192 if ((code != RECORD_TYPE)
1193 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1194 assert ("converting COMPLEX to REAL" == NULL);
1195 assert (code != ENUMERAL_TYPE);
1196 if (code == INTEGER_TYPE)
1198 assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1199 && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1200 || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1201 && (TYPE_PRECISION (type)
1202 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1203 return fold (convert_to_integer (type, e));
1205 if (code == POINTER_TYPE)
1207 assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1208 return fold (convert_to_pointer (type, e));
1210 if (code == REAL_TYPE)
1212 assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1213 assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1214 return fold (convert_to_real (type, e));
1216 if (code == COMPLEX_TYPE)
1218 assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1219 assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1220 return fold (convert_to_complex (type, e));
1222 if (code == RECORD_TYPE)
1224 assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1225 /* Check that at least the first field name agrees. */
1226 assert (DECL_NAME (TYPE_FIELDS (type))
1227 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1228 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1229 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1230 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1231 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1233 return fold (ffecom_convert_to_complex_ (type, e));
1236 assert ("conversion to non-scalar type requested" == NULL);
1237 return error_mark_node;
1241 /* Like gcc's convert(), but crashes if narrowing might happen. */
1243 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1245 ffecom_convert_widen_ (type, expr)
1248 register tree e = expr;
1249 register enum tree_code code = TREE_CODE (type);
1251 if (type == TREE_TYPE (e)
1252 || TREE_CODE (e) == ERROR_MARK)
1254 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1255 return fold (build1 (NOP_EXPR, type, e));
1256 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1257 || code == ERROR_MARK)
1258 return error_mark_node;
1259 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1261 assert ("void value not ignored as it ought to be" == NULL);
1262 return error_mark_node;
1264 assert (code != VOID_TYPE);
1265 if ((code != RECORD_TYPE)
1266 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1267 assert ("narrowing COMPLEX to REAL" == NULL);
1268 assert (code != ENUMERAL_TYPE);
1269 if (code == INTEGER_TYPE)
1271 assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1272 && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1273 || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1274 && (TYPE_PRECISION (type)
1275 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1276 return fold (convert_to_integer (type, e));
1278 if (code == POINTER_TYPE)
1280 assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1281 return fold (convert_to_pointer (type, e));
1283 if (code == REAL_TYPE)
1285 assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1286 assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1287 return fold (convert_to_real (type, e));
1289 if (code == COMPLEX_TYPE)
1291 assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1292 assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1293 return fold (convert_to_complex (type, e));
1295 if (code == RECORD_TYPE)
1297 assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1298 /* Check that at least the first field name agrees. */
1299 assert (DECL_NAME (TYPE_FIELDS (type))
1300 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1301 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1302 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1303 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1304 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1306 return fold (ffecom_convert_to_complex_ (type, e));
1309 assert ("conversion to non-scalar type requested" == NULL);
1310 return error_mark_node;
1314 /* Handles making a COMPLEX type, either the standard
1315 (but buggy?) gbe way, or the safer (but less elegant?)
1318 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1320 ffecom_make_complex_type_ (tree subtype)
1326 if (ffe_is_emulate_complex ())
1328 type = make_node (RECORD_TYPE);
1329 realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1330 imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1331 TYPE_FIELDS (type) = realfield;
1336 type = make_node (COMPLEX_TYPE);
1337 TREE_TYPE (type) = subtype;
1345 /* Chooses either the gbe or the f2c way to build a
1346 complex constant. */
1348 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1350 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1354 if (ffe_is_emulate_complex ())
1356 bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1357 TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1358 bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1362 bothparts = build_complex (type, realpart, imagpart);
1369 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1371 ffecom_arglist_expr_ (const char *c, ffebld expr)
1374 tree *plist = &list;
1375 tree trail = NULL_TREE; /* Append char length args here. */
1376 tree *ptrail = &trail;
1381 tree wanted = NULL_TREE;
1382 static char zed[] = "0";
1387 while (expr != NULL)
1410 wanted = ffecom_f2c_complex_type_node;
1414 wanted = ffecom_f2c_doublereal_type_node;
1418 wanted = ffecom_f2c_doublecomplex_type_node;
1422 wanted = ffecom_f2c_real_type_node;
1426 wanted = ffecom_f2c_integer_type_node;
1430 wanted = ffecom_f2c_longint_type_node;
1434 assert ("bad argstring code" == NULL);
1440 exprh = ffebld_head (expr);
1444 if ((wanted == NULL_TREE)
1447 (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1448 [ffeinfo_kindtype (ffebld_info (exprh))])
1449 == TYPE_MODE (wanted))))
1451 = build_tree_list (NULL_TREE,
1452 ffecom_arg_ptr_to_expr (exprh,
1456 item = ffecom_arg_expr (exprh, &length);
1457 item = ffecom_convert_widen_ (wanted, item);
1460 item = ffecom_1 (ADDR_EXPR,
1461 build_pointer_type (TREE_TYPE (item)),
1465 = build_tree_list (NULL_TREE,
1469 plist = &TREE_CHAIN (*plist);
1470 expr = ffebld_trail (expr);
1471 if (length != NULL_TREE)
1473 *ptrail = build_tree_list (NULL_TREE, length);
1474 ptrail = &TREE_CHAIN (*ptrail);
1478 /* We've run out of args in the call; if the implementation expects
1479 more, supply null pointers for them, which the implementation can
1480 check to see if an arg was omitted. */
1482 while (*c != '\0' && *c != '0')
1487 assert ("missing arg to run-time routine!" == NULL);
1502 assert ("bad arg string code" == NULL);
1506 = build_tree_list (NULL_TREE,
1508 plist = &TREE_CHAIN (*plist);
1517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1519 ffecom_widest_expr_type_ (ffebld list)
1522 ffebld widest = NULL;
1524 ffetype widest_type = NULL;
1527 for (; list != NULL; list = ffebld_trail (list))
1529 item = ffebld_head (list);
1532 if ((widest != NULL)
1533 && (ffeinfo_basictype (ffebld_info (item))
1534 != ffeinfo_basictype (ffebld_info (widest))))
1536 type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1537 ffeinfo_kindtype (ffebld_info (item)));
1538 if ((widest == FFEINFO_kindtypeNONE)
1539 || (ffetype_size (type)
1540 > ffetype_size (widest_type)))
1547 assert (widest != NULL);
1548 t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1549 [ffeinfo_kindtype (ffebld_info (widest))];
1550 assert (t != NULL_TREE);
1555 /* Check whether a partial overlap between two expressions is possible.
1557 Can *starting* to write a portion of expr1 change the value
1558 computed (perhaps already, *partially*) by expr2?
1560 Currently, this is a concern only for a COMPLEX expr1. But if it
1561 isn't in COMMON or local EQUIVALENCE, since we don't support
1562 aliasing of arguments, it isn't a concern. */
1565 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1570 switch (ffebld_op (expr1))
1572 case FFEBLD_opSYMTER:
1573 sym = ffebld_symter (expr1);
1576 case FFEBLD_opARRAYREF:
1577 if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1579 sym = ffebld_symter (ffebld_left (expr1));
1586 if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1587 && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1588 || ! (st = ffesymbol_storage (sym))
1589 || ! ffestorag_parent (st)))
1592 /* It's in COMMON or local EQUIVALENCE. */
1597 /* Check whether dest and source might overlap. ffebld versions of these
1598 might or might not be passed, will be NULL if not.
1600 The test is really whether source_tree is modifiable and, if modified,
1601 might overlap destination such that the value(s) in the destination might
1602 change before it is finally modified. dest_* are the canonized
1603 destination itself. */
1605 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1607 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1608 tree source_tree, ffebld source UNUSED,
1616 if (source_tree == NULL_TREE)
1619 switch (TREE_CODE (source_tree))
1622 case IDENTIFIER_NODE:
1633 case TRUNC_DIV_EXPR:
1635 case FLOOR_DIV_EXPR:
1636 case ROUND_DIV_EXPR:
1637 case TRUNC_MOD_EXPR:
1639 case FLOOR_MOD_EXPR:
1640 case ROUND_MOD_EXPR:
1642 case EXACT_DIV_EXPR:
1643 case FIX_TRUNC_EXPR:
1645 case FIX_FLOOR_EXPR:
1646 case FIX_ROUND_EXPR:
1661 case BIT_ANDTC_EXPR:
1663 case TRUTH_ANDIF_EXPR:
1664 case TRUTH_ORIF_EXPR:
1665 case TRUTH_AND_EXPR:
1667 case TRUTH_XOR_EXPR:
1668 case TRUTH_NOT_EXPR:
1684 return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1685 TREE_OPERAND (source_tree, 1), NULL,
1689 return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1690 TREE_OPERAND (source_tree, 0), NULL,
1695 case NON_LVALUE_EXPR:
1697 if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1700 ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1702 source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1707 ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1708 TREE_OPERAND (source_tree, 1), NULL,
1710 || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1711 TREE_OPERAND (source_tree, 2), NULL,
1716 ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1718 TREE_OPERAND (source_tree, 0));
1722 if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1725 source_decl = source_tree;
1726 source_offset = bitsize_zero_node;
1727 source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1731 case REFERENCE_EXPR:
1732 case PREDECREMENT_EXPR:
1733 case PREINCREMENT_EXPR:
1734 case POSTDECREMENT_EXPR:
1735 case POSTINCREMENT_EXPR:
1743 /* Come here when source_decl, source_offset, and source_size filled
1744 in appropriately. */
1746 if (source_decl == NULL_TREE)
1747 return FALSE; /* No decl involved, so no overlap. */
1749 if (source_decl != dest_decl)
1750 return FALSE; /* Different decl, no overlap. */
1752 if (TREE_CODE (dest_size) == ERROR_MARK)
1753 return TRUE; /* Assignment into entire assumed-size
1754 array? Shouldn't happen.... */
1756 t = ffecom_2 (LE_EXPR, integer_type_node,
1757 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1759 convert (TREE_TYPE (dest_offset),
1761 convert (TREE_TYPE (dest_offset),
1764 if (integer_onep (t))
1765 return FALSE; /* Destination precedes source. */
1768 || (source_size == NULL_TREE)
1769 || (TREE_CODE (source_size) == ERROR_MARK)
1770 || integer_zerop (source_size))
1771 return TRUE; /* No way to tell if dest follows source. */
1773 t = ffecom_2 (LE_EXPR, integer_type_node,
1774 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1776 convert (TREE_TYPE (source_offset),
1778 convert (TREE_TYPE (source_offset),
1781 if (integer_onep (t))
1782 return FALSE; /* Destination follows source. */
1784 return TRUE; /* Destination and source overlap. */
1788 /* Check whether dest might overlap any of a list of arguments or is
1789 in a COMMON area the callee might know about (and thus modify). */
1791 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1793 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1794 tree args, tree callee_commons,
1802 ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1805 if (dest_decl == NULL_TREE)
1806 return FALSE; /* Seems unlikely! */
1808 /* If the decl cannot be determined reliably, or if its in COMMON
1809 and the callee isn't known to not futz with COMMON via other
1810 means, overlap might happen. */
1812 if ((TREE_CODE (dest_decl) == ERROR_MARK)
1813 || ((callee_commons != NULL_TREE)
1814 && TREE_PUBLIC (dest_decl)))
1817 for (; args != NULL_TREE; args = TREE_CHAIN (args))
1819 if (((arg = TREE_VALUE (args)) != NULL_TREE)
1820 && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1821 arg, NULL, scalar_args))
1829 /* Build a string for a variable name as used by NAMELIST. This means that
1830 if we're using the f2c library, we build an uppercase string, since
1833 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1835 ffecom_build_f2c_string_ (int i, const char *s)
1837 if (!ffe_is_f2c_library ())
1838 return build_string (i, s);
1847 if (((size_t) i) > ARRAY_SIZE (space))
1848 tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1852 for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1853 *q = ffesrc_toupper (*p);
1856 t = build_string (i, tmp);
1858 if (((size_t) i) > ARRAY_SIZE (space))
1859 malloc_kill_ks (malloc_pool_image (), tmp, i);
1866 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1867 type to just get whatever the function returns), handling the
1868 f2c value-returning convention, if required, by prepending
1869 to the arglist a pointer to a temporary to receive the return value. */
1871 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1873 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1874 tree type, tree args, tree dest_tree,
1875 ffebld dest, bool *dest_used, tree callee_commons,
1876 bool scalar_args, tree hook)
1881 if (dest_used != NULL)
1886 if ((dest_used == NULL)
1888 || (ffeinfo_basictype (ffebld_info (dest))
1889 != FFEINFO_basictypeCOMPLEX)
1890 || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1891 || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1892 || ffecom_args_overlapping_ (dest_tree, dest, args,
1897 tempvar = ffecom_make_tempvar (ffecom_tree_type
1898 [FFEINFO_basictypeCOMPLEX][kt],
1899 FFETARGET_charactersizeNONE,
1909 tempvar = dest_tree;
1914 = build_tree_list (NULL_TREE,
1915 ffecom_1 (ADDR_EXPR,
1916 build_pointer_type (TREE_TYPE (tempvar)),
1918 TREE_CHAIN (item) = args;
1920 item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1923 if (tempvar != dest_tree)
1924 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1927 item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1930 if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1931 item = ffecom_convert_narrow_ (type, item);
1937 /* Given two arguments, transform them and make a call to the given
1938 function via ffecom_call_. */
1940 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1942 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1943 tree type, ffebld left, ffebld right,
1944 tree dest_tree, ffebld dest, bool *dest_used,
1945 tree callee_commons, bool scalar_args, bool ref, tree hook)
1954 /* Pass arguments by reference. */
1955 left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1956 right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1960 /* Pass arguments by value. */
1961 left_tree = ffecom_arg_expr (left, &left_length);
1962 right_tree = ffecom_arg_expr (right, &right_length);
1966 left_tree = build_tree_list (NULL_TREE, left_tree);
1967 right_tree = build_tree_list (NULL_TREE, right_tree);
1968 TREE_CHAIN (left_tree) = right_tree;
1970 if (left_length != NULL_TREE)
1972 left_length = build_tree_list (NULL_TREE, left_length);
1973 TREE_CHAIN (right_tree) = left_length;
1976 if (right_length != NULL_TREE)
1978 right_length = build_tree_list (NULL_TREE, right_length);
1979 if (left_length != NULL_TREE)
1980 TREE_CHAIN (left_length) = right_length;
1982 TREE_CHAIN (right_tree) = right_length;
1985 return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1986 dest_tree, dest, dest_used, callee_commons,
1991 /* Return ptr/length args for char subexpression
1993 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1994 subexpressions by constructing the appropriate trees for the ptr-to-
1995 character-text and length-of-character-text arguments in a calling
1998 Note that if with_null is TRUE, and the expression is an opCONTER,
1999 a null byte is appended to the string. */
2001 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2003 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
2007 ffetargetCharacter1 val;
2008 ffetargetCharacterSize newlen;
2010 switch (ffebld_op (expr))
2012 case FFEBLD_opCONTER:
2013 val = ffebld_constant_character1 (ffebld_conter (expr));
2014 newlen = ffetarget_length_character1 (val);
2017 /* Begin FFETARGET-NULL-KLUDGE. */
2021 *length = build_int_2 (newlen, 0);
2022 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2023 high = build_int_2 (newlen, 0);
2024 TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
2025 item = build_string (newlen,
2026 ffetarget_text_character1 (val));
2027 /* End FFETARGET-NULL-KLUDGE. */
2029 = build_type_variant
2033 (ffecom_f2c_ftnlen_type_node,
2034 ffecom_f2c_ftnlen_one_node,
2037 TREE_CONSTANT (item) = 1;
2038 TREE_STATIC (item) = 1;
2039 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
2043 case FFEBLD_opSYMTER:
2045 ffesymbol s = ffebld_symter (expr);
2047 item = ffesymbol_hook (s).decl_tree;
2048 if (item == NULL_TREE)
2050 s = ffecom_sym_transform_ (s);
2051 item = ffesymbol_hook (s).decl_tree;
2053 if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
2055 if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
2056 *length = ffesymbol_hook (s).length_tree;
2059 *length = build_int_2 (ffesymbol_size (s), 0);
2060 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2063 else if (item == error_mark_node)
2064 *length = error_mark_node;
2066 /* FFEINFO_kindFUNCTION. */
2067 *length = NULL_TREE;
2068 if (!ffesymbol_hook (s).addr
2069 && (item != error_mark_node))
2070 item = ffecom_1 (ADDR_EXPR,
2071 build_pointer_type (TREE_TYPE (item)),
2076 case FFEBLD_opARRAYREF:
2078 ffecom_char_args_ (&item, length, ffebld_left (expr));
2080 if (item == error_mark_node || *length == error_mark_node)
2082 item = *length = error_mark_node;
2086 item = ffecom_arrayref_ (item, expr, 1);
2090 case FFEBLD_opSUBSTR:
2094 ffebld thing = ffebld_right (expr);
2097 const char *char_name;
2101 assert (ffebld_op (thing) == FFEBLD_opITEM);
2102 start = ffebld_head (thing);
2103 thing = ffebld_trail (thing);
2104 assert (ffebld_trail (thing) == NULL);
2105 end = ffebld_head (thing);
2107 /* Determine name for pretty-printing range-check errors. */
2108 for (left_symter = ffebld_left (expr);
2109 left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2110 left_symter = ffebld_left (left_symter))
2112 if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2113 char_name = ffesymbol_text (ffebld_symter (left_symter));
2115 char_name = "[expr?]";
2117 ffecom_char_args_ (&item, length, ffebld_left (expr));
2119 if (item == error_mark_node || *length == error_mark_node)
2121 item = *length = error_mark_node;
2125 array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2127 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2135 end_tree = ffecom_expr (end);
2136 if (flag_bounds_check)
2137 end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2139 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2142 if (end_tree == error_mark_node)
2144 item = *length = error_mark_node;
2153 start_tree = ffecom_expr (start);
2154 if (flag_bounds_check)
2155 start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2157 start_tree = convert (ffecom_f2c_ftnlen_type_node,
2160 if (start_tree == error_mark_node)
2162 item = *length = error_mark_node;
2166 start_tree = ffecom_save_tree (start_tree);
2168 item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2170 ffecom_2 (MINUS_EXPR,
2171 TREE_TYPE (start_tree),
2173 ffecom_f2c_ftnlen_one_node));
2177 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2178 ffecom_f2c_ftnlen_one_node,
2179 ffecom_2 (MINUS_EXPR,
2180 ffecom_f2c_ftnlen_type_node,
2186 end_tree = ffecom_expr (end);
2187 if (flag_bounds_check)
2188 end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2190 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2193 if (end_tree == error_mark_node)
2195 item = *length = error_mark_node;
2199 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2200 ffecom_f2c_ftnlen_one_node,
2201 ffecom_2 (MINUS_EXPR,
2202 ffecom_f2c_ftnlen_type_node,
2203 end_tree, start_tree));
2209 case FFEBLD_opFUNCREF:
2211 ffesymbol s = ffebld_symter (ffebld_left (expr));
2214 ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2217 if (size == FFETARGET_charactersizeNONE)
2218 /* ~~Kludge alert! This should someday be fixed. */
2221 *length = build_int_2 (size, 0);
2222 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2224 if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2225 == FFEINFO_whereINTRINSIC)
2229 /* Invocation of an intrinsic returning CHARACTER*1. */
2230 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2234 ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2235 assert (ix != FFECOM_gfrt);
2236 item = ffecom_gfrt_tree_ (ix);
2241 item = ffesymbol_hook (s).decl_tree;
2242 if (item == NULL_TREE)
2244 s = ffecom_sym_transform_ (s);
2245 item = ffesymbol_hook (s).decl_tree;
2247 if (item == error_mark_node)
2249 item = *length = error_mark_node;
2253 if (!ffesymbol_hook (s).addr)
2254 item = ffecom_1_fn (item);
2258 tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2260 tempvar = ffebld_nonter_hook (expr);
2263 tempvar = ffecom_1 (ADDR_EXPR,
2264 build_pointer_type (TREE_TYPE (tempvar)),
2267 args = build_tree_list (NULL_TREE, tempvar);
2269 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT) /* Sfunc args by value. */
2270 TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2273 TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2274 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2276 TREE_CHAIN (TREE_CHAIN (args))
2277 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2278 ffebld_right (expr));
2282 TREE_CHAIN (TREE_CHAIN (args))
2283 = ffecom_list_ptr_to_expr (ffebld_right (expr));
2287 item = ffecom_3s (CALL_EXPR,
2288 TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2289 item, args, NULL_TREE);
2290 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2295 case FFEBLD_opCONVERT:
2297 ffecom_char_args_ (&item, length, ffebld_left (expr));
2299 if (item == error_mark_node || *length == error_mark_node)
2301 item = *length = error_mark_node;
2305 if ((ffebld_size_known (ffebld_left (expr))
2306 == FFETARGET_charactersizeNONE)
2307 || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2308 { /* Possible blank-padding needed, copy into
2315 tempvar = ffecom_make_tempvar (char_type_node,
2316 ffebld_size (expr), -1);
2318 tempvar = ffebld_nonter_hook (expr);
2321 tempvar = ffecom_1 (ADDR_EXPR,
2322 build_pointer_type (TREE_TYPE (tempvar)),
2325 newlen = build_int_2 (ffebld_size (expr), 0);
2326 TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2328 args = build_tree_list (NULL_TREE, tempvar);
2329 TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2330 TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2331 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2332 = build_tree_list (NULL_TREE, *length);
2334 item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2335 TREE_SIDE_EFFECTS (item) = 1;
2336 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2341 { /* Just truncate the length. */
2342 *length = build_int_2 (ffebld_size (expr), 0);
2343 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2348 assert ("bad op for single char arg expr" == NULL);
2357 /* Check the size of the type to be sure it doesn't overflow the
2358 "portable" capacities of the compiler back end. `dummy' types
2359 can generally overflow the normal sizes as long as the computations
2360 themselves don't overflow. A particular target of the back end
2361 must still enforce its size requirements, though, and the back
2362 end takes care of this in stor-layout.c. */
2364 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2366 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2368 if (TREE_CODE (type) == ERROR_MARK)
2371 if (TYPE_SIZE (type) == NULL_TREE)
2374 if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2377 if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2378 || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2379 || TREE_OVERFLOW (TYPE_SIZE (type)))))
2381 ffebad_start (FFEBAD_ARRAY_LARGE);
2382 ffebad_string (ffesymbol_text (s));
2383 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2386 return error_mark_node;
2393 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2394 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2395 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2397 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2399 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2401 ffetargetCharacterSize sz = ffesymbol_size (s);
2406 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2407 tlen = NULL_TREE; /* A statement function, no length passed. */
2410 if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2411 tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2412 ffesymbol_text (s));
2414 tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2415 tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2417 DECL_ARTIFICIAL (tlen) = 1;
2421 if (sz == FFETARGET_charactersizeNONE)
2423 assert (tlen != NULL_TREE);
2424 highval = variable_size (tlen);
2428 highval = build_int_2 (sz, 0);
2429 TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2432 type = build_array_type (type,
2433 build_range_type (ffecom_f2c_ftnlen_type_node,
2434 ffecom_f2c_ftnlen_one_node,
2442 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2444 ffecomConcatList_ catlist;
2445 ffebld expr; // expr of CHARACTER basictype.
2446 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2447 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2449 Scans expr for character subexpressions, updates and returns catlist
2452 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2453 static ffecomConcatList_
2454 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2455 ffetargetCharacterSize max)
2457 ffetargetCharacterSize sz;
2459 recurse: /* :::::::::::::::::::: */
2464 if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2465 return catlist; /* Don't append any more items. */
2467 switch (ffebld_op (expr))
2469 case FFEBLD_opCONTER:
2470 case FFEBLD_opSYMTER:
2471 case FFEBLD_opARRAYREF:
2472 case FFEBLD_opFUNCREF:
2473 case FFEBLD_opSUBSTR:
2474 case FFEBLD_opCONVERT: /* Callers should strip this off beforehand
2475 if they don't need to preserve it. */
2476 if (catlist.count == catlist.max)
2477 { /* Make a (larger) list. */
2481 newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2482 newx = malloc_new_ks (malloc_pool_image (), "catlist",
2483 newmax * sizeof (newx[0]));
2484 if (catlist.max != 0)
2486 memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2487 malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2488 catlist.max * sizeof (newx[0]));
2490 catlist.max = newmax;
2491 catlist.exprs = newx;
2493 if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2494 catlist.minlen += sz;
2496 ++catlist.minlen; /* Not true for F90; can be 0 length. */
2497 if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2498 catlist.maxlen = sz;
2500 catlist.maxlen += sz;
2501 if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2502 { /* This item overlaps (or is beyond) the end
2503 of the destination. */
2504 switch (ffebld_op (expr))
2506 case FFEBLD_opCONTER:
2507 case FFEBLD_opSYMTER:
2508 case FFEBLD_opARRAYREF:
2509 case FFEBLD_opFUNCREF:
2510 case FFEBLD_opSUBSTR:
2511 /* ~~Do useful truncations here. */
2515 assert ("op changed or inconsistent switches!" == NULL);
2519 catlist.exprs[catlist.count++] = expr;
2522 case FFEBLD_opPAREN:
2523 expr = ffebld_left (expr);
2524 goto recurse; /* :::::::::::::::::::: */
2526 case FFEBLD_opCONCATENATE:
2527 catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2528 expr = ffebld_right (expr);
2529 goto recurse; /* :::::::::::::::::::: */
2531 #if 0 /* Breaks passing small actual arg to larger
2532 dummy arg of sfunc */
2533 case FFEBLD_opCONVERT:
2534 expr = ffebld_left (expr);
2536 ffetargetCharacterSize cmax;
2538 cmax = catlist.len + ffebld_size_known (expr);
2540 if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2543 goto recurse; /* :::::::::::::::::::: */
2550 assert ("bad op in _gather_" == NULL);
2556 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2558 ffecomConcatList_ catlist;
2559 ffecom_concat_list_kill_(catlist);
2561 Anything allocated within the list info is deallocated. */
2563 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2565 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2567 if (catlist.max != 0)
2568 malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2569 catlist.max * sizeof (catlist.exprs[0]));
2573 /* Make list of concatenated string exprs.
2575 Returns a flattened list of concatenated subexpressions given a
2576 tree of such expressions. */
2578 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2579 static ffecomConcatList_
2580 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2582 ffecomConcatList_ catlist;
2584 catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2585 return ffecom_concat_list_gather_ (catlist, expr, max);
2590 /* Provide some kind of useful info on member of aggregate area,
2591 since current g77/gcc technology does not provide debug info
2592 on these members. */
2594 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2596 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2597 tree member_type UNUSED, ffetargetOffset offset)
2607 for (type_id = member_type;
2608 TREE_CODE (type_id) != IDENTIFIER_NODE;
2611 switch (TREE_CODE (type_id))
2615 type_id = TYPE_NAME (type_id);
2620 type_id = TREE_TYPE (type_id);
2624 assert ("no IDENTIFIER_NODE for type!" == NULL);
2625 type_id = error_mark_node;
2631 if (ffecom_transform_only_dummies_
2632 || !ffe_is_debug_kludge ())
2633 return; /* Can't do this yet, maybe later. */
2636 + strlen (aggr_type)
2637 + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2639 + IDENTIFIER_LENGTH (type_id);
2642 if (((size_t) len) >= ARRAY_SIZE (space))
2643 buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2647 sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2649 IDENTIFIER_POINTER (DECL_NAME (aggr)),
2652 value = build_string (len, buff);
2654 = build_type_variant (build_array_type (char_type_node,
2658 build_int_2 (strlen (buff), 0))),
2660 decl = build_decl (VAR_DECL,
2661 ffecom_get_identifier_ (ffesymbol_text (member)),
2663 TREE_CONSTANT (decl) = 1;
2664 TREE_STATIC (decl) = 1;
2665 DECL_INITIAL (decl) = error_mark_node;
2666 DECL_IN_SYSTEM_HEADER (decl) = 1; /* Don't let -Wunused complain. */
2667 decl = start_decl (decl, FALSE);
2668 finish_decl (decl, value, FALSE);
2670 if (buff != &space[0])
2671 malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2675 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2677 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2678 int i; // entry# for this entrypoint (used by master fn)
2679 ffecom_do_entrypoint_(s,i);
2681 Makes a public entry point that calls our private master fn (already
2684 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2686 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2689 tree type; /* Type of function. */
2690 tree multi_retval; /* Var holding return value (union). */
2691 tree result; /* Var holding result. */
2692 ffeinfoBasictype bt;
2696 bool charfunc; /* All entry points return same type
2698 bool cmplxfunc; /* Use f2c way of returning COMPLEX. */
2699 bool multi; /* Master fn has multiple return types. */
2700 bool altreturning = FALSE; /* This entry point has alternate returns. */
2702 int old_lineno = lineno;
2703 const char *old_input_filename = input_filename;
2705 input_filename = ffesymbol_where_filename (fn);
2706 lineno = ffesymbol_where_filelinenum (fn);
2708 /* c-parse.y indeed does call suspend_momentary and not only ignores the
2709 return value, but also never calls resume_momentary, when starting an
2710 outer function (see "fndef:", "setspecs:", and so on). So g77 does the
2711 same thing. It shouldn't be a problem since start_function calls
2712 temporary_allocation, but it might be necessary. If it causes a problem
2713 here, then maybe there's a bug lurking in gcc. NOTE: This identical
2714 comment appears twice in thist file. */
2716 suspend_momentary ();
2718 ffecom_doing_entry_ = TRUE; /* Don't bother with array dimensions. */
2720 switch (ffecom_primary_entry_kind_)
2722 case FFEINFO_kindFUNCTION:
2724 /* Determine actual return type for function. */
2726 gt = FFEGLOBAL_typeFUNC;
2727 bt = ffesymbol_basictype (fn);
2728 kt = ffesymbol_kindtype (fn);
2729 if (bt == FFEINFO_basictypeNONE)
2731 ffeimplic_establish_symbol (fn);
2732 if (ffesymbol_funcresult (fn) != NULL)
2733 ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2734 bt = ffesymbol_basictype (fn);
2735 kt = ffesymbol_kindtype (fn);
2738 if (bt == FFEINFO_basictypeCHARACTER)
2739 charfunc = TRUE, cmplxfunc = FALSE;
2740 else if ((bt == FFEINFO_basictypeCOMPLEX)
2741 && ffesymbol_is_f2c (fn))
2742 charfunc = FALSE, cmplxfunc = TRUE;
2744 charfunc = cmplxfunc = FALSE;
2747 type = ffecom_tree_fun_type_void;
2748 else if (ffesymbol_is_f2c (fn))
2749 type = ffecom_tree_fun_type[bt][kt];
2751 type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2753 if ((type == NULL_TREE)
2754 || (TREE_TYPE (type) == NULL_TREE))
2755 type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
2757 multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2760 case FFEINFO_kindSUBROUTINE:
2761 gt = FFEGLOBAL_typeSUBR;
2762 bt = FFEINFO_basictypeNONE;
2763 kt = FFEINFO_kindtypeNONE;
2764 if (ffecom_is_altreturning_)
2765 { /* Am _I_ altreturning? */
2766 for (item = ffesymbol_dummyargs (fn);
2768 item = ffebld_trail (item))
2770 if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2772 altreturning = TRUE;
2777 type = ffecom_tree_subr_type;
2779 type = ffecom_tree_fun_type_void;
2782 type = ffecom_tree_fun_type_void;
2789 assert ("say what??" == NULL);
2791 case FFEINFO_kindANY:
2792 gt = FFEGLOBAL_typeANY;
2793 bt = FFEINFO_basictypeNONE;
2794 kt = FFEINFO_kindtypeNONE;
2795 type = error_mark_node;
2802 /* build_decl uses the current lineno and input_filename to set the decl
2803 source info. So, I've putzed with ffestd and ffeste code to update that
2804 source info to point to the appropriate statement just before calling
2805 ffecom_do_entrypoint (which calls this fn). */
2807 start_function (ffecom_get_external_identifier_ (fn),
2809 0, /* nested/inline */
2810 1); /* TREE_PUBLIC */
2812 if (((g = ffesymbol_global (fn)) != NULL)
2813 && ((ffeglobal_type (g) == gt)
2814 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2816 ffeglobal_set_hook (g, current_function_decl);
2819 /* Reset args in master arg list so they get retransitioned. */
2821 for (item = ffecom_master_arglist_;
2823 item = ffebld_trail (item))
2828 arg = ffebld_head (item);
2829 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2830 continue; /* Alternate return or some such thing. */
2831 s = ffebld_symter (arg);
2832 ffesymbol_hook (s).decl_tree = NULL_TREE;
2833 ffesymbol_hook (s).length_tree = NULL_TREE;
2836 /* Build dummy arg list for this entry point. */
2838 yes = suspend_momentary ();
2840 if (charfunc || cmplxfunc)
2841 { /* Prepend arg for where result goes. */
2846 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2848 type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2850 result = ffecom_get_invented_identifier ("__g77_%s", "result");
2852 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2855 length = ffecom_char_enhance_arg_ (&type, fn);
2857 length = NULL_TREE; /* Not ref'd if !charfunc. */
2859 type = build_pointer_type (type);
2860 result = build_decl (PARM_DECL, result, type);
2862 push_parm_decl (result);
2863 ffecom_func_result_ = result;
2867 push_parm_decl (length);
2868 ffecom_func_length_ = length;
2872 result = DECL_RESULT (current_function_decl);
2874 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2876 resume_momentary (yes);
2878 store_parm_decls (0);
2880 ffecom_start_compstmt ();
2881 /* Disallow temp vars at this level. */
2882 current_binding_level->prep_state = 2;
2884 /* Make local var to hold return type for multi-type master fn. */
2888 yes = suspend_momentary ();
2890 multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2892 multi_retval = build_decl (VAR_DECL, multi_retval,
2893 ffecom_multi_type_node_);
2894 multi_retval = start_decl (multi_retval, FALSE);
2895 finish_decl (multi_retval, NULL_TREE, FALSE);
2897 resume_momentary (yes);
2900 multi_retval = NULL_TREE; /* Not actually ref'd if !multi. */
2902 /* Here we emit the actual code for the entry point. */
2908 tree arglist = NULL_TREE;
2909 tree *plist = &arglist;
2915 /* Prepare actual arg list based on master arg list. */
2917 for (list = ffecom_master_arglist_;
2919 list = ffebld_trail (list))
2921 arg = ffebld_head (list);
2922 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2924 s = ffebld_symter (arg);
2925 if (ffesymbol_hook (s).decl_tree == NULL_TREE
2926 || ffesymbol_hook (s).decl_tree == error_mark_node)
2927 actarg = null_pointer_node; /* We don't have this arg. */
2929 actarg = ffesymbol_hook (s).decl_tree;
2930 *plist = build_tree_list (NULL_TREE, actarg);
2931 plist = &TREE_CHAIN (*plist);
2934 /* This code appends the length arguments for character
2935 variables/arrays. */
2937 for (list = ffecom_master_arglist_;
2939 list = ffebld_trail (list))
2941 arg = ffebld_head (list);
2942 if (ffebld_op (arg) != FFEBLD_opSYMTER)
2944 s = ffebld_symter (arg);
2945 if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2946 continue; /* Only looking for CHARACTER arguments. */
2947 if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2948 continue; /* Only looking for variables and arrays. */
2949 if (ffesymbol_hook (s).length_tree == NULL_TREE
2950 || ffesymbol_hook (s).length_tree == error_mark_node)
2951 actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2953 actarg = ffesymbol_hook (s).length_tree;
2954 *plist = build_tree_list (NULL_TREE, actarg);
2955 plist = &TREE_CHAIN (*plist);
2958 /* Prepend character-value return info to actual arg list. */
2962 prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2963 TREE_CHAIN (prepend)
2964 = build_tree_list (NULL_TREE, ffecom_func_length_);
2965 TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2969 /* Prepend multi-type return value to actual arg list. */
2974 = build_tree_list (NULL_TREE,
2975 ffecom_1 (ADDR_EXPR,
2976 build_pointer_type (TREE_TYPE (multi_retval)),
2978 TREE_CHAIN (prepend) = arglist;
2982 /* Prepend my entry-point number to the actual arg list. */
2984 prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2985 TREE_CHAIN (prepend) = arglist;
2988 /* Build the call to the master function. */
2990 master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2991 call = ffecom_3s (CALL_EXPR,
2992 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2993 master_fn, arglist, NULL_TREE);
2995 /* Decide whether the master function is a function or subroutine, and
2996 handle the return value for my entry point. */
2998 if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
3001 expand_expr_stmt (call);
3002 expand_null_return ();
3004 else if (multi && cmplxfunc)
3006 expand_expr_stmt (call);
3008 = ffecom_1 (INDIRECT_REF,
3009 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
3011 result = ffecom_modify (NULL_TREE, result,
3012 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
3014 ffecom_multi_fields_[bt][kt]));
3015 expand_expr_stmt (result);
3016 expand_null_return ();
3020 expand_expr_stmt (call);
3022 = ffecom_modify (NULL_TREE, result,
3023 convert (TREE_TYPE (result),
3024 ffecom_2 (COMPONENT_REF,
3025 ffecom_tree_type[bt][kt],
3027 ffecom_multi_fields_[bt][kt])));
3028 expand_return (result);
3033 = ffecom_1 (INDIRECT_REF,
3034 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
3036 result = ffecom_modify (NULL_TREE, result, call);
3037 expand_expr_stmt (result);
3038 expand_null_return ();
3042 result = ffecom_modify (NULL_TREE,
3044 convert (TREE_TYPE (result),
3046 expand_return (result);
3052 ffecom_end_compstmt ();
3054 finish_function (0);
3056 lineno = old_lineno;
3057 input_filename = old_input_filename;
3059 ffecom_doing_entry_ = FALSE;
3063 /* Transform expr into gcc tree with possible destination
3065 Recursive descent on expr while making corresponding tree nodes and
3066 attaching type info and such. If destination supplied and compatible
3067 with temporary that would be made in certain cases, temporary isn't
3068 made, destination used instead, and dest_used flag set TRUE. */
3070 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3072 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
3073 bool *dest_used, bool assignp, bool widenp)
3078 ffeinfoBasictype bt;
3081 tree dt; /* decl_tree for an ffesymbol. */
3082 tree tree_type, tree_type_x;
3085 enum tree_code code;
3087 assert (expr != NULL);
3089 if (dest_used != NULL)
3092 bt = ffeinfo_basictype (ffebld_info (expr));
3093 kt = ffeinfo_kindtype (ffebld_info (expr));
3094 tree_type = ffecom_tree_type[bt][kt];
3096 /* Widen integral arithmetic as desired while preserving signedness. */
3097 tree_type_x = NULL_TREE;
3098 if (widenp && tree_type
3099 && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
3100 && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
3101 tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
3103 switch (ffebld_op (expr))
3105 case FFEBLD_opACCTER:
3108 ffebit bits = ffebld_accter_bits (expr);
3109 ffetargetOffset source_offset = 0;
3110 ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3113 assert (dest_offset == 0
3114 || (bt == FFEINFO_basictypeCHARACTER
3115 && kt == FFEINFO_kindtypeCHARACTER1));
3120 ffebldConstantUnion cu;
3123 ffebldConstantArray ca = ffebld_accter (expr);
3125 ffebit_test (bits, source_offset, &value, &length);
3131 for (i = 0; i < length; ++i)
3133 cu = ffebld_constantarray_get (ca, bt, kt,
3136 t = ffecom_constantunion (&cu, bt, kt, tree_type);
3139 && dest_offset != 0)
3140 purpose = build_int_2 (dest_offset, 0);
3142 purpose = NULL_TREE;
3144 if (list == NULL_TREE)
3145 list = item = build_tree_list (purpose, t);
3148 TREE_CHAIN (item) = build_tree_list (purpose, t);
3149 item = TREE_CHAIN (item);
3153 source_offset += length;
3154 dest_offset += length;
3158 item = build_int_2 ((ffebld_accter_size (expr)
3159 + ffebld_accter_pad (expr)) - 1, 0);
3160 ffebit_kill (ffebld_accter_bits (expr));
3161 TREE_TYPE (item) = ffecom_integer_type_node;
3165 build_range_type (ffecom_integer_type_node,
3166 ffecom_integer_zero_node,
3168 list = build (CONSTRUCTOR, item, NULL_TREE, list);
3169 TREE_CONSTANT (list) = 1;
3170 TREE_STATIC (list) = 1;
3173 case FFEBLD_opARRTER:
3178 if (ffebld_arrter_pad (expr) == 0)
3182 assert (bt == FFEINFO_basictypeCHARACTER
3183 && kt == FFEINFO_kindtypeCHARACTER1);
3185 /* Becomes PURPOSE first time through loop. */
3186 item = build_int_2 (ffebld_arrter_pad (expr), 0);
3189 for (i = 0; i < ffebld_arrter_size (expr); ++i)
3191 ffebldConstantUnion cu
3192 = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3194 t = ffecom_constantunion (&cu, bt, kt, tree_type);
3196 if (list == NULL_TREE)
3197 /* Assume item is PURPOSE first time through loop. */
3198 list = item = build_tree_list (item, t);
3201 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3202 item = TREE_CHAIN (item);
3207 item = build_int_2 ((ffebld_arrter_size (expr)
3208 + ffebld_arrter_pad (expr)) - 1, 0);
3209 TREE_TYPE (item) = ffecom_integer_type_node;
3213 build_range_type (ffecom_integer_type_node,
3214 ffecom_integer_zero_node,
3216 list = build (CONSTRUCTOR, item, NULL_TREE, list);
3217 TREE_CONSTANT (list) = 1;
3218 TREE_STATIC (list) = 1;
3221 case FFEBLD_opCONTER:
3222 assert (ffebld_conter_pad (expr) == 0);
3224 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3228 case FFEBLD_opSYMTER:
3229 if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3230 || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3231 return ffecom_ptr_to_expr (expr); /* Same as %REF(intrinsic). */
3232 s = ffebld_symter (expr);
3233 t = ffesymbol_hook (s).decl_tree;
3236 { /* ASSIGN'ed-label expr. */
3237 if (ffe_is_ugly_assign ())
3239 /* User explicitly wants ASSIGN'ed variables to be at the same
3240 memory address as the variables when used in non-ASSIGN
3241 contexts. That can make old, arcane, non-standard code
3242 work, but don't try to do it when a pointer wouldn't fit
3243 in the normal variable (take other approach, and warn,
3248 s = ffecom_sym_transform_ (s);
3249 t = ffesymbol_hook (s).decl_tree;
3250 assert (t != NULL_TREE);
3253 if (t == error_mark_node)
3256 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3257 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3259 if (ffesymbol_hook (s).addr)
3260 t = ffecom_1 (INDIRECT_REF,
3261 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3265 if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3267 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3268 FFEBAD_severityWARNING);
3269 ffebad_string (ffesymbol_text (s));
3270 ffebad_here (0, ffesymbol_where_line (s),
3271 ffesymbol_where_column (s));
3276 /* Don't use the normal variable's tree for ASSIGN, though mark
3277 it as in the system header (housekeeping). Use an explicit,
3278 specially created sibling that is known to be wide enough
3279 to hold pointers to labels. */
3282 && TREE_CODE (t) == VAR_DECL)
3283 DECL_IN_SYSTEM_HEADER (t) = 1; /* Don't let -Wunused complain. */
3285 t = ffesymbol_hook (s).assign_tree;
3288 s = ffecom_sym_transform_assign_ (s);
3289 t = ffesymbol_hook (s).assign_tree;
3290 assert (t != NULL_TREE);
3297 s = ffecom_sym_transform_ (s);
3298 t = ffesymbol_hook (s).decl_tree;
3299 assert (t != NULL_TREE);
3301 if (ffesymbol_hook (s).addr)
3302 t = ffecom_1 (INDIRECT_REF,
3303 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3307 case FFEBLD_opARRAYREF:
3308 return ffecom_arrayref_ (NULL_TREE, expr, 0);
3310 case FFEBLD_opUPLUS:
3311 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3312 return ffecom_1 (NOP_EXPR, tree_type, left);
3314 case FFEBLD_opPAREN:
3315 /* ~~~Make sure Fortran rules respected here */
3316 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3317 return ffecom_1 (NOP_EXPR, tree_type, left);
3319 case FFEBLD_opUMINUS:
3320 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3323 tree_type = tree_type_x;
3324 left = convert (tree_type, left);
3326 return ffecom_1 (NEGATE_EXPR, tree_type, left);
3329 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3330 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3333 tree_type = tree_type_x;
3334 left = convert (tree_type, left);
3335 right = convert (tree_type, right);
3337 return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3339 case FFEBLD_opSUBTRACT:
3340 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3341 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3344 tree_type = tree_type_x;
3345 left = convert (tree_type, left);
3346 right = convert (tree_type, right);
3348 return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3350 case FFEBLD_opMULTIPLY:
3351 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3352 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3355 tree_type = tree_type_x;
3356 left = convert (tree_type, left);
3357 right = convert (tree_type, right);
3359 return ffecom_2 (MULT_EXPR, tree_type, left, right);
3361 case FFEBLD_opDIVIDE:
3362 left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3363 right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3366 tree_type = tree_type_x;
3367 left = convert (tree_type, left);
3368 right = convert (tree_type, right);
3370 return ffecom_tree_divide_ (tree_type, left, right,
3371 dest_tree, dest, dest_used,
3372 ffebld_nonter_hook (expr));
3374 case FFEBLD_opPOWER:
3376 ffebld left = ffebld_left (expr);
3377 ffebld right = ffebld_right (expr);
3379 ffeinfoKindtype rtkt;
3380 ffeinfoKindtype ltkt;
3383 switch (ffeinfo_basictype (ffebld_info (right)))
3386 case FFEINFO_basictypeINTEGER:
3389 item = ffecom_expr_power_integer_ (expr);
3390 if (item != NULL_TREE)
3394 rtkt = FFEINFO_kindtypeINTEGER1;
3395 switch (ffeinfo_basictype (ffebld_info (left)))
3397 case FFEINFO_basictypeINTEGER:
3398 if ((ffeinfo_kindtype (ffebld_info (left))
3399 == FFEINFO_kindtypeINTEGER4)
3400 || (ffeinfo_kindtype (ffebld_info (right))
3401 == FFEINFO_kindtypeINTEGER4))
3403 code = FFECOM_gfrtPOW_QQ;
3404 ltkt = FFEINFO_kindtypeINTEGER4;
3405 rtkt = FFEINFO_kindtypeINTEGER4;
3409 code = FFECOM_gfrtPOW_II;
3410 ltkt = FFEINFO_kindtypeINTEGER1;
3414 case FFEINFO_basictypeREAL:
3415 if (ffeinfo_kindtype (ffebld_info (left))
3416 == FFEINFO_kindtypeREAL1)
3418 code = FFECOM_gfrtPOW_RI;
3419 ltkt = FFEINFO_kindtypeREAL1;
3423 code = FFECOM_gfrtPOW_DI;
3424 ltkt = FFEINFO_kindtypeREAL2;
3428 case FFEINFO_basictypeCOMPLEX:
3429 if (ffeinfo_kindtype (ffebld_info (left))
3430 == FFEINFO_kindtypeREAL1)
3432 code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
3433 ltkt = FFEINFO_kindtypeREAL1;
3437 code = FFECOM_gfrtPOW_ZI; /* Overlapping result okay. */
3438 ltkt = FFEINFO_kindtypeREAL2;
3443 assert ("bad pow_*i" == NULL);
3444 code = FFECOM_gfrtPOW_CI; /* Overlapping result okay. */
3445 ltkt = FFEINFO_kindtypeREAL1;
3448 if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3449 left = ffeexpr_convert (left, NULL, NULL,
3450 ffeinfo_basictype (ffebld_info (left)),
3452 FFETARGET_charactersizeNONE,
3453 FFEEXPR_contextLET);
3454 if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3455 right = ffeexpr_convert (right, NULL, NULL,
3456 FFEINFO_basictypeINTEGER,
3458 FFETARGET_charactersizeNONE,
3459 FFEEXPR_contextLET);
3462 case FFEINFO_basictypeREAL:
3463 if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3464 left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3465 FFEINFO_kindtypeREALDOUBLE, 0,
3466 FFETARGET_charactersizeNONE,
3467 FFEEXPR_contextLET);
3468 if (ffeinfo_kindtype (ffebld_info (right))
3469 == FFEINFO_kindtypeREAL1)
3470 right = ffeexpr_convert (right, NULL, NULL,
3471 FFEINFO_basictypeREAL,
3472 FFEINFO_kindtypeREALDOUBLE, 0,
3473 FFETARGET_charactersizeNONE,
3474 FFEEXPR_contextLET);
3475 /* We used to call FFECOM_gfrtPOW_DD here,
3476 which passes arguments by reference. */
3477 code = FFECOM_gfrtL_POW;
3478 /* Pass arguments by value. */
3482 case FFEINFO_basictypeCOMPLEX:
3483 if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3484 left = ffeexpr_convert (left, NULL, NULL,
3485 FFEINFO_basictypeCOMPLEX,
3486 FFEINFO_kindtypeREALDOUBLE, 0,
3487 FFETARGET_charactersizeNONE,
3488 FFEEXPR_contextLET);
3489 if (ffeinfo_kindtype (ffebld_info (right))
3490 == FFEINFO_kindtypeREAL1)
3491 right = ffeexpr_convert (right, NULL, NULL,
3492 FFEINFO_basictypeCOMPLEX,
3493 FFEINFO_kindtypeREALDOUBLE, 0,
3494 FFETARGET_charactersizeNONE,
3495 FFEEXPR_contextLET);
3496 code = FFECOM_gfrtPOW_ZZ; /* Overlapping result okay. */
3497 ref = TRUE; /* Pass arguments by reference. */
3501 assert ("bad pow_x*" == NULL);
3502 code = FFECOM_gfrtPOW_II;
3505 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3506 ffecom_gfrt_kindtype (code),
3507 (ffe_is_f2c_library ()
3508 && ffecom_gfrt_complex_[code]),
3509 tree_type, left, right,
3510 dest_tree, dest, dest_used,
3511 NULL_TREE, FALSE, ref,
3512 ffebld_nonter_hook (expr));
3518 case FFEINFO_basictypeLOGICAL:
3519 item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3520 return convert (tree_type, item);
3522 case FFEINFO_basictypeINTEGER:
3523 return ffecom_1 (BIT_NOT_EXPR, tree_type,
3524 ffecom_expr (ffebld_left (expr)));
3527 assert ("NOT bad basictype" == NULL);
3529 case FFEINFO_basictypeANY:
3530 return error_mark_node;
3534 case FFEBLD_opFUNCREF:
3535 assert (ffeinfo_basictype (ffebld_info (expr))
3536 != FFEINFO_basictypeCHARACTER);
3538 case FFEBLD_opSUBRREF:
3539 if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3540 == FFEINFO_whereINTRINSIC)
3541 { /* Invocation of an intrinsic. */
3542 item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3546 s = ffebld_symter (ffebld_left (expr));
3547 dt = ffesymbol_hook (s).decl_tree;
3548 if (dt == NULL_TREE)
3550 s = ffecom_sym_transform_ (s);
3551 dt = ffesymbol_hook (s).decl_tree;
3553 if (dt == error_mark_node)
3556 if (ffesymbol_hook (s).addr)
3559 item = ffecom_1_fn (dt);
3561 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3562 args = ffecom_list_expr (ffebld_right (expr));
3564 args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3566 if (args == error_mark_node)
3567 return error_mark_node;
3569 item = ffecom_call_ (item, kt,
3570 ffesymbol_is_f2c (s)
3571 && (bt == FFEINFO_basictypeCOMPLEX)
3572 && (ffesymbol_where (s)
3573 != FFEINFO_whereCONSTANT),
3576 dest_tree, dest, dest_used,
3577 error_mark_node, FALSE,
3578 ffebld_nonter_hook (expr));
3579 TREE_SIDE_EFFECTS (item) = 1;
3585 case FFEINFO_basictypeLOGICAL:
3587 = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3588 ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3589 ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3590 return convert (tree_type, item);
3592 case FFEINFO_basictypeINTEGER:
3593 return ffecom_2 (BIT_AND_EXPR, tree_type,
3594 ffecom_expr (ffebld_left (expr)),
3595 ffecom_expr (ffebld_right (expr)));
3598 assert ("AND bad basictype" == NULL);
3600 case FFEINFO_basictypeANY:
3601 return error_mark_node;
3608 case FFEINFO_basictypeLOGICAL:
3610 = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3611 ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3612 ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3613 return convert (tree_type, item);
3615 case FFEINFO_basictypeINTEGER:
3616 return ffecom_2 (BIT_IOR_EXPR, tree_type,
3617 ffecom_expr (ffebld_left (expr)),
3618 ffecom_expr (ffebld_right (expr)));
3621 assert ("OR bad basictype" == NULL);
3623 case FFEINFO_basictypeANY:
3624 return error_mark_node;
3632 case FFEINFO_basictypeLOGICAL:
3634 = ffecom_2 (NE_EXPR, integer_type_node,
3635 ffecom_expr (ffebld_left (expr)),
3636 ffecom_expr (ffebld_right (expr)));
3637 return convert (tree_type, ffecom_truth_value (item));
3639 case FFEINFO_basictypeINTEGER:
3640 return ffecom_2 (BIT_XOR_EXPR, tree_type,
3641 ffecom_expr (ffebld_left (expr)),
3642 ffecom_expr (ffebld_right (expr)));
3645 assert ("XOR/NEQV bad basictype" == NULL);
3647 case FFEINFO_basictypeANY:
3648 return error_mark_node;
3655 case FFEINFO_basictypeLOGICAL:
3657 = ffecom_2 (EQ_EXPR, integer_type_node,
3658 ffecom_expr (ffebld_left (expr)),
3659 ffecom_expr (ffebld_right (expr)));
3660 return convert (tree_type, ffecom_truth_value (item));
3662 case FFEINFO_basictypeINTEGER:
3664 ffecom_1 (BIT_NOT_EXPR, tree_type,
3665 ffecom_2 (BIT_XOR_EXPR, tree_type,
3666 ffecom_expr (ffebld_left (expr)),
3667 ffecom_expr (ffebld_right (expr))));
3670 assert ("EQV bad basictype" == NULL);
3672 case FFEINFO_basictypeANY:
3673 return error_mark_node;
3677 case FFEBLD_opCONVERT:
3678 if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3679 return error_mark_node;
3683 case FFEINFO_basictypeLOGICAL:
3684 case FFEINFO_basictypeINTEGER:
3685 case FFEINFO_basictypeREAL:
3686 return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3688 case FFEINFO_basictypeCOMPLEX:
3689 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3691 case FFEINFO_basictypeINTEGER:
3692 case FFEINFO_basictypeLOGICAL:
3693 case FFEINFO_basictypeREAL:
3694 item = ffecom_expr (ffebld_left (expr));
3695 if (item == error_mark_node)
3696 return error_mark_node;
3697 /* convert() takes care of converting to the subtype first,
3698 at least in gcc-2.7.2. */
3699 item = convert (tree_type, item);
3702 case FFEINFO_basictypeCOMPLEX:
3703 return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3706 assert ("CONVERT COMPLEX bad basictype" == NULL);
3708 case FFEINFO_basictypeANY:
3709 return error_mark_node;
3714 assert ("CONVERT bad basictype" == NULL);
3716 case FFEINFO_basictypeANY:
3717 return error_mark_node;
3723 goto relational; /* :::::::::::::::::::: */
3727 goto relational; /* :::::::::::::::::::: */
3731 goto relational; /* :::::::::::::::::::: */
3735 goto relational; /* :::::::::::::::::::: */
3739 goto relational; /* :::::::::::::::::::: */
3744 relational: /* :::::::::::::::::::: */
3745 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3747 case FFEINFO_basictypeLOGICAL:
3748 case FFEINFO_basictypeINTEGER:
3749 case FFEINFO_basictypeREAL:
3750 item = ffecom_2 (code, integer_type_node,
3751 ffecom_expr (ffebld_left (expr)),
3752 ffecom_expr (ffebld_right (expr)));
3753 return convert (tree_type, item);
3755 case FFEINFO_basictypeCOMPLEX:
3756 assert (code == EQ_EXPR || code == NE_EXPR);
3759 tree arg1 = ffecom_expr (ffebld_left (expr));
3760 tree arg2 = ffecom_expr (ffebld_right (expr));
3762 if (arg1 == error_mark_node || arg2 == error_mark_node)
3763 return error_mark_node;
3765 arg1 = ffecom_save_tree (arg1);
3766 arg2 = ffecom_save_tree (arg2);
3768 if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3770 real_type = TREE_TYPE (TREE_TYPE (arg1));
3771 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3775 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3776 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3780 = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3781 ffecom_2 (EQ_EXPR, integer_type_node,
3782 ffecom_1 (REALPART_EXPR, real_type, arg1),
3783 ffecom_1 (REALPART_EXPR, real_type, arg2)),
3784 ffecom_2 (EQ_EXPR, integer_type_node,
3785 ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3786 ffecom_1 (IMAGPART_EXPR, real_type,
3788 if (code == EQ_EXPR)
3789 item = ffecom_truth_value (item);
3791 item = ffecom_truth_value_invert (item);
3792 return convert (tree_type, item);
3795 case FFEINFO_basictypeCHARACTER:
3797 ffebld left = ffebld_left (expr);
3798 ffebld right = ffebld_right (expr);
3804 /* f2c run-time functions do the implicit blank-padding for us,
3805 so we don't usually have to implement blank-padding ourselves.
3806 (The exception is when we pass an argument to a separately
3807 compiled statement function -- if we know the arg is not the
3808 same length as the dummy, we must truncate or extend it. If
3809 we "inline" statement functions, that necessity goes away as
3812 Strip off the CONVERT operators that blank-pad. (Truncation by
3813 CONVERT shouldn't happen here, but it can happen in
3816 while (ffebld_op (left) == FFEBLD_opCONVERT)
3817 left = ffebld_left (left);
3818 while (ffebld_op (right) == FFEBLD_opCONVERT)
3819 right = ffebld_left (right);
3821 left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3822 right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3824 if (left_tree == error_mark_node || left_length == error_mark_node
3825 || right_tree == error_mark_node
3826 || right_length == error_mark_node)
3827 return error_mark_node;
3829 if ((ffebld_size_known (left) == 1)
3830 && (ffebld_size_known (right) == 1))
3833 = ffecom_1 (INDIRECT_REF,
3834 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3837 = ffecom_1 (INDIRECT_REF,
3838 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3842 = ffecom_2 (code, integer_type_node,
3843 ffecom_2 (ARRAY_REF,
3844 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3847 ffecom_2 (ARRAY_REF,
3848 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3854 item = build_tree_list (NULL_TREE, left_tree);
3855 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3856 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3858 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3859 = build_tree_list (NULL_TREE, right_length);
3860 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3861 item = ffecom_2 (code, integer_type_node,
3863 convert (TREE_TYPE (item),
3864 integer_zero_node));
3866 item = convert (tree_type, item);
3872 assert ("relational bad basictype" == NULL);
3874 case FFEINFO_basictypeANY:
3875 return error_mark_node;
3879 case FFEBLD_opPERCENT_LOC:
3880 item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3881 return convert (tree_type, item);
3885 case FFEBLD_opBOUNDS:
3886 case FFEBLD_opREPEAT:
3887 case FFEBLD_opLABTER:
3888 case FFEBLD_opLABTOK:
3889 case FFEBLD_opIMPDO:
3890 case FFEBLD_opCONCATENATE:
3891 case FFEBLD_opSUBSTR:
3893 assert ("bad op" == NULL);
3896 return error_mark_node;
3900 assert ("didn't think anything got here anymore!!" == NULL);
3902 switch (ffebld_arity (expr))
3905 TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3906 TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3907 if (TREE_OPERAND (item, 0) == error_mark_node
3908 || TREE_OPERAND (item, 1) == error_mark_node)
3909 return error_mark_node;
3913 TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3914 if (TREE_OPERAND (item, 0) == error_mark_node)
3915 return error_mark_node;
3927 /* Returns the tree that does the intrinsic invocation.
3929 Note: this function applies only to intrinsics returning
3930 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3933 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3935 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3936 ffebld dest, bool *dest_used)
3939 tree saved_expr1; /* For those who need it. */
3940 tree saved_expr2; /* For those who need it. */
3941 ffeinfoBasictype bt;
3945 tree real_type; /* REAL type corresponding to COMPLEX. */
3947 ffebld list = ffebld_right (expr); /* List of (some) args. */
3948 ffebld arg1; /* For handy reference. */
3951 ffeintrinImp codegen_imp;
3954 assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3956 if (dest_used != NULL)
3959 bt = ffeinfo_basictype (ffebld_info (expr));
3960 kt = ffeinfo_kindtype (ffebld_info (expr));
3961 tree_type = ffecom_tree_type[bt][kt];
3965 arg1 = ffebld_head (list);
3966 if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3967 return error_mark_node;
3968 if ((list = ffebld_trail (list)) != NULL)
3970 arg2 = ffebld_head (list);
3971 if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3972 return error_mark_node;
3973 if ((list = ffebld_trail (list)) != NULL)
3975 arg3 = ffebld_head (list);
3976 if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3977 return error_mark_node;
3986 arg1 = arg2 = arg3 = NULL;
3988 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3989 args. This is used by the MAX/MIN expansions. */
3992 arg1_type = ffecom_tree_type
3993 [ffeinfo_basictype (ffebld_info (arg1))]
3994 [ffeinfo_kindtype (ffebld_info (arg1))];
3996 arg1_type = NULL_TREE; /* Really not needed, but might catch bugs
3999 /* There are several ways for each of the cases in the following switch
4000 statements to exit (from simplest to use to most complicated):
4002 break; (when expr_tree == NULL)
4004 A standard call is made to the specific intrinsic just as if it had been
4005 passed in as a dummy procedure and called as any old procedure. This
4006 method can produce slower code but in some cases it's the easiest way for
4007 now. However, if a (presumably faster) direct call is available,
4008 that is used, so this is the easiest way in many more cases now.
4010 gfrt = FFECOM_gfrtWHATEVER;
4013 gfrt contains the gfrt index of a library function to call, passing the
4014 argument(s) by value rather than by reference. Used when a more
4015 careful choice of library function is needed than that provided
4016 by the vanilla `break;'.
4020 The expr_tree has been completely set up and is ready to be returned
4021 as is. No further actions are taken. Use this when the tree is not
4022 in the simple form for one of the arity_n labels. */
4024 /* For info on how the switch statement cases were written, see the files
4025 enclosed in comments below the switch statement. */
4027 codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
4028 gfrt = ffeintrin_gfrt_direct (codegen_imp);
4029 if (gfrt == FFECOM_gfrt)
4030 gfrt = ffeintrin_gfrt_indirect (codegen_imp);
4032 switch (codegen_imp)
4034 case FFEINTRIN_impABS:
4035 case FFEINTRIN_impCABS:
4036 case FFEINTRIN_impCDABS:
4037 case FFEINTRIN_impDABS:
4038 case FFEINTRIN_impIABS:
4039 if (ffeinfo_basictype (ffebld_info (arg1))
4040 == FFEINFO_basictypeCOMPLEX)
4042 if (kt == FFEINFO_kindtypeREAL1)
4043 gfrt = FFECOM_gfrtCABS;
4044 else if (kt == FFEINFO_kindtypeREAL2)
4045 gfrt = FFECOM_gfrtCDABS;
4048 return ffecom_1 (ABS_EXPR, tree_type,
4049 convert (tree_type, ffecom_expr (arg1)));
4051 case FFEINTRIN_impACOS:
4052 case FFEINTRIN_impDACOS:
4055 case FFEINTRIN_impAIMAG:
4056 case FFEINTRIN_impDIMAG:
4057 case FFEINTRIN_impIMAGPART:
4058 if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4059 arg1_type = TREE_TYPE (arg1_type);
4061 arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4065 ffecom_1 (IMAGPART_EXPR, arg1_type,
4066 ffecom_expr (arg1)));
4068 case FFEINTRIN_impAINT:
4069 case FFEINTRIN_impDINT:
4071 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
4072 return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
4073 #else /* in the meantime, must use floor to avoid range problems with ints */
4074 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
4075 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4078 ffecom_3 (COND_EXPR, double_type_node,
4080 (ffecom_2 (GE_EXPR, integer_type_node,
4083 ffecom_float_zero_))),
4084 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4085 build_tree_list (NULL_TREE,
4086 convert (double_type_node,
4089 ffecom_1 (NEGATE_EXPR, double_type_node,
4090 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4091 build_tree_list (NULL_TREE,
4092 convert (double_type_node,
4093 ffecom_1 (NEGATE_EXPR,
4101 case FFEINTRIN_impANINT:
4102 case FFEINTRIN_impDNINT:
4103 #if 0 /* This way of doing it won't handle real
4104 numbers of large magnitudes. */
4105 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4106 expr_tree = convert (tree_type,
4107 convert (integer_type_node,
4108 ffecom_3 (COND_EXPR, tree_type,
4113 ffecom_float_zero_)),
4114 ffecom_2 (PLUS_EXPR,
4117 ffecom_float_half_),
4118 ffecom_2 (MINUS_EXPR,
4121 ffecom_float_half_))));
4123 #else /* So we instead call floor. */
4124 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4125 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4128 ffecom_3 (COND_EXPR, double_type_node,
4130 (ffecom_2 (GE_EXPR, integer_type_node,
4133 ffecom_float_zero_))),
4134 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4135 build_tree_list (NULL_TREE,
4136 convert (double_type_node,
4137 ffecom_2 (PLUS_EXPR,
4141 ffecom_float_half_)))),
4143 ffecom_1 (NEGATE_EXPR, double_type_node,
4144 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4145 build_tree_list (NULL_TREE,
4146 convert (double_type_node,
4147 ffecom_2 (MINUS_EXPR,
4150 ffecom_float_half_),
4157 case FFEINTRIN_impASIN:
4158 case FFEINTRIN_impDASIN:
4159 case FFEINTRIN_impATAN:
4160 case FFEINTRIN_impDATAN:
4161 case FFEINTRIN_impATAN2:
4162 case FFEINTRIN_impDATAN2:
4165 case FFEINTRIN_impCHAR:
4166 case FFEINTRIN_impACHAR:
4168 tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4170 tempvar = ffebld_nonter_hook (expr);
4174 tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4176 expr_tree = ffecom_modify (tmv,
4177 ffecom_2 (ARRAY_REF, tmv, tempvar,
4179 convert (tmv, ffecom_expr (arg1)));
4181 expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4184 expr_tree = ffecom_1 (ADDR_EXPR,
4185 build_pointer_type (TREE_TYPE (expr_tree)),
4189 case FFEINTRIN_impCMPLX:
4190 case FFEINTRIN_impDCMPLX:
4193 convert (tree_type, ffecom_expr (arg1));
4195 real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4197 ffecom_2 (COMPLEX_EXPR, tree_type,
4198 convert (real_type, ffecom_expr (arg1)),
4200 ffecom_expr (arg2)));
4202 case FFEINTRIN_impCOMPLEX:
4204 ffecom_2 (COMPLEX_EXPR, tree_type,
4206 ffecom_expr (arg2));
4208 case FFEINTRIN_impCONJG:
4209 case FFEINTRIN_impDCONJG:
4213 real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4214 arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4216 ffecom_2 (COMPLEX_EXPR, tree_type,
4217 ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4218 ffecom_1 (NEGATE_EXPR, real_type,
4219 ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4222 case FFEINTRIN_impCOS:
4223 case FFEINTRIN_impCCOS:
4224 case FFEINTRIN_impCDCOS:
4225 case FFEINTRIN_impDCOS:
4226 if (bt == FFEINFO_basictypeCOMPLEX)
4228 if (kt == FFEINFO_kindtypeREAL1)
4229 gfrt = FFECOM_gfrtCCOS; /* Overlapping result okay. */
4230 else if (kt == FFEINFO_kindtypeREAL2)
4231 gfrt = FFECOM_gfrtCDCOS; /* Overlapping result okay. */
4235 case FFEINTRIN_impCOSH:
4236 case FFEINTRIN_impDCOSH:
4239 case FFEINTRIN_impDBLE:
4240 case FFEINTRIN_impDFLOAT:
4241 case FFEINTRIN_impDREAL:
4242 case FFEINTRIN_impFLOAT:
4243 case FFEINTRIN_impIDINT:
4244 case FFEINTRIN_impIFIX:
4245 case FFEINTRIN_impINT2:
4246 case FFEINTRIN_impINT8:
4247 case FFEINTRIN_impINT:
4248 case FFEINTRIN_impLONG:
4249 case FFEINTRIN_impREAL:
4250 case FFEINTRIN_impSHORT:
4251 case FFEINTRIN_impSNGL:
4252 return convert (tree_type, ffecom_expr (arg1));
4254 case FFEINTRIN_impDIM:
4255 case FFEINTRIN_impDDIM:
4256 case FFEINTRIN_impIDIM:
4257 saved_expr1 = ffecom_save_tree (convert (tree_type,
4258 ffecom_expr (arg1)));
4259 saved_expr2 = ffecom_save_tree (convert (tree_type,
4260 ffecom_expr (arg2)));
4262 ffecom_3 (COND_EXPR, tree_type,
4264 (ffecom_2 (GT_EXPR, integer_type_node,
4267 ffecom_2 (MINUS_EXPR, tree_type,
4270 convert (tree_type, ffecom_float_zero_));
4272 case FFEINTRIN_impDPROD:
4274 ffecom_2 (MULT_EXPR, tree_type,
4275 convert (tree_type, ffecom_expr (arg1)),
4276 convert (tree_type, ffecom_expr (arg2)));
4278 case FFEINTRIN_impEXP:
4279 case FFEINTRIN_impCDEXP:
4280 case FFEINTRIN_impCEXP:
4281 case FFEINTRIN_impDEXP:
4282 if (bt == FFEINFO_basictypeCOMPLEX)
4284 if (kt == FFEINFO_kindtypeREAL1)
4285 gfrt = FFECOM_gfrtCEXP; /* Overlapping result okay. */
4286 else if (kt == FFEINFO_kindtypeREAL2)
4287 gfrt = FFECOM_gfrtCDEXP; /* Overlapping result okay. */
4291 case FFEINTRIN_impICHAR:
4292 case FFEINTRIN_impIACHAR:
4293 #if 0 /* The simple approach. */
4294 ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4296 = ffecom_1 (INDIRECT_REF,
4297 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4300 = ffecom_2 (ARRAY_REF,
4301 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4304 return convert (tree_type, expr_tree);
4305 #else /* The more interesting (and more optimal) approach. */
4306 expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4307 expr_tree = ffecom_3 (COND_EXPR, tree_type,
4310 convert (tree_type, integer_zero_node));
4314 case FFEINTRIN_impINDEX:
4317 case FFEINTRIN_impLEN:
4319 break; /* The simple approach. */
4321 return ffecom_intrinsic_len_ (arg1); /* The more optimal approach. */
4324 case FFEINTRIN_impLGE:
4325 case FFEINTRIN_impLGT:
4326 case FFEINTRIN_impLLE:
4327 case FFEINTRIN_impLLT:
4330 case FFEINTRIN_impLOG:
4331 case FFEINTRIN_impALOG:
4332 case FFEINTRIN_impCDLOG:
4333 case FFEINTRIN_impCLOG:
4334 case FFEINTRIN_impDLOG:
4335 if (bt == FFEINFO_basictypeCOMPLEX)
4337 if (kt == FFEINFO_kindtypeREAL1)
4338 gfrt = FFECOM_gfrtCLOG; /* Overlapping result okay. */
4339 else if (kt == FFEINFO_kindtypeREAL2)
4340 gfrt = FFECOM_gfrtCDLOG; /* Overlapping result okay. */
4344 case FFEINTRIN_impLOG10:
4345 case FFEINTRIN_impALOG10:
4346 case FFEINTRIN_impDLOG10:
4347 if (gfrt != FFECOM_gfrt)
4348 break; /* Already picked one, stick with it. */
4350 if (kt == FFEINFO_kindtypeREAL1)
4351 /* We used to call FFECOM_gfrtALOG10 here. */
4352 gfrt = FFECOM_gfrtL_LOG10;
4353 else if (kt == FFEINFO_kindtypeREAL2)
4354 /* We used to call FFECOM_gfrtDLOG10 here. */
4355 gfrt = FFECOM_gfrtL_LOG10;
4358 case FFEINTRIN_impMAX:
4359 case FFEINTRIN_impAMAX0:
4360 case FFEINTRIN_impAMAX1:
4361 case FFEINTRIN_impDMAX1:
4362 case FFEINTRIN_impMAX0:
4363 case FFEINTRIN_impMAX1:
4364 if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4365 arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4367 arg1_type = tree_type;
4368 expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4369 convert (arg1_type, ffecom_expr (arg1)),
4370 convert (arg1_type, ffecom_expr (arg2)));
4371 for (; list != NULL; list = ffebld_trail (list))
4373 if ((ffebld_head (list) == NULL)
4374 || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4376 expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4379 ffecom_expr (ffebld_head (list))));
4381 return convert (tree_type, expr_tree);
4383 case FFEINTRIN_impMIN:
4384 case FFEINTRIN_impAMIN0:
4385 case FFEINTRIN_impAMIN1:
4386 case FFEINTRIN_impDMIN1:
4387 case FFEINTRIN_impMIN0:
4388 case FFEINTRIN_impMIN1:
4389 if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4390 arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4392 arg1_type = tree_type;
4393 expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4394 convert (arg1_type, ffecom_expr (arg1)),
4395 convert (arg1_type, ffecom_expr (arg2)));
4396 for (; list != NULL; list = ffebld_trail (list))
4398 if ((ffebld_head (list) == NULL)
4399 || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4401 expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4404 ffecom_expr (ffebld_head (list))));
4406 return convert (tree_type, expr_tree);
4408 case FFEINTRIN_impMOD:
4409 case FFEINTRIN_impAMOD:
4410 case FFEINTRIN_impDMOD:
4411 if (bt != FFEINFO_basictypeREAL)
4412 return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4413 convert (tree_type, ffecom_expr (arg1)),
4414 convert (tree_type, ffecom_expr (arg2)));
4416 if (kt == FFEINFO_kindtypeREAL1)
4417 /* We used to call FFECOM_gfrtAMOD here. */
4418 gfrt = FFECOM_gfrtL_FMOD;
4419 else if (kt == FFEINFO_kindtypeREAL2)
4420 /* We used to call FFECOM_gfrtDMOD here. */
4421 gfrt = FFECOM_gfrtL_FMOD;
4424 case FFEINTRIN_impNINT:
4425 case FFEINTRIN_impIDNINT:
4427 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4428 return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4430 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4431 saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4433 convert (ffecom_integer_type_node,
4434 ffecom_3 (COND_EXPR, arg1_type,
4436 (ffecom_2 (GE_EXPR, integer_type_node,
4439 ffecom_float_zero_))),
4440 ffecom_2 (PLUS_EXPR, arg1_type,
4443 ffecom_float_half_)),
4444 ffecom_2 (MINUS_EXPR, arg1_type,
4447 ffecom_float_half_))));
4450 case FFEINTRIN_impSIGN:
4451 case FFEINTRIN_impDSIGN:
4452 case FFEINTRIN_impISIGN:
4454 tree arg2_tree = ffecom_expr (arg2);
4458 (ffecom_1 (ABS_EXPR, tree_type,
4460 ffecom_expr (arg1))));
4462 = ffecom_3 (COND_EXPR, tree_type,
4464 (ffecom_2 (GE_EXPR, integer_type_node,
4466 convert (TREE_TYPE (arg2_tree),
4467 integer_zero_node))),
4469 ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4470 /* Make sure SAVE_EXPRs get referenced early enough. */
4472 = ffecom_2 (COMPOUND_EXPR, tree_type,
4473 convert (void_type_node, saved_expr1),
4478 case FFEINTRIN_impSIN:
4479 case FFEINTRIN_impCDSIN:
4480 case FFEINTRIN_impCSIN:
4481 case FFEINTRIN_impDSIN:
4482 if (bt == FFEINFO_basictypeCOMPLEX)
4484 if (kt == FFEINFO_kindtypeREAL1)
4485 gfrt = FFECOM_gfrtCSIN; /* Overlapping result okay. */
4486 else if (kt == FFEINFO_kindtypeREAL2)
4487 gfrt = FFECOM_gfrtCDSIN; /* Overlapping result okay. */
4491 case FFEINTRIN_impSINH:
4492 case FFEINTRIN_impDSINH:
4495 case FFEINTRIN_impSQRT:
4496 case FFEINTRIN_impCDSQRT:
4497 case FFEINTRIN_impCSQRT:
4498 case FFEINTRIN_impDSQRT:
4499 if (bt == FFEINFO_basictypeCOMPLEX)
4501 if (kt == FFEINFO_kindtypeREAL1)
4502 gfrt = FFECOM_gfrtCSQRT; /* Overlapping result okay. */
4503 else if (kt == FFEINFO_kindtypeREAL2)
4504 gfrt = FFECOM_gfrtCDSQRT; /* Overlapping result okay. */
4508 case FFEINTRIN_impTAN:
4509 case FFEINTRIN_impDTAN:
4510 case FFEINTRIN_impTANH:
4511 case FFEINTRIN_impDTANH:
4514 case FFEINTRIN_impREALPART:
4515 if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4516 arg1_type = TREE_TYPE (arg1_type);
4518 arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4522 ffecom_1 (REALPART_EXPR, arg1_type,
4523 ffecom_expr (arg1)));
4525 case FFEINTRIN_impIAND:
4526 case FFEINTRIN_impAND:
4527 return ffecom_2 (BIT_AND_EXPR, tree_type,
4529 ffecom_expr (arg1)),
4531 ffecom_expr (arg2)));
4533 case FFEINTRIN_impIOR:
4534 case FFEINTRIN_impOR:
4535 return ffecom_2 (BIT_IOR_EXPR, tree_type,
4537 ffecom_expr (arg1)),
4539 ffecom_expr (arg2)));
4541 case FFEINTRIN_impIEOR:
4542 case FFEINTRIN_impXOR:
4543 return ffecom_2 (BIT_XOR_EXPR, tree_type,
4545 ffecom_expr (arg1)),
4547 ffecom_expr (arg2)));
4549 case FFEINTRIN_impLSHIFT:
4550 return ffecom_2 (LSHIFT_EXPR, tree_type,
4552 convert (integer_type_node,
4553 ffecom_expr (arg2)));
4555 case FFEINTRIN_impRSHIFT:
4556 return ffecom_2 (RSHIFT_EXPR, tree_type,
4558 convert (integer_type_node,
4559 ffecom_expr (arg2)));
4561 case FFEINTRIN_impNOT:
4562 return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4564 case FFEINTRIN_impBIT_SIZE:
4565 return convert (tree_type, TYPE_SIZE (arg1_type));
4567 case FFEINTRIN_impBTEST:
4569 ffetargetLogical1 true;
4570 ffetargetLogical1 false;
4574 ffetarget_logical1 (&true, TRUE);
4575 ffetarget_logical1 (&false, FALSE);
4577 true_tree = convert (tree_type, integer_one_node);
4579 true_tree = convert (tree_type, build_int_2 (true, 0));
4581 false_tree = convert (tree_type, integer_zero_node);
4583 false_tree = convert (tree_type, build_int_2 (false, 0));
4586 ffecom_3 (COND_EXPR, tree_type,
4588 (ffecom_2 (EQ_EXPR, integer_type_node,
4589 ffecom_2 (BIT_AND_EXPR, arg1_type,
4591 ffecom_2 (LSHIFT_EXPR, arg1_type,
4594 convert (integer_type_node,
4595 ffecom_expr (arg2)))),
4597 integer_zero_node))),
4602 case FFEINTRIN_impIBCLR:
4604 ffecom_2 (BIT_AND_EXPR, tree_type,
4606 ffecom_1 (BIT_NOT_EXPR, tree_type,
4607 ffecom_2 (LSHIFT_EXPR, tree_type,
4610 convert (integer_type_node,
4611 ffecom_expr (arg2)))));
4613 case FFEINTRIN_impIBITS:
4615 tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4616 ffecom_expr (arg3)));
4618 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4621 = ffecom_2 (BIT_AND_EXPR, tree_type,
4622 ffecom_2 (RSHIFT_EXPR, tree_type,
4624 convert (integer_type_node,
4625 ffecom_expr (arg2))),
4627 ffecom_2 (RSHIFT_EXPR, uns_type,
4628 ffecom_1 (BIT_NOT_EXPR,
4631 integer_zero_node)),
4632 ffecom_2 (MINUS_EXPR,
4634 TYPE_SIZE (uns_type),
4636 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4638 = ffecom_3 (COND_EXPR, tree_type,
4640 (ffecom_2 (NE_EXPR, integer_type_node,
4642 integer_zero_node)),
4644 convert (tree_type, integer_zero_node));
4649 case FFEINTRIN_impIBSET:
4651 ffecom_2 (BIT_IOR_EXPR, tree_type,
4653 ffecom_2 (LSHIFT_EXPR, tree_type,
4654 convert (tree_type, integer_one_node),
4655 convert (integer_type_node,
4656 ffecom_expr (arg2))));
4658 case FFEINTRIN_impISHFT:
4660 tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4661 tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4662 ffecom_expr (arg2)));
4664 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4667 = ffecom_3 (COND_EXPR, tree_type,
4669 (ffecom_2 (GE_EXPR, integer_type_node,
4671 integer_zero_node)),
4672 ffecom_2 (LSHIFT_EXPR, tree_type,
4676 ffecom_2 (RSHIFT_EXPR, uns_type,
4677 convert (uns_type, arg1_tree),
4678 ffecom_1 (NEGATE_EXPR,
4681 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4683 = ffecom_3 (COND_EXPR, tree_type,
4685 (ffecom_2 (NE_EXPR, integer_type_node,
4687 TYPE_SIZE (uns_type))),
4689 convert (tree_type, integer_zero_node));
4691 /* Make sure SAVE_EXPRs get referenced early enough. */
4693 = ffecom_2 (COMPOUND_EXPR, tree_type,
4694 convert (void_type_node, arg1_tree),
4695 ffecom_2 (COMPOUND_EXPR, tree_type,
4696 convert (void_type_node, arg2_tree),
4701 case FFEINTRIN_impISHFTC:
4703 tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4704 tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4705 ffecom_expr (arg2)));
4706 tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4707 : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4713 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4716 = ffecom_2 (LSHIFT_EXPR, tree_type,
4717 ffecom_1 (BIT_NOT_EXPR, tree_type,
4718 convert (tree_type, integer_zero_node)),
4720 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4722 = ffecom_3 (COND_EXPR, tree_type,
4724 (ffecom_2 (NE_EXPR, integer_type_node,
4726 TYPE_SIZE (uns_type))),
4728 convert (tree_type, integer_zero_node));
4730 mask_arg1 = ffecom_save_tree (mask_arg1);
4732 = ffecom_2 (BIT_AND_EXPR, tree_type,
4734 ffecom_1 (BIT_NOT_EXPR, tree_type,
4736 masked_arg1 = ffecom_save_tree (masked_arg1);
4738 = ffecom_2 (BIT_IOR_EXPR, tree_type,
4740 ffecom_2 (RSHIFT_EXPR, uns_type,
4741 convert (uns_type, masked_arg1),
4742 ffecom_1 (NEGATE_EXPR,
4745 ffecom_2 (LSHIFT_EXPR, tree_type,
4747 ffecom_2 (PLUS_EXPR, integer_type_node,
4751 = ffecom_2 (BIT_IOR_EXPR, tree_type,
4752 ffecom_2 (LSHIFT_EXPR, tree_type,
4756 ffecom_2 (RSHIFT_EXPR, uns_type,
4757 convert (uns_type, masked_arg1),
4758 ffecom_2 (MINUS_EXPR,
4763 = ffecom_3 (COND_EXPR, tree_type,
4765 (ffecom_2 (LT_EXPR, integer_type_node,
4767 integer_zero_node)),
4771 = ffecom_2 (BIT_IOR_EXPR, tree_type,
4772 ffecom_2 (BIT_AND_EXPR, tree_type,
4775 ffecom_2 (BIT_AND_EXPR, tree_type,
4776 ffecom_1 (BIT_NOT_EXPR, tree_type,
4780 = ffecom_3 (COND_EXPR, tree_type,
4782 (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4783 ffecom_2 (EQ_EXPR, integer_type_node,
4788 ffecom_2 (EQ_EXPR, integer_type_node,
4790 integer_zero_node))),
4793 /* Make sure SAVE_EXPRs get referenced early enough. */
4795 = ffecom_2 (COMPOUND_EXPR, tree_type,
4796 convert (void_type_node, arg1_tree),
4797 ffecom_2 (COMPOUND_EXPR, tree_type,
4798 convert (void_type_node, arg2_tree),
4799 ffecom_2 (COMPOUND_EXPR, tree_type,
4800 convert (void_type_node,
4802 ffecom_2 (COMPOUND_EXPR, tree_type,
4803 convert (void_type_node,
4807 = ffecom_2 (COMPOUND_EXPR, tree_type,
4808 convert (void_type_node,
4814 case FFEINTRIN_impLOC:
4816 tree arg1_tree = ffecom_expr (arg1);
4819 = convert (tree_type,
4820 ffecom_1 (ADDR_EXPR,
4821 build_pointer_type (TREE_TYPE (arg1_tree)),
4826 case FFEINTRIN_impMVBITS:
4831 ffebld arg4 = ffebld_head (ffebld_trail (list));
4834 ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4838 tree arg5_plus_arg3;
4840 arg2_tree = convert (integer_type_node,
4841 ffecom_expr (arg2));
4842 arg3_tree = ffecom_save_tree (convert (integer_type_node,
4843 ffecom_expr (arg3)));
4844 arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4845 arg4_type = TREE_TYPE (arg4_tree);
4847 arg1_tree = ffecom_save_tree (convert (arg4_type,
4848 ffecom_expr (arg1)));
4850 arg5_tree = ffecom_save_tree (convert (integer_type_node,
4851 ffecom_expr (arg5)));
4854 = ffecom_2 (LSHIFT_EXPR, arg4_type,
4855 ffecom_2 (BIT_AND_EXPR, arg4_type,
4856 ffecom_2 (RSHIFT_EXPR, arg4_type,
4859 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4860 ffecom_2 (LSHIFT_EXPR, arg4_type,
4861 ffecom_1 (BIT_NOT_EXPR,
4865 integer_zero_node)),
4869 = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4873 = ffecom_2 (LSHIFT_EXPR, arg4_type,
4874 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4876 integer_zero_node)),
4878 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4880 = ffecom_3 (COND_EXPR, arg4_type,
4882 (ffecom_2 (NE_EXPR, integer_type_node,
4884 convert (TREE_TYPE (arg5_plus_arg3),
4885 TYPE_SIZE (arg4_type)))),
4887 convert (arg4_type, integer_zero_node));
4890 = ffecom_2 (BIT_AND_EXPR, arg4_type,
4892 ffecom_2 (BIT_IOR_EXPR, arg4_type,
4894 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4895 ffecom_2 (LSHIFT_EXPR, arg4_type,
4896 ffecom_1 (BIT_NOT_EXPR,
4900 integer_zero_node)),
4903 = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4906 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4908 = ffecom_3 (COND_EXPR, arg4_type,
4910 (ffecom_2 (NE_EXPR, integer_type_node,
4912 convert (TREE_TYPE (arg3_tree),
4913 integer_zero_node))),
4917 = ffecom_3 (COND_EXPR, arg4_type,
4919 (ffecom_2 (NE_EXPR, integer_type_node,
4921 convert (TREE_TYPE (arg3_tree),
4922 TYPE_SIZE (arg4_type)))),
4927 = ffecom_2s (MODIFY_EXPR, void_type_node,
4930 /* Make sure SAVE_EXPRs get referenced early enough. */
4932 = ffecom_2 (COMPOUND_EXPR, void_type_node,
4934 ffecom_2 (COMPOUND_EXPR, void_type_node,
4936 ffecom_2 (COMPOUND_EXPR, void_type_node,
4938 ffecom_2 (COMPOUND_EXPR, void_type_node,
4942 = ffecom_2 (COMPOUND_EXPR, void_type_node,
4949 case FFEINTRIN_impDERF:
4950 case FFEINTRIN_impERF:
4951 case FFEINTRIN_impDERFC:
4952 case FFEINTRIN_impERFC:
4955 case FFEINTRIN_impIARGC:
4956 /* extern int xargc; i__1 = xargc - 1; */
4957 expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4959 convert (TREE_TYPE (ffecom_tree_xargc_),
4963 case FFEINTRIN_impSIGNAL_func:
4964 case FFEINTRIN_impSIGNAL_subr:
4970 arg1_tree = convert (ffecom_f2c_integer_type_node,
4971 ffecom_expr (arg1));
4972 arg1_tree = ffecom_1 (ADDR_EXPR,
4973 build_pointer_type (TREE_TYPE (arg1_tree)),
4976 /* Pass procedure as a pointer to it, anything else by value. */
4977 if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4978 arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4980 arg2_tree = ffecom_ptr_to_expr (arg2);
4981 arg2_tree = convert (TREE_TYPE (null_pointer_node),
4985 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4987 arg3_tree = NULL_TREE;
4989 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4990 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4991 TREE_CHAIN (arg1_tree) = arg2_tree;
4994 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4995 ffecom_gfrt_kindtype (gfrt),
4997 ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
5001 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5002 ffebld_nonter_hook (expr));
5004 if (arg3_tree != NULL_TREE)
5006 = ffecom_modify (NULL_TREE, arg3_tree,
5007 convert (TREE_TYPE (arg3_tree),
5012 case FFEINTRIN_impALARM:
5018 arg1_tree = convert (ffecom_f2c_integer_type_node,
5019 ffecom_expr (arg1));
5020 arg1_tree = ffecom_1 (ADDR_EXPR,
5021 build_pointer_type (TREE_TYPE (arg1_tree)),
5024 /* Pass procedure as a pointer to it, anything else by value. */
5025 if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
5026 arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
5028 arg2_tree = ffecom_ptr_to_expr (arg2);
5029 arg2_tree = convert (TREE_TYPE (null_pointer_node),
5033 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5035 arg3_tree = NULL_TREE;
5037 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5038 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5039 TREE_CHAIN (arg1_tree) = arg2_tree;
5042 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5043 ffecom_gfrt_kindtype (gfrt),
5047 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5048 ffebld_nonter_hook (expr));
5050 if (arg3_tree != NULL_TREE)
5052 = ffecom_modify (NULL_TREE, arg3_tree,
5053 convert (TREE_TYPE (arg3_tree),
5058 case FFEINTRIN_impCHDIR_subr:
5059 case FFEINTRIN_impFDATE_subr:
5060 case FFEINTRIN_impFGET_subr:
5061 case FFEINTRIN_impFPUT_subr:
5062 case FFEINTRIN_impGETCWD_subr:
5063 case FFEINTRIN_impHOSTNM_subr:
5064 case FFEINTRIN_impSYSTEM_subr:
5065 case FFEINTRIN_impUNLINK_subr:
5067 tree arg1_len = integer_zero_node;
5071 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5074 arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5076 arg2_tree = NULL_TREE;
5078 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5079 arg1_len = build_tree_list (NULL_TREE, arg1_len);
5080 TREE_CHAIN (arg1_tree) = arg1_len;
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 if (arg2_tree != NULL_TREE)
5093 = ffecom_modify (NULL_TREE, arg2_tree,
5094 convert (TREE_TYPE (arg2_tree),
5099 case FFEINTRIN_impEXIT:
5103 expr_tree = build_tree_list (NULL_TREE,
5104 ffecom_1 (ADDR_EXPR,
5106 (ffecom_integer_type_node),
5107 integer_zero_node));
5110 ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5111 ffecom_gfrt_kindtype (gfrt),
5115 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5116 ffebld_nonter_hook (expr));
5118 case FFEINTRIN_impFLUSH:
5120 gfrt = FFECOM_gfrtFLUSH;
5122 gfrt = FFECOM_gfrtFLUSH1;
5125 case FFEINTRIN_impCHMOD_subr:
5126 case FFEINTRIN_impLINK_subr:
5127 case FFEINTRIN_impRENAME_subr:
5128 case FFEINTRIN_impSYMLNK_subr:
5130 tree arg1_len = integer_zero_node;
5132 tree arg2_len = integer_zero_node;
5136 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5137 arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5139 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5141 arg3_tree = NULL_TREE;
5143 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5144 arg1_len = build_tree_list (NULL_TREE, arg1_len);
5145 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5146 arg2_len = build_tree_list (NULL_TREE, arg2_len);
5147 TREE_CHAIN (arg1_tree) = arg2_tree;
5148 TREE_CHAIN (arg2_tree) = arg1_len;
5149 TREE_CHAIN (arg1_len) = arg2_len;
5150 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5151 ffecom_gfrt_kindtype (gfrt),
5155 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5156 ffebld_nonter_hook (expr));
5157 if (arg3_tree != NULL_TREE)
5158 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5159 convert (TREE_TYPE (arg3_tree),
5164 case FFEINTRIN_impLSTAT_subr:
5165 case FFEINTRIN_impSTAT_subr:
5167 tree arg1_len = integer_zero_node;
5172 arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5174 arg2_tree = ffecom_ptr_to_expr (arg2);
5177 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5179 arg3_tree = NULL_TREE;
5181 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5182 arg1_len = build_tree_list (NULL_TREE, arg1_len);
5183 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5184 TREE_CHAIN (arg1_tree) = arg2_tree;
5185 TREE_CHAIN (arg2_tree) = arg1_len;
5186 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5187 ffecom_gfrt_kindtype (gfrt),
5191 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5192 ffebld_nonter_hook (expr));
5193 if (arg3_tree != NULL_TREE)
5194 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5195 convert (TREE_TYPE (arg3_tree),
5200 case FFEINTRIN_impFGETC_subr:
5201 case FFEINTRIN_impFPUTC_subr:
5205 tree arg2_len = integer_zero_node;
5208 arg1_tree = convert (ffecom_f2c_integer_type_node,
5209 ffecom_expr (arg1));
5210 arg1_tree = ffecom_1 (ADDR_EXPR,
5211 build_pointer_type (TREE_TYPE (arg1_tree)),
5214 arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5216 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5218 arg3_tree = NULL_TREE;
5220 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5221 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5222 arg2_len = build_tree_list (NULL_TREE, arg2_len);
5223 TREE_CHAIN (arg1_tree) = arg2_tree;
5224 TREE_CHAIN (arg2_tree) = arg2_len;
5226 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5227 ffecom_gfrt_kindtype (gfrt),
5231 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5232 ffebld_nonter_hook (expr));
5233 if (arg3_tree != NULL_TREE)
5234 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5235 convert (TREE_TYPE (arg3_tree),
5240 case FFEINTRIN_impFSTAT_subr:
5246 arg1_tree = convert (ffecom_f2c_integer_type_node,
5247 ffecom_expr (arg1));
5248 arg1_tree = ffecom_1 (ADDR_EXPR,
5249 build_pointer_type (TREE_TYPE (arg1_tree)),
5252 arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5253 ffecom_ptr_to_expr (arg2));
5256 arg3_tree = NULL_TREE;
5258 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5260 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5261 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5262 TREE_CHAIN (arg1_tree) = arg2_tree;
5263 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5264 ffecom_gfrt_kindtype (gfrt),
5268 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5269 ffebld_nonter_hook (expr));
5270 if (arg3_tree != NULL_TREE) {
5271 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5272 convert (TREE_TYPE (arg3_tree),
5278 case FFEINTRIN_impKILL_subr:
5284 arg1_tree = convert (ffecom_f2c_integer_type_node,
5285 ffecom_expr (arg1));
5286 arg1_tree = ffecom_1 (ADDR_EXPR,
5287 build_pointer_type (TREE_TYPE (arg1_tree)),
5290 arg2_tree = convert (ffecom_f2c_integer_type_node,
5291 ffecom_expr (arg2));
5292 arg2_tree = ffecom_1 (ADDR_EXPR,
5293 build_pointer_type (TREE_TYPE (arg2_tree)),
5297 arg3_tree = NULL_TREE;
5299 arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5301 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5302 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5303 TREE_CHAIN (arg1_tree) = arg2_tree;
5304 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5305 ffecom_gfrt_kindtype (gfrt),
5309 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5310 ffebld_nonter_hook (expr));
5311 if (arg3_tree != NULL_TREE) {
5312 expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5313 convert (TREE_TYPE (arg3_tree),
5319 case FFEINTRIN_impCTIME_subr:
5320 case FFEINTRIN_impTTYNAM_subr:
5322 tree arg1_len = integer_zero_node;
5326 arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5328 arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5329 ffecom_f2c_longint_type_node :
5330 ffecom_f2c_integer_type_node),
5331 ffecom_expr (arg1));
5332 arg2_tree = ffecom_1 (ADDR_EXPR,
5333 build_pointer_type (TREE_TYPE (arg2_tree)),
5336 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5337 arg1_len = build_tree_list (NULL_TREE, arg1_len);
5338 arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5339 TREE_CHAIN (arg1_len) = arg2_tree;
5340 TREE_CHAIN (arg1_tree) = arg1_len;
5343 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5344 ffecom_gfrt_kindtype (gfrt),
5348 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5349 ffebld_nonter_hook (expr));
5350 TREE_SIDE_EFFECTS (expr_tree) = 1;
5354 case FFEINTRIN_impIRAND:
5355 case FFEINTRIN_impRAND:
5356 /* Arg defaults to 0 (normal random case) */
5361 arg1_tree = ffecom_integer_zero_node;
5363 arg1_tree = ffecom_expr (arg1);
5364 arg1_tree = convert (ffecom_f2c_integer_type_node,
5366 arg1_tree = ffecom_1 (ADDR_EXPR,
5367 build_pointer_type (TREE_TYPE (arg1_tree)),
5369 arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5371 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5372 ffecom_gfrt_kindtype (gfrt),
5374 ((codegen_imp == FFEINTRIN_impIRAND) ?
5375 ffecom_f2c_integer_type_node :
5376 ffecom_f2c_real_type_node),
5378 dest_tree, dest, dest_used,
5380 ffebld_nonter_hook (expr));
5384 case FFEINTRIN_impFTELL_subr:
5385 case FFEINTRIN_impUMASK_subr:
5390 arg1_tree = convert (ffecom_f2c_integer_type_node,
5391 ffecom_expr (arg1));
5392 arg1_tree = ffecom_1 (ADDR_EXPR,
5393 build_pointer_type (TREE_TYPE (arg1_tree)),
5397 arg2_tree = NULL_TREE;
5399 arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5401 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5402 ffecom_gfrt_kindtype (gfrt),
5405 build_tree_list (NULL_TREE, arg1_tree),
5406 NULL_TREE, NULL, NULL, NULL_TREE,
5408 ffebld_nonter_hook (expr));
5409 if (arg2_tree != NULL_TREE) {
5410 expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5411 convert (TREE_TYPE (arg2_tree),
5417 case FFEINTRIN_impCPU_TIME:
5418 case FFEINTRIN_impSECOND_subr:
5422 arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5425 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5426 ffecom_gfrt_kindtype (gfrt),
5430 NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5431 ffebld_nonter_hook (expr));
5434 = ffecom_modify (NULL_TREE, arg1_tree,
5435 convert (TREE_TYPE (arg1_tree),
5440 case FFEINTRIN_impDTIME_subr:
5441 case FFEINTRIN_impETIME_subr:
5446 result_tree = ffecom_expr_w (NULL_TREE, arg2);
5448 arg1_tree = ffecom_ptr_to_expr (arg1);
5450 expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5451 ffecom_gfrt_kindtype (gfrt),
5454 build_tree_list (NULL_TREE, arg1_tree),
5455 NULL_TREE, NULL, NULL, NULL_TREE,
5457 ffebld_nonter_hook (expr));
5458 expr_tree = ffecom_modify (NULL_TREE, result_tree,
5459 convert (TREE_TYPE (result_tree),
5464 /* Straightforward calls of libf2c routines: */
5465 case FFEINTRIN_impABORT:
5466 case FFEINTRIN_impACCESS:
5467 case FFEINTRIN_impBESJ0:
5468 case FFEINTRIN_impBESJ1:
5469 case FFEINTRIN_impBESJN:
5470 case FFEINTRIN_impBESY0:
5471 case FFEINTRIN_impBESY1:
5472 case FFEINTRIN_impBESYN:
5473 case FFEINTRIN_impCHDIR_func:
5474 case FFEINTRIN_impCHMOD_func:
5475 case FFEINTRIN_impDATE:
5476 case FFEINTRIN_impDATE_AND_TIME:
5477 case FFEINTRIN_impDBESJ0:
5478 case FFEINTRIN_impDBESJ1:
5479 case FFEINTRIN_impDBESJN:
5480 case FFEINTRIN_impDBESY0:
5481 case FFEINTRIN_impDBESY1:
5482 case FFEINTRIN_impDBESYN:
5483 case FFEINTRIN_impDTIME_func:
5484 case FFEINTRIN_impETIME_func:
5485 case FFEINTRIN_impFGETC_func:
5486 case FFEINTRIN_impFGET_func:
5487 case FFEINTRIN_impFNUM:
5488 case FFEINTRIN_impFPUTC_func:
5489 case FFEINTRIN_impFPUT_func:
5490 case FFEINTRIN_impFSEEK:
5491 case FFEINTRIN_impFSTAT_func:
5492 case FFEINTRIN_impFTELL_func:
5493 case FFEINTRIN_impGERROR:
5494 case FFEINTRIN_impGETARG:
5495 case FFEINTRIN_impGETCWD_func:
5496 case FFEINTRIN_impGETENV:
5497 case FFEINTRIN_impGETGID:
5498 case FFEINTRIN_impGETLOG:
5499 case FFEINTRIN_impGETPID:
5500 case FFEINTRIN_impGETUID:
5501 case FFEINTRIN_impGMTIME:
5502 case FFEINTRIN_impHOSTNM_func:
5503 case FFEINTRIN_impIDATE_unix:
5504 case FFEINTRIN_impIDATE_vxt:
5505 case FFEINTRIN_impIERRNO:
5506 case FFEINTRIN_impISATTY:
5507 case FFEINTRIN_impITIME:
5508 case FFEINTRIN_impKILL_func:
5509 case FFEINTRIN_impLINK_func:
5510 case FFEINTRIN_impLNBLNK:
5511 case FFEINTRIN_impLSTAT_func:
5512 case FFEINTRIN_impLTIME:
5513 case FFEINTRIN_impMCLOCK8:
5514 case FFEINTRIN_impMCLOCK:
5515 case FFEINTRIN_impPERROR:
5516 case FFEINTRIN_impRENAME_func:
5517 case FFEINTRIN_impSECNDS:
5518 case FFEINTRIN_impSECOND_func:
5519 case FFEINTRIN_impSLEEP:
5520 case FFEINTRIN_impSRAND:
5521 case FFEINTRIN_impSTAT_func:
5522 case FFEINTRIN_impSYMLNK_func:
5523 case FFEINTRIN_impSYSTEM_CLOCK:
5524 case FFEINTRIN_impSYSTEM_func:
5525 case FFEINTRIN_impTIME8:
5526 case FFEINTRIN_impTIME_unix:
5527 case FFEINTRIN_impTIME_vxt:
5528 case FFEINTRIN_impUMASK_func:
5529 case FFEINTRIN_impUNLINK_func:
5532 case FFEINTRIN_impCTIME_func: /* CHARACTER functions not handled here. */
5533 case FFEINTRIN_impFDATE_func: /* CHARACTER functions not handled here. */
5534 case FFEINTRIN_impTTYNAM_func: /* CHARACTER functions not handled here. */
5535 case FFEINTRIN_impNONE:
5536 case FFEINTRIN_imp: /* Hush up gcc warning. */
5537 fprintf (stderr, "No %s implementation.\n",
5538 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5539 assert ("unimplemented intrinsic" == NULL);
5540 return error_mark_node;
5543 assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5545 expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5546 ffebld_right (expr));
5548 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5549 (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5551 expr_tree, dest_tree, dest, dest_used,
5553 ffebld_nonter_hook (expr));
5555 /* See bottom of this file for f2c transforms used to determine
5556 many of the above implementations. The info seems to confuse
5557 Emacs's C mode indentation, which is why it's been moved to
5558 the bottom of this source file. */
5562 /* For power (exponentiation) where right-hand operand is type INTEGER,
5563 generate in-line code to do it the fast way (which, if the operand
5564 is a constant, might just mean a series of multiplies). */
5566 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5568 ffecom_expr_power_integer_ (ffebld expr)
5570 tree l = ffecom_expr (ffebld_left (expr));
5571 tree r = ffecom_expr (ffebld_right (expr));
5572 tree ltype = TREE_TYPE (l);
5573 tree rtype = TREE_TYPE (r);
5574 tree result = NULL_TREE;
5576 if (l == error_mark_node
5577 || r == error_mark_node)
5578 return error_mark_node;
5580 if (TREE_CODE (r) == INTEGER_CST)
5582 int sgn = tree_int_cst_sgn (r);
5585 return convert (ltype, integer_one_node);
5587 if ((TREE_CODE (ltype) == INTEGER_TYPE)
5590 /* Reciprocal of integer is either 0, -1, or 1, so after
5591 calculating that (which we leave to the back end to do
5592 or not do optimally), don't bother with any multiplying. */
5594 result = ffecom_tree_divide_ (ltype,
5595 convert (ltype, integer_one_node),
5597 NULL_TREE, NULL, NULL, NULL_TREE);
5598 r = ffecom_1 (NEGATE_EXPR,
5601 if ((TREE_INT_CST_LOW (r) & 1) == 0)
5602 result = ffecom_1 (ABS_EXPR, rtype,
5606 /* Generate appropriate series of multiplies, preceded
5607 by divide if the exponent is negative. */
5613 l = ffecom_tree_divide_ (ltype,
5614 convert (ltype, integer_one_node),
5616 NULL_TREE, NULL, NULL,
5617 ffebld_nonter_hook (expr));
5618 r = ffecom_1 (NEGATE_EXPR, rtype, r);
5619 assert (TREE_CODE (r) == INTEGER_CST);
5621 if (tree_int_cst_sgn (r) < 0)
5622 { /* The "most negative" number. */
5623 r = ffecom_1 (NEGATE_EXPR, rtype,
5624 ffecom_2 (RSHIFT_EXPR, rtype,
5628 l = ffecom_2 (MULT_EXPR, ltype,
5636 if (TREE_INT_CST_LOW (r) & 1)
5638 if (result == NULL_TREE)
5641 result = ffecom_2 (MULT_EXPR, ltype,
5646 r = ffecom_2 (RSHIFT_EXPR, rtype,
5649 if (integer_zerop (r))
5651 assert (TREE_CODE (r) == INTEGER_CST);
5654 l = ffecom_2 (MULT_EXPR, ltype,
5661 /* Though rhs isn't a constant, in-line code cannot be expanded
5662 while transforming dummies
5663 because the back end cannot be easily convinced to generate
5664 stores (MODIFY_EXPR), handle temporaries, and so on before
5665 all the appropriate rtx's have been generated for things like
5666 dummy args referenced in rhs -- which doesn't happen until
5667 store_parm_decls() is called (expand_function_start, I believe,
5668 does the actual rtx-stuffing of PARM_DECLs).
5670 So, in this case, let the caller generate the call to the
5671 run-time-library function to evaluate the power for us. */
5673 if (ffecom_transform_only_dummies_)
5676 /* Right-hand operand not a constant, expand in-line code to figure
5677 out how to do the multiplies, &c.
5679 The returned expression is expressed this way in GNU C, where l and
5682 ({ typeof (r) rtmp = r;
5683 typeof (l) ltmp = l;
5690 if ((basetypeof (l) == basetypeof (int))
5693 result = ((typeof (l)) 1) / ltmp;
5694 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5700 if ((basetypeof (l) != basetypeof (int))
5703 ltmp = ((typeof (l)) 1) / ltmp;
5707 rtmp = -(rtmp >> 1);
5715 if ((rtmp >>= 1) == 0)
5724 Note that some of the above is compile-time collapsable, such as
5725 the first part of the if statements that checks the base type of
5726 l against int. The if statements are phrased that way to suggest
5727 an easy way to generate the if/else constructs here, knowing that
5728 the back end should (and probably does) eliminate the resulting
5729 dead code (either the int case or the non-int case), something
5730 it couldn't do without the redundant phrasing, requiring explicit
5731 dead-code elimination here, which would be kind of difficult to
5738 tree basetypeof_l_is_int;
5743 = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5745 se = expand_start_stmt_expr ();
5747 ffecom_start_compstmt ();
5750 rtmp = ffecom_make_tempvar ("power_r", rtype,
5751 FFETARGET_charactersizeNONE, -1);
5752 ltmp = ffecom_make_tempvar ("power_l", ltype,
5753 FFETARGET_charactersizeNONE, -1);
5754 result = ffecom_make_tempvar ("power_res", ltype,
5755 FFETARGET_charactersizeNONE, -1);
5756 if (TREE_CODE (ltype) == COMPLEX_TYPE
5757 || TREE_CODE (ltype) == RECORD_TYPE)
5758 divide = ffecom_make_tempvar ("power_div", ltype,
5759 FFETARGET_charactersizeNONE, -1);
5766 hook = ffebld_nonter_hook (expr);
5768 assert (TREE_CODE (hook) == TREE_VEC);
5769 assert (TREE_VEC_LENGTH (hook) == 4);
5770 rtmp = TREE_VEC_ELT (hook, 0);
5771 ltmp = TREE_VEC_ELT (hook, 1);
5772 result = TREE_VEC_ELT (hook, 2);
5773 divide = TREE_VEC_ELT (hook, 3);
5774 if (TREE_CODE (ltype) == COMPLEX_TYPE
5775 || TREE_CODE (ltype) == RECORD_TYPE)
5782 expand_expr_stmt (ffecom_modify (void_type_node,
5785 expand_expr_stmt (ffecom_modify (void_type_node,
5788 expand_start_cond (ffecom_truth_value
5789 (ffecom_2 (EQ_EXPR, integer_type_node,
5791 convert (rtype, integer_zero_node))),
5793 expand_expr_stmt (ffecom_modify (void_type_node,
5795 convert (ltype, integer_one_node)));
5796 expand_start_else ();
5797 if (! integer_zerop (basetypeof_l_is_int))
5799 expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5802 integer_zero_node)),
5804 expand_expr_stmt (ffecom_modify (void_type_node,
5808 convert (ltype, integer_one_node),
5810 NULL_TREE, NULL, NULL,
5812 expand_start_cond (ffecom_truth_value
5813 (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5814 ffecom_2 (LT_EXPR, integer_type_node,
5817 integer_zero_node)),
5818 ffecom_2 (EQ_EXPR, integer_type_node,
5819 ffecom_2 (BIT_AND_EXPR,
5821 ffecom_1 (NEGATE_EXPR,
5827 integer_zero_node)))),
5829 expand_expr_stmt (ffecom_modify (void_type_node,
5831 ffecom_1 (NEGATE_EXPR,
5835 expand_start_else ();
5837 expand_expr_stmt (ffecom_modify (void_type_node,
5839 convert (ltype, integer_one_node)));
5840 expand_start_cond (ffecom_truth_value
5841 (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5842 ffecom_truth_value_invert
5843 (basetypeof_l_is_int),
5844 ffecom_2 (LT_EXPR, integer_type_node,
5847 integer_zero_node)))),
5849 expand_expr_stmt (ffecom_modify (void_type_node,
5853 convert (ltype, integer_one_node),
5855 NULL_TREE, NULL, NULL,
5857 expand_expr_stmt (ffecom_modify (void_type_node,
5859 ffecom_1 (NEGATE_EXPR, rtype,
5861 expand_start_cond (ffecom_truth_value
5862 (ffecom_2 (LT_EXPR, integer_type_node,
5864 convert (rtype, integer_zero_node))),
5866 expand_expr_stmt (ffecom_modify (void_type_node,
5868 ffecom_1 (NEGATE_EXPR, 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 expand_start_loop (1);
5881 expand_start_cond (ffecom_truth_value
5882 (ffecom_2 (BIT_AND_EXPR, rtype,
5884 convert (rtype, integer_one_node))),
5886 expand_expr_stmt (ffecom_modify (void_type_node,
5888 ffecom_2 (MULT_EXPR, ltype,
5892 expand_exit_loop_if_false (NULL,
5894 (ffecom_modify (rtype,
5896 ffecom_2 (RSHIFT_EXPR,
5899 integer_one_node))));
5900 expand_expr_stmt (ffecom_modify (void_type_node,
5902 ffecom_2 (MULT_EXPR, ltype,
5907 if (!integer_zerop (basetypeof_l_is_int))
5909 expand_expr_stmt (result);
5911 t = ffecom_end_compstmt ();
5913 result = expand_end_stmt_expr (se);
5915 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5917 if (TREE_CODE (t) == BLOCK)
5919 /* Make a BIND_EXPR for the BLOCK already made. */
5920 result = build (BIND_EXPR, TREE_TYPE (result),
5921 NULL_TREE, result, t);
5922 /* Remove the block from the tree at this point.
5923 It gets put back at the proper place
5924 when the BIND_EXPR is expanded. */
5935 /* ffecom_expr_transform_ -- Transform symbols in expr
5937 ffebld expr; // FFE expression.
5938 ffecom_expr_transform_ (expr);
5940 Recursive descent on expr while transforming any untransformed SYMTERs. */
5942 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5944 ffecom_expr_transform_ (ffebld expr)
5949 tail_recurse: /* :::::::::::::::::::: */
5954 switch (ffebld_op (expr))
5956 case FFEBLD_opSYMTER:
5957 s = ffebld_symter (expr);
5958 t = ffesymbol_hook (s).decl_tree;
5959 if ((t == NULL_TREE)
5960 && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5961 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5962 && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5964 s = ffecom_sym_transform_ (s);
5965 t = ffesymbol_hook (s).decl_tree; /* Sfunc expr non-dummy,
5968 break; /* Ok if (t == NULL) here. */
5971 ffecom_expr_transform_ (ffebld_head (expr));
5972 expr = ffebld_trail (expr);
5973 goto tail_recurse; /* :::::::::::::::::::: */
5979 switch (ffebld_arity (expr))
5982 ffecom_expr_transform_ (ffebld_left (expr));
5983 expr = ffebld_right (expr);
5984 goto tail_recurse; /* :::::::::::::::::::: */
5987 expr = ffebld_left (expr);
5988 goto tail_recurse; /* :::::::::::::::::::: */
5998 /* Make a type based on info in live f2c.h file. */
6000 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6002 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
6006 case FFECOM_f2ccodeCHAR:
6007 *type = make_signed_type (CHAR_TYPE_SIZE);
6010 case FFECOM_f2ccodeSHORT:
6011 *type = make_signed_type (SHORT_TYPE_SIZE);
6014 case FFECOM_f2ccodeINT:
6015 *type = make_signed_type (INT_TYPE_SIZE);
6018 case FFECOM_f2ccodeLONG:
6019 *type = make_signed_type (LONG_TYPE_SIZE);
6022 case FFECOM_f2ccodeLONGLONG:
6023 *type = make_signed_type (LONG_LONG_TYPE_SIZE);
6026 case FFECOM_f2ccodeCHARPTR:
6027 *type = build_pointer_type (DEFAULT_SIGNED_CHAR
6028 ? signed_char_type_node
6029 : unsigned_char_type_node);
6032 case FFECOM_f2ccodeFLOAT:
6033 *type = make_node (REAL_TYPE);
6034 TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
6035 layout_type (*type);
6038 case FFECOM_f2ccodeDOUBLE:
6039 *type = make_node (REAL_TYPE);
6040 TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
6041 layout_type (*type);
6044 case FFECOM_f2ccodeLONGDOUBLE:
6045 *type = make_node (REAL_TYPE);
6046 TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
6047 layout_type (*type);
6050 case FFECOM_f2ccodeTWOREALS:
6051 *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
6054 case FFECOM_f2ccodeTWODOUBLEREALS:
6055 *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
6059 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
6060 *type = error_mark_node;
6064 pushdecl (build_decl (TYPE_DECL,
6065 ffecom_get_invented_identifier ("__g77_f2c_%s", name),
6070 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6071 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6075 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
6081 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
6082 if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
6083 && compare_tree_int (TYPE_SIZE (t), size) == 0)
6085 assert (code != -1);
6086 ffecom_f2c_typecode_[bt][j] = code;
6092 /* Finish up globals after doing all program units in file
6094 Need to handle only uninitialized COMMON areas. */
6096 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6098 ffecom_finish_global_ (ffeglobal global)
6104 if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
6107 if (ffeglobal_common_init (global))
6110 cbt = ffeglobal_hook (global);
6111 if ((cbt == NULL_TREE)
6112 || !ffeglobal_common_have_size (global))
6113 return global; /* No need to make common, never ref'd. */
6115 suspend_momentary ();
6117 DECL_EXTERNAL (cbt) = 0;
6119 /* Give the array a size now. */
6121 size = build_int_2 ((ffeglobal_common_size (global)
6122 + ffeglobal_common_pad (global)) - 1,
6125 cbtype = TREE_TYPE (cbt);
6126 TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6129 if (!TREE_TYPE (size))
6130 TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6131 layout_type (cbtype);
6133 cbt = start_decl (cbt, FALSE);
6134 assert (cbt == ffeglobal_hook (global));
6136 finish_decl (cbt, NULL_TREE, FALSE);
6142 /* Finish up any untransformed symbols. */
6144 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6146 ffecom_finish_symbol_transform_ (ffesymbol s)
6148 if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6151 /* It's easy to know to transform an untransformed symbol, to make sure
6152 we put out debugging info for it. But COMMON variables, unlike
6153 EQUIVALENCE ones, aren't given declarations in addition to the
6154 tree expressions that specify offsets, because COMMON variables
6155 can be referenced in the outer scope where only dummy arguments
6156 (PARM_DECLs) should really be seen. To be safe, just don't do any
6157 VAR_DECLs for COMMON variables when we transform them for real
6158 use, and therefore we do all the VAR_DECL creating here. */
6160 if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6162 if (ffesymbol_kind (s) != FFEINFO_kindNONE
6163 || (ffesymbol_where (s) != FFEINFO_whereNONE
6164 && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6165 && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6166 /* Not transformed, and not CHARACTER*(*), and not a dummy
6167 argument, which can happen only if the entry point names
6168 it "rides in on" are all invalidated for other reasons. */
6169 s = ffecom_sym_transform_ (s);
6172 if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6173 && (ffesymbol_hook (s).decl_tree != error_mark_node))
6175 int yes = suspend_momentary ();
6177 /* This isn't working, at least for dbxout. The .s file looks
6178 okay to me (burley), but in gdb 4.9 at least, the variables
6179 appear to reside somewhere outside of the common area, so
6180 it doesn't make sense to mislead anyone by generating the info
6181 on those variables until this is fixed. NOTE: Same problem
6182 with EQUIVALENCE, sadly...see similar #if later. */
6183 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6184 ffesymbol_storage (s));
6186 resume_momentary (yes);
6193 /* Append underscore(s) to name before calling get_identifier. "us"
6194 is nonzero if the name already contains an underscore and thus
6195 needs two underscores appended. */
6197 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6199 ffecom_get_appended_identifier_ (char us, const char *name)
6205 newname = xmalloc ((i = strlen (name)) + 1
6206 + ffe_is_underscoring ()
6208 memcpy (newname, name, i);
6210 newname[i + us] = '_';
6211 newname[i + 1 + us] = '\0';
6212 id = get_identifier (newname);
6220 /* Decide whether to append underscore to name before calling
6223 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6225 ffecom_get_external_identifier_ (ffesymbol s)
6228 const char *name = ffesymbol_text (s);
6230 /* If name is a built-in name, just return it as is. */
6232 if (!ffe_is_underscoring ()
6233 || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6234 #if FFETARGET_isENFORCED_MAIN_NAME
6235 || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6237 || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6239 || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6240 return get_identifier (name);
6242 us = ffe_is_second_underscore ()
6243 ? (strchr (name, '_') != NULL)
6246 return ffecom_get_appended_identifier_ (us, name);
6250 /* Decide whether to append underscore to internal name before calling
6253 This is for non-external, top-function-context names only. Transform
6254 identifier so it doesn't conflict with the transformed result
6255 of using a _different_ external name. E.g. if "CALL FOO" is
6256 transformed into "FOO_();", then the variable in "FOO_ = 3"
6257 must be transformed into something that does not conflict, since
6258 these two things should be independent.
6260 The transformation is as follows. If the name does not contain
6261 an underscore, there is no possible conflict, so just return.
6262 If the name does contain an underscore, then transform it just
6263 like we transform an external identifier. */
6265 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6267 ffecom_get_identifier_ (const char *name)
6269 /* If name does not contain an underscore, just return it as is. */
6271 if (!ffe_is_underscoring ()
6272 || (strchr (name, '_') == NULL))
6273 return get_identifier (name);
6275 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6280 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6283 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6284 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6285 ffesymbol_kindtype(s));
6287 Call after setting up containing function and getting trees for all
6290 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6292 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6294 ffebld expr = ffesymbol_sfexpr (s);
6298 bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6299 static bool recurse = FALSE;
6301 int old_lineno = lineno;
6302 const char *old_input_filename = input_filename;
6304 ffecom_nested_entry_ = s;
6306 /* For now, we don't have a handy pointer to where the sfunc is actually
6307 defined, though that should be easy to add to an ffesymbol. (The
6308 token/where info available might well point to the place where the type
6309 of the sfunc is declared, especially if that precedes the place where
6310 the sfunc itself is defined, which is typically the case.) We should
6311 put out a null pointer rather than point somewhere wrong, but I want to
6312 see how it works at this point. */
6314 input_filename = ffesymbol_where_filename (s);
6315 lineno = ffesymbol_where_filelinenum (s);
6317 /* Pretransform the expression so any newly discovered things belong to the
6318 outer program unit, not to the statement function. */
6320 ffecom_expr_transform_ (expr);
6322 /* Make sure no recursive invocation of this fn (a specific case of failing
6323 to pretransform an sfunc's expression, i.e. where its expression
6324 references another untransformed sfunc) happens. */
6329 yes = suspend_momentary ();
6331 push_f_function_context ();
6334 type = void_type_node;
6337 type = ffecom_tree_type[bt][kt];
6338 if (type == NULL_TREE)
6339 type = integer_type_node; /* _sym_exec_transition reports
6343 start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6344 build_function_type (type, NULL_TREE),
6345 1, /* nested/inline */
6346 0); /* TREE_PUBLIC */
6348 /* We don't worry about COMPLEX return values here, because this is
6349 entirely internal to our code, and gcc has the ability to return COMPLEX
6350 directly as a value. */
6352 yes = suspend_momentary ();
6355 { /* Prepend arg for where result goes. */
6358 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6360 result = ffecom_get_invented_identifier ("__g77_%s", "result");
6362 ffecom_char_enhance_arg_ (&type, s); /* Ignore returned length. */
6364 type = build_pointer_type (type);
6365 result = build_decl (PARM_DECL, result, type);
6367 push_parm_decl (result);
6370 result = NULL_TREE; /* Not ref'd if !charfunc. */
6372 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6374 resume_momentary (yes);
6376 store_parm_decls (0);
6378 ffecom_start_compstmt ();
6384 ffetargetCharacterSize sz = ffesymbol_size (s);
6387 result_length = build_int_2 (sz, 0);
6388 TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6390 ffecom_prepare_let_char_ (sz, expr);
6392 ffecom_prepare_end ();
6394 ffecom_let_char_ (result, result_length, sz, expr);
6395 expand_null_return ();
6399 ffecom_prepare_expr (expr);
6401 ffecom_prepare_end ();
6403 expand_return (ffecom_modify (NULL_TREE,
6404 DECL_RESULT (current_function_decl),
6405 ffecom_expr (expr)));
6411 ffecom_end_compstmt ();
6413 func = current_function_decl;
6414 finish_function (1);
6416 pop_f_function_context ();
6418 resume_momentary (yes);
6422 lineno = old_lineno;
6423 input_filename = old_input_filename;
6425 ffecom_nested_entry_ = NULL;
6432 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6434 ffecom_gfrt_args_ (ffecomGfrt ix)
6436 return ffecom_gfrt_argstring_[ix];
6440 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6442 ffecom_gfrt_tree_ (ffecomGfrt ix)
6444 if (ffecom_gfrt_[ix] == NULL_TREE)
6445 ffecom_make_gfrt_ (ix);
6447 return ffecom_1 (ADDR_EXPR,
6448 build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6453 /* Return initialize-to-zero expression for this VAR_DECL. */
6455 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6456 /* A somewhat evil way to prevent the garbage collector
6457 from collecting 'tree' structures. */
6458 #define NUM_TRACKED_CHUNK 63
6459 static struct tree_ggc_tracker
6461 struct tree_ggc_tracker *next;
6462 tree trees[NUM_TRACKED_CHUNK];
6463 } *tracker_head = NULL;
6466 mark_tracker_head (void *arg)
6468 struct tree_ggc_tracker *head;
6471 for (head = * (struct tree_ggc_tracker **) arg;
6476 for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6477 ggc_mark_tree (head->trees[i]);
6482 ffecom_save_tree_forever (tree t)
6485 if (tracker_head != NULL)
6486 for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6487 if (tracker_head->trees[i] == NULL)
6489 tracker_head->trees[i] = t;
6494 /* Need to allocate a new block. */
6495 struct tree_ggc_tracker *old_head = tracker_head;
6497 tracker_head = ggc_alloc (sizeof (*tracker_head));
6498 tracker_head->next = old_head;
6499 tracker_head->trees[0] = t;
6500 for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6501 tracker_head->trees[i] = NULL;
6506 ffecom_init_zero_ (tree decl)
6509 int incremental = TREE_STATIC (decl);
6510 tree type = TREE_TYPE (decl);
6514 make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
6515 assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6520 if ((TREE_CODE (type) != ARRAY_TYPE)
6521 && (TREE_CODE (type) != RECORD_TYPE)
6522 && (TREE_CODE (type) != UNION_TYPE)
6524 init = convert (type, integer_zero_node);
6525 else if (!incremental)
6527 int momentary = suspend_momentary ();
6529 init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6530 TREE_CONSTANT (init) = 1;
6531 TREE_STATIC (init) = 1;
6533 resume_momentary (momentary);
6537 int momentary = suspend_momentary ();
6539 assemble_zeros (int_size_in_bytes (type));
6540 init = error_mark_node;
6542 resume_momentary (momentary);
6545 pop_momentary_nofree ();
6551 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6553 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6559 switch (ffebld_op (arg))
6561 case FFEBLD_opCONTER: /* For F90, check 0-length. */
6562 if (ffetarget_length_character1
6563 (ffebld_constant_character1
6564 (ffebld_conter (arg))) == 0)
6566 *maybe_tree = integer_zero_node;
6567 return convert (tree_type, integer_zero_node);
6570 *maybe_tree = integer_one_node;
6571 expr_tree = build_int_2 (*ffetarget_text_character1
6572 (ffebld_constant_character1
6573 (ffebld_conter (arg))),
6575 TREE_TYPE (expr_tree) = tree_type;
6578 case FFEBLD_opSYMTER:
6579 case FFEBLD_opARRAYREF:
6580 case FFEBLD_opFUNCREF:
6581 case FFEBLD_opSUBSTR:
6582 ffecom_char_args_ (&expr_tree, &length_tree, arg);
6584 if ((expr_tree == error_mark_node)
6585 || (length_tree == error_mark_node))
6587 *maybe_tree = error_mark_node;
6588 return error_mark_node;
6591 if (integer_zerop (length_tree))
6593 *maybe_tree = integer_zero_node;
6594 return convert (tree_type, integer_zero_node);
6598 = ffecom_1 (INDIRECT_REF,
6599 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6602 = ffecom_2 (ARRAY_REF,
6603 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6606 expr_tree = convert (tree_type, expr_tree);
6608 if (TREE_CODE (length_tree) == INTEGER_CST)
6609 *maybe_tree = integer_one_node;
6610 else /* Must check length at run time. */
6612 = ffecom_truth_value
6613 (ffecom_2 (GT_EXPR, integer_type_node,
6615 ffecom_f2c_ftnlen_zero_node));
6618 case FFEBLD_opPAREN:
6619 case FFEBLD_opCONVERT:
6620 if (ffeinfo_size (ffebld_info (arg)) == 0)
6622 *maybe_tree = integer_zero_node;
6623 return convert (tree_type, integer_zero_node);
6625 return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6628 case FFEBLD_opCONCATENATE:
6635 expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6637 expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6639 *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6642 expr_tree = ffecom_3 (COND_EXPR, tree_type,
6650 assert ("bad op in ICHAR" == NULL);
6651 return error_mark_node;
6656 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6660 length_arg = ffecom_intrinsic_len_ (expr);
6662 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6663 subexpressions by constructing the appropriate tree for the
6664 length-of-character-text argument in a calling sequence. */
6666 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6668 ffecom_intrinsic_len_ (ffebld expr)
6670 ffetargetCharacter1 val;
6673 switch (ffebld_op (expr))
6675 case FFEBLD_opCONTER:
6676 val = ffebld_constant_character1 (ffebld_conter (expr));
6677 length = build_int_2 (ffetarget_length_character1 (val), 0);
6678 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6681 case FFEBLD_opSYMTER:
6683 ffesymbol s = ffebld_symter (expr);
6686 item = ffesymbol_hook (s).decl_tree;
6687 if (item == NULL_TREE)
6689 s = ffecom_sym_transform_ (s);
6690 item = ffesymbol_hook (s).decl_tree;
6692 if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6694 if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6695 length = ffesymbol_hook (s).length_tree;
6698 length = build_int_2 (ffesymbol_size (s), 0);
6699 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6702 else if (item == error_mark_node)
6703 length = error_mark_node;
6704 else /* FFEINFO_kindFUNCTION: */
6709 case FFEBLD_opARRAYREF:
6710 length = ffecom_intrinsic_len_ (ffebld_left (expr));
6713 case FFEBLD_opSUBSTR:
6717 ffebld thing = ffebld_right (expr);
6721 assert (ffebld_op (thing) == FFEBLD_opITEM);
6722 start = ffebld_head (thing);
6723 thing = ffebld_trail (thing);
6724 assert (ffebld_trail (thing) == NULL);
6725 end = ffebld_head (thing);
6727 length = ffecom_intrinsic_len_ (ffebld_left (expr));
6729 if (length == error_mark_node)
6738 length = convert (ffecom_f2c_ftnlen_type_node,
6744 start_tree = convert (ffecom_f2c_ftnlen_type_node,
6745 ffecom_expr (start));
6747 if (start_tree == error_mark_node)
6749 length = error_mark_node;
6755 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6756 ffecom_f2c_ftnlen_one_node,
6757 ffecom_2 (MINUS_EXPR,
6758 ffecom_f2c_ftnlen_type_node,
6764 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6767 if (end_tree == error_mark_node)
6769 length = error_mark_node;
6773 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6774 ffecom_f2c_ftnlen_one_node,
6775 ffecom_2 (MINUS_EXPR,
6776 ffecom_f2c_ftnlen_type_node,
6777 end_tree, start_tree));
6783 case FFEBLD_opCONCATENATE:
6785 = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6786 ffecom_intrinsic_len_ (ffebld_left (expr)),
6787 ffecom_intrinsic_len_ (ffebld_right (expr)));
6790 case FFEBLD_opFUNCREF:
6791 case FFEBLD_opCONVERT:
6792 length = build_int_2 (ffebld_size (expr), 0);
6793 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6797 assert ("bad op for single char arg expr" == NULL);
6798 length = ffecom_f2c_ftnlen_zero_node;
6802 assert (length != NULL_TREE);
6808 /* Handle CHARACTER assignments.
6810 Generates code to do the assignment. Used by ordinary assignment
6811 statement handler ffecom_let_stmt and by statement-function
6812 handler to generate code for a statement function. */
6814 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6816 ffecom_let_char_ (tree dest_tree, tree dest_length,
6817 ffetargetCharacterSize dest_size, ffebld source)
6819 ffecomConcatList_ catlist;
6824 if ((dest_tree == error_mark_node)
6825 || (dest_length == error_mark_node))
6828 assert (dest_tree != NULL_TREE);
6829 assert (dest_length != NULL_TREE);
6831 /* Source might be an opCONVERT, which just means it is a different size
6832 than the destination. Since the underlying implementation here handles
6833 that (directly or via the s_copy or s_cat run-time-library functions),
6834 we don't need the "convenience" of an opCONVERT that tells us to
6835 truncate or blank-pad, particularly since the resulting implementation
6836 would probably be slower than otherwise. */
6838 while (ffebld_op (source) == FFEBLD_opCONVERT)
6839 source = ffebld_left (source);
6841 catlist = ffecom_concat_list_new_ (source, dest_size);
6842 switch (ffecom_concat_list_count_ (catlist))
6844 case 0: /* Shouldn't happen, but in case it does... */
6845 ffecom_concat_list_kill_ (catlist);
6846 source_tree = null_pointer_node;
6847 source_length = ffecom_f2c_ftnlen_zero_node;
6848 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6849 TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6850 TREE_CHAIN (TREE_CHAIN (expr_tree))
6851 = build_tree_list (NULL_TREE, dest_length);
6852 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6853 = build_tree_list (NULL_TREE, source_length);
6855 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6856 TREE_SIDE_EFFECTS (expr_tree) = 1;
6858 expand_expr_stmt (expr_tree);
6862 case 1: /* The (fairly) easy case. */
6863 ffecom_char_args_ (&source_tree, &source_length,
6864 ffecom_concat_list_expr_ (catlist, 0));
6865 ffecom_concat_list_kill_ (catlist);
6866 assert (source_tree != NULL_TREE);
6867 assert (source_length != NULL_TREE);
6869 if ((source_tree == error_mark_node)
6870 || (source_length == error_mark_node))
6876 = ffecom_1 (INDIRECT_REF,
6877 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6881 = ffecom_2 (ARRAY_REF,
6882 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6887 = ffecom_1 (INDIRECT_REF,
6888 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6892 = ffecom_2 (ARRAY_REF,
6893 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6898 expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6900 expand_expr_stmt (expr_tree);
6905 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6906 TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6907 TREE_CHAIN (TREE_CHAIN (expr_tree))
6908 = build_tree_list (NULL_TREE, dest_length);
6909 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6910 = build_tree_list (NULL_TREE, source_length);
6912 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6913 TREE_SIDE_EFFECTS (expr_tree) = 1;
6915 expand_expr_stmt (expr_tree);
6919 default: /* Must actually concatenate things. */
6923 /* Heavy-duty concatenation. */
6926 int count = ffecom_concat_list_count_ (catlist);
6938 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6939 FFETARGET_charactersizeNONE, count, TRUE);
6940 item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6941 FFETARGET_charactersizeNONE,
6947 hook = ffebld_nonter_hook (source);
6949 assert (TREE_CODE (hook) == TREE_VEC);
6950 assert (TREE_VEC_LENGTH (hook) == 2);
6951 length_array = lengths = TREE_VEC_ELT (hook, 0);
6952 item_array = items = TREE_VEC_ELT (hook, 1);
6956 for (i = 0; i < count; ++i)
6958 ffecom_char_args_ (&citem, &clength,
6959 ffecom_concat_list_expr_ (catlist, i));
6960 if ((citem == error_mark_node)
6961 || (clength == error_mark_node))
6963 ffecom_concat_list_kill_ (catlist);
6968 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6969 ffecom_modify (void_type_node,
6970 ffecom_2 (ARRAY_REF,
6971 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6973 build_int_2 (i, 0)),
6977 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6978 ffecom_modify (void_type_node,
6979 ffecom_2 (ARRAY_REF,
6980 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6982 build_int_2 (i, 0)),
6987 expr_tree = build_tree_list (NULL_TREE, dest_tree);
6988 TREE_CHAIN (expr_tree)
6989 = build_tree_list (NULL_TREE,
6990 ffecom_1 (ADDR_EXPR,
6991 build_pointer_type (TREE_TYPE (items)),
6993 TREE_CHAIN (TREE_CHAIN (expr_tree))
6994 = build_tree_list (NULL_TREE,
6995 ffecom_1 (ADDR_EXPR,
6996 build_pointer_type (TREE_TYPE (lengths)),
6998 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
7001 ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
7002 convert (ffecom_f2c_ftnlen_type_node,
7003 build_int_2 (count, 0))));
7004 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
7005 = build_tree_list (NULL_TREE, dest_length);
7007 expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
7008 TREE_SIDE_EFFECTS (expr_tree) = 1;
7010 expand_expr_stmt (expr_tree);
7013 ffecom_concat_list_kill_ (catlist);
7017 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
7020 ffecom_make_gfrt_(ix);
7022 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
7023 for the indicated run-time routine (ix). */
7025 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7027 ffecom_make_gfrt_ (ffecomGfrt ix)
7032 switch (ffecom_gfrt_type_[ix])
7034 case FFECOM_rttypeVOID_:
7035 ttype = void_type_node;
7038 case FFECOM_rttypeVOIDSTAR_:
7039 ttype = TREE_TYPE (null_pointer_node); /* `void *'. */
7042 case FFECOM_rttypeFTNINT_:
7043 ttype = ffecom_f2c_ftnint_type_node;
7046 case FFECOM_rttypeINTEGER_:
7047 ttype = ffecom_f2c_integer_type_node;
7050 case FFECOM_rttypeLONGINT_:
7051 ttype = ffecom_f2c_longint_type_node;
7054 case FFECOM_rttypeLOGICAL_:
7055 ttype = ffecom_f2c_logical_type_node;
7058 case FFECOM_rttypeREAL_F2C_:
7059 ttype = double_type_node;
7062 case FFECOM_rttypeREAL_GNU_:
7063 ttype = float_type_node;
7066 case FFECOM_rttypeCOMPLEX_F2C_:
7067 ttype = void_type_node;
7070 case FFECOM_rttypeCOMPLEX_GNU_:
7071 ttype = ffecom_f2c_complex_type_node;
7074 case FFECOM_rttypeDOUBLE_:
7075 ttype = double_type_node;
7078 case FFECOM_rttypeDOUBLEREAL_:
7079 ttype = ffecom_f2c_doublereal_type_node;
7082 case FFECOM_rttypeDBLCMPLX_F2C_:
7083 ttype = void_type_node;
7086 case FFECOM_rttypeDBLCMPLX_GNU_:
7087 ttype = ffecom_f2c_doublecomplex_type_node;
7090 case FFECOM_rttypeCHARACTER_:
7091 ttype = void_type_node;
7096 assert ("bad rttype" == NULL);
7100 ttype = build_function_type (ttype, NULL_TREE);
7101 t = build_decl (FUNCTION_DECL,
7102 get_identifier (ffecom_gfrt_name_[ix]),
7104 DECL_EXTERNAL (t) = 1;
7105 TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
7106 TREE_PUBLIC (t) = 1;
7107 TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
7109 /* Sanity check: A function that's const cannot be volatile. */
7111 assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
7113 /* Sanity check: A function that's const cannot return complex. */
7115 assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
7117 t = start_decl (t, TRUE);
7119 finish_decl (t, NULL_TREE, TRUE);
7121 ffecom_gfrt_[ix] = t;
7125 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
7127 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7129 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
7131 ffesymbol s = ffestorag_symbol (st);
7133 if (ffesymbol_namelisted (s))
7134 ffecom_member_namelisted_ = TRUE;
7138 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
7139 the member so debugger will see it. Otherwise nobody should be
7140 referencing the member. */
7142 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7144 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7152 || ((mt = ffestorag_hook (mst)) == NULL)
7153 || (mt == error_mark_node))
7157 || ((s = ffestorag_symbol (st)) == NULL))
7160 type = ffecom_type_localvar_ (s,
7161 ffesymbol_basictype (s),
7162 ffesymbol_kindtype (s));
7163 if (type == error_mark_node)
7166 t = build_decl (VAR_DECL,
7167 ffecom_get_identifier_ (ffesymbol_text (s)),
7170 TREE_STATIC (t) = TREE_STATIC (mt);
7171 DECL_INITIAL (t) = NULL_TREE;
7172 TREE_ASM_WRITTEN (t) = 1;
7175 = gen_rtx (MEM, TYPE_MODE (type),
7176 plus_constant (XEXP (DECL_RTL (mt), 0),
7177 ffestorag_modulo (mst)
7178 + ffestorag_offset (st)
7179 - ffestorag_offset (mst)));
7181 t = start_decl (t, FALSE);
7183 finish_decl (t, NULL_TREE, FALSE);
7187 /* Prepare source expression for assignment into a destination perhaps known
7188 to be of a specific size. */
7191 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7193 ffecomConcatList_ catlist;
7198 tree tempvar = NULL_TREE;
7200 while (ffebld_op (source) == FFEBLD_opCONVERT)
7201 source = ffebld_left (source);
7203 catlist = ffecom_concat_list_new_ (source, dest_size);
7204 count = ffecom_concat_list_count_ (catlist);
7209 = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7210 FFETARGET_charactersizeNONE, count);
7212 = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7213 FFETARGET_charactersizeNONE, count);
7215 tempvar = make_tree_vec (2);
7216 TREE_VEC_ELT (tempvar, 0) = ltmp;
7217 TREE_VEC_ELT (tempvar, 1) = itmp;
7220 for (i = 0; i < count; ++i)
7221 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7223 ffecom_concat_list_kill_ (catlist);
7227 ffebld_nonter_set_hook (source, tempvar);
7228 current_binding_level->prep_state = 1;
7232 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7234 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7235 (which generates their trees) and then their trees get push_parm_decl'd.
7237 The second arg is TRUE if the dummies are for a statement function, in
7238 which case lengths are not pushed for character arguments (since they are
7239 always known by both the caller and the callee, though the code allows
7240 for someday permitting CHAR*(*) stmtfunc dummies). */
7242 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7244 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7251 ffecom_transform_only_dummies_ = TRUE;
7253 /* First push the parms corresponding to actual dummy "contents". */
7255 for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7257 dummy = ffebld_head (dumlist);
7258 switch (ffebld_op (dummy))
7262 continue; /* Forget alternate returns. */
7267 assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7268 s = ffebld_symter (dummy);
7269 parm = ffesymbol_hook (s).decl_tree;
7270 if (parm == NULL_TREE)
7272 s = ffecom_sym_transform_ (s);
7273 parm = ffesymbol_hook (s).decl_tree;
7274 assert (parm != NULL_TREE);
7276 if (parm != error_mark_node)
7277 push_parm_decl (parm);
7280 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7282 for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7284 dummy = ffebld_head (dumlist);
7285 switch (ffebld_op (dummy))
7289 continue; /* Forget alternate returns, they mean
7295 s = ffebld_symter (dummy);
7296 if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7297 continue; /* Only looking for CHARACTER arguments. */
7298 if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7299 continue; /* Stmtfunc arg with known size needs no
7301 if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7302 continue; /* Only looking for variables and arrays. */
7303 parm = ffesymbol_hook (s).length_tree;
7304 assert (parm != NULL_TREE);
7305 if (parm != error_mark_node)
7306 push_parm_decl (parm);
7309 ffecom_transform_only_dummies_ = FALSE;
7313 /* ffecom_start_progunit_ -- Beginning of program unit
7315 Does GNU back end stuff necessary to teach it about the start of its
7316 equivalent of a Fortran program unit. */
7318 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7320 ffecom_start_progunit_ ()
7322 ffesymbol fn = ffecom_primary_entry_;
7324 tree id; /* Identifier (name) of function. */
7325 tree type; /* Type of function. */
7326 tree result; /* Result of function. */
7327 ffeinfoBasictype bt;
7331 ffeglobalType egt = FFEGLOBAL_type;
7334 bool altentries = (ffecom_num_entrypoints_ != 0);
7337 && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7338 && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7339 bool main_program = FALSE;
7340 int old_lineno = lineno;
7341 const char *old_input_filename = input_filename;
7344 assert (fn != NULL);
7345 assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7347 input_filename = ffesymbol_where_filename (fn);
7348 lineno = ffesymbol_where_filelinenum (fn);
7350 /* c-parse.y indeed does call suspend_momentary and not only ignores the
7351 return value, but also never calls resume_momentary, when starting an
7352 outer function (see "fndef:", "setspecs:", and so on). So g77 does the
7353 same thing. It shouldn't be a problem since start_function calls
7354 temporary_allocation, but it might be necessary. If it causes a problem
7355 here, then maybe there's a bug lurking in gcc. NOTE: This identical
7356 comment appears twice in thist file. */
7358 suspend_momentary ();
7360 switch (ffecom_primary_entry_kind_)
7362 case FFEINFO_kindPROGRAM:
7363 main_program = TRUE;
7364 gt = FFEGLOBAL_typeMAIN;
7365 bt = FFEINFO_basictypeNONE;
7366 kt = FFEINFO_kindtypeNONE;
7367 type = ffecom_tree_fun_type_void;
7372 case FFEINFO_kindBLOCKDATA:
7373 gt = FFEGLOBAL_typeBDATA;
7374 bt = FFEINFO_basictypeNONE;
7375 kt = FFEINFO_kindtypeNONE;
7376 type = ffecom_tree_fun_type_void;
7381 case FFEINFO_kindFUNCTION:
7382 gt = FFEGLOBAL_typeFUNC;
7383 egt = FFEGLOBAL_typeEXT;
7384 bt = ffesymbol_basictype (fn);
7385 kt = ffesymbol_kindtype (fn);
7386 if (bt == FFEINFO_basictypeNONE)
7388 ffeimplic_establish_symbol (fn);
7389 if (ffesymbol_funcresult (fn) != NULL)
7390 ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7391 bt = ffesymbol_basictype (fn);
7392 kt = ffesymbol_kindtype (fn);
7396 charfunc = cmplxfunc = FALSE;
7397 else if (bt == FFEINFO_basictypeCHARACTER)
7398 charfunc = TRUE, cmplxfunc = FALSE;
7399 else if ((bt == FFEINFO_basictypeCOMPLEX)
7400 && ffesymbol_is_f2c (fn)
7402 charfunc = FALSE, cmplxfunc = TRUE;
7404 charfunc = cmplxfunc = FALSE;
7406 if (multi || charfunc)
7407 type = ffecom_tree_fun_type_void;
7408 else if (ffesymbol_is_f2c (fn) && !altentries)
7409 type = ffecom_tree_fun_type[bt][kt];
7411 type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7413 if ((type == NULL_TREE)
7414 || (TREE_TYPE (type) == NULL_TREE))
7415 type = ffecom_tree_fun_type_void; /* _sym_exec_transition. */
7418 case FFEINFO_kindSUBROUTINE:
7419 gt = FFEGLOBAL_typeSUBR;
7420 egt = FFEGLOBAL_typeEXT;
7421 bt = FFEINFO_basictypeNONE;
7422 kt = FFEINFO_kindtypeNONE;
7423 if (ffecom_is_altreturning_)
7424 type = ffecom_tree_subr_type;
7426 type = ffecom_tree_fun_type_void;
7432 assert ("say what??" == NULL);
7434 case FFEINFO_kindANY:
7435 gt = FFEGLOBAL_typeANY;
7436 bt = FFEINFO_basictypeNONE;
7437 kt = FFEINFO_kindtypeNONE;
7438 type = error_mark_node;
7446 id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7447 ffesymbol_text (fn));
7449 #if FFETARGET_isENFORCED_MAIN
7450 else if (main_program)
7451 id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7454 id = ffecom_get_external_identifier_ (fn);
7458 0, /* nested/inline */
7459 !altentries); /* TREE_PUBLIC */
7461 TREE_USED (current_function_decl) = 1; /* Avoid spurious warning if altentries. */
7464 && ((g = ffesymbol_global (fn)) != NULL)
7465 && ((ffeglobal_type (g) == gt)
7466 || (ffeglobal_type (g) == egt)))
7468 ffeglobal_set_hook (g, current_function_decl);
7471 yes = suspend_momentary ();
7473 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7474 exec-transitioning needs current_function_decl to be filled in. So we
7475 do these things in two phases. */
7478 { /* 1st arg identifies which entrypoint. */
7479 ffecom_which_entrypoint_decl_
7480 = build_decl (PARM_DECL,
7481 ffecom_get_invented_identifier ("__g77_%s",
7482 "which_entrypoint"),
7484 push_parm_decl (ffecom_which_entrypoint_decl_);
7490 { /* Arg for result (return value). */
7495 type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7497 type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7499 type = ffecom_multi_type_node_;
7501 result = ffecom_get_invented_identifier ("__g77_%s", "result");
7503 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7506 length = ffecom_char_enhance_arg_ (&type, fn);
7508 length = NULL_TREE; /* Not ref'd if !charfunc. */
7510 type = build_pointer_type (type);
7511 result = build_decl (PARM_DECL, result, type);
7513 push_parm_decl (result);
7515 ffecom_multi_retval_ = result;
7517 ffecom_func_result_ = result;
7521 push_parm_decl (length);
7522 ffecom_func_length_ = length;
7526 if (ffecom_primary_entry_is_proc_)
7529 arglist = ffecom_master_arglist_;
7531 arglist = ffesymbol_dummyargs (fn);
7532 ffecom_push_dummy_decls_ (arglist, FALSE);
7535 resume_momentary (yes);
7537 if (TREE_CODE (current_function_decl) != ERROR_MARK)
7538 store_parm_decls (main_program ? 1 : 0);
7540 ffecom_start_compstmt ();
7541 /* Disallow temp vars at this level. */
7542 current_binding_level->prep_state = 2;
7544 lineno = old_lineno;
7545 input_filename = old_input_filename;
7547 /* This handles any symbols still untransformed, in case -g specified.
7548 This used to be done in ffecom_finish_progunit, but it turns out to
7549 be necessary to do it here so that statement functions are
7550 expanded before code. But don't bother for BLOCK DATA. */
7552 if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7553 ffesymbol_drive (ffecom_finish_symbol_transform_);
7557 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7560 ffecom_sym_transform_(s);
7562 The ffesymbol_hook info for s is updated with appropriate backend info
7565 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7567 ffecom_sym_transform_ (ffesymbol s)
7569 tree t; /* Transformed thingy. */
7570 tree tlen; /* Length if CHAR*(*). */
7571 bool addr; /* Is t the address of the thingy? */
7572 ffeinfoBasictype bt;
7576 int old_lineno = lineno;
7577 const char *old_input_filename = input_filename;
7579 /* Must ensure special ASSIGN variables are declared at top of outermost
7580 block, else they'll end up in the innermost block when their first
7581 ASSIGN is seen, which leaves them out of scope when they're the
7582 subject of a GOTO or I/O statement.
7584 We make this variable even if -fugly-assign. Just let it go unused,
7585 in case it turns out there are cases where we really want to use this
7586 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7588 if (! ffecom_transform_only_dummies_
7589 && ffesymbol_assigned (s)
7590 && ! ffesymbol_hook (s).assign_tree)
7591 s = ffecom_sym_transform_assign_ (s);
7593 if (ffesymbol_sfdummyparent (s) == NULL)
7595 input_filename = ffesymbol_where_filename (s);
7596 lineno = ffesymbol_where_filelinenum (s);
7600 ffesymbol sf = ffesymbol_sfdummyparent (s);
7602 input_filename = ffesymbol_where_filename (sf);
7603 lineno = ffesymbol_where_filelinenum (sf);
7606 bt = ffeinfo_basictype (ffebld_info (s));
7607 kt = ffeinfo_kindtype (ffebld_info (s));
7613 switch (ffesymbol_kind (s))
7615 case FFEINFO_kindNONE:
7616 switch (ffesymbol_where (s))
7618 case FFEINFO_whereDUMMY: /* Subroutine or function. */
7619 assert (ffecom_transform_only_dummies_);
7621 /* Before 0.4, this could be ENTITY/DUMMY, but see
7622 ffestu_sym_end_transition -- no longer true (in particular, if
7623 it could be an ENTITY, it _will_ be made one, so that
7624 possibility won't come through here). So we never make length
7625 arg for CHARACTER type. */
7627 t = build_decl (PARM_DECL,
7628 ffecom_get_identifier_ (ffesymbol_text (s)),
7629 ffecom_tree_ptr_to_subr_type);
7631 DECL_ARTIFICIAL (t) = 1;
7636 case FFEINFO_whereGLOBAL: /* Subroutine or function. */
7637 assert (!ffecom_transform_only_dummies_);
7639 if (((g = ffesymbol_global (s)) != NULL)
7640 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7641 || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7642 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7643 && (ffeglobal_hook (g) != NULL_TREE)
7644 && ffe_is_globals ())
7646 t = ffeglobal_hook (g);
7650 t = build_decl (FUNCTION_DECL,
7651 ffecom_get_external_identifier_ (s),
7652 ffecom_tree_subr_type); /* Assume subr. */
7653 DECL_EXTERNAL (t) = 1;
7654 TREE_PUBLIC (t) = 1;
7656 t = start_decl (t, FALSE);
7657 finish_decl (t, NULL_TREE, FALSE);
7660 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7661 || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7662 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7663 ffeglobal_set_hook (g, t);
7665 ffecom_save_tree_forever (t);
7670 assert ("NONE where unexpected" == NULL);
7672 case FFEINFO_whereANY:
7677 case FFEINFO_kindENTITY:
7678 switch (ffeinfo_where (ffesymbol_info (s)))
7681 case FFEINFO_whereCONSTANT:
7682 /* ~~Debugging info needed? */
7683 assert (!ffecom_transform_only_dummies_);
7684 t = error_mark_node; /* Shouldn't ever see this in expr. */
7687 case FFEINFO_whereLOCAL:
7688 assert (!ffecom_transform_only_dummies_);
7691 ffestorag st = ffesymbol_storage (s);
7695 && (ffestorag_size (st) == 0))
7697 t = error_mark_node;
7701 yes = suspend_momentary ();
7702 type = ffecom_type_localvar_ (s, bt, kt);
7703 resume_momentary (yes);
7705 if (type == error_mark_node)
7707 t = error_mark_node;
7712 && (ffestorag_parent (st) != NULL))
7713 { /* Child of EQUIVALENCE parent. */
7717 ffetargetOffset offset;
7719 est = ffestorag_parent (st);
7720 ffecom_transform_equiv_ (est);
7722 et = ffestorag_hook (est);
7723 assert (et != NULL_TREE);
7725 if (! TREE_STATIC (et))
7726 put_var_into_stack (et);
7728 yes = suspend_momentary ();
7730 offset = ffestorag_modulo (est)
7731 + ffestorag_offset (ffesymbol_storage (s))
7732 - ffestorag_offset (est);
7734 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7736 /* (t_type *) (((char *) &et) + offset) */
7738 t = convert (string_type_node, /* (char *) */
7739 ffecom_1 (ADDR_EXPR,
7740 build_pointer_type (TREE_TYPE (et)),
7742 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7744 build_int_2 (offset, 0));
7745 t = convert (build_pointer_type (type),
7747 TREE_CONSTANT (t) = staticp (et);
7751 resume_momentary (yes);
7756 bool init = ffesymbol_is_init (s);
7758 yes = suspend_momentary ();
7760 t = build_decl (VAR_DECL,
7761 ffecom_get_identifier_ (ffesymbol_text (s)),
7765 || ffesymbol_namelisted (s)
7766 #ifdef FFECOM_sizeMAXSTACKITEM
7768 && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7770 || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7771 && (ffecom_primary_entry_kind_
7772 != FFEINFO_kindBLOCKDATA)
7773 && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7774 TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7776 TREE_STATIC (t) = 0; /* No need to make static. */
7778 if (init || ffe_is_init_local_zero ())
7779 DECL_INITIAL (t) = error_mark_node;
7781 /* Keep -Wunused from complaining about var if it
7782 is used as sfunc arg or DATA implied-DO. */
7783 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7784 DECL_IN_SYSTEM_HEADER (t) = 1;
7786 t = start_decl (t, FALSE);
7790 if (ffesymbol_init (s) != NULL)
7791 initexpr = ffecom_expr (ffesymbol_init (s));
7793 initexpr = ffecom_init_zero_ (t);
7795 else if (ffe_is_init_local_zero ())
7796 initexpr = ffecom_init_zero_ (t);
7798 initexpr = NULL_TREE; /* Not ref'd if !init. */
7800 finish_decl (t, initexpr, FALSE);
7802 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7804 assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7805 assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7806 ffestorag_size (st)));
7809 resume_momentary (yes);
7814 case FFEINFO_whereRESULT:
7815 assert (!ffecom_transform_only_dummies_);
7817 if (bt == FFEINFO_basictypeCHARACTER)
7818 { /* Result is already in list of dummies, use
7820 t = ffecom_func_result_;
7821 tlen = ffecom_func_length_;
7825 if ((ffecom_num_entrypoints_ == 0)
7826 && (bt == FFEINFO_basictypeCOMPLEX)
7827 && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7828 { /* Result is already in list of dummies, use
7830 t = ffecom_func_result_;
7834 if (ffecom_func_result_ != NULL_TREE)
7836 t = ffecom_func_result_;
7839 if ((ffecom_num_entrypoints_ != 0)
7840 && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7842 yes = suspend_momentary ();
7844 assert (ffecom_multi_retval_ != NULL_TREE);
7845 t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7846 ffecom_multi_retval_);
7847 t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7848 t, ffecom_multi_fields_[bt][kt]);
7850 resume_momentary (yes);
7854 yes = suspend_momentary ();
7856 t = build_decl (VAR_DECL,
7857 ffecom_get_identifier_ (ffesymbol_text (s)),
7858 ffecom_tree_type[bt][kt]);
7859 TREE_STATIC (t) = 0; /* Put result on stack. */
7860 t = start_decl (t, FALSE);
7861 finish_decl (t, NULL_TREE, FALSE);
7863 ffecom_func_result_ = t;
7865 resume_momentary (yes);
7868 case FFEINFO_whereDUMMY:
7876 bool adjustable = FALSE; /* Conditionally adjustable? */
7878 type = ffecom_tree_type[bt][kt];
7879 if (ffesymbol_sfdummyparent (s) != NULL)
7881 if (current_function_decl == ffecom_outer_function_decl_)
7882 { /* Exec transition before sfunc
7883 context; get it later. */
7886 t = ffecom_get_identifier_ (ffesymbol_text
7887 (ffesymbol_sfdummyparent (s)));
7890 t = ffecom_get_identifier_ (ffesymbol_text (s));
7892 assert (ffecom_transform_only_dummies_);
7894 old_sizes = get_pending_sizes ();
7895 put_pending_sizes (old_sizes);
7897 if (bt == FFEINFO_basictypeCHARACTER)
7898 tlen = ffecom_char_enhance_arg_ (&type, s);
7899 type = ffecom_check_size_overflow_ (s, type, TRUE);
7901 for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7903 if (type == error_mark_node)
7906 dim = ffebld_head (dl);
7907 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7908 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7909 low = ffecom_integer_one_node;
7911 low = ffecom_expr (ffebld_left (dim));
7912 assert (ffebld_right (dim) != NULL);
7913 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7914 || ffecom_doing_entry_)
7916 /* Used to just do high=low. But for ffecom_tree_
7917 canonize_ref_, it probably is important to correctly
7918 assess the size. E.g. given COMPLEX C(*),CFUNC and
7919 C(2)=CFUNC(C), overlap can happen, while it can't
7920 for, say, C(1)=CFUNC(C(2)). */
7921 /* Even more recently used to set to INT_MAX, but that
7922 broke when some overflow checking went into the back
7923 end. Now we just leave the upper bound unspecified. */
7927 high = ffecom_expr (ffebld_right (dim));
7929 /* Determine whether array is conditionally adjustable,
7930 to decide whether back-end magic is needed.
7932 Normally the front end uses the back-end function
7933 variable_size to wrap SAVE_EXPR's around expressions
7934 affecting the size/shape of an array so that the
7935 size/shape info doesn't change during execution
7936 of the compiled code even though variables and
7937 functions referenced in those expressions might.
7939 variable_size also makes sure those saved expressions
7940 get evaluated immediately upon entry to the
7941 compiled procedure -- the front end normally doesn't
7942 have to worry about that.
7944 However, there is a problem with this that affects
7945 g77's implementation of entry points, and that is
7946 that it is _not_ true that each invocation of the
7947 compiled procedure is permitted to evaluate
7948 array size/shape info -- because it is possible
7949 that, for some invocations, that info is invalid (in
7950 which case it is "promised" -- i.e. a violation of
7951 the Fortran standard -- that the compiled code
7952 won't reference the array or its size/shape
7953 during that particular invocation).
7955 To phrase this in C terms, consider this gcc function:
7957 void foo (int *n, float (*a)[*n])
7959 // a is "pointer to array ...", fyi.
7962 Suppose that, for some invocations, it is permitted
7963 for a caller of foo to do this:
7967 Now the _written_ code for foo can take such a call
7968 into account by either testing explicitly for whether
7969 (a == NULL) || (n == NULL) -- presumably it is
7970 not permitted to reference *a in various fashions
7971 if (n == NULL) I suppose -- or it can avoid it by
7972 looking at other info (other arguments, static/global
7975 However, this won't work in gcc 2.5.8 because it'll
7976 automatically emit the code to save the "*n"
7977 expression, which'll yield a NULL dereference for
7978 the "foo (NULL, NULL)" call, something the code
7979 for foo cannot prevent.
7981 g77 definitely needs to avoid executing such
7982 code anytime the pointer to the adjustable array
7983 is NULL, because even if its bounds expressions
7984 don't have any references to possible "absent"
7985 variables like "*n" -- say all variable references
7986 are to COMMON variables, i.e. global (though in C,
7987 local static could actually make sense) -- the
7988 expressions could yield other run-time problems
7989 for allowably "dead" values in those variables.
7991 For example, let's consider a more complicated
7997 void foo (float (*a)[i/j])
8002 The above is (essentially) quite valid for Fortran
8003 but, again, for a call like "foo (NULL);", it is
8004 permitted for i and j to be undefined when the
8005 call is made. If j happened to be zero, for
8006 example, emitting the code to evaluate "i/j"
8007 could result in a run-time error.
8009 Offhand, though I don't have my F77 or F90
8010 standards handy, it might even be valid for a
8011 bounds expression to contain a function reference,
8012 in which case I doubt it is permitted for an
8013 implementation to invoke that function in the
8014 Fortran case involved here (invocation of an
8015 alternate ENTRY point that doesn't have the adjustable
8016 array as one of its arguments).
8018 So, the code that the compiler would normally emit
8019 to preevaluate the size/shape info for an
8020 adjustable array _must not_ be executed at run time
8021 in certain cases. Specifically, for Fortran,
8022 the case is when the pointer to the adjustable
8023 array == NULL. (For gnu-ish C, it might be nice
8024 for the source code itself to specify an expression
8025 that, if TRUE, inhibits execution of the code. Or
8026 reverse the sense for elegance.)
8028 (Note that g77 could use a different test than NULL,
8029 actually, since it happens to always pass an
8030 integer to the called function that specifies which
8031 entry point is being invoked. Hmm, this might
8032 solve the next problem.)
8034 One way a user could, I suppose, write "foo" so
8035 it works is to insert COND_EXPR's for the
8036 size/shape info so the dangerous stuff isn't
8037 actually done, as in:
8039 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
8044 The next problem is that the front end needs to
8045 be able to tell the back end about the array's
8046 decl _before_ it tells it about the conditional
8047 expression to inhibit evaluation of size/shape info,
8050 To solve this, the front end needs to be able
8051 to give the back end the expression to inhibit
8052 generation of the preevaluation code _after_
8053 it makes the decl for the adjustable array.
8055 Until then, the above example using the COND_EXPR
8056 doesn't pass muster with gcc because the "(a == NULL)"
8057 part has a reference to "a", which is still
8058 undefined at that point.
8060 g77 will therefore use a different mechanism in the
8064 && ((TREE_CODE (low) != INTEGER_CST)
8065 || (high && TREE_CODE (high) != INTEGER_CST)))
8068 #if 0 /* Old approach -- see below. */
8069 if (TREE_CODE (low) != INTEGER_CST)
8070 low = ffecom_3 (COND_EXPR, integer_type_node,
8071 ffecom_adjarray_passed_ (s),
8073 ffecom_integer_zero_node);
8075 if (high && TREE_CODE (high) != INTEGER_CST)
8076 high = ffecom_3 (COND_EXPR, integer_type_node,
8077 ffecom_adjarray_passed_ (s),
8079 ffecom_integer_zero_node);
8082 /* ~~~gcc/stor-layout.c (layout_type) should do this,
8083 probably. Fixes 950302-1.f. */
8085 if (TREE_CODE (low) != INTEGER_CST)
8086 low = variable_size (low);
8088 /* ~~~Similarly, this fixes dumb0.f. The C front end
8089 does this, which is why dumb0.c would work. */
8091 if (high && TREE_CODE (high) != INTEGER_CST)
8092 high = variable_size (high);
8097 build_range_type (ffecom_integer_type_node,
8099 type = ffecom_check_size_overflow_ (s, type, TRUE);
8102 if (type == error_mark_node)
8104 t = error_mark_node;
8108 if ((ffesymbol_sfdummyparent (s) == NULL)
8109 || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
8111 type = build_pointer_type (type);
8115 t = build_decl (PARM_DECL, t, type);
8117 DECL_ARTIFICIAL (t) = 1;
8120 /* If this arg is present in every entry point's list of
8121 dummy args, then we're done. */
8123 if (ffesymbol_numentries (s)
8124 == (ffecom_num_entrypoints_ + 1))
8129 /* If variable_size in stor-layout has been called during
8130 the above, then get_pending_sizes should have the
8131 yet-to-be-evaluated saved expressions pending.
8132 Make the whole lot of them get emitted, conditionally
8133 on whether the array decl ("t" above) is not NULL. */
8136 tree sizes = get_pending_sizes ();
8141 tem = TREE_CHAIN (tem))
8143 tree temv = TREE_VALUE (tem);
8149 = ffecom_2 (COMPOUND_EXPR,
8158 = ffecom_3 (COND_EXPR,
8165 convert (TREE_TYPE (sizes),
8166 integer_zero_node));
8167 sizes = ffecom_save_tree (sizes);
8170 = tree_cons (NULL_TREE, sizes, tem);
8174 put_pending_sizes (sizes);
8180 && (ffesymbol_numentries (s)
8181 != ffecom_num_entrypoints_ + 1))
8183 = ffecom_2 (NE_EXPR, integer_type_node,
8189 && (ffesymbol_numentries (s)
8190 != ffecom_num_entrypoints_ + 1))
8192 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8193 ffebad_here (0, ffesymbol_where_line (s),
8194 ffesymbol_where_column (s));
8195 ffebad_string (ffesymbol_text (s));
8204 case FFEINFO_whereCOMMON:
8209 ffestorag st = ffesymbol_storage (s);
8213 cs = ffesymbol_common (s); /* The COMMON area itself. */
8214 if (st != NULL) /* Else not laid out. */
8216 ffecom_transform_common_ (cs);
8217 st = ffesymbol_storage (s);
8220 yes = suspend_momentary ();
8222 type = ffecom_type_localvar_ (s, bt, kt);
8224 cg = ffesymbol_global (cs); /* The global COMMON info. */
8226 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8229 ct = ffeglobal_hook (cg); /* The common area's tree. */
8231 if ((ct == NULL_TREE)
8233 || (type == error_mark_node))
8234 t = error_mark_node;
8237 ffetargetOffset offset;
8240 cst = ffestorag_parent (st);
8241 assert (cst == ffesymbol_storage (cs));
8243 offset = ffestorag_modulo (cst)
8244 + ffestorag_offset (st)
8245 - ffestorag_offset (cst);
8247 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8249 /* (t_type *) (((char *) &ct) + offset) */
8251 t = convert (string_type_node, /* (char *) */
8252 ffecom_1 (ADDR_EXPR,
8253 build_pointer_type (TREE_TYPE (ct)),
8255 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8257 build_int_2 (offset, 0));
8258 t = convert (build_pointer_type (type),
8260 TREE_CONSTANT (t) = 1;
8265 resume_momentary (yes);
8269 case FFEINFO_whereIMMEDIATE:
8270 case FFEINFO_whereGLOBAL:
8271 case FFEINFO_whereFLEETING:
8272 case FFEINFO_whereFLEETING_CADDR:
8273 case FFEINFO_whereFLEETING_IADDR:
8274 case FFEINFO_whereINTRINSIC:
8275 case FFEINFO_whereCONSTANT_SUBOBJECT:
8277 assert ("ENTITY where unheard of" == NULL);
8279 case FFEINFO_whereANY:
8280 t = error_mark_node;
8285 case FFEINFO_kindFUNCTION:
8286 switch (ffeinfo_where (ffesymbol_info (s)))
8288 case FFEINFO_whereLOCAL: /* Me. */
8289 assert (!ffecom_transform_only_dummies_);
8290 t = current_function_decl;
8293 case FFEINFO_whereGLOBAL:
8294 assert (!ffecom_transform_only_dummies_);
8296 if (((g = ffesymbol_global (s)) != NULL)
8297 && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8298 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8299 && (ffeglobal_hook (g) != NULL_TREE)
8300 && ffe_is_globals ())
8302 t = ffeglobal_hook (g);
8306 if (ffesymbol_is_f2c (s)
8307 && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8308 t = ffecom_tree_fun_type[bt][kt];
8310 t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8312 t = build_decl (FUNCTION_DECL,
8313 ffecom_get_external_identifier_ (s),
8315 DECL_EXTERNAL (t) = 1;
8316 TREE_PUBLIC (t) = 1;
8318 t = start_decl (t, FALSE);
8319 finish_decl (t, NULL_TREE, FALSE);
8322 && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8323 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8324 ffeglobal_set_hook (g, t);
8326 ffecom_save_tree_forever (t);
8330 case FFEINFO_whereDUMMY:
8331 assert (ffecom_transform_only_dummies_);
8333 if (ffesymbol_is_f2c (s)
8334 && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8335 t = ffecom_tree_ptr_to_fun_type[bt][kt];
8337 t = build_pointer_type
8338 (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8340 t = build_decl (PARM_DECL,
8341 ffecom_get_identifier_ (ffesymbol_text (s)),
8344 DECL_ARTIFICIAL (t) = 1;
8349 case FFEINFO_whereCONSTANT: /* Statement function. */
8350 assert (!ffecom_transform_only_dummies_);
8351 t = ffecom_gen_sfuncdef_ (s, bt, kt);
8354 case FFEINFO_whereINTRINSIC:
8355 assert (!ffecom_transform_only_dummies_);
8356 break; /* Let actual references generate their
8360 assert ("FUNCTION where unheard of" == NULL);
8362 case FFEINFO_whereANY:
8363 t = error_mark_node;
8368 case FFEINFO_kindSUBROUTINE:
8369 switch (ffeinfo_where (ffesymbol_info (s)))
8371 case FFEINFO_whereLOCAL: /* Me. */
8372 assert (!ffecom_transform_only_dummies_);
8373 t = current_function_decl;
8376 case FFEINFO_whereGLOBAL:
8377 assert (!ffecom_transform_only_dummies_);
8379 if (((g = ffesymbol_global (s)) != NULL)
8380 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8381 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8382 && (ffeglobal_hook (g) != NULL_TREE)
8383 && ffe_is_globals ())
8385 t = ffeglobal_hook (g);
8389 t = build_decl (FUNCTION_DECL,
8390 ffecom_get_external_identifier_ (s),
8391 ffecom_tree_subr_type);
8392 DECL_EXTERNAL (t) = 1;
8393 TREE_PUBLIC (t) = 1;
8395 t = start_decl (t, FALSE);
8396 finish_decl (t, NULL_TREE, FALSE);
8399 && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8400 || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8401 ffeglobal_set_hook (g, t);
8403 ffecom_save_tree_forever (t);
8407 case FFEINFO_whereDUMMY:
8408 assert (ffecom_transform_only_dummies_);
8410 t = build_decl (PARM_DECL,
8411 ffecom_get_identifier_ (ffesymbol_text (s)),
8412 ffecom_tree_ptr_to_subr_type);
8414 DECL_ARTIFICIAL (t) = 1;
8419 case FFEINFO_whereINTRINSIC:
8420 assert (!ffecom_transform_only_dummies_);
8421 break; /* Let actual references generate their
8425 assert ("SUBROUTINE where unheard of" == NULL);
8427 case FFEINFO_whereANY:
8428 t = error_mark_node;
8433 case FFEINFO_kindPROGRAM:
8434 switch (ffeinfo_where (ffesymbol_info (s)))
8436 case FFEINFO_whereLOCAL: /* Me. */
8437 assert (!ffecom_transform_only_dummies_);
8438 t = current_function_decl;
8441 case FFEINFO_whereCOMMON:
8442 case FFEINFO_whereDUMMY:
8443 case FFEINFO_whereGLOBAL:
8444 case FFEINFO_whereRESULT:
8445 case FFEINFO_whereFLEETING:
8446 case FFEINFO_whereFLEETING_CADDR:
8447 case FFEINFO_whereFLEETING_IADDR:
8448 case FFEINFO_whereIMMEDIATE:
8449 case FFEINFO_whereINTRINSIC:
8450 case FFEINFO_whereCONSTANT:
8451 case FFEINFO_whereCONSTANT_SUBOBJECT:
8453 assert ("PROGRAM where unheard of" == NULL);
8455 case FFEINFO_whereANY:
8456 t = error_mark_node;
8461 case FFEINFO_kindBLOCKDATA:
8462 switch (ffeinfo_where (ffesymbol_info (s)))
8464 case FFEINFO_whereLOCAL: /* Me. */
8465 assert (!ffecom_transform_only_dummies_);
8466 t = current_function_decl;
8469 case FFEINFO_whereGLOBAL:
8470 assert (!ffecom_transform_only_dummies_);
8472 t = build_decl (FUNCTION_DECL,
8473 ffecom_get_external_identifier_ (s),
8474 ffecom_tree_blockdata_type);
8475 DECL_EXTERNAL (t) = 1;
8476 TREE_PUBLIC (t) = 1;
8478 t = start_decl (t, FALSE);
8479 finish_decl (t, NULL_TREE, FALSE);
8481 ffecom_save_tree_forever (t);
8485 case FFEINFO_whereCOMMON:
8486 case FFEINFO_whereDUMMY:
8487 case FFEINFO_whereRESULT:
8488 case FFEINFO_whereFLEETING:
8489 case FFEINFO_whereFLEETING_CADDR:
8490 case FFEINFO_whereFLEETING_IADDR:
8491 case FFEINFO_whereIMMEDIATE:
8492 case FFEINFO_whereINTRINSIC:
8493 case FFEINFO_whereCONSTANT:
8494 case FFEINFO_whereCONSTANT_SUBOBJECT:
8496 assert ("BLOCKDATA where unheard of" == NULL);
8498 case FFEINFO_whereANY:
8499 t = error_mark_node;
8504 case FFEINFO_kindCOMMON:
8505 switch (ffeinfo_where (ffesymbol_info (s)))
8507 case FFEINFO_whereLOCAL:
8508 assert (!ffecom_transform_only_dummies_);
8509 ffecom_transform_common_ (s);
8512 case FFEINFO_whereNONE:
8513 case FFEINFO_whereCOMMON:
8514 case FFEINFO_whereDUMMY:
8515 case FFEINFO_whereGLOBAL:
8516 case FFEINFO_whereRESULT:
8517 case FFEINFO_whereFLEETING:
8518 case FFEINFO_whereFLEETING_CADDR:
8519 case FFEINFO_whereFLEETING_IADDR:
8520 case FFEINFO_whereIMMEDIATE:
8521 case FFEINFO_whereINTRINSIC:
8522 case FFEINFO_whereCONSTANT:
8523 case FFEINFO_whereCONSTANT_SUBOBJECT:
8525 assert ("COMMON where unheard of" == NULL);
8527 case FFEINFO_whereANY:
8528 t = error_mark_node;
8533 case FFEINFO_kindCONSTRUCT:
8534 switch (ffeinfo_where (ffesymbol_info (s)))
8536 case FFEINFO_whereLOCAL:
8537 assert (!ffecom_transform_only_dummies_);
8540 case FFEINFO_whereNONE:
8541 case FFEINFO_whereCOMMON:
8542 case FFEINFO_whereDUMMY:
8543 case FFEINFO_whereGLOBAL:
8544 case FFEINFO_whereRESULT:
8545 case FFEINFO_whereFLEETING:
8546 case FFEINFO_whereFLEETING_CADDR:
8547 case FFEINFO_whereFLEETING_IADDR:
8548 case FFEINFO_whereIMMEDIATE:
8549 case FFEINFO_whereINTRINSIC:
8550 case FFEINFO_whereCONSTANT:
8551 case FFEINFO_whereCONSTANT_SUBOBJECT:
8553 assert ("CONSTRUCT where unheard of" == NULL);
8555 case FFEINFO_whereANY:
8556 t = error_mark_node;
8561 case FFEINFO_kindNAMELIST:
8562 switch (ffeinfo_where (ffesymbol_info (s)))
8564 case FFEINFO_whereLOCAL:
8565 assert (!ffecom_transform_only_dummies_);
8566 t = ffecom_transform_namelist_ (s);
8569 case FFEINFO_whereNONE:
8570 case FFEINFO_whereCOMMON:
8571 case FFEINFO_whereDUMMY:
8572 case FFEINFO_whereGLOBAL:
8573 case FFEINFO_whereRESULT:
8574 case FFEINFO_whereFLEETING:
8575 case FFEINFO_whereFLEETING_CADDR:
8576 case FFEINFO_whereFLEETING_IADDR:
8577 case FFEINFO_whereIMMEDIATE:
8578 case FFEINFO_whereINTRINSIC:
8579 case FFEINFO_whereCONSTANT:
8580 case FFEINFO_whereCONSTANT_SUBOBJECT:
8582 assert ("NAMELIST where unheard of" == NULL);
8584 case FFEINFO_whereANY:
8585 t = error_mark_node;
8591 assert ("kind unheard of" == NULL);
8593 case FFEINFO_kindANY:
8594 t = error_mark_node;
8598 ffesymbol_hook (s).decl_tree = t;
8599 ffesymbol_hook (s).length_tree = tlen;
8600 ffesymbol_hook (s).addr = addr;
8602 lineno = old_lineno;
8603 input_filename = old_input_filename;
8609 /* Transform into ASSIGNable symbol.
8611 Symbol has already been transformed, but for whatever reason, the
8612 resulting decl_tree has been deemed not usable for an ASSIGN target.
8613 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8614 another local symbol of type void * and stuff that in the assign_tree
8615 argument. The F77/F90 standards allow this implementation. */
8617 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8619 ffecom_sym_transform_assign_ (ffesymbol s)
8621 tree t; /* Transformed thingy. */
8623 int old_lineno = lineno;
8624 const char *old_input_filename = input_filename;
8626 if (ffesymbol_sfdummyparent (s) == NULL)
8628 input_filename = ffesymbol_where_filename (s);
8629 lineno = ffesymbol_where_filelinenum (s);
8633 ffesymbol sf = ffesymbol_sfdummyparent (s);
8635 input_filename = ffesymbol_where_filename (sf);
8636 lineno = ffesymbol_where_filelinenum (sf);
8639 assert (!ffecom_transform_only_dummies_);
8641 yes = suspend_momentary ();
8643 t = build_decl (VAR_DECL,
8644 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8645 ffesymbol_text (s)),
8646 TREE_TYPE (null_pointer_node));
8648 switch (ffesymbol_where (s))
8650 case FFEINFO_whereLOCAL:
8651 /* Unlike for regular vars, SAVE status is easy to determine for
8652 ASSIGNed vars, since there's no initialization, there's no
8653 effective storage association (so "SAVE J" does not apply to
8654 K even given "EQUIVALENCE (J,K)"), there's no size issue
8655 to worry about, etc. */
8656 if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8657 && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8658 && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8659 TREE_STATIC (t) = 1; /* SAVEd in proc, make static. */
8661 TREE_STATIC (t) = 0; /* No need to make static. */
8664 case FFEINFO_whereCOMMON:
8665 TREE_STATIC (t) = 1; /* Assume COMMONs always SAVEd. */
8668 case FFEINFO_whereDUMMY:
8669 /* Note that twinning a DUMMY means the caller won't see
8670 the ASSIGNed value. But both F77 and F90 allow implementations
8671 to do this, i.e. disallow Fortran code that would try and
8672 take advantage of actually putting a label into a variable
8673 via a dummy argument (or any other storage association, for
8675 TREE_STATIC (t) = 0;
8679 TREE_STATIC (t) = 0;
8683 t = start_decl (t, FALSE);
8684 finish_decl (t, NULL_TREE, FALSE);
8686 resume_momentary (yes);
8688 ffesymbol_hook (s).assign_tree = t;
8690 lineno = old_lineno;
8691 input_filename = old_input_filename;
8697 /* Implement COMMON area in back end.
8699 Because COMMON-based variables can be referenced in the dimension
8700 expressions of dummy (adjustable) arrays, and because dummies
8701 (in the gcc back end) need to be put in the outer binding level
8702 of a function (which has two binding levels, the outer holding
8703 the dummies and the inner holding the other vars), special care
8704 must be taken to handle COMMON areas.
8706 The current strategy is basically to always tell the back end about
8707 the COMMON area as a top-level external reference to just a block
8708 of storage of the master type of that area (e.g. integer, real,
8709 character, whatever -- not a structure). As a distinct action,
8710 if initial values are provided, tell the back end about the area
8711 as a top-level non-external (initialized) area and remember not to
8712 allow further initialization or expansion of the area. Meanwhile,
8713 if no initialization happens at all, tell the back end about
8714 the largest size we've seen declared so the space does get reserved.
8715 (This function doesn't handle all that stuff, but it does some
8716 of the important things.)
8718 Meanwhile, for COMMON variables themselves, just keep creating
8719 references like *((float *) (&common_area + offset)) each time
8720 we reference the variable. In other words, don't make a VAR_DECL
8721 or any kind of component reference (like we used to do before 0.4),
8722 though we might do that as well just for debugging purposes (and
8723 stuff the rtl with the appropriate offset expression). */
8725 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8727 ffecom_transform_common_ (ffesymbol s)
8729 ffestorag st = ffesymbol_storage (s);
8730 ffeglobal g = ffesymbol_global (s);
8735 bool is_init = ffestorag_is_init (st);
8737 assert (st != NULL);
8740 || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8743 /* First update the size of the area in global terms. */
8745 ffeglobal_size_common (s, ffestorag_size (st));
8747 if (!ffeglobal_common_init (g))
8748 is_init = FALSE; /* No explicit init, don't let erroneous joins init. */
8750 cbt = ffeglobal_hook (g);
8752 /* If we already have declared this common block for a previous program
8753 unit, and either we already initialized it or we don't have new
8754 initialization for it, just return what we have without changing it. */
8756 if ((cbt != NULL_TREE)
8758 || !DECL_EXTERNAL (cbt)))
8760 if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8764 /* Process inits. */
8768 if (ffestorag_init (st) != NULL)
8772 /* Set the padding for the expression, so ffecom_expr
8773 knows to insert that many zeros. */
8774 switch (ffebld_op (sexp = ffestorag_init (st)))
8776 case FFEBLD_opCONTER:
8777 ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8780 case FFEBLD_opARRTER:
8781 ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8784 case FFEBLD_opACCTER:
8785 ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8789 assert ("bad op for cmn init (pad)" == NULL);
8793 init = ffecom_expr (sexp);
8794 if (init == error_mark_node)
8795 { /* Hopefully the back end complained! */
8797 if (cbt != NULL_TREE)
8802 init = error_mark_node;
8807 /* cbtype must be permanently allocated! */
8809 /* Allocate the MAX of the areas so far, seen filewide. */
8810 high = build_int_2 ((ffeglobal_common_size (g)
8811 + ffeglobal_common_pad (g)) - 1, 0);
8812 TREE_TYPE (high) = ffecom_integer_type_node;
8815 cbtype = build_array_type (char_type_node,
8816 build_range_type (integer_type_node,
8820 cbtype = build_array_type (char_type_node, NULL_TREE);
8822 if (cbt == NULL_TREE)
8825 = build_decl (VAR_DECL,
8826 ffecom_get_external_identifier_ (s),
8828 TREE_STATIC (cbt) = 1;
8829 TREE_PUBLIC (cbt) = 1;
8834 TREE_TYPE (cbt) = cbtype;
8836 DECL_EXTERNAL (cbt) = init ? 0 : 1;
8837 DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8839 cbt = start_decl (cbt, TRUE);
8840 if (ffeglobal_hook (g) != NULL)
8841 assert (cbt == ffeglobal_hook (g));
8843 assert (!init || !DECL_EXTERNAL (cbt));
8845 /* Make sure that any type can live in COMMON and be referenced
8846 without getting a bus error. We could pick the most restrictive
8847 alignment of all entities actually placed in the COMMON, but
8848 this seems easy enough. */
8850 DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8851 DECL_USER_ALIGN (cbt) = 0;
8853 if (is_init && (ffestorag_init (st) == NULL))
8854 init = ffecom_init_zero_ (cbt);
8856 finish_decl (cbt, init, TRUE);
8859 ffestorag_set_init (st, ffebld_new_any ());
8863 assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8864 assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8865 assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8866 (ffeglobal_common_size (g)
8867 + ffeglobal_common_pad (g))));
8870 ffeglobal_set_hook (g, cbt);
8872 ffestorag_set_hook (st, cbt);
8874 ffecom_save_tree_forever (cbt);
8878 /* Make master area for local EQUIVALENCE. */
8880 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8882 ffecom_transform_equiv_ (ffestorag eqst)
8888 bool is_init = ffestorag_is_init (eqst);
8891 assert (eqst != NULL);
8893 eqt = ffestorag_hook (eqst);
8895 if (eqt != NULL_TREE)
8898 /* Process inits. */
8902 if (ffestorag_init (eqst) != NULL)
8906 /* Set the padding for the expression, so ffecom_expr
8907 knows to insert that many zeros. */
8908 switch (ffebld_op (sexp = ffestorag_init (eqst)))
8910 case FFEBLD_opCONTER:
8911 ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8914 case FFEBLD_opARRTER:
8915 ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8918 case FFEBLD_opACCTER:
8919 ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8923 assert ("bad op for eqv init (pad)" == NULL);
8927 init = ffecom_expr (sexp);
8928 if (init == error_mark_node)
8929 init = NULL_TREE; /* Hopefully the back end complained! */
8932 init = error_mark_node;
8934 else if (ffe_is_init_local_zero ())
8935 init = error_mark_node;
8939 ffecom_member_namelisted_ = FALSE;
8940 ffestorag_drive (ffestorag_list_equivs (eqst),
8941 &ffecom_member_phase1_,
8944 yes = suspend_momentary ();
8946 high = build_int_2 ((ffestorag_size (eqst)
8947 + ffestorag_modulo (eqst)) - 1, 0);
8948 TREE_TYPE (high) = ffecom_integer_type_node;
8950 eqtype = build_array_type (char_type_node,
8951 build_range_type (ffecom_integer_type_node,
8952 ffecom_integer_zero_node,
8955 eqt = build_decl (VAR_DECL,
8956 ffecom_get_invented_identifier ("__g77_equiv_%s",
8958 (ffestorag_symbol (eqst))),
8960 DECL_EXTERNAL (eqt) = 0;
8962 || ffecom_member_namelisted_
8963 #ifdef FFECOM_sizeMAXSTACKITEM
8964 || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8966 || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8967 && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8968 && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8969 TREE_STATIC (eqt) = 1;
8971 TREE_STATIC (eqt) = 0;
8972 TREE_PUBLIC (eqt) = 0;
8973 TREE_ADDRESSABLE (eqt) = 1; /* Ensure non-register allocation */
8974 DECL_CONTEXT (eqt) = current_function_decl;
8976 DECL_INITIAL (eqt) = error_mark_node;
8978 DECL_INITIAL (eqt) = NULL_TREE;
8980 eqt = start_decl (eqt, FALSE);
8982 /* Make sure that any type can live in EQUIVALENCE and be referenced
8983 without getting a bus error. We could pick the most restrictive
8984 alignment of all entities actually placed in the EQUIVALENCE, but
8985 this seems easy enough. */
8987 DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8988 DECL_USER_ALIGN (eqt) = 0;
8990 if ((!is_init && ffe_is_init_local_zero ())
8991 || (is_init && (ffestorag_init (eqst) == NULL)))
8992 init = ffecom_init_zero_ (eqt);
8994 finish_decl (eqt, init, FALSE);
8997 ffestorag_set_init (eqst, ffebld_new_any ());
9000 assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
9001 assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
9002 (ffestorag_size (eqst)
9003 + ffestorag_modulo (eqst))));
9006 ffestorag_set_hook (eqst, eqt);
9008 ffestorag_drive (ffestorag_list_equivs (eqst),
9009 &ffecom_member_phase2_,
9012 resume_momentary (yes);
9016 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
9018 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9020 ffecom_transform_namelist_ (ffesymbol s)
9023 tree nmltype = ffecom_type_namelist_ ();
9032 static int mynumber = 0;
9034 yes = suspend_momentary ();
9036 nmlt = build_decl (VAR_DECL,
9037 ffecom_get_invented_identifier ("__g77_namelist_%d",
9040 TREE_STATIC (nmlt) = 1;
9041 DECL_INITIAL (nmlt) = error_mark_node;
9043 nmlt = start_decl (nmlt, FALSE);
9045 /* Process inits. */
9047 i = strlen (ffesymbol_text (s));
9049 high = build_int_2 (i, 0);
9050 TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
9052 nameinit = ffecom_build_f2c_string_ (i + 1,
9053 ffesymbol_text (s));
9054 TREE_TYPE (nameinit)
9055 = build_type_variant
9058 build_range_type (ffecom_f2c_ftnlen_type_node,
9059 ffecom_f2c_ftnlen_one_node,
9062 TREE_CONSTANT (nameinit) = 1;
9063 TREE_STATIC (nameinit) = 1;
9064 nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
9067 varsinit = ffecom_vardesc_array_ (s);
9068 varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
9070 TREE_CONSTANT (varsinit) = 1;
9071 TREE_STATIC (varsinit) = 1;
9076 for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
9079 nvarsinit = build_int_2 (i, 0);
9080 TREE_TYPE (nvarsinit) = integer_type_node;
9081 TREE_CONSTANT (nvarsinit) = 1;
9082 TREE_STATIC (nvarsinit) = 1;
9084 nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
9085 TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
9087 TREE_CHAIN (TREE_CHAIN (nmlinits))
9088 = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
9090 nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
9091 TREE_CONSTANT (nmlinits) = 1;
9092 TREE_STATIC (nmlinits) = 1;
9094 finish_decl (nmlt, nmlinits, FALSE);
9096 nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
9098 resume_momentary (yes);
9105 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
9106 analyzed on the assumption it is calculating a pointer to be
9107 indirected through. It must return the proper decl and offset,
9108 taking into account different units of measurements for offsets. */
9110 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9112 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
9115 switch (TREE_CODE (t))
9119 case NON_LVALUE_EXPR:
9120 ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9124 ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9125 if ((*decl == NULL_TREE)
9126 || (*decl == error_mark_node))
9129 if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
9131 /* An offset into COMMON. */
9132 *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
9133 *offset, TREE_OPERAND (t, 1)));
9134 /* Convert offset (presumably in bytes) into canonical units
9135 (presumably bits). */
9136 *offset = size_binop (MULT_EXPR,
9137 convert (bitsizetype, *offset),
9138 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
9141 /* Not a COMMON reference, so an unrecognized pattern. */
9142 *decl = error_mark_node;
9147 *offset = bitsize_zero_node;
9151 if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
9153 /* A reference to COMMON. */
9154 *decl = TREE_OPERAND (t, 0);
9155 *offset = bitsize_zero_node;
9160 /* Not a COMMON reference, so an unrecognized pattern. */
9161 *decl = error_mark_node;
9167 /* Given a tree that is possibly intended for use as an lvalue, return
9168 information representing a canonical view of that tree as a decl, an
9169 offset into that decl, and a size for the lvalue.
9171 If there's no applicable decl, NULL_TREE is returned for the decl,
9172 and the other fields are left undefined.
9174 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9175 is returned for the decl, and the other fields are left undefined.
9177 Otherwise, the decl returned currently is either a VAR_DECL or a
9180 The offset returned is always valid, but of course not necessarily
9181 a constant, and not necessarily converted into the appropriate
9182 type, leaving that up to the caller (so as to avoid that overhead
9183 if the decls being looked at are different anyway).
9185 If the size cannot be determined (e.g. an adjustable array),
9186 an ERROR_MARK node is returned for the size. Otherwise, the
9187 size returned is valid, not necessarily a constant, and not
9188 necessarily converted into the appropriate type as with the
9191 Note that the offset and size expressions are expressed in the
9192 base storage units (usually bits) rather than in the units of
9193 the type of the decl, because two decls with different types
9194 might overlap but with apparently non-overlapping array offsets,
9195 whereas converting the array offsets to consistant offsets will
9196 reveal the overlap. */
9198 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9200 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9203 /* The default path is to report a nonexistant decl. */
9209 switch (TREE_CODE (t))
9212 case IDENTIFIER_NODE:
9221 case TRUNC_DIV_EXPR:
9223 case FLOOR_DIV_EXPR:
9224 case ROUND_DIV_EXPR:
9225 case TRUNC_MOD_EXPR:
9227 case FLOOR_MOD_EXPR:
9228 case ROUND_MOD_EXPR:
9230 case EXACT_DIV_EXPR:
9231 case FIX_TRUNC_EXPR:
9233 case FIX_FLOOR_EXPR:
9234 case FIX_ROUND_EXPR:
9249 case BIT_ANDTC_EXPR:
9251 case TRUTH_ANDIF_EXPR:
9252 case TRUTH_ORIF_EXPR:
9253 case TRUTH_AND_EXPR:
9255 case TRUTH_XOR_EXPR:
9256 case TRUTH_NOT_EXPR:
9276 *offset = bitsize_zero_node;
9277 *size = TYPE_SIZE (TREE_TYPE (t));
9282 tree array = TREE_OPERAND (t, 0);
9283 tree element = TREE_OPERAND (t, 1);
9286 if ((array == NULL_TREE)
9287 || (element == NULL_TREE))
9289 *decl = error_mark_node;
9293 ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9295 if ((*decl == NULL_TREE)
9296 || (*decl == error_mark_node))
9299 /* Calculate ((element - base) * NBBY) + init_offset. */
9300 *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9302 TYPE_MIN_VALUE (TYPE_DOMAIN
9303 (TREE_TYPE (array)))));
9305 *offset = size_binop (MULT_EXPR,
9306 convert (bitsizetype, *offset),
9307 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9309 *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9311 *size = TYPE_SIZE (TREE_TYPE (t));
9317 /* Most of this code is to handle references to COMMON. And so
9318 far that is useful only for calling library functions, since
9319 external (user) functions might reference common areas. But
9320 even calling an external function, it's worthwhile to decode
9321 COMMON references because if not storing into COMMON, we don't
9322 want COMMON-based arguments to gratuitously force use of a
9325 *size = TYPE_SIZE (TREE_TYPE (t));
9327 ffecom_tree_canonize_ptr_ (decl, offset,
9328 TREE_OPERAND (t, 0));
9335 case NON_LVALUE_EXPR:
9338 case COND_EXPR: /* More cases than we can handle. */
9340 case REFERENCE_EXPR:
9341 case PREDECREMENT_EXPR:
9342 case PREINCREMENT_EXPR:
9343 case POSTDECREMENT_EXPR:
9344 case POSTINCREMENT_EXPR:
9347 *decl = error_mark_node;
9353 /* Do divide operation appropriate to type of operands. */
9355 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9357 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9358 tree dest_tree, ffebld dest, bool *dest_used,
9361 if ((left == error_mark_node)
9362 || (right == error_mark_node))
9363 return error_mark_node;
9365 switch (TREE_CODE (tree_type))
9368 return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9373 if (! optimize_size)
9374 return ffecom_2 (RDIV_EXPR, tree_type,
9380 if (TREE_TYPE (tree_type)
9381 == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9382 ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
9384 ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
9386 left = ffecom_1 (ADDR_EXPR,
9387 build_pointer_type (TREE_TYPE (left)),
9389 left = build_tree_list (NULL_TREE, left);
9390 right = ffecom_1 (ADDR_EXPR,
9391 build_pointer_type (TREE_TYPE (right)),
9393 right = build_tree_list (NULL_TREE, right);
9394 TREE_CHAIN (left) = right;
9396 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9397 ffecom_gfrt_kindtype (ix),
9398 ffe_is_f2c_library (),
9401 dest_tree, dest, dest_used,
9402 NULL_TREE, TRUE, hook);
9410 if (TREE_TYPE (TYPE_FIELDS (tree_type))
9411 == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9412 ix = FFECOM_gfrtDIV_CC; /* Overlapping result okay. */
9414 ix = FFECOM_gfrtDIV_ZZ; /* Overlapping result okay. */
9416 left = ffecom_1 (ADDR_EXPR,
9417 build_pointer_type (TREE_TYPE (left)),
9419 left = build_tree_list (NULL_TREE, left);
9420 right = ffecom_1 (ADDR_EXPR,
9421 build_pointer_type (TREE_TYPE (right)),
9423 right = build_tree_list (NULL_TREE, right);
9424 TREE_CHAIN (left) = right;
9426 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9427 ffecom_gfrt_kindtype (ix),
9428 ffe_is_f2c_library (),
9431 dest_tree, dest, dest_used,
9432 NULL_TREE, TRUE, hook);
9437 return ffecom_2 (RDIV_EXPR, tree_type,
9444 /* Build type info for non-dummy variable. */
9446 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9448 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9457 type = ffecom_tree_type[bt][kt];
9458 if (bt == FFEINFO_basictypeCHARACTER)
9460 hight = build_int_2 (ffesymbol_size (s), 0);
9461 TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9466 build_range_type (ffecom_f2c_ftnlen_type_node,
9467 ffecom_f2c_ftnlen_one_node,
9469 type = ffecom_check_size_overflow_ (s, type, FALSE);
9472 for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9474 if (type == error_mark_node)
9477 dim = ffebld_head (dl);
9478 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9480 if (ffebld_left (dim) == NULL)
9481 lowt = integer_one_node;
9483 lowt = ffecom_expr (ffebld_left (dim));
9485 if (TREE_CODE (lowt) != INTEGER_CST)
9486 lowt = variable_size (lowt);
9488 assert (ffebld_right (dim) != NULL);
9489 hight = ffecom_expr (ffebld_right (dim));
9491 if (TREE_CODE (hight) != INTEGER_CST)
9492 hight = variable_size (hight);
9494 type = build_array_type (type,
9495 build_range_type (ffecom_integer_type_node,
9497 type = ffecom_check_size_overflow_ (s, type, FALSE);
9504 /* Build Namelist type. */
9506 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9508 ffecom_type_namelist_ ()
9510 static tree type = NULL_TREE;
9512 if (type == NULL_TREE)
9514 static tree namefield, varsfield, nvarsfield;
9517 vardesctype = ffecom_type_vardesc_ ();
9519 type = make_node (RECORD_TYPE);
9521 vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9523 namefield = ffecom_decl_field (type, NULL_TREE, "name",
9525 varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9526 nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9529 TYPE_FIELDS (type) = namefield;
9532 ggc_add_tree_root (&type, 1);
9540 /* Build Vardesc type. */
9542 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9544 ffecom_type_vardesc_ ()
9546 static tree type = NULL_TREE;
9547 static tree namefield, addrfield, dimsfield, typefield;
9549 if (type == NULL_TREE)
9551 type = make_node (RECORD_TYPE);
9553 namefield = ffecom_decl_field (type, NULL_TREE, "name",
9555 addrfield = ffecom_decl_field (type, namefield, "addr",
9557 dimsfield = ffecom_decl_field (type, addrfield, "dims",
9558 ffecom_f2c_ptr_to_ftnlen_type_node);
9559 typefield = ffecom_decl_field (type, dimsfield, "type",
9562 TYPE_FIELDS (type) = namefield;
9565 ggc_add_tree_root (&type, 1);
9573 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9575 ffecom_vardesc_ (ffebld expr)
9579 assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9580 s = ffebld_symter (expr);
9582 if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9585 tree vardesctype = ffecom_type_vardesc_ ();
9594 static int mynumber = 0;
9596 yes = suspend_momentary ();
9598 var = build_decl (VAR_DECL,
9599 ffecom_get_invented_identifier ("__g77_vardesc_%d",
9602 TREE_STATIC (var) = 1;
9603 DECL_INITIAL (var) = error_mark_node;
9605 var = start_decl (var, FALSE);
9607 /* Process inits. */
9609 nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9611 ffesymbol_text (s));
9612 TREE_TYPE (nameinit)
9613 = build_type_variant
9616 build_range_type (integer_type_node,
9618 build_int_2 (i, 0))),
9620 TREE_CONSTANT (nameinit) = 1;
9621 TREE_STATIC (nameinit) = 1;
9622 nameinit = ffecom_1 (ADDR_EXPR,
9623 build_pointer_type (TREE_TYPE (nameinit)),
9626 addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9628 dimsinit = ffecom_vardesc_dims_ (s);
9630 if (typeinit == NULL_TREE)
9632 ffeinfoBasictype bt = ffesymbol_basictype (s);
9633 ffeinfoKindtype kt = ffesymbol_kindtype (s);
9634 int tc = ffecom_f2c_typecode (bt, kt);
9637 typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9640 typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9642 varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9644 TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9646 TREE_CHAIN (TREE_CHAIN (varinits))
9647 = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9648 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9649 = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9651 varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9652 TREE_CONSTANT (varinits) = 1;
9653 TREE_STATIC (varinits) = 1;
9655 finish_decl (var, varinits, FALSE);
9657 var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9659 resume_momentary (yes);
9661 ffesymbol_hook (s).vardesc_tree = var;
9664 return ffesymbol_hook (s).vardesc_tree;
9668 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9670 ffecom_vardesc_array_ (ffesymbol s)
9674 tree item = NULL_TREE;
9678 static int mynumber = 0;
9680 for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9682 b = ffebld_trail (b), ++i)
9686 t = ffecom_vardesc_ (ffebld_head (b));
9688 if (list == NULL_TREE)
9689 list = item = build_tree_list (NULL_TREE, t);
9692 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9693 item = TREE_CHAIN (item);
9697 yes = suspend_momentary ();
9699 item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9700 build_range_type (integer_type_node,
9702 build_int_2 (i, 0)));
9703 list = build (CONSTRUCTOR, item, NULL_TREE, list);
9704 TREE_CONSTANT (list) = 1;
9705 TREE_STATIC (list) = 1;
9707 var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9708 var = build_decl (VAR_DECL, var, item);
9709 TREE_STATIC (var) = 1;
9710 DECL_INITIAL (var) = error_mark_node;
9711 var = start_decl (var, FALSE);
9712 finish_decl (var, list, FALSE);
9714 resume_momentary (yes);
9720 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9722 ffecom_vardesc_dims_ (ffesymbol s)
9724 if (ffesymbol_dims (s) == NULL)
9725 return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9733 tree item = NULL_TREE;
9738 tree baseoff = NULL_TREE;
9739 static int mynumber = 0;
9741 numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9742 TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9744 numelem = ffecom_expr (ffesymbol_arraysize (s));
9745 TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9748 backlist = NULL_TREE;
9749 for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9751 b = ffebld_trail (b), e = ffebld_trail (e))
9757 if (ffebld_trail (b) == NULL)
9761 t = convert (ffecom_f2c_ftnlen_type_node,
9762 ffecom_expr (ffebld_head (e)));
9764 if (list == NULL_TREE)
9765 list = item = build_tree_list (NULL_TREE, t);
9768 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9769 item = TREE_CHAIN (item);
9773 if (ffebld_left (ffebld_head (b)) == NULL)
9774 low = ffecom_integer_one_node;
9776 low = ffecom_expr (ffebld_left (ffebld_head (b)));
9777 low = convert (ffecom_f2c_ftnlen_type_node, low);
9779 back = build_tree_list (low, t);
9780 TREE_CHAIN (back) = backlist;
9784 for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9786 if (TREE_VALUE (item) == NULL_TREE)
9787 baseoff = TREE_PURPOSE (item);
9789 baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9790 TREE_PURPOSE (item),
9791 ffecom_2 (MULT_EXPR,
9792 ffecom_f2c_ftnlen_type_node,
9797 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9799 baseoff = build_tree_list (NULL_TREE, baseoff);
9800 TREE_CHAIN (baseoff) = list;
9802 numelem = build_tree_list (NULL_TREE, numelem);
9803 TREE_CHAIN (numelem) = baseoff;
9805 numdim = build_tree_list (NULL_TREE, numdim);
9806 TREE_CHAIN (numdim) = numelem;
9808 yes = suspend_momentary ();
9810 item = build_array_type (ffecom_f2c_ftnlen_type_node,
9811 build_range_type (integer_type_node,
9814 ((int) ffesymbol_rank (s)
9816 list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9817 TREE_CONSTANT (list) = 1;
9818 TREE_STATIC (list) = 1;
9820 var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9821 var = build_decl (VAR_DECL, var, item);
9822 TREE_STATIC (var) = 1;
9823 DECL_INITIAL (var) = error_mark_node;
9824 var = start_decl (var, FALSE);
9825 finish_decl (var, list, FALSE);
9827 var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9829 resume_momentary (yes);
9836 /* Essentially does a "fold (build1 (code, type, node))" while checking
9837 for certain housekeeping things.
9839 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9840 ffecom_1_fn instead. */
9842 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9844 ffecom_1 (enum tree_code code, tree type, tree node)
9848 if ((node == error_mark_node)
9849 || (type == error_mark_node))
9850 return error_mark_node;
9852 if (code == ADDR_EXPR)
9854 if (!mark_addressable (node))
9855 assert ("can't mark_addressable this node!" == NULL);
9858 switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9863 item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9867 item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9872 if (TREE_CODE (type) != RECORD_TYPE)
9874 item = build1 (code, type, node);
9877 node = ffecom_stabilize_aggregate_ (node);
9878 realtype = TREE_TYPE (TYPE_FIELDS (type));
9880 ffecom_2 (COMPLEX_EXPR, type,
9881 ffecom_1 (NEGATE_EXPR, realtype,
9882 ffecom_1 (REALPART_EXPR, realtype,
9884 ffecom_1 (NEGATE_EXPR, realtype,
9885 ffecom_1 (IMAGPART_EXPR, realtype,
9890 item = build1 (code, type, node);
9894 if (TREE_SIDE_EFFECTS (node))
9895 TREE_SIDE_EFFECTS (item) = 1;
9896 if ((code == ADDR_EXPR) && staticp (node))
9897 TREE_CONSTANT (item) = 1;
9902 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9903 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9904 does not set TREE_ADDRESSABLE (because calling an inline
9905 function does not mean the function needs to be separately
9908 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9910 ffecom_1_fn (tree node)
9915 if (node == error_mark_node)
9916 return error_mark_node;
9918 type = build_type_variant (TREE_TYPE (node),
9919 TREE_READONLY (node),
9920 TREE_THIS_VOLATILE (node));
9921 item = build1 (ADDR_EXPR,
9922 build_pointer_type (type), node);
9923 if (TREE_SIDE_EFFECTS (node))
9924 TREE_SIDE_EFFECTS (item) = 1;
9926 TREE_CONSTANT (item) = 1;
9931 /* Essentially does a "fold (build (code, type, node1, node2))" while
9932 checking for certain housekeeping things. */
9934 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9936 ffecom_2 (enum tree_code code, tree type, tree node1,
9941 if ((node1 == error_mark_node)
9942 || (node2 == error_mark_node)
9943 || (type == error_mark_node))
9944 return error_mark_node;
9946 switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9948 tree a, b, c, d, realtype;
9951 assert ("no CONJ_EXPR support yet" == NULL);
9952 return error_mark_node;
9955 item = build_tree_list (TYPE_FIELDS (type), node1);
9956 TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9957 item = build (CONSTRUCTOR, type, NULL_TREE, item);
9961 if (TREE_CODE (type) != RECORD_TYPE)
9963 item = build (code, type, node1, node2);
9966 node1 = ffecom_stabilize_aggregate_ (node1);
9967 node2 = ffecom_stabilize_aggregate_ (node2);
9968 realtype = TREE_TYPE (TYPE_FIELDS (type));
9970 ffecom_2 (COMPLEX_EXPR, type,
9971 ffecom_2 (PLUS_EXPR, realtype,
9972 ffecom_1 (REALPART_EXPR, realtype,
9974 ffecom_1 (REALPART_EXPR, realtype,
9976 ffecom_2 (PLUS_EXPR, realtype,
9977 ffecom_1 (IMAGPART_EXPR, realtype,
9979 ffecom_1 (IMAGPART_EXPR, realtype,
9984 if (TREE_CODE (type) != RECORD_TYPE)
9986 item = build (code, type, node1, node2);
9989 node1 = ffecom_stabilize_aggregate_ (node1);
9990 node2 = ffecom_stabilize_aggregate_ (node2);
9991 realtype = TREE_TYPE (TYPE_FIELDS (type));
9993 ffecom_2 (COMPLEX_EXPR, type,
9994 ffecom_2 (MINUS_EXPR, realtype,
9995 ffecom_1 (REALPART_EXPR, realtype,
9997 ffecom_1 (REALPART_EXPR, realtype,
9999 ffecom_2 (MINUS_EXPR, realtype,
10000 ffecom_1 (IMAGPART_EXPR, realtype,
10002 ffecom_1 (IMAGPART_EXPR, realtype,
10007 if (TREE_CODE (type) != RECORD_TYPE)
10009 item = build (code, type, node1, node2);
10012 node1 = ffecom_stabilize_aggregate_ (node1);
10013 node2 = ffecom_stabilize_aggregate_ (node2);
10014 realtype = TREE_TYPE (TYPE_FIELDS (type));
10015 a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
10017 b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
10019 c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
10021 d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
10024 ffecom_2 (COMPLEX_EXPR, type,
10025 ffecom_2 (MINUS_EXPR, realtype,
10026 ffecom_2 (MULT_EXPR, realtype,
10029 ffecom_2 (MULT_EXPR, realtype,
10032 ffecom_2 (PLUS_EXPR, realtype,
10033 ffecom_2 (MULT_EXPR, realtype,
10036 ffecom_2 (MULT_EXPR, realtype,
10042 if ((TREE_CODE (node1) != RECORD_TYPE)
10043 && (TREE_CODE (node2) != RECORD_TYPE))
10045 item = build (code, type, node1, node2);
10048 assert (TREE_CODE (node1) == RECORD_TYPE);
10049 assert (TREE_CODE (node2) == RECORD_TYPE);
10050 node1 = ffecom_stabilize_aggregate_ (node1);
10051 node2 = ffecom_stabilize_aggregate_ (node2);
10052 realtype = TREE_TYPE (TYPE_FIELDS (type));
10054 ffecom_2 (TRUTH_ANDIF_EXPR, type,
10055 ffecom_2 (code, type,
10056 ffecom_1 (REALPART_EXPR, realtype,
10058 ffecom_1 (REALPART_EXPR, realtype,
10060 ffecom_2 (code, type,
10061 ffecom_1 (IMAGPART_EXPR, realtype,
10063 ffecom_1 (IMAGPART_EXPR, realtype,
10068 if ((TREE_CODE (node1) != RECORD_TYPE)
10069 && (TREE_CODE (node2) != RECORD_TYPE))
10071 item = build (code, type, node1, node2);
10074 assert (TREE_CODE (node1) == RECORD_TYPE);
10075 assert (TREE_CODE (node2) == RECORD_TYPE);
10076 node1 = ffecom_stabilize_aggregate_ (node1);
10077 node2 = ffecom_stabilize_aggregate_ (node2);
10078 realtype = TREE_TYPE (TYPE_FIELDS (type));
10080 ffecom_2 (TRUTH_ORIF_EXPR, type,
10081 ffecom_2 (code, type,
10082 ffecom_1 (REALPART_EXPR, realtype,
10084 ffecom_1 (REALPART_EXPR, realtype,
10086 ffecom_2 (code, type,
10087 ffecom_1 (IMAGPART_EXPR, realtype,
10089 ffecom_1 (IMAGPART_EXPR, realtype,
10094 item = build (code, type, node1, node2);
10098 if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
10099 TREE_SIDE_EFFECTS (item) = 1;
10100 return fold (item);
10104 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
10106 ffesymbol s; // the ENTRY point itself
10107 if (ffecom_2pass_advise_entrypoint(s))
10108 // the ENTRY point has been accepted
10110 Does whatever compiler needs to do when it learns about the entrypoint,
10111 like determine the return type of the master function, count the
10112 number of entrypoints, etc. Returns FALSE if the return type is
10113 not compatible with the return type(s) of other entrypoint(s).
10115 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
10116 later (after _finish_progunit) be called with the same entrypoint(s)
10117 as passed to this fn for which TRUE was returned.
10120 Return FALSE if the return type conflicts with previous entrypoints. */
10122 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10124 ffecom_2pass_advise_entrypoint (ffesymbol entry)
10126 ffebld list; /* opITEM. */
10127 ffebld mlist; /* opITEM. */
10128 ffebld plist; /* opITEM. */
10129 ffebld arg; /* ffebld_head(opITEM). */
10130 ffebld item; /* opITEM. */
10131 ffesymbol s; /* ffebld_symter(arg). */
10132 ffeinfoBasictype bt = ffesymbol_basictype (entry);
10133 ffeinfoKindtype kt = ffesymbol_kindtype (entry);
10134 ffetargetCharacterSize size = ffesymbol_size (entry);
10137 if (ffecom_num_entrypoints_ == 0)
10138 { /* First entrypoint, make list of main
10139 arglist's dummies. */
10140 assert (ffecom_primary_entry_ != NULL);
10142 ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
10143 ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
10144 ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
10146 for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
10148 list = ffebld_trail (list))
10150 arg = ffebld_head (list);
10151 if (ffebld_op (arg) != FFEBLD_opSYMTER)
10152 continue; /* Alternate return or some such thing. */
10153 item = ffebld_new_item (arg, NULL);
10155 ffecom_master_arglist_ = item;
10157 ffebld_set_trail (plist, item);
10162 /* If necessary, scan entry arglist for alternate returns. Do this scan
10163 apparently redundantly (it's done below to UNIONize the arglists) so
10164 that we don't complain about RETURN 1 if an offending ENTRY is the only
10165 one with an alternate return. */
10167 if (!ffecom_is_altreturning_)
10169 for (list = ffesymbol_dummyargs (entry);
10171 list = ffebld_trail (list))
10173 arg = ffebld_head (list);
10174 if (ffebld_op (arg) == FFEBLD_opSTAR)
10176 ffecom_is_altreturning_ = TRUE;
10182 /* Now check type compatibility. */
10184 switch (ffecom_master_bt_)
10186 case FFEINFO_basictypeNONE:
10187 ok = (bt != FFEINFO_basictypeCHARACTER);
10190 case FFEINFO_basictypeCHARACTER:
10192 = (bt == FFEINFO_basictypeCHARACTER)
10193 && (kt == ffecom_master_kt_)
10194 && (size == ffecom_master_size_);
10197 case FFEINFO_basictypeANY:
10198 return FALSE; /* Just don't bother. */
10201 if (bt == FFEINFO_basictypeCHARACTER)
10207 if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10209 ffecom_master_bt_ = FFEINFO_basictypeNONE;
10210 ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10217 ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10218 ffest_ffebad_here_current_stmt (0);
10220 return FALSE; /* Can't handle entrypoint. */
10223 /* Entrypoint type compatible with previous types. */
10225 ++ffecom_num_entrypoints_;
10227 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10229 for (list = ffesymbol_dummyargs (entry);
10231 list = ffebld_trail (list))
10233 arg = ffebld_head (list);
10234 if (ffebld_op (arg) != FFEBLD_opSYMTER)
10235 continue; /* Alternate return or some such thing. */
10236 s = ffebld_symter (arg);
10237 for (plist = NULL, mlist = ffecom_master_arglist_;
10239 plist = mlist, mlist = ffebld_trail (mlist))
10240 { /* plist points to previous item for easy
10241 appending of arg. */
10242 if (ffebld_symter (ffebld_head (mlist)) == s)
10243 break; /* Already have this arg in the master list. */
10246 continue; /* Already have this arg in the master list. */
10248 /* Append this arg to the master list. */
10250 item = ffebld_new_item (arg, NULL);
10252 ffecom_master_arglist_ = item;
10254 ffebld_set_trail (plist, item);
10261 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10263 ffesymbol s; // the ENTRY point itself
10264 ffecom_2pass_do_entrypoint(s);
10266 Does whatever compiler needs to do to make the entrypoint actually
10267 happen. Must be called for each entrypoint after
10268 ffecom_finish_progunit is called. */
10270 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10272 ffecom_2pass_do_entrypoint (ffesymbol entry)
10274 static int mfn_num = 0;
10275 static int ent_num;
10277 if (mfn_num != ffecom_num_fns_)
10278 { /* First entrypoint for this program unit. */
10280 mfn_num = ffecom_num_fns_;
10281 ffecom_do_entry_ (ffecom_primary_entry_, 0);
10286 --ffecom_num_entrypoints_;
10288 ffecom_do_entry_ (entry, ent_num);
10293 /* Essentially does a "fold (build (code, type, node1, node2))" while
10294 checking for certain housekeeping things. Always sets
10295 TREE_SIDE_EFFECTS. */
10297 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10299 ffecom_2s (enum tree_code code, tree type, tree node1,
10304 if ((node1 == error_mark_node)
10305 || (node2 == error_mark_node)
10306 || (type == error_mark_node))
10307 return error_mark_node;
10309 item = build (code, type, node1, node2);
10310 TREE_SIDE_EFFECTS (item) = 1;
10311 return fold (item);
10315 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10316 checking for certain housekeeping things. */
10318 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10320 ffecom_3 (enum tree_code code, tree type, tree node1,
10321 tree node2, tree node3)
10325 if ((node1 == error_mark_node)
10326 || (node2 == error_mark_node)
10327 || (node3 == error_mark_node)
10328 || (type == error_mark_node))
10329 return error_mark_node;
10331 item = build (code, type, node1, node2, node3);
10332 if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10333 || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10334 TREE_SIDE_EFFECTS (item) = 1;
10335 return fold (item);
10339 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10340 checking for certain housekeeping things. Always sets
10341 TREE_SIDE_EFFECTS. */
10343 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10345 ffecom_3s (enum tree_code code, tree type, tree node1,
10346 tree node2, tree node3)
10350 if ((node1 == error_mark_node)
10351 || (node2 == error_mark_node)
10352 || (node3 == error_mark_node)
10353 || (type == error_mark_node))
10354 return error_mark_node;
10356 item = build (code, type, node1, node2, node3);
10357 TREE_SIDE_EFFECTS (item) = 1;
10358 return fold (item);
10363 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10365 See use by ffecom_list_expr.
10367 If expression is NULL, returns an integer zero tree. If it is not
10368 a CHARACTER expression, returns whatever ffecom_expr
10369 returns and sets the length return value to NULL_TREE. Otherwise
10370 generates code to evaluate the character expression, returns the proper
10371 pointer to the result, but does NOT set the length return value to a tree
10372 that specifies the length of the result. (In other words, the length
10373 variable is always set to NULL_TREE, because a length is never passed.)
10376 Don't set returned length, since nobody needs it (yet; someday if
10377 we allow CHARACTER*(*) dummies to statement functions, we'll need
10380 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10382 ffecom_arg_expr (ffebld expr, tree *length)
10386 *length = NULL_TREE;
10389 return integer_zero_node;
10391 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10392 return ffecom_expr (expr);
10394 return ffecom_arg_ptr_to_expr (expr, &ign);
10398 /* Transform expression into constant argument-pointer-to-expression tree.
10400 If the expression can be transformed into a argument-pointer-to-expression
10401 tree that is constant, that is done, and the tree returned. Else
10402 NULL_TREE is returned.
10404 That way, a caller can attempt to provide compile-time initialization
10405 of a variable and, if that fails, *then* choose to start a new block
10406 and resort to using temporaries, as appropriate. */
10409 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10412 return integer_zero_node;
10414 if (ffebld_op (expr) == FFEBLD_opANY)
10417 *length = error_mark_node;
10418 return error_mark_node;
10421 if (ffebld_arity (expr) == 0
10422 && (ffebld_op (expr) != FFEBLD_opSYMTER
10423 || ffebld_where (expr) == FFEINFO_whereCOMMON
10424 || ffebld_where (expr) == FFEINFO_whereGLOBAL
10425 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10429 t = ffecom_arg_ptr_to_expr (expr, length);
10430 assert (TREE_CONSTANT (t));
10431 assert (! length || TREE_CONSTANT (*length));
10436 && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10437 *length = build_int_2 (ffebld_size (expr), 0);
10439 *length = NULL_TREE;
10443 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10445 See use by ffecom_list_ptr_to_expr.
10447 If expression is NULL, returns an integer zero tree. If it is not
10448 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10449 returns and sets the length return value to NULL_TREE. Otherwise
10450 generates code to evaluate the character expression, returns the proper
10451 pointer to the result, AND sets the length return value to a tree that
10452 specifies the length of the result.
10454 If the length argument is NULL, this is a slightly special
10455 case of building a FORMAT expression, that is, an expression that
10456 will be used at run time without regard to length. For the current
10457 implementation, which uses the libf2c library, this means it is nice
10458 to append a null byte to the end of the expression, where feasible,
10459 to make sure any diagnostic about the FORMAT string terminates at
10462 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10463 length argument. This might even be seen as a feature, if a null
10464 byte can always be appended. */
10466 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10468 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10472 ffecomConcatList_ catlist;
10474 if (length != NULL)
10475 *length = NULL_TREE;
10478 return integer_zero_node;
10480 switch (ffebld_op (expr))
10482 case FFEBLD_opPERCENT_VAL:
10483 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10484 return ffecom_expr (ffebld_left (expr));
10489 temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10490 if (temp_exp == error_mark_node)
10491 return error_mark_node;
10493 return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10497 case FFEBLD_opPERCENT_REF:
10498 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10499 return ffecom_ptr_to_expr (ffebld_left (expr));
10500 if (length != NULL)
10502 ign_length = NULL_TREE;
10503 length = &ign_length;
10505 expr = ffebld_left (expr);
10508 case FFEBLD_opPERCENT_DESCR:
10509 switch (ffeinfo_basictype (ffebld_info (expr)))
10511 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10512 case FFEINFO_basictypeHOLLERITH:
10514 case FFEINFO_basictypeCHARACTER:
10515 break; /* Passed by descriptor anyway. */
10518 item = ffecom_ptr_to_expr (expr);
10519 if (item != error_mark_node)
10520 *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10529 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10530 if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10531 && (length != NULL))
10532 { /* Pass Hollerith by descriptor. */
10533 ffetargetHollerith h;
10535 assert (ffebld_op (expr) == FFEBLD_opCONTER);
10536 h = ffebld_cu_val_hollerith (ffebld_constant_union
10537 (ffebld_conter (expr)));
10539 = build_int_2 (h.length, 0);
10540 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10544 if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10545 return ffecom_ptr_to_expr (expr);
10547 assert (ffeinfo_kindtype (ffebld_info (expr))
10548 == FFEINFO_kindtypeCHARACTER1);
10550 while (ffebld_op (expr) == FFEBLD_opPAREN)
10551 expr = ffebld_left (expr);
10553 catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10554 switch (ffecom_concat_list_count_ (catlist))
10556 case 0: /* Shouldn't happen, but in case it does... */
10557 if (length != NULL)
10559 *length = ffecom_f2c_ftnlen_zero_node;
10560 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10562 ffecom_concat_list_kill_ (catlist);
10563 return null_pointer_node;
10565 case 1: /* The (fairly) easy case. */
10566 if (length == NULL)
10567 ffecom_char_args_with_null_ (&item, &ign_length,
10568 ffecom_concat_list_expr_ (catlist, 0));
10570 ffecom_char_args_ (&item, length,
10571 ffecom_concat_list_expr_ (catlist, 0));
10572 ffecom_concat_list_kill_ (catlist);
10573 assert (item != NULL_TREE);
10576 default: /* Must actually concatenate things. */
10581 int count = ffecom_concat_list_count_ (catlist);
10592 ffetargetCharacterSize sz;
10594 sz = ffecom_concat_list_maxlen_ (catlist);
10596 assert (sz != FFETARGET_charactersizeNONE);
10601 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10602 FFETARGET_charactersizeNONE, count, TRUE);
10605 = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10606 FFETARGET_charactersizeNONE, count, TRUE);
10607 temporary = ffecom_push_tempvar (char_type_node,
10613 hook = ffebld_nonter_hook (expr);
10615 assert (TREE_CODE (hook) == TREE_VEC);
10616 assert (TREE_VEC_LENGTH (hook) == 3);
10617 length_array = lengths = TREE_VEC_ELT (hook, 0);
10618 item_array = items = TREE_VEC_ELT (hook, 1);
10619 temporary = TREE_VEC_ELT (hook, 2);
10623 known_length = ffecom_f2c_ftnlen_zero_node;
10625 for (i = 0; i < count; ++i)
10628 && (length == NULL))
10629 ffecom_char_args_with_null_ (&citem, &clength,
10630 ffecom_concat_list_expr_ (catlist, i));
10632 ffecom_char_args_ (&citem, &clength,
10633 ffecom_concat_list_expr_ (catlist, i));
10634 if ((citem == error_mark_node)
10635 || (clength == error_mark_node))
10637 ffecom_concat_list_kill_ (catlist);
10638 *length = error_mark_node;
10639 return error_mark_node;
10643 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10644 ffecom_modify (void_type_node,
10645 ffecom_2 (ARRAY_REF,
10646 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10648 build_int_2 (i, 0)),
10651 clength = ffecom_save_tree (clength);
10652 if (length != NULL)
10654 = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10658 = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10659 ffecom_modify (void_type_node,
10660 ffecom_2 (ARRAY_REF,
10661 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10663 build_int_2 (i, 0)),
10668 temporary = ffecom_1 (ADDR_EXPR,
10669 build_pointer_type (TREE_TYPE (temporary)),
10672 item = build_tree_list (NULL_TREE, temporary);
10674 = build_tree_list (NULL_TREE,
10675 ffecom_1 (ADDR_EXPR,
10676 build_pointer_type (TREE_TYPE (items)),
10678 TREE_CHAIN (TREE_CHAIN (item))
10679 = build_tree_list (NULL_TREE,
10680 ffecom_1 (ADDR_EXPR,
10681 build_pointer_type (TREE_TYPE (lengths)),
10683 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10686 ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10687 convert (ffecom_f2c_ftnlen_type_node,
10688 build_int_2 (count, 0))));
10689 num = build_int_2 (sz, 0);
10690 TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10691 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10692 = build_tree_list (NULL_TREE, num);
10694 item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10695 TREE_SIDE_EFFECTS (item) = 1;
10696 item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10700 if (length != NULL)
10701 *length = known_length;
10704 ffecom_concat_list_kill_ (catlist);
10705 assert (item != NULL_TREE);
10710 /* Generate call to run-time function.
10712 The first arg is the GNU Fortran Run-Time function index, the second
10713 arg is the list of arguments to pass to it. Returned is the expression
10714 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10715 result (which may be void). */
10717 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10719 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10721 return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10722 ffecom_gfrt_kindtype (ix),
10723 ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10724 NULL_TREE, args, NULL_TREE, NULL,
10725 NULL, NULL_TREE, TRUE, hook);
10729 /* Transform constant-union to tree. */
10731 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10733 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10734 ffeinfoKindtype kt, tree tree_type)
10740 case FFEINFO_basictypeINTEGER:
10746 #if FFETARGET_okINTEGER1
10747 case FFEINFO_kindtypeINTEGER1:
10748 val = ffebld_cu_val_integer1 (*cu);
10752 #if FFETARGET_okINTEGER2
10753 case FFEINFO_kindtypeINTEGER2:
10754 val = ffebld_cu_val_integer2 (*cu);
10758 #if FFETARGET_okINTEGER3
10759 case FFEINFO_kindtypeINTEGER3:
10760 val = ffebld_cu_val_integer3 (*cu);
10764 #if FFETARGET_okINTEGER4
10765 case FFEINFO_kindtypeINTEGER4:
10766 val = ffebld_cu_val_integer4 (*cu);
10771 assert ("bad INTEGER constant kind type" == NULL);
10772 /* Fall through. */
10773 case FFEINFO_kindtypeANY:
10774 return error_mark_node;
10776 item = build_int_2 (val, (val < 0) ? -1 : 0);
10777 TREE_TYPE (item) = tree_type;
10781 case FFEINFO_basictypeLOGICAL:
10787 #if FFETARGET_okLOGICAL1
10788 case FFEINFO_kindtypeLOGICAL1:
10789 val = ffebld_cu_val_logical1 (*cu);
10793 #if FFETARGET_okLOGICAL2
10794 case FFEINFO_kindtypeLOGICAL2:
10795 val = ffebld_cu_val_logical2 (*cu);
10799 #if FFETARGET_okLOGICAL3
10800 case FFEINFO_kindtypeLOGICAL3:
10801 val = ffebld_cu_val_logical3 (*cu);
10805 #if FFETARGET_okLOGICAL4
10806 case FFEINFO_kindtypeLOGICAL4:
10807 val = ffebld_cu_val_logical4 (*cu);
10812 assert ("bad LOGICAL constant kind type" == NULL);
10813 /* Fall through. */
10814 case FFEINFO_kindtypeANY:
10815 return error_mark_node;
10817 item = build_int_2 (val, (val < 0) ? -1 : 0);
10818 TREE_TYPE (item) = tree_type;
10822 case FFEINFO_basictypeREAL:
10824 REAL_VALUE_TYPE val;
10828 #if FFETARGET_okREAL1
10829 case FFEINFO_kindtypeREAL1:
10830 val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10834 #if FFETARGET_okREAL2
10835 case FFEINFO_kindtypeREAL2:
10836 val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10840 #if FFETARGET_okREAL3
10841 case FFEINFO_kindtypeREAL3:
10842 val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10846 #if FFETARGET_okREAL4
10847 case FFEINFO_kindtypeREAL4:
10848 val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10853 assert ("bad REAL constant kind type" == NULL);
10854 /* Fall through. */
10855 case FFEINFO_kindtypeANY:
10856 return error_mark_node;
10858 item = build_real (tree_type, val);
10862 case FFEINFO_basictypeCOMPLEX:
10864 REAL_VALUE_TYPE real;
10865 REAL_VALUE_TYPE imag;
10866 tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10870 #if FFETARGET_okCOMPLEX1
10871 case FFEINFO_kindtypeREAL1:
10872 real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10873 imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10877 #if FFETARGET_okCOMPLEX2
10878 case FFEINFO_kindtypeREAL2:
10879 real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10880 imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10884 #if FFETARGET_okCOMPLEX3
10885 case FFEINFO_kindtypeREAL3:
10886 real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10887 imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10891 #if FFETARGET_okCOMPLEX4
10892 case FFEINFO_kindtypeREAL4:
10893 real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10894 imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10899 assert ("bad REAL constant kind type" == NULL);
10900 /* Fall through. */
10901 case FFEINFO_kindtypeANY:
10902 return error_mark_node;
10904 item = ffecom_build_complex_constant_ (tree_type,
10905 build_real (el_type, real),
10906 build_real (el_type, imag));
10910 case FFEINFO_basictypeCHARACTER:
10911 { /* Happens only in DATA and similar contexts. */
10912 ffetargetCharacter1 val;
10916 #if FFETARGET_okCHARACTER1
10917 case FFEINFO_kindtypeLOGICAL1:
10918 val = ffebld_cu_val_character1 (*cu);
10923 assert ("bad CHARACTER constant kind type" == NULL);
10924 /* Fall through. */
10925 case FFEINFO_kindtypeANY:
10926 return error_mark_node;
10928 item = build_string (ffetarget_length_character1 (val),
10929 ffetarget_text_character1 (val));
10931 = build_type_variant (build_array_type (char_type_node,
10933 (integer_type_node,
10936 (ffetarget_length_character1
10942 case FFEINFO_basictypeHOLLERITH:
10944 ffetargetHollerith h;
10946 h = ffebld_cu_val_hollerith (*cu);
10948 /* If not at least as wide as default INTEGER, widen it. */
10949 if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10950 item = build_string (h.length, h.text);
10953 char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10955 memcpy (str, h.text, h.length);
10956 memset (&str[h.length], ' ',
10957 FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10959 item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10963 = build_type_variant (build_array_type (char_type_node,
10965 (integer_type_node,
10973 case FFEINFO_basictypeTYPELESS:
10975 ffetargetInteger1 ival;
10976 ffetargetTypeless tless;
10979 tless = ffebld_cu_val_typeless (*cu);
10980 error = ffetarget_convert_integer1_typeless (&ival, tless);
10981 assert (error == FFEBAD);
10983 item = build_int_2 ((int) ival, 0);
10988 assert ("not yet on constant type" == NULL);
10989 /* Fall through. */
10990 case FFEINFO_basictypeANY:
10991 return error_mark_node;
10994 TREE_CONSTANT (item) = 1;
11001 /* Transform expression into constant tree.
11003 If the expression can be transformed into a tree that is constant,
11004 that is done, and the tree returned. Else NULL_TREE is returned.
11006 That way, a caller can attempt to provide compile-time initialization
11007 of a variable and, if that fails, *then* choose to start a new block
11008 and resort to using temporaries, as appropriate. */
11011 ffecom_const_expr (ffebld expr)
11014 return integer_zero_node;
11016 if (ffebld_op (expr) == FFEBLD_opANY)
11017 return error_mark_node;
11019 if (ffebld_arity (expr) == 0
11020 && (ffebld_op (expr) != FFEBLD_opSYMTER
11022 /* ~~Enable once common/equivalence is handled properly? */
11023 || ffebld_where (expr) == FFEINFO_whereCOMMON
11025 || ffebld_where (expr) == FFEINFO_whereGLOBAL
11026 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
11030 t = ffecom_expr (expr);
11031 assert (TREE_CONSTANT (t));
11038 /* Handy way to make a field in a struct/union. */
11040 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11042 ffecom_decl_field (tree context, tree prevfield,
11043 const char *name, tree type)
11047 field = build_decl (FIELD_DECL, get_identifier (name), type);
11048 DECL_CONTEXT (field) = context;
11049 DECL_ALIGN (field) = 0;
11050 DECL_USER_ALIGN (field) = 0;
11051 if (prevfield != NULL_TREE)
11052 TREE_CHAIN (prevfield) = field;
11060 ffecom_close_include (FILE *f)
11062 #if FFECOM_GCC_INCLUDE
11063 ffecom_close_include_ (f);
11068 ffecom_decode_include_option (char *spec)
11070 #if FFECOM_GCC_INCLUDE
11071 return ffecom_decode_include_option_ (spec);
11077 /* End a compound statement (block). */
11079 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11081 ffecom_end_compstmt (void)
11083 return bison_rule_compstmt_ ();
11085 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
11087 /* ffecom_end_transition -- Perform end transition on all symbols
11089 ffecom_end_transition();
11091 Calls ffecom_sym_end_transition for each global and local symbol. */
11094 ffecom_end_transition ()
11096 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11100 if (ffe_is_ffedebug ())
11101 fprintf (dmpout, "; end_stmt_transition\n");
11103 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11104 ffecom_list_blockdata_ = NULL;
11105 ffecom_list_common_ = NULL;
11108 ffesymbol_drive (ffecom_sym_end_transition);
11109 if (ffe_is_ffedebug ())
11111 ffestorag_report ();
11112 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11113 ffesymbol_report_all ();
11117 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11118 ffecom_start_progunit_ ();
11120 for (item = ffecom_list_blockdata_;
11122 item = ffebld_trail (item))
11130 static int number = 0;
11132 callee = ffebld_head (item);
11133 s = ffebld_symter (callee);
11134 t = ffesymbol_hook (s).decl_tree;
11135 if (t == NULL_TREE)
11137 s = ffecom_sym_transform_ (s);
11138 t = ffesymbol_hook (s).decl_tree;
11141 yes = suspend_momentary ();
11143 dt = build_pointer_type (TREE_TYPE (t));
11145 var = build_decl (VAR_DECL,
11146 ffecom_get_invented_identifier ("__g77_forceload_%d",
11149 DECL_EXTERNAL (var) = 0;
11150 TREE_STATIC (var) = 1;
11151 TREE_PUBLIC (var) = 0;
11152 DECL_INITIAL (var) = error_mark_node;
11153 TREE_USED (var) = 1;
11155 var = start_decl (var, FALSE);
11157 t = ffecom_1 (ADDR_EXPR, dt, t);
11159 finish_decl (var, t, FALSE);
11161 resume_momentary (yes);
11164 /* This handles any COMMON areas that weren't referenced but have, for
11165 example, important initial data. */
11167 for (item = ffecom_list_common_;
11169 item = ffebld_trail (item))
11170 ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
11172 ffecom_list_common_ = NULL;
11176 /* ffecom_exec_transition -- Perform exec transition on all symbols
11178 ffecom_exec_transition();
11180 Calls ffecom_sym_exec_transition for each global and local symbol.
11181 Make sure error updating not inhibited. */
11184 ffecom_exec_transition ()
11188 if (ffe_is_ffedebug ())
11189 fprintf (dmpout, "; exec_stmt_transition\n");
11191 inhibited = ffebad_inhibit ();
11192 ffebad_set_inhibit (FALSE);
11194 ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
11195 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
11196 if (ffe_is_ffedebug ())
11198 ffestorag_report ();
11199 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11200 ffesymbol_report_all ();
11205 ffebad_set_inhibit (TRUE);
11208 /* Handle assignment statement.
11210 Convert dest and source using ffecom_expr, then join them
11211 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
11213 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11215 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11222 if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11227 /* This attempts to replicate the test below, but must not be
11228 true when the test below is false. (Always err on the side
11229 of creating unused temporaries, to avoid ICEs.) */
11230 if (ffebld_op (dest) != FFEBLD_opSYMTER
11231 || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11232 && (TREE_CODE (dest_tree) != VAR_DECL
11233 || TREE_ADDRESSABLE (dest_tree))))
11235 ffecom_prepare_expr_ (source, dest);
11240 ffecom_prepare_expr_ (source, NULL);
11244 ffecom_prepare_expr_w (NULL_TREE, dest);
11246 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11247 create a temporary through which the assignment is to take place,
11248 since MODIFY_EXPR doesn't handle partial overlap properly. */
11249 if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11250 && ffecom_possible_partial_overlap_ (dest, source))
11252 assign_temp = ffecom_make_tempvar ("complex_let",
11254 [ffebld_basictype (dest)]
11255 [ffebld_kindtype (dest)],
11256 FFETARGET_charactersizeNONE,
11260 assign_temp = NULL_TREE;
11262 ffecom_prepare_end ();
11264 dest_tree = ffecom_expr_w (NULL_TREE, dest);
11265 if (dest_tree == error_mark_node)
11268 if ((TREE_CODE (dest_tree) != VAR_DECL)
11269 || TREE_ADDRESSABLE (dest_tree))
11270 source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11274 assert (! dest_used);
11276 source_tree = ffecom_expr (source);
11278 if (source_tree == error_mark_node)
11282 expr_tree = source_tree;
11283 else if (assign_temp)
11286 /* The back end understands a conceptual move (evaluate source;
11287 store into dest), so use that, in case it can determine
11288 that it is going to use, say, two registers as temporaries
11289 anyway. So don't use the temp (and someday avoid generating
11290 it, once this code starts triggering regularly). */
11291 expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11295 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11298 expand_expr_stmt (expr_tree);
11299 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11305 expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11309 expand_expr_stmt (expr_tree);
11313 ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11314 ffecom_prepare_expr_w (NULL_TREE, dest);
11316 ffecom_prepare_end ();
11318 ffecom_char_args_ (&dest_tree, &dest_length, dest);
11319 ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11324 /* ffecom_expr -- Transform expr into gcc tree
11327 ffebld expr; // FFE expression.
11328 tree = ffecom_expr(expr);
11330 Recursive descent on expr while making corresponding tree nodes and
11331 attaching type info and such. */
11333 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11335 ffecom_expr (ffebld expr)
11337 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11341 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
11343 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11345 ffecom_expr_assign (ffebld expr)
11347 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11351 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
11353 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11355 ffecom_expr_assign_w (ffebld expr)
11357 return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11361 /* Transform expr for use as into read/write tree and stabilize the
11362 reference. Not for use on CHARACTER expressions.
11364 Recursive descent on expr while making corresponding tree nodes and
11365 attaching type info and such. */
11367 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11369 ffecom_expr_rw (tree type, ffebld expr)
11371 assert (expr != NULL);
11372 /* Different target types not yet supported. */
11373 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11375 return stabilize_reference (ffecom_expr (expr));
11379 /* Transform expr for use as into write tree and stabilize the
11380 reference. Not for use on CHARACTER expressions.
11382 Recursive descent on expr while making corresponding tree nodes and
11383 attaching type info and such. */
11385 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11387 ffecom_expr_w (tree type, ffebld expr)
11389 assert (expr != NULL);
11390 /* Different target types not yet supported. */
11391 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11393 return stabilize_reference (ffecom_expr (expr));
11397 /* Do global stuff. */
11399 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11401 ffecom_finish_compile ()
11403 assert (ffecom_outer_function_decl_ == NULL_TREE);
11404 assert (current_function_decl == NULL_TREE);
11406 ffeglobal_drive (ffecom_finish_global_);
11410 /* Public entry point for front end to access finish_decl. */
11412 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11414 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11416 assert (!is_top_level);
11417 finish_decl (decl, init, FALSE);
11421 /* Finish a program unit. */
11423 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11425 ffecom_finish_progunit ()
11427 ffecom_end_compstmt ();
11429 ffecom_previous_function_decl_ = current_function_decl;
11430 ffecom_which_entrypoint_decl_ = NULL_TREE;
11432 finish_function (0);
11437 /* Wrapper for get_identifier. pattern is sprintf-like. */
11439 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11441 ffecom_get_invented_identifier (const char *pattern, ...)
11447 va_start (ap, pattern);
11448 if (vasprintf (&nam, pattern, ap) == 0)
11451 decl = get_identifier (nam);
11453 IDENTIFIER_INVENTED (decl) = 1;
11458 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11460 assert (gfrt < FFECOM_gfrt);
11462 switch (ffecom_gfrt_type_[gfrt])
11464 case FFECOM_rttypeVOID_:
11465 case FFECOM_rttypeVOIDSTAR_:
11466 return FFEINFO_basictypeNONE;
11468 case FFECOM_rttypeFTNINT_:
11469 return FFEINFO_basictypeINTEGER;
11471 case FFECOM_rttypeINTEGER_:
11472 return FFEINFO_basictypeINTEGER;
11474 case FFECOM_rttypeLONGINT_:
11475 return FFEINFO_basictypeINTEGER;
11477 case FFECOM_rttypeLOGICAL_:
11478 return FFEINFO_basictypeLOGICAL;
11480 case FFECOM_rttypeREAL_F2C_:
11481 case FFECOM_rttypeREAL_GNU_:
11482 return FFEINFO_basictypeREAL;
11484 case FFECOM_rttypeCOMPLEX_F2C_:
11485 case FFECOM_rttypeCOMPLEX_GNU_:
11486 return FFEINFO_basictypeCOMPLEX;
11488 case FFECOM_rttypeDOUBLE_:
11489 case FFECOM_rttypeDOUBLEREAL_:
11490 return FFEINFO_basictypeREAL;
11492 case FFECOM_rttypeDBLCMPLX_F2C_:
11493 case FFECOM_rttypeDBLCMPLX_GNU_:
11494 return FFEINFO_basictypeCOMPLEX;
11496 case FFECOM_rttypeCHARACTER_:
11497 return FFEINFO_basictypeCHARACTER;
11500 return FFEINFO_basictypeANY;
11505 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11507 assert (gfrt < FFECOM_gfrt);
11509 switch (ffecom_gfrt_type_[gfrt])
11511 case FFECOM_rttypeVOID_:
11512 case FFECOM_rttypeVOIDSTAR_:
11513 return FFEINFO_kindtypeNONE;
11515 case FFECOM_rttypeFTNINT_:
11516 return FFEINFO_kindtypeINTEGER1;
11518 case FFECOM_rttypeINTEGER_:
11519 return FFEINFO_kindtypeINTEGER1;
11521 case FFECOM_rttypeLONGINT_:
11522 return FFEINFO_kindtypeINTEGER4;
11524 case FFECOM_rttypeLOGICAL_:
11525 return FFEINFO_kindtypeLOGICAL1;
11527 case FFECOM_rttypeREAL_F2C_:
11528 case FFECOM_rttypeREAL_GNU_:
11529 return FFEINFO_kindtypeREAL1;
11531 case FFECOM_rttypeCOMPLEX_F2C_:
11532 case FFECOM_rttypeCOMPLEX_GNU_:
11533 return FFEINFO_kindtypeREAL1;
11535 case FFECOM_rttypeDOUBLE_:
11536 case FFECOM_rttypeDOUBLEREAL_:
11537 return FFEINFO_kindtypeREAL2;
11539 case FFECOM_rttypeDBLCMPLX_F2C_:
11540 case FFECOM_rttypeDBLCMPLX_GNU_:
11541 return FFEINFO_kindtypeREAL2;
11543 case FFECOM_rttypeCHARACTER_:
11544 return FFEINFO_kindtypeCHARACTER1;
11547 return FFEINFO_kindtypeANY;
11561 tree double_ftype_double;
11562 tree float_ftype_float;
11563 tree ldouble_ftype_ldouble;
11564 tree ffecom_tree_ptr_to_fun_type_void;
11566 /* This block of code comes from the now-obsolete cktyps.c. It checks
11567 whether the compiler environment is buggy in known ways, some of which
11568 would, if not explicitly checked here, result in subtle bugs in g77. */
11570 if (ffe_is_do_internal_checks ())
11572 static char names[][12]
11574 {"bar", "bletch", "foo", "foobar"};
11579 name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11580 (int (*)(const void *, const void *)) strcmp);
11581 if (name != (char *) &names[2])
11583 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11588 ul = strtoul ("123456789", NULL, 10);
11589 if (ul != 123456789L)
11591 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11592 in proj.h" == NULL);
11596 fl = atof ("56.789");
11597 if ((fl < 56.788) || (fl > 56.79))
11599 assert ("atof not type double, fix your #include <stdio.h>"
11605 #if FFECOM_GCC_INCLUDE
11606 ffecom_initialize_char_syntax_ ();
11609 ffecom_outer_function_decl_ = NULL_TREE;
11610 current_function_decl = NULL_TREE;
11611 named_labels = NULL_TREE;
11612 current_binding_level = NULL_BINDING_LEVEL;
11613 free_binding_level = NULL_BINDING_LEVEL;
11614 /* Make the binding_level structure for global names. */
11616 global_binding_level = current_binding_level;
11617 current_binding_level->prep_state = 2;
11619 build_common_tree_nodes (1);
11621 /* Define `int' and `char' first so that dbx will output them first. */
11622 pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11623 integer_type_node));
11624 pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11626 pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11627 long_integer_type_node));
11628 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11629 unsigned_type_node));
11630 pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11631 long_unsigned_type_node));
11632 pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11633 long_long_integer_type_node));
11634 pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11635 long_long_unsigned_type_node));
11636 pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11637 short_integer_type_node));
11638 pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11639 short_unsigned_type_node));
11641 /* Set the sizetype before we make other types. This *should* be the
11642 first type we create. */
11645 (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11646 ffecom_typesize_pointer_
11647 = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11649 build_common_tree_nodes_2 (0);
11651 /* Define both `signed char' and `unsigned char'. */
11652 pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11653 signed_char_type_node));
11655 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11656 unsigned_char_type_node));
11658 pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11660 pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11661 double_type_node));
11662 pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11663 long_double_type_node));
11665 /* For now, override what build_common_tree_nodes has done. */
11666 complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11667 complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11668 complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11669 complex_long_double_type_node
11670 = ffecom_make_complex_type_ (long_double_type_node);
11672 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11673 complex_integer_type_node));
11674 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11675 complex_float_type_node));
11676 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11677 complex_double_type_node));
11678 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11679 complex_long_double_type_node));
11681 pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11683 /* We are not going to have real types in C with less than byte alignment,
11684 so we might as well not have any types that claim to have it. */
11685 TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11686 TYPE_USER_ALIGN (void_type_node) = 0;
11688 string_type_node = build_pointer_type (char_type_node);
11690 ffecom_tree_fun_type_void
11691 = build_function_type (void_type_node, NULL_TREE);
11693 ffecom_tree_ptr_to_fun_type_void
11694 = build_pointer_type (ffecom_tree_fun_type_void);
11696 endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11699 = build_function_type (float_type_node,
11700 tree_cons (NULL_TREE, float_type_node, endlink));
11702 double_ftype_double
11703 = build_function_type (double_type_node,
11704 tree_cons (NULL_TREE, double_type_node, endlink));
11706 ldouble_ftype_ldouble
11707 = build_function_type (long_double_type_node,
11708 tree_cons (NULL_TREE, long_double_type_node,
11711 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11712 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11714 ffecom_tree_type[i][j] = NULL_TREE;
11715 ffecom_tree_fun_type[i][j] = NULL_TREE;
11716 ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11717 ffecom_f2c_typecode_[i][j] = -1;
11720 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11721 to size FLOAT_TYPE_SIZE because they have to be the same size as
11722 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11723 Compiler options and other such stuff that change the ways these
11724 types are set should not affect this particular setup. */
11726 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11727 = t = make_signed_type (FLOAT_TYPE_SIZE);
11728 pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11730 type = ffetype_new ();
11732 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11734 ffetype_set_ams (type,
11735 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11736 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11737 ffetype_set_star (base_type,
11738 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11740 ffetype_set_kind (base_type, 1, type);
11741 ffecom_typesize_integer1_ = ffetype_size (type);
11742 assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11744 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11745 = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11746 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11749 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11750 = t = make_signed_type (CHAR_TYPE_SIZE);
11751 pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11753 type = ffetype_new ();
11754 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11756 ffetype_set_ams (type,
11757 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11758 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11759 ffetype_set_star (base_type,
11760 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11762 ffetype_set_kind (base_type, 3, type);
11763 assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11765 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11766 = t = make_unsigned_type (CHAR_TYPE_SIZE);
11767 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11770 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11771 = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11772 pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11774 type = ffetype_new ();
11775 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11777 ffetype_set_ams (type,
11778 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11779 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11780 ffetype_set_star (base_type,
11781 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11783 ffetype_set_kind (base_type, 6, type);
11784 assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11786 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11787 = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11788 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11791 ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11792 = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11793 pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11795 type = ffetype_new ();
11796 ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11798 ffetype_set_ams (type,
11799 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11800 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11801 ffetype_set_star (base_type,
11802 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11804 ffetype_set_kind (base_type, 2, type);
11805 assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11807 ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11808 = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11809 pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11813 if (ffe_is_do_internal_checks ()
11814 && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11815 && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11816 && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11817 && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11819 fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11824 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11825 = t = make_signed_type (FLOAT_TYPE_SIZE);
11826 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11828 type = ffetype_new ();
11830 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11832 ffetype_set_ams (type,
11833 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11834 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11835 ffetype_set_star (base_type,
11836 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11838 ffetype_set_kind (base_type, 1, type);
11839 assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11841 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11842 = t = make_signed_type (CHAR_TYPE_SIZE);
11843 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11845 type = ffetype_new ();
11846 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11848 ffetype_set_ams (type,
11849 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11850 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11851 ffetype_set_star (base_type,
11852 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11854 ffetype_set_kind (base_type, 3, type);
11855 assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11857 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11858 = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11859 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11861 type = ffetype_new ();
11862 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11864 ffetype_set_ams (type,
11865 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11866 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11867 ffetype_set_star (base_type,
11868 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11870 ffetype_set_kind (base_type, 6, type);
11871 assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11873 ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11874 = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11875 pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11877 type = ffetype_new ();
11878 ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11880 ffetype_set_ams (type,
11881 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11882 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11883 ffetype_set_star (base_type,
11884 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11886 ffetype_set_kind (base_type, 2, type);
11887 assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11889 ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11890 = t = make_node (REAL_TYPE);
11891 TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11892 pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11895 type = ffetype_new ();
11897 ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11899 ffetype_set_ams (type,
11900 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11901 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11902 ffetype_set_star (base_type,
11903 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11905 ffetype_set_kind (base_type, 1, type);
11906 ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11907 = FFETARGET_f2cTYREAL;
11908 assert (ffetype_size (type) == sizeof (ffetargetReal1));
11910 ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11911 = t = make_node (REAL_TYPE);
11912 TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2; /* Always twice REAL. */
11913 pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11916 type = ffetype_new ();
11917 ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11919 ffetype_set_ams (type,
11920 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11921 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11922 ffetype_set_star (base_type,
11923 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11925 ffetype_set_kind (base_type, 2, type);
11926 ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11927 = FFETARGET_f2cTYDREAL;
11928 assert (ffetype_size (type) == sizeof (ffetargetReal2));
11930 ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11931 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11932 pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11934 type = ffetype_new ();
11936 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11938 ffetype_set_ams (type,
11939 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11940 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11941 ffetype_set_star (base_type,
11942 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11944 ffetype_set_kind (base_type, 1, type);
11945 ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11946 = FFETARGET_f2cTYCOMPLEX;
11947 assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11949 ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11950 = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11951 pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11953 type = ffetype_new ();
11954 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11956 ffetype_set_ams (type,
11957 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11958 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11959 ffetype_set_star (base_type,
11960 TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11962 ffetype_set_kind (base_type, 2,
11964 ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11965 = FFETARGET_f2cTYDCOMPLEX;
11966 assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11968 /* Make function and ptr-to-function types for non-CHARACTER types. */
11970 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11971 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11973 if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11975 if (i == FFEINFO_basictypeINTEGER)
11977 /* Figure out the smallest INTEGER type that can hold
11978 a pointer on this machine. */
11979 if (GET_MODE_SIZE (TYPE_MODE (t))
11980 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11982 if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11983 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11984 > GET_MODE_SIZE (TYPE_MODE (t))))
11985 ffecom_pointer_kind_ = j;
11988 else if (i == FFEINFO_basictypeCOMPLEX)
11989 t = void_type_node;
11990 /* For f2c compatibility, REAL functions are really
11991 implemented as DOUBLE PRECISION. */
11992 else if ((i == FFEINFO_basictypeREAL)
11993 && (j == FFEINFO_kindtypeREAL1))
11994 t = ffecom_tree_type
11995 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11997 t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11999 ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
12003 /* Set up pointer types. */
12005 if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
12006 fatal ("no INTEGER type can hold a pointer on this configuration");
12007 else if (0 && ffe_is_do_internal_checks ())
12008 fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
12009 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
12010 FFEINFO_kindtypeINTEGERDEFAULT),
12012 ffeinfo_type (FFEINFO_basictypeINTEGER,
12013 ffecom_pointer_kind_));
12015 if (ffe_is_ugly_assign ())
12016 ffecom_label_kind_ = ffecom_pointer_kind_; /* Require ASSIGN etc to this. */
12018 ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
12019 if (0 && ffe_is_do_internal_checks ())
12020 fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
12022 ffecom_integer_type_node
12023 = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
12024 ffecom_integer_zero_node = convert (ffecom_integer_type_node,
12025 integer_zero_node);
12026 ffecom_integer_one_node = convert (ffecom_integer_type_node,
12029 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
12030 Turns out that by TYLONG, runtime/libI77/lio.h really means
12031 "whatever size an ftnint is". For consistency and sanity,
12032 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
12033 all are INTEGER, which we also make out of whatever back-end
12034 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
12035 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
12036 accommodate machines like the Alpha. Note that this suggests
12037 f2c and libf2c are missing a distinction perhaps needed on
12038 some machines between "int" and "long int". -- burley 0.5.5 950215 */
12040 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
12041 FFETARGET_f2cTYLONG);
12042 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
12043 FFETARGET_f2cTYSHORT);
12044 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
12045 FFETARGET_f2cTYINT1);
12046 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
12047 FFETARGET_f2cTYQUAD);
12048 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
12049 FFETARGET_f2cTYLOGICAL);
12050 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
12051 FFETARGET_f2cTYLOGICAL2);
12052 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
12053 FFETARGET_f2cTYLOGICAL1);
12054 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
12055 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
12056 FFETARGET_f2cTYQUAD);
12058 /* CHARACTER stuff is all special-cased, so it is not handled in the above
12059 loop. CHARACTER items are built as arrays of unsigned char. */
12061 ffecom_tree_type[FFEINFO_basictypeCHARACTER]
12062 [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
12063 type = ffetype_new ();
12065 ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
12066 FFEINFO_kindtypeCHARACTER1,
12068 ffetype_set_ams (type,
12069 TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12070 TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12071 ffetype_set_kind (base_type, 1, type);
12072 assert (ffetype_size (type)
12073 == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
12075 ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
12076 [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
12077 ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
12078 [FFEINFO_kindtypeCHARACTER1]
12079 = ffecom_tree_ptr_to_fun_type_void;
12080 ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
12081 = FFETARGET_f2cTYCHAR;
12083 ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
12086 /* Make multi-return-value type and fields. */
12088 ffecom_multi_type_node_ = make_node (UNION_TYPE);
12092 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
12093 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
12097 if (ffecom_tree_type[i][j] == NULL_TREE)
12098 continue; /* Not supported. */
12099 sprintf (&name[0], "bt_%s_kt_%s",
12100 ffeinfo_basictype_string ((ffeinfoBasictype) i),
12101 ffeinfo_kindtype_string ((ffeinfoKindtype) j));
12102 ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
12103 get_identifier (name),
12104 ffecom_tree_type[i][j]);
12105 DECL_CONTEXT (ffecom_multi_fields_[i][j])
12106 = ffecom_multi_type_node_;
12107 DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
12108 DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
12109 TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
12110 field = ffecom_multi_fields_[i][j];
12113 TYPE_FIELDS (ffecom_multi_type_node_) = field;
12114 layout_type (ffecom_multi_type_node_);
12116 /* Subroutines usually return integer because they might have alternate
12119 ffecom_tree_subr_type
12120 = build_function_type (integer_type_node, NULL_TREE);
12121 ffecom_tree_ptr_to_subr_type
12122 = build_pointer_type (ffecom_tree_subr_type);
12123 ffecom_tree_blockdata_type
12124 = build_function_type (void_type_node, NULL_TREE);
12126 builtin_function ("__builtin_sqrtf", float_ftype_float,
12127 BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
12128 builtin_function ("__builtin_fsqrt", double_ftype_double,
12129 BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
12130 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
12131 BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
12132 builtin_function ("__builtin_sinf", float_ftype_float,
12133 BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
12134 builtin_function ("__builtin_sin", double_ftype_double,
12135 BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
12136 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
12137 BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
12138 builtin_function ("__builtin_cosf", float_ftype_float,
12139 BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
12140 builtin_function ("__builtin_cos", double_ftype_double,
12141 BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
12142 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
12143 BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
12146 pedantic_lvalues = FALSE;
12149 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
12152 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
12155 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
12158 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
12159 FFECOM_f2cDOUBLEREAL,
12161 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
12164 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
12165 FFECOM_f2cDOUBLECOMPLEX,
12167 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
12170 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
12173 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
12176 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
12179 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
12183 ffecom_f2c_ftnlen_zero_node
12184 = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
12186 ffecom_f2c_ftnlen_one_node
12187 = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
12189 ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
12190 TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
12192 ffecom_f2c_ptr_to_ftnlen_type_node
12193 = build_pointer_type (ffecom_f2c_ftnlen_type_node);
12195 ffecom_f2c_ptr_to_ftnint_type_node
12196 = build_pointer_type (ffecom_f2c_ftnint_type_node);
12198 ffecom_f2c_ptr_to_integer_type_node
12199 = build_pointer_type (ffecom_f2c_integer_type_node);
12201 ffecom_f2c_ptr_to_real_type_node
12202 = build_pointer_type (ffecom_f2c_real_type_node);
12204 ffecom_float_zero_ = build_real (float_type_node, dconst0);
12205 ffecom_double_zero_ = build_real (double_type_node, dconst0);
12207 REAL_VALUE_TYPE point_5;
12209 #ifdef REAL_ARITHMETIC
12210 REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12214 ffecom_float_half_ = build_real (float_type_node, point_5);
12215 ffecom_double_half_ = build_real (double_type_node, point_5);
12218 /* Do "extern int xargc;". */
12220 ffecom_tree_xargc_ = build_decl (VAR_DECL,
12221 get_identifier ("f__xargc"),
12222 integer_type_node);
12223 DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12224 TREE_STATIC (ffecom_tree_xargc_) = 1;
12225 TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12226 ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12227 finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12229 #if 0 /* This is being fixed, and seems to be working now. */
12230 if ((FLOAT_TYPE_SIZE != 32)
12231 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12233 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12234 (int) FLOAT_TYPE_SIZE);
12235 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12236 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12237 warning ("properly unless they all are 32 bits wide.");
12238 warning ("Please keep this in mind before you report bugs. g77 should");
12239 warning ("support non-32-bit machines better as of version 0.6.");
12243 #if 0 /* Code in ste.c that would crash has been commented out. */
12244 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12245 < TYPE_PRECISION (string_type_node))
12246 /* I/O will probably crash. */
12247 warning ("configuration: char * holds %d bits, but ftnlen only %d",
12248 TYPE_PRECISION (string_type_node),
12249 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12252 #if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
12253 if (TYPE_PRECISION (ffecom_integer_type_node)
12254 < TYPE_PRECISION (string_type_node))
12255 /* ASSIGN 10 TO I will crash. */
12256 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12257 ASSIGN statement might fail",
12258 TYPE_PRECISION (string_type_node),
12259 TYPE_PRECISION (ffecom_integer_type_node));
12264 /* ffecom_init_2 -- Initialize
12266 ffecom_init_2(); */
12268 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12272 assert (ffecom_outer_function_decl_ == NULL_TREE);
12273 assert (current_function_decl == NULL_TREE);
12274 assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12276 ffecom_master_arglist_ = NULL;
12278 ffecom_primary_entry_ = NULL;
12279 ffecom_is_altreturning_ = FALSE;
12280 ffecom_func_result_ = NULL_TREE;
12281 ffecom_multi_retval_ = NULL_TREE;
12285 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12288 ffebld expr; // FFE opITEM list.
12289 tree = ffecom_list_expr(expr);
12291 List of actual args is transformed into corresponding gcc backend list. */
12293 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12295 ffecom_list_expr (ffebld expr)
12298 tree *plist = &list;
12299 tree trail = NULL_TREE; /* Append char length args here. */
12300 tree *ptrail = &trail;
12303 while (expr != NULL)
12305 tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12307 if (texpr == error_mark_node)
12308 return error_mark_node;
12310 *plist = build_tree_list (NULL_TREE, texpr);
12311 plist = &TREE_CHAIN (*plist);
12312 expr = ffebld_trail (expr);
12313 if (length != NULL_TREE)
12315 *ptrail = build_tree_list (NULL_TREE, length);
12316 ptrail = &TREE_CHAIN (*ptrail);
12326 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12329 ffebld expr; // FFE opITEM list.
12330 tree = ffecom_list_ptr_to_expr(expr);
12332 List of actual args is transformed into corresponding gcc backend list for
12333 use in calling an external procedure (vs. a statement function). */
12335 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12337 ffecom_list_ptr_to_expr (ffebld expr)
12340 tree *plist = &list;
12341 tree trail = NULL_TREE; /* Append char length args here. */
12342 tree *ptrail = &trail;
12345 while (expr != NULL)
12347 tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12349 if (texpr == error_mark_node)
12350 return error_mark_node;
12352 *plist = build_tree_list (NULL_TREE, texpr);
12353 plist = &TREE_CHAIN (*plist);
12354 expr = ffebld_trail (expr);
12355 if (length != NULL_TREE)
12357 *ptrail = build_tree_list (NULL_TREE, length);
12358 ptrail = &TREE_CHAIN (*ptrail);
12368 /* Obtain gcc's LABEL_DECL tree for label. */
12370 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12372 ffecom_lookup_label (ffelab label)
12376 if (ffelab_hook (label) == NULL_TREE)
12378 char labelname[16];
12380 switch (ffelab_type (label))
12382 case FFELAB_typeLOOPEND:
12383 case FFELAB_typeNOTLOOP:
12384 case FFELAB_typeENDIF:
12385 sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12386 glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12388 DECL_CONTEXT (glabel) = current_function_decl;
12389 DECL_MODE (glabel) = VOIDmode;
12392 case FFELAB_typeFORMAT:
12393 glabel = build_decl (VAR_DECL,
12394 ffecom_get_invented_identifier
12395 ("__g77_format_%d", (int) ffelab_value (label)),
12396 build_type_variant (build_array_type
12400 TREE_CONSTANT (glabel) = 1;
12401 TREE_STATIC (glabel) = 1;
12402 DECL_CONTEXT (glabel) = 0;
12403 DECL_INITIAL (glabel) = NULL;
12404 make_decl_rtl (glabel, NULL, 0);
12405 expand_decl (glabel);
12407 ffecom_save_tree_forever (glabel);
12411 case FFELAB_typeANY:
12412 glabel = error_mark_node;
12416 assert ("bad label type" == NULL);
12420 ffelab_set_hook (label, glabel);
12424 glabel = ffelab_hook (label);
12431 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12432 a single source specification (as in the fourth argument of MVBITS).
12433 If the type is NULL_TREE, the type of lhs is used to make the type of
12434 the MODIFY_EXPR. */
12436 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12438 ffecom_modify (tree newtype, tree lhs,
12441 if (lhs == error_mark_node || rhs == error_mark_node)
12442 return error_mark_node;
12444 if (newtype == NULL_TREE)
12445 newtype = TREE_TYPE (lhs);
12447 if (TREE_SIDE_EFFECTS (lhs))
12448 lhs = stabilize_reference (lhs);
12450 return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12455 /* Register source file name. */
12458 ffecom_file (const char *name)
12460 #if FFECOM_GCC_INCLUDE
12461 ffecom_file_ (name);
12465 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12468 ffecom_notify_init_storage(st);
12470 Gets called when all possible units in an aggregate storage area (a LOCAL
12471 with equivalences or a COMMON) have been initialized. The initialization
12472 info either is in ffestorag_init or, if that is NULL,
12473 ffestorag_accretion:
12475 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12476 even for an array if the array is one element in length!
12478 ffestorag_accretion will contain an opACCTER. It is much like an
12479 opARRTER except it has an ffebit object in it instead of just a size.
12480 The back end can use the info in the ffebit object, if it wants, to
12481 reduce the amount of actual initialization, but in any case it should
12482 kill the ffebit object when done. Also, set accretion to NULL but
12483 init to a non-NULL value.
12485 After performing initialization, DO NOT set init to NULL, because that'll
12486 tell the front end it is ok for more initialization to happen. Instead,
12487 set init to an opANY expression or some such thing that you can use to
12488 tell that you've already initialized the object.
12491 Support two-pass FFE. */
12494 ffecom_notify_init_storage (ffestorag st)
12496 ffebld init; /* The initialization expression. */
12497 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12498 ffetargetOffset size; /* The size of the entity. */
12499 ffetargetAlign pad; /* Its initial padding. */
12502 if (ffestorag_init (st) == NULL)
12504 init = ffestorag_accretion (st);
12505 assert (init != NULL);
12506 ffestorag_set_accretion (st, NULL);
12507 ffestorag_set_accretes (st, 0);
12509 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12510 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12511 size = ffebld_accter_size (init);
12512 pad = ffebld_accter_pad (init);
12513 ffebit_kill (ffebld_accter_bits (init));
12514 ffebld_set_op (init, FFEBLD_opARRTER);
12515 ffebld_set_arrter (init, ffebld_accter (init));
12516 ffebld_arrter_set_size (init, size);
12517 ffebld_arrter_set_pad (init, size);
12521 ffestorag_set_init (st, init);
12526 init = ffestorag_init (st);
12529 #if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
12530 ffestorag_set_init (st, ffebld_new_any ());
12532 if (ffebld_op (init) == FFEBLD_opANY)
12533 return; /* Oh, we already did this! */
12535 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12539 if (ffestorag_symbol (st) != NULL)
12540 s = ffestorag_symbol (st);
12542 s = ffestorag_typesymbol (st);
12544 fprintf (dmpout, "= initialize_storage \"%s\" ",
12545 (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12546 ffebld_dump (init);
12547 fputc ('\n', dmpout);
12551 #endif /* if FFECOM_ONEPASS */
12554 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12557 ffecom_notify_init_symbol(s);
12559 Gets called when all possible units in a symbol (not placed in COMMON
12560 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12561 have been initialized. The initialization info either is in
12562 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12564 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12565 even for an array if the array is one element in length!
12567 ffesymbol_accretion will contain an opACCTER. It is much like an
12568 opARRTER except it has an ffebit object in it instead of just a size.
12569 The back end can use the info in the ffebit object, if it wants, to
12570 reduce the amount of actual initialization, but in any case it should
12571 kill the ffebit object when done. Also, set accretion to NULL but
12572 init to a non-NULL value.
12574 After performing initialization, DO NOT set init to NULL, because that'll
12575 tell the front end it is ok for more initialization to happen. Instead,
12576 set init to an opANY expression or some such thing that you can use to
12577 tell that you've already initialized the object.
12580 Support two-pass FFE. */
12583 ffecom_notify_init_symbol (ffesymbol s)
12585 ffebld init; /* The initialization expression. */
12586 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12587 ffetargetOffset size; /* The size of the entity. */
12588 ffetargetAlign pad; /* Its initial padding. */
12591 if (ffesymbol_storage (s) == NULL)
12592 return; /* Do nothing until COMMON/EQUIVALENCE
12593 possibilities checked. */
12595 if ((ffesymbol_init (s) == NULL)
12596 && ((init = ffesymbol_accretion (s)) != NULL))
12598 ffesymbol_set_accretion (s, NULL);
12599 ffesymbol_set_accretes (s, 0);
12601 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12602 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12603 size = ffebld_accter_size (init);
12604 pad = ffebld_accter_pad (init);
12605 ffebit_kill (ffebld_accter_bits (init));
12606 ffebld_set_op (init, FFEBLD_opARRTER);
12607 ffebld_set_arrter (init, ffebld_accter (init));
12608 ffebld_arrter_set_size (init, size);
12609 ffebld_arrter_set_pad (init, size);
12613 ffesymbol_set_init (s, init);
12618 init = ffesymbol_init (s);
12622 ffesymbol_set_init (s, ffebld_new_any ());
12624 if (ffebld_op (init) == FFEBLD_opANY)
12625 return; /* Oh, we already did this! */
12627 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12628 fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12629 ffebld_dump (init);
12630 fputc ('\n', dmpout);
12633 #endif /* if FFECOM_ONEPASS */
12636 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12639 ffecom_notify_primary_entry(s);
12641 Gets called when implicit or explicit PROGRAM statement seen or when
12642 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12643 global symbol that serves as the entry point. */
12646 ffecom_notify_primary_entry (ffesymbol s)
12648 ffecom_primary_entry_ = s;
12649 ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12651 if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12652 || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12653 ffecom_primary_entry_is_proc_ = TRUE;
12655 ffecom_primary_entry_is_proc_ = FALSE;
12657 if (!ffe_is_silent ())
12659 if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12660 fprintf (stderr, "%s:\n", ffesymbol_text (s));
12662 fprintf (stderr, " %s:\n", ffesymbol_text (s));
12665 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12666 if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12671 for (list = ffesymbol_dummyargs (s);
12673 list = ffebld_trail (list))
12675 arg = ffebld_head (list);
12676 if (ffebld_op (arg) == FFEBLD_opSTAR)
12678 ffecom_is_altreturning_ = TRUE;
12687 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12689 #if FFECOM_GCC_INCLUDE
12690 return ffecom_open_include_ (name, l, c);
12692 return fopen (name, "r");
12696 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12699 ffebld expr; // FFE expression.
12700 tree = ffecom_ptr_to_expr(expr);
12702 Like ffecom_expr, but sticks address-of in front of most things. */
12704 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12706 ffecom_ptr_to_expr (ffebld expr)
12709 ffeinfoBasictype bt;
12710 ffeinfoKindtype kt;
12713 assert (expr != NULL);
12715 switch (ffebld_op (expr))
12717 case FFEBLD_opSYMTER:
12718 s = ffebld_symter (expr);
12719 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12723 ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12724 assert (ix != FFECOM_gfrt);
12725 if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12727 ffecom_make_gfrt_ (ix);
12728 item = ffecom_gfrt_[ix];
12733 item = ffesymbol_hook (s).decl_tree;
12734 if (item == NULL_TREE)
12736 s = ffecom_sym_transform_ (s);
12737 item = ffesymbol_hook (s).decl_tree;
12740 assert (item != NULL);
12741 if (item == error_mark_node)
12743 if (!ffesymbol_hook (s).addr)
12744 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12748 case FFEBLD_opARRAYREF:
12749 return ffecom_arrayref_ (NULL_TREE, expr, 1);
12751 case FFEBLD_opCONTER:
12753 bt = ffeinfo_basictype (ffebld_info (expr));
12754 kt = ffeinfo_kindtype (ffebld_info (expr));
12756 item = ffecom_constantunion (&ffebld_constant_union
12757 (ffebld_conter (expr)), bt, kt,
12758 ffecom_tree_type[bt][kt]);
12759 if (item == error_mark_node)
12760 return error_mark_node;
12761 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12766 return error_mark_node;
12769 bt = ffeinfo_basictype (ffebld_info (expr));
12770 kt = ffeinfo_kindtype (ffebld_info (expr));
12772 item = ffecom_expr (expr);
12773 if (item == error_mark_node)
12774 return error_mark_node;
12776 /* The back end currently optimizes a bit too zealously for us, in that
12777 we fail JCB001 if the following block of code is omitted. It checks
12778 to see if the transformed expression is a symbol or array reference,
12779 and encloses it in a SAVE_EXPR if that is the case. */
12782 if ((TREE_CODE (item) == VAR_DECL)
12783 || (TREE_CODE (item) == PARM_DECL)
12784 || (TREE_CODE (item) == RESULT_DECL)
12785 || (TREE_CODE (item) == INDIRECT_REF)
12786 || (TREE_CODE (item) == ARRAY_REF)
12787 || (TREE_CODE (item) == COMPONENT_REF)
12789 || (TREE_CODE (item) == OFFSET_REF)
12791 || (TREE_CODE (item) == BUFFER_REF)
12792 || (TREE_CODE (item) == REALPART_EXPR)
12793 || (TREE_CODE (item) == IMAGPART_EXPR))
12795 item = ffecom_save_tree (item);
12798 item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12803 assert ("fall-through error" == NULL);
12804 return error_mark_node;
12808 /* Obtain a temp var with given data type.
12810 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12811 or >= 0 for a CHARACTER type.
12813 elements is -1 for a scalar or > 0 for an array of type. */
12815 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12817 ffecom_make_tempvar (const char *commentary, tree type,
12818 ffetargetCharacterSize size, int elements)
12822 static int mynumber;
12824 assert (current_binding_level->prep_state < 2);
12826 if (type == error_mark_node)
12827 return error_mark_node;
12829 yes = suspend_momentary ();
12831 if (size != FFETARGET_charactersizeNONE)
12832 type = build_array_type (type,
12833 build_range_type (ffecom_f2c_ftnlen_type_node,
12834 ffecom_f2c_ftnlen_one_node,
12835 build_int_2 (size, 0)));
12836 if (elements != -1)
12837 type = build_array_type (type,
12838 build_range_type (integer_type_node,
12840 build_int_2 (elements - 1,
12842 t = build_decl (VAR_DECL,
12843 ffecom_get_invented_identifier ("__g77_%s_%d",
12848 t = start_decl (t, FALSE);
12849 finish_decl (t, NULL_TREE, FALSE);
12851 resume_momentary (yes);
12857 /* Prepare argument pointer to expression.
12859 Like ffecom_prepare_expr, except for expressions to be evaluated
12860 via ffecom_arg_ptr_to_expr. */
12863 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12865 /* ~~For now, it seems to be the same thing. */
12866 ffecom_prepare_expr (expr);
12870 /* End of preparations. */
12873 ffecom_prepare_end (void)
12875 int prep_state = current_binding_level->prep_state;
12877 assert (prep_state < 2);
12878 current_binding_level->prep_state = 2;
12880 return (prep_state == 1) ? TRUE : FALSE;
12883 /* Prepare expression.
12885 This is called before any code is generated for the current block.
12886 It scans the expression, declares any temporaries that might be needed
12887 during evaluation of the expression, and stores those temporaries in
12888 the appropriate "hook" fields of the expression. `dest', if not NULL,
12889 specifies the destination that ffecom_expr_ will see, in case that
12890 helps avoid generating unused temporaries.
12892 ~~Improve to avoid allocating unused temporaries by taking `dest'
12893 into account vis-a-vis aliasing requirements of complex/character
12897 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12899 ffeinfoBasictype bt;
12900 ffeinfoKindtype kt;
12901 ffetargetCharacterSize sz;
12902 tree tempvar = NULL_TREE;
12904 assert (current_binding_level->prep_state < 2);
12909 bt = ffeinfo_basictype (ffebld_info (expr));
12910 kt = ffeinfo_kindtype (ffebld_info (expr));
12911 sz = ffeinfo_size (ffebld_info (expr));
12913 /* Generate whatever temporaries are needed to represent the result
12914 of the expression. */
12916 if (bt == FFEINFO_basictypeCHARACTER)
12918 while (ffebld_op (expr) == FFEBLD_opPAREN)
12919 expr = ffebld_left (expr);
12922 switch (ffebld_op (expr))
12925 /* Don't make temps for SYMTER, CONTER, etc. */
12926 if (ffebld_arity (expr) == 0)
12931 case FFEINFO_basictypeCOMPLEX:
12932 if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12936 if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12939 s = ffebld_symter (ffebld_left (expr));
12940 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12941 || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12942 && ! ffesymbol_is_f2c (s))
12943 || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12944 && ! ffe_is_f2c_library ()))
12947 else if (ffebld_op (expr) == FFEBLD_opPOWER)
12949 /* Requires special treatment. There's no POW_CC function
12950 in libg2c, so POW_ZZ is used, which means we always
12951 need a double-complex temp, not a single-complex. */
12952 kt = FFEINFO_kindtypeREAL2;
12954 else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12955 /* The other ops don't need temps for complex operands. */
12958 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12959 REAL(C). See 19990325-0.f, routine `check', for cases. */
12960 tempvar = ffecom_make_tempvar ("complex",
12962 [FFEINFO_basictypeCOMPLEX][kt],
12963 FFETARGET_charactersizeNONE,
12967 case FFEINFO_basictypeCHARACTER:
12968 if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12971 if (sz == FFETARGET_charactersizeNONE)
12972 /* ~~Kludge alert! This should someday be fixed. */
12975 tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12984 case FFEBLD_opPOWER:
12987 tree rtmp, ltmp, result;
12989 ltype = ffecom_type_expr (ffebld_left (expr));
12990 rtype = ffecom_type_expr (ffebld_right (expr));
12992 rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12993 ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12994 result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12996 tempvar = make_tree_vec (3);
12997 TREE_VEC_ELT (tempvar, 0) = rtmp;
12998 TREE_VEC_ELT (tempvar, 1) = ltmp;
12999 TREE_VEC_ELT (tempvar, 2) = result;
13004 case FFEBLD_opCONCATENATE:
13006 /* This gets special handling, because only one set of temps
13007 is needed for a tree of these -- the tree is treated as
13008 a flattened list of concatenations when generating code. */
13010 ffecomConcatList_ catlist;
13011 tree ltmp, itmp, result;
13015 catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
13016 count = ffecom_concat_list_count_ (catlist);
13021 = ffecom_make_tempvar ("concat_len",
13022 ffecom_f2c_ftnlen_type_node,
13023 FFETARGET_charactersizeNONE, count);
13025 = ffecom_make_tempvar ("concat_item",
13026 ffecom_f2c_address_type_node,
13027 FFETARGET_charactersizeNONE, count);
13029 = ffecom_make_tempvar ("concat_res",
13031 ffecom_concat_list_maxlen_ (catlist),
13034 tempvar = make_tree_vec (3);
13035 TREE_VEC_ELT (tempvar, 0) = ltmp;
13036 TREE_VEC_ELT (tempvar, 1) = itmp;
13037 TREE_VEC_ELT (tempvar, 2) = result;
13040 for (i = 0; i < count; ++i)
13041 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
13044 ffecom_concat_list_kill_ (catlist);
13048 ffebld_nonter_set_hook (expr, tempvar);
13049 current_binding_level->prep_state = 1;
13054 case FFEBLD_opCONVERT:
13055 if (bt == FFEINFO_basictypeCHARACTER
13056 && ((ffebld_size_known (ffebld_left (expr))
13057 == FFETARGET_charactersizeNONE)
13058 || (ffebld_size_known (ffebld_left (expr)) >= sz)))
13059 tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
13065 ffebld_nonter_set_hook (expr, tempvar);
13066 current_binding_level->prep_state = 1;
13069 /* Prepare subexpressions for this expr. */
13071 switch (ffebld_op (expr))
13073 case FFEBLD_opPERCENT_LOC:
13074 ffecom_prepare_ptr_to_expr (ffebld_left (expr));
13077 case FFEBLD_opPERCENT_VAL:
13078 case FFEBLD_opPERCENT_REF:
13079 ffecom_prepare_expr (ffebld_left (expr));
13082 case FFEBLD_opPERCENT_DESCR:
13083 ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
13086 case FFEBLD_opITEM:
13092 item = ffebld_trail (item))
13093 if (ffebld_head (item) != NULL)
13094 ffecom_prepare_expr (ffebld_head (item));
13099 /* Need to handle character conversion specially. */
13100 switch (ffebld_arity (expr))
13103 ffecom_prepare_expr (ffebld_left (expr));
13104 ffecom_prepare_expr (ffebld_right (expr));
13108 ffecom_prepare_expr (ffebld_left (expr));
13119 /* Prepare expression for reading and writing.
13121 Like ffecom_prepare_expr, except for expressions to be evaluated
13122 via ffecom_expr_rw. */
13125 ffecom_prepare_expr_rw (tree type, ffebld expr)
13127 /* This is all we support for now. */
13128 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13130 /* ~~For now, it seems to be the same thing. */
13131 ffecom_prepare_expr (expr);
13135 /* Prepare expression for writing.
13137 Like ffecom_prepare_expr, except for expressions to be evaluated
13138 via ffecom_expr_w. */
13141 ffecom_prepare_expr_w (tree type, ffebld expr)
13143 /* This is all we support for now. */
13144 assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13146 /* ~~For now, it seems to be the same thing. */
13147 ffecom_prepare_expr (expr);
13151 /* Prepare expression for returning.
13153 Like ffecom_prepare_expr, except for expressions to be evaluated
13154 via ffecom_return_expr. */
13157 ffecom_prepare_return_expr (ffebld expr)
13159 assert (current_binding_level->prep_state < 2);
13161 if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
13162 && ffecom_is_altreturning_
13164 ffecom_prepare_expr (expr);
13167 /* Prepare pointer to expression.
13169 Like ffecom_prepare_expr, except for expressions to be evaluated
13170 via ffecom_ptr_to_expr. */
13173 ffecom_prepare_ptr_to_expr (ffebld expr)
13175 /* ~~For now, it seems to be the same thing. */
13176 ffecom_prepare_expr (expr);
13180 /* Transform expression into constant pointer-to-expression tree.
13182 If the expression can be transformed into a pointer-to-expression tree
13183 that is constant, that is done, and the tree returned. Else NULL_TREE
13186 That way, a caller can attempt to provide compile-time initialization
13187 of a variable and, if that fails, *then* choose to start a new block
13188 and resort to using temporaries, as appropriate. */
13191 ffecom_ptr_to_const_expr (ffebld expr)
13194 return integer_zero_node;
13196 if (ffebld_op (expr) == FFEBLD_opANY)
13197 return error_mark_node;
13199 if (ffebld_arity (expr) == 0
13200 && (ffebld_op (expr) != FFEBLD_opSYMTER
13201 || ffebld_where (expr) == FFEINFO_whereCOMMON
13202 || ffebld_where (expr) == FFEINFO_whereGLOBAL
13203 || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
13207 t = ffecom_ptr_to_expr (expr);
13208 assert (TREE_CONSTANT (t));
13215 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13217 tree rtn; // NULL_TREE means use expand_null_return()
13218 ffebld expr; // NULL if no alt return expr to RETURN stmt
13219 rtn = ffecom_return_expr(expr);
13221 Based on the program unit type and other info (like return function
13222 type, return master function type when alternate ENTRY points,
13223 whether subroutine has any alternate RETURN points, etc), returns the
13224 appropriate expression to be returned to the caller, or NULL_TREE
13225 meaning no return value or the caller expects it to be returned somewhere
13226 else (which is handled by other parts of this module). */
13228 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13230 ffecom_return_expr (ffebld expr)
13234 switch (ffecom_primary_entry_kind_)
13236 case FFEINFO_kindPROGRAM:
13237 case FFEINFO_kindBLOCKDATA:
13241 case FFEINFO_kindSUBROUTINE:
13242 if (!ffecom_is_altreturning_)
13243 rtn = NULL_TREE; /* No alt returns, never an expr. */
13244 else if (expr == NULL)
13245 rtn = integer_zero_node;
13247 rtn = ffecom_expr (expr);
13250 case FFEINFO_kindFUNCTION:
13251 if ((ffecom_multi_retval_ != NULL_TREE)
13252 || (ffesymbol_basictype (ffecom_primary_entry_)
13253 == FFEINFO_basictypeCHARACTER)
13254 || ((ffesymbol_basictype (ffecom_primary_entry_)
13255 == FFEINFO_basictypeCOMPLEX)
13256 && (ffecom_num_entrypoints_ == 0)
13257 && ffesymbol_is_f2c (ffecom_primary_entry_)))
13258 { /* Value is returned by direct assignment
13259 into (implicit) dummy. */
13263 rtn = ffecom_func_result_;
13265 /* Spurious error if RETURN happens before first reference! So elide
13266 this code. In particular, for debugging registry, rtn should always
13267 be non-null after all, but TREE_USED won't be set until we encounter
13268 a reference in the code. Perfectly okay (but weird) code that,
13269 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13270 this diagnostic for no reason. Have people use -O -Wuninitialized
13271 and leave it to the back end to find obviously weird cases. */
13273 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13274 situation; if the return value has never been referenced, it won't
13275 have a tree under 2pass mode. */
13276 if ((rtn == NULL_TREE)
13277 || !TREE_USED (rtn))
13279 ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13280 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13281 ffesymbol_where_column (ffecom_primary_entry_));
13282 ffebad_string (ffesymbol_text (ffesymbol_funcresult
13283 (ffecom_primary_entry_)));
13290 assert ("bad unit kind" == NULL);
13291 case FFEINFO_kindANY:
13292 rtn = error_mark_node;
13300 /* Do save_expr only if tree is not error_mark_node. */
13302 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13304 ffecom_save_tree (tree t)
13306 return save_expr (t);
13310 /* Start a compound statement (block). */
13312 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13314 ffecom_start_compstmt (void)
13316 bison_rule_pushlevel_ ();
13318 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13320 /* Public entry point for front end to access start_decl. */
13322 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13324 ffecom_start_decl (tree decl, bool is_initialized)
13326 DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13327 return start_decl (decl, FALSE);
13331 /* ffecom_sym_commit -- Symbol's state being committed to reality
13334 ffecom_sym_commit(s);
13336 Does whatever the backend needs when a symbol is committed after having
13337 been backtrackable for a period of time. */
13339 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13341 ffecom_sym_commit (ffesymbol s UNUSED)
13343 assert (!ffesymbol_retractable ());
13347 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13349 ffecom_sym_end_transition();
13351 Does backend-specific stuff and also calls ffest_sym_end_transition
13352 to do the necessary FFE stuff.
13354 Backtracking is never enabled when this fn is called, so don't worry
13358 ffecom_sym_end_transition (ffesymbol s)
13362 assert (!ffesymbol_retractable ());
13364 s = ffest_sym_end_transition (s);
13366 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13367 if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13368 && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13370 ffecom_list_blockdata_
13371 = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13372 FFEINTRIN_specNONE,
13373 FFEINTRIN_impNONE),
13374 ffecom_list_blockdata_);
13378 /* This is where we finally notice that a symbol has partial initialization
13379 and finalize it. */
13381 if (ffesymbol_accretion (s) != NULL)
13383 assert (ffesymbol_init (s) == NULL);
13384 ffecom_notify_init_symbol (s);
13386 else if (((st = ffesymbol_storage (s)) != NULL)
13387 && ((st = ffestorag_parent (st)) != NULL)
13388 && (ffestorag_accretion (st) != NULL))
13390 assert (ffestorag_init (st) == NULL);
13391 ffecom_notify_init_storage (st);
13394 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13395 if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13396 && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13397 && (ffesymbol_storage (s) != NULL))
13399 ffecom_list_common_
13400 = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13401 FFEINTRIN_specNONE,
13402 FFEINTRIN_impNONE),
13403 ffecom_list_common_);
13410 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13412 ffecom_sym_exec_transition();
13414 Does backend-specific stuff and also calls ffest_sym_exec_transition
13415 to do the necessary FFE stuff.
13417 See the long-winded description in ffecom_sym_learned for info
13418 on handling the situation where backtracking is inhibited. */
13421 ffecom_sym_exec_transition (ffesymbol s)
13423 s = ffest_sym_exec_transition (s);
13428 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13431 s = ffecom_sym_learned(s);
13433 Called when a new symbol is seen after the exec transition or when more
13434 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
13435 it arrives here is that all its latest info is updated already, so its
13436 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13437 field filled in if its gone through here or exec_transition first, and
13440 The backend probably wants to check ffesymbol_retractable() to see if
13441 backtracking is in effect. If so, the FFE's changes to the symbol may
13442 be retracted (undone) or committed (ratified), at which time the
13443 appropriate ffecom_sym_retract or _commit function will be called
13446 If the backend has its own backtracking mechanism, great, use it so that
13447 committal is a simple operation. Though it doesn't make much difference,
13448 I suppose: the reason for tentative symbol evolution in the FFE is to
13449 enable error detection in weird incorrect statements early and to disable
13450 incorrect error detection on a correct statement. The backend is not
13451 likely to introduce any information that'll get involved in these
13452 considerations, so it is probably just fine that the implementation
13453 model for this fn and for _exec_transition is to not do anything
13454 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13455 and instead wait until ffecom_sym_commit is called (which it never
13456 will be as long as we're using ambiguity-detecting statement analysis in
13457 the FFE, which we are initially to shake out the code, but don't depend
13458 on this), otherwise go ahead and do whatever is needed.
13460 In essence, then, when this fn and _exec_transition get called while
13461 backtracking is enabled, a general mechanism would be to flag which (or
13462 both) of these were called (and in what order? neat question as to what
13463 might happen that I'm too lame to think through right now) and then when
13464 _commit is called reproduce the original calling sequence, if any, for
13465 the two fns (at which point backtracking will, of course, be disabled). */
13468 ffecom_sym_learned (ffesymbol s)
13470 ffestorag_exec_layout (s);
13475 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13478 ffecom_sym_retract(s);
13480 Does whatever the backend needs when a symbol is retracted after having
13481 been backtrackable for a period of time. */
13483 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13485 ffecom_sym_retract (ffesymbol s UNUSED)
13487 assert (!ffesymbol_retractable ());
13489 #if 0 /* GCC doesn't commit any backtrackable sins,
13490 so nothing needed here. */
13491 switch (ffesymbol_hook (s).state)
13493 case 0: /* nothing happened yet. */
13496 case 1: /* exec transition happened. */
13499 case 2: /* learned happened. */
13502 case 3: /* learned then exec. */
13505 case 4: /* exec then learned. */
13509 assert ("bad hook state" == NULL);
13516 /* Create temporary gcc label. */
13518 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13520 ffecom_temp_label ()
13523 static int mynumber = 0;
13525 glabel = build_decl (LABEL_DECL,
13526 ffecom_get_invented_identifier ("__g77_label_%d",
13529 DECL_CONTEXT (glabel) = current_function_decl;
13530 DECL_MODE (glabel) = VOIDmode;
13536 /* Return an expression that is usable as an arg in a conditional context
13537 (IF, DO WHILE, .NOT., and so on).
13539 Use the one provided for the back end as of >2.6.0. */
13541 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13543 ffecom_truth_value (tree expr)
13545 return truthvalue_conversion (expr);
13549 /* Return the inversion of a truth value (the inversion of what
13550 ffecom_truth_value builds).
13552 Apparently invert_truthvalue, which is properly in the back end, is
13553 enough for now, so just use it. */
13555 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13557 ffecom_truth_value_invert (tree expr)
13559 return invert_truthvalue (ffecom_truth_value (expr));
13564 /* Return the tree that is the type of the expression, as would be
13565 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13566 transforming the expression, generating temporaries, etc. */
13569 ffecom_type_expr (ffebld expr)
13571 ffeinfoBasictype bt;
13572 ffeinfoKindtype kt;
13575 assert (expr != NULL);
13577 bt = ffeinfo_basictype (ffebld_info (expr));
13578 kt = ffeinfo_kindtype (ffebld_info (expr));
13579 tree_type = ffecom_tree_type[bt][kt];
13581 switch (ffebld_op (expr))
13583 case FFEBLD_opCONTER:
13584 case FFEBLD_opSYMTER:
13585 case FFEBLD_opARRAYREF:
13586 case FFEBLD_opUPLUS:
13587 case FFEBLD_opPAREN:
13588 case FFEBLD_opUMINUS:
13590 case FFEBLD_opSUBTRACT:
13591 case FFEBLD_opMULTIPLY:
13592 case FFEBLD_opDIVIDE:
13593 case FFEBLD_opPOWER:
13595 case FFEBLD_opFUNCREF:
13596 case FFEBLD_opSUBRREF:
13600 case FFEBLD_opNEQV:
13602 case FFEBLD_opCONVERT:
13609 case FFEBLD_opPERCENT_LOC:
13612 case FFEBLD_opACCTER:
13613 case FFEBLD_opARRTER:
13614 case FFEBLD_opITEM:
13615 case FFEBLD_opSTAR:
13616 case FFEBLD_opBOUNDS:
13617 case FFEBLD_opREPEAT:
13618 case FFEBLD_opLABTER:
13619 case FFEBLD_opLABTOK:
13620 case FFEBLD_opIMPDO:
13621 case FFEBLD_opCONCATENATE:
13622 case FFEBLD_opSUBSTR:
13624 assert ("bad op for ffecom_type_expr" == NULL);
13625 /* Fall through. */
13627 return error_mark_node;
13631 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13633 If the PARM_DECL already exists, return it, else create it. It's an
13634 integer_type_node argument for the master function that implements a
13635 subroutine or function with more than one entrypoint and is bound at
13636 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13637 first ENTRY statement, and so on). */
13639 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13641 ffecom_which_entrypoint_decl ()
13643 assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13645 return ffecom_which_entrypoint_decl_;
13650 /* The following sections consists of private and public functions
13651 that have the same names and perform roughly the same functions
13652 as counterparts in the C front end. Changes in the C front end
13653 might affect how things should be done here. Only functions
13654 needed by the back end should be public here; the rest should
13655 be private (static in the C sense). Functions needed by other
13656 g77 front-end modules should be accessed by them via public
13657 ffecom_* names, which should themselves call private versions
13658 in this section so the private versions are easy to recognize
13659 when upgrading to a new gcc and finding interesting changes
13662 Functions named after rule "foo:" in c-parse.y are named
13663 "bison_rule_foo_" so they are easy to find. */
13665 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13668 bison_rule_pushlevel_ ()
13670 emit_line_note (input_filename, lineno);
13672 clear_last_expr ();
13674 expand_start_bindings (0);
13678 bison_rule_compstmt_ ()
13681 int keep = kept_level_p ();
13683 /* Make the temps go away. */
13685 current_binding_level->names = NULL_TREE;
13687 emit_line_note (input_filename, lineno);
13688 expand_end_bindings (getdecls (), keep, 0);
13689 t = poplevel (keep, 1, 0);
13695 /* Return a definition for a builtin function named NAME and whose data type
13696 is TYPE. TYPE should be a function type with argument types.
13697 FUNCTION_CODE tells later passes how to compile calls to this function.
13698 See tree.h for its possible values.
13700 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13701 the name to be called if we can't opencode the function. */
13704 builtin_function (const char *name, tree type, int function_code,
13705 enum built_in_class class,
13706 const char *library_name)
13708 tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13709 DECL_EXTERNAL (decl) = 1;
13710 TREE_PUBLIC (decl) = 1;
13712 DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13713 make_decl_rtl (decl, NULL_PTR, 1);
13715 DECL_BUILT_IN_CLASS (decl) = class;
13716 DECL_FUNCTION_CODE (decl) = function_code;
13721 /* Handle when a new declaration NEWDECL
13722 has the same name as an old one OLDDECL
13723 in the same binding contour.
13724 Prints an error message if appropriate.
13726 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13727 Otherwise, return 0. */
13730 duplicate_decls (tree newdecl, tree olddecl)
13732 int types_match = 1;
13733 int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13734 && DECL_INITIAL (newdecl) != 0);
13735 tree oldtype = TREE_TYPE (olddecl);
13736 tree newtype = TREE_TYPE (newdecl);
13738 if (olddecl == newdecl)
13741 if (TREE_CODE (newtype) == ERROR_MARK
13742 || TREE_CODE (oldtype) == ERROR_MARK)
13745 /* New decl is completely inconsistent with the old one =>
13746 tell caller to replace the old one.
13747 This is always an error except in the case of shadowing a builtin. */
13748 if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13751 /* For real parm decl following a forward decl,
13752 return 1 so old decl will be reused. */
13753 if (types_match && TREE_CODE (newdecl) == PARM_DECL
13754 && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13757 /* The new declaration is the same kind of object as the old one.
13758 The declarations may partially match. Print warnings if they don't
13759 match enough. Ultimately, copy most of the information from the new
13760 decl to the old one, and keep using the old one. */
13762 if (TREE_CODE (olddecl) == FUNCTION_DECL
13763 && DECL_BUILT_IN (olddecl))
13765 /* A function declaration for a built-in function. */
13766 if (!TREE_PUBLIC (newdecl))
13768 else if (!types_match)
13770 /* Accept the return type of the new declaration if same modes. */
13771 tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13772 tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13774 if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13776 /* Function types may be shared, so we can't just modify
13777 the return type of olddecl's function type. */
13779 = build_function_type (newreturntype,
13780 TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13784 TREE_TYPE (olddecl) = newtype;
13790 else if (TREE_CODE (olddecl) == FUNCTION_DECL
13791 && DECL_SOURCE_LINE (olddecl) == 0)
13793 /* A function declaration for a predeclared function
13794 that isn't actually built in. */
13795 if (!TREE_PUBLIC (newdecl))
13797 else if (!types_match)
13799 /* If the types don't match, preserve volatility indication.
13800 Later on, we will discard everything else about the
13801 default declaration. */
13802 TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13806 /* Copy all the DECL_... slots specified in the new decl
13807 except for any that we copy here from the old type.
13809 Past this point, we don't change OLDTYPE and NEWTYPE
13810 even if we change the types of NEWDECL and OLDDECL. */
13814 /* Merge the data types specified in the two decls. */
13815 if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13816 TREE_TYPE (newdecl)
13817 = TREE_TYPE (olddecl)
13818 = TREE_TYPE (newdecl);
13820 /* Lay the type out, unless already done. */
13821 if (oldtype != TREE_TYPE (newdecl))
13823 if (TREE_TYPE (newdecl) != error_mark_node)
13824 layout_type (TREE_TYPE (newdecl));
13825 if (TREE_CODE (newdecl) != FUNCTION_DECL
13826 && TREE_CODE (newdecl) != TYPE_DECL
13827 && TREE_CODE (newdecl) != CONST_DECL)
13828 layout_decl (newdecl, 0);
13832 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13833 DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13834 DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13835 if (TREE_CODE (olddecl) != FUNCTION_DECL)
13836 if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13838 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13839 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13843 /* Keep the old rtl since we can safely use it. */
13844 DECL_RTL (newdecl) = DECL_RTL (olddecl);
13846 /* Merge the type qualifiers. */
13847 if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13848 && !TREE_THIS_VOLATILE (newdecl))
13849 TREE_THIS_VOLATILE (olddecl) = 0;
13850 if (TREE_READONLY (newdecl))
13851 TREE_READONLY (olddecl) = 1;
13852 if (TREE_THIS_VOLATILE (newdecl))
13854 TREE_THIS_VOLATILE (olddecl) = 1;
13855 if (TREE_CODE (newdecl) == VAR_DECL)
13856 make_var_volatile (newdecl);
13859 /* Keep source location of definition rather than declaration.
13860 Likewise, keep decl at outer scope. */
13861 if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13862 || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13864 DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13865 DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13867 if (DECL_CONTEXT (olddecl) == 0
13868 && TREE_CODE (newdecl) != FUNCTION_DECL)
13869 DECL_CONTEXT (newdecl) = 0;
13872 /* Merge the unused-warning information. */
13873 if (DECL_IN_SYSTEM_HEADER (olddecl))
13874 DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13875 else if (DECL_IN_SYSTEM_HEADER (newdecl))
13876 DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13878 /* Merge the initialization information. */
13879 if (DECL_INITIAL (newdecl) == 0)
13880 DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13882 /* Merge the section attribute.
13883 We want to issue an error if the sections conflict but that must be
13884 done later in decl_attributes since we are called before attributes
13886 if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13887 DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13890 if (TREE_CODE (newdecl) == FUNCTION_DECL)
13892 DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13893 DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13897 /* If cannot merge, then use the new type and qualifiers,
13898 and don't preserve the old rtl. */
13901 TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13902 TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13903 TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13904 TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13907 /* Merge the storage class information. */
13908 /* For functions, static overrides non-static. */
13909 if (TREE_CODE (newdecl) == FUNCTION_DECL)
13911 TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13912 /* This is since we don't automatically
13913 copy the attributes of NEWDECL into OLDDECL. */
13914 TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13915 /* If this clears `static', clear it in the identifier too. */
13916 if (! TREE_PUBLIC (olddecl))
13917 TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13919 if (DECL_EXTERNAL (newdecl))
13921 TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13922 DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13923 /* An extern decl does not override previous storage class. */
13924 TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13928 TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13929 TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13932 /* If either decl says `inline', this fn is inline,
13933 unless its definition was passed already. */
13934 if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13935 DECL_INLINE (olddecl) = 1;
13936 DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13938 /* Get rid of any built-in function if new arg types don't match it
13939 or if we have a function definition. */
13940 if (TREE_CODE (newdecl) == FUNCTION_DECL
13941 && DECL_BUILT_IN (olddecl)
13942 && (!types_match || new_is_definition))
13944 TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13945 DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13948 /* If redeclaring a builtin function, and not a definition,
13950 Also preserve various other info from the definition. */
13951 if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13953 if (DECL_BUILT_IN (olddecl))
13955 DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13956 DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13959 DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
13961 DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13962 DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13963 DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13964 DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13967 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13968 But preserve olddecl's DECL_UID. */
13970 register unsigned olddecl_uid = DECL_UID (olddecl);
13972 memcpy ((char *) olddecl + sizeof (struct tree_common),
13973 (char *) newdecl + sizeof (struct tree_common),
13974 sizeof (struct tree_decl) - sizeof (struct tree_common));
13975 DECL_UID (olddecl) = olddecl_uid;
13981 /* Finish processing of a declaration;
13982 install its initial value.
13983 If the length of an array type is not known before,
13984 it must be determined now, from the initial value, or it is an error. */
13987 finish_decl (tree decl, tree init, bool is_top_level)
13989 register tree type = TREE_TYPE (decl);
13990 int was_incomplete = (DECL_SIZE (decl) == 0);
13991 int temporary = allocation_temporary_p ();
13992 bool at_top_level = (current_binding_level == global_binding_level);
13993 bool top_level = is_top_level || at_top_level;
13995 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13997 assert (!is_top_level || !at_top_level);
13999 if (TREE_CODE (decl) == PARM_DECL)
14000 assert (init == NULL_TREE);
14001 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
14002 overlaps DECL_ARG_TYPE. */
14003 else if (init == NULL_TREE)
14004 assert (DECL_INITIAL (decl) == NULL_TREE);
14006 assert (DECL_INITIAL (decl) == error_mark_node);
14008 if (init != NULL_TREE)
14010 if (TREE_CODE (decl) != TYPE_DECL)
14011 DECL_INITIAL (decl) = init;
14014 /* typedef foo = bar; store the type of bar as the type of foo. */
14015 TREE_TYPE (decl) = TREE_TYPE (init);
14016 DECL_INITIAL (decl) = init = 0;
14020 /* Pop back to the obstack that is current for this binding level. This is
14021 because MAXINDEX, rtl, etc. to be made below must go in the permanent
14022 obstack. But don't discard the temporary data yet. */
14025 /* Deduce size of array from initialization, if not already known */
14027 if (TREE_CODE (type) == ARRAY_TYPE
14028 && TYPE_DOMAIN (type) == 0
14029 && TREE_CODE (decl) != TYPE_DECL)
14031 assert (top_level);
14032 assert (was_incomplete);
14034 layout_decl (decl, 0);
14037 if (TREE_CODE (decl) == VAR_DECL)
14039 if (DECL_SIZE (decl) == NULL_TREE
14040 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
14041 layout_decl (decl, 0);
14043 if (DECL_SIZE (decl) == NULL_TREE
14044 && (TREE_STATIC (decl)
14046 /* A static variable with an incomplete type is an error if it is
14047 initialized. Also if it is not file scope. Otherwise, let it
14048 through, but if it is not `extern' then it may cause an error
14050 (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
14052 /* An automatic variable with an incomplete type is an error. */
14053 !DECL_EXTERNAL (decl)))
14055 assert ("storage size not known" == NULL);
14059 if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
14060 && (DECL_SIZE (decl) != 0)
14061 && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
14063 assert ("storage size not constant" == NULL);
14068 /* Output the assembler code and/or RTL code for variables and functions,
14069 unless the type is an undefined structure or union. If not, it will get
14070 done when the type is completed. */
14072 if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
14074 rest_of_decl_compilation (decl, NULL,
14075 DECL_CONTEXT (decl) == 0,
14078 if (DECL_CONTEXT (decl) != 0)
14080 /* Recompute the RTL of a local array now if it used to be an
14081 incomplete type. */
14083 && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
14085 /* If we used it already as memory, it must stay in memory. */
14086 TREE_ADDRESSABLE (decl) = TREE_USED (decl);
14087 /* If it's still incomplete now, no init will save it. */
14088 if (DECL_SIZE (decl) == 0)
14089 DECL_INITIAL (decl) = 0;
14090 expand_decl (decl);
14092 /* Compute and store the initial value. */
14093 if (TREE_CODE (decl) != FUNCTION_DECL)
14094 expand_decl_init (decl);
14097 else if (TREE_CODE (decl) == TYPE_DECL)
14099 rest_of_decl_compilation (decl, NULL_PTR,
14100 DECL_CONTEXT (decl) == 0,
14104 if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
14106 /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
14108 && TREE_CODE (decl) != PARM_DECL)
14110 /* We need to remember that this array HAD an initialization, but
14111 discard the actual temporary nodes, since we can't have a permanent
14112 node keep pointing to them. */
14113 /* We make an exception for inline functions, since it's normal for a
14114 local extern redeclaration of an inline function to have a copy of
14115 the top-level decl's DECL_INLINE. */
14116 if ((DECL_INITIAL (decl) != 0)
14117 && (DECL_INITIAL (decl) != error_mark_node))
14119 /* If this is a const variable, then preserve the
14120 initializer instead of discarding it so that we can optimize
14121 references to it. */
14122 /* This test used to include TREE_STATIC, but this won't be set
14123 for function level initializers. */
14124 if (TREE_READONLY (decl))
14126 preserve_initializer ();
14128 /* The initializer and DECL must have the same (or equivalent
14129 types), but if the initializer is a STRING_CST, its type
14130 might not be on the right obstack, so copy the type
14132 TREE_TYPE (DECL_INITIAL (decl)) = type;
14135 DECL_INITIAL (decl) = error_mark_node;
14139 /* If we have gone back from temporary to permanent allocation, actually
14140 free the temporary space that we no longer need. */
14141 if (temporary && !allocation_temporary_p ())
14142 permanent_allocation (0);
14144 /* At the end of a declaration, throw away any variable type sizes of types
14145 defined inside that declaration. There is no use computing them in the
14146 following function definition. */
14147 if (current_binding_level == global_binding_level)
14148 get_pending_sizes ();
14151 /* Finish up a function declaration and compile that function
14152 all the way to assembler language output. The free the storage
14153 for the function definition.
14155 This is called after parsing the body of the function definition.
14157 NESTED is nonzero if the function being finished is nested in another. */
14160 finish_function (int nested)
14162 register tree fndecl = current_function_decl;
14164 assert (fndecl != NULL_TREE);
14165 if (TREE_CODE (fndecl) != ERROR_MARK)
14168 assert (DECL_CONTEXT (fndecl) != NULL_TREE);
14170 assert (DECL_CONTEXT (fndecl) == NULL_TREE);
14173 /* TREE_READONLY (fndecl) = 1;
14174 This caused &foo to be of type ptr-to-const-function
14175 which then got a warning when stored in a ptr-to-function variable. */
14177 poplevel (1, 0, 1);
14179 if (TREE_CODE (fndecl) != ERROR_MARK)
14181 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
14183 /* Must mark the RESULT_DECL as being in this function. */
14185 DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
14187 /* Obey `register' declarations if `setjmp' is called in this fn. */
14188 /* Generate rtl for function exit. */
14189 expand_function_end (input_filename, lineno, 0);
14191 /* So we can tell if jump_optimize sets it to 1. */
14194 /* If this is a nested function, protect the local variables in the stack
14195 above us from being collected while we're compiling this function. */
14196 if (ggc_p && nested)
14197 ggc_push_context ();
14199 /* Run the optimizers and output the assembler code for this function. */
14200 rest_of_compilation (fndecl);
14202 /* Undo the GC context switch. */
14203 if (ggc_p && nested)
14204 ggc_pop_context ();
14207 /* Free all the tree nodes making up this function. */
14208 /* Switch back to allocating nodes permanently until we start another
14211 permanent_allocation (1);
14213 if (TREE_CODE (fndecl) != ERROR_MARK
14215 && DECL_SAVED_INSNS (fndecl) == 0)
14217 /* Stop pointing to the local nodes about to be freed. */
14218 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14219 function definition. */
14220 /* For a nested function, this is done in pop_f_function_context. */
14221 /* If rest_of_compilation set this to 0, leave it 0. */
14222 if (DECL_INITIAL (fndecl) != 0)
14223 DECL_INITIAL (fndecl) = error_mark_node;
14224 DECL_ARGUMENTS (fndecl) = 0;
14229 /* Let the error reporting routines know that we're outside a function.
14230 For a nested function, this value is used in pop_c_function_context
14231 and then reset via pop_function_context. */
14232 ffecom_outer_function_decl_ = current_function_decl = NULL;
14236 /* Plug-in replacement for identifying the name of a decl and, for a
14237 function, what we call it in diagnostics. For now, "program unit"
14238 should suffice, since it's a bit of a hassle to figure out which
14239 of several kinds of things it is. Note that it could conceivably
14240 be a statement function, which probably isn't really a program unit
14241 per se, but if that comes up, it should be easy to check (being a
14242 nested function and all). */
14244 static const char *
14245 lang_printable_name (tree decl, int v)
14247 /* Just to keep GCC quiet about the unused variable.
14248 In theory, differing values of V should produce different
14253 if (TREE_CODE (decl) == ERROR_MARK)
14254 return "erroneous code";
14255 return IDENTIFIER_POINTER (DECL_NAME (decl));
14259 /* g77's function to print out name of current function that caused
14264 lang_print_error_function (const char *file)
14266 static ffeglobal last_g = NULL;
14267 static ffesymbol last_s = NULL;
14272 if ((ffecom_primary_entry_ == NULL)
14273 || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14281 g = ffesymbol_global (ffecom_primary_entry_);
14282 if (ffecom_nested_entry_ == NULL)
14284 s = ffecom_primary_entry_;
14285 switch (ffesymbol_kind (s))
14287 case FFEINFO_kindFUNCTION:
14291 case FFEINFO_kindSUBROUTINE:
14292 kind = "subroutine";
14295 case FFEINFO_kindPROGRAM:
14299 case FFEINFO_kindBLOCKDATA:
14300 kind = "block-data";
14304 kind = ffeinfo_kind_message (ffesymbol_kind (s));
14310 s = ffecom_nested_entry_;
14311 kind = "statement function";
14315 if ((last_g != g) || (last_s != s))
14318 fprintf (stderr, "%s: ", file);
14321 fprintf (stderr, "Outside of any program unit:\n");
14324 const char *name = ffesymbol_text (s);
14326 fprintf (stderr, "In %s `%s':\n", kind, name);
14335 /* Similar to `lookup_name' but look only at current binding level. */
14338 lookup_name_current_level (tree name)
14342 if (current_binding_level == global_binding_level)
14343 return IDENTIFIER_GLOBAL_VALUE (name);
14345 if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14348 for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14349 if (DECL_NAME (t) == name)
14355 /* Create a new `struct binding_level'. */
14357 static struct binding_level *
14358 make_binding_level ()
14361 return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14364 /* Save and restore the variables in this file and elsewhere
14365 that keep track of the progress of compilation of the current function.
14366 Used for nested functions. */
14370 struct f_function *next;
14372 tree shadowed_labels;
14373 struct binding_level *binding_level;
14376 struct f_function *f_function_chain;
14378 /* Restore the variables used during compilation of a C function. */
14381 pop_f_function_context ()
14383 struct f_function *p = f_function_chain;
14386 /* Bring back all the labels that were shadowed. */
14387 for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14388 if (DECL_NAME (TREE_VALUE (link)) != 0)
14389 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14390 = TREE_VALUE (link);
14392 if (current_function_decl != error_mark_node
14393 && DECL_SAVED_INSNS (current_function_decl) == 0)
14395 /* Stop pointing to the local nodes about to be freed. */
14396 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14397 function definition. */
14398 DECL_INITIAL (current_function_decl) = error_mark_node;
14399 DECL_ARGUMENTS (current_function_decl) = 0;
14402 pop_function_context ();
14404 f_function_chain = p->next;
14406 named_labels = p->named_labels;
14407 shadowed_labels = p->shadowed_labels;
14408 current_binding_level = p->binding_level;
14413 /* Save and reinitialize the variables
14414 used during compilation of a C function. */
14417 push_f_function_context ()
14419 struct f_function *p
14420 = (struct f_function *) xmalloc (sizeof (struct f_function));
14422 push_function_context ();
14424 p->next = f_function_chain;
14425 f_function_chain = p;
14427 p->named_labels = named_labels;
14428 p->shadowed_labels = shadowed_labels;
14429 p->binding_level = current_binding_level;
14433 push_parm_decl (tree parm)
14435 int old_immediate_size_expand = immediate_size_expand;
14437 /* Don't try computing parm sizes now -- wait till fn is called. */
14439 immediate_size_expand = 0;
14441 push_obstacks_nochange ();
14443 /* Fill in arg stuff. */
14445 DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14446 DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14447 TREE_READONLY (parm) = 1; /* All implementation args are read-only. */
14449 parm = pushdecl (parm);
14451 immediate_size_expand = old_immediate_size_expand;
14453 finish_decl (parm, NULL_TREE, FALSE);
14456 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
14459 pushdecl_top_level (x)
14463 register struct binding_level *b = current_binding_level;
14464 register tree f = current_function_decl;
14466 current_binding_level = global_binding_level;
14467 current_function_decl = NULL_TREE;
14469 current_binding_level = b;
14470 current_function_decl = f;
14474 /* Store the list of declarations of the current level.
14475 This is done for the parameter declarations of a function being defined,
14476 after they are modified in the light of any missing parameters. */
14482 return current_binding_level->names = decls;
14485 /* Store the parameter declarations into the current function declaration.
14486 This is called after parsing the parameter declarations, before
14487 digesting the body of the function.
14489 For an old-style definition, modify the function's type
14490 to specify at least the number of arguments. */
14493 store_parm_decls (int is_main_program UNUSED)
14495 register tree fndecl = current_function_decl;
14497 if (fndecl == error_mark_node)
14500 /* This is a chain of PARM_DECLs from old-style parm declarations. */
14501 DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14503 /* Initialize the RTL code for the function. */
14505 init_function_start (fndecl, input_filename, lineno);
14507 /* Set up parameters and prepare for return, for the function. */
14509 expand_function_start (fndecl, 0);
14513 start_decl (tree decl, bool is_top_level)
14516 bool at_top_level = (current_binding_level == global_binding_level);
14517 bool top_level = is_top_level || at_top_level;
14519 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14521 assert (!is_top_level || !at_top_level);
14523 /* The corresponding pop_obstacks is in finish_decl. */
14524 push_obstacks_nochange ();
14526 if (DECL_INITIAL (decl) != NULL_TREE)
14528 assert (DECL_INITIAL (decl) == error_mark_node);
14529 assert (!DECL_EXTERNAL (decl));
14531 else if (top_level)
14532 assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14534 /* For Fortran, we by default put things in .common when possible. */
14535 DECL_COMMON (decl) = 1;
14537 /* Add this decl to the current binding level. TEM may equal DECL or it may
14538 be a previous decl of the same name. */
14540 tem = pushdecl_top_level (decl);
14542 tem = pushdecl (decl);
14544 /* For a local variable, define the RTL now. */
14546 /* But not if this is a duplicate decl and we preserved the rtl from the
14547 previous one (which may or may not happen). */
14548 && DECL_RTL (tem) == 0)
14550 if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14552 else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14553 && DECL_INITIAL (tem) != 0)
14557 if (DECL_INITIAL (tem) != NULL_TREE)
14559 /* When parsing and digesting the initializer, use temporary storage.
14560 Do this even if we will ignore the value. */
14562 temporary_allocation ();
14568 /* Create the FUNCTION_DECL for a function definition.
14569 DECLSPECS and DECLARATOR are the parts of the declaration;
14570 they describe the function's name and the type it returns,
14571 but twisted together in a fashion that parallels the syntax of C.
14573 This function creates a binding context for the function body
14574 as well as setting up the FUNCTION_DECL in current_function_decl.
14576 Returns 1 on success. If the DECLARATOR is not suitable for a function
14577 (it defines a datum instead), we return 0, which tells
14578 yyparse to report a parse error.
14580 NESTED is nonzero for a function nested within another function. */
14583 start_function (tree name, tree type, int nested, int public)
14587 int old_immediate_size_expand = immediate_size_expand;
14590 shadowed_labels = 0;
14592 /* Don't expand any sizes in the return type of the function. */
14593 immediate_size_expand = 0;
14598 assert (current_function_decl != NULL_TREE);
14599 assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14603 assert (current_function_decl == NULL_TREE);
14606 if (TREE_CODE (type) == ERROR_MARK)
14607 decl1 = current_function_decl = error_mark_node;
14610 decl1 = build_decl (FUNCTION_DECL,
14613 TREE_PUBLIC (decl1) = public ? 1 : 0;
14615 DECL_INLINE (decl1) = 1;
14616 TREE_STATIC (decl1) = 1;
14617 DECL_EXTERNAL (decl1) = 0;
14619 announce_function (decl1);
14621 /* Make the init_value nonzero so pushdecl knows this is not tentative.
14622 error_mark_node is replaced below (in poplevel) with the BLOCK. */
14623 DECL_INITIAL (decl1) = error_mark_node;
14625 /* Record the decl so that the function name is defined. If we already have
14626 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
14628 current_function_decl = pushdecl (decl1);
14632 ffecom_outer_function_decl_ = current_function_decl;
14635 current_binding_level->prep_state = 2;
14637 if (TREE_CODE (current_function_decl) != ERROR_MARK)
14639 make_function_rtl (current_function_decl);
14641 restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14642 DECL_RESULT (current_function_decl)
14643 = build_decl (RESULT_DECL, NULL_TREE, restype);
14647 /* Allocate further tree nodes temporarily during compilation of this
14649 temporary_allocation ();
14651 if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14652 TREE_ADDRESSABLE (current_function_decl) = 1;
14654 immediate_size_expand = old_immediate_size_expand;
14657 /* Here are the public functions the GNU back end needs. */
14660 convert (type, expr)
14663 register tree e = expr;
14664 register enum tree_code code = TREE_CODE (type);
14666 if (type == TREE_TYPE (e)
14667 || TREE_CODE (e) == ERROR_MARK)
14669 if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14670 return fold (build1 (NOP_EXPR, type, e));
14671 if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14672 || code == ERROR_MARK)
14673 return error_mark_node;
14674 if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14676 assert ("void value not ignored as it ought to be" == NULL);
14677 return error_mark_node;
14679 if (code == VOID_TYPE)
14680 return build1 (CONVERT_EXPR, type, e);
14681 if ((code != RECORD_TYPE)
14682 && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14683 e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14685 if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14686 return fold (convert_to_integer (type, e));
14687 if (code == POINTER_TYPE)
14688 return fold (convert_to_pointer (type, e));
14689 if (code == REAL_TYPE)
14690 return fold (convert_to_real (type, e));
14691 if (code == COMPLEX_TYPE)
14692 return fold (convert_to_complex (type, e));
14693 if (code == RECORD_TYPE)
14694 return fold (ffecom_convert_to_complex_ (type, e));
14696 assert ("conversion to non-scalar type requested" == NULL);
14697 return error_mark_node;
14700 /* integrate_decl_tree calls this function, but since we don't use the
14701 DECL_LANG_SPECIFIC field, this is a no-op. */
14704 copy_lang_decl (node)
14709 /* Return the list of declarations of the current level.
14710 Note that this list is in reverse order unless/until
14711 you nreverse it; and when you do nreverse it, you must
14712 store the result back using `storedecls' or you will lose. */
14717 return current_binding_level->names;
14720 /* Nonzero if we are currently in the global binding level. */
14723 global_bindings_p ()
14725 return current_binding_level == global_binding_level;
14728 /* Print an error message for invalid use of an incomplete type.
14729 VALUE is the expression that was used (or 0 if that isn't known)
14730 and TYPE is the type that was invalid. */
14733 incomplete_type_error (value, type)
14737 if (TREE_CODE (type) == ERROR_MARK)
14740 assert ("incomplete type?!?" == NULL);
14743 /* Mark ARG for GC. */
14745 mark_binding_level (void *arg)
14747 struct binding_level *level = *(struct binding_level **) arg;
14751 ggc_mark_tree (level->names);
14752 ggc_mark_tree (level->blocks);
14753 ggc_mark_tree (level->this_block);
14754 level = level->level_chain;
14759 init_decl_processing ()
14761 static tree *const tree_roots[] = {
14762 ¤t_function_decl,
14764 &ffecom_tree_fun_type_void,
14765 &ffecom_integer_zero_node,
14766 &ffecom_integer_one_node,
14767 &ffecom_tree_subr_type,
14768 &ffecom_tree_ptr_to_subr_type,
14769 &ffecom_tree_blockdata_type,
14770 &ffecom_tree_xargc_,
14771 &ffecom_f2c_integer_type_node,
14772 &ffecom_f2c_ptr_to_integer_type_node,
14773 &ffecom_f2c_address_type_node,
14774 &ffecom_f2c_real_type_node,
14775 &ffecom_f2c_ptr_to_real_type_node,
14776 &ffecom_f2c_doublereal_type_node,
14777 &ffecom_f2c_complex_type_node,
14778 &ffecom_f2c_doublecomplex_type_node,
14779 &ffecom_f2c_longint_type_node,
14780 &ffecom_f2c_logical_type_node,
14781 &ffecom_f2c_flag_type_node,
14782 &ffecom_f2c_ftnlen_type_node,
14783 &ffecom_f2c_ftnlen_zero_node,
14784 &ffecom_f2c_ftnlen_one_node,
14785 &ffecom_f2c_ftnlen_two_node,
14786 &ffecom_f2c_ptr_to_ftnlen_type_node,
14787 &ffecom_f2c_ftnint_type_node,
14788 &ffecom_f2c_ptr_to_ftnint_type_node,
14789 &ffecom_outer_function_decl_,
14790 &ffecom_previous_function_decl_,
14791 &ffecom_which_entrypoint_decl_,
14792 &ffecom_float_zero_,
14793 &ffecom_float_half_,
14794 &ffecom_double_zero_,
14795 &ffecom_double_half_,
14796 &ffecom_func_result_,
14797 &ffecom_func_length_,
14798 &ffecom_multi_type_node_,
14799 &ffecom_multi_retval_,
14807 /* Record our roots. */
14808 for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14809 ggc_add_tree_root (tree_roots[i], 1);
14810 ggc_add_tree_root (&ffecom_tree_type[0][0],
14811 FFEINFO_basictype*FFEINFO_kindtype);
14812 ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14813 FFEINFO_basictype*FFEINFO_kindtype);
14814 ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14815 FFEINFO_basictype*FFEINFO_kindtype);
14816 ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14817 ggc_add_root (¤t_binding_level, 1, sizeof current_binding_level,
14818 mark_binding_level);
14819 ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14820 mark_binding_level);
14821 ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14827 init_parse (filename)
14828 const char *filename;
14830 /* Open input file. */
14831 if (filename == 0 || !strcmp (filename, "-"))
14834 filename = "stdin";
14837 finput = fopen (filename, "r");
14839 pfatal_with_name (filename);
14841 #ifdef IO_BUFFER_SIZE
14842 setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14845 /* Make identifier nodes long enough for the language-specific slots. */
14846 set_identifier_size (sizeof (struct lang_identifier));
14847 decl_printable_name = lang_printable_name;
14849 print_error_function = lang_print_error_function;
14861 /* Delete the node BLOCK from the current binding level.
14862 This is used for the block inside a stmt expr ({...})
14863 so that the block can be reinserted where appropriate. */
14866 delete_block (block)
14870 if (current_binding_level->blocks == block)
14871 current_binding_level->blocks = TREE_CHAIN (block);
14872 for (t = current_binding_level->blocks; t;)
14874 if (TREE_CHAIN (t) == block)
14875 TREE_CHAIN (t) = TREE_CHAIN (block);
14877 t = TREE_CHAIN (t);
14879 TREE_CHAIN (block) = NULL;
14880 /* Clear TREE_USED which is always set by poplevel.
14881 The flag is set again if insert_block is called. */
14882 TREE_USED (block) = 0;
14886 insert_block (block)
14889 TREE_USED (block) = 1;
14890 current_binding_level->blocks
14891 = chainon (current_binding_level->blocks, block);
14895 lang_decode_option (argc, argv)
14899 return ffe_decode_option (argc, argv);
14902 /* used by print-tree.c */
14905 lang_print_xnode (file, node, indent)
14915 ffe_terminate_0 ();
14917 if (ffe_is_ffedebug ())
14918 malloc_pool_display (malloc_pool_image ());
14927 /* Return the typed-based alias set for T, which may be an expression
14928 or a type. Return -1 if we don't do anything special. */
14931 lang_get_alias_set (t)
14932 tree t ATTRIBUTE_UNUSED;
14934 /* We do not wish to use alias-set based aliasing at all. Used in the
14935 extreme (every object with its own set, with equivalences recorded)
14936 it might be helpful, but there are problems when it comes to inlining.
14937 We get on ok with flag_argument_noalias, and alias-set aliasing does
14938 currently limit how stack slots can be reused, which is a lose. */
14943 lang_init_options ()
14945 /* Set default options for Fortran. */
14946 flag_move_all_movables = 1;
14947 flag_reduce_all_givs = 1;
14948 flag_argument_noalias = 2;
14949 flag_errno_math = 0;
14950 flag_complex_divide_method = 1;
14956 /* If the file is output from cpp, it should contain a first line
14957 `# 1 "real-filename"', and the current design of gcc (toplev.c
14958 in particular and the way it sets up information relied on by
14959 INCLUDE) requires that we read this now, and store the
14960 "real-filename" info in master_input_filename. Ask the lexer
14961 to try doing this. */
14962 ffelex_hash_kludge (finput);
14966 mark_addressable (exp)
14969 register tree x = exp;
14971 switch (TREE_CODE (x))
14974 case COMPONENT_REF:
14976 x = TREE_OPERAND (x, 0);
14980 TREE_ADDRESSABLE (x) = 1;
14987 if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14988 && DECL_NONLOCAL (x))
14990 if (TREE_PUBLIC (x))
14992 assert ("address of global register var requested" == NULL);
14995 assert ("address of register variable requested" == NULL);
14997 else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14999 if (TREE_PUBLIC (x))
15001 assert ("address of global register var requested" == NULL);
15004 assert ("address of register var requested" == NULL);
15006 put_var_into_stack (x);
15009 case FUNCTION_DECL:
15010 TREE_ADDRESSABLE (x) = 1;
15011 #if 0 /* poplevel deals with this now. */
15012 if (DECL_CONTEXT (x) == 0)
15013 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
15021 /* If DECL has a cleanup, build and return that cleanup here.
15022 This is a callback called by expand_expr. */
15025 maybe_build_cleanup (decl)
15028 /* There are no cleanups in Fortran. */
15032 /* Exit a binding level.
15033 Pop the level off, and restore the state of the identifier-decl mappings
15034 that were in effect when this level was entered.
15036 If KEEP is nonzero, this level had explicit declarations, so
15037 and create a "block" (a BLOCK node) for the level
15038 to record its declarations and subblocks for symbol table output.
15040 If FUNCTIONBODY is nonzero, this level is the body of a function,
15041 so create a block as if KEEP were set and also clear out all
15044 If REVERSE is nonzero, reverse the order of decls before putting
15045 them into the BLOCK. */
15048 poplevel (keep, reverse, functionbody)
15053 register tree link;
15054 /* The chain of decls was accumulated in reverse order.
15055 Put it into forward order, just for cleanliness. */
15057 tree subblocks = current_binding_level->blocks;
15060 int block_previously_created;
15062 /* Get the decls in the order they were written.
15063 Usually current_binding_level->names is in reverse order.
15064 But parameter decls were previously put in forward order. */
15067 current_binding_level->names
15068 = decls = nreverse (current_binding_level->names);
15070 decls = current_binding_level->names;
15072 /* Output any nested inline functions within this block
15073 if they weren't already output. */
15075 for (decl = decls; decl; decl = TREE_CHAIN (decl))
15076 if (TREE_CODE (decl) == FUNCTION_DECL
15077 && ! TREE_ASM_WRITTEN (decl)
15078 && DECL_INITIAL (decl) != 0
15079 && TREE_ADDRESSABLE (decl))
15081 /* If this decl was copied from a file-scope decl
15082 on account of a block-scope extern decl,
15083 propagate TREE_ADDRESSABLE to the file-scope decl.
15085 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
15086 true, since then the decl goes through save_for_inline_copying. */
15087 if (DECL_ABSTRACT_ORIGIN (decl) != 0
15088 && DECL_ABSTRACT_ORIGIN (decl) != decl)
15089 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
15090 else if (DECL_SAVED_INSNS (decl) != 0)
15092 push_function_context ();
15093 output_inline_function (decl);
15094 pop_function_context ();
15098 /* If there were any declarations or structure tags in that level,
15099 or if this level is a function body,
15100 create a BLOCK to record them for the life of this function. */
15103 block_previously_created = (current_binding_level->this_block != 0);
15104 if (block_previously_created)
15105 block = current_binding_level->this_block;
15106 else if (keep || functionbody)
15107 block = make_node (BLOCK);
15110 BLOCK_VARS (block) = decls;
15111 BLOCK_SUBBLOCKS (block) = subblocks;
15114 /* In each subblock, record that this is its superior. */
15116 for (link = subblocks; link; link = TREE_CHAIN (link))
15117 BLOCK_SUPERCONTEXT (link) = block;
15119 /* Clear out the meanings of the local variables of this level. */
15121 for (link = decls; link; link = TREE_CHAIN (link))
15123 if (DECL_NAME (link) != 0)
15125 /* If the ident. was used or addressed via a local extern decl,
15126 don't forget that fact. */
15127 if (DECL_EXTERNAL (link))
15129 if (TREE_USED (link))
15130 TREE_USED (DECL_NAME (link)) = 1;
15131 if (TREE_ADDRESSABLE (link))
15132 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
15134 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
15138 /* If the level being exited is the top level of a function,
15139 check over all the labels, and clear out the current
15140 (function local) meanings of their names. */
15144 /* If this is the top level block of a function,
15145 the vars are the function's parameters.
15146 Don't leave them in the BLOCK because they are
15147 found in the FUNCTION_DECL instead. */
15149 BLOCK_VARS (block) = 0;
15152 /* Pop the current level, and free the structure for reuse. */
15155 register struct binding_level *level = current_binding_level;
15156 current_binding_level = current_binding_level->level_chain;
15158 level->level_chain = free_binding_level;
15159 free_binding_level = level;
15162 /* Dispose of the block that we just made inside some higher level. */
15164 && current_function_decl != error_mark_node)
15165 DECL_INITIAL (current_function_decl) = block;
15168 if (!block_previously_created)
15169 current_binding_level->blocks
15170 = chainon (current_binding_level->blocks, block);
15172 /* If we did not make a block for the level just exited,
15173 any blocks made for inner levels
15174 (since they cannot be recorded as subblocks in that level)
15175 must be carried forward so they will later become subblocks
15176 of something else. */
15177 else if (subblocks)
15178 current_binding_level->blocks
15179 = chainon (current_binding_level->blocks, subblocks);
15182 TREE_USED (block) = 1;
15187 print_lang_decl (file, node, indent)
15195 print_lang_identifier (file, node, indent)
15200 print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
15201 print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
15205 print_lang_statistics ()
15210 print_lang_type (file, node, indent)
15217 /* Record a decl-node X as belonging to the current lexical scope.
15218 Check for errors (such as an incompatible declaration for the same
15219 name already seen in the same scope).
15221 Returns either X or an old decl for the same name.
15222 If an old decl is returned, it may have been smashed
15223 to agree with what X says. */
15230 register tree name = DECL_NAME (x);
15231 register struct binding_level *b = current_binding_level;
15233 if ((TREE_CODE (x) == FUNCTION_DECL)
15234 && (DECL_INITIAL (x) == 0)
15235 && DECL_EXTERNAL (x))
15236 DECL_CONTEXT (x) = NULL_TREE;
15238 DECL_CONTEXT (x) = current_function_decl;
15242 if (IDENTIFIER_INVENTED (name))
15245 DECL_ARTIFICIAL (x) = 1;
15247 DECL_IN_SYSTEM_HEADER (x) = 1;
15250 t = lookup_name_current_level (name);
15252 assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
15254 /* Don't push non-parms onto list for parms until we understand
15255 why we're doing this and whether it works. */
15257 assert ((b == global_binding_level)
15258 || !ffecom_transform_only_dummies_
15259 || TREE_CODE (x) == PARM_DECL);
15261 if ((t != NULL_TREE) && duplicate_decls (x, t))
15264 /* If we are processing a typedef statement, generate a whole new
15265 ..._TYPE node (which will be just an variant of the existing
15266 ..._TYPE node with identical properties) and then install the
15267 TYPE_DECL node generated to represent the typedef name as the
15268 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15270 The whole point here is to end up with a situation where each and every
15271 ..._TYPE node the compiler creates will be uniquely associated with
15272 AT MOST one node representing a typedef name. This way, even though
15273 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15274 (i.e. "typedef name") nodes very early on, later parts of the
15275 compiler can always do the reverse translation and get back the
15276 corresponding typedef name. For example, given:
15278 typedef struct S MY_TYPE; MY_TYPE object;
15280 Later parts of the compiler might only know that `object' was of type
15281 `struct S' if it were not for code just below. With this code
15282 however, later parts of the compiler see something like:
15284 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15286 And they can then deduce (from the node for type struct S') that the
15287 original object declaration was:
15291 Being able to do this is important for proper support of protoize, and
15292 also for generating precise symbolic debugging information which
15293 takes full account of the programmer's (typedef) vocabulary.
15295 Obviously, we don't want to generate a duplicate ..._TYPE node if the
15296 TYPE_DECL node that we are now processing really represents a
15297 standard built-in type.
15299 Since all standard types are effectively declared at line zero in the
15300 source file, we can easily check to see if we are working on a
15301 standard type by checking the current value of lineno. */
15303 if (TREE_CODE (x) == TYPE_DECL)
15305 if (DECL_SOURCE_LINE (x) == 0)
15307 if (TYPE_NAME (TREE_TYPE (x)) == 0)
15308 TYPE_NAME (TREE_TYPE (x)) = x;
15310 else if (TREE_TYPE (x) != error_mark_node)
15312 tree tt = TREE_TYPE (x);
15314 tt = build_type_copy (tt);
15315 TYPE_NAME (tt) = x;
15316 TREE_TYPE (x) = tt;
15320 /* This name is new in its binding level. Install the new declaration
15322 if (b == global_binding_level)
15323 IDENTIFIER_GLOBAL_VALUE (name) = x;
15325 IDENTIFIER_LOCAL_VALUE (name) = x;
15328 /* Put decls on list in reverse order. We will reverse them later if
15330 TREE_CHAIN (x) = b->names;
15336 /* Nonzero if the current level needs to have a BLOCK made. */
15343 for (decl = current_binding_level->names;
15345 decl = TREE_CHAIN (decl))
15347 if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15348 || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15349 /* Currently, there aren't supposed to be non-artificial names
15350 at other than the top block for a function -- they're
15351 believed to always be temps. But it's wise to check anyway. */
15357 /* Enter a new binding level.
15358 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15359 not for that of tags. */
15362 pushlevel (tag_transparent)
15363 int tag_transparent;
15365 register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15367 assert (! tag_transparent);
15369 if (current_binding_level == global_binding_level)
15374 /* Reuse or create a struct for this binding level. */
15376 if (free_binding_level)
15378 newlevel = free_binding_level;
15379 free_binding_level = free_binding_level->level_chain;
15383 newlevel = make_binding_level ();
15386 /* Add this level to the front of the chain (stack) of levels that
15389 *newlevel = clear_binding_level;
15390 newlevel->level_chain = current_binding_level;
15391 current_binding_level = newlevel;
15394 /* Set the BLOCK node for the innermost scope
15395 (the one we are currently in). */
15399 register tree block;
15401 current_binding_level->this_block = block;
15404 /* ~~gcc/tree.h *should* declare this, because toplev.c references it. */
15406 /* Can't 'yydebug' a front end not generated by yacc/bison! */
15409 set_yydebug (value)
15413 fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15417 signed_or_unsigned_type (unsignedp, type)
15423 if (! INTEGRAL_TYPE_P (type))
15425 if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15426 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15427 if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15428 return unsignedp ? unsigned_type_node : integer_type_node;
15429 if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15430 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15431 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15432 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15433 if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15434 return (unsignedp ? long_long_unsigned_type_node
15435 : long_long_integer_type_node);
15437 type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15438 if (type2 == NULL_TREE)
15448 tree type1 = TYPE_MAIN_VARIANT (type);
15449 ffeinfoKindtype kt;
15452 if (type1 == unsigned_char_type_node || type1 == char_type_node)
15453 return signed_char_type_node;
15454 if (type1 == unsigned_type_node)
15455 return integer_type_node;
15456 if (type1 == short_unsigned_type_node)
15457 return short_integer_type_node;
15458 if (type1 == long_unsigned_type_node)
15459 return long_integer_type_node;
15460 if (type1 == long_long_unsigned_type_node)
15461 return long_long_integer_type_node;
15462 #if 0 /* gcc/c-* files only */
15463 if (type1 == unsigned_intDI_type_node)
15464 return intDI_type_node;
15465 if (type1 == unsigned_intSI_type_node)
15466 return intSI_type_node;
15467 if (type1 == unsigned_intHI_type_node)
15468 return intHI_type_node;
15469 if (type1 == unsigned_intQI_type_node)
15470 return intQI_type_node;
15473 type2 = type_for_size (TYPE_PRECISION (type1), 0);
15474 if (type2 != NULL_TREE)
15477 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15479 type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15481 if (type1 == type2)
15482 return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15488 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15489 or validate its data type for an `if' or `while' statement or ?..: exp.
15491 This preparation consists of taking the ordinary
15492 representation of an expression expr and producing a valid tree
15493 boolean expression describing whether expr is nonzero. We could
15494 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15495 but we optimize comparisons, &&, ||, and !.
15497 The resulting type should always be `integer_type_node'. */
15500 truthvalue_conversion (expr)
15503 if (TREE_CODE (expr) == ERROR_MARK)
15506 #if 0 /* This appears to be wrong for C++. */
15507 /* These really should return error_mark_node after 2.4 is stable.
15508 But not all callers handle ERROR_MARK properly. */
15509 switch (TREE_CODE (TREE_TYPE (expr)))
15512 error ("struct type value used where scalar is required");
15513 return integer_zero_node;
15516 error ("union type value used where scalar is required");
15517 return integer_zero_node;
15520 error ("array type value used where scalar is required");
15521 return integer_zero_node;
15528 switch (TREE_CODE (expr))
15530 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15531 or comparison expressions as truth values at this level. */
15533 case COMPONENT_REF:
15534 /* A one-bit unsigned bit-field is already acceptable. */
15535 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15536 && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15542 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15543 or comparison expressions as truth values at this level. */
15545 if (integer_zerop (TREE_OPERAND (expr, 1)))
15546 return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15548 case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15549 case TRUTH_ANDIF_EXPR:
15550 case TRUTH_ORIF_EXPR:
15551 case TRUTH_AND_EXPR:
15552 case TRUTH_OR_EXPR:
15553 case TRUTH_XOR_EXPR:
15554 TREE_TYPE (expr) = integer_type_node;
15561 return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15564 return real_zerop (expr) ? integer_zero_node : integer_one_node;
15567 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15568 return build (COMPOUND_EXPR, integer_type_node,
15569 TREE_OPERAND (expr, 0), integer_one_node);
15571 return integer_one_node;
15574 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15575 ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15577 truthvalue_conversion (TREE_OPERAND (expr, 0)),
15578 truthvalue_conversion (TREE_OPERAND (expr, 1)));
15584 /* These don't change whether an object is non-zero or zero. */
15585 return truthvalue_conversion (TREE_OPERAND (expr, 0));
15589 /* These don't change whether an object is zero or non-zero, but
15590 we can't ignore them if their second arg has side-effects. */
15591 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15592 return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15593 truthvalue_conversion (TREE_OPERAND (expr, 0)));
15595 return truthvalue_conversion (TREE_OPERAND (expr, 0));
15598 /* Distribute the conversion into the arms of a COND_EXPR. */
15599 return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15600 truthvalue_conversion (TREE_OPERAND (expr, 1)),
15601 truthvalue_conversion (TREE_OPERAND (expr, 2))));
15604 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15605 since that affects how `default_conversion' will behave. */
15606 if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15607 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15609 /* fall through... */
15611 /* If this is widening the argument, we can ignore it. */
15612 if (TYPE_PRECISION (TREE_TYPE (expr))
15613 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15614 return truthvalue_conversion (TREE_OPERAND (expr, 0));
15618 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15620 if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15621 && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15623 /* fall through... */
15625 /* This and MINUS_EXPR can be changed into a comparison of the
15627 if (TREE_TYPE (TREE_OPERAND (expr, 0))
15628 == TREE_TYPE (TREE_OPERAND (expr, 1)))
15629 return ffecom_2 (NE_EXPR, integer_type_node,
15630 TREE_OPERAND (expr, 0),
15631 TREE_OPERAND (expr, 1));
15632 return ffecom_2 (NE_EXPR, integer_type_node,
15633 TREE_OPERAND (expr, 0),
15634 fold (build1 (NOP_EXPR,
15635 TREE_TYPE (TREE_OPERAND (expr, 0)),
15636 TREE_OPERAND (expr, 1))));
15639 if (integer_onep (TREE_OPERAND (expr, 1)))
15644 #if 0 /* No such thing in Fortran. */
15645 if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15646 warning ("suggest parentheses around assignment used as truth value");
15654 if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15656 ((TREE_SIDE_EFFECTS (expr)
15657 ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15659 truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15660 TREE_TYPE (TREE_TYPE (expr)),
15662 truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15663 TREE_TYPE (TREE_TYPE (expr)),
15666 return ffecom_2 (NE_EXPR, integer_type_node,
15668 convert (TREE_TYPE (expr), integer_zero_node));
15672 type_for_mode (mode, unsignedp)
15673 enum machine_mode mode;
15680 if (mode == TYPE_MODE (integer_type_node))
15681 return unsignedp ? unsigned_type_node : integer_type_node;
15683 if (mode == TYPE_MODE (signed_char_type_node))
15684 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15686 if (mode == TYPE_MODE (short_integer_type_node))
15687 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15689 if (mode == TYPE_MODE (long_integer_type_node))
15690 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15692 if (mode == TYPE_MODE (long_long_integer_type_node))
15693 return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15695 #if HOST_BITS_PER_WIDE_INT >= 64
15696 if (mode == TYPE_MODE (intTI_type_node))
15697 return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15700 if (mode == TYPE_MODE (float_type_node))
15701 return float_type_node;
15703 if (mode == TYPE_MODE (double_type_node))
15704 return double_type_node;
15706 if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15707 return build_pointer_type (char_type_node);
15709 if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15710 return build_pointer_type (integer_type_node);
15712 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15713 for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15715 if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15716 && (mode == TYPE_MODE (t)))
15718 if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15719 return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15729 type_for_size (bits, unsignedp)
15733 ffeinfoKindtype kt;
15736 if (bits == TYPE_PRECISION (integer_type_node))
15737 return unsignedp ? unsigned_type_node : integer_type_node;
15739 if (bits == TYPE_PRECISION (signed_char_type_node))
15740 return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15742 if (bits == TYPE_PRECISION (short_integer_type_node))
15743 return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15745 if (bits == TYPE_PRECISION (long_integer_type_node))
15746 return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15748 if (bits == TYPE_PRECISION (long_long_integer_type_node))
15749 return (unsignedp ? long_long_unsigned_type_node
15750 : long_long_integer_type_node);
15752 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15754 type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15756 if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15757 return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15765 unsigned_type (type)
15768 tree type1 = TYPE_MAIN_VARIANT (type);
15769 ffeinfoKindtype kt;
15772 if (type1 == signed_char_type_node || type1 == char_type_node)
15773 return unsigned_char_type_node;
15774 if (type1 == integer_type_node)
15775 return unsigned_type_node;
15776 if (type1 == short_integer_type_node)
15777 return short_unsigned_type_node;
15778 if (type1 == long_integer_type_node)
15779 return long_unsigned_type_node;
15780 if (type1 == long_long_integer_type_node)
15781 return long_long_unsigned_type_node;
15782 #if 0 /* gcc/c-* files only */
15783 if (type1 == intDI_type_node)
15784 return unsigned_intDI_type_node;
15785 if (type1 == intSI_type_node)
15786 return unsigned_intSI_type_node;
15787 if (type1 == intHI_type_node)
15788 return unsigned_intHI_type_node;
15789 if (type1 == intQI_type_node)
15790 return unsigned_intQI_type_node;
15793 type2 = type_for_size (TYPE_PRECISION (type1), 1);
15794 if (type2 != NULL_TREE)
15797 for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15799 type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15801 if (type1 == type2)
15802 return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15808 /* Callback routines for garbage collection. */
15814 union tree_node *t ATTRIBUTE_UNUSED;
15816 if (TREE_CODE (t) == IDENTIFIER_NODE)
15818 struct lang_identifier *i = (struct lang_identifier *) t;
15819 ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15820 ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15821 ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15823 else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15824 ggc_mark (TYPE_LANG_SPECIFIC (t));
15828 lang_mark_false_label_stack (l)
15829 struct label_node *l;
15831 /* Fortran doesn't use false_label_stack. It better be NULL. */
15836 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15838 #if FFECOM_GCC_INCLUDE
15840 /* From gcc/cccp.c, the code to handle -I. */
15842 /* Skip leading "./" from a directory name.
15843 This may yield the empty string, which represents the current directory. */
15845 static const char *
15846 skip_redundant_dir_prefix (const char *dir)
15848 while (dir[0] == '.' && dir[1] == '/')
15849 for (dir += 2; *dir == '/'; dir++)
15851 if (dir[0] == '.' && !dir[1])
15856 /* The file_name_map structure holds a mapping of file names for a
15857 particular directory. This mapping is read from the file named
15858 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15859 map filenames on a file system with severe filename restrictions,
15860 such as DOS. The format of the file name map file is just a series
15861 of lines with two tokens on each line. The first token is the name
15862 to map, and the second token is the actual name to use. */
15864 struct file_name_map
15866 struct file_name_map *map_next;
15871 #define FILE_NAME_MAP_FILE "header.gcc"
15873 /* Current maximum length of directory names in the search path
15874 for include files. (Altered as we get more of them.) */
15876 static int max_include_len = 0;
15878 struct file_name_list
15880 struct file_name_list *next;
15882 /* Mapping of file names for this directory. */
15883 struct file_name_map *name_map;
15884 /* Non-zero if name_map is valid. */
15888 static struct file_name_list *include = NULL; /* First dir to search */
15889 static struct file_name_list *last_include = NULL; /* Last in chain */
15891 /* I/O buffer structure.
15892 The `fname' field is nonzero for source files and #include files
15893 and for the dummy text used for -D and -U.
15894 It is zero for rescanning results of macro expansion
15895 and for expanding macro arguments. */
15896 #define INPUT_STACK_MAX 400
15897 static struct file_buf {
15899 /* Filename specified with #line command. */
15900 const char *nominal_fname;
15901 /* Record where in the search path this file was found.
15902 For #include_next. */
15903 struct file_name_list *dir;
15905 ffewhereColumn column;
15906 } instack[INPUT_STACK_MAX];
15908 static int last_error_tick = 0; /* Incremented each time we print it. */
15909 static int input_file_stack_tick = 0; /* Incremented when status changes. */
15911 /* Current nesting level of input sources.
15912 `instack[indepth]' is the level currently being read. */
15913 static int indepth = -1;
15915 typedef struct file_buf FILE_BUF;
15917 typedef unsigned char U_CHAR;
15919 /* table to tell if char can be part of a C identifier. */
15920 U_CHAR is_idchar[256];
15921 /* table to tell if char can be first char of a c identifier. */
15922 U_CHAR is_idstart[256];
15923 /* table to tell if c is horizontal space. */
15924 U_CHAR is_hor_space[256];
15925 /* table to tell if c is horizontal or vertical space. */
15926 static U_CHAR is_space[256];
15928 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15929 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15931 /* Nonzero means -I- has been seen,
15932 so don't look for #include "foo" the source-file directory. */
15933 static int ignore_srcdir;
15935 #ifndef INCLUDE_LEN_FUDGE
15936 #define INCLUDE_LEN_FUDGE 0
15939 static void append_include_chain (struct file_name_list *first,
15940 struct file_name_list *last);
15941 static FILE *open_include_file (char *filename,
15942 struct file_name_list *searchptr);
15943 static void print_containing_files (ffebadSeverity sev);
15944 static const char *skip_redundant_dir_prefix (const char *);
15945 static char *read_filename_string (int ch, FILE *f);
15946 static struct file_name_map *read_name_map (const char *dirname);
15948 /* Append a chain of `struct file_name_list's
15949 to the end of the main include chain.
15950 FIRST is the beginning of the chain to append, and LAST is the end. */
15953 append_include_chain (first, last)
15954 struct file_name_list *first, *last;
15956 struct file_name_list *dir;
15958 if (!first || !last)
15964 last_include->next = first;
15966 for (dir = first; ; dir = dir->next) {
15967 int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15968 if (len > max_include_len)
15969 max_include_len = len;
15975 last_include = last;
15978 /* Try to open include file FILENAME. SEARCHPTR is the directory
15979 being tried from the include file search path. This function maps
15980 filenames on file systems based on information read by
15984 open_include_file (filename, searchptr)
15986 struct file_name_list *searchptr;
15988 register struct file_name_map *map;
15989 register char *from;
15992 if (searchptr && ! searchptr->got_name_map)
15994 searchptr->name_map = read_name_map (searchptr->fname
15995 ? searchptr->fname : ".");
15996 searchptr->got_name_map = 1;
15999 /* First check the mapping for the directory we are using. */
16000 if (searchptr && searchptr->name_map)
16003 if (searchptr->fname)
16004 from += strlen (searchptr->fname) + 1;
16005 for (map = searchptr->name_map; map; map = map->map_next)
16007 if (! strcmp (map->map_from, from))
16009 /* Found a match. */
16010 return fopen (map->map_to, "r");
16015 /* Try to find a mapping file for the particular directory we are
16016 looking in. Thus #include <sys/types.h> will look up sys/types.h
16017 in /usr/include/header.gcc and look up types.h in
16018 /usr/include/sys/header.gcc. */
16019 p = rindex (filename, '/');
16020 #ifdef DIR_SEPARATOR
16021 if (! p) p = rindex (filename, DIR_SEPARATOR);
16023 char *tmp = rindex (filename, DIR_SEPARATOR);
16024 if (tmp != NULL && tmp > p) p = tmp;
16030 && searchptr->fname
16031 && strlen (searchptr->fname) == (size_t) (p - filename)
16032 && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
16034 /* FILENAME is in SEARCHPTR, which we've already checked. */
16035 return fopen (filename, "r");
16041 map = read_name_map (".");
16045 dir = (char *) xmalloc (p - filename + 1);
16046 memcpy (dir, filename, p - filename);
16047 dir[p - filename] = '\0';
16049 map = read_name_map (dir);
16052 for (; map; map = map->map_next)
16053 if (! strcmp (map->map_from, from))
16054 return fopen (map->map_to, "r");
16056 return fopen (filename, "r");
16059 /* Print the file names and line numbers of the #include
16060 commands which led to the current file. */
16063 print_containing_files (ffebadSeverity sev)
16065 FILE_BUF *ip = NULL;
16071 /* If stack of files hasn't changed since we last printed
16072 this info, don't repeat it. */
16073 if (last_error_tick == input_file_stack_tick)
16076 for (i = indepth; i >= 0; i--)
16077 if (instack[i].fname != NULL) {
16082 /* Give up if we don't find a source file. */
16086 /* Find the other, outer source files. */
16087 for (i--; i >= 0; i--)
16088 if (instack[i].fname != NULL)
16094 str1 = "In file included";
16106 ffebad_start_msg ("%A from %B at %0%C", sev);
16107 ffebad_here (0, ip->line, ip->column);
16108 ffebad_string (str1);
16109 ffebad_string (ip->nominal_fname);
16110 ffebad_string (str2);
16114 /* Record we have printed the status as of this time. */
16115 last_error_tick = input_file_stack_tick;
16118 /* Read a space delimited string of unlimited length from a stdio
16122 read_filename_string (ch, f)
16130 set = alloc = xmalloc (len + 1);
16131 if (! is_space[ch])
16134 while ((ch = getc (f)) != EOF && ! is_space[ch])
16136 if (set - alloc == len)
16139 alloc = xrealloc (alloc, len + 1);
16140 set = alloc + len / 2;
16150 /* Read the file name map file for DIRNAME. */
16152 static struct file_name_map *
16153 read_name_map (dirname)
16154 const char *dirname;
16156 /* This structure holds a linked list of file name maps, one per
16158 struct file_name_map_list
16160 struct file_name_map_list *map_list_next;
16161 char *map_list_name;
16162 struct file_name_map *map_list_map;
16164 static struct file_name_map_list *map_list;
16165 register struct file_name_map_list *map_list_ptr;
16169 int separator_needed;
16171 dirname = skip_redundant_dir_prefix (dirname);
16173 for (map_list_ptr = map_list; map_list_ptr;
16174 map_list_ptr = map_list_ptr->map_list_next)
16175 if (! strcmp (map_list_ptr->map_list_name, dirname))
16176 return map_list_ptr->map_list_map;
16178 map_list_ptr = ((struct file_name_map_list *)
16179 xmalloc (sizeof (struct file_name_map_list)));
16180 map_list_ptr->map_list_name = xstrdup (dirname);
16181 map_list_ptr->map_list_map = NULL;
16183 dirlen = strlen (dirname);
16184 separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
16185 name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
16186 strcpy (name, dirname);
16187 name[dirlen] = '/';
16188 strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
16189 f = fopen (name, "r");
16192 map_list_ptr->map_list_map = NULL;
16197 while ((ch = getc (f)) != EOF)
16200 struct file_name_map *ptr;
16204 from = read_filename_string (ch, f);
16205 while ((ch = getc (f)) != EOF && is_hor_space[ch])
16207 to = read_filename_string (ch, f);
16209 ptr = ((struct file_name_map *)
16210 xmalloc (sizeof (struct file_name_map)));
16211 ptr->map_from = from;
16213 /* Make the real filename absolute. */
16218 ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
16219 strcpy (ptr->map_to, dirname);
16220 ptr->map_to[dirlen] = '/';
16221 strcpy (ptr->map_to + dirlen + separator_needed, to);
16225 ptr->map_next = map_list_ptr->map_list_map;
16226 map_list_ptr->map_list_map = ptr;
16228 while ((ch = getc (f)) != '\n')
16235 map_list_ptr->map_list_next = map_list;
16236 map_list = map_list_ptr;
16238 return map_list_ptr->map_list_map;
16242 ffecom_file_ (const char *name)
16246 /* Do partial setup of input buffer for the sake of generating
16247 early #line directives (when -g is in effect). */
16249 fp = &instack[++indepth];
16250 memset ((char *) fp, 0, sizeof (FILE_BUF));
16253 fp->nominal_fname = fp->fname = name;
16256 /* Initialize syntactic classifications of characters. */
16259 ffecom_initialize_char_syntax_ ()
16264 * Set up is_idchar and is_idstart tables. These should be
16265 * faster than saying (is_alpha (c) || c == '_'), etc.
16266 * Set up these things before calling any routines tthat
16269 for (i = 'a'; i <= 'z'; i++) {
16270 is_idchar[i - 'a' + 'A'] = 1;
16272 is_idstart[i - 'a' + 'A'] = 1;
16275 for (i = '0'; i <= '9'; i++)
16277 is_idchar['_'] = 1;
16278 is_idstart['_'] = 1;
16280 /* horizontal space table */
16281 is_hor_space[' '] = 1;
16282 is_hor_space['\t'] = 1;
16283 is_hor_space['\v'] = 1;
16284 is_hor_space['\f'] = 1;
16285 is_hor_space['\r'] = 1;
16288 is_space['\t'] = 1;
16289 is_space['\v'] = 1;
16290 is_space['\f'] = 1;
16291 is_space['\n'] = 1;
16292 is_space['\r'] = 1;
16296 ffecom_close_include_ (FILE *f)
16301 input_file_stack_tick++;
16303 ffewhere_line_kill (instack[indepth].line);
16304 ffewhere_column_kill (instack[indepth].column);
16308 ffecom_decode_include_option_ (char *spec)
16310 struct file_name_list *dirtmp;
16312 if (! ignore_srcdir && !strcmp (spec, "-"))
16316 dirtmp = (struct file_name_list *)
16317 xmalloc (sizeof (struct file_name_list));
16318 dirtmp->next = 0; /* New one goes on the end */
16320 dirtmp->fname = spec;
16322 fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16323 dirtmp->got_name_map = 0;
16324 append_include_chain (dirtmp, dirtmp);
16329 /* Open INCLUDEd file. */
16332 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16335 size_t flen = strlen (fbeg);
16336 struct file_name_list *search_start = include; /* Chain of dirs to search */
16337 struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16338 struct file_name_list *searchptr = 0;
16339 char *fname; /* Dynamically allocated fname buffer */
16346 dsp[0].fname = NULL;
16348 /* If -I- was specified, don't search current dir, only spec'd ones. */
16349 if (!ignore_srcdir)
16351 for (fp = &instack[indepth]; fp >= instack; fp--)
16357 if ((nam = fp->nominal_fname) != NULL)
16359 /* Found a named file. Figure out dir of the file,
16360 and put it in front of the search list. */
16361 dsp[0].next = search_start;
16362 search_start = dsp;
16364 ep = rindex (nam, '/');
16365 #ifdef DIR_SEPARATOR
16366 if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR);
16368 char *tmp = rindex (nam, DIR_SEPARATOR);
16369 if (tmp != NULL && tmp > ep) ep = tmp;
16373 ep = rindex (nam, ']');
16374 if (ep == NULL) ep = rindex (nam, '>');
16375 if (ep == NULL) ep = rindex (nam, ':');
16376 if (ep != NULL) ep++;
16381 dsp[0].fname = (char *) xmalloc (n + 1);
16382 strncpy (dsp[0].fname, nam, n);
16383 dsp[0].fname[n] = '\0';
16384 if (n + INCLUDE_LEN_FUDGE > max_include_len)
16385 max_include_len = n + INCLUDE_LEN_FUDGE;
16388 dsp[0].fname = NULL; /* Current directory */
16389 dsp[0].got_name_map = 0;
16395 /* Allocate this permanently, because it gets stored in the definitions
16397 fname = xmalloc (max_include_len + flen + 4);
16398 /* + 2 above for slash and terminating null. */
16399 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16402 /* If specified file name is absolute, just open it. */
16405 #ifdef DIR_SEPARATOR
16406 || *fbeg == DIR_SEPARATOR
16410 strncpy (fname, (char *) fbeg, flen);
16412 f = open_include_file (fname, NULL_PTR);
16418 /* Search directory path, trying to open the file.
16419 Copy each filename tried into FNAME. */
16421 for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16423 if (searchptr->fname)
16425 /* The empty string in a search path is ignored.
16426 This makes it possible to turn off entirely
16427 a standard piece of the list. */
16428 if (searchptr->fname[0] == 0)
16430 strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16431 if (fname[0] && fname[strlen (fname) - 1] != '/')
16432 strcat (fname, "/");
16433 fname[strlen (fname) + flen] = 0;
16438 strncat (fname, fbeg, flen);
16440 /* Change this 1/2 Unix 1/2 VMS file specification into a
16441 full VMS file specification */
16442 if (searchptr->fname && (searchptr->fname[0] != 0))
16444 /* Fix up the filename */
16445 hack_vms_include_specification (fname);
16449 /* This is a normal VMS filespec, so use it unchanged. */
16450 strncpy (fname, (char *) fbeg, flen);
16452 #if 0 /* Not for g77. */
16453 /* if it's '#include filename', add the missing .h */
16454 if (index (fname, '.') == NULL)
16455 strcat (fname, ".h");
16459 f = open_include_file (fname, searchptr);
16461 if (f == NULL && errno == EACCES)
16463 print_containing_files (FFEBAD_severityWARNING);
16464 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16465 FFEBAD_severityWARNING);
16466 ffebad_string (fname);
16467 ffebad_here (0, l, c);
16478 /* A file that was not found. */
16480 strncpy (fname, (char *) fbeg, flen);
16482 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16483 ffebad_start (FFEBAD_OPEN_INCLUDE);
16484 ffebad_here (0, l, c);
16485 ffebad_string (fname);
16489 if (dsp[0].fname != NULL)
16490 free (dsp[0].fname);
16495 if (indepth >= (INPUT_STACK_MAX - 1))
16497 print_containing_files (FFEBAD_severityFATAL);
16498 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16499 FFEBAD_severityFATAL);
16500 ffebad_string (fname);
16501 ffebad_here (0, l, c);
16506 instack[indepth].line = ffewhere_line_use (l);
16507 instack[indepth].column = ffewhere_column_use (c);
16509 fp = &instack[indepth + 1];
16510 memset ((char *) fp, 0, sizeof (FILE_BUF));
16511 fp->nominal_fname = fp->fname = fname;
16512 fp->dir = searchptr;
16515 input_file_stack_tick++;
16519 #endif /* FFECOM_GCC_INCLUDE */
16521 /**INDENT* (Do not reformat this comment even with -fca option.)
16522 Data-gathering files: Given the source file listed below, compiled with
16523 f2c I obtained the output file listed after that, and from the output
16524 file I derived the above code.
16526 -------- (begin input file to f2c)
16532 double precision D1,D2
16534 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16561 c FFEINTRIN_impACOS
16562 call fooR(ACOS(R1))
16563 c FFEINTRIN_impAIMAG
16564 call fooR(AIMAG(C1))
16565 c FFEINTRIN_impAINT
16566 call fooR(AINT(R1))
16567 c FFEINTRIN_impALOG
16568 call fooR(ALOG(R1))
16569 c FFEINTRIN_impALOG10
16570 call fooR(ALOG10(R1))
16571 c FFEINTRIN_impAMAX0
16572 call fooR(AMAX0(I1,I2))
16573 c FFEINTRIN_impAMAX1
16574 call fooR(AMAX1(R1,R2))
16575 c FFEINTRIN_impAMIN0
16576 call fooR(AMIN0(I1,I2))
16577 c FFEINTRIN_impAMIN1
16578 call fooR(AMIN1(R1,R2))
16579 c FFEINTRIN_impAMOD
16580 call fooR(AMOD(R1,R2))
16581 c FFEINTRIN_impANINT
16582 call fooR(ANINT(R1))
16583 c FFEINTRIN_impASIN
16584 call fooR(ASIN(R1))
16585 c FFEINTRIN_impATAN
16586 call fooR(ATAN(R1))
16587 c FFEINTRIN_impATAN2
16588 call fooR(ATAN2(R1,R2))
16589 c FFEINTRIN_impCABS
16590 call fooR(CABS(C1))
16591 c FFEINTRIN_impCCOS
16592 call fooC(CCOS(C1))
16593 c FFEINTRIN_impCEXP
16594 call fooC(CEXP(C1))
16595 c FFEINTRIN_impCHAR
16596 call fooA(CHAR(I1))
16597 c FFEINTRIN_impCLOG
16598 call fooC(CLOG(C1))
16599 c FFEINTRIN_impCONJG
16600 call fooC(CONJG(C1))
16603 c FFEINTRIN_impCOSH
16604 call fooR(COSH(R1))
16605 c FFEINTRIN_impCSIN
16606 call fooC(CSIN(C1))
16607 c FFEINTRIN_impCSQRT
16608 call fooC(CSQRT(C1))
16609 c FFEINTRIN_impDABS
16610 call fooD(DABS(D1))
16611 c FFEINTRIN_impDACOS
16612 call fooD(DACOS(D1))
16613 c FFEINTRIN_impDASIN
16614 call fooD(DASIN(D1))
16615 c FFEINTRIN_impDATAN
16616 call fooD(DATAN(D1))
16617 c FFEINTRIN_impDATAN2
16618 call fooD(DATAN2(D1,D2))
16619 c FFEINTRIN_impDCOS
16620 call fooD(DCOS(D1))
16621 c FFEINTRIN_impDCOSH
16622 call fooD(DCOSH(D1))
16623 c FFEINTRIN_impDDIM
16624 call fooD(DDIM(D1,D2))
16625 c FFEINTRIN_impDEXP
16626 call fooD(DEXP(D1))
16628 call fooR(DIM(R1,R2))
16629 c FFEINTRIN_impDINT
16630 call fooD(DINT(D1))
16631 c FFEINTRIN_impDLOG
16632 call fooD(DLOG(D1))
16633 c FFEINTRIN_impDLOG10
16634 call fooD(DLOG10(D1))
16635 c FFEINTRIN_impDMAX1
16636 call fooD(DMAX1(D1,D2))
16637 c FFEINTRIN_impDMIN1
16638 call fooD(DMIN1(D1,D2))
16639 c FFEINTRIN_impDMOD
16640 call fooD(DMOD(D1,D2))
16641 c FFEINTRIN_impDNINT
16642 call fooD(DNINT(D1))
16643 c FFEINTRIN_impDPROD
16644 call fooD(DPROD(R1,R2))
16645 c FFEINTRIN_impDSIGN
16646 call fooD(DSIGN(D1,D2))
16647 c FFEINTRIN_impDSIN
16648 call fooD(DSIN(D1))
16649 c FFEINTRIN_impDSINH
16650 call fooD(DSINH(D1))
16651 c FFEINTRIN_impDSQRT
16652 call fooD(DSQRT(D1))
16653 c FFEINTRIN_impDTAN
16654 call fooD(DTAN(D1))
16655 c FFEINTRIN_impDTANH
16656 call fooD(DTANH(D1))
16659 c FFEINTRIN_impIABS
16660 call fooI(IABS(I1))
16661 c FFEINTRIN_impICHAR
16662 call fooI(ICHAR(A1))
16663 c FFEINTRIN_impIDIM
16664 call fooI(IDIM(I1,I2))
16665 c FFEINTRIN_impIDNINT
16666 call fooI(IDNINT(D1))
16667 c FFEINTRIN_impINDEX
16668 call fooI(INDEX(A1,A2))
16669 c FFEINTRIN_impISIGN
16670 call fooI(ISIGN(I1,I2))
16674 call fooL(LGE(A1,A2))
16676 call fooL(LGT(A1,A2))
16678 call fooL(LLE(A1,A2))
16680 call fooL(LLT(A1,A2))
16681 c FFEINTRIN_impMAX0
16682 call fooI(MAX0(I1,I2))
16683 c FFEINTRIN_impMAX1
16684 call fooI(MAX1(R1,R2))
16685 c FFEINTRIN_impMIN0
16686 call fooI(MIN0(I1,I2))
16687 c FFEINTRIN_impMIN1
16688 call fooI(MIN1(R1,R2))
16690 call fooI(MOD(I1,I2))
16691 c FFEINTRIN_impNINT
16692 call fooI(NINT(R1))
16693 c FFEINTRIN_impSIGN
16694 call fooR(SIGN(R1,R2))
16697 c FFEINTRIN_impSINH
16698 call fooR(SINH(R1))
16699 c FFEINTRIN_impSQRT
16700 call fooR(SQRT(R1))
16703 c FFEINTRIN_impTANH
16704 call fooR(TANH(R1))
16705 c FFEINTRIN_imp_CMPLX_C
16706 call fooC(cmplx(C1,C2))
16707 c FFEINTRIN_imp_CMPLX_D
16708 call fooZ(cmplx(D1,D2))
16709 c FFEINTRIN_imp_CMPLX_I
16710 call fooC(cmplx(I1,I2))
16711 c FFEINTRIN_imp_CMPLX_R
16712 call fooC(cmplx(R1,R2))
16713 c FFEINTRIN_imp_DBLE_C
16714 call fooD(dble(C1))
16715 c FFEINTRIN_imp_DBLE_D
16716 call fooD(dble(D1))
16717 c FFEINTRIN_imp_DBLE_I
16718 call fooD(dble(I1))
16719 c FFEINTRIN_imp_DBLE_R
16720 call fooD(dble(R1))
16721 c FFEINTRIN_imp_INT_C
16723 c FFEINTRIN_imp_INT_D
16725 c FFEINTRIN_imp_INT_I
16727 c FFEINTRIN_imp_INT_R
16729 c FFEINTRIN_imp_REAL_C
16730 call fooR(real(C1))
16731 c FFEINTRIN_imp_REAL_D
16732 call fooR(real(D1))
16733 c FFEINTRIN_imp_REAL_I
16734 call fooR(real(I1))
16735 c FFEINTRIN_imp_REAL_R
16736 call fooR(real(R1))
16738 c FFEINTRIN_imp_INT_D:
16740 c FFEINTRIN_specIDINT
16741 call fooI(IDINT(D1))
16743 c FFEINTRIN_imp_INT_R:
16745 c FFEINTRIN_specIFIX
16746 call fooI(IFIX(R1))
16747 c FFEINTRIN_specINT
16750 c FFEINTRIN_imp_REAL_D:
16752 c FFEINTRIN_specSNGL
16753 call fooR(SNGL(D1))
16755 c FFEINTRIN_imp_REAL_I:
16757 c FFEINTRIN_specFLOAT
16758 call fooR(FLOAT(I1))
16759 c FFEINTRIN_specREAL
16760 call fooR(REAL(I1))
16763 -------- (end input file to f2c)
16765 -------- (begin output from providing above input file as input to:
16766 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16767 -------- -e "s:^#.*$::g"')
16769 // -- translated by f2c (version 19950223).
16770 You must link the resulting object file with the libraries:
16771 -lf2c -lm (in that order)
16775 // f2c.h -- Standard Fortran to C header file //
16777 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
16779 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16784 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16785 // we assume short, float are OK //
16786 typedef long int // long int // integer;
16787 typedef char *address;
16788 typedef short int shortint;
16789 typedef float real;
16790 typedef double doublereal;
16791 typedef struct { real r, i; } complex;
16792 typedef struct { doublereal r, i; } doublecomplex;
16793 typedef long int // long int // logical;
16794 typedef short int shortlogical;
16795 typedef char logical1;
16796 typedef char integer1;
16797 // typedef long long longint; // // system-dependent //
16802 // Extern is for use with -E //
16816 typedef long int // int or long int // flag;
16817 typedef long int // int or long int // ftnlen;
16818 typedef long int // int or long int // ftnint;
16821 //external read, write//
16830 //internal read, write//
16860 //rewind, backspace, endfile//
16872 ftnint *inex; //parameters in standard's order//
16898 union Multitype { // for multiple entry points //
16909 typedef union Multitype Multitype;
16911 typedef long Long; // No longer used; formerly in Namelist //
16913 struct Vardesc { // for Namelist //
16919 typedef struct Vardesc Vardesc;
16926 typedef struct Namelist Namelist;
16935 // procedure parameter types for -A and -C++ //
16940 typedef int // Unknown procedure type // (*U_fp)();
16941 typedef shortint (*J_fp)();
16942 typedef integer (*I_fp)();
16943 typedef real (*R_fp)();
16944 typedef doublereal (*D_fp)(), (*E_fp)();
16945 typedef // Complex // void (*C_fp)();
16946 typedef // Double Complex // void (*Z_fp)();
16947 typedef logical (*L_fp)();
16948 typedef shortlogical (*K_fp)();
16949 typedef // Character // void (*H_fp)();
16950 typedef // Subroutine // int (*S_fp)();
16952 // E_fp is for real functions when -R is not specified //
16953 typedef void C_f; // complex function //
16954 typedef void H_f; // character function //
16955 typedef void Z_f; // double complex function //
16956 typedef doublereal E_f; // real function with -R not specified //
16958 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16961 // (No such symbols should be defined in a strict ANSI C compiler.
16962 We can avoid trouble with f2c-translated code by using
16963 gcc -ansi [-traditional].) //
16987 // Main program // MAIN__()
16989 // System generated locals //
16992 doublereal d__1, d__2;
16994 doublecomplex z__1, z__2, z__3;
16998 // Builtin functions //
17001 double pow_ri(), pow_di();
17005 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
17006 asin(), atan(), atan2(), c_abs();
17007 void c_cos(), c_exp(), c_log(), r_cnjg();
17008 double cos(), cosh();
17009 void c_sin(), c_sqrt();
17010 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
17011 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
17012 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
17013 logical l_ge(), l_gt(), l_le(), l_lt();
17017 // Local variables //
17018 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
17019 fool_(), fooz_(), getem_();
17020 static char a1[10], a2[10];
17021 static complex c1, c2;
17022 static doublereal d1, d2;
17023 static integer i1, i2;
17024 static real r1, r2;
17027 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
17035 d__1 = (doublereal) i1;
17036 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
17046 c_div(&q__1, &c1, &c2);
17048 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
17050 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
17053 i__1 = pow_ii(&i1, &i2);
17055 r__1 = pow_ri(&r1, &i1);
17057 d__1 = pow_di(&d1, &i1);
17059 pow_ci(&q__1, &c1, &i1);
17061 d__1 = (doublereal) r1;
17062 d__2 = (doublereal) r2;
17063 r__1 = pow_dd(&d__1, &d__2);
17065 d__2 = (doublereal) r1;
17066 d__1 = pow_dd(&d__2, &d1);
17068 d__1 = pow_dd(&d1, &d2);
17070 d__2 = (doublereal) r1;
17071 d__1 = pow_dd(&d1, &d__2);
17073 z__2.r = c1.r, z__2.i = c1.i;
17074 z__3.r = c2.r, z__3.i = c2.i;
17075 pow_zz(&z__1, &z__2, &z__3);
17076 q__1.r = z__1.r, q__1.i = z__1.i;
17078 z__2.r = c1.r, z__2.i = c1.i;
17079 z__3.r = r1, z__3.i = 0.;
17080 pow_zz(&z__1, &z__2, &z__3);
17081 q__1.r = z__1.r, q__1.i = z__1.i;
17083 z__2.r = c1.r, z__2.i = c1.i;
17084 z__3.r = d1, z__3.i = 0.;
17085 pow_zz(&z__1, &z__2, &z__3);
17087 // FFEINTRIN_impABS //
17088 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
17090 // FFEINTRIN_impACOS //
17093 // FFEINTRIN_impAIMAG //
17094 r__1 = r_imag(&c1);
17096 // FFEINTRIN_impAINT //
17099 // FFEINTRIN_impALOG //
17102 // FFEINTRIN_impALOG10 //
17103 r__1 = r_lg10(&r1);
17105 // FFEINTRIN_impAMAX0 //
17106 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17108 // FFEINTRIN_impAMAX1 //
17109 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
17111 // FFEINTRIN_impAMIN0 //
17112 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17114 // FFEINTRIN_impAMIN1 //
17115 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
17117 // FFEINTRIN_impAMOD //
17118 r__1 = r_mod(&r1, &r2);
17120 // FFEINTRIN_impANINT //
17121 r__1 = r_nint(&r1);
17123 // FFEINTRIN_impASIN //
17126 // FFEINTRIN_impATAN //
17129 // FFEINTRIN_impATAN2 //
17130 r__1 = atan2(r1, r2);
17132 // FFEINTRIN_impCABS //
17135 // FFEINTRIN_impCCOS //
17138 // FFEINTRIN_impCEXP //
17141 // FFEINTRIN_impCHAR //
17142 *(unsigned char *)&ch__1[0] = i1;
17144 // FFEINTRIN_impCLOG //
17147 // FFEINTRIN_impCONJG //
17148 r_cnjg(&q__1, &c1);
17150 // FFEINTRIN_impCOS //
17153 // FFEINTRIN_impCOSH //
17156 // FFEINTRIN_impCSIN //
17159 // FFEINTRIN_impCSQRT //
17160 c_sqrt(&q__1, &c1);
17162 // FFEINTRIN_impDABS //
17163 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
17165 // FFEINTRIN_impDACOS //
17168 // FFEINTRIN_impDASIN //
17171 // FFEINTRIN_impDATAN //
17174 // FFEINTRIN_impDATAN2 //
17175 d__1 = atan2(d1, d2);
17177 // FFEINTRIN_impDCOS //
17180 // FFEINTRIN_impDCOSH //
17183 // FFEINTRIN_impDDIM //
17184 d__1 = d_dim(&d1, &d2);
17186 // FFEINTRIN_impDEXP //
17189 // FFEINTRIN_impDIM //
17190 r__1 = r_dim(&r1, &r2);
17192 // FFEINTRIN_impDINT //
17195 // FFEINTRIN_impDLOG //
17198 // FFEINTRIN_impDLOG10 //
17199 d__1 = d_lg10(&d1);
17201 // FFEINTRIN_impDMAX1 //
17202 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
17204 // FFEINTRIN_impDMIN1 //
17205 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
17207 // FFEINTRIN_impDMOD //
17208 d__1 = d_mod(&d1, &d2);
17210 // FFEINTRIN_impDNINT //
17211 d__1 = d_nint(&d1);
17213 // FFEINTRIN_impDPROD //
17214 d__1 = (doublereal) r1 * r2;
17216 // FFEINTRIN_impDSIGN //
17217 d__1 = d_sign(&d1, &d2);
17219 // FFEINTRIN_impDSIN //
17222 // FFEINTRIN_impDSINH //
17225 // FFEINTRIN_impDSQRT //
17228 // FFEINTRIN_impDTAN //
17231 // FFEINTRIN_impDTANH //
17234 // FFEINTRIN_impEXP //
17237 // FFEINTRIN_impIABS //
17238 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
17240 // FFEINTRIN_impICHAR //
17241 i__1 = *(unsigned char *)a1;
17243 // FFEINTRIN_impIDIM //
17244 i__1 = i_dim(&i1, &i2);
17246 // FFEINTRIN_impIDNINT //
17247 i__1 = i_dnnt(&d1);
17249 // FFEINTRIN_impINDEX //
17250 i__1 = i_indx(a1, a2, 10L, 10L);
17252 // FFEINTRIN_impISIGN //
17253 i__1 = i_sign(&i1, &i2);
17255 // FFEINTRIN_impLEN //
17256 i__1 = i_len(a1, 10L);
17258 // FFEINTRIN_impLGE //
17259 L__1 = l_ge(a1, a2, 10L, 10L);
17261 // FFEINTRIN_impLGT //
17262 L__1 = l_gt(a1, a2, 10L, 10L);
17264 // FFEINTRIN_impLLE //
17265 L__1 = l_le(a1, a2, 10L, 10L);
17267 // FFEINTRIN_impLLT //
17268 L__1 = l_lt(a1, a2, 10L, 10L);
17270 // FFEINTRIN_impMAX0 //
17271 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17273 // FFEINTRIN_impMAX1 //
17274 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
17276 // FFEINTRIN_impMIN0 //
17277 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17279 // FFEINTRIN_impMIN1 //
17280 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
17282 // FFEINTRIN_impMOD //
17285 // FFEINTRIN_impNINT //
17286 i__1 = i_nint(&r1);
17288 // FFEINTRIN_impSIGN //
17289 r__1 = r_sign(&r1, &r2);
17291 // FFEINTRIN_impSIN //
17294 // FFEINTRIN_impSINH //
17297 // FFEINTRIN_impSQRT //
17300 // FFEINTRIN_impTAN //
17303 // FFEINTRIN_impTANH //
17306 // FFEINTRIN_imp_CMPLX_C //
17309 q__1.r = r__1, q__1.i = r__2;
17311 // FFEINTRIN_imp_CMPLX_D //
17312 z__1.r = d1, z__1.i = d2;
17314 // FFEINTRIN_imp_CMPLX_I //
17317 q__1.r = r__1, q__1.i = r__2;
17319 // FFEINTRIN_imp_CMPLX_R //
17320 q__1.r = r1, q__1.i = r2;
17322 // FFEINTRIN_imp_DBLE_C //
17323 d__1 = (doublereal) c1.r;
17325 // FFEINTRIN_imp_DBLE_D //
17328 // FFEINTRIN_imp_DBLE_I //
17329 d__1 = (doublereal) i1;
17331 // FFEINTRIN_imp_DBLE_R //
17332 d__1 = (doublereal) r1;
17334 // FFEINTRIN_imp_INT_C //
17335 i__1 = (integer) c1.r;
17337 // FFEINTRIN_imp_INT_D //
17338 i__1 = (integer) d1;
17340 // FFEINTRIN_imp_INT_I //
17343 // FFEINTRIN_imp_INT_R //
17344 i__1 = (integer) r1;
17346 // FFEINTRIN_imp_REAL_C //
17349 // FFEINTRIN_imp_REAL_D //
17352 // FFEINTRIN_imp_REAL_I //
17355 // FFEINTRIN_imp_REAL_R //
17359 // FFEINTRIN_imp_INT_D: //
17361 // FFEINTRIN_specIDINT //
17362 i__1 = (integer) d1;
17365 // FFEINTRIN_imp_INT_R: //
17367 // FFEINTRIN_specIFIX //
17368 i__1 = (integer) r1;
17370 // FFEINTRIN_specINT //
17371 i__1 = (integer) r1;
17374 // FFEINTRIN_imp_REAL_D: //
17376 // FFEINTRIN_specSNGL //
17380 // FFEINTRIN_imp_REAL_I: //
17382 // FFEINTRIN_specFLOAT //
17385 // FFEINTRIN_specREAL //
17391 -------- (end output file from f2c)