1 /* com.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995-1997 Free Software Foundation, Inc.
3 Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
5 This file is part of GNU Fortran.
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
26 Contains compiler-specific functions.
31 /* Understanding this module means understanding the interface between
32 the g77 front end and the gcc back end (or, perhaps, some other
33 back end). In here are the functions called by the front end proper
34 to notify whatever back end is in place about certain things, and
35 also the back-end-specific functions. It's a bear to deal with, so
36 lately I've been trying to simplify things, especially with regard
37 to the gcc-back-end-specific stuff.
39 Building expressions generally seems quite easy, but building decls
40 has been challenging and is undergoing revision. gcc has several
43 TYPE_DECL -- a type (int, float, struct, function, etc.)
44 CONST_DECL -- a constant of some type other than function
45 LABEL_DECL -- a variable or a constant?
46 PARM_DECL -- an argument to a function (a variable that is a dummy)
47 RESULT_DECL -- the return value of a function (a variable)
48 VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
49 FUNCTION_DECL -- a function (either the actual function or an extern ref)
50 FIELD_DECL -- a field in a struct or union (goes into types)
52 g77 has a set of functions that somewhat parallels the gcc front end
53 when it comes to building decls:
55 Internal Function (one we define, not just declare as extern):
57 yes = suspend_momentary ();
58 if (is_nested) push_f_function_context ();
59 start_function (get_identifier ("function_name"), function_type,
60 is_nested, is_public);
61 // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
62 store_parm_decls (is_main_program);
63 ffecom_start_compstmt_ ();
64 // for stmts and decls inside function, do appropriate things;
65 ffecom_end_compstmt_ ();
66 finish_function (is_nested);
67 if (is_nested) pop_f_function_context ();
68 if (is_nested) resume_momentary (yes);
74 yes = suspend_momentary ();
75 // fill in external, public, static, &c for decl, and
76 // set DECL_INITIAL to error_mark_node if going to initialize
77 // set is_top_level TRUE only if not at top level and decl
78 // must go in top level (i.e. not within current function decl context)
79 d = start_decl (decl, is_top_level);
80 init = ...; // if have initializer
81 finish_decl (d, init, is_top_level);
82 resume_momentary (yes);
88 #if FFECOM_targetCURRENT == FFECOM_targetGCC
94 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
96 #define FFECOM_GCC_INCLUDE 1 /* Enable -I. */
98 /* BEGIN stuff from gcc/cccp.c. */
100 /* The following symbols should be autoconfigured:
107 In the mean time, we'll get by with approximations based
108 on existing GCC configuration symbols. */
111 # ifndef HAVE_STDLIB_H
112 # define HAVE_STDLIB_H 1
114 # ifndef HAVE_UNISTD_H
115 # define HAVE_UNISTD_H 1
117 # ifndef STDC_HEADERS
118 # define STDC_HEADERS 1
120 #endif /* defined (POSIX) */
122 #if defined (POSIX) || (defined (USG) && !defined (VMS))
123 # ifndef HAVE_FCNTL_H
124 # define HAVE_FCNTL_H 1
131 # if TIME_WITH_SYS_TIME
132 # include <sys/time.h>
136 # include <sys/time.h>
141 # include <sys/resource.h>
148 /* This defines "errno" properly for VMS, and gives us EACCES. */
164 /* VMS-specific definitions */
167 #define O_RDONLY 0 /* Open arg for Read/Only */
168 #define O_WRONLY 1 /* Open arg for Write/Only */
169 #define read(fd,buf,size) VMS_read (fd,buf,size)
170 #define write(fd,buf,size) VMS_write (fd,buf,size)
171 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
172 #define fopen(fname,mode) VMS_fopen (fname,mode)
173 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
174 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
175 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
176 static int VMS_fstat (), VMS_stat ();
177 static char * VMS_strncat ();
178 static int VMS_read ();
179 static int VMS_write ();
180 static int VMS_open ();
181 static FILE * VMS_fopen ();
182 static FILE * VMS_freopen ();
183 static void hack_vms_include_specification ();
184 typedef struct { unsigned :16, :16, :16; } vms_ino_t
;
185 #define ino_t vms_ino_t
186 #define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */
188 #define BSTRING /* VMS/GCC supplies the bstring routines */
189 #endif /* __GNUC__ */
196 /* END stuff from gcc/cccp.c. */
199 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
216 /* Externals defined here. */
218 #define FFECOM_FASTER_ARRAY_REFS 0 /* Generates faster code? */
220 #if FFECOM_targetCURRENT == FFECOM_targetGCC
222 /* tree.h declares a bunch of stuff that it expects the front end to
223 define. Here are the definitions, which in the C front end are
224 found in the file c-decl.c. */
226 tree integer_zero_node
;
227 tree integer_one_node
;
228 tree null_pointer_node
;
229 tree error_mark_node
;
231 tree integer_type_node
;
232 tree unsigned_type_node
;
234 tree current_function_decl
;
236 /* ~~tree.h SHOULD declare this, because toplev.c and dwarfout.c reference
239 char *language_string
= "GNU F77";
241 /* These definitions parallel those in c-decl.c so that code from that
242 module can be used pretty much as is. Much of these defs aren't
243 otherwise used, i.e. by g77 code per se, except some of them are used
244 to build some of them that are. The ones that are global (i.e. not
245 "static") are those that ste.c and such might use (directly
246 or by using com macros that reference them in their definitions). */
248 static tree short_integer_type_node
;
249 tree long_integer_type_node
;
250 static tree long_long_integer_type_node
;
252 static tree short_unsigned_type_node
;
253 static tree long_unsigned_type_node
;
254 static tree long_long_unsigned_type_node
;
256 static tree unsigned_char_type_node
;
257 static tree signed_char_type_node
;
259 static tree float_type_node
;
260 static tree double_type_node
;
261 static tree complex_float_type_node
;
262 tree complex_double_type_node
;
263 static tree long_double_type_node
;
264 static tree complex_integer_type_node
;
265 static tree complex_long_double_type_node
;
267 tree string_type_node
;
269 static tree double_ftype_double
;
270 static tree float_ftype_float
;
271 static tree ldouble_ftype_ldouble
;
273 /* The rest of these are inventions for g77, though there might be
274 similar things in the C front end. As they are found, these
275 inventions should be renamed to be canonical. Note that only
276 the ones currently required to be global are so. */
278 static tree ffecom_tree_fun_type_void
;
279 static tree ffecom_tree_ptr_to_fun_type_void
;
281 tree ffecom_integer_type_node
; /* Abbrev for _tree_type[blah][blah]. */
282 tree ffecom_integer_zero_node
; /* Like *_*_* with g77's integer type. */
283 tree ffecom_integer_one_node
; /* " */
284 tree ffecom_tree_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
286 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
287 just use build_function_type and build_pointer_type on the
288 appropriate _tree_type array element. */
290 static tree ffecom_tree_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
291 static tree ffecom_tree_ptr_to_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
292 static tree ffecom_tree_subr_type
;
293 static tree ffecom_tree_ptr_to_subr_type
;
294 static tree ffecom_tree_blockdata_type
;
296 static tree ffecom_tree_xargc_
;
298 ffecomSymbol ffecom_symbol_null_
305 ffeinfoKindtype ffecom_pointer_kind_
= FFEINFO_basictypeNONE
;
306 ffeinfoKindtype ffecom_label_kind_
= FFEINFO_basictypeNONE
;
308 int ffecom_f2c_typecode_
[FFEINFO_basictype
][FFEINFO_kindtype
];
309 tree ffecom_f2c_integer_type_node
;
310 tree ffecom_f2c_ptr_to_integer_type_node
;
311 tree ffecom_f2c_address_type_node
;
312 tree ffecom_f2c_real_type_node
;
313 tree ffecom_f2c_ptr_to_real_type_node
;
314 tree ffecom_f2c_doublereal_type_node
;
315 tree ffecom_f2c_complex_type_node
;
316 tree ffecom_f2c_doublecomplex_type_node
;
317 tree ffecom_f2c_longint_type_node
;
318 tree ffecom_f2c_logical_type_node
;
319 tree ffecom_f2c_flag_type_node
;
320 tree ffecom_f2c_ftnlen_type_node
;
321 tree ffecom_f2c_ftnlen_zero_node
;
322 tree ffecom_f2c_ftnlen_one_node
;
323 tree ffecom_f2c_ftnlen_two_node
;
324 tree ffecom_f2c_ptr_to_ftnlen_type_node
;
325 tree ffecom_f2c_ftnint_type_node
;
326 tree ffecom_f2c_ptr_to_ftnint_type_node
;
327 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
329 /* Simple definitions and enumerations. */
331 #ifndef FFECOM_sizeMAXSTACKITEM
332 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
333 larger than this # bytes
334 off stack if possible. */
337 /* For systems that have large enough stacks, they should define
338 this to 0, and here, for ease of use later on, we just undefine
341 #if FFECOM_sizeMAXSTACKITEM == 0
342 #undef FFECOM_sizeMAXSTACKITEM
348 FFECOM_rttypeINT_
, /* C's `int' type, for libF77/system_.c? */
349 FFECOM_rttypeINTEGER_
,
350 FFECOM_rttypeLONGINT_
, /* C's `long long int' type. */
351 FFECOM_rttypeLOGICAL_
,
352 FFECOM_rttypeREAL_F2C_
, /* f2c's `float' returned as `double'. */
353 FFECOM_rttypeREAL_GNU_
, /* `float' returned as such. */
354 FFECOM_rttypeCOMPLEX_F2C_
, /* f2c's `complex' returned via 1st arg. */
355 FFECOM_rttypeCOMPLEX_GNU_
, /* gcc's `complex float' returned as such. */
356 FFECOM_rttypeDOUBLE_
, /* C's `double' type. */
357 FFECOM_rttypeDOUBLEREAL_
,
358 FFECOM_rttypeDBLCMPLX_F2C_
, /* f2c's `doublecomplex' returned via 1st arg. */
359 FFECOM_rttypeDBLCMPLX_GNU_
, /* gcc's `complex double' returned as such. */
360 FFECOM_rttypeCHARACTER_
, /* f2c `char *'/`ftnlen' pair. */
364 /* Internal typedefs. */
366 #if FFECOM_targetCURRENT == FFECOM_targetGCC
367 typedef struct _ffecom_concat_list_ ffecomConcatList_
;
368 typedef struct _ffecom_temp_
*ffecomTemp_
;
369 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
371 /* Private include files. */
374 /* Internal structure definitions. */
376 #if FFECOM_targetCURRENT == FFECOM_targetGCC
377 struct _ffecom_concat_list_
382 ffetargetCharacterSize minlen
;
383 ffetargetCharacterSize maxlen
;
389 tree type
; /* Base type (w/o size/array applied). */
391 ffetargetCharacterSize size
;
397 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
399 /* Static functions (internal). */
401 #if FFECOM_targetCURRENT == FFECOM_targetGCC
402 static tree
ffecom_arglist_expr_ (char *argstring
, ffebld args
);
403 static tree
ffecom_widest_expr_type_ (ffebld list
);
404 static bool ffecom_overlap_ (tree dest_decl
, tree dest_offset
,
405 tree dest_size
, tree source_tree
,
406 ffebld source
, bool scalar_arg
);
407 static bool ffecom_args_overlapping_ (tree dest_tree
, ffebld dest
,
408 tree args
, tree callee_commons
,
410 static tree
ffecom_build_f2c_string_ (int i
, char *s
);
411 static tree
ffecom_call_ (tree fn
, ffeinfoKindtype kt
,
412 bool is_f2c_complex
, tree type
,
413 tree args
, tree dest_tree
,
414 ffebld dest
, bool *dest_used
,
415 tree callee_commons
, bool scalar_args
);
416 static tree
ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
,
417 bool is_f2c_complex
, tree type
,
418 ffebld left
, ffebld right
,
419 tree dest_tree
, ffebld dest
,
420 bool *dest_used
, tree callee_commons
,
422 static void ffecom_char_args_ (tree
*xitem
, tree
*length
,
424 static tree
ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
);
425 static tree
ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
);
426 static ffecomConcatList_
427 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
,
429 ffetargetCharacterSize max
);
430 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist
);
431 static ffecomConcatList_
ffecom_concat_list_new_ (ffebld expr
,
432 ffetargetCharacterSize max
);
433 static void ffecom_debug_kludge_ (tree aggr
, char *aggr_type
, ffesymbol member
,
434 tree member_type
, ffetargetOffset offset
);
435 static void ffecom_do_entry_ (ffesymbol fn
, int entrynum
);
436 static tree
ffecom_expr_ (ffebld expr
, tree dest_tree
,
437 ffebld dest
, bool *dest_used
,
439 static tree
ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
440 ffebld dest
, bool *dest_used
);
441 static tree
ffecom_expr_power_integer_ (ffebld left
, ffebld right
);
442 static void ffecom_expr_transform_ (ffebld expr
);
443 static void ffecom_f2c_make_type_ (tree
*type
, int tcode
, char *name
);
444 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
446 static ffeglobal
ffecom_finish_global_ (ffeglobal global
);
447 static ffesymbol
ffecom_finish_symbol_transform_ (ffesymbol s
);
448 static tree
ffecom_get_appended_identifier_ (char us
, char *text
);
449 static tree
ffecom_get_external_identifier_ (ffesymbol s
);
450 static tree
ffecom_get_identifier_ (char *text
);
451 static tree
ffecom_gen_sfuncdef_ (ffesymbol s
,
454 static char *ffecom_gfrt_args_ (ffecomGfrt ix
);
455 static tree
ffecom_gfrt_tree_ (ffecomGfrt ix
);
456 static tree
ffecom_init_zero_ (tree decl
);
457 static tree
ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
459 static tree
ffecom_intrinsic_len_ (ffebld expr
);
460 static void ffecom_let_char_ (tree dest_tree
,
462 ffetargetCharacterSize dest_size
,
464 static void ffecom_make_gfrt_ (ffecomGfrt ix
);
465 static void ffecom_member_phase1_ (ffestorag mst
, ffestorag st
);
466 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
467 static void ffecom_member_phase2_ (ffestorag mst
, ffestorag st
);
469 static void ffecom_push_dummy_decls_ (ffebld dumlist
,
471 static void ffecom_start_progunit_ (void);
472 static ffesymbol
ffecom_sym_transform_ (ffesymbol s
);
473 static ffesymbol
ffecom_sym_transform_assign_ (ffesymbol s
);
474 static void ffecom_transform_common_ (ffesymbol s
);
475 static void ffecom_transform_equiv_ (ffestorag st
);
476 static tree
ffecom_transform_namelist_ (ffesymbol s
);
477 static void ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
479 static void ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
480 tree
*size
, tree tree
);
481 static tree
ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
482 tree dest_tree
, ffebld dest
,
484 static tree
ffecom_type_localvar_ (ffesymbol s
,
487 static tree
ffecom_type_namelist_ (void);
489 static tree
ffecom_type_permanent_copy_ (tree t
);
491 static tree
ffecom_type_vardesc_ (void);
492 static tree
ffecom_vardesc_ (ffebld expr
);
493 static tree
ffecom_vardesc_array_ (ffesymbol s
);
494 static tree
ffecom_vardesc_dims_ (ffesymbol s
);
495 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
497 /* These are static functions that parallel those found in the C front
498 end and thus have the same names. */
500 #if FFECOM_targetCURRENT == FFECOM_targetGCC
501 static void bison_rule_compstmt_ (void);
502 static void bison_rule_pushlevel_ (void);
503 static tree
builtin_function (char *name
, tree type
,
504 enum built_in_function function_code
,
506 static int duplicate_decls (tree newdecl
, tree olddecl
);
507 static void finish_decl (tree decl
, tree init
, bool is_top_level
);
508 static void finish_function (int nested
);
509 static char *lang_printable_name (tree decl
, int v
);
510 static tree
lookup_name_current_level (tree name
);
511 static struct binding_level
*make_binding_level (void);
512 static void pop_f_function_context (void);
513 static void push_f_function_context (void);
514 static void push_parm_decl (tree parm
);
515 static tree
pushdecl_top_level (tree decl
);
516 static tree
storedecls (tree decls
);
517 static void store_parm_decls (int is_main_program
);
518 static tree
start_decl (tree decl
, bool is_top_level
);
519 static void start_function (tree name
, tree type
, int nested
, int public);
520 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
521 #if FFECOM_GCC_INCLUDE
522 static void ffecom_file_ (char *name
);
523 static void ffecom_initialize_char_syntax_ (void);
524 static void ffecom_close_include_ (FILE *f
);
525 static int ffecom_decode_include_option_ (char *spec
);
526 static FILE *ffecom_open_include_ (char *name
, ffewhereLine l
,
528 #endif /* FFECOM_GCC_INCLUDE */
530 /* Static objects accessed by functions in this module. */
532 static ffesymbol ffecom_primary_entry_
= NULL
;
533 static ffesymbol ffecom_nested_entry_
= NULL
;
534 static ffeinfoKind ffecom_primary_entry_kind_
;
535 static bool ffecom_primary_entry_is_proc_
;
536 #if FFECOM_targetCURRENT == FFECOM_targetGCC
537 static tree ffecom_outer_function_decl_
;
538 static tree ffecom_previous_function_decl_
;
539 static tree ffecom_which_entrypoint_decl_
;
540 static ffecomTemp_ ffecom_latest_temp_
;
541 static int ffecom_pending_calls_
= 0;
542 static tree ffecom_float_zero_
= NULL_TREE
;
543 static tree ffecom_float_half_
= NULL_TREE
;
544 static tree ffecom_double_zero_
= NULL_TREE
;
545 static tree ffecom_double_half_
= NULL_TREE
;
546 static tree ffecom_func_result_
;/* For functions. */
547 static tree ffecom_func_length_
;/* For CHARACTER fns. */
548 static ffebld ffecom_list_blockdata_
;
549 static ffebld ffecom_list_common_
;
550 static ffebld ffecom_master_arglist_
;
551 static ffeinfoBasictype ffecom_master_bt_
;
552 static ffeinfoKindtype ffecom_master_kt_
;
553 static ffetargetCharacterSize ffecom_master_size_
;
554 static int ffecom_num_fns_
= 0;
555 static int ffecom_num_entrypoints_
= 0;
556 static bool ffecom_is_altreturning_
= FALSE
;
557 static tree ffecom_multi_type_node_
;
558 static tree ffecom_multi_retval_
;
560 ffecom_multi_fields_
[FFEINFO_basictype
][FFEINFO_kindtype
];
561 static bool ffecom_member_namelisted_
; /* _member_phase1_ namelisted? */
562 static bool ffecom_doing_entry_
= FALSE
;
563 static bool ffecom_transform_only_dummies_
= FALSE
;
565 /* Holds pointer-to-function expressions. */
567 static tree ffecom_gfrt_
[FFECOM_gfrt
]
570 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE,
571 #include "com-rt.def"
575 /* Holds the external names of the functions. */
577 static char *ffecom_gfrt_name_
[FFECOM_gfrt
]
580 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME,
581 #include "com-rt.def"
585 /* Whether the function returns. */
587 static bool ffecom_gfrt_volatile_
[FFECOM_gfrt
]
590 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE,
591 #include "com-rt.def"
595 /* Whether the function returns type complex. */
597 static bool ffecom_gfrt_complex_
[FFECOM_gfrt
]
600 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX,
601 #include "com-rt.def"
605 /* Type code for the function return value. */
607 static ffecomRttype_ ffecom_gfrt_type_
[FFECOM_gfrt
]
610 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE,
611 #include "com-rt.def"
615 /* String of codes for the function's arguments. */
617 static char *ffecom_gfrt_argstring_
[FFECOM_gfrt
]
620 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS,
621 #include "com-rt.def"
624 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
626 /* Internal macros. */
628 #if FFECOM_targetCURRENT == FFECOM_targetGCC
630 /* We let tm.h override the types used here, to handle trivial differences
631 such as the choice of unsigned int or long unsigned int for size_t.
632 When machines start needing nontrivial differences in the size type,
633 it would be best to do something here to figure out automatically
634 from other information what type to use. */
636 /* NOTE: g77 currently doesn't use these; see setting of sizetype and
637 change that if you need to. -- jcb 09/01/91. */
640 #define SIZE_TYPE "long unsigned int"
644 #define WCHAR_TYPE "int"
647 #define ffecom_concat_list_count_(catlist) ((catlist).count)
648 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
649 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
650 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
652 #define ffecom_start_compstmt_ bison_rule_pushlevel_
653 #define ffecom_end_compstmt_ bison_rule_compstmt_
655 /* For each binding contour we allocate a binding_level structure
656 * which records the names defined in that contour.
659 * 1) one for each function definition,
660 * where internal declarations of the parameters appear.
662 * The current meaning of a name can be found by searching the levels from
663 * the current one out to the global one.
666 /* Note that the information in the `names' component of the global contour
667 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
671 /* A chain of _DECL nodes for all variables, constants, functions, and
672 typedef types. These are in the reverse of the order supplied. */
675 /* For each level (except not the global one), a chain of BLOCK nodes for
676 all the levels that were entered and exited one level down. */
679 /* The BLOCK node for this level, if one has been preallocated. If 0, the
680 BLOCK is allocated (if needed) when the level is popped. */
683 /* The binding level which this one is contained in (inherits from). */
684 struct binding_level
*level_chain
;
687 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
689 /* The binding level currently in effect. */
691 static struct binding_level
*current_binding_level
;
693 /* A chain of binding_level structures awaiting reuse. */
695 static struct binding_level
*free_binding_level
;
697 /* The outermost binding level, for names of file scope.
698 This is created when the compiler is started and exists
699 through the entire run. */
701 static struct binding_level
*global_binding_level
;
703 /* Binding level structures are initialized by copying this one. */
705 static struct binding_level clear_binding_level
707 {NULL
, NULL
, NULL
, NULL_BINDING_LEVEL
};
709 /* Language-dependent contents of an identifier. */
711 struct lang_identifier
713 struct tree_identifier ignore
;
714 tree global_value
, local_value
, label_value
;
718 /* Macros for access to language-specific slots in an identifier. */
719 /* Each of these slots contains a DECL node or null. */
721 /* This represents the value which the identifier has in the
722 file-scope namespace. */
723 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
724 (((struct lang_identifier *)(NODE))->global_value)
725 /* This represents the value which the identifier has in the current
727 #define IDENTIFIER_LOCAL_VALUE(NODE) \
728 (((struct lang_identifier *)(NODE))->local_value)
729 /* This represents the value which the identifier has as a label in
730 the current label scope. */
731 #define IDENTIFIER_LABEL_VALUE(NODE) \
732 (((struct lang_identifier *)(NODE))->label_value)
733 /* This is nonzero if the identifier was "made up" by g77 code. */
734 #define IDENTIFIER_INVENTED(NODE) \
735 (((struct lang_identifier *)(NODE))->invented)
737 /* In identifiers, C uses the following fields in a special way:
738 TREE_PUBLIC to record that there was a previous local extern decl.
739 TREE_USED to record that such a decl was used.
740 TREE_ADDRESSABLE to record that the address of such a decl was used. */
742 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
743 that have names. Here so we can clear out their names' definitions
744 at the end of the function. */
746 static tree named_labels
;
748 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
750 static tree shadowed_labels
;
752 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
755 /* This is like gcc's stabilize_reference -- in fact, most of the code
756 comes from that -- but it handles the situation where the reference
757 is going to have its subparts picked at, and it shouldn't change
758 (or trigger extra invocations of functions in the subtrees) due to
759 this. save_expr is a bit overzealous, because we don't need the
760 entire thing calculated and saved like a temp. So, for DECLs, no
761 change is needed, because these are stable aggregates, and ARRAY_REF
762 and such might well be stable too, but for things like calculations,
763 we do need to calculate a snapshot of a value before picking at it. */
765 #if FFECOM_targetCURRENT == FFECOM_targetGCC
767 ffecom_stabilize_aggregate_ (tree ref
)
770 enum tree_code code
= TREE_CODE (ref
);
777 /* No action is needed in this case. */
787 result
= build_nt (code
, stabilize_reference (TREE_OPERAND (ref
, 0)));
791 result
= build_nt (INDIRECT_REF
,
792 stabilize_reference_1 (TREE_OPERAND (ref
, 0)));
796 result
= build_nt (COMPONENT_REF
,
797 stabilize_reference (TREE_OPERAND (ref
, 0)),
798 TREE_OPERAND (ref
, 1));
802 result
= build_nt (BIT_FIELD_REF
,
803 stabilize_reference (TREE_OPERAND (ref
, 0)),
804 stabilize_reference_1 (TREE_OPERAND (ref
, 1)),
805 stabilize_reference_1 (TREE_OPERAND (ref
, 2)));
809 result
= build_nt (ARRAY_REF
,
810 stabilize_reference (TREE_OPERAND (ref
, 0)),
811 stabilize_reference_1 (TREE_OPERAND (ref
, 1)));
815 result
= build_nt (COMPOUND_EXPR
,
816 stabilize_reference_1 (TREE_OPERAND (ref
, 0)),
817 stabilize_reference (TREE_OPERAND (ref
, 1)));
821 result
= build1 (INDIRECT_REF
, TREE_TYPE (ref
),
822 save_expr (build1 (ADDR_EXPR
,
823 build_pointer_type (TREE_TYPE (ref
)),
829 return save_expr (ref
);
832 return error_mark_node
;
835 TREE_TYPE (result
) = TREE_TYPE (ref
);
836 TREE_READONLY (result
) = TREE_READONLY (ref
);
837 TREE_SIDE_EFFECTS (result
) = TREE_SIDE_EFFECTS (ref
);
838 TREE_THIS_VOLATILE (result
) = TREE_THIS_VOLATILE (ref
);
839 TREE_RAISES (result
) = TREE_RAISES (ref
);
845 /* A rip-off of gcc's convert.c convert_to_complex function,
846 reworked to handle complex implemented as C structures
847 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
849 #if FFECOM_targetCURRENT == FFECOM_targetGCC
851 ffecom_convert_to_complex_ (tree type
, tree expr
)
853 register enum tree_code form
= TREE_CODE (TREE_TYPE (expr
));
856 assert (TREE_CODE (type
) == RECORD_TYPE
);
858 subtype
= TREE_TYPE (TYPE_FIELDS (type
));
860 if (form
== REAL_TYPE
|| form
== INTEGER_TYPE
|| form
== ENUMERAL_TYPE
)
862 expr
= convert (subtype
, expr
);
863 return ffecom_2 (COMPLEX_EXPR
, type
, expr
,
864 convert (subtype
, integer_zero_node
));
867 if (form
== RECORD_TYPE
)
869 tree elt_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
)));
870 if (TYPE_MAIN_VARIANT (elt_type
) == TYPE_MAIN_VARIANT (subtype
))
874 expr
= save_expr (expr
);
875 return ffecom_2 (COMPLEX_EXPR
,
878 ffecom_1 (REALPART_EXPR
,
879 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
882 ffecom_1 (IMAGPART_EXPR
,
883 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
888 if (form
== POINTER_TYPE
|| form
== REFERENCE_TYPE
)
889 error ("pointer value used where a complex was expected");
891 error ("aggregate value used where a complex was expected");
893 return ffecom_2 (COMPLEX_EXPR
, type
,
894 convert (subtype
, integer_zero_node
),
895 convert (subtype
, integer_zero_node
));
899 /* Like gcc's convert(), but crashes if widening might happen. */
901 #if FFECOM_targetCURRENT == FFECOM_targetGCC
903 ffecom_convert_narrow_ (type
, expr
)
906 register tree e
= expr
;
907 register enum tree_code code
= TREE_CODE (type
);
909 if (type
== TREE_TYPE (e
)
910 || TREE_CODE (e
) == ERROR_MARK
)
912 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
913 return fold (build1 (NOP_EXPR
, type
, e
));
914 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
915 || code
== ERROR_MARK
)
916 return error_mark_node
;
917 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
919 assert ("void value not ignored as it ought to be" == NULL
);
920 return error_mark_node
;
922 assert (code
!= VOID_TYPE
);
923 if ((code
!= RECORD_TYPE
)
924 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
925 assert ("converting COMPLEX to REAL" == NULL
);
926 assert (code
!= ENUMERAL_TYPE
);
927 if (code
== INTEGER_TYPE
)
929 assert (TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
);
930 assert (TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)));
931 return fold (convert_to_integer (type
, e
));
933 if (code
== POINTER_TYPE
)
935 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
936 return fold (convert_to_pointer (type
, e
));
938 if (code
== REAL_TYPE
)
940 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
941 assert (TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)));
942 return fold (convert_to_real (type
, e
));
944 if (code
== COMPLEX_TYPE
)
946 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
947 assert (TYPE_PRECISION (TREE_TYPE (type
)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
948 return fold (convert_to_complex (type
, e
));
950 if (code
== RECORD_TYPE
)
952 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
953 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
954 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
955 return fold (ffecom_convert_to_complex_ (type
, e
));
958 assert ("conversion to non-scalar type requested" == NULL
);
959 return error_mark_node
;
963 /* Like gcc's convert(), but crashes if narrowing might happen. */
965 #if FFECOM_targetCURRENT == FFECOM_targetGCC
967 ffecom_convert_widen_ (type
, expr
)
970 register tree e
= expr
;
971 register enum tree_code code
= TREE_CODE (type
);
973 if (type
== TREE_TYPE (e
)
974 || TREE_CODE (e
) == ERROR_MARK
)
976 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
977 return fold (build1 (NOP_EXPR
, type
, e
));
978 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
979 || code
== ERROR_MARK
)
980 return error_mark_node
;
981 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
983 assert ("void value not ignored as it ought to be" == NULL
);
984 return error_mark_node
;
986 assert (code
!= VOID_TYPE
);
987 if ((code
!= RECORD_TYPE
)
988 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
989 assert ("narrowing COMPLEX to REAL" == NULL
);
990 assert (code
!= ENUMERAL_TYPE
);
991 if (code
== INTEGER_TYPE
)
993 assert (TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
);
994 assert (TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)));
995 return fold (convert_to_integer (type
, e
));
997 if (code
== POINTER_TYPE
)
999 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1000 return fold (convert_to_pointer (type
, e
));
1002 if (code
== REAL_TYPE
)
1004 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1005 assert (TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)));
1006 return fold (convert_to_real (type
, e
));
1008 if (code
== COMPLEX_TYPE
)
1010 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1011 assert (TYPE_PRECISION (TREE_TYPE (type
)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1012 return fold (convert_to_complex (type
, e
));
1014 if (code
== RECORD_TYPE
)
1016 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1017 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1018 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1019 return fold (ffecom_convert_to_complex_ (type
, e
));
1022 assert ("conversion to non-scalar type requested" == NULL
);
1023 return error_mark_node
;
1027 /* Handles making a COMPLEX type, either the standard
1028 (but buggy?) gbe way, or the safer (but less elegant?)
1031 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1033 ffecom_make_complex_type_ (tree subtype
)
1039 if (ffe_is_emulate_complex ())
1041 type
= make_node (RECORD_TYPE
);
1042 realfield
= ffecom_decl_field (type
, NULL_TREE
, "r", subtype
);
1043 imagfield
= ffecom_decl_field (type
, realfield
, "i", subtype
);
1044 TYPE_FIELDS (type
) = realfield
;
1049 type
= make_node (COMPLEX_TYPE
);
1050 TREE_TYPE (type
) = subtype
;
1058 /* Chooses either the gbe or the f2c way to build a
1059 complex constant. */
1061 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1063 ffecom_build_complex_constant_ (tree type
, tree realpart
, tree imagpart
)
1067 if (ffe_is_emulate_complex ())
1069 bothparts
= build_tree_list (TYPE_FIELDS (type
), realpart
);
1070 TREE_CHAIN (bothparts
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), imagpart
);
1071 bothparts
= build (CONSTRUCTOR
, type
, NULL_TREE
, bothparts
);
1075 bothparts
= build_complex (type
, realpart
, imagpart
);
1082 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1084 ffecom_arglist_expr_ (char *c
, ffebld expr
)
1087 tree
*plist
= &list
;
1088 tree trail
= NULL_TREE
; /* Append char length args here. */
1089 tree
*ptrail
= &trail
;
1094 tree wanted
= NULL_TREE
;
1096 while (expr
!= NULL
)
1119 wanted
= ffecom_f2c_complex_type_node
;
1123 wanted
= ffecom_f2c_doublereal_type_node
;
1127 wanted
= ffecom_f2c_doublecomplex_type_node
;
1131 wanted
= ffecom_f2c_real_type_node
;
1135 wanted
= ffecom_f2c_integer_type_node
;
1139 wanted
= ffecom_f2c_longint_type_node
;
1143 assert ("bad argstring code" == NULL
);
1149 exprh
= ffebld_head (expr
);
1153 if ((wanted
== NULL_TREE
)
1156 (ffecom_tree_type
[ffeinfo_basictype (ffebld_info (exprh
))]
1157 [ffeinfo_kindtype (ffebld_info (exprh
))])
1158 == TYPE_MODE (wanted
))))
1160 = build_tree_list (NULL_TREE
,
1161 ffecom_arg_ptr_to_expr (exprh
,
1165 item
= ffecom_arg_expr (exprh
, &length
);
1166 item
= ffecom_convert_widen_ (wanted
, item
);
1169 item
= ffecom_1 (ADDR_EXPR
,
1170 build_pointer_type (TREE_TYPE (item
)),
1174 = build_tree_list (NULL_TREE
,
1178 plist
= &TREE_CHAIN (*plist
);
1179 expr
= ffebld_trail (expr
);
1180 if (length
!= NULL_TREE
)
1182 *ptrail
= build_tree_list (NULL_TREE
, length
);
1183 ptrail
= &TREE_CHAIN (*ptrail
);
1193 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1195 ffecom_widest_expr_type_ (ffebld list
)
1198 ffebld widest
= NULL
;
1200 ffetype widest_type
= NULL
;
1203 for (; list
!= NULL
; list
= ffebld_trail (list
))
1205 item
= ffebld_head (list
);
1208 if ((widest
!= NULL
)
1209 && (ffeinfo_basictype (ffebld_info (item
))
1210 != ffeinfo_basictype (ffebld_info (widest
))))
1212 type
= ffeinfo_type (ffeinfo_basictype (ffebld_info (item
)),
1213 ffeinfo_kindtype (ffebld_info (item
)));
1214 if ((widest
== FFEINFO_kindtypeNONE
)
1215 || (ffetype_size (type
)
1216 > ffetype_size (widest_type
)))
1223 assert (widest
!= NULL
);
1224 t
= ffecom_tree_type
[ffeinfo_basictype (ffebld_info (widest
))]
1225 [ffeinfo_kindtype (ffebld_info (widest
))];
1226 assert (t
!= NULL_TREE
);
1231 /* Check whether dest and source might overlap. ffebld versions of these
1232 might or might not be passed, will be NULL if not.
1234 The test is really whether source_tree is modifiable and, if modified,
1235 might overlap destination such that the value(s) in the destination might
1236 change before it is finally modified. dest_* are the canonized
1237 destination itself. */
1239 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1241 ffecom_overlap_ (tree dest_decl
, tree dest_offset
, tree dest_size
,
1242 tree source_tree
, ffebld source UNUSED
,
1250 if (source_tree
== NULL_TREE
)
1253 switch (TREE_CODE (source_tree
))
1256 case IDENTIFIER_NODE
:
1267 case TRUNC_DIV_EXPR
:
1269 case FLOOR_DIV_EXPR
:
1270 case ROUND_DIV_EXPR
:
1271 case TRUNC_MOD_EXPR
:
1273 case FLOOR_MOD_EXPR
:
1274 case ROUND_MOD_EXPR
:
1276 case EXACT_DIV_EXPR
:
1277 case FIX_TRUNC_EXPR
:
1279 case FIX_FLOOR_EXPR
:
1280 case FIX_ROUND_EXPR
:
1295 case BIT_ANDTC_EXPR
:
1297 case TRUTH_ANDIF_EXPR
:
1298 case TRUTH_ORIF_EXPR
:
1299 case TRUTH_AND_EXPR
:
1301 case TRUTH_XOR_EXPR
:
1302 case TRUTH_NOT_EXPR
:
1318 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1319 TREE_OPERAND (source_tree
, 1), NULL
,
1323 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1324 TREE_OPERAND (source_tree
, 0), NULL
,
1329 case NON_LVALUE_EXPR
:
1331 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1334 ffecom_tree_canonize_ptr_ (&source_decl
, &source_offset
,
1336 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1341 ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1342 TREE_OPERAND (source_tree
, 1), NULL
,
1344 || ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1345 TREE_OPERAND (source_tree
, 2), NULL
,
1350 ffecom_tree_canonize_ref_ (&source_decl
, &source_offset
,
1352 TREE_OPERAND (source_tree
, 0));
1356 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1359 source_decl
= source_tree
;
1360 source_offset
= size_zero_node
;
1361 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1365 case REFERENCE_EXPR
:
1366 case PREDECREMENT_EXPR
:
1367 case PREINCREMENT_EXPR
:
1368 case POSTDECREMENT_EXPR
:
1369 case POSTINCREMENT_EXPR
:
1377 /* Come here when source_decl, source_offset, and source_size filled
1378 in appropriately. */
1380 if (source_decl
== NULL_TREE
)
1381 return FALSE
; /* No decl involved, so no overlap. */
1383 if (source_decl
!= dest_decl
)
1384 return FALSE
; /* Different decl, no overlap. */
1386 if (TREE_CODE (dest_size
) == ERROR_MARK
)
1387 return TRUE
; /* Assignment into entire assumed-size
1388 array? Shouldn't happen.... */
1390 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1391 ffecom_2 (PLUS_EXPR
, TREE_TYPE (dest_offset
),
1393 convert (TREE_TYPE (dest_offset
),
1395 convert (TREE_TYPE (dest_offset
),
1398 if (integer_onep (t
))
1399 return FALSE
; /* Destination precedes source. */
1402 || (source_size
== NULL_TREE
)
1403 || (TREE_CODE (source_size
) == ERROR_MARK
)
1404 || integer_zerop (source_size
))
1405 return TRUE
; /* No way to tell if dest follows source. */
1407 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1408 ffecom_2 (PLUS_EXPR
, TREE_TYPE (source_offset
),
1410 convert (TREE_TYPE (source_offset
),
1412 convert (TREE_TYPE (source_offset
),
1415 if (integer_onep (t
))
1416 return FALSE
; /* Destination follows source. */
1418 return TRUE
; /* Destination and source overlap. */
1422 /* Check whether dest might overlap any of a list of arguments or is
1423 in a COMMON area the callee might know about (and thus modify). */
1425 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1427 ffecom_args_overlapping_ (tree dest_tree
, ffebld dest UNUSED
,
1428 tree args
, tree callee_commons
,
1436 ffecom_tree_canonize_ref_ (&dest_decl
, &dest_offset
, &dest_size
,
1439 if (dest_decl
== NULL_TREE
)
1440 return FALSE
; /* Seems unlikely! */
1442 /* If the decl cannot be determined reliably, or if its in COMMON
1443 and the callee isn't known to not futz with COMMON via other
1444 means, overlap might happen. */
1446 if ((TREE_CODE (dest_decl
) == ERROR_MARK
)
1447 || ((callee_commons
!= NULL_TREE
)
1448 && TREE_PUBLIC (dest_decl
)))
1451 for (; args
!= NULL_TREE
; args
= TREE_CHAIN (args
))
1453 if (((arg
= TREE_VALUE (args
)) != NULL_TREE
)
1454 && ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1455 arg
, NULL
, scalar_args
))
1463 /* Build a string for a variable name as used by NAMELIST. This means that
1464 if we're using the f2c library, we build an uppercase string, since
1467 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1469 ffecom_build_f2c_string_ (int i
, char *s
)
1471 if (!ffe_is_f2c_library ())
1472 return build_string (i
, s
);
1481 if (((size_t) i
) > ARRAY_SIZE (space
))
1482 tmp
= malloc_new_ks (malloc_pool_image (), "f2c_string", i
);
1486 for (p
= s
, q
= tmp
; *p
!= '\0'; ++p
, ++q
)
1487 *q
= ffesrc_toupper (*p
);
1490 t
= build_string (i
, tmp
);
1492 if (((size_t) i
) > ARRAY_SIZE (space
))
1493 malloc_kill_ks (malloc_pool_image (), tmp
, i
);
1500 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1501 type to just get whatever the function returns), handling the
1502 f2c value-returning convention, if required, by prepending
1503 to the arglist a pointer to a temporary to receive the return value. */
1505 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1507 ffecom_call_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1508 tree type
, tree args
, tree dest_tree
,
1509 ffebld dest
, bool *dest_used
, tree callee_commons
,
1515 if (dest_used
!= NULL
)
1520 if ((dest_used
== NULL
)
1522 || (ffeinfo_basictype (ffebld_info (dest
))
1523 != FFEINFO_basictypeCOMPLEX
)
1524 || (ffeinfo_kindtype (ffebld_info (dest
)) != kt
)
1525 || ((type
!= NULL_TREE
) && (TREE_TYPE (dest_tree
) != type
))
1526 || ffecom_args_overlapping_ (dest_tree
, dest
, args
,
1530 tempvar
= ffecom_push_tempvar (ffecom_tree_type
1531 [FFEINFO_basictypeCOMPLEX
][kt
],
1532 FFETARGET_charactersizeNONE
,
1538 tempvar
= dest_tree
;
1543 = build_tree_list (NULL_TREE
,
1544 ffecom_1 (ADDR_EXPR
,
1545 build_pointer_type (TREE_TYPE (tempvar
)),
1547 TREE_CHAIN (item
) = args
;
1549 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1552 if (tempvar
!= dest_tree
)
1553 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
, tempvar
);
1556 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1559 if ((type
!= NULL_TREE
) && (TREE_TYPE (item
) != type
))
1560 item
= ffecom_convert_narrow_ (type
, item
);
1566 /* Given two arguments, transform them and make a call to the given
1567 function via ffecom_call_. */
1569 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1571 ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1572 tree type
, ffebld left
, ffebld right
,
1573 tree dest_tree
, ffebld dest
, bool *dest_used
,
1574 tree callee_commons
, bool scalar_args
)
1581 ffecom_push_calltemps ();
1582 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
1583 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
1584 ffecom_pop_calltemps ();
1586 left_tree
= build_tree_list (NULL_TREE
, left_tree
);
1587 right_tree
= build_tree_list (NULL_TREE
, right_tree
);
1588 TREE_CHAIN (left_tree
) = right_tree
;
1590 if (left_length
!= NULL_TREE
)
1592 left_length
= build_tree_list (NULL_TREE
, left_length
);
1593 TREE_CHAIN (right_tree
) = left_length
;
1596 if (right_length
!= NULL_TREE
)
1598 right_length
= build_tree_list (NULL_TREE
, right_length
);
1599 if (left_length
!= NULL_TREE
)
1600 TREE_CHAIN (left_length
) = right_length
;
1602 TREE_CHAIN (right_tree
) = right_length
;
1605 return ffecom_call_ (fn
, kt
, is_f2c_complex
, type
, left_tree
,
1606 dest_tree
, dest
, dest_used
, callee_commons
,
1611 /* ffecom_char_args_ -- Return ptr/length args for char subexpression
1616 ffecom_char_args_(&ptr_arg,&length_arg,expr);
1618 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1619 subexpressions by constructing the appropriate trees for the ptr-to-
1620 character-text and length-of-character-text arguments in a calling
1623 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1625 ffecom_char_args_ (tree
*xitem
, tree
*length
, ffebld expr
)
1629 ffetargetCharacter1 val
;
1631 switch (ffebld_op (expr
))
1633 case FFEBLD_opCONTER
:
1634 val
= ffebld_constant_character1 (ffebld_conter (expr
));
1635 *length
= build_int_2 (ffetarget_length_character1 (val
), 0);
1636 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1637 high
= build_int_2 (ffetarget_length_character1 (val
),
1639 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
1640 item
= build_string (ffetarget_length_character1 (val
),
1641 ffetarget_text_character1 (val
));
1643 = build_type_variant
1647 (ffecom_f2c_ftnlen_type_node
,
1648 ffecom_f2c_ftnlen_one_node
,
1651 TREE_CONSTANT (item
) = 1;
1652 TREE_STATIC (item
) = 1;
1653 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
1657 case FFEBLD_opSYMTER
:
1659 ffesymbol s
= ffebld_symter (expr
);
1661 item
= ffesymbol_hook (s
).decl_tree
;
1662 if (item
== NULL_TREE
)
1664 s
= ffecom_sym_transform_ (s
);
1665 item
= ffesymbol_hook (s
).decl_tree
;
1667 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
1669 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
1670 *length
= ffesymbol_hook (s
).length_tree
;
1673 *length
= build_int_2 (ffesymbol_size (s
), 0);
1674 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1677 else if (item
== error_mark_node
)
1678 *length
= error_mark_node
;
1679 else /* FFEINFO_kindFUNCTION: */
1680 *length
= NULL_TREE
;
1681 if (!ffesymbol_hook (s
).addr
1682 && (item
!= error_mark_node
))
1683 item
= ffecom_1 (ADDR_EXPR
,
1684 build_pointer_type (TREE_TYPE (item
)),
1689 case FFEBLD_opARRAYREF
:
1691 ffebld dims
[FFECOM_dimensionsMAX
];
1695 ffecom_push_calltemps ();
1696 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1697 ffecom_pop_calltemps ();
1699 if (item
== error_mark_node
|| *length
== error_mark_node
)
1701 item
= *length
= error_mark_node
;
1705 /* Build up ARRAY_REFs in reverse order (since we're column major
1706 here in Fortran land). */
1708 for (i
= 0, expr
= ffebld_right (expr
);
1710 expr
= ffebld_trail (expr
))
1711 dims
[i
++] = ffebld_head (expr
);
1713 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
1715 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
1717 item
= ffecom_2 (PLUS_EXPR
, build_pointer_type (TREE_TYPE (array
)),
1719 size_binop (MULT_EXPR
,
1720 size_in_bytes (TREE_TYPE (array
)),
1721 size_binop (MINUS_EXPR
,
1722 ffecom_expr (dims
[i
]),
1723 TYPE_MIN_VALUE (TYPE_DOMAIN (array
)))));
1728 case FFEBLD_opSUBSTR
:
1732 ffebld thing
= ffebld_right (expr
);
1736 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
1737 start
= ffebld_head (thing
);
1738 thing
= ffebld_trail (thing
);
1739 assert (ffebld_trail (thing
) == NULL
);
1740 end
= ffebld_head (thing
);
1742 ffecom_push_calltemps ();
1743 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1744 ffecom_pop_calltemps ();
1746 if (item
== error_mark_node
|| *length
== error_mark_node
)
1748 item
= *length
= error_mark_node
;
1758 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
1761 if (end_tree
== error_mark_node
)
1763 item
= *length
= error_mark_node
;
1772 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
1773 ffecom_expr (start
));
1775 if (start_tree
== error_mark_node
)
1777 item
= *length
= error_mark_node
;
1781 start_tree
= ffecom_save_tree (start_tree
);
1783 item
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (item
),
1785 ffecom_2 (MINUS_EXPR
,
1786 TREE_TYPE (start_tree
),
1788 ffecom_f2c_ftnlen_one_node
));
1792 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
1793 ffecom_f2c_ftnlen_one_node
,
1794 ffecom_2 (MINUS_EXPR
,
1795 ffecom_f2c_ftnlen_type_node
,
1801 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
1804 if (end_tree
== error_mark_node
)
1806 item
= *length
= error_mark_node
;
1810 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
1811 ffecom_f2c_ftnlen_one_node
,
1812 ffecom_2 (MINUS_EXPR
,
1813 ffecom_f2c_ftnlen_type_node
,
1814 end_tree
, start_tree
));
1820 case FFEBLD_opFUNCREF
:
1822 ffesymbol s
= ffebld_symter (ffebld_left (expr
));
1825 ffetargetCharacterSize size
= ffeinfo_size (ffebld_info (expr
));
1828 if (size
== FFETARGET_charactersizeNONE
)
1829 size
= 24; /* ~~~~ Kludge alert! This should someday be fixed. */
1831 *length
= build_int_2 (size
, 0);
1832 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1834 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
1835 == FFEINFO_whereINTRINSIC
)
1838 { /* Invocation of an intrinsic returning CHARACTER*1. */
1839 item
= ffecom_expr_intrinsic_ (expr
, NULL_TREE
,
1843 ix
= ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr
)));
1844 assert (ix
!= FFECOM_gfrt
);
1845 item
= ffecom_gfrt_tree_ (ix
);
1850 item
= ffesymbol_hook (s
).decl_tree
;
1851 if (item
== NULL_TREE
)
1853 s
= ffecom_sym_transform_ (s
);
1854 item
= ffesymbol_hook (s
).decl_tree
;
1856 if (item
== error_mark_node
)
1858 item
= *length
= error_mark_node
;
1862 if (!ffesymbol_hook (s
).addr
)
1863 item
= ffecom_1_fn (item
);
1866 assert (ffecom_pending_calls_
!= 0);
1867 tempvar
= ffecom_push_tempvar (char_type_node
, size
, -1, TRUE
);
1868 tempvar
= ffecom_1 (ADDR_EXPR
,
1869 build_pointer_type (TREE_TYPE (tempvar
)),
1872 ffecom_push_calltemps ();
1874 args
= build_tree_list (NULL_TREE
, tempvar
);
1876 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
) /* Sfunc args by value. */
1877 TREE_CHAIN (args
) = ffecom_list_expr (ffebld_right (expr
));
1880 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, *length
);
1881 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
1883 TREE_CHAIN (TREE_CHAIN (args
))
1884 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix
),
1885 ffebld_right (expr
));
1889 TREE_CHAIN (TREE_CHAIN (args
))
1890 = ffecom_list_ptr_to_expr (ffebld_right (expr
));
1894 item
= ffecom_3s (CALL_EXPR
,
1895 TREE_TYPE (TREE_TYPE (TREE_TYPE (item
))),
1896 item
, args
, NULL_TREE
);
1897 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
,
1900 ffecom_pop_calltemps ();
1904 case FFEBLD_opCONVERT
:
1906 ffecom_push_calltemps ();
1907 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1908 ffecom_pop_calltemps ();
1910 if (item
== error_mark_node
|| *length
== error_mark_node
)
1912 item
= *length
= error_mark_node
;
1916 if ((ffebld_size_known (ffebld_left (expr
))
1917 == FFETARGET_charactersizeNONE
)
1918 || (ffebld_size_known (ffebld_left (expr
)) < (ffebld_size (expr
))))
1919 { /* Possible blank-padding needed, copy into
1925 assert (ffecom_pending_calls_
!= 0);
1926 tempvar
= ffecom_push_tempvar (char_type_node
,
1927 ffebld_size (expr
), -1, TRUE
);
1928 tempvar
= ffecom_1 (ADDR_EXPR
,
1929 build_pointer_type (TREE_TYPE (tempvar
)),
1932 newlen
= build_int_2 (ffebld_size (expr
), 0);
1933 TREE_TYPE (newlen
) = ffecom_f2c_ftnlen_type_node
;
1935 args
= build_tree_list (NULL_TREE
, tempvar
);
1936 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, item
);
1937 TREE_CHAIN (TREE_CHAIN (args
)) = build_tree_list (NULL_TREE
, newlen
);
1938 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args
)))
1939 = build_tree_list (NULL_TREE
, *length
);
1941 item
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, args
);
1942 TREE_SIDE_EFFECTS (item
) = 1;
1943 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), fold (item
),
1948 { /* Just truncate the length. */
1949 *length
= build_int_2 (ffebld_size (expr
), 0);
1950 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1955 assert ("bad op for single char arg expr" == NULL
);
1964 /* Check the size of the type to be sure it doesn't overflow the
1965 "portable" capacities of the compiler back end. `dummy' types
1966 can generally overflow the normal sizes as long as the computations
1967 themselves don't overflow. A particular target of the back end
1968 must still enforce its size requirements, though, and the back
1969 end takes care of this in stor-layout.c. */
1971 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1973 ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
)
1975 if (TREE_CODE (type
) == ERROR_MARK
)
1978 if (TYPE_SIZE (type
) == NULL_TREE
)
1981 if (TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
)
1984 if ((tree_int_cst_sgn (TYPE_SIZE (type
)) < 0)
1985 || (!dummy
&& (TREE_INT_CST_HIGH (TYPE_SIZE (type
)) != 0))
1986 || TREE_OVERFLOW (TYPE_SIZE (type
)))
1988 ffebad_start (FFEBAD_ARRAY_LARGE
);
1989 ffebad_string (ffesymbol_text (s
));
1990 ffebad_here (0, ffesymbol_where_line (s
), ffesymbol_where_column (s
));
1993 return error_mark_node
;
2000 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2001 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2002 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2004 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2006 ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
)
2008 ffetargetCharacterSize sz
= ffesymbol_size (s
);
2013 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
2014 tlen
= NULL_TREE
; /* A statement function, no length passed. */
2017 if (ffesymbol_where (s
) == FFEINFO_whereDUMMY
)
2018 tlen
= ffecom_get_invented_identifier ("__g77_length_%s",
2019 ffesymbol_text (s
), 0);
2021 tlen
= ffecom_get_invented_identifier ("__g77_%s",
2023 tlen
= build_decl (PARM_DECL
, tlen
, ffecom_f2c_ftnlen_type_node
);
2025 DECL_ARTIFICIAL (tlen
) = 1;
2029 if (sz
== FFETARGET_charactersizeNONE
)
2031 assert (tlen
!= NULL_TREE
);
2036 highval
= build_int_2 (sz
, 0);
2037 TREE_TYPE (highval
) = ffecom_f2c_ftnlen_type_node
;
2040 type
= build_array_type (type
,
2041 build_range_type (ffecom_f2c_ftnlen_type_node
,
2042 ffecom_f2c_ftnlen_one_node
,
2050 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2052 ffecomConcatList_ catlist;
2053 ffebld expr; // expr of CHARACTER basictype.
2054 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2055 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2057 Scans expr for character subexpressions, updates and returns catlist
2060 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2061 static ffecomConcatList_
2062 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
, ffebld expr
,
2063 ffetargetCharacterSize max
)
2065 ffetargetCharacterSize sz
;
2067 recurse
: /* :::::::::::::::::::: */
2072 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
>= max
))
2073 return catlist
; /* Don't append any more items. */
2075 switch (ffebld_op (expr
))
2077 case FFEBLD_opCONTER
:
2078 case FFEBLD_opSYMTER
:
2079 case FFEBLD_opARRAYREF
:
2080 case FFEBLD_opFUNCREF
:
2081 case FFEBLD_opSUBSTR
:
2082 case FFEBLD_opCONVERT
: /* Callers should strip this off beforehand
2083 if they don't need to preserve it. */
2084 if (catlist
.count
== catlist
.max
)
2085 { /* Make a (larger) list. */
2089 newmax
= (catlist
.max
== 0) ? 8 : catlist
.max
* 2;
2090 newx
= malloc_new_ks (malloc_pool_image (), "catlist",
2091 newmax
* sizeof (newx
[0]));
2092 if (catlist
.max
!= 0)
2094 memcpy (newx
, catlist
.exprs
, catlist
.max
* sizeof (newx
[0]));
2095 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2096 catlist
.max
* sizeof (newx
[0]));
2098 catlist
.max
= newmax
;
2099 catlist
.exprs
= newx
;
2101 if ((sz
= ffebld_size_known (expr
)) != FFETARGET_charactersizeNONE
)
2102 catlist
.minlen
+= sz
;
2104 ++catlist
.minlen
; /* Not true for F90; can be 0 length. */
2105 if ((sz
= ffebld_size_max (expr
)) == FFETARGET_charactersizeNONE
)
2106 catlist
.maxlen
= sz
;
2108 catlist
.maxlen
+= sz
;
2109 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
> max
))
2110 { /* This item overlaps (or is beyond) the end
2111 of the destination. */
2112 switch (ffebld_op (expr
))
2114 case FFEBLD_opCONTER
:
2115 case FFEBLD_opSYMTER
:
2116 case FFEBLD_opARRAYREF
:
2117 case FFEBLD_opFUNCREF
:
2118 case FFEBLD_opSUBSTR
:
2119 break; /* ~~Do useful truncations here. */
2122 assert ("op changed or inconsistent switches!" == NULL
);
2126 catlist
.exprs
[catlist
.count
++] = expr
;
2129 case FFEBLD_opPAREN
:
2130 expr
= ffebld_left (expr
);
2131 goto recurse
; /* :::::::::::::::::::: */
2133 case FFEBLD_opCONCATENATE
:
2134 catlist
= ffecom_concat_list_gather_ (catlist
, ffebld_left (expr
), max
);
2135 expr
= ffebld_right (expr
);
2136 goto recurse
; /* :::::::::::::::::::: */
2138 #if 0 /* Breaks passing small actual arg to larger
2139 dummy arg of sfunc */
2140 case FFEBLD_opCONVERT
:
2141 expr
= ffebld_left (expr
);
2143 ffetargetCharacterSize cmax
;
2145 cmax
= catlist
.len
+ ffebld_size_known (expr
);
2147 if ((max
== FFETARGET_charactersizeNONE
) || (max
> cmax
))
2150 goto recurse
; /* :::::::::::::::::::: */
2157 assert ("bad op in _gather_" == NULL
);
2163 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2165 ffecomConcatList_ catlist;
2166 ffecom_concat_list_kill_(catlist);
2168 Anything allocated within the list info is deallocated. */
2170 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2172 ffecom_concat_list_kill_ (ffecomConcatList_ catlist
)
2174 if (catlist
.max
!= 0)
2175 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2176 catlist
.max
* sizeof (catlist
.exprs
[0]));
2180 /* ffecom_concat_list_new_ -- Make list of concatenated string exprs
2182 ffecomConcatList_ catlist;
2183 ffebld expr; // Root expr of CHARACTER basictype.
2184 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2185 catlist = ffecom_concat_list_new_(expr,max);
2187 Returns a flattened list of concatenated subexpressions given a
2188 tree of such expressions. */
2190 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2191 static ffecomConcatList_
2192 ffecom_concat_list_new_ (ffebld expr
, ffetargetCharacterSize max
)
2194 ffecomConcatList_ catlist
;
2196 catlist
.maxlen
= catlist
.minlen
= catlist
.max
= catlist
.count
= 0;
2197 return ffecom_concat_list_gather_ (catlist
, expr
, max
);
2202 /* Provide some kind of useful info on member of aggregate area,
2203 since current g77/gcc technology does not provide debug info
2204 on these members. */
2206 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2208 ffecom_debug_kludge_ (tree aggr
, char *aggr_type
, ffesymbol member
,
2209 tree member_type UNUSED
, ffetargetOffset offset
)
2219 for (type_id
= member_type
;
2220 TREE_CODE (type_id
) != IDENTIFIER_NODE
;
2223 switch (TREE_CODE (type_id
))
2227 type_id
= TYPE_NAME (type_id
);
2232 type_id
= TREE_TYPE (type_id
);
2236 assert ("no IDENTIFIER_NODE for type!" == NULL
);
2237 type_id
= error_mark_node
;
2243 if (ffecom_transform_only_dummies_
2244 || !ffe_is_debug_kludge ())
2245 return; /* Can't do this yet, maybe later. */
2248 + strlen (aggr_type
)
2249 + IDENTIFIER_LENGTH (DECL_NAME (aggr
));
2251 + IDENTIFIER_LENGTH (type_id
);
2254 if (((size_t) len
) >= ARRAY_SIZE (space
))
2255 buff
= malloc_new_ks (malloc_pool_image (), "debug_kludge", len
+ 1);
2259 sprintf (&buff
[0], "At (%s) `%s' plus %ld bytes",
2261 IDENTIFIER_POINTER (DECL_NAME (aggr
)),
2264 value
= build_string (len
, buff
);
2266 = build_type_variant (build_array_type (char_type_node
,
2270 build_int_2 (strlen (buff
), 0))),
2272 decl
= build_decl (VAR_DECL
,
2273 ffecom_get_identifier_ (ffesymbol_text (member
)),
2275 TREE_CONSTANT (decl
) = 1;
2276 TREE_STATIC (decl
) = 1;
2277 DECL_INITIAL (decl
) = error_mark_node
;
2278 DECL_IN_SYSTEM_HEADER (decl
) = 1; /* Don't let -Wunused complain. */
2279 decl
= start_decl (decl
, FALSE
);
2280 finish_decl (decl
, value
, FALSE
);
2282 if (buff
!= &space
[0])
2283 malloc_kill_ks (malloc_pool_image (), buff
, len
+ 1);
2287 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2289 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2290 int i; // entry# for this entrypoint (used by master fn)
2291 ffecom_do_entrypoint_(s,i);
2293 Makes a public entry point that calls our private master fn (already
2296 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2298 ffecom_do_entry_ (ffesymbol fn
, int entrynum
)
2301 tree type
; /* Type of function. */
2302 tree multi_retval
; /* Var holding return value (union). */
2303 tree result
; /* Var holding result. */
2304 ffeinfoBasictype bt
;
2308 bool charfunc
; /* All entry points return same type
2310 bool cmplxfunc
; /* Use f2c way of returning COMPLEX. */
2311 bool multi
; /* Master fn has multiple return types. */
2312 bool altreturning
= FALSE
; /* This entry point has alternate returns. */
2315 /* c-parse.y indeed does call suspend_momentary and not only ignores the
2316 return value, but also never calls resume_momentary, when starting an
2317 outer function (see "fndef:", "setspecs:", and so on). So g77 does the
2318 same thing. It shouldn't be a problem since start_function calls
2319 temporary_allocation, but it might be necessary. If it causes a problem
2320 here, then maybe there's a bug lurking in gcc. NOTE: This identical
2321 comment appears twice in thist file. */
2323 suspend_momentary ();
2325 ffecom_doing_entry_
= TRUE
; /* Don't bother with array dimensions. */
2327 switch (ffecom_primary_entry_kind_
)
2329 case FFEINFO_kindFUNCTION
:
2331 /* Determine actual return type for function. */
2333 gt
= FFEGLOBAL_typeFUNC
;
2334 bt
= ffesymbol_basictype (fn
);
2335 kt
= ffesymbol_kindtype (fn
);
2336 if (bt
== FFEINFO_basictypeNONE
)
2338 ffeimplic_establish_symbol (fn
);
2339 if (ffesymbol_funcresult (fn
) != NULL
)
2340 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
2341 bt
= ffesymbol_basictype (fn
);
2342 kt
= ffesymbol_kindtype (fn
);
2345 if (bt
== FFEINFO_basictypeCHARACTER
)
2346 charfunc
= TRUE
, cmplxfunc
= FALSE
;
2347 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
2348 && ffesymbol_is_f2c (fn
))
2349 charfunc
= FALSE
, cmplxfunc
= TRUE
;
2351 charfunc
= cmplxfunc
= FALSE
;
2354 type
= ffecom_tree_fun_type_void
;
2355 else if (ffesymbol_is_f2c (fn
))
2356 type
= ffecom_tree_fun_type
[bt
][kt
];
2358 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
2360 if ((type
== NULL_TREE
)
2361 || (TREE_TYPE (type
) == NULL_TREE
))
2362 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
2364 multi
= (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
2367 case FFEINFO_kindSUBROUTINE
:
2368 gt
= FFEGLOBAL_typeSUBR
;
2369 bt
= FFEINFO_basictypeNONE
;
2370 kt
= FFEINFO_kindtypeNONE
;
2371 if (ffecom_is_altreturning_
)
2372 { /* Am _I_ altreturning? */
2373 for (item
= ffesymbol_dummyargs (fn
);
2375 item
= ffebld_trail (item
))
2377 if (ffebld_op (ffebld_head (item
)) == FFEBLD_opSTAR
)
2379 altreturning
= TRUE
;
2384 type
= ffecom_tree_subr_type
;
2386 type
= ffecom_tree_fun_type_void
;
2389 type
= ffecom_tree_fun_type_void
;
2396 assert ("say what??" == NULL
);
2398 case FFEINFO_kindANY
:
2399 gt
= FFEGLOBAL_typeANY
;
2400 bt
= FFEINFO_basictypeNONE
;
2401 kt
= FFEINFO_kindtypeNONE
;
2402 type
= error_mark_node
;
2409 /* build_decl uses the current lineno and input_filename to set the decl
2410 source info. So, I've putzed with ffestd and ffeste code to update that
2411 source info to point to the appropriate statement just before calling
2412 ffecom_do_entrypoint (which calls this fn). */
2414 start_function (ffecom_get_external_identifier_ (fn
),
2416 0, /* nested/inline */
2417 1); /* TREE_PUBLIC */
2419 if (((g
= ffesymbol_global (fn
)) != NULL
)
2420 && ((ffeglobal_type (g
) == gt
)
2421 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
2423 ffeglobal_set_hook (g
, current_function_decl
);
2426 /* Reset args in master arg list so they get retransitioned. */
2428 for (item
= ffecom_master_arglist_
;
2430 item
= ffebld_trail (item
))
2435 arg
= ffebld_head (item
);
2436 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2437 continue; /* Alternate return or some such thing. */
2438 s
= ffebld_symter (arg
);
2439 ffesymbol_hook (s
).decl_tree
= NULL_TREE
;
2440 ffesymbol_hook (s
).length_tree
= NULL_TREE
;
2443 /* Build dummy arg list for this entry point. */
2445 yes
= suspend_momentary ();
2447 if (charfunc
|| cmplxfunc
)
2448 { /* Prepend arg for where result goes. */
2453 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
2455 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
2457 result
= ffecom_get_invented_identifier ("__g77_%s",
2460 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2463 length
= ffecom_char_enhance_arg_ (&type
, fn
);
2465 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
2467 type
= build_pointer_type (type
);
2468 result
= build_decl (PARM_DECL
, result
, type
);
2470 push_parm_decl (result
);
2471 ffecom_func_result_
= result
;
2475 push_parm_decl (length
);
2476 ffecom_func_length_
= length
;
2480 result
= DECL_RESULT (current_function_decl
);
2482 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn
), FALSE
);
2484 resume_momentary (yes
);
2486 store_parm_decls (0);
2488 ffecom_start_compstmt_ ();
2490 /* Make local var to hold return type for multi-type master fn. */
2494 yes
= suspend_momentary ();
2496 multi_retval
= ffecom_get_invented_identifier ("__g77_%s",
2498 multi_retval
= build_decl (VAR_DECL
, multi_retval
,
2499 ffecom_multi_type_node_
);
2500 multi_retval
= start_decl (multi_retval
, FALSE
);
2501 finish_decl (multi_retval
, NULL_TREE
, FALSE
);
2503 resume_momentary (yes
);
2506 multi_retval
= NULL_TREE
; /* Not actually ref'd if !multi. */
2508 /* Here we emit the actual code for the entry point. */
2514 tree arglist
= NULL_TREE
;
2515 tree
*plist
= &arglist
;
2521 /* Prepare actual arg list based on master arg list. */
2523 for (list
= ffecom_master_arglist_
;
2525 list
= ffebld_trail (list
))
2527 arg
= ffebld_head (list
);
2528 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2530 s
= ffebld_symter (arg
);
2531 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
)
2532 actarg
= null_pointer_node
; /* We don't have this arg. */
2534 actarg
= ffesymbol_hook (s
).decl_tree
;
2535 *plist
= build_tree_list (NULL_TREE
, actarg
);
2536 plist
= &TREE_CHAIN (*plist
);
2539 /* This code appends the length arguments for character
2540 variables/arrays. */
2542 for (list
= ffecom_master_arglist_
;
2544 list
= ffebld_trail (list
))
2546 arg
= ffebld_head (list
);
2547 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2549 s
= ffebld_symter (arg
);
2550 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
2551 continue; /* Only looking for CHARACTER arguments. */
2552 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
2553 continue; /* Only looking for variables and arrays. */
2554 if (ffesymbol_hook (s
).length_tree
== NULL_TREE
)
2555 actarg
= ffecom_f2c_ftnlen_zero_node
; /* We don't have this arg. */
2557 actarg
= ffesymbol_hook (s
).length_tree
;
2558 *plist
= build_tree_list (NULL_TREE
, actarg
);
2559 plist
= &TREE_CHAIN (*plist
);
2562 /* Prepend character-value return info to actual arg list. */
2566 prepend
= build_tree_list (NULL_TREE
, ffecom_func_result_
);
2567 TREE_CHAIN (prepend
)
2568 = build_tree_list (NULL_TREE
, ffecom_func_length_
);
2569 TREE_CHAIN (TREE_CHAIN (prepend
)) = arglist
;
2573 /* Prepend multi-type return value to actual arg list. */
2578 = build_tree_list (NULL_TREE
,
2579 ffecom_1 (ADDR_EXPR
,
2580 build_pointer_type (TREE_TYPE (multi_retval
)),
2582 TREE_CHAIN (prepend
) = arglist
;
2586 /* Prepend my entry-point number to the actual arg list. */
2588 prepend
= build_tree_list (NULL_TREE
, build_int_2 (entrynum
, 0));
2589 TREE_CHAIN (prepend
) = arglist
;
2592 /* Build the call to the master function. */
2594 master_fn
= ffecom_1_fn (ffecom_previous_function_decl_
);
2595 call
= ffecom_3s (CALL_EXPR
,
2596 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn
))),
2597 master_fn
, arglist
, NULL_TREE
);
2599 /* Decide whether the master function is a function or subroutine, and
2600 handle the return value for my entry point. */
2602 if (charfunc
|| ((ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
2605 expand_expr_stmt (call
);
2606 expand_null_return ();
2608 else if (multi
&& cmplxfunc
)
2610 expand_expr_stmt (call
);
2612 = ffecom_1 (INDIRECT_REF
,
2613 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2615 result
= ffecom_modify (NULL_TREE
, result
,
2616 ffecom_2 (COMPONENT_REF
, TREE_TYPE (result
),
2618 ffecom_multi_fields_
[bt
][kt
]));
2619 expand_expr_stmt (result
);
2620 expand_null_return ();
2624 expand_expr_stmt (call
);
2626 = ffecom_modify (NULL_TREE
, result
,
2627 convert (TREE_TYPE (result
),
2628 ffecom_2 (COMPONENT_REF
,
2629 ffecom_tree_type
[bt
][kt
],
2631 ffecom_multi_fields_
[bt
][kt
])));
2632 expand_return (result
);
2637 = ffecom_1 (INDIRECT_REF
,
2638 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2640 result
= ffecom_modify (NULL_TREE
, result
, call
);
2641 expand_expr_stmt (result
);
2642 expand_null_return ();
2646 result
= ffecom_modify (NULL_TREE
,
2648 convert (TREE_TYPE (result
),
2650 expand_return (result
);
2656 ffecom_end_compstmt_ ();
2658 finish_function (0);
2660 ffecom_doing_entry_
= FALSE
;
2664 /* Transform expr into gcc tree with possible destination
2666 Recursive descent on expr while making corresponding tree nodes and
2667 attaching type info and such. If destination supplied and compatible
2668 with temporary that would be made in certain cases, temporary isn't
2669 made, destination used instead, and dest_used flag set TRUE. */
2671 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2673 ffecom_expr_ (ffebld expr
, tree dest_tree
,
2674 ffebld dest
, bool *dest_used
,
2680 ffeinfoBasictype bt
;
2684 tree dt
; /* decl_tree for an ffesymbol. */
2686 enum tree_code code
;
2688 assert (expr
!= NULL
);
2690 if (dest_used
!= NULL
)
2693 bt
= ffeinfo_basictype (ffebld_info (expr
));
2694 kt
= ffeinfo_kindtype (ffebld_info (expr
));
2696 switch (ffebld_op (expr
))
2698 case FFEBLD_opACCTER
:
2699 tree_type
= ffecom_tree_type
[bt
][kt
];
2702 ffebit bits
= ffebld_accter_bits (expr
);
2703 ffetargetOffset source_offset
= 0;
2707 size
= ffetype_size (ffeinfo_type (bt
, kt
));
2712 ffebldConstantUnion cu
;
2715 ffebldConstantArray ca
= ffebld_accter (expr
);
2717 ffebit_test (bits
, source_offset
, &value
, &length
);
2723 for (i
= 0; i
< length
; ++i
)
2725 cu
= ffebld_constantarray_get (ca
, bt
, kt
,
2728 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
2731 purpose
= build_int_2 (source_offset
, 0);
2733 purpose
= NULL_TREE
;
2735 if (list
== NULL_TREE
)
2736 list
= item
= build_tree_list (purpose
, t
);
2739 TREE_CHAIN (item
) = build_tree_list (purpose
, t
);
2740 item
= TREE_CHAIN (item
);
2744 source_offset
+= length
;
2748 item
= build_int_2 (ffebld_accter_size (expr
), 0);
2749 ffebit_kill (ffebld_accter_bits (expr
));
2750 TREE_TYPE (item
) = ffecom_integer_type_node
;
2754 build_range_type (ffecom_integer_type_node
,
2755 ffecom_integer_zero_node
,
2757 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
2758 TREE_CONSTANT (list
) = 1;
2759 TREE_STATIC (list
) = 1;
2762 case FFEBLD_opARRTER
:
2763 tree_type
= ffecom_tree_type
[bt
][kt
];
2767 list
= item
= NULL_TREE
;
2768 for (i
= 0; i
< ffebld_arrter_size (expr
); ++i
)
2770 ffebldConstantUnion cu
2771 = ffebld_constantarray_get (ffebld_arrter (expr
), bt
, kt
, i
);
2773 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
2775 if (list
== NULL_TREE
)
2776 list
= item
= build_tree_list (NULL_TREE
, t
);
2779 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
2780 item
= TREE_CHAIN (item
);
2785 item
= build_int_2 (ffebld_arrter_size (expr
), 0);
2786 TREE_TYPE (item
) = ffecom_integer_type_node
;
2790 build_range_type (ffecom_integer_type_node
,
2791 ffecom_integer_one_node
,
2793 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
2794 TREE_CONSTANT (list
) = 1;
2795 TREE_STATIC (list
) = 1;
2798 case FFEBLD_opCONTER
:
2799 tree_type
= ffecom_tree_type
[bt
][kt
];
2801 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr
)),
2805 case FFEBLD_opSYMTER
:
2806 if ((ffebld_symter_generic (expr
) != FFEINTRIN_genNONE
)
2807 || (ffebld_symter_specific (expr
) != FFEINTRIN_specNONE
))
2808 return ffecom_ptr_to_expr (expr
); /* Same as %REF(intrinsic). */
2809 s
= ffebld_symter (expr
);
2810 t
= ffesymbol_hook (s
).decl_tree
;
2813 { /* ASSIGN'ed-label expr. */
2814 if (ffe_is_ugly_assign ())
2816 /* User explicitly wants ASSIGN'ed variables to be at the same
2817 memory address as the variables when used in non-ASSIGN
2818 contexts. That can make old, arcane, non-standard code
2819 work, but don't try to do it when a pointer wouldn't fit
2820 in the normal variable (take other approach, and warn,
2825 s
= ffecom_sym_transform_ (s
);
2826 t
= ffesymbol_hook (s
).decl_tree
;
2827 assert (t
!= NULL_TREE
);
2830 if (t
== error_mark_node
)
2833 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t
)))
2834 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
2836 if (ffesymbol_hook (s
).addr
)
2837 t
= ffecom_1 (INDIRECT_REF
,
2838 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
2842 if (ffesymbol_hook (s
).assign_tree
== NULL_TREE
)
2844 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
2845 FFEBAD_severityWARNING
);
2846 ffebad_string (ffesymbol_text (s
));
2847 ffebad_here (0, ffesymbol_where_line (s
),
2848 ffesymbol_where_column (s
));
2853 /* Don't use the normal variable's tree for ASSIGN, though mark
2854 it as in the system header (housekeeping). Use an explicit,
2855 specially created sibling that is known to be wide enough
2856 to hold pointers to labels. */
2859 && TREE_CODE (t
) == VAR_DECL
)
2860 DECL_IN_SYSTEM_HEADER (t
) = 1; /* Don't let -Wunused complain. */
2862 t
= ffesymbol_hook (s
).assign_tree
;
2865 s
= ffecom_sym_transform_assign_ (s
);
2866 t
= ffesymbol_hook (s
).assign_tree
;
2867 assert (t
!= NULL_TREE
);
2874 s
= ffecom_sym_transform_ (s
);
2875 t
= ffesymbol_hook (s
).decl_tree
;
2876 assert (t
!= NULL_TREE
);
2878 if (ffesymbol_hook (s
).addr
)
2879 t
= ffecom_1 (INDIRECT_REF
,
2880 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
2884 case FFEBLD_opARRAYREF
:
2886 ffebld dims
[FFECOM_dimensionsMAX
];
2887 #if FFECOM_FASTER_ARRAY_REFS
2892 #if FFECOM_FASTER_ARRAY_REFS
2893 t
= ffecom_ptr_to_expr (ffebld_left (expr
));
2895 t
= ffecom_expr (ffebld_left (expr
));
2897 if (t
== error_mark_node
)
2900 if ((ffeinfo_where (ffebld_info (expr
)) == FFEINFO_whereFLEETING
)
2901 && !mark_addressable (t
))
2902 return error_mark_node
; /* Make sure non-const ref is to
2905 /* Build up ARRAY_REFs in reverse order (since we're column major
2906 here in Fortran land). */
2908 for (i
= 0, expr
= ffebld_right (expr
);
2910 expr
= ffebld_trail (expr
))
2911 dims
[i
++] = ffebld_head (expr
);
2913 #if FFECOM_FASTER_ARRAY_REFS
2914 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
)));
2916 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
2917 t
= ffecom_2 (PLUS_EXPR
,
2918 build_pointer_type (TREE_TYPE (array
)),
2920 size_binop (MULT_EXPR
,
2921 size_in_bytes (TREE_TYPE (array
)),
2922 size_binop (MINUS_EXPR
,
2923 ffecom_expr (dims
[i
]),
2924 TYPE_MIN_VALUE (TYPE_DOMAIN (array
)))));
2925 t
= ffecom_1 (INDIRECT_REF
,
2926 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))),
2930 t
= ffecom_2 (ARRAY_REF
,
2931 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))),
2933 ffecom_expr (dims
[--i
]));
2939 case FFEBLD_opUPLUS
:
2940 tree_type
= ffecom_tree_type
[bt
][kt
];
2941 return ffecom_1 (NOP_EXPR
, tree_type
, ffecom_expr (ffebld_left (expr
)));
2943 case FFEBLD_opPAREN
: /* ~~~Make sure Fortran rules respected here */
2944 tree_type
= ffecom_tree_type
[bt
][kt
];
2945 return ffecom_1 (NOP_EXPR
, tree_type
, ffecom_expr (ffebld_left (expr
)));
2947 case FFEBLD_opUMINUS
:
2948 tree_type
= ffecom_tree_type
[bt
][kt
];
2949 return ffecom_1 (NEGATE_EXPR
, tree_type
,
2950 ffecom_expr (ffebld_left (expr
)));
2953 tree_type
= ffecom_tree_type
[bt
][kt
];
2954 return ffecom_2 (PLUS_EXPR
, tree_type
,
2955 ffecom_expr (ffebld_left (expr
)),
2956 ffecom_expr (ffebld_right (expr
)));
2959 case FFEBLD_opSUBTRACT
:
2960 tree_type
= ffecom_tree_type
[bt
][kt
];
2961 return ffecom_2 (MINUS_EXPR
, tree_type
,
2962 ffecom_expr (ffebld_left (expr
)),
2963 ffecom_expr (ffebld_right (expr
)));
2965 case FFEBLD_opMULTIPLY
:
2966 tree_type
= ffecom_tree_type
[bt
][kt
];
2967 return ffecom_2 (MULT_EXPR
, tree_type
,
2968 ffecom_expr (ffebld_left (expr
)),
2969 ffecom_expr (ffebld_right (expr
)));
2971 case FFEBLD_opDIVIDE
:
2972 tree_type
= ffecom_tree_type
[bt
][kt
];
2974 ffecom_tree_divide_ (tree_type
,
2975 ffecom_expr (ffebld_left (expr
)),
2976 ffecom_expr (ffebld_right (expr
)),
2977 dest_tree
, dest
, dest_used
);
2979 case FFEBLD_opPOWER
:
2980 tree_type
= ffecom_tree_type
[bt
][kt
];
2982 ffebld left
= ffebld_left (expr
);
2983 ffebld right
= ffebld_right (expr
);
2985 ffeinfoKindtype rtkt
;
2987 switch (ffeinfo_basictype (ffebld_info (right
)))
2989 case FFEINFO_basictypeINTEGER
:
2992 item
= ffecom_expr_power_integer_ (left
, right
);
2993 if (item
!= NULL_TREE
)
2997 rtkt
= FFEINFO_kindtypeINTEGER1
;
2998 switch (ffeinfo_basictype (ffebld_info (left
)))
3000 case FFEINFO_basictypeINTEGER
:
3001 if ((ffeinfo_kindtype (ffebld_info (left
))
3002 == FFEINFO_kindtypeINTEGER4
)
3003 || (ffeinfo_kindtype (ffebld_info (right
))
3004 == FFEINFO_kindtypeINTEGER4
))
3006 code
= FFECOM_gfrtPOW_QQ
;
3007 rtkt
= FFEINFO_kindtypeINTEGER4
;
3010 code
= FFECOM_gfrtPOW_II
;
3013 case FFEINFO_basictypeREAL
:
3014 if (ffeinfo_kindtype (ffebld_info (left
))
3015 == FFEINFO_kindtypeREAL1
)
3016 code
= FFECOM_gfrtPOW_RI
;
3018 code
= FFECOM_gfrtPOW_DI
;
3021 case FFEINFO_basictypeCOMPLEX
:
3022 if (ffeinfo_kindtype (ffebld_info (left
))
3023 == FFEINFO_kindtypeREAL1
)
3024 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3026 code
= FFECOM_gfrtPOW_ZI
; /* Overlapping result okay. */
3030 assert ("bad pow_*i" == NULL
);
3031 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3034 if (ffeinfo_kindtype (ffebld_info (left
)) != rtkt
)
3035 left
= ffeexpr_convert (left
, NULL
, NULL
,
3036 FFEINFO_basictypeINTEGER
,
3038 FFETARGET_charactersizeNONE
,
3039 FFEEXPR_contextLET
);
3040 if (ffeinfo_kindtype (ffebld_info (right
)) != rtkt
)
3041 right
= ffeexpr_convert (right
, NULL
, NULL
,
3042 FFEINFO_basictypeINTEGER
,
3044 FFETARGET_charactersizeNONE
,
3045 FFEEXPR_contextLET
);
3048 case FFEINFO_basictypeREAL
:
3049 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3050 left
= ffeexpr_convert (left
, NULL
, NULL
, FFEINFO_basictypeREAL
,
3051 FFEINFO_kindtypeREALDOUBLE
, 0,
3052 FFETARGET_charactersizeNONE
,
3053 FFEEXPR_contextLET
);
3054 if (ffeinfo_kindtype (ffebld_info (right
))
3055 == FFEINFO_kindtypeREAL1
)
3056 right
= ffeexpr_convert (right
, NULL
, NULL
,
3057 FFEINFO_basictypeREAL
,
3058 FFEINFO_kindtypeREALDOUBLE
, 0,
3059 FFETARGET_charactersizeNONE
,
3060 FFEEXPR_contextLET
);
3061 code
= FFECOM_gfrtPOW_DD
;
3064 case FFEINFO_basictypeCOMPLEX
:
3065 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3066 left
= ffeexpr_convert (left
, NULL
, NULL
,
3067 FFEINFO_basictypeCOMPLEX
,
3068 FFEINFO_kindtypeREALDOUBLE
, 0,
3069 FFETARGET_charactersizeNONE
,
3070 FFEEXPR_contextLET
);
3071 if (ffeinfo_kindtype (ffebld_info (right
))
3072 == FFEINFO_kindtypeREAL1
)
3073 right
= ffeexpr_convert (right
, NULL
, NULL
,
3074 FFEINFO_basictypeCOMPLEX
,
3075 FFEINFO_kindtypeREALDOUBLE
, 0,
3076 FFETARGET_charactersizeNONE
,
3077 FFEEXPR_contextLET
);
3078 code
= FFECOM_gfrtPOW_ZZ
; /* Overlapping result okay. */
3082 assert ("bad pow_x*" == NULL
);
3083 code
= FFECOM_gfrtPOW_II
;
3086 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code
),
3087 ffecom_gfrt_kindtype (code
),
3088 (ffe_is_f2c_library ()
3089 && ffecom_gfrt_complex_
[code
]),
3090 tree_type
, left
, right
,
3091 dest_tree
, dest
, dest_used
,
3096 tree_type
= ffecom_tree_type
[bt
][kt
];
3099 case FFEINFO_basictypeLOGICAL
:
3101 = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr
)));
3102 return convert (tree_type
, item
);
3104 case FFEINFO_basictypeINTEGER
:
3105 return ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3106 ffecom_expr (ffebld_left (expr
)));
3109 assert ("NOT bad basictype" == NULL
);
3111 case FFEINFO_basictypeANY
:
3112 return error_mark_node
;
3116 case FFEBLD_opFUNCREF
:
3117 assert (ffeinfo_basictype (ffebld_info (expr
))
3118 != FFEINFO_basictypeCHARACTER
);
3120 case FFEBLD_opSUBRREF
:
3121 tree_type
= ffecom_tree_type
[bt
][kt
];
3122 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
3123 == FFEINFO_whereINTRINSIC
)
3124 { /* Invocation of an intrinsic. */
3125 item
= ffecom_expr_intrinsic_ (expr
, dest_tree
, dest
,
3129 s
= ffebld_symter (ffebld_left (expr
));
3130 dt
= ffesymbol_hook (s
).decl_tree
;
3131 if (dt
== NULL_TREE
)
3133 s
= ffecom_sym_transform_ (s
);
3134 dt
= ffesymbol_hook (s
).decl_tree
;
3136 if (dt
== error_mark_node
)
3139 if (ffesymbol_hook (s
).addr
)
3142 item
= ffecom_1_fn (dt
);
3144 ffecom_push_calltemps ();
3145 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
3146 args
= ffecom_list_expr (ffebld_right (expr
));
3148 args
= ffecom_list_ptr_to_expr (ffebld_right (expr
));
3149 ffecom_pop_calltemps ();
3151 item
= ffecom_call_ (item
, kt
,
3152 ffesymbol_is_f2c (s
)
3153 && (bt
== FFEINFO_basictypeCOMPLEX
)
3154 && (ffesymbol_where (s
)
3155 != FFEINFO_whereCONSTANT
),
3158 dest_tree
, dest
, dest_used
,
3159 error_mark_node
, FALSE
);
3160 TREE_SIDE_EFFECTS (item
) = 1;
3164 tree_type
= ffecom_tree_type
[bt
][kt
];
3167 case FFEINFO_basictypeLOGICAL
:
3169 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3170 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3171 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3172 return convert (tree_type
, item
);
3174 case FFEINFO_basictypeINTEGER
:
3175 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
3176 ffecom_expr (ffebld_left (expr
)),
3177 ffecom_expr (ffebld_right (expr
)));
3180 assert ("AND bad basictype" == NULL
);
3182 case FFEINFO_basictypeANY
:
3183 return error_mark_node
;
3188 tree_type
= ffecom_tree_type
[bt
][kt
];
3191 case FFEINFO_basictypeLOGICAL
:
3193 = ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
3194 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3195 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3196 return convert (tree_type
, item
);
3198 case FFEINFO_basictypeINTEGER
:
3199 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
3200 ffecom_expr (ffebld_left (expr
)),
3201 ffecom_expr (ffebld_right (expr
)));
3204 assert ("OR bad basictype" == NULL
);
3206 case FFEINFO_basictypeANY
:
3207 return error_mark_node
;
3213 tree_type
= ffecom_tree_type
[bt
][kt
];
3216 case FFEINFO_basictypeLOGICAL
:
3218 = ffecom_2 (NE_EXPR
, integer_type_node
,
3219 ffecom_expr (ffebld_left (expr
)),
3220 ffecom_expr (ffebld_right (expr
)));
3221 return convert (tree_type
, ffecom_truth_value (item
));
3223 case FFEINFO_basictypeINTEGER
:
3224 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3225 ffecom_expr (ffebld_left (expr
)),
3226 ffecom_expr (ffebld_right (expr
)));
3229 assert ("XOR/NEQV bad basictype" == NULL
);
3231 case FFEINFO_basictypeANY
:
3232 return error_mark_node
;
3237 tree_type
= ffecom_tree_type
[bt
][kt
];
3240 case FFEINFO_basictypeLOGICAL
:
3242 = ffecom_2 (EQ_EXPR
, integer_type_node
,
3243 ffecom_expr (ffebld_left (expr
)),
3244 ffecom_expr (ffebld_right (expr
)));
3245 return convert (tree_type
, ffecom_truth_value (item
));
3247 case FFEINFO_basictypeINTEGER
:
3249 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3250 ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3251 ffecom_expr (ffebld_left (expr
)),
3252 ffecom_expr (ffebld_right (expr
))));
3255 assert ("EQV bad basictype" == NULL
);
3257 case FFEINFO_basictypeANY
:
3258 return error_mark_node
;
3262 case FFEBLD_opCONVERT
:
3263 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opANY
)
3264 return error_mark_node
;
3266 tree_type
= ffecom_tree_type
[bt
][kt
];
3269 case FFEINFO_basictypeLOGICAL
:
3270 case FFEINFO_basictypeINTEGER
:
3271 case FFEINFO_basictypeREAL
:
3272 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3274 case FFEINFO_basictypeCOMPLEX
:
3275 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3277 case FFEINFO_basictypeINTEGER
:
3278 case FFEINFO_basictypeLOGICAL
:
3279 case FFEINFO_basictypeREAL
:
3280 item
= ffecom_expr (ffebld_left (expr
));
3281 if (item
== error_mark_node
)
3282 return error_mark_node
;
3283 /* convert() takes care of converting to the subtype first,
3284 at least in gcc-2.7.2. */
3285 item
= convert (tree_type
, item
);
3288 case FFEINFO_basictypeCOMPLEX
:
3289 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3292 assert ("CONVERT COMPLEX bad basictype" == NULL
);
3294 case FFEINFO_basictypeANY
:
3295 return error_mark_node
;
3300 assert ("CONVERT bad basictype" == NULL
);
3302 case FFEINFO_basictypeANY
:
3303 return error_mark_node
;
3309 goto relational
; /* :::::::::::::::::::: */
3313 goto relational
; /* :::::::::::::::::::: */
3317 goto relational
; /* :::::::::::::::::::: */
3321 goto relational
; /* :::::::::::::::::::: */
3325 goto relational
; /* :::::::::::::::::::: */
3330 relational
: /* :::::::::::::::::::: */
3332 tree_type
= ffecom_tree_type
[bt
][kt
];
3333 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3335 case FFEINFO_basictypeLOGICAL
:
3336 case FFEINFO_basictypeINTEGER
:
3337 case FFEINFO_basictypeREAL
:
3338 item
= ffecom_2 (code
, integer_type_node
,
3339 ffecom_expr (ffebld_left (expr
)),
3340 ffecom_expr (ffebld_right (expr
)));
3341 return convert (tree_type
, item
);
3343 case FFEINFO_basictypeCOMPLEX
:
3344 assert (code
== EQ_EXPR
|| code
== NE_EXPR
);
3347 tree arg1
= ffecom_expr (ffebld_left (expr
));
3348 tree arg2
= ffecom_expr (ffebld_right (expr
));
3350 if (arg1
== error_mark_node
|| arg2
== error_mark_node
)
3351 return error_mark_node
;
3353 arg1
= ffecom_save_tree (arg1
);
3354 arg2
= ffecom_save_tree (arg2
);
3356 if (TREE_CODE (TREE_TYPE (arg1
)) == COMPLEX_TYPE
)
3358 real_type
= TREE_TYPE (TREE_TYPE (arg1
));
3359 assert (real_type
== TREE_TYPE (TREE_TYPE (arg2
)));
3363 real_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1
)));
3364 assert (real_type
== TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2
))));
3368 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3369 ffecom_2 (EQ_EXPR
, integer_type_node
,
3370 ffecom_1 (REALPART_EXPR
, real_type
, arg1
),
3371 ffecom_1 (REALPART_EXPR
, real_type
, arg2
)),
3372 ffecom_2 (EQ_EXPR
, integer_type_node
,
3373 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1
),
3374 ffecom_1 (IMAGPART_EXPR
, real_type
,
3376 if (code
== EQ_EXPR
)
3377 item
= ffecom_truth_value (item
);
3379 item
= ffecom_truth_value_invert (item
);
3380 return convert (tree_type
, item
);
3383 case FFEINFO_basictypeCHARACTER
:
3384 ffecom_push_calltemps (); /* Even though we might not call. */
3387 ffebld left
= ffebld_left (expr
);
3388 ffebld right
= ffebld_right (expr
);
3394 /* f2c run-time functions do the implicit blank-padding for us,
3395 so we don't usually have to implement blank-padding ourselves.
3396 (The exception is when we pass an argument to a separately
3397 compiled statement function -- if we know the arg is not the
3398 same length as the dummy, we must truncate or extend it. If
3399 we "inline" statement functions, that necessity goes away as
3402 Strip off the CONVERT operators that blank-pad. (Truncation by
3403 CONVERT shouldn't happen here, but it can happen in
3406 while (ffebld_op (left
) == FFEBLD_opCONVERT
)
3407 left
= ffebld_left (left
);
3408 while (ffebld_op (right
) == FFEBLD_opCONVERT
)
3409 right
= ffebld_left (right
);
3411 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
3412 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
3414 if (left_tree
== error_mark_node
|| left_length
== error_mark_node
3415 || right_tree
== error_mark_node
3416 || right_length
== error_mark_node
)
3418 ffecom_pop_calltemps ();
3419 return error_mark_node
;
3422 if ((ffebld_size_known (left
) == 1)
3423 && (ffebld_size_known (right
) == 1))
3426 = ffecom_1 (INDIRECT_REF
,
3427 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3430 = ffecom_1 (INDIRECT_REF
,
3431 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3435 = ffecom_2 (code
, integer_type_node
,
3436 ffecom_2 (ARRAY_REF
,
3437 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3440 ffecom_2 (ARRAY_REF
,
3441 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3447 item
= build_tree_list (NULL_TREE
, left_tree
);
3448 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, right_tree
);
3449 TREE_CHAIN (TREE_CHAIN (item
)) = build_tree_list (NULL_TREE
,
3451 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
3452 = build_tree_list (NULL_TREE
, right_length
);
3453 item
= ffecom_call_gfrt (FFECOM_gfrtCMP
, item
);
3454 item
= ffecom_2 (code
, integer_type_node
,
3456 convert (TREE_TYPE (item
),
3457 integer_zero_node
));
3459 item
= convert (tree_type
, item
);
3462 ffecom_pop_calltemps ();
3466 assert ("relational bad basictype" == NULL
);
3468 case FFEINFO_basictypeANY
:
3469 return error_mark_node
;
3473 case FFEBLD_opPERCENT_LOC
:
3474 tree_type
= ffecom_tree_type
[bt
][kt
];
3475 item
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &list
);
3476 return convert (tree_type
, item
);
3480 case FFEBLD_opBOUNDS
:
3481 case FFEBLD_opREPEAT
:
3482 case FFEBLD_opLABTER
:
3483 case FFEBLD_opLABTOK
:
3484 case FFEBLD_opIMPDO
:
3485 case FFEBLD_opCONCATENATE
:
3486 case FFEBLD_opSUBSTR
:
3488 assert ("bad op" == NULL
);
3491 return error_mark_node
;
3495 assert ("didn't think anything got here anymore!!" == NULL
);
3497 switch (ffebld_arity (expr
))
3500 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3501 TREE_OPERAND (item
, 1) = ffecom_expr (ffebld_right (expr
));
3502 if (TREE_OPERAND (item
, 0) == error_mark_node
3503 || TREE_OPERAND (item
, 1) == error_mark_node
)
3504 return error_mark_node
;
3508 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3509 if (TREE_OPERAND (item
, 0) == error_mark_node
)
3510 return error_mark_node
;
3522 /* Returns the tree that does the intrinsic invocation.
3524 Note: this function applies only to intrinsics returning
3525 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3528 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3530 ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
3531 ffebld dest
, bool *dest_used
)
3534 tree saved_expr1
; /* For those who need it. */
3535 tree saved_expr2
; /* For those who need it. */
3536 ffeinfoBasictype bt
;
3540 tree real_type
; /* REAL type corresponding to COMPLEX. */
3542 ffebld list
= ffebld_right (expr
); /* List of (some) args. */
3543 ffebld arg1
; /* For handy reference. */
3546 ffeintrinImp codegen_imp
;
3549 assert (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
);
3551 if (dest_used
!= NULL
)
3554 bt
= ffeinfo_basictype (ffebld_info (expr
));
3555 kt
= ffeinfo_kindtype (ffebld_info (expr
));
3556 tree_type
= ffecom_tree_type
[bt
][kt
];
3560 arg1
= ffebld_head (list
);
3561 if (arg1
!= NULL
&& ffebld_op (arg1
) == FFEBLD_opANY
)
3562 return error_mark_node
;
3563 if ((list
= ffebld_trail (list
)) != NULL
)
3565 arg2
= ffebld_head (list
);
3566 if (arg2
!= NULL
&& ffebld_op (arg2
) == FFEBLD_opANY
)
3567 return error_mark_node
;
3568 if ((list
= ffebld_trail (list
)) != NULL
)
3570 arg3
= ffebld_head (list
);
3571 if (arg3
!= NULL
&& ffebld_op (arg3
) == FFEBLD_opANY
)
3572 return error_mark_node
;
3581 arg1
= arg2
= arg3
= NULL
;
3583 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3584 args. This is used by the MAX/MIN expansions. */
3587 arg1_type
= ffecom_tree_type
3588 [ffeinfo_basictype (ffebld_info (arg1
))]
3589 [ffeinfo_kindtype (ffebld_info (arg1
))];
3591 arg1_type
= NULL_TREE
; /* Really not needed, but might catch bugs
3594 /* There are several ways for each of the cases in the following switch
3595 statements to exit (from simplest to use to most complicated):
3597 break; (when expr_tree == NULL)
3599 A standard call is made to the specific intrinsic just as if it had been
3600 passed in as a dummy procedure and called as any old procedure. This
3601 method can produce slower code but in some cases it's the easiest way for
3602 now. However, if a (presumably faster) direct call is available,
3603 that is used, so this is the easiest way in many more cases now.
3605 gfrt = FFECOM_gfrtWHATEVER;
3608 gfrt contains the gfrt index of a library function to call, passing the
3609 argument(s) by value rather than by reference. Used when a more
3610 careful choice of library function is needed than that provided
3611 by the vanilla `break;'.
3615 The expr_tree has been completely set up and is ready to be returned
3616 as is. No further actions are taken. Use this when the tree is not
3617 in the simple form for one of the arity_n labels. */
3619 /* For info on how the switch statement cases were written, see the files
3620 enclosed in comments below the switch statement. */
3622 codegen_imp
= ffebld_symter_implementation (ffebld_left (expr
));
3623 gfrt
= ffeintrin_gfrt_direct (codegen_imp
);
3624 if (gfrt
== FFECOM_gfrt
)
3625 gfrt
= ffeintrin_gfrt_indirect (codegen_imp
);
3627 switch (codegen_imp
)
3629 case FFEINTRIN_impABS
:
3630 case FFEINTRIN_impCABS
:
3631 case FFEINTRIN_impCDABS
:
3632 case FFEINTRIN_impDABS
:
3633 case FFEINTRIN_impIABS
:
3634 if (ffeinfo_basictype (ffebld_info (arg1
))
3635 == FFEINFO_basictypeCOMPLEX
)
3637 if (kt
== FFEINFO_kindtypeREAL1
)
3638 gfrt
= FFECOM_gfrtCABS
;
3639 else if (kt
== FFEINFO_kindtypeREAL2
)
3640 gfrt
= FFECOM_gfrtCDABS
;
3643 return ffecom_1 (ABS_EXPR
, tree_type
,
3644 convert (tree_type
, ffecom_expr (arg1
)));
3646 case FFEINTRIN_impACOS
:
3647 case FFEINTRIN_impDACOS
:
3650 case FFEINTRIN_impAIMAG
:
3651 case FFEINTRIN_impDIMAG
:
3652 case FFEINTRIN_impIMAGPART
:
3653 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
3654 arg1_type
= TREE_TYPE (arg1_type
);
3656 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
3660 ffecom_1 (IMAGPART_EXPR
, arg1_type
,
3661 ffecom_expr (arg1
)));
3663 case FFEINTRIN_impAINT
:
3664 case FFEINTRIN_impDINT
:
3665 #if 0 /* ~~ someday implement FIX_TRUNC_EXPR
3666 yielding same type as arg */
3667 return ffecom_1 (FIX_TRUNC_EXPR
, tree_type
, ffecom_expr (arg1
));
3668 #else /* in the meantime, must use floor to avoid range problems with ints */
3669 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3670 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3673 ffecom_3 (COND_EXPR
, double_type_node
,
3675 (ffecom_2 (GE_EXPR
, integer_type_node
,
3678 ffecom_float_zero_
))),
3679 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3680 build_tree_list (NULL_TREE
,
3681 convert (double_type_node
,
3683 ffecom_1 (NEGATE_EXPR
, double_type_node
,
3684 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3685 build_tree_list (NULL_TREE
,
3686 convert (double_type_node
,
3687 ffecom_1 (NEGATE_EXPR
,
3694 case FFEINTRIN_impANINT
:
3695 case FFEINTRIN_impDNINT
:
3696 #if 0 /* This way of doing it won't handle real
3697 numbers of large magnitudes. */
3698 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3699 expr_tree
= convert (tree_type
,
3700 convert (integer_type_node
,
3701 ffecom_3 (COND_EXPR
, tree_type
,
3706 ffecom_float_zero_
)),
3707 ffecom_2 (PLUS_EXPR
,
3710 ffecom_float_half_
),
3711 ffecom_2 (MINUS_EXPR
,
3714 ffecom_float_half_
))));
3716 #else /* So we instead call floor. */
3717 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3718 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3721 ffecom_3 (COND_EXPR
, double_type_node
,
3723 (ffecom_2 (GE_EXPR
, integer_type_node
,
3726 ffecom_float_zero_
))),
3727 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3728 build_tree_list (NULL_TREE
,
3729 convert (double_type_node
,
3730 ffecom_2 (PLUS_EXPR
,
3734 ffecom_float_half_
))))),
3735 ffecom_1 (NEGATE_EXPR
, double_type_node
,
3736 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3737 build_tree_list (NULL_TREE
,
3738 convert (double_type_node
,
3739 ffecom_2 (MINUS_EXPR
,
3742 ffecom_float_half_
),
3748 case FFEINTRIN_impASIN
:
3749 case FFEINTRIN_impDASIN
:
3750 case FFEINTRIN_impATAN
:
3751 case FFEINTRIN_impDATAN
:
3752 case FFEINTRIN_impATAN2
:
3753 case FFEINTRIN_impDATAN2
:
3756 case FFEINTRIN_impCHAR
:
3757 case FFEINTRIN_impACHAR
:
3758 assert (ffecom_pending_calls_
!= 0);
3759 tempvar
= ffecom_push_tempvar (char_type_node
,
3762 tree tmv
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar
)));
3764 expr_tree
= ffecom_modify (tmv
,
3765 ffecom_2 (ARRAY_REF
, tmv
, tempvar
,
3767 convert (tmv
, ffecom_expr (arg1
)));
3769 expr_tree
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
),
3772 expr_tree
= ffecom_1 (ADDR_EXPR
,
3773 build_pointer_type (TREE_TYPE (expr_tree
)),
3777 case FFEINTRIN_impCMPLX
:
3778 case FFEINTRIN_impDCMPLX
:
3781 convert (tree_type
, ffecom_expr (arg1
));
3783 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
3785 ffecom_2 (COMPLEX_EXPR
, tree_type
,
3786 convert (real_type
, ffecom_expr (arg1
)),
3788 ffecom_expr (arg2
)));
3790 case FFEINTRIN_impCOMPLEX
:
3792 ffecom_2 (COMPLEX_EXPR
, tree_type
,
3794 ffecom_expr (arg2
));
3796 case FFEINTRIN_impCONJG
:
3797 case FFEINTRIN_impDCONJG
:
3801 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
3802 arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
3804 ffecom_2 (COMPLEX_EXPR
, tree_type
,
3805 ffecom_1 (REALPART_EXPR
, real_type
, arg1_tree
),
3806 ffecom_1 (NEGATE_EXPR
, real_type
,
3807 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1_tree
)));
3810 case FFEINTRIN_impCOS
:
3811 case FFEINTRIN_impCCOS
:
3812 case FFEINTRIN_impCDCOS
:
3813 case FFEINTRIN_impDCOS
:
3814 if (bt
== FFEINFO_basictypeCOMPLEX
)
3816 if (kt
== FFEINFO_kindtypeREAL1
)
3817 gfrt
= FFECOM_gfrtCCOS
; /* Overlapping result okay. */
3818 else if (kt
== FFEINFO_kindtypeREAL2
)
3819 gfrt
= FFECOM_gfrtCDCOS
; /* Overlapping result okay. */
3823 case FFEINTRIN_impCOSH
:
3824 case FFEINTRIN_impDCOSH
:
3827 case FFEINTRIN_impDBLE
:
3828 case FFEINTRIN_impDFLOAT
:
3829 case FFEINTRIN_impDREAL
:
3830 case FFEINTRIN_impFLOAT
:
3831 case FFEINTRIN_impIDINT
:
3832 case FFEINTRIN_impIFIX
:
3833 case FFEINTRIN_impINT2
:
3834 case FFEINTRIN_impINT8
:
3835 case FFEINTRIN_impINT
:
3836 case FFEINTRIN_impLONG
:
3837 case FFEINTRIN_impREAL
:
3838 case FFEINTRIN_impSHORT
:
3839 case FFEINTRIN_impSNGL
:
3840 return convert (tree_type
, ffecom_expr (arg1
));
3842 case FFEINTRIN_impDIM
:
3843 case FFEINTRIN_impDDIM
:
3844 case FFEINTRIN_impIDIM
:
3845 saved_expr1
= ffecom_save_tree (convert (tree_type
,
3846 ffecom_expr (arg1
)));
3847 saved_expr2
= ffecom_save_tree (convert (tree_type
,
3848 ffecom_expr (arg2
)));
3850 ffecom_3 (COND_EXPR
, tree_type
,
3852 (ffecom_2 (GT_EXPR
, integer_type_node
,
3855 ffecom_2 (MINUS_EXPR
, tree_type
,
3858 convert (tree_type
, ffecom_float_zero_
));
3860 case FFEINTRIN_impDPROD
:
3862 ffecom_2 (MULT_EXPR
, tree_type
,
3863 convert (tree_type
, ffecom_expr (arg1
)),
3864 convert (tree_type
, ffecom_expr (arg2
)));
3866 case FFEINTRIN_impEXP
:
3867 case FFEINTRIN_impCDEXP
:
3868 case FFEINTRIN_impCEXP
:
3869 case FFEINTRIN_impDEXP
:
3870 if (bt
== FFEINFO_basictypeCOMPLEX
)
3872 if (kt
== FFEINFO_kindtypeREAL1
)
3873 gfrt
= FFECOM_gfrtCEXP
; /* Overlapping result okay. */
3874 else if (kt
== FFEINFO_kindtypeREAL2
)
3875 gfrt
= FFECOM_gfrtCDEXP
; /* Overlapping result okay. */
3879 case FFEINTRIN_impICHAR
:
3880 case FFEINTRIN_impIACHAR
:
3881 #if 0 /* The simple approach. */
3882 ffecom_char_args_ (&expr_tree
, &saved_expr1
/* Ignored */ , arg1
);
3884 = ffecom_1 (INDIRECT_REF
,
3885 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
3888 = ffecom_2 (ARRAY_REF
,
3889 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
3892 return convert (tree_type
, expr_tree
);
3893 #else /* The more interesting (and more optimal) approach. */
3894 expr_tree
= ffecom_intrinsic_ichar_ (tree_type
, arg1
, &saved_expr1
);
3895 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
3898 convert (tree_type
, integer_zero_node
));
3902 case FFEINTRIN_impINDEX
:
3905 case FFEINTRIN_impLEN
:
3907 break; /* The simple approach. */
3909 return ffecom_intrinsic_len_ (arg1
); /* The more optimal approach. */
3912 case FFEINTRIN_impLGE
:
3913 case FFEINTRIN_impLGT
:
3914 case FFEINTRIN_impLLE
:
3915 case FFEINTRIN_impLLT
:
3918 case FFEINTRIN_impLOG
:
3919 case FFEINTRIN_impALOG
:
3920 case FFEINTRIN_impCDLOG
:
3921 case FFEINTRIN_impCLOG
:
3922 case FFEINTRIN_impDLOG
:
3923 if (bt
== FFEINFO_basictypeCOMPLEX
)
3925 if (kt
== FFEINFO_kindtypeREAL1
)
3926 gfrt
= FFECOM_gfrtCLOG
; /* Overlapping result okay. */
3927 else if (kt
== FFEINFO_kindtypeREAL2
)
3928 gfrt
= FFECOM_gfrtCDLOG
; /* Overlapping result okay. */
3932 case FFEINTRIN_impLOG10
:
3933 case FFEINTRIN_impALOG10
:
3934 case FFEINTRIN_impDLOG10
:
3935 if (gfrt
!= FFECOM_gfrt
)
3936 break; /* Already picked one, stick with it. */
3938 if (kt
== FFEINFO_kindtypeREAL1
)
3939 gfrt
= FFECOM_gfrtALOG10
;
3940 else if (kt
== FFEINFO_kindtypeREAL2
)
3941 gfrt
= FFECOM_gfrtDLOG10
;
3944 case FFEINTRIN_impMAX
:
3945 case FFEINTRIN_impAMAX0
:
3946 case FFEINTRIN_impAMAX1
:
3947 case FFEINTRIN_impDMAX1
:
3948 case FFEINTRIN_impMAX0
:
3949 case FFEINTRIN_impMAX1
:
3950 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
3951 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
3953 arg1_type
= tree_type
;
3954 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
3955 convert (arg1_type
, ffecom_expr (arg1
)),
3956 convert (arg1_type
, ffecom_expr (arg2
)));
3957 for (; list
!= NULL
; list
= ffebld_trail (list
))
3959 if ((ffebld_head (list
) == NULL
)
3960 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
3962 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
3965 ffecom_expr (ffebld_head (list
))));
3967 return convert (tree_type
, expr_tree
);
3969 case FFEINTRIN_impMIN
:
3970 case FFEINTRIN_impAMIN0
:
3971 case FFEINTRIN_impAMIN1
:
3972 case FFEINTRIN_impDMIN1
:
3973 case FFEINTRIN_impMIN0
:
3974 case FFEINTRIN_impMIN1
:
3975 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
3976 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
3978 arg1_type
= tree_type
;
3979 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
3980 convert (arg1_type
, ffecom_expr (arg1
)),
3981 convert (arg1_type
, ffecom_expr (arg2
)));
3982 for (; list
!= NULL
; list
= ffebld_trail (list
))
3984 if ((ffebld_head (list
) == NULL
)
3985 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
3987 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
3990 ffecom_expr (ffebld_head (list
))));
3992 return convert (tree_type
, expr_tree
);
3994 case FFEINTRIN_impMOD
:
3995 case FFEINTRIN_impAMOD
:
3996 case FFEINTRIN_impDMOD
:
3997 if (bt
!= FFEINFO_basictypeREAL
)
3998 return ffecom_2 (TRUNC_MOD_EXPR
, tree_type
,
3999 convert (tree_type
, ffecom_expr (arg1
)),
4000 convert (tree_type
, ffecom_expr (arg2
)));
4002 if (kt
== FFEINFO_kindtypeREAL1
)
4003 gfrt
= FFECOM_gfrtAMOD
;
4004 else if (kt
== FFEINFO_kindtypeREAL2
)
4005 gfrt
= FFECOM_gfrtDMOD
;
4008 case FFEINTRIN_impNINT
:
4009 case FFEINTRIN_impIDNINT
:
4010 #if 0 /* ~~ ideally FIX_ROUND_EXPR would be
4011 implemented, but it ain't yet */
4012 return ffecom_1 (FIX_ROUND_EXPR
, tree_type
, ffecom_expr (arg1
));
4014 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4015 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4017 convert (ffecom_integer_type_node
,
4018 ffecom_3 (COND_EXPR
, arg1_type
,
4020 (ffecom_2 (GE_EXPR
, integer_type_node
,
4023 ffecom_float_zero_
))),
4024 ffecom_2 (PLUS_EXPR
, arg1_type
,
4027 ffecom_float_half_
)),
4028 ffecom_2 (MINUS_EXPR
, arg1_type
,
4031 ffecom_float_half_
))));
4034 case FFEINTRIN_impSIGN
:
4035 case FFEINTRIN_impDSIGN
:
4036 case FFEINTRIN_impISIGN
:
4038 tree arg2_tree
= ffecom_expr (arg2
);
4042 (ffecom_1 (ABS_EXPR
, tree_type
,
4044 ffecom_expr (arg1
))));
4046 = ffecom_3 (COND_EXPR
, tree_type
,
4048 (ffecom_2 (GE_EXPR
, integer_type_node
,
4050 convert (TREE_TYPE (arg2_tree
),
4051 integer_zero_node
))),
4053 ffecom_1 (NEGATE_EXPR
, tree_type
, saved_expr1
));
4054 /* Make sure SAVE_EXPRs get referenced early enough. */
4056 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4057 convert (void_type_node
, saved_expr1
),
4062 case FFEINTRIN_impSIN
:
4063 case FFEINTRIN_impCDSIN
:
4064 case FFEINTRIN_impCSIN
:
4065 case FFEINTRIN_impDSIN
:
4066 if (bt
== FFEINFO_basictypeCOMPLEX
)
4068 if (kt
== FFEINFO_kindtypeREAL1
)
4069 gfrt
= FFECOM_gfrtCSIN
; /* Overlapping result okay. */
4070 else if (kt
== FFEINFO_kindtypeREAL2
)
4071 gfrt
= FFECOM_gfrtCDSIN
; /* Overlapping result okay. */
4075 case FFEINTRIN_impSINH
:
4076 case FFEINTRIN_impDSINH
:
4079 case FFEINTRIN_impSQRT
:
4080 case FFEINTRIN_impCDSQRT
:
4081 case FFEINTRIN_impCSQRT
:
4082 case FFEINTRIN_impDSQRT
:
4083 if (bt
== FFEINFO_basictypeCOMPLEX
)
4085 if (kt
== FFEINFO_kindtypeREAL1
)
4086 gfrt
= FFECOM_gfrtCSQRT
; /* Overlapping result okay. */
4087 else if (kt
== FFEINFO_kindtypeREAL2
)
4088 gfrt
= FFECOM_gfrtCDSQRT
; /* Overlapping result okay. */
4092 case FFEINTRIN_impTAN
:
4093 case FFEINTRIN_impDTAN
:
4094 case FFEINTRIN_impTANH
:
4095 case FFEINTRIN_impDTANH
:
4098 case FFEINTRIN_impREALPART
:
4099 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
4100 arg1_type
= TREE_TYPE (arg1_type
);
4102 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
4106 ffecom_1 (REALPART_EXPR
, arg1_type
,
4107 ffecom_expr (arg1
)));
4109 case FFEINTRIN_impIAND
:
4110 case FFEINTRIN_impAND
:
4111 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
4113 ffecom_expr (arg1
)),
4115 ffecom_expr (arg2
)));
4117 case FFEINTRIN_impIOR
:
4118 case FFEINTRIN_impOR
:
4119 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4121 ffecom_expr (arg1
)),
4123 ffecom_expr (arg2
)));
4125 case FFEINTRIN_impIEOR
:
4126 case FFEINTRIN_impXOR
:
4127 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
4129 ffecom_expr (arg1
)),
4131 ffecom_expr (arg2
)));
4133 case FFEINTRIN_impLSHIFT
:
4134 return ffecom_2 (LSHIFT_EXPR
, tree_type
,
4136 convert (integer_type_node
,
4137 ffecom_expr (arg2
)));
4139 case FFEINTRIN_impRSHIFT
:
4140 return ffecom_2 (RSHIFT_EXPR
, tree_type
,
4142 convert (integer_type_node
,
4143 ffecom_expr (arg2
)));
4145 case FFEINTRIN_impNOT
:
4146 return ffecom_1 (BIT_NOT_EXPR
, tree_type
, ffecom_expr (arg1
));
4148 case FFEINTRIN_impBIT_SIZE
:
4149 return convert (tree_type
, TYPE_SIZE (arg1_type
));
4151 case FFEINTRIN_impBTEST
:
4153 ffetargetLogical1
true;
4154 ffetargetLogical1
false;
4158 ffetarget_logical1 (&true, TRUE
);
4159 ffetarget_logical1 (&false, FALSE
);
4161 true_tree
= convert (tree_type
, integer_one_node
);
4163 true_tree
= convert (tree_type
, build_int_2 (true, 0));
4165 false_tree
= convert (tree_type
, integer_zero_node
);
4167 false_tree
= convert (tree_type
, build_int_2 (false, 0));
4170 ffecom_3 (COND_EXPR
, tree_type
,
4172 (ffecom_2 (EQ_EXPR
, integer_type_node
,
4173 ffecom_2 (BIT_AND_EXPR
, arg1_type
,
4175 ffecom_2 (LSHIFT_EXPR
, arg1_type
,
4178 convert (integer_type_node
,
4179 ffecom_expr (arg2
)))),
4181 integer_zero_node
))),
4186 case FFEINTRIN_impIBCLR
:
4188 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4190 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4191 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4194 convert (integer_type_node
,
4195 ffecom_expr (arg2
)))));
4197 case FFEINTRIN_impIBITS
:
4199 tree arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4200 ffecom_expr (arg3
)));
4202 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4205 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4206 ffecom_2 (RSHIFT_EXPR
, tree_type
,
4208 convert (integer_type_node
,
4209 ffecom_expr (arg2
))),
4211 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4212 ffecom_1 (BIT_NOT_EXPR
,
4215 integer_zero_node
)),
4216 ffecom_2 (MINUS_EXPR
,
4218 TYPE_SIZE (uns_type
),
4220 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4222 = ffecom_3 (COND_EXPR
, tree_type
,
4224 (ffecom_2 (NE_EXPR
, integer_type_node
,
4226 integer_zero_node
)),
4228 convert (tree_type
, integer_zero_node
));
4233 case FFEINTRIN_impIBSET
:
4235 ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4237 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4238 convert (tree_type
, integer_one_node
),
4239 convert (integer_type_node
,
4240 ffecom_expr (arg2
))));
4242 case FFEINTRIN_impISHFT
:
4244 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4245 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4246 ffecom_expr (arg2
)));
4248 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4251 = ffecom_3 (COND_EXPR
, tree_type
,
4253 (ffecom_2 (GE_EXPR
, integer_type_node
,
4255 integer_zero_node
)),
4256 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4260 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4261 convert (uns_type
, arg1_tree
),
4262 ffecom_1 (NEGATE_EXPR
,
4265 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4267 = ffecom_3 (COND_EXPR
, tree_type
,
4269 (ffecom_2 (NE_EXPR
, integer_type_node
,
4271 TYPE_SIZE (uns_type
))),
4273 convert (tree_type
, integer_zero_node
));
4275 /* Make sure SAVE_EXPRs get referenced early enough. */
4277 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4278 convert (void_type_node
, arg1_tree
),
4279 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4280 convert (void_type_node
, arg2_tree
),
4285 case FFEINTRIN_impISHFTC
:
4287 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4288 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4289 ffecom_expr (arg2
)));
4290 tree arg3_tree
= (arg3
== NULL
) ? TYPE_SIZE (tree_type
)
4291 : ffecom_save_tree (convert (integer_type_node
, ffecom_expr (arg3
)));
4297 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4300 = ffecom_2 (LSHIFT_EXPR
, tree_type
,
4301 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4302 convert (tree_type
, integer_zero_node
)),
4304 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4306 = ffecom_3 (COND_EXPR
, tree_type
,
4308 (ffecom_2 (NE_EXPR
, integer_type_node
,
4310 TYPE_SIZE (uns_type
))),
4312 convert (tree_type
, integer_zero_node
));
4314 mask_arg1
= ffecom_save_tree (mask_arg1
);
4316 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4318 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4320 masked_arg1
= ffecom_save_tree (masked_arg1
);
4322 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4324 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4325 convert (uns_type
, masked_arg1
),
4326 ffecom_1 (NEGATE_EXPR
,
4329 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4331 ffecom_2 (PLUS_EXPR
, integer_type_node
,
4335 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4336 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4340 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4341 convert (uns_type
, masked_arg1
),
4342 ffecom_2 (MINUS_EXPR
,
4347 = ffecom_3 (COND_EXPR
, tree_type
,
4349 (ffecom_2 (LT_EXPR
, integer_type_node
,
4351 integer_zero_node
)),
4355 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4356 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4359 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4360 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4364 = ffecom_3 (COND_EXPR
, tree_type
,
4366 (ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
4367 ffecom_2 (EQ_EXPR
, integer_type_node
,
4372 ffecom_2 (EQ_EXPR
, integer_type_node
,
4374 integer_zero_node
))),
4377 /* Make sure SAVE_EXPRs get referenced early enough. */
4379 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4380 convert (void_type_node
, arg1_tree
),
4381 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4382 convert (void_type_node
, arg2_tree
),
4383 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4384 convert (void_type_node
,
4386 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4387 convert (void_type_node
,
4391 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4392 convert (void_type_node
,
4398 case FFEINTRIN_impLOC
:
4400 tree arg1_tree
= ffecom_expr (arg1
);
4403 = convert (tree_type
,
4404 ffecom_1 (ADDR_EXPR
,
4405 build_pointer_type (TREE_TYPE (arg1_tree
)),
4410 case FFEINTRIN_impMVBITS
:
4415 ffebld arg4
= ffebld_head (ffebld_trail (list
));
4418 ffebld arg5
= ffebld_head (ffebld_trail (ffebld_trail (list
)));
4422 tree arg5_plus_arg3
;
4424 ffecom_push_calltemps ();
4426 arg2_tree
= convert (integer_type_node
,
4427 ffecom_expr (arg2
));
4428 arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4429 ffecom_expr (arg3
)));
4430 arg4_tree
= ffecom_expr_rw (arg4
);
4431 arg4_type
= TREE_TYPE (arg4_tree
);
4433 arg1_tree
= ffecom_save_tree (convert (arg4_type
,
4434 ffecom_expr (arg1
)));
4436 arg5_tree
= ffecom_save_tree (convert (integer_type_node
,
4437 ffecom_expr (arg5
)));
4439 ffecom_pop_calltemps ();
4442 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4443 ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4444 ffecom_2 (RSHIFT_EXPR
, arg4_type
,
4447 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4448 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4449 ffecom_1 (BIT_NOT_EXPR
,
4453 integer_zero_node
)),
4457 = ffecom_save_tree (ffecom_2 (PLUS_EXPR
, arg4_type
,
4461 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4462 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4464 integer_zero_node
)),
4466 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4468 = ffecom_3 (COND_EXPR
, arg4_type
,
4470 (ffecom_2 (NE_EXPR
, integer_type_node
,
4472 convert (TREE_TYPE (arg5_plus_arg3
),
4473 TYPE_SIZE (arg4_type
)))),
4475 convert (arg4_type
, integer_zero_node
));
4478 = ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4480 ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4482 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4483 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4484 ffecom_1 (BIT_NOT_EXPR
,
4488 integer_zero_node
)),
4491 = ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4494 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4496 = ffecom_3 (COND_EXPR
, arg4_type
,
4498 (ffecom_2 (NE_EXPR
, integer_type_node
,
4500 convert (TREE_TYPE (arg3_tree
),
4501 integer_zero_node
))),
4505 = ffecom_3 (COND_EXPR
, arg4_type
,
4507 (ffecom_2 (NE_EXPR
, integer_type_node
,
4509 convert (TREE_TYPE (arg3_tree
),
4510 TYPE_SIZE (arg4_type
)))),
4515 = ffecom_2s (MODIFY_EXPR
, void_type_node
,
4518 /* Make sure SAVE_EXPRs get referenced early enough. */
4520 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4522 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4524 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4526 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4530 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4537 case FFEINTRIN_impDERF
:
4538 case FFEINTRIN_impERF
:
4539 case FFEINTRIN_impDERFC
:
4540 case FFEINTRIN_impERFC
:
4543 case FFEINTRIN_impIARGC
:
4544 /* extern int xargc; i__1 = xargc - 1; */
4545 expr_tree
= ffecom_2 (MINUS_EXPR
, TREE_TYPE (ffecom_tree_xargc_
),
4547 convert (TREE_TYPE (ffecom_tree_xargc_
),
4551 case FFEINTRIN_impSIGNAL_func
:
4552 case FFEINTRIN_impSIGNAL_subr
:
4558 ffecom_push_calltemps ();
4560 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4561 ffecom_expr (arg1
));
4562 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4563 build_pointer_type (TREE_TYPE (arg1_tree
)),
4566 /* Pass procedure as a pointer to it, anything else by value. */
4567 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4568 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4570 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4571 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4575 arg3_tree
= ffecom_expr_rw (arg3
);
4577 arg3_tree
= NULL_TREE
;
4579 ffecom_pop_calltemps ();
4581 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4582 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4583 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4586 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4587 ffecom_gfrt_kindtype (gfrt
),
4589 ((codegen_imp
== FFEINTRIN_impSIGNAL_subr
) ?
4593 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4595 if (arg3_tree
!= NULL_TREE
)
4597 = ffecom_modify (NULL_TREE
, arg3_tree
,
4598 convert (TREE_TYPE (arg3_tree
),
4603 case FFEINTRIN_impALARM
:
4609 ffecom_push_calltemps ();
4611 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4612 ffecom_expr (arg1
));
4613 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4614 build_pointer_type (TREE_TYPE (arg1_tree
)),
4617 /* Pass procedure as a pointer to it, anything else by value. */
4618 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4619 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4621 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4622 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4626 arg3_tree
= ffecom_expr_rw (arg3
);
4628 arg3_tree
= NULL_TREE
;
4630 ffecom_pop_calltemps ();
4632 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4633 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4634 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4637 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4638 ffecom_gfrt_kindtype (gfrt
),
4642 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4644 if (arg3_tree
!= NULL_TREE
)
4646 = ffecom_modify (NULL_TREE
, arg3_tree
,
4647 convert (TREE_TYPE (arg3_tree
),
4652 case FFEINTRIN_impCHDIR_subr
:
4653 case FFEINTRIN_impFDATE_subr
:
4654 case FFEINTRIN_impFGET_subr
:
4655 case FFEINTRIN_impFPUT_subr
:
4656 case FFEINTRIN_impGETCWD_subr
:
4657 case FFEINTRIN_impHOSTNM_subr
:
4658 case FFEINTRIN_impSYSTEM_subr
:
4659 case FFEINTRIN_impUNLINK_subr
:
4661 tree arg1_len
= integer_zero_node
;
4665 ffecom_push_calltemps ();
4667 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4670 arg2_tree
= ffecom_expr_rw (arg2
);
4672 arg2_tree
= NULL_TREE
;
4674 ffecom_pop_calltemps ();
4676 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4677 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4678 TREE_CHAIN (arg1_tree
) = arg1_len
;
4681 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4682 ffecom_gfrt_kindtype (gfrt
),
4686 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4688 if (arg2_tree
!= NULL_TREE
)
4690 = ffecom_modify (NULL_TREE
, arg2_tree
,
4691 convert (TREE_TYPE (arg2_tree
),
4696 case FFEINTRIN_impEXIT
:
4700 expr_tree
= build_tree_list (NULL_TREE
,
4701 ffecom_1 (ADDR_EXPR
,
4703 (ffecom_integer_type_node
),
4704 integer_zero_node
));
4707 ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4708 ffecom_gfrt_kindtype (gfrt
),
4712 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4714 case FFEINTRIN_impFLUSH
:
4716 gfrt
= FFECOM_gfrtFLUSH
;
4718 gfrt
= FFECOM_gfrtFLUSH1
;
4721 case FFEINTRIN_impCHMOD_subr
:
4722 case FFEINTRIN_impLINK_subr
:
4723 case FFEINTRIN_impRENAME_subr
:
4724 case FFEINTRIN_impSYMLNK_subr
:
4726 tree arg1_len
= integer_zero_node
;
4728 tree arg2_len
= integer_zero_node
;
4732 ffecom_push_calltemps ();
4734 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4735 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
4737 arg3_tree
= ffecom_expr_rw (arg3
);
4739 arg3_tree
= NULL_TREE
;
4741 ffecom_pop_calltemps ();
4743 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4744 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4745 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4746 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
4747 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4748 TREE_CHAIN (arg2_tree
) = arg1_len
;
4749 TREE_CHAIN (arg1_len
) = arg2_len
;
4750 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4751 ffecom_gfrt_kindtype (gfrt
),
4755 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4756 if (arg3_tree
!= NULL_TREE
)
4757 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4758 convert (TREE_TYPE (arg3_tree
),
4763 case FFEINTRIN_impLSTAT_subr
:
4764 case FFEINTRIN_impSTAT_subr
:
4766 tree arg1_len
= integer_zero_node
;
4771 ffecom_push_calltemps ();
4773 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4775 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4778 arg3_tree
= ffecom_expr_rw (arg3
);
4780 arg3_tree
= NULL_TREE
;
4782 ffecom_pop_calltemps ();
4784 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4785 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4786 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4787 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4788 TREE_CHAIN (arg2_tree
) = arg1_len
;
4789 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4790 ffecom_gfrt_kindtype (gfrt
),
4794 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4795 if (arg3_tree
!= NULL_TREE
)
4796 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4797 convert (TREE_TYPE (arg3_tree
),
4802 case FFEINTRIN_impFGETC_subr
:
4803 case FFEINTRIN_impFPUTC_subr
:
4807 tree arg2_len
= integer_zero_node
;
4810 ffecom_push_calltemps ();
4812 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4813 ffecom_expr (arg1
));
4814 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4815 build_pointer_type (TREE_TYPE (arg1_tree
)),
4818 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
4819 arg3_tree
= ffecom_expr_rw (arg3
);
4821 ffecom_pop_calltemps ();
4823 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4824 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4825 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
4826 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4827 TREE_CHAIN (arg2_tree
) = arg2_len
;
4829 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4830 ffecom_gfrt_kindtype (gfrt
),
4834 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4835 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4836 convert (TREE_TYPE (arg3_tree
),
4841 case FFEINTRIN_impFSTAT_subr
:
4847 ffecom_push_calltemps ();
4849 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4850 ffecom_expr (arg1
));
4851 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4852 build_pointer_type (TREE_TYPE (arg1_tree
)),
4855 arg2_tree
= convert (ffecom_f2c_ptr_to_integer_type_node
,
4856 ffecom_ptr_to_expr (arg2
));
4859 arg3_tree
= NULL_TREE
;
4861 arg3_tree
= ffecom_expr_rw (arg3
);
4863 ffecom_pop_calltemps ();
4865 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4866 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4867 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4868 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4869 ffecom_gfrt_kindtype (gfrt
),
4873 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4874 if (arg3_tree
!= NULL_TREE
) {
4875 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4876 convert (TREE_TYPE (arg3_tree
),
4882 case FFEINTRIN_impKILL_subr
:
4888 ffecom_push_calltemps ();
4890 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4891 ffecom_expr (arg1
));
4892 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4893 build_pointer_type (TREE_TYPE (arg1_tree
)),
4896 arg2_tree
= convert (ffecom_f2c_integer_type_node
,
4897 ffecom_expr (arg2
));
4898 arg2_tree
= ffecom_1 (ADDR_EXPR
,
4899 build_pointer_type (TREE_TYPE (arg2_tree
)),
4903 arg3_tree
= NULL_TREE
;
4905 arg3_tree
= ffecom_expr_rw (arg3
);
4907 ffecom_pop_calltemps ();
4909 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4910 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4911 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4912 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4913 ffecom_gfrt_kindtype (gfrt
),
4917 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4918 if (arg3_tree
!= NULL_TREE
) {
4919 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4920 convert (TREE_TYPE (arg3_tree
),
4926 case FFEINTRIN_impCTIME_subr
:
4927 case FFEINTRIN_impTTYNAM_subr
:
4929 tree arg1_len
= integer_zero_node
;
4933 ffecom_push_calltemps ();
4935 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4937 arg2_tree
= convert (((gfrt
== FFEINTRIN_impCTIME_subr
) ?
4938 ffecom_f2c_longint_type_node
:
4939 ffecom_f2c_integer_type_node
),
4940 ffecom_expr (arg2
));
4941 arg2_tree
= ffecom_1 (ADDR_EXPR
,
4942 build_pointer_type (TREE_TYPE (arg2_tree
)),
4945 ffecom_pop_calltemps ();
4947 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4948 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4949 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4950 TREE_CHAIN (arg1_len
) = arg2_tree
;
4951 TREE_CHAIN (arg1_tree
) = arg1_len
;
4954 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4955 ffecom_gfrt_kindtype (gfrt
),
4959 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4963 case FFEINTRIN_impIRAND
:
4964 case FFEINTRIN_impRAND
:
4965 /* Arg defaults to 0 (normal random case) */
4970 arg1_tree
= ffecom_integer_zero_node
;
4972 arg1_tree
= ffecom_expr (arg1
);
4973 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4975 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4976 build_pointer_type (TREE_TYPE (arg1_tree
)),
4978 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4980 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4981 ffecom_gfrt_kindtype (gfrt
),
4983 ((codegen_imp
== FFEINTRIN_impIRAND
) ?
4984 ffecom_f2c_integer_type_node
:
4985 ffecom_f2c_doublereal_type_node
),
4987 dest_tree
, dest
, dest_used
,
4992 case FFEINTRIN_impFTELL_subr
:
4993 case FFEINTRIN_impUMASK_subr
:
4998 ffecom_push_calltemps ();
5000 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5001 ffecom_expr (arg1
));
5002 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5003 build_pointer_type (TREE_TYPE (arg1_tree
)),
5007 arg2_tree
= NULL_TREE
;
5009 arg2_tree
= ffecom_expr_rw (arg2
);
5011 ffecom_pop_calltemps ();
5013 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5014 ffecom_gfrt_kindtype (gfrt
),
5017 build_tree_list (NULL_TREE
, arg1_tree
),
5018 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5020 if (arg2_tree
!= NULL_TREE
) {
5021 expr_tree
= ffecom_modify (NULL_TREE
, arg2_tree
,
5022 convert (TREE_TYPE (arg2_tree
),
5028 case FFEINTRIN_impCPU_TIME
:
5029 case FFEINTRIN_impSECOND_subr
:
5033 ffecom_push_calltemps ();
5035 arg1_tree
= ffecom_expr_rw (arg1
);
5037 ffecom_pop_calltemps ();
5040 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5041 ffecom_gfrt_kindtype (gfrt
),
5045 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
5048 = ffecom_modify (NULL_TREE
, arg1_tree
,
5049 convert (TREE_TYPE (arg1_tree
),
5054 case FFEINTRIN_impDTIME_subr
:
5055 case FFEINTRIN_impETIME_subr
:
5060 ffecom_push_calltemps ();
5062 arg1_tree
= ffecom_expr_rw (arg1
);
5064 arg2_tree
= ffecom_ptr_to_expr (arg2
);
5066 ffecom_pop_calltemps ();
5068 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5069 ffecom_gfrt_kindtype (gfrt
),
5072 build_tree_list (NULL_TREE
, arg2_tree
),
5073 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5075 expr_tree
= ffecom_modify (NULL_TREE
, arg1_tree
,
5076 convert (TREE_TYPE (arg1_tree
),
5081 /* Straightforward calls of libf2c routines: */
5082 case FFEINTRIN_impABORT
:
5083 case FFEINTRIN_impACCESS
:
5084 case FFEINTRIN_impBESJ0
:
5085 case FFEINTRIN_impBESJ1
:
5086 case FFEINTRIN_impBESJN
:
5087 case FFEINTRIN_impBESY0
:
5088 case FFEINTRIN_impBESY1
:
5089 case FFEINTRIN_impBESYN
:
5090 case FFEINTRIN_impCHDIR_func
:
5091 case FFEINTRIN_impCHMOD_func
:
5092 case FFEINTRIN_impDATE
:
5093 case FFEINTRIN_impDBESJ0
:
5094 case FFEINTRIN_impDBESJ1
:
5095 case FFEINTRIN_impDBESJN
:
5096 case FFEINTRIN_impDBESY0
:
5097 case FFEINTRIN_impDBESY1
:
5098 case FFEINTRIN_impDBESYN
:
5099 case FFEINTRIN_impDTIME_func
:
5100 case FFEINTRIN_impETIME_func
:
5101 case FFEINTRIN_impFGETC_func
:
5102 case FFEINTRIN_impFGET_func
:
5103 case FFEINTRIN_impFNUM
:
5104 case FFEINTRIN_impFPUTC_func
:
5105 case FFEINTRIN_impFPUT_func
:
5106 case FFEINTRIN_impFSEEK
:
5107 case FFEINTRIN_impFSTAT_func
:
5108 case FFEINTRIN_impFTELL_func
:
5109 case FFEINTRIN_impGERROR
:
5110 case FFEINTRIN_impGETARG
:
5111 case FFEINTRIN_impGETCWD_func
:
5112 case FFEINTRIN_impGETENV
:
5113 case FFEINTRIN_impGETGID
:
5114 case FFEINTRIN_impGETLOG
:
5115 case FFEINTRIN_impGETPID
:
5116 case FFEINTRIN_impGETUID
:
5117 case FFEINTRIN_impGMTIME
:
5118 case FFEINTRIN_impHOSTNM_func
:
5119 case FFEINTRIN_impIDATE_unix
:
5120 case FFEINTRIN_impIDATE_vxt
:
5121 case FFEINTRIN_impIERRNO
:
5122 case FFEINTRIN_impISATTY
:
5123 case FFEINTRIN_impITIME
:
5124 case FFEINTRIN_impKILL_func
:
5125 case FFEINTRIN_impLINK_func
:
5126 case FFEINTRIN_impLNBLNK
:
5127 case FFEINTRIN_impLSTAT_func
:
5128 case FFEINTRIN_impLTIME
:
5129 case FFEINTRIN_impMCLOCK8
:
5130 case FFEINTRIN_impMCLOCK
:
5131 case FFEINTRIN_impPERROR
:
5132 case FFEINTRIN_impRENAME_func
:
5133 case FFEINTRIN_impSECNDS
:
5134 case FFEINTRIN_impSECOND_func
:
5135 case FFEINTRIN_impSLEEP
:
5136 case FFEINTRIN_impSRAND
:
5137 case FFEINTRIN_impSTAT_func
:
5138 case FFEINTRIN_impSYMLNK_func
:
5139 case FFEINTRIN_impSYSTEM_CLOCK
:
5140 case FFEINTRIN_impSYSTEM_func
:
5141 case FFEINTRIN_impTIME8
:
5142 case FFEINTRIN_impTIME_unix
:
5143 case FFEINTRIN_impTIME_vxt
:
5144 case FFEINTRIN_impUMASK_func
:
5145 case FFEINTRIN_impUNLINK_func
:
5148 case FFEINTRIN_impCTIME_func
: /* CHARACTER functions not handled here. */
5149 case FFEINTRIN_impFDATE_func
: /* CHARACTER functions not handled here. */
5150 case FFEINTRIN_impTTYNAM_func
: /* CHARACTER functions not handled here. */
5151 case FFEINTRIN_impNONE
:
5152 case FFEINTRIN_imp
: /* Hush up gcc warning. */
5153 fprintf (stderr
, "No %s implementation.\n",
5154 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr
))));
5155 assert ("unimplemented intrinsic" == NULL
);
5156 return error_mark_node
;
5159 assert (gfrt
!= FFECOM_gfrt
); /* Must have an implementation! */
5161 ffecom_push_calltemps ();
5162 expr_tree
= ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt
),
5163 ffebld_right (expr
));
5164 ffecom_pop_calltemps ();
5166 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt
), ffecom_gfrt_kindtype (gfrt
),
5167 (ffe_is_f2c_library () && ffecom_gfrt_complex_
[gfrt
]),
5169 expr_tree
, dest_tree
, dest
, dest_used
,
5172 /**INDENT* (Do not reformat this comment even with -fca option.)
5173 Data-gathering files: Given the source file listed below, compiled with
5174 f2c I obtained the output file listed after that, and from the output
5175 file I derived the above code.
5177 -------- (begin input file to f2c)
5183 double precision D1,D2
5185 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
5214 c FFEINTRIN_impAIMAG
5215 call fooR(AIMAG(C1))
5220 c FFEINTRIN_impALOG10
5221 call fooR(ALOG10(R1))
5222 c FFEINTRIN_impAMAX0
5223 call fooR(AMAX0(I1,I2))
5224 c FFEINTRIN_impAMAX1
5225 call fooR(AMAX1(R1,R2))
5226 c FFEINTRIN_impAMIN0
5227 call fooR(AMIN0(I1,I2))
5228 c FFEINTRIN_impAMIN1
5229 call fooR(AMIN1(R1,R2))
5231 call fooR(AMOD(R1,R2))
5232 c FFEINTRIN_impANINT
5233 call fooR(ANINT(R1))
5238 c FFEINTRIN_impATAN2
5239 call fooR(ATAN2(R1,R2))
5250 c FFEINTRIN_impCONJG
5251 call fooC(CONJG(C1))
5258 c FFEINTRIN_impCSQRT
5259 call fooC(CSQRT(C1))
5262 c FFEINTRIN_impDACOS
5263 call fooD(DACOS(D1))
5264 c FFEINTRIN_impDASIN
5265 call fooD(DASIN(D1))
5266 c FFEINTRIN_impDATAN
5267 call fooD(DATAN(D1))
5268 c FFEINTRIN_impDATAN2
5269 call fooD(DATAN2(D1,D2))
5272 c FFEINTRIN_impDCOSH
5273 call fooD(DCOSH(D1))
5275 call fooD(DDIM(D1,D2))
5279 call fooR(DIM(R1,R2))
5284 c FFEINTRIN_impDLOG10
5285 call fooD(DLOG10(D1))
5286 c FFEINTRIN_impDMAX1
5287 call fooD(DMAX1(D1,D2))
5288 c FFEINTRIN_impDMIN1
5289 call fooD(DMIN1(D1,D2))
5291 call fooD(DMOD(D1,D2))
5292 c FFEINTRIN_impDNINT
5293 call fooD(DNINT(D1))
5294 c FFEINTRIN_impDPROD
5295 call fooD(DPROD(R1,R2))
5296 c FFEINTRIN_impDSIGN
5297 call fooD(DSIGN(D1,D2))
5300 c FFEINTRIN_impDSINH
5301 call fooD(DSINH(D1))
5302 c FFEINTRIN_impDSQRT
5303 call fooD(DSQRT(D1))
5306 c FFEINTRIN_impDTANH
5307 call fooD(DTANH(D1))
5312 c FFEINTRIN_impICHAR
5313 call fooI(ICHAR(A1))
5315 call fooI(IDIM(I1,I2))
5316 c FFEINTRIN_impIDNINT
5317 call fooI(IDNINT(D1))
5318 c FFEINTRIN_impINDEX
5319 call fooI(INDEX(A1,A2))
5320 c FFEINTRIN_impISIGN
5321 call fooI(ISIGN(I1,I2))
5325 call fooL(LGE(A1,A2))
5327 call fooL(LGT(A1,A2))
5329 call fooL(LLE(A1,A2))
5331 call fooL(LLT(A1,A2))
5333 call fooI(MAX0(I1,I2))
5335 call fooI(MAX1(R1,R2))
5337 call fooI(MIN0(I1,I2))
5339 call fooI(MIN1(R1,R2))
5341 call fooI(MOD(I1,I2))
5345 call fooR(SIGN(R1,R2))
5356 c FFEINTRIN_imp_CMPLX_C
5357 call fooC(cmplx(C1,C2))
5358 c FFEINTRIN_imp_CMPLX_D
5359 call fooZ(cmplx(D1,D2))
5360 c FFEINTRIN_imp_CMPLX_I
5361 call fooC(cmplx(I1,I2))
5362 c FFEINTRIN_imp_CMPLX_R
5363 call fooC(cmplx(R1,R2))
5364 c FFEINTRIN_imp_DBLE_C
5366 c FFEINTRIN_imp_DBLE_D
5368 c FFEINTRIN_imp_DBLE_I
5370 c FFEINTRIN_imp_DBLE_R
5372 c FFEINTRIN_imp_INT_C
5374 c FFEINTRIN_imp_INT_D
5376 c FFEINTRIN_imp_INT_I
5378 c FFEINTRIN_imp_INT_R
5380 c FFEINTRIN_imp_REAL_C
5382 c FFEINTRIN_imp_REAL_D
5384 c FFEINTRIN_imp_REAL_I
5386 c FFEINTRIN_imp_REAL_R
5389 c FFEINTRIN_imp_INT_D:
5391 c FFEINTRIN_specIDINT
5392 call fooI(IDINT(D1))
5394 c FFEINTRIN_imp_INT_R:
5396 c FFEINTRIN_specIFIX
5401 c FFEINTRIN_imp_REAL_D:
5403 c FFEINTRIN_specSNGL
5406 c FFEINTRIN_imp_REAL_I:
5408 c FFEINTRIN_specFLOAT
5409 call fooR(FLOAT(I1))
5410 c FFEINTRIN_specREAL
5414 -------- (end input file to f2c)
5416 -------- (begin output from providing above input file as input to:
5417 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
5418 -------- -e "s:^#.*$::g"')
5420 // -- translated by f2c (version 19950223).
5421 You must link the resulting object file with the libraries:
5422 -lf2c -lm (in that order)
5426 // f2c.h -- Standard Fortran to C header file //
5428 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
5430 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
5435 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
5436 // we assume short, float are OK //
5437 typedef long int // long int // integer;
5438 typedef char *address;
5439 typedef short int shortint;
5441 typedef double doublereal;
5442 typedef struct { real r, i; } complex;
5443 typedef struct { doublereal r, i; } doublecomplex;
5444 typedef long int // long int // logical;
5445 typedef short int shortlogical;
5446 typedef char logical1;
5447 typedef char integer1;
5448 // typedef long long longint; // // system-dependent //
5453 // Extern is for use with -E //
5467 typedef long int // int or long int // flag;
5468 typedef long int // int or long int // ftnlen;
5469 typedef long int // int or long int // ftnint;
5472 //external read, write//
5481 //internal read, write//
5511 //rewind, backspace, endfile//
5523 ftnint *inex; //parameters in standard's order//
5549 union Multitype { // for multiple entry points //
5560 typedef union Multitype Multitype;
5562 typedef long Long; // No longer used; formerly in Namelist //
5564 struct Vardesc { // for Namelist //
5570 typedef struct Vardesc Vardesc;
5577 typedef struct Namelist Namelist;
5586 // procedure parameter types for -A and -C++ //
5591 typedef int // Unknown procedure type // (*U_fp)();
5592 typedef shortint (*J_fp)();
5593 typedef integer (*I_fp)();
5594 typedef real (*R_fp)();
5595 typedef doublereal (*D_fp)(), (*E_fp)();
5596 typedef // Complex // void (*C_fp)();
5597 typedef // Double Complex // void (*Z_fp)();
5598 typedef logical (*L_fp)();
5599 typedef shortlogical (*K_fp)();
5600 typedef // Character // void (*H_fp)();
5601 typedef // Subroutine // int (*S_fp)();
5603 // E_fp is for real functions when -R is not specified //
5604 typedef void C_f; // complex function //
5605 typedef void H_f; // character function //
5606 typedef void Z_f; // double complex function //
5607 typedef doublereal E_f; // real function with -R not specified //
5609 // undef any lower-case symbols that your C compiler predefines, e.g.: //
5612 // (No such symbols should be defined in a strict ANSI C compiler.
5613 We can avoid trouble with f2c-translated code by using
5614 gcc -ansi [-traditional].) //
5638 // Main program // MAIN__()
5640 // System generated locals //
5643 doublereal d__1, d__2;
5645 doublecomplex z__1, z__2, z__3;
5649 // Builtin functions //
5652 double pow_ri(), pow_di();
5656 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
5657 asin(), atan(), atan2(), c_abs();
5658 void c_cos(), c_exp(), c_log(), r_cnjg();
5659 double cos(), cosh();
5660 void c_sin(), c_sqrt();
5661 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
5662 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
5663 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
5664 logical l_ge(), l_gt(), l_le(), l_lt();
5668 // Local variables //
5669 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
5670 fool_(), fooz_(), getem_();
5671 static char a1[10], a2[10];
5672 static complex c1, c2;
5673 static doublereal d1, d2;
5674 static integer i1, i2;
5678 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
5686 d__1 = (doublereal) i1;
5687 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
5697 c_div(&q__1, &c1, &c2);
5699 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
5701 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
5704 i__1 = pow_ii(&i1, &i2);
5706 r__1 = pow_ri(&r1, &i1);
5708 d__1 = pow_di(&d1, &i1);
5710 pow_ci(&q__1, &c1, &i1);
5712 d__1 = (doublereal) r1;
5713 d__2 = (doublereal) r2;
5714 r__1 = pow_dd(&d__1, &d__2);
5716 d__2 = (doublereal) r1;
5717 d__1 = pow_dd(&d__2, &d1);
5719 d__1 = pow_dd(&d1, &d2);
5721 d__2 = (doublereal) r1;
5722 d__1 = pow_dd(&d1, &d__2);
5724 z__2.r = c1.r, z__2.i = c1.i;
5725 z__3.r = c2.r, z__3.i = c2.i;
5726 pow_zz(&z__1, &z__2, &z__3);
5727 q__1.r = z__1.r, q__1.i = z__1.i;
5729 z__2.r = c1.r, z__2.i = c1.i;
5730 z__3.r = r1, z__3.i = 0.;
5731 pow_zz(&z__1, &z__2, &z__3);
5732 q__1.r = z__1.r, q__1.i = z__1.i;
5734 z__2.r = c1.r, z__2.i = c1.i;
5735 z__3.r = d1, z__3.i = 0.;
5736 pow_zz(&z__1, &z__2, &z__3);
5738 // FFEINTRIN_impABS //
5739 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
5741 // FFEINTRIN_impACOS //
5744 // FFEINTRIN_impAIMAG //
5747 // FFEINTRIN_impAINT //
5750 // FFEINTRIN_impALOG //
5753 // FFEINTRIN_impALOG10 //
5756 // FFEINTRIN_impAMAX0 //
5757 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
5759 // FFEINTRIN_impAMAX1 //
5760 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
5762 // FFEINTRIN_impAMIN0 //
5763 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
5765 // FFEINTRIN_impAMIN1 //
5766 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
5768 // FFEINTRIN_impAMOD //
5769 r__1 = r_mod(&r1, &r2);
5771 // FFEINTRIN_impANINT //
5774 // FFEINTRIN_impASIN //
5777 // FFEINTRIN_impATAN //
5780 // FFEINTRIN_impATAN2 //
5781 r__1 = atan2(r1, r2);
5783 // FFEINTRIN_impCABS //
5786 // FFEINTRIN_impCCOS //
5789 // FFEINTRIN_impCEXP //
5792 // FFEINTRIN_impCHAR //
5793 *(unsigned char *)&ch__1[0] = i1;
5795 // FFEINTRIN_impCLOG //
5798 // FFEINTRIN_impCONJG //
5801 // FFEINTRIN_impCOS //
5804 // FFEINTRIN_impCOSH //
5807 // FFEINTRIN_impCSIN //
5810 // FFEINTRIN_impCSQRT //
5813 // FFEINTRIN_impDABS //
5814 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
5816 // FFEINTRIN_impDACOS //
5819 // FFEINTRIN_impDASIN //
5822 // FFEINTRIN_impDATAN //
5825 // FFEINTRIN_impDATAN2 //
5826 d__1 = atan2(d1, d2);
5828 // FFEINTRIN_impDCOS //
5831 // FFEINTRIN_impDCOSH //
5834 // FFEINTRIN_impDDIM //
5835 d__1 = d_dim(&d1, &d2);
5837 // FFEINTRIN_impDEXP //
5840 // FFEINTRIN_impDIM //
5841 r__1 = r_dim(&r1, &r2);
5843 // FFEINTRIN_impDINT //
5846 // FFEINTRIN_impDLOG //
5849 // FFEINTRIN_impDLOG10 //
5852 // FFEINTRIN_impDMAX1 //
5853 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
5855 // FFEINTRIN_impDMIN1 //
5856 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
5858 // FFEINTRIN_impDMOD //
5859 d__1 = d_mod(&d1, &d2);
5861 // FFEINTRIN_impDNINT //
5864 // FFEINTRIN_impDPROD //
5865 d__1 = (doublereal) r1 * r2;
5867 // FFEINTRIN_impDSIGN //
5868 d__1 = d_sign(&d1, &d2);
5870 // FFEINTRIN_impDSIN //
5873 // FFEINTRIN_impDSINH //
5876 // FFEINTRIN_impDSQRT //
5879 // FFEINTRIN_impDTAN //
5882 // FFEINTRIN_impDTANH //
5885 // FFEINTRIN_impEXP //
5888 // FFEINTRIN_impIABS //
5889 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
5891 // FFEINTRIN_impICHAR //
5892 i__1 = *(unsigned char *)a1;
5894 // FFEINTRIN_impIDIM //
5895 i__1 = i_dim(&i1, &i2);
5897 // FFEINTRIN_impIDNINT //
5900 // FFEINTRIN_impINDEX //
5901 i__1 = i_indx(a1, a2, 10L, 10L);
5903 // FFEINTRIN_impISIGN //
5904 i__1 = i_sign(&i1, &i2);
5906 // FFEINTRIN_impLEN //
5907 i__1 = i_len(a1, 10L);
5909 // FFEINTRIN_impLGE //
5910 L__1 = l_ge(a1, a2, 10L, 10L);
5912 // FFEINTRIN_impLGT //
5913 L__1 = l_gt(a1, a2, 10L, 10L);
5915 // FFEINTRIN_impLLE //
5916 L__1 = l_le(a1, a2, 10L, 10L);
5918 // FFEINTRIN_impLLT //
5919 L__1 = l_lt(a1, a2, 10L, 10L);
5921 // FFEINTRIN_impMAX0 //
5922 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
5924 // FFEINTRIN_impMAX1 //
5925 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
5927 // FFEINTRIN_impMIN0 //
5928 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
5930 // FFEINTRIN_impMIN1 //
5931 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
5933 // FFEINTRIN_impMOD //
5936 // FFEINTRIN_impNINT //
5939 // FFEINTRIN_impSIGN //
5940 r__1 = r_sign(&r1, &r2);
5942 // FFEINTRIN_impSIN //
5945 // FFEINTRIN_impSINH //
5948 // FFEINTRIN_impSQRT //
5951 // FFEINTRIN_impTAN //
5954 // FFEINTRIN_impTANH //
5957 // FFEINTRIN_imp_CMPLX_C //
5960 q__1.r = r__1, q__1.i = r__2;
5962 // FFEINTRIN_imp_CMPLX_D //
5963 z__1.r = d1, z__1.i = d2;
5965 // FFEINTRIN_imp_CMPLX_I //
5968 q__1.r = r__1, q__1.i = r__2;
5970 // FFEINTRIN_imp_CMPLX_R //
5971 q__1.r = r1, q__1.i = r2;
5973 // FFEINTRIN_imp_DBLE_C //
5974 d__1 = (doublereal) c1.r;
5976 // FFEINTRIN_imp_DBLE_D //
5979 // FFEINTRIN_imp_DBLE_I //
5980 d__1 = (doublereal) i1;
5982 // FFEINTRIN_imp_DBLE_R //
5983 d__1 = (doublereal) r1;
5985 // FFEINTRIN_imp_INT_C //
5986 i__1 = (integer) c1.r;
5988 // FFEINTRIN_imp_INT_D //
5989 i__1 = (integer) d1;
5991 // FFEINTRIN_imp_INT_I //
5994 // FFEINTRIN_imp_INT_R //
5995 i__1 = (integer) r1;
5997 // FFEINTRIN_imp_REAL_C //
6000 // FFEINTRIN_imp_REAL_D //
6003 // FFEINTRIN_imp_REAL_I //
6006 // FFEINTRIN_imp_REAL_R //
6010 // FFEINTRIN_imp_INT_D: //
6012 // FFEINTRIN_specIDINT //
6013 i__1 = (integer) d1;
6016 // FFEINTRIN_imp_INT_R: //
6018 // FFEINTRIN_specIFIX //
6019 i__1 = (integer) r1;
6021 // FFEINTRIN_specINT //
6022 i__1 = (integer) r1;
6025 // FFEINTRIN_imp_REAL_D: //
6027 // FFEINTRIN_specSNGL //
6031 // FFEINTRIN_imp_REAL_I: //
6033 // FFEINTRIN_specFLOAT //
6036 // FFEINTRIN_specREAL //
6042 -------- (end output file from f2c)
6048 /* For power (exponentiation) where right-hand operand is type INTEGER,
6049 generate in-line code to do it the fast way (which, if the operand
6050 is a constant, might just mean a series of multiplies). */
6052 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6054 ffecom_expr_power_integer_ (ffebld left
, ffebld right
)
6056 tree l
= ffecom_expr (left
);
6057 tree r
= ffecom_expr (right
);
6058 tree ltype
= TREE_TYPE (l
);
6059 tree rtype
= TREE_TYPE (r
);
6060 tree result
= NULL_TREE
;
6062 if (l
== error_mark_node
6063 || r
== error_mark_node
)
6064 return error_mark_node
;
6066 if (TREE_CODE (r
) == INTEGER_CST
)
6068 int sgn
= tree_int_cst_sgn (r
);
6071 return convert (ltype
, integer_one_node
);
6073 if ((TREE_CODE (ltype
) == INTEGER_TYPE
)
6076 /* Reciprocal of integer is either 0, -1, or 1, so after
6077 calculating that (which we leave to the back end to do
6078 or not do optimally), don't bother with any multiplying. */
6080 result
= ffecom_tree_divide_ (ltype
,
6081 convert (ltype
, integer_one_node
),
6083 NULL_TREE
, NULL
, NULL
);
6084 r
= ffecom_1 (NEGATE_EXPR
,
6087 if ((TREE_INT_CST_LOW (r
) & 1) == 0)
6088 result
= ffecom_1 (ABS_EXPR
, rtype
,
6092 /* Generate appropriate series of multiplies, preceded
6093 by divide if the exponent is negative. */
6099 l
= ffecom_tree_divide_ (ltype
,
6100 convert (ltype
, integer_one_node
),
6102 NULL_TREE
, NULL
, NULL
);
6103 r
= ffecom_1 (NEGATE_EXPR
, rtype
, r
);
6104 assert (TREE_CODE (r
) == INTEGER_CST
);
6106 if (tree_int_cst_sgn (r
) < 0)
6107 { /* The "most negative" number. */
6108 r
= ffecom_1 (NEGATE_EXPR
, rtype
,
6109 ffecom_2 (RSHIFT_EXPR
, rtype
,
6113 l
= ffecom_2 (MULT_EXPR
, ltype
,
6121 if (TREE_INT_CST_LOW (r
) & 1)
6123 if (result
== NULL_TREE
)
6126 result
= ffecom_2 (MULT_EXPR
, ltype
,
6131 r
= ffecom_2 (RSHIFT_EXPR
, rtype
,
6134 if (integer_zerop (r
))
6136 assert (TREE_CODE (r
) == INTEGER_CST
);
6139 l
= ffecom_2 (MULT_EXPR
, ltype
,
6146 /* Though rhs isn't a constant, in-line code cannot be expanded
6147 while transforming dummies
6148 because the back end cannot be easily convinced to generate
6149 stores (MODIFY_EXPR), handle temporaries, and so on before
6150 all the appropriate rtx's have been generated for things like
6151 dummy args referenced in rhs -- which doesn't happen until
6152 store_parm_decls() is called (expand_function_start, I believe,
6153 does the actual rtx-stuffing of PARM_DECLs).
6155 So, in this case, let the caller generate the call to the
6156 run-time-library function to evaluate the power for us. */
6158 if (ffecom_transform_only_dummies_
)
6161 /* Right-hand operand not a constant, expand in-line code to figure
6162 out how to do the multiplies, &c.
6164 The returned expression is expressed this way in GNU C, where l and
6167 ({ typeof (r) rtmp = r;
6168 typeof (l) ltmp = l;
6175 if ((basetypeof (l) == basetypeof (int))
6178 result = ((typeof (l)) 1) / ltmp;
6179 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
6185 if ((basetypeof (l) != basetypeof (int))
6188 ltmp = ((typeof (l)) 1) / ltmp;
6192 rtmp = -(rtmp >> 1);
6200 if ((rtmp >>= 1) == 0)
6209 Note that some of the above is compile-time collapsable, such as
6210 the first part of the if statements that checks the base type of
6211 l against int. The if statements are phrased that way to suggest
6212 an easy way to generate the if/else constructs here, knowing that
6213 the back end should (and probably does) eliminate the resulting
6214 dead code (either the int case or the non-int case), something
6215 it couldn't do without the redundant phrasing, requiring explicit
6216 dead-code elimination here, which would be kind of difficult to
6222 tree basetypeof_l_is_int
;
6226 = build_int_2 ((TREE_CODE (ltype
) == INTEGER_TYPE
), 0);
6228 se
= expand_start_stmt_expr ();
6229 ffecom_push_calltemps ();
6231 rtmp
= ffecom_push_tempvar (rtype
, FFETARGET_charactersizeNONE
, -1,
6233 ltmp
= ffecom_push_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1,
6235 result
= ffecom_push_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1,
6238 expand_expr_stmt (ffecom_modify (void_type_node
,
6241 expand_expr_stmt (ffecom_modify (void_type_node
,
6244 expand_start_cond (ffecom_truth_value
6245 (ffecom_2 (EQ_EXPR
, integer_type_node
,
6247 convert (rtype
, integer_zero_node
))),
6249 expand_expr_stmt (ffecom_modify (void_type_node
,
6251 convert (ltype
, integer_one_node
)));
6252 expand_start_else ();
6253 if (!integer_zerop (basetypeof_l_is_int
))
6255 expand_start_cond (ffecom_2 (LT_EXPR
, integer_type_node
,
6258 integer_zero_node
)),
6260 expand_expr_stmt (ffecom_modify (void_type_node
,
6264 convert (ltype
, integer_one_node
),
6266 NULL_TREE
, NULL
, NULL
)));
6267 expand_start_cond (ffecom_truth_value
6268 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
6269 ffecom_2 (LT_EXPR
, integer_type_node
,
6272 integer_zero_node
)),
6273 ffecom_2 (EQ_EXPR
, integer_type_node
,
6274 ffecom_2 (BIT_AND_EXPR
,
6276 ffecom_1 (NEGATE_EXPR
,
6282 integer_zero_node
)))),
6284 expand_expr_stmt (ffecom_modify (void_type_node
,
6286 ffecom_1 (NEGATE_EXPR
,
6290 expand_start_else ();
6292 expand_expr_stmt (ffecom_modify (void_type_node
,
6294 convert (ltype
, integer_one_node
)));
6295 expand_start_cond (ffecom_truth_value
6296 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
6297 ffecom_truth_value_invert
6298 (basetypeof_l_is_int
),
6299 ffecom_2 (LT_EXPR
, integer_type_node
,
6302 integer_zero_node
)))),
6304 expand_expr_stmt (ffecom_modify (void_type_node
,
6308 convert (ltype
, integer_one_node
),
6310 NULL_TREE
, NULL
, NULL
)));
6311 expand_expr_stmt (ffecom_modify (void_type_node
,
6313 ffecom_1 (NEGATE_EXPR
, rtype
,
6315 expand_start_cond (ffecom_truth_value
6316 (ffecom_2 (LT_EXPR
, integer_type_node
,
6318 convert (rtype
, integer_zero_node
))),
6320 expand_expr_stmt (ffecom_modify (void_type_node
,
6322 ffecom_1 (NEGATE_EXPR
, rtype
,
6323 ffecom_2 (RSHIFT_EXPR
,
6326 integer_one_node
))));
6327 expand_expr_stmt (ffecom_modify (void_type_node
,
6329 ffecom_2 (MULT_EXPR
, ltype
,
6334 expand_start_loop (1);
6335 expand_start_cond (ffecom_truth_value
6336 (ffecom_2 (BIT_AND_EXPR
, rtype
,
6338 convert (rtype
, integer_one_node
))),
6340 expand_expr_stmt (ffecom_modify (void_type_node
,
6342 ffecom_2 (MULT_EXPR
, ltype
,
6346 expand_exit_loop_if_false (NULL
,
6348 (ffecom_modify (rtype
,
6350 ffecom_2 (RSHIFT_EXPR
,
6353 integer_one_node
))));
6354 expand_expr_stmt (ffecom_modify (void_type_node
,
6356 ffecom_2 (MULT_EXPR
, ltype
,
6361 if (!integer_zerop (basetypeof_l_is_int
))
6363 expand_expr_stmt (result
);
6365 ffecom_pop_calltemps ();
6366 result
= expand_end_stmt_expr (se
);
6367 TREE_SIDE_EFFECTS (result
) = 1;
6374 /* ffecom_expr_transform_ -- Transform symbols in expr
6376 ffebld expr; // FFE expression.
6377 ffecom_expr_transform_ (expr);
6379 Recursive descent on expr while transforming any untransformed SYMTERs. */
6381 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6383 ffecom_expr_transform_ (ffebld expr
)
6388 tail_recurse
: /* :::::::::::::::::::: */
6393 switch (ffebld_op (expr
))
6395 case FFEBLD_opSYMTER
:
6396 s
= ffebld_symter (expr
);
6397 t
= ffesymbol_hook (s
).decl_tree
;
6398 if ((t
== NULL_TREE
)
6399 && ((ffesymbol_kind (s
) != FFEINFO_kindNONE
)
6400 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
6401 && (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
))))
6403 s
= ffecom_sym_transform_ (s
);
6404 t
= ffesymbol_hook (s
).decl_tree
; /* Sfunc expr non-dummy,
6407 break; /* Ok if (t == NULL) here. */
6410 ffecom_expr_transform_ (ffebld_head (expr
));
6411 expr
= ffebld_trail (expr
);
6412 goto tail_recurse
; /* :::::::::::::::::::: */
6418 switch (ffebld_arity (expr
))
6421 ffecom_expr_transform_ (ffebld_left (expr
));
6422 expr
= ffebld_right (expr
);
6423 goto tail_recurse
; /* :::::::::::::::::::: */
6426 expr
= ffebld_left (expr
);
6427 goto tail_recurse
; /* :::::::::::::::::::: */
6437 /* Make a type based on info in live f2c.h file. */
6439 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6441 ffecom_f2c_make_type_ (tree
*type
, int tcode
, char *name
)
6445 case FFECOM_f2ccodeCHAR
:
6446 *type
= make_signed_type (CHAR_TYPE_SIZE
);
6449 case FFECOM_f2ccodeSHORT
:
6450 *type
= make_signed_type (SHORT_TYPE_SIZE
);
6453 case FFECOM_f2ccodeINT
:
6454 *type
= make_signed_type (INT_TYPE_SIZE
);
6457 case FFECOM_f2ccodeLONG
:
6458 *type
= make_signed_type (LONG_TYPE_SIZE
);
6461 case FFECOM_f2ccodeLONGLONG
:
6462 *type
= make_signed_type (LONG_LONG_TYPE_SIZE
);
6465 case FFECOM_f2ccodeCHARPTR
:
6466 *type
= build_pointer_type (DEFAULT_SIGNED_CHAR
6467 ? signed_char_type_node
6468 : unsigned_char_type_node
);
6471 case FFECOM_f2ccodeFLOAT
:
6472 *type
= make_node (REAL_TYPE
);
6473 TYPE_PRECISION (*type
) = FLOAT_TYPE_SIZE
;
6474 layout_type (*type
);
6477 case FFECOM_f2ccodeDOUBLE
:
6478 *type
= make_node (REAL_TYPE
);
6479 TYPE_PRECISION (*type
) = DOUBLE_TYPE_SIZE
;
6480 layout_type (*type
);
6483 case FFECOM_f2ccodeLONGDOUBLE
:
6484 *type
= make_node (REAL_TYPE
);
6485 TYPE_PRECISION (*type
) = LONG_DOUBLE_TYPE_SIZE
;
6486 layout_type (*type
);
6489 case FFECOM_f2ccodeTWOREALS
:
6490 *type
= ffecom_make_complex_type_ (ffecom_f2c_real_type_node
);
6493 case FFECOM_f2ccodeTWODOUBLEREALS
:
6494 *type
= ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node
);
6498 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL
);
6499 *type
= error_mark_node
;
6503 pushdecl (build_decl (TYPE_DECL
,
6504 ffecom_get_invented_identifier ("__g77_f2c_%s",
6510 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6511 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6515 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
6521 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
6522 if (((t
= ffecom_tree_type
[bt
][j
]) != NULL_TREE
)
6523 && (TREE_INT_CST_LOW (TYPE_SIZE (t
)) == size
))
6525 assert (code
!= -1);
6526 ffecom_f2c_typecode_
[bt
][j
] = code
;
6532 /* Finish up globals after doing all program units in file
6534 Need to handle only uninitialized COMMON areas. */
6536 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6538 ffecom_finish_global_ (ffeglobal global
)
6544 if (ffeglobal_type (global
) != FFEGLOBAL_typeCOMMON
)
6547 if (ffeglobal_common_init (global
))
6550 cbt
= ffeglobal_hook (global
);
6551 if ((cbt
== NULL_TREE
)
6552 || !ffeglobal_common_have_size (global
))
6553 return global
; /* No need to make common, never ref'd. */
6555 suspend_momentary ();
6557 DECL_EXTERNAL (cbt
) = 0;
6559 /* Give the array a size now. */
6561 size
= build_int_2 (ffeglobal_common_size (global
), 0);
6563 cbtype
= TREE_TYPE (cbt
);
6564 TYPE_DOMAIN (cbtype
) = build_range_type (integer_type_node
,
6567 if (!TREE_TYPE (size
))
6568 TREE_TYPE (size
) = TYPE_DOMAIN (cbtype
);
6569 layout_type (cbtype
);
6571 cbt
= start_decl (cbt
, FALSE
);
6572 assert (cbt
== ffeglobal_hook (global
));
6574 finish_decl (cbt
, NULL_TREE
, FALSE
);
6580 /* Finish up any untransformed symbols. */
6582 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6584 ffecom_finish_symbol_transform_ (ffesymbol s
)
6589 /* It's easy to know to transform an untransformed symbol, to make sure
6590 we put out debugging info for it. But COMMON variables, unlike
6591 EQUIVALENCE ones, aren't given declarations in addition to the
6592 tree expressions that specify offsets, because COMMON variables
6593 can be referenced in the outer scope where only dummy arguments
6594 (PARM_DECLs) should really be seen. To be safe, just don't do any
6595 VAR_DECLs for COMMON variables when we transform them for real
6596 use, and therefore we do all the VAR_DECL creating here. */
6598 if ((ffesymbol_hook (s
).decl_tree
== NULL_TREE
)
6599 && ((ffesymbol_kind (s
) != FFEINFO_kindNONE
)
6600 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
6601 && (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
)))
6602 && (ffesymbol_where (s
) != FFEINFO_whereDUMMY
))
6603 /* Not transformed, and not CHARACTER*(*), and not a dummy
6604 argument, which can happen only if the entry point names
6605 it "rides in on" are all invalidated for other reasons. */
6606 s
= ffecom_sym_transform_ (s
);
6608 if ((ffesymbol_where (s
) == FFEINFO_whereCOMMON
)
6609 && (ffesymbol_hook (s
).decl_tree
!= error_mark_node
))
6611 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
6612 int yes
= suspend_momentary ();
6614 /* This isn't working, at least for dbxout. The .s file looks
6615 okay to me (burley), but in gdb 4.9 at least, the variables
6616 appear to reside somewhere outside of the common area, so
6617 it doesn't make sense to mislead anyone by generating the info
6618 on those variables until this is fixed. NOTE: Same problem
6619 with EQUIVALENCE, sadly...see similar #if later. */
6620 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s
)),
6621 ffesymbol_storage (s
));
6623 resume_momentary (yes
);
6631 /* Append underscore(s) to name before calling get_identifier. "us"
6632 is nonzero if the name already contains an underscore and thus
6633 needs two underscores appended. */
6635 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6637 ffecom_get_appended_identifier_ (char us
, char *name
)
6643 newname
= xmalloc ((i
= strlen (name
)) + 1
6644 + ffe_is_underscoring ()
6646 memcpy (newname
, name
, i
);
6648 newname
[i
+ us
] = '_';
6649 newname
[i
+ 1 + us
] = '\0';
6650 id
= get_identifier (newname
);
6658 /* Decide whether to append underscore to name before calling
6661 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6663 ffecom_get_external_identifier_ (ffesymbol s
)
6666 char *name
= ffesymbol_text (s
);
6668 /* If name is a built-in name, just return it as is. */
6670 if (!ffe_is_underscoring ()
6671 || (strcmp (name
, FFETARGET_nameBLANK_COMMON
) == 0)
6672 #if FFETARGET_isENFORCED_MAIN_NAME
6673 || (strcmp (name
, FFETARGET_nameENFORCED_NAME
) == 0)
6675 || (strcmp (name
, FFETARGET_nameUNNAMED_MAIN
) == 0)
6677 || (strcmp (name
, FFETARGET_nameUNNAMED_BLOCK_DATA
) == 0))
6678 return get_identifier (name
);
6680 us
= ffe_is_second_underscore ()
6681 ? (strchr (name
, '_') != NULL
)
6684 return ffecom_get_appended_identifier_ (us
, name
);
6688 /* Decide whether to append underscore to internal name before calling
6691 This is for non-external, top-function-context names only. Transform
6692 identifier so it doesn't conflict with the transformed result
6693 of using a _different_ external name. E.g. if "CALL FOO" is
6694 transformed into "FOO_();", then the variable in "FOO_ = 3"
6695 must be transformed into something that does not conflict, since
6696 these two things should be independent.
6698 The transformation is as follows. If the name does not contain
6699 an underscore, there is no possible conflict, so just return.
6700 If the name does contain an underscore, then transform it just
6701 like we transform an external identifier. */
6703 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6705 ffecom_get_identifier_ (char *name
)
6707 /* If name does not contain an underscore, just return it as is. */
6709 if (!ffe_is_underscoring ()
6710 || (strchr (name
, '_') == NULL
))
6711 return get_identifier (name
);
6713 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6718 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6721 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6722 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6723 ffesymbol_kindtype(s));
6725 Call after setting up containing function and getting trees for all
6728 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6730 ffecom_gen_sfuncdef_ (ffesymbol s
, ffeinfoBasictype bt
, ffeinfoKindtype kt
)
6732 ffebld expr
= ffesymbol_sfexpr (s
);
6736 bool charfunc
= (bt
== FFEINFO_basictypeCHARACTER
);
6737 static bool recurse
= FALSE
;
6739 int old_lineno
= lineno
;
6740 char *old_input_filename
= input_filename
;
6742 ffecom_nested_entry_
= s
;
6744 /* For now, we don't have a handy pointer to where the sfunc is actually
6745 defined, though that should be easy to add to an ffesymbol. (The
6746 token/where info available might well point to the place where the type
6747 of the sfunc is declared, especially if that precedes the place where
6748 the sfunc itself is defined, which is typically the case.) We should
6749 put out a null pointer rather than point somewhere wrong, but I want to
6750 see how it works at this point. */
6752 input_filename
= ffesymbol_where_filename (s
);
6753 lineno
= ffesymbol_where_filelinenum (s
);
6755 /* Pretransform the expression so any newly discovered things belong to the
6756 outer program unit, not to the statement function. */
6758 ffecom_expr_transform_ (expr
);
6760 /* Make sure no recursive invocation of this fn (a specific case of failing
6761 to pretransform an sfunc's expression, i.e. where its expression
6762 references another untransformed sfunc) happens. */
6767 yes
= suspend_momentary ();
6769 push_f_function_context ();
6771 ffecom_push_calltemps ();
6774 type
= void_type_node
;
6777 type
= ffecom_tree_type
[bt
][kt
];
6778 if (type
== NULL_TREE
)
6779 type
= integer_type_node
; /* _sym_exec_transition reports
6783 start_function (ffecom_get_identifier_ (ffesymbol_text (s
)),
6784 build_function_type (type
, NULL_TREE
),
6785 1, /* nested/inline */
6786 0); /* TREE_PUBLIC */
6788 /* We don't worry about COMPLEX return values here, because this is
6789 entirely internal to our code, and gcc has the ability to return COMPLEX
6790 directly as a value. */
6792 yes
= suspend_momentary ();
6795 { /* Prepend arg for where result goes. */
6798 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
6800 result
= ffecom_get_invented_identifier ("__g77_%s",
6803 ffecom_char_enhance_arg_ (&type
, s
); /* Ignore returned length. */
6805 type
= build_pointer_type (type
);
6806 result
= build_decl (PARM_DECL
, result
, type
);
6808 push_parm_decl (result
);
6811 result
= NULL_TREE
; /* Not ref'd if !charfunc. */
6813 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s
), TRUE
);
6815 resume_momentary (yes
);
6817 store_parm_decls (0);
6819 ffecom_start_compstmt_ ();
6825 ffetargetCharacterSize sz
= ffesymbol_size (s
);
6828 result_length
= build_int_2 (sz
, 0);
6829 TREE_TYPE (result_length
) = ffecom_f2c_ftnlen_type_node
;
6831 ffecom_let_char_ (result
, result_length
, sz
, expr
);
6832 expand_null_return ();
6835 expand_return (ffecom_modify (NULL_TREE
,
6836 DECL_RESULT (current_function_decl
),
6837 ffecom_expr (expr
)));
6842 ffecom_end_compstmt_ ();
6844 func
= current_function_decl
;
6845 finish_function (1);
6847 ffecom_pop_calltemps ();
6849 pop_f_function_context ();
6851 resume_momentary (yes
);
6855 lineno
= old_lineno
;
6856 input_filename
= old_input_filename
;
6858 ffecom_nested_entry_
= NULL
;
6865 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6867 ffecom_gfrt_args_ (ffecomGfrt ix
)
6869 return ffecom_gfrt_argstring_
[ix
];
6873 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6875 ffecom_gfrt_tree_ (ffecomGfrt ix
)
6877 if (ffecom_gfrt_
[ix
] == NULL_TREE
)
6878 ffecom_make_gfrt_ (ix
);
6880 return ffecom_1 (ADDR_EXPR
,
6881 build_pointer_type (TREE_TYPE (ffecom_gfrt_
[ix
])),
6886 /* Return initialize-to-zero expression for this VAR_DECL. */
6888 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6890 ffecom_init_zero_ (tree decl
)
6893 int incremental
= TREE_STATIC (decl
);
6894 tree type
= TREE_TYPE (decl
);
6898 int momentary
= suspend_momentary ();
6899 push_obstacks_nochange ();
6900 if (TREE_PERMANENT (decl
))
6901 end_temporary_allocation ();
6902 make_decl_rtl (decl
, NULL
, TREE_PUBLIC (decl
) ? 1 : 0);
6903 assemble_variable (decl
, TREE_PUBLIC (decl
) ? 1 : 0, 0, 1);
6905 resume_momentary (momentary
);
6910 if ((TREE_CODE (type
) != ARRAY_TYPE
)
6911 && (TREE_CODE (type
) != RECORD_TYPE
)
6912 && (TREE_CODE (type
) != UNION_TYPE
)
6914 init
= convert (type
, integer_zero_node
);
6915 else if (!incremental
)
6917 int momentary
= suspend_momentary ();
6919 init
= build (CONSTRUCTOR
, type
, NULL_TREE
, NULL_TREE
);
6920 TREE_CONSTANT (init
) = 1;
6921 TREE_STATIC (init
) = 1;
6923 resume_momentary (momentary
);
6927 int momentary
= suspend_momentary ();
6929 assemble_zeros (int_size_in_bytes (type
));
6930 init
= error_mark_node
;
6932 resume_momentary (momentary
);
6935 pop_momentary_nofree ();
6941 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6943 ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
6949 switch (ffebld_op (arg
))
6951 case FFEBLD_opCONTER
: /* For F90, check 0-length. */
6952 if (ffetarget_length_character1
6953 (ffebld_constant_character1
6954 (ffebld_conter (arg
))) == 0)
6956 *maybe_tree
= integer_zero_node
;
6957 return convert (tree_type
, integer_zero_node
);
6960 *maybe_tree
= integer_one_node
;
6961 expr_tree
= build_int_2 (*ffetarget_text_character1
6962 (ffebld_constant_character1
6963 (ffebld_conter (arg
))),
6965 TREE_TYPE (expr_tree
) = tree_type
;
6968 case FFEBLD_opSYMTER
:
6969 case FFEBLD_opARRAYREF
:
6970 case FFEBLD_opFUNCREF
:
6971 case FFEBLD_opSUBSTR
:
6972 ffecom_push_calltemps ();
6973 ffecom_char_args_ (&expr_tree
, &length_tree
, arg
);
6974 ffecom_pop_calltemps ();
6976 if ((expr_tree
== error_mark_node
)
6977 || (length_tree
== error_mark_node
))
6979 *maybe_tree
= error_mark_node
;
6980 return error_mark_node
;
6983 if (integer_zerop (length_tree
))
6985 *maybe_tree
= integer_zero_node
;
6986 return convert (tree_type
, integer_zero_node
);
6990 = ffecom_1 (INDIRECT_REF
,
6991 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
6994 = ffecom_2 (ARRAY_REF
,
6995 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
6998 expr_tree
= convert (tree_type
, expr_tree
);
7000 if (TREE_CODE (length_tree
) == INTEGER_CST
)
7001 *maybe_tree
= integer_one_node
;
7002 else /* Must check length at run time. */
7004 = ffecom_truth_value
7005 (ffecom_2 (GT_EXPR
, integer_type_node
,
7007 ffecom_f2c_ftnlen_zero_node
));
7010 case FFEBLD_opPAREN
:
7011 case FFEBLD_opCONVERT
:
7012 if (ffeinfo_size (ffebld_info (arg
)) == 0)
7014 *maybe_tree
= integer_zero_node
;
7015 return convert (tree_type
, integer_zero_node
);
7017 return ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
7020 case FFEBLD_opCONCATENATE
:
7027 expr_left
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
7029 expr_right
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_right (arg
),
7031 *maybe_tree
= ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
7034 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
7042 assert ("bad op in ICHAR" == NULL
);
7043 return error_mark_node
;
7048 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
7052 length_arg = ffecom_intrinsic_len_ (expr);
7054 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
7055 subexpressions by constructing the appropriate tree for the
7056 length-of-character-text argument in a calling sequence. */
7058 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7060 ffecom_intrinsic_len_ (ffebld expr
)
7062 ffetargetCharacter1 val
;
7065 switch (ffebld_op (expr
))
7067 case FFEBLD_opCONTER
:
7068 val
= ffebld_constant_character1 (ffebld_conter (expr
));
7069 length
= build_int_2 (ffetarget_length_character1 (val
), 0);
7070 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
7073 case FFEBLD_opSYMTER
:
7075 ffesymbol s
= ffebld_symter (expr
);
7078 item
= ffesymbol_hook (s
).decl_tree
;
7079 if (item
== NULL_TREE
)
7081 s
= ffecom_sym_transform_ (s
);
7082 item
= ffesymbol_hook (s
).decl_tree
;
7084 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
7086 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
7087 length
= ffesymbol_hook (s
).length_tree
;
7090 length
= build_int_2 (ffesymbol_size (s
), 0);
7091 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
7094 else if (item
== error_mark_node
)
7095 length
= error_mark_node
;
7096 else /* FFEINFO_kindFUNCTION: */
7101 case FFEBLD_opARRAYREF
:
7102 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
7105 case FFEBLD_opSUBSTR
:
7109 ffebld thing
= ffebld_right (expr
);
7113 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
7114 start
= ffebld_head (thing
);
7115 thing
= ffebld_trail (thing
);
7116 assert (ffebld_trail (thing
) == NULL
);
7117 end
= ffebld_head (thing
);
7119 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
7121 if (length
== error_mark_node
)
7130 length
= convert (ffecom_f2c_ftnlen_type_node
,
7136 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
7137 ffecom_expr (start
));
7139 if (start_tree
== error_mark_node
)
7141 length
= error_mark_node
;
7147 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
7148 ffecom_f2c_ftnlen_one_node
,
7149 ffecom_2 (MINUS_EXPR
,
7150 ffecom_f2c_ftnlen_type_node
,
7156 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
7159 if (end_tree
== error_mark_node
)
7161 length
= error_mark_node
;
7165 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
7166 ffecom_f2c_ftnlen_one_node
,
7167 ffecom_2 (MINUS_EXPR
,
7168 ffecom_f2c_ftnlen_type_node
,
7169 end_tree
, start_tree
));
7175 case FFEBLD_opCONCATENATE
:
7177 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
7178 ffecom_intrinsic_len_ (ffebld_left (expr
)),
7179 ffecom_intrinsic_len_ (ffebld_right (expr
)));
7182 case FFEBLD_opFUNCREF
:
7183 case FFEBLD_opCONVERT
:
7184 length
= build_int_2 (ffebld_size (expr
), 0);
7185 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
7189 assert ("bad op for single char arg expr" == NULL
);
7190 length
= ffecom_f2c_ftnlen_zero_node
;
7194 assert (length
!= NULL_TREE
);
7200 /* ffecom_let_char_ -- Do assignment stuff for character type
7202 tree dest_tree; // destination (ADDR_EXPR)
7203 tree dest_length; // length (INT_CST/INDIRECT_REF(PARM_DECL))
7204 ffetargetCharacterSize dest_size; // length
7205 ffebld source; // source expression
7206 ffecom_let_char_(dest_tree,dest_length,dest_size,source);
7208 Generates code to do the assignment. Used by ordinary assignment
7209 statement handler ffecom_let_stmt and by statement-function
7210 handler to generate code for a statement function. */
7212 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7214 ffecom_let_char_ (tree dest_tree
, tree dest_length
,
7215 ffetargetCharacterSize dest_size
, ffebld source
)
7217 ffecomConcatList_ catlist
;
7222 if ((dest_tree
== error_mark_node
)
7223 || (dest_length
== error_mark_node
))
7226 assert (dest_tree
!= NULL_TREE
);
7227 assert (dest_length
!= NULL_TREE
);
7229 /* Source might be an opCONVERT, which just means it is a different size
7230 than the destination. Since the underlying implementation here handles
7231 that (directly or via the s_copy or s_cat run-time-library functions),
7232 we don't need the "convenience" of an opCONVERT that tells us to
7233 truncate or blank-pad, particularly since the resulting implementation
7234 would probably be slower than otherwise. */
7236 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
7237 source
= ffebld_left (source
);
7239 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
7240 switch (ffecom_concat_list_count_ (catlist
))
7242 case 0: /* Shouldn't happen, but in case it does... */
7243 ffecom_concat_list_kill_ (catlist
);
7244 source_tree
= null_pointer_node
;
7245 source_length
= ffecom_f2c_ftnlen_zero_node
;
7246 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
7247 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
7248 TREE_CHAIN (TREE_CHAIN (expr_tree
))
7249 = build_tree_list (NULL_TREE
, dest_length
);
7250 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
7251 = build_tree_list (NULL_TREE
, source_length
);
7253 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
);
7254 TREE_SIDE_EFFECTS (expr_tree
) = 1;
7256 expand_expr_stmt (expr_tree
);
7260 case 1: /* The (fairly) easy case. */
7261 ffecom_char_args_ (&source_tree
, &source_length
,
7262 ffecom_concat_list_expr_ (catlist
, 0));
7263 ffecom_concat_list_kill_ (catlist
);
7264 assert (source_tree
!= NULL_TREE
);
7265 assert (source_length
!= NULL_TREE
);
7267 if ((source_tree
== error_mark_node
)
7268 || (source_length
== error_mark_node
))
7274 = ffecom_1 (INDIRECT_REF
,
7275 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7279 = ffecom_2 (ARRAY_REF
,
7280 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7285 = ffecom_1 (INDIRECT_REF
,
7286 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7290 = ffecom_2 (ARRAY_REF
,
7291 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7296 expr_tree
= ffecom_modify (void_type_node
, dest_tree
, source_tree
);
7298 expand_expr_stmt (expr_tree
);
7303 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
7304 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
7305 TREE_CHAIN (TREE_CHAIN (expr_tree
))
7306 = build_tree_list (NULL_TREE
, dest_length
);
7307 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
7308 = build_tree_list (NULL_TREE
, source_length
);
7310 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
);
7311 TREE_SIDE_EFFECTS (expr_tree
) = 1;
7313 expand_expr_stmt (expr_tree
);
7317 default: /* Must actually concatenate things. */
7321 /* Heavy-duty concatenation. */
7324 int count
= ffecom_concat_list_count_ (catlist
);
7335 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
7336 FFETARGET_charactersizeNONE
, count
, TRUE
);
7337 item_array
= items
= ffecom_push_tempvar (ffecom_f2c_address_type_node
,
7338 FFETARGET_charactersizeNONE
,
7341 for (i
= 0; i
< count
; ++i
)
7343 ffecom_char_args_ (&citem
, &clength
,
7344 ffecom_concat_list_expr_ (catlist
, i
));
7345 if ((citem
== error_mark_node
)
7346 || (clength
== error_mark_node
))
7348 ffecom_concat_list_kill_ (catlist
);
7353 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
7354 ffecom_modify (void_type_node
,
7355 ffecom_2 (ARRAY_REF
,
7356 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
7358 build_int_2 (i
, 0)),
7362 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
7363 ffecom_modify (void_type_node
,
7364 ffecom_2 (ARRAY_REF
,
7365 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
7367 build_int_2 (i
, 0)),
7372 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
7373 TREE_CHAIN (expr_tree
)
7374 = build_tree_list (NULL_TREE
,
7375 ffecom_1 (ADDR_EXPR
,
7376 build_pointer_type (TREE_TYPE (items
)),
7378 TREE_CHAIN (TREE_CHAIN (expr_tree
))
7379 = build_tree_list (NULL_TREE
,
7380 ffecom_1 (ADDR_EXPR
,
7381 build_pointer_type (TREE_TYPE (lengths
)),
7383 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
7386 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
7387 convert (ffecom_f2c_ftnlen_type_node
,
7388 build_int_2 (count
, 0))));
7389 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
))))
7390 = build_tree_list (NULL_TREE
, dest_length
);
7392 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCAT
, expr_tree
);
7393 TREE_SIDE_EFFECTS (expr_tree
) = 1;
7395 expand_expr_stmt (expr_tree
);
7398 ffecom_concat_list_kill_ (catlist
);
7402 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
7405 ffecom_make_gfrt_(ix);
7407 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
7408 for the indicated run-time routine (ix). */
7410 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7412 ffecom_make_gfrt_ (ffecomGfrt ix
)
7417 push_obstacks_nochange ();
7418 end_temporary_allocation ();
7420 switch (ffecom_gfrt_type_
[ix
])
7422 case FFECOM_rttypeVOID_
:
7423 ttype
= void_type_node
;
7426 case FFECOM_rttypeINT_
:
7427 ttype
= integer_type_node
;
7430 case FFECOM_rttypeINTEGER_
:
7431 ttype
= ffecom_f2c_integer_type_node
;
7434 case FFECOM_rttypeLONGINT_
:
7435 ttype
= ffecom_f2c_longint_type_node
;
7438 case FFECOM_rttypeLOGICAL_
:
7439 ttype
= ffecom_f2c_logical_type_node
;
7442 case FFECOM_rttypeREAL_F2C_
:
7443 ttype
= ffecom_f2c_real_type_node
;
7446 case FFECOM_rttypeREAL_GNU_
:
7447 ttype
= ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
];
7450 case FFECOM_rttypeCOMPLEX_F2C_
:
7451 ttype
= void_type_node
;
7454 case FFECOM_rttypeCOMPLEX_GNU_
:
7455 ttype
= ffecom_f2c_complex_type_node
;
7458 case FFECOM_rttypeDOUBLE_
:
7459 ttype
= double_type_node
;
7462 case FFECOM_rttypeDBLCMPLX_F2C_
:
7463 ttype
= void_type_node
;
7466 case FFECOM_rttypeDBLCMPLX_GNU_
:
7467 ttype
= ffecom_f2c_doublecomplex_type_node
;
7470 case FFECOM_rttypeCHARACTER_
:
7471 ttype
= void_type_node
;
7476 assert ("bad rttype" == NULL
);
7480 ttype
= build_function_type (ttype
, NULL_TREE
);
7481 t
= build_decl (FUNCTION_DECL
,
7482 get_identifier (ffecom_gfrt_name_
[ix
]),
7484 DECL_EXTERNAL (t
) = 1;
7485 TREE_PUBLIC (t
) = 1;
7486 TREE_THIS_VOLATILE (t
) = ffecom_gfrt_volatile_
[ix
] ? 1 : 0;
7488 t
= start_decl (t
, TRUE
);
7490 finish_decl (t
, NULL_TREE
, TRUE
);
7492 resume_temporary_allocation ();
7495 ffecom_gfrt_
[ix
] = t
;
7499 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
7501 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7503 ffecom_member_phase1_ (ffestorag mst UNUSED
, ffestorag st
)
7505 ffesymbol s
= ffestorag_symbol (st
);
7507 if (ffesymbol_namelisted (s
))
7508 ffecom_member_namelisted_
= TRUE
;
7512 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
7513 the member so debugger will see it. Otherwise nobody should be
7514 referencing the member. */
7516 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7517 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
7519 ffecom_member_phase2_ (ffestorag mst
, ffestorag st
)
7527 || ((mt
= ffestorag_hook (mst
)) == NULL
)
7528 || (mt
== error_mark_node
))
7532 || ((s
= ffestorag_symbol (st
)) == NULL
))
7535 type
= ffecom_type_localvar_ (s
,
7536 ffesymbol_basictype (s
),
7537 ffesymbol_kindtype (s
));
7538 if (type
== error_mark_node
)
7541 t
= build_decl (VAR_DECL
,
7542 ffecom_get_identifier_ (ffesymbol_text (s
)),
7545 TREE_STATIC (t
) = TREE_STATIC (mt
);
7546 DECL_INITIAL (t
) = NULL_TREE
;
7547 TREE_ASM_WRITTEN (t
) = 1;
7550 = gen_rtx (MEM
, TYPE_MODE (type
),
7551 plus_constant (XEXP (DECL_RTL (mt
), 0),
7552 ffestorag_modulo (mst
)
7553 + ffestorag_offset (st
)
7554 - ffestorag_offset (mst
)));
7556 t
= start_decl (t
, FALSE
);
7558 finish_decl (t
, NULL_TREE
, FALSE
);
7563 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7565 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7566 (which generates their trees) and then their trees get push_parm_decl'd.
7568 The second arg is TRUE if the dummies are for a statement function, in
7569 which case lengths are not pushed for character arguments (since they are
7570 always known by both the caller and the callee, though the code allows
7571 for someday permitting CHAR*(*) stmtfunc dummies). */
7573 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7575 ffecom_push_dummy_decls_ (ffebld dummy_list
, bool stmtfunc
)
7582 ffecom_transform_only_dummies_
= TRUE
;
7584 /* First push the parms corresponding to actual dummy "contents". */
7586 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7588 dummy
= ffebld_head (dumlist
);
7589 switch (ffebld_op (dummy
))
7593 continue; /* Forget alternate returns. */
7598 assert (ffebld_op (dummy
) == FFEBLD_opSYMTER
);
7599 s
= ffebld_symter (dummy
);
7600 parm
= ffesymbol_hook (s
).decl_tree
;
7601 if (parm
== NULL_TREE
)
7603 s
= ffecom_sym_transform_ (s
);
7604 parm
= ffesymbol_hook (s
).decl_tree
;
7605 assert (parm
!= NULL_TREE
);
7607 if (parm
!= error_mark_node
)
7608 push_parm_decl (parm
);
7611 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7613 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7615 dummy
= ffebld_head (dumlist
);
7616 switch (ffebld_op (dummy
))
7620 continue; /* Forget alternate returns, they mean
7626 s
= ffebld_symter (dummy
);
7627 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
7628 continue; /* Only looking for CHARACTER arguments. */
7629 if (stmtfunc
&& (ffesymbol_size (s
) != FFETARGET_charactersizeNONE
))
7630 continue; /* Stmtfunc arg with known size needs no
7632 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
7633 continue; /* Only looking for variables and arrays. */
7634 parm
= ffesymbol_hook (s
).length_tree
;
7635 assert (parm
!= NULL_TREE
);
7636 if (parm
!= error_mark_node
)
7637 push_parm_decl (parm
);
7640 ffecom_transform_only_dummies_
= FALSE
;
7644 /* ffecom_start_progunit_ -- Beginning of program unit
7646 Does GNU back end stuff necessary to teach it about the start of its
7647 equivalent of a Fortran program unit. */
7649 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7651 ffecom_start_progunit_ ()
7653 ffesymbol fn
= ffecom_primary_entry_
;
7655 tree id
; /* Identifier (name) of function. */
7656 tree type
; /* Type of function. */
7657 tree result
; /* Result of function. */
7658 ffeinfoBasictype bt
;
7662 ffeglobalType egt
= FFEGLOBAL_type
;
7665 bool altentries
= (ffecom_num_entrypoints_
!= 0);
7668 && (ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
7669 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
7670 bool main_program
= FALSE
;
7671 int old_lineno
= lineno
;
7672 char *old_input_filename
= input_filename
;
7675 assert (fn
!= NULL
);
7676 assert (ffesymbol_hook (fn
).decl_tree
== NULL_TREE
);
7678 input_filename
= ffesymbol_where_filename (fn
);
7679 lineno
= ffesymbol_where_filelinenum (fn
);
7681 /* c-parse.y indeed does call suspend_momentary and not only ignores the
7682 return value, but also never calls resume_momentary, when starting an
7683 outer function (see "fndef:", "setspecs:", and so on). So g77 does the
7684 same thing. It shouldn't be a problem since start_function calls
7685 temporary_allocation, but it might be necessary. If it causes a problem
7686 here, then maybe there's a bug lurking in gcc. NOTE: This identical
7687 comment appears twice in thist file. */
7689 suspend_momentary ();
7691 switch (ffecom_primary_entry_kind_
)
7693 case FFEINFO_kindPROGRAM
:
7694 main_program
= TRUE
;
7695 gt
= FFEGLOBAL_typeMAIN
;
7696 bt
= FFEINFO_basictypeNONE
;
7697 kt
= FFEINFO_kindtypeNONE
;
7698 type
= ffecom_tree_fun_type_void
;
7703 case FFEINFO_kindBLOCKDATA
:
7704 gt
= FFEGLOBAL_typeBDATA
;
7705 bt
= FFEINFO_basictypeNONE
;
7706 kt
= FFEINFO_kindtypeNONE
;
7707 type
= ffecom_tree_fun_type_void
;
7712 case FFEINFO_kindFUNCTION
:
7713 gt
= FFEGLOBAL_typeFUNC
;
7714 egt
= FFEGLOBAL_typeEXT
;
7715 bt
= ffesymbol_basictype (fn
);
7716 kt
= ffesymbol_kindtype (fn
);
7717 if (bt
== FFEINFO_basictypeNONE
)
7719 ffeimplic_establish_symbol (fn
);
7720 if (ffesymbol_funcresult (fn
) != NULL
)
7721 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
7722 bt
= ffesymbol_basictype (fn
);
7723 kt
= ffesymbol_kindtype (fn
);
7727 charfunc
= cmplxfunc
= FALSE
;
7728 else if (bt
== FFEINFO_basictypeCHARACTER
)
7729 charfunc
= TRUE
, cmplxfunc
= FALSE
;
7730 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
7731 && ffesymbol_is_f2c (fn
)
7733 charfunc
= FALSE
, cmplxfunc
= TRUE
;
7735 charfunc
= cmplxfunc
= FALSE
;
7737 if (multi
|| charfunc
)
7738 type
= ffecom_tree_fun_type_void
;
7739 else if (ffesymbol_is_f2c (fn
) && !altentries
)
7740 type
= ffecom_tree_fun_type
[bt
][kt
];
7742 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
7744 if ((type
== NULL_TREE
)
7745 || (TREE_TYPE (type
) == NULL_TREE
))
7746 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
7749 case FFEINFO_kindSUBROUTINE
:
7750 gt
= FFEGLOBAL_typeSUBR
;
7751 egt
= FFEGLOBAL_typeEXT
;
7752 bt
= FFEINFO_basictypeNONE
;
7753 kt
= FFEINFO_kindtypeNONE
;
7754 if (ffecom_is_altreturning_
)
7755 type
= ffecom_tree_subr_type
;
7757 type
= ffecom_tree_fun_type_void
;
7763 assert ("say what??" == NULL
);
7765 case FFEINFO_kindANY
:
7766 gt
= FFEGLOBAL_typeANY
;
7767 bt
= FFEINFO_basictypeNONE
;
7768 kt
= FFEINFO_kindtypeNONE
;
7769 type
= error_mark_node
;
7776 id
= ffecom_get_invented_identifier ("__g77_masterfun_%s",
7777 ffesymbol_text (fn
),
7779 #if FFETARGET_isENFORCED_MAIN
7780 else if (main_program
)
7781 id
= get_identifier (FFETARGET_nameENFORCED_MAIN_NAME
);
7784 id
= ffecom_get_external_identifier_ (fn
);
7788 0, /* nested/inline */
7789 !altentries
); /* TREE_PUBLIC */
7792 && ((g
= ffesymbol_global (fn
)) != NULL
)
7793 && ((ffeglobal_type (g
) == gt
)
7794 || (ffeglobal_type (g
) == egt
)))
7796 ffeglobal_set_hook (g
, current_function_decl
);
7799 yes
= suspend_momentary ();
7801 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7802 exec-transitioning needs current_function_decl to be filled in. So we
7803 do these things in two phases. */
7806 { /* 1st arg identifies which entrypoint. */
7807 ffecom_which_entrypoint_decl_
7808 = build_decl (PARM_DECL
,
7809 ffecom_get_invented_identifier ("__g77_%s",
7813 push_parm_decl (ffecom_which_entrypoint_decl_
);
7819 { /* Arg for result (return value). */
7824 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
7826 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
7828 type
= ffecom_multi_type_node_
;
7830 result
= ffecom_get_invented_identifier ("__g77_%s",
7833 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7836 length
= ffecom_char_enhance_arg_ (&type
, fn
);
7838 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
7840 type
= build_pointer_type (type
);
7841 result
= build_decl (PARM_DECL
, result
, type
);
7843 push_parm_decl (result
);
7845 ffecom_multi_retval_
= result
;
7847 ffecom_func_result_
= result
;
7851 push_parm_decl (length
);
7852 ffecom_func_length_
= length
;
7856 if (ffecom_primary_entry_is_proc_
)
7859 arglist
= ffecom_master_arglist_
;
7861 arglist
= ffesymbol_dummyargs (fn
);
7862 ffecom_push_dummy_decls_ (arglist
, FALSE
);
7865 resume_momentary (yes
);
7867 store_parm_decls (main_program
? 1 : 0);
7869 ffecom_start_compstmt_ ();
7871 lineno
= old_lineno
;
7872 input_filename
= old_input_filename
;
7874 /* This handles any symbols still untransformed, in case -g specified.
7875 This used to be done in ffecom_finish_progunit, but it turns out to
7876 be necessary to do it here so that statement functions are
7877 expanded before code. But don't bother for BLOCK DATA. */
7879 if (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
7880 ffesymbol_drive (ffecom_finish_symbol_transform_
);
7884 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7887 ffecom_sym_transform_(s);
7889 The ffesymbol_hook info for s is updated with appropriate backend info
7892 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7894 ffecom_sym_transform_ (ffesymbol s
)
7896 tree t
; /* Transformed thingy. */
7897 tree tlen
; /* Length if CHAR*(*). */
7898 bool addr
; /* Is t the address of the thingy? */
7899 ffeinfoBasictype bt
;
7903 int old_lineno
= lineno
;
7904 char *old_input_filename
= input_filename
;
7906 if (ffesymbol_sfdummyparent (s
) == NULL
)
7908 input_filename
= ffesymbol_where_filename (s
);
7909 lineno
= ffesymbol_where_filelinenum (s
);
7913 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
7915 input_filename
= ffesymbol_where_filename (sf
);
7916 lineno
= ffesymbol_where_filelinenum (sf
);
7919 bt
= ffeinfo_basictype (ffebld_info (s
));
7920 kt
= ffeinfo_kindtype (ffebld_info (s
));
7926 switch (ffesymbol_kind (s
))
7928 case FFEINFO_kindNONE
:
7929 switch (ffesymbol_where (s
))
7931 case FFEINFO_whereDUMMY
: /* Subroutine or function. */
7932 assert (ffecom_transform_only_dummies_
);
7934 /* Before 0.4, this could be ENTITY/DUMMY, but see
7935 ffestu_sym_end_transition -- no longer true (in particular, if
7936 it could be an ENTITY, it _will_ be made one, so that
7937 possibility won't come through here). So we never make length
7938 arg for CHARACTER type. */
7940 t
= build_decl (PARM_DECL
,
7941 ffecom_get_identifier_ (ffesymbol_text (s
)),
7942 ffecom_tree_ptr_to_subr_type
);
7944 DECL_ARTIFICIAL (t
) = 1;
7949 case FFEINFO_whereGLOBAL
: /* Subroutine or function. */
7950 assert (!ffecom_transform_only_dummies_
);
7952 if (((g
= ffesymbol_global (s
)) != NULL
)
7953 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
7954 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7955 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
7956 && (ffeglobal_hook (g
) != NULL_TREE
)
7957 && ffe_is_globals ())
7959 t
= ffeglobal_hook (g
);
7963 push_obstacks_nochange ();
7964 end_temporary_allocation ();
7966 t
= build_decl (FUNCTION_DECL
,
7967 ffecom_get_external_identifier_ (s
),
7968 ffecom_tree_subr_type
); /* Assume subr. */
7969 DECL_EXTERNAL (t
) = 1;
7970 TREE_PUBLIC (t
) = 1;
7972 t
= start_decl (t
, FALSE
);
7973 finish_decl (t
, NULL_TREE
, FALSE
);
7976 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
7977 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7978 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
7979 ffeglobal_set_hook (g
, t
);
7981 resume_temporary_allocation ();
7987 assert ("NONE where unexpected" == NULL
);
7989 case FFEINFO_whereANY
:
7994 case FFEINFO_kindENTITY
:
7995 switch (ffeinfo_where (ffesymbol_info (s
)))
7998 case FFEINFO_whereCONSTANT
: /* ~~debugging info needed? */
7999 assert (!ffecom_transform_only_dummies_
);
8000 t
= error_mark_node
; /* Shouldn't ever see this in expr. */
8003 case FFEINFO_whereLOCAL
:
8004 assert (!ffecom_transform_only_dummies_
);
8007 ffestorag st
= ffesymbol_storage (s
);
8011 && (ffestorag_size (st
) == 0))
8013 t
= error_mark_node
;
8017 yes
= suspend_momentary ();
8018 type
= ffecom_type_localvar_ (s
, bt
, kt
);
8019 resume_momentary (yes
);
8021 if (type
== error_mark_node
)
8023 t
= error_mark_node
;
8028 && (ffestorag_parent (st
) != NULL
))
8029 { /* Child of EQUIVALENCE parent. */
8033 ffetargetOffset offset
;
8035 est
= ffestorag_parent (st
);
8036 ffecom_transform_equiv_ (est
);
8038 et
= ffestorag_hook (est
);
8039 assert (et
!= NULL_TREE
);
8041 if (! TREE_STATIC (et
))
8042 put_var_into_stack (et
);
8044 yes
= suspend_momentary ();
8046 offset
= ffestorag_modulo (est
)
8047 + ffestorag_offset (ffesymbol_storage (s
))
8048 - ffestorag_offset (est
);
8050 ffecom_debug_kludge_ (et
, "EQUIVALENCE", s
, type
, offset
);
8052 /* (t_type *) (((char *) &et) + offset) */
8054 t
= convert (string_type_node
, /* (char *) */
8055 ffecom_1 (ADDR_EXPR
,
8056 build_pointer_type (TREE_TYPE (et
)),
8058 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
8060 build_int_2 (offset
, 0));
8061 t
= convert (build_pointer_type (type
),
8066 resume_momentary (yes
);
8071 bool init
= ffesymbol_is_init (s
);
8073 yes
= suspend_momentary ();
8075 t
= build_decl (VAR_DECL
,
8076 ffecom_get_identifier_ (ffesymbol_text (s
)),
8080 || ffesymbol_namelisted (s
)
8081 #ifdef FFECOM_sizeMAXSTACKITEM
8083 && (ffestorag_size (st
) > FFECOM_sizeMAXSTACKITEM
))
8085 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8086 && (ffecom_primary_entry_kind_
8087 != FFEINFO_kindBLOCKDATA
)
8088 && (ffesymbol_is_save (s
) || ffe_is_saveall ())))
8089 TREE_STATIC (t
) = !ffesymbol_attr (s
, FFESYMBOL_attrADJUSTABLE
);
8091 TREE_STATIC (t
) = 0; /* No need to make static. */
8093 if (init
|| ffe_is_init_local_zero ())
8094 DECL_INITIAL (t
) = error_mark_node
;
8096 /* Keep -Wunused from complaining about var if it
8097 is used as sfunc arg or DATA implied-DO. */
8098 if (ffesymbol_attrs (s
) & FFESYMBOL_attrsSFARG
)
8099 DECL_IN_SYSTEM_HEADER (t
) = 1;
8101 t
= start_decl (t
, FALSE
);
8105 if (ffesymbol_init (s
) != NULL
)
8106 initexpr
= ffecom_expr (ffesymbol_init (s
));
8108 initexpr
= ffecom_init_zero_ (t
);
8110 else if (ffe_is_init_local_zero ())
8111 initexpr
= ffecom_init_zero_ (t
);
8113 initexpr
= NULL_TREE
; /* Not ref'd if !init. */
8115 finish_decl (t
, initexpr
, FALSE
);
8117 if ((st
!= NULL
) && (DECL_SIZE (t
) != error_mark_node
))
8121 size_tree
= size_binop (CEIL_DIV_EXPR
,
8123 size_int (BITS_PER_UNIT
));
8124 assert (TREE_INT_CST_HIGH (size_tree
) == 0);
8125 assert (TREE_INT_CST_LOW (size_tree
) == ffestorag_size (st
));
8128 resume_momentary (yes
);
8133 case FFEINFO_whereRESULT
:
8134 assert (!ffecom_transform_only_dummies_
);
8136 if (bt
== FFEINFO_basictypeCHARACTER
)
8137 { /* Result is already in list of dummies, use
8139 t
= ffecom_func_result_
;
8140 tlen
= ffecom_func_length_
;
8144 if ((ffecom_num_entrypoints_
== 0)
8145 && (bt
== FFEINFO_basictypeCOMPLEX
)
8146 && (ffesymbol_is_f2c (ffecom_primary_entry_
)))
8147 { /* Result is already in list of dummies, use
8149 t
= ffecom_func_result_
;
8153 if (ffecom_func_result_
!= NULL_TREE
)
8155 t
= ffecom_func_result_
;
8158 if ((ffecom_num_entrypoints_
!= 0)
8159 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
))
8161 yes
= suspend_momentary ();
8163 assert (ffecom_multi_retval_
!= NULL_TREE
);
8164 t
= ffecom_1 (INDIRECT_REF
, ffecom_multi_type_node_
,
8165 ffecom_multi_retval_
);
8166 t
= ffecom_2 (COMPONENT_REF
, ffecom_tree_type
[bt
][kt
],
8167 t
, ffecom_multi_fields_
[bt
][kt
]);
8169 resume_momentary (yes
);
8173 yes
= suspend_momentary ();
8175 t
= build_decl (VAR_DECL
,
8176 ffecom_get_identifier_ (ffesymbol_text (s
)),
8177 ffecom_tree_type
[bt
][kt
]);
8178 TREE_STATIC (t
) = 0; /* Put result on stack. */
8179 t
= start_decl (t
, FALSE
);
8180 finish_decl (t
, NULL_TREE
, FALSE
);
8182 ffecom_func_result_
= t
;
8184 resume_momentary (yes
);
8187 case FFEINFO_whereDUMMY
:
8195 bool adjustable
= FALSE
; /* Conditionally adjustable? */
8197 type
= ffecom_tree_type
[bt
][kt
];
8198 if (ffesymbol_sfdummyparent (s
) != NULL
)
8200 if (current_function_decl
== ffecom_outer_function_decl_
)
8201 { /* Exec transition before sfunc
8202 context; get it later. */
8205 t
= ffecom_get_identifier_ (ffesymbol_text
8206 (ffesymbol_sfdummyparent (s
)));
8209 t
= ffecom_get_identifier_ (ffesymbol_text (s
));
8211 assert (ffecom_transform_only_dummies_
);
8213 old_sizes
= get_pending_sizes ();
8214 put_pending_sizes (old_sizes
);
8216 if (bt
== FFEINFO_basictypeCHARACTER
)
8217 tlen
= ffecom_char_enhance_arg_ (&type
, s
);
8218 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
8220 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
8222 if (type
== error_mark_node
)
8225 dim
= ffebld_head (dl
);
8226 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
8227 if ((ffebld_left (dim
) == NULL
) || ffecom_doing_entry_
)
8228 low
= ffecom_integer_one_node
;
8230 low
= ffecom_expr (ffebld_left (dim
));
8231 assert (ffebld_right (dim
) != NULL
);
8232 if ((ffebld_op (ffebld_right (dim
)) == FFEBLD_opSTAR
)
8233 || ffecom_doing_entry_
)
8234 /* Used to just do high=low. But for ffecom_tree_
8235 canonize_ref_, it probably is important to correctly
8236 assess the size. E.g. given COMPLEX C(*),CFUNC and
8237 C(2)=CFUNC(C), overlap can happen, while it can't
8238 for, say, C(1)=CFUNC(C(2)). */
8239 high
= convert (TREE_TYPE (low
),
8240 TYPE_MAX_VALUE (TREE_TYPE (low
)));
8242 high
= ffecom_expr (ffebld_right (dim
));
8244 /* Determine whether array is conditionally adjustable,
8245 to decide whether back-end magic is needed.
8247 Normally the front end uses the back-end function
8248 variable_size to wrap SAVE_EXPR's around expressions
8249 affecting the size/shape of an array so that the
8250 size/shape info doesn't change during execution
8251 of the compiled code even though variables and
8252 functions referenced in those expressions might.
8254 variable_size also makes sure those saved expressions
8255 get evaluated immediately upon entry to the
8256 compiled procedure -- the front end normally doesn't
8257 have to worry about that.
8259 However, there is a problem with this that affects
8260 g77's implementation of entry points, and that is
8261 that it is _not_ true that each invocation of the
8262 compiled procedure is permitted to evaluate
8263 array size/shape info -- because it is possible
8264 that, for some invocations, that info is invalid (in
8265 which case it is "promised" -- i.e. a violation of
8266 the Fortran standard -- that the compiled code
8267 won't reference the array or its size/shape
8268 during that particular invocation).
8270 To phrase this in C terms, consider this gcc function:
8272 void foo (int *n, float (*a)[*n])
8274 // a is "pointer to array ...", fyi.
8277 Suppose that, for some invocations, it is permitted
8278 for a caller of foo to do this:
8282 Now the _written_ code for foo can take such a call
8283 into account by either testing explicitly for whether
8284 (a == NULL) || (n == NULL) -- presumably it is
8285 not permitted to reference *a in various fashions
8286 if (n == NULL) I suppose -- or it can avoid it by
8287 looking at other info (other arguments, static/global
8290 However, this won't work in gcc 2.5.8 because it'll
8291 automatically emit the code to save the "*n"
8292 expression, which'll yield a NULL dereference for
8293 the "foo (NULL, NULL)" call, something the code
8294 for foo cannot prevent.
8296 g77 definitely needs to avoid executing such
8297 code anytime the pointer to the adjustable array
8298 is NULL, because even if its bounds expressions
8299 don't have any references to possible "absent"
8300 variables like "*n" -- say all variable references
8301 are to COMMON variables, i.e. global (though in C,
8302 local static could actually make sense) -- the
8303 expressions could yield other run-time problems
8304 for allowably "dead" values in those variables.
8306 For example, let's consider a more complicated
8312 void foo (float (*a)[i/j])
8317 The above is (essentially) quite valid for Fortran
8318 but, again, for a call like "foo (NULL);", it is
8319 permitted for i and j to be undefined when the
8320 call is made. If j happened to be zero, for
8321 example, emitting the code to evaluate "i/j"
8322 could result in a run-time error.
8324 Offhand, though I don't have my F77 or F90
8325 standards handy, it might even be valid for a
8326 bounds expression to contain a function reference,
8327 in which case I doubt it is permitted for an
8328 implementation to invoke that function in the
8329 Fortran case involved here (invocation of an
8330 alternate ENTRY point that doesn't have the adjustable
8331 array as one of its arguments).
8333 So, the code that the compiler would normally emit
8334 to preevaluate the size/shape info for an
8335 adjustable array _must not_ be executed at run time
8336 in certain cases. Specifically, for Fortran,
8337 the case is when the pointer to the adjustable
8338 array == NULL. (For gnu-ish C, it might be nice
8339 for the source code itself to specify an expression
8340 that, if TRUE, inhibits execution of the code. Or
8341 reverse the sense for elegance.)
8343 (Note that g77 could use a different test than NULL,
8344 actually, since it happens to always pass an
8345 integer to the called function that specifies which
8346 entry point is being invoked. Hmm, this might
8347 solve the next problem.)
8349 One way a user could, I suppose, write "foo" so
8350 it works is to insert COND_EXPR's for the
8351 size/shape info so the dangerous stuff isn't
8352 actually done, as in:
8354 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
8359 The next problem is that the front end needs to
8360 be able to tell the back end about the array's
8361 decl _before_ it tells it about the conditional
8362 expression to inhibit evaluation of size/shape info,
8365 To solve this, the front end needs to be able
8366 to give the back end the expression to inhibit
8367 generation of the preevaluation code _after_
8368 it makes the decl for the adjustable array.
8370 Until then, the above example using the COND_EXPR
8371 doesn't pass muster with gcc because the "(a == NULL)"
8372 part has a reference to "a", which is still
8373 undefined at that point.
8375 g77 will therefore use a different mechanism in the
8379 && ((TREE_CODE (low
) != INTEGER_CST
)
8380 || (TREE_CODE (high
) != INTEGER_CST
)))
8383 #if 0 /* Old approach -- see below. */
8384 if (TREE_CODE (low
) != INTEGER_CST
)
8385 low
= ffecom_3 (COND_EXPR
, integer_type_node
,
8386 ffecom_adjarray_passed_ (s
),
8388 ffecom_integer_zero_node
);
8390 if (TREE_CODE (high
) != INTEGER_CST
)
8391 high
= ffecom_3 (COND_EXPR
, integer_type_node
,
8392 ffecom_adjarray_passed_ (s
),
8394 ffecom_integer_zero_node
);
8397 /* ~~~gcc/stor-layout.c/layout_type should do this,
8398 probably. Fixes 950302-1.f. */
8400 if (TREE_CODE (low
) != INTEGER_CST
)
8401 low
= variable_size (low
);
8403 /* ~~~similarly, this fixes dumb0.f. The C front end
8404 does this, which is why dumb0.c would work. */
8406 if (TREE_CODE (high
) != INTEGER_CST
)
8407 high
= variable_size (high
);
8412 build_range_type (ffecom_integer_type_node
,
8414 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
8417 if (type
== error_mark_node
)
8419 t
= error_mark_node
;
8423 if ((ffesymbol_sfdummyparent (s
) == NULL
)
8424 || (ffesymbol_basictype (s
) == FFEINFO_basictypeCHARACTER
))
8426 type
= build_pointer_type (type
);
8430 t
= build_decl (PARM_DECL
, t
, type
);
8432 DECL_ARTIFICIAL (t
) = 1;
8435 /* If this arg is present in every entry point's list of
8436 dummy args, then we're done. */
8438 if (ffesymbol_numentries (s
)
8439 == (ffecom_num_entrypoints_
+ 1))
8444 /* If variable_size in stor-layout has been called during
8445 the above, then get_pending_sizes should have the
8446 yet-to-be-evaluated saved expressions pending.
8447 Make the whole lot of them get emitted, conditionally
8448 on whether the array decl ("t" above) is not NULL. */
8451 tree sizes
= get_pending_sizes ();
8456 tem
= TREE_CHAIN (tem
))
8458 tree temv
= TREE_VALUE (tem
);
8464 = ffecom_2 (COMPOUND_EXPR
,
8473 = ffecom_3 (COND_EXPR
,
8480 convert (TREE_TYPE (sizes
),
8481 integer_zero_node
));
8482 sizes
= ffecom_save_tree (sizes
);
8485 = tree_cons (NULL_TREE
, sizes
, tem
);
8489 put_pending_sizes (sizes
);
8495 && (ffesymbol_numentries (s
)
8496 != ffecom_num_entrypoints_
+ 1))
8498 = ffecom_2 (NE_EXPR
, integer_type_node
,
8504 && (ffesymbol_numentries (s
)
8505 != ffecom_num_entrypoints_
+ 1))
8507 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED
);
8508 ffebad_here (0, ffesymbol_where_line (s
),
8509 ffesymbol_where_column (s
));
8510 ffebad_string (ffesymbol_text (s
));
8519 case FFEINFO_whereCOMMON
:
8524 ffestorag st
= ffesymbol_storage (s
);
8528 cs
= ffesymbol_common (s
); /* The COMMON area itself. */
8529 if (st
!= NULL
) /* Else not laid out. */
8531 ffecom_transform_common_ (cs
);
8532 st
= ffesymbol_storage (s
);
8535 yes
= suspend_momentary ();
8537 type
= ffecom_type_localvar_ (s
, bt
, kt
);
8539 cg
= ffesymbol_global (cs
); /* The global COMMON info. */
8541 || (ffeglobal_type (cg
) != FFEGLOBAL_typeCOMMON
))
8544 ct
= ffeglobal_hook (cg
); /* The common area's tree. */
8546 if ((ct
== NULL_TREE
)
8548 || (type
== error_mark_node
))
8549 t
= error_mark_node
;
8552 ffetargetOffset offset
;
8555 cst
= ffestorag_parent (st
);
8556 assert (cst
== ffesymbol_storage (cs
));
8558 offset
= ffestorag_modulo (cst
)
8559 + ffestorag_offset (st
)
8560 - ffestorag_offset (cst
);
8562 ffecom_debug_kludge_ (ct
, "COMMON", s
, type
, offset
);
8564 /* (t_type *) (((char *) &ct) + offset) */
8566 t
= convert (string_type_node
, /* (char *) */
8567 ffecom_1 (ADDR_EXPR
,
8568 build_pointer_type (TREE_TYPE (ct
)),
8570 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
8572 build_int_2 (offset
, 0));
8573 t
= convert (build_pointer_type (type
),
8579 resume_momentary (yes
);
8583 case FFEINFO_whereIMMEDIATE
:
8584 case FFEINFO_whereGLOBAL
:
8585 case FFEINFO_whereFLEETING
:
8586 case FFEINFO_whereFLEETING_CADDR
:
8587 case FFEINFO_whereFLEETING_IADDR
:
8588 case FFEINFO_whereINTRINSIC
:
8589 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8591 assert ("ENTITY where unheard of" == NULL
);
8593 case FFEINFO_whereANY
:
8594 t
= error_mark_node
;
8599 case FFEINFO_kindFUNCTION
:
8600 switch (ffeinfo_where (ffesymbol_info (s
)))
8602 case FFEINFO_whereLOCAL
: /* Me. */
8603 assert (!ffecom_transform_only_dummies_
);
8604 t
= current_function_decl
;
8607 case FFEINFO_whereGLOBAL
:
8608 assert (!ffecom_transform_only_dummies_
);
8610 if (((g
= ffesymbol_global (s
)) != NULL
)
8611 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8612 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8613 && (ffeglobal_hook (g
) != NULL_TREE
)
8614 && ffe_is_globals ())
8616 t
= ffeglobal_hook (g
);
8620 push_obstacks_nochange ();
8621 end_temporary_allocation ();
8623 if (ffesymbol_is_f2c (s
)
8624 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8625 t
= ffecom_tree_fun_type
[bt
][kt
];
8627 t
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
8629 t
= build_decl (FUNCTION_DECL
,
8630 ffecom_get_external_identifier_ (s
),
8632 DECL_EXTERNAL (t
) = 1;
8633 TREE_PUBLIC (t
) = 1;
8635 t
= start_decl (t
, FALSE
);
8636 finish_decl (t
, NULL_TREE
, FALSE
);
8639 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8640 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8641 ffeglobal_set_hook (g
, t
);
8643 resume_temporary_allocation ();
8648 case FFEINFO_whereDUMMY
:
8649 assert (ffecom_transform_only_dummies_
);
8651 if (ffesymbol_is_f2c (s
)
8652 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8653 t
= ffecom_tree_ptr_to_fun_type
[bt
][kt
];
8655 t
= build_pointer_type
8656 (build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
));
8658 t
= build_decl (PARM_DECL
,
8659 ffecom_get_identifier_ (ffesymbol_text (s
)),
8662 DECL_ARTIFICIAL (t
) = 1;
8667 case FFEINFO_whereCONSTANT
: /* Statement function. */
8668 assert (!ffecom_transform_only_dummies_
);
8669 t
= ffecom_gen_sfuncdef_ (s
, bt
, kt
);
8672 case FFEINFO_whereINTRINSIC
:
8673 assert (!ffecom_transform_only_dummies_
);
8674 break; /* Let actual references generate their
8678 assert ("FUNCTION where unheard of" == NULL
);
8680 case FFEINFO_whereANY
:
8681 t
= error_mark_node
;
8686 case FFEINFO_kindSUBROUTINE
:
8687 switch (ffeinfo_where (ffesymbol_info (s
)))
8689 case FFEINFO_whereLOCAL
: /* Me. */
8690 assert (!ffecom_transform_only_dummies_
);
8691 t
= current_function_decl
;
8694 case FFEINFO_whereGLOBAL
:
8695 assert (!ffecom_transform_only_dummies_
);
8697 if (((g
= ffesymbol_global (s
)) != NULL
)
8698 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8699 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8700 && (ffeglobal_hook (g
) != NULL_TREE
)
8701 && ffe_is_globals ())
8703 t
= ffeglobal_hook (g
);
8707 push_obstacks_nochange ();
8708 end_temporary_allocation ();
8710 t
= build_decl (FUNCTION_DECL
,
8711 ffecom_get_external_identifier_ (s
),
8712 ffecom_tree_subr_type
);
8713 DECL_EXTERNAL (t
) = 1;
8714 TREE_PUBLIC (t
) = 1;
8716 t
= start_decl (t
, FALSE
);
8717 finish_decl (t
, NULL_TREE
, FALSE
);
8720 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8721 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8722 ffeglobal_set_hook (g
, t
);
8724 resume_temporary_allocation ();
8729 case FFEINFO_whereDUMMY
:
8730 assert (ffecom_transform_only_dummies_
);
8732 t
= build_decl (PARM_DECL
,
8733 ffecom_get_identifier_ (ffesymbol_text (s
)),
8734 ffecom_tree_ptr_to_subr_type
);
8736 DECL_ARTIFICIAL (t
) = 1;
8741 case FFEINFO_whereINTRINSIC
:
8742 assert (!ffecom_transform_only_dummies_
);
8743 break; /* Let actual references generate their
8747 assert ("SUBROUTINE where unheard of" == NULL
);
8749 case FFEINFO_whereANY
:
8750 t
= error_mark_node
;
8755 case FFEINFO_kindPROGRAM
:
8756 switch (ffeinfo_where (ffesymbol_info (s
)))
8758 case FFEINFO_whereLOCAL
: /* Me. */
8759 assert (!ffecom_transform_only_dummies_
);
8760 t
= current_function_decl
;
8763 case FFEINFO_whereCOMMON
:
8764 case FFEINFO_whereDUMMY
:
8765 case FFEINFO_whereGLOBAL
:
8766 case FFEINFO_whereRESULT
:
8767 case FFEINFO_whereFLEETING
:
8768 case FFEINFO_whereFLEETING_CADDR
:
8769 case FFEINFO_whereFLEETING_IADDR
:
8770 case FFEINFO_whereIMMEDIATE
:
8771 case FFEINFO_whereINTRINSIC
:
8772 case FFEINFO_whereCONSTANT
:
8773 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8775 assert ("PROGRAM where unheard of" == NULL
);
8777 case FFEINFO_whereANY
:
8778 t
= error_mark_node
;
8783 case FFEINFO_kindBLOCKDATA
:
8784 switch (ffeinfo_where (ffesymbol_info (s
)))
8786 case FFEINFO_whereLOCAL
: /* Me. */
8787 assert (!ffecom_transform_only_dummies_
);
8788 t
= current_function_decl
;
8791 case FFEINFO_whereGLOBAL
:
8792 assert (!ffecom_transform_only_dummies_
);
8794 push_obstacks_nochange ();
8795 end_temporary_allocation ();
8797 t
= build_decl (FUNCTION_DECL
,
8798 ffecom_get_external_identifier_ (s
),
8799 ffecom_tree_blockdata_type
);
8800 DECL_EXTERNAL (t
) = 1;
8801 TREE_PUBLIC (t
) = 1;
8803 t
= start_decl (t
, FALSE
);
8804 finish_decl (t
, NULL_TREE
, FALSE
);
8806 resume_temporary_allocation ();
8811 case FFEINFO_whereCOMMON
:
8812 case FFEINFO_whereDUMMY
:
8813 case FFEINFO_whereRESULT
:
8814 case FFEINFO_whereFLEETING
:
8815 case FFEINFO_whereFLEETING_CADDR
:
8816 case FFEINFO_whereFLEETING_IADDR
:
8817 case FFEINFO_whereIMMEDIATE
:
8818 case FFEINFO_whereINTRINSIC
:
8819 case FFEINFO_whereCONSTANT
:
8820 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8822 assert ("BLOCKDATA where unheard of" == NULL
);
8824 case FFEINFO_whereANY
:
8825 t
= error_mark_node
;
8830 case FFEINFO_kindCOMMON
:
8831 switch (ffeinfo_where (ffesymbol_info (s
)))
8833 case FFEINFO_whereLOCAL
:
8834 assert (!ffecom_transform_only_dummies_
);
8835 ffecom_transform_common_ (s
);
8838 case FFEINFO_whereNONE
:
8839 case FFEINFO_whereCOMMON
:
8840 case FFEINFO_whereDUMMY
:
8841 case FFEINFO_whereGLOBAL
:
8842 case FFEINFO_whereRESULT
:
8843 case FFEINFO_whereFLEETING
:
8844 case FFEINFO_whereFLEETING_CADDR
:
8845 case FFEINFO_whereFLEETING_IADDR
:
8846 case FFEINFO_whereIMMEDIATE
:
8847 case FFEINFO_whereINTRINSIC
:
8848 case FFEINFO_whereCONSTANT
:
8849 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8851 assert ("COMMON where unheard of" == NULL
);
8853 case FFEINFO_whereANY
:
8854 t
= error_mark_node
;
8859 case FFEINFO_kindCONSTRUCT
:
8860 switch (ffeinfo_where (ffesymbol_info (s
)))
8862 case FFEINFO_whereLOCAL
:
8863 assert (!ffecom_transform_only_dummies_
);
8866 case FFEINFO_whereNONE
:
8867 case FFEINFO_whereCOMMON
:
8868 case FFEINFO_whereDUMMY
:
8869 case FFEINFO_whereGLOBAL
:
8870 case FFEINFO_whereRESULT
:
8871 case FFEINFO_whereFLEETING
:
8872 case FFEINFO_whereFLEETING_CADDR
:
8873 case FFEINFO_whereFLEETING_IADDR
:
8874 case FFEINFO_whereIMMEDIATE
:
8875 case FFEINFO_whereINTRINSIC
:
8876 case FFEINFO_whereCONSTANT
:
8877 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8879 assert ("CONSTRUCT where unheard of" == NULL
);
8881 case FFEINFO_whereANY
:
8882 t
= error_mark_node
;
8887 case FFEINFO_kindNAMELIST
:
8888 switch (ffeinfo_where (ffesymbol_info (s
)))
8890 case FFEINFO_whereLOCAL
:
8891 assert (!ffecom_transform_only_dummies_
);
8892 t
= ffecom_transform_namelist_ (s
);
8895 case FFEINFO_whereNONE
:
8896 case FFEINFO_whereCOMMON
:
8897 case FFEINFO_whereDUMMY
:
8898 case FFEINFO_whereGLOBAL
:
8899 case FFEINFO_whereRESULT
:
8900 case FFEINFO_whereFLEETING
:
8901 case FFEINFO_whereFLEETING_CADDR
:
8902 case FFEINFO_whereFLEETING_IADDR
:
8903 case FFEINFO_whereIMMEDIATE
:
8904 case FFEINFO_whereINTRINSIC
:
8905 case FFEINFO_whereCONSTANT
:
8906 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8908 assert ("NAMELIST where unheard of" == NULL
);
8910 case FFEINFO_whereANY
:
8911 t
= error_mark_node
;
8917 assert ("kind unheard of" == NULL
);
8919 case FFEINFO_kindANY
:
8920 t
= error_mark_node
;
8924 ffesymbol_hook (s
).decl_tree
= t
;
8925 ffesymbol_hook (s
).length_tree
= tlen
;
8926 ffesymbol_hook (s
).addr
= addr
;
8928 lineno
= old_lineno
;
8929 input_filename
= old_input_filename
;
8935 /* Transform into ASSIGNable symbol.
8937 Symbol has already been transformed, but for whatever reason, the
8938 resulting decl_tree has been deemed not usable for an ASSIGN target.
8939 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8940 another local symbol of type void * and stuff that in the assign_tree
8941 argument. The F77/F90 standards allow this implementation. */
8943 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8945 ffecom_sym_transform_assign_ (ffesymbol s
)
8947 tree t
; /* Transformed thingy. */
8949 int old_lineno
= lineno
;
8950 char *old_input_filename
= input_filename
;
8952 if (ffesymbol_sfdummyparent (s
) == NULL
)
8954 input_filename
= ffesymbol_where_filename (s
);
8955 lineno
= ffesymbol_where_filelinenum (s
);
8959 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
8961 input_filename
= ffesymbol_where_filename (sf
);
8962 lineno
= ffesymbol_where_filelinenum (sf
);
8965 assert (!ffecom_transform_only_dummies_
);
8967 yes
= suspend_momentary ();
8969 t
= build_decl (VAR_DECL
,
8970 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8973 TREE_TYPE (null_pointer_node
));
8975 switch (ffesymbol_where (s
))
8977 case FFEINFO_whereLOCAL
:
8978 /* Unlike for regular vars, SAVE status is easy to determine for
8979 ASSIGNed vars, since there's no initialization, there's no
8980 effective storage association (so "SAVE J" does not apply to
8981 K even given "EQUIVALENCE (J,K)"), there's no size issue
8982 to worry about, etc. */
8983 if ((ffesymbol_is_save (s
) || ffe_is_saveall ())
8984 && (ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8985 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
))
8986 TREE_STATIC (t
) = 1; /* SAVEd in proc, make static. */
8988 TREE_STATIC (t
) = 0; /* No need to make static. */
8991 case FFEINFO_whereCOMMON
:
8992 TREE_STATIC (t
) = 1; /* Assume COMMONs always SAVEd. */
8995 case FFEINFO_whereDUMMY
:
8996 /* Note that twinning a DUMMY means the caller won't see
8997 the ASSIGNed value. But both F77 and F90 allow implementations
8998 to do this, i.e. disallow Fortran code that would try and
8999 take advantage of actually putting a label into a variable
9000 via a dummy argument (or any other storage association, for
9002 TREE_STATIC (t
) = 0;
9006 TREE_STATIC (t
) = 0;
9010 t
= start_decl (t
, FALSE
);
9011 finish_decl (t
, NULL_TREE
, FALSE
);
9013 resume_momentary (yes
);
9015 ffesymbol_hook (s
).assign_tree
= t
;
9017 lineno
= old_lineno
;
9018 input_filename
= old_input_filename
;
9024 /* Implement COMMON area in back end.
9026 Because COMMON-based variables can be referenced in the dimension
9027 expressions of dummy (adjustable) arrays, and because dummies
9028 (in the gcc back end) need to be put in the outer binding level
9029 of a function (which has two binding levels, the outer holding
9030 the dummies and the inner holding the other vars), special care
9031 must be taken to handle COMMON areas.
9033 The current strategy is basically to always tell the back end about
9034 the COMMON area as a top-level external reference to just a block
9035 of storage of the master type of that area (e.g. integer, real,
9036 character, whatever -- not a structure). As a distinct action,
9037 if initial values are provided, tell the back end about the area
9038 as a top-level non-external (initialized) area and remember not to
9039 allow further initialization or expansion of the area. Meanwhile,
9040 if no initialization happens at all, tell the back end about
9041 the largest size we've seen declared so the space does get reserved.
9042 (This function doesn't handle all that stuff, but it does some
9043 of the important things.)
9045 Meanwhile, for COMMON variables themselves, just keep creating
9046 references like *((float *) (&common_area + offset)) each time
9047 we reference the variable. In other words, don't make a VAR_DECL
9048 or any kind of component reference (like we used to do before 0.4),
9049 though we might do that as well just for debugging purposes (and
9050 stuff the rtl with the appropriate offset expression). */
9052 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9054 ffecom_transform_common_ (ffesymbol s
)
9056 ffestorag st
= ffesymbol_storage (s
);
9057 ffeglobal g
= ffesymbol_global (s
);
9061 bool is_init
= ffestorag_is_init (st
);
9063 assert (st
!= NULL
);
9066 || (ffeglobal_type (g
) != FFEGLOBAL_typeCOMMON
))
9069 /* First update the size of the area in global terms. */
9071 ffeglobal_size_common (s
, ffestorag_size (st
));
9073 if (!ffeglobal_common_init (g
))
9074 is_init
= FALSE
; /* No explicit init, don't let erroneous joins init. */
9076 cbt
= ffeglobal_hook (g
);
9078 /* If we already have declared this common block for a previous program
9079 unit, and either we already initialized it or we don't have new
9080 initialization for it, just return what we have without changing it. */
9082 if ((cbt
!= NULL_TREE
)
9084 || !DECL_EXTERNAL (cbt
)))
9087 /* Process inits. */
9091 if (ffestorag_init (st
) != NULL
)
9093 init
= ffecom_expr (ffestorag_init (st
));
9094 if (init
== error_mark_node
)
9095 { /* Hopefully the back end complained! */
9097 if (cbt
!= NULL_TREE
)
9102 init
= error_mark_node
;
9107 push_obstacks_nochange ();
9108 end_temporary_allocation ();
9110 /* cbtype must be permanently allocated! */
9113 cbtype
= build_array_type (char_type_node
,
9114 build_range_type (integer_type_node
,
9117 (ffeglobal_common_size (g
),
9120 cbtype
= build_array_type (char_type_node
, NULL_TREE
);
9122 if (cbt
== NULL_TREE
)
9125 = build_decl (VAR_DECL
,
9126 ffecom_get_external_identifier_ (s
),
9128 TREE_STATIC (cbt
) = 1;
9129 TREE_PUBLIC (cbt
) = 1;
9134 TREE_TYPE (cbt
) = cbtype
;
9136 DECL_EXTERNAL (cbt
) = init
? 0 : 1;
9137 DECL_INITIAL (cbt
) = init
? error_mark_node
: NULL_TREE
;
9139 cbt
= start_decl (cbt
, TRUE
);
9140 if (ffeglobal_hook (g
) != NULL
)
9141 assert (cbt
== ffeglobal_hook (g
));
9143 assert (!init
|| !DECL_EXTERNAL (cbt
));
9145 /* Make sure that any type can live in COMMON and be referenced
9146 without getting a bus error. We could pick the most restrictive
9147 alignment of all entities actually placed in the COMMON, but
9148 this seems easy enough. */
9150 DECL_ALIGN (cbt
) = BIGGEST_ALIGNMENT
;
9152 if (is_init
&& (ffestorag_init (st
) == NULL
))
9153 init
= ffecom_init_zero_ (cbt
);
9155 finish_decl (cbt
, init
, TRUE
);
9158 ffestorag_set_init (st
, ffebld_new_any ());
9164 assert (DECL_SIZE (cbt
) != NULL_TREE
);
9165 assert (TREE_CODE (DECL_SIZE (cbt
)) == INTEGER_CST
);
9166 size_tree
= size_binop (CEIL_DIV_EXPR
,
9168 size_int (BITS_PER_UNIT
));
9169 assert (TREE_INT_CST_HIGH (size_tree
) == 0);
9170 assert (TREE_INT_CST_LOW (size_tree
) == ffeglobal_common_size (g
));
9173 ffeglobal_set_hook (g
, cbt
);
9175 ffestorag_set_hook (st
, cbt
);
9177 resume_temporary_allocation ();
9182 /* Make master area for local EQUIVALENCE. */
9184 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9186 ffecom_transform_equiv_ (ffestorag eqst
)
9192 bool is_init
= ffestorag_is_init (eqst
);
9195 assert (eqst
!= NULL
);
9197 eqt
= ffestorag_hook (eqst
);
9199 if (eqt
!= NULL_TREE
)
9202 /* Process inits. */
9206 if (ffestorag_init (eqst
) != NULL
)
9208 init
= ffecom_expr (ffestorag_init (eqst
));
9209 if (init
== error_mark_node
)
9210 init
= NULL_TREE
; /* Hopefully the back end complained! */
9213 init
= error_mark_node
;
9215 else if (ffe_is_init_local_zero ())
9216 init
= error_mark_node
;
9220 ffecom_member_namelisted_
= FALSE
;
9221 ffestorag_drive (ffestorag_list_equivs (eqst
),
9222 &ffecom_member_phase1_
,
9225 yes
= suspend_momentary ();
9227 high
= build_int_2 (ffestorag_size (eqst
), 0);
9228 TREE_TYPE (high
) = ffecom_integer_type_node
;
9230 eqtype
= build_array_type (char_type_node
,
9231 build_range_type (ffecom_integer_type_node
,
9232 ffecom_integer_one_node
,
9235 eqt
= build_decl (VAR_DECL
,
9236 ffecom_get_invented_identifier ("__g77_equiv_%s",
9242 DECL_EXTERNAL (eqt
) = 0;
9244 || ffecom_member_namelisted_
9245 #ifdef FFECOM_sizeMAXSTACKITEM
9246 || (ffestorag_size (eqst
) > FFECOM_sizeMAXSTACKITEM
)
9248 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
9249 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
9250 && (ffestorag_is_save (eqst
) || ffe_is_saveall ())))
9251 TREE_STATIC (eqt
) = 1;
9253 TREE_STATIC (eqt
) = 0;
9254 TREE_PUBLIC (eqt
) = 0;
9255 DECL_CONTEXT (eqt
) = current_function_decl
;
9257 DECL_INITIAL (eqt
) = error_mark_node
;
9259 DECL_INITIAL (eqt
) = NULL_TREE
;
9261 eqt
= start_decl (eqt
, FALSE
);
9263 /* Make sure this shows up as a debug symbol, which is not normally
9264 the case for invented identifiers. */
9266 DECL_IGNORED_P (eqt
) = 0;
9268 /* Make sure that any type can live in EQUIVALENCE and be referenced
9269 without getting a bus error. We could pick the most restrictive
9270 alignment of all entities actually placed in the EQUIVALENCE, but
9271 this seems easy enough. */
9273 DECL_ALIGN (eqt
) = BIGGEST_ALIGNMENT
;
9275 if ((!is_init
&& ffe_is_init_local_zero ())
9276 || (is_init
&& (ffestorag_init (eqst
) == NULL
)))
9277 init
= ffecom_init_zero_ (eqt
);
9279 finish_decl (eqt
, init
, FALSE
);
9282 ffestorag_set_init (eqst
, ffebld_new_any ());
9287 size_tree
= size_binop (CEIL_DIV_EXPR
,
9289 size_int (BITS_PER_UNIT
));
9290 assert (TREE_INT_CST_HIGH (size_tree
) == 0);
9291 assert (TREE_INT_CST_LOW (size_tree
) == ffestorag_size (eqst
));
9294 ffestorag_set_hook (eqst
, eqt
);
9296 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
9297 ffestorag_drive (ffestorag_list_equivs (eqst
),
9298 &ffecom_member_phase2_
,
9302 resume_momentary (yes
);
9306 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
9308 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9310 ffecom_transform_namelist_ (ffesymbol s
)
9313 tree nmltype
= ffecom_type_namelist_ ();
9322 static int mynumber
= 0;
9324 yes
= suspend_momentary ();
9326 nmlt
= build_decl (VAR_DECL
,
9327 ffecom_get_invented_identifier ("__g77_namelist_%d",
9330 TREE_STATIC (nmlt
) = 1;
9331 DECL_INITIAL (nmlt
) = error_mark_node
;
9333 nmlt
= start_decl (nmlt
, FALSE
);
9335 /* Process inits. */
9337 i
= strlen (ffesymbol_text (s
));
9339 high
= build_int_2 (i
, 0);
9340 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
9342 nameinit
= ffecom_build_f2c_string_ (i
+ 1,
9343 ffesymbol_text (s
));
9344 TREE_TYPE (nameinit
)
9345 = build_type_variant
9348 build_range_type (ffecom_f2c_ftnlen_type_node
,
9349 ffecom_f2c_ftnlen_one_node
,
9352 TREE_CONSTANT (nameinit
) = 1;
9353 TREE_STATIC (nameinit
) = 1;
9354 nameinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (nameinit
)),
9357 varsinit
= ffecom_vardesc_array_ (s
);
9358 varsinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (varsinit
)),
9360 TREE_CONSTANT (varsinit
) = 1;
9361 TREE_STATIC (varsinit
) = 1;
9366 for (i
= 0, b
= ffesymbol_namelist (s
); b
!= NULL
; b
= ffebld_trail (b
))
9369 nvarsinit
= build_int_2 (i
, 0);
9370 TREE_TYPE (nvarsinit
) = integer_type_node
;
9371 TREE_CONSTANT (nvarsinit
) = 1;
9372 TREE_STATIC (nvarsinit
) = 1;
9374 nmlinits
= build_tree_list ((field
= TYPE_FIELDS (nmltype
)), nameinit
);
9375 TREE_CHAIN (nmlinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
9377 TREE_CHAIN (TREE_CHAIN (nmlinits
))
9378 = build_tree_list ((field
= TREE_CHAIN (field
)), nvarsinit
);
9380 nmlinits
= build (CONSTRUCTOR
, nmltype
, NULL_TREE
, nmlinits
);
9381 TREE_CONSTANT (nmlinits
) = 1;
9382 TREE_STATIC (nmlinits
) = 1;
9384 finish_decl (nmlt
, nmlinits
, FALSE
);
9386 nmlt
= ffecom_1 (ADDR_EXPR
, build_pointer_type (nmltype
), nmlt
);
9388 resume_momentary (yes
);
9395 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
9396 analyzed on the assumption it is calculating a pointer to be
9397 indirected through. It must return the proper decl and offset,
9398 taking into account different units of measurements for offsets. */
9400 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9402 ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
9405 switch (TREE_CODE (t
))
9409 case NON_LVALUE_EXPR
:
9410 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
9414 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
9415 if ((*decl
== NULL_TREE
)
9416 || (*decl
== error_mark_node
))
9419 if (TREE_CODE (TREE_OPERAND (t
, 1)) == INTEGER_CST
)
9421 /* An offset into COMMON. */
9422 *offset
= size_binop (PLUS_EXPR
,
9424 TREE_OPERAND (t
, 1));
9425 /* Convert offset (presumably in bytes) into canonical units
9426 (presumably bits). */
9427 *offset
= size_binop (MULT_EXPR
,
9429 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t
))));
9432 /* Not a COMMON reference, so an unrecognized pattern. */
9433 *decl
= error_mark_node
;
9438 *offset
= size_zero_node
;
9442 if (TREE_CODE (TREE_OPERAND (t
, 0)) == VAR_DECL
)
9444 /* A reference to COMMON. */
9445 *decl
= TREE_OPERAND (t
, 0);
9446 *offset
= size_zero_node
;
9451 /* Not a COMMON reference, so an unrecognized pattern. */
9452 *decl
= error_mark_node
;
9458 /* Given a tree that is possibly intended for use as an lvalue, return
9459 information representing a canonical view of that tree as a decl, an
9460 offset into that decl, and a size for the lvalue.
9462 If there's no applicable decl, NULL_TREE is returned for the decl,
9463 and the other fields are left undefined.
9465 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9466 is returned for the decl, and the other fields are left undefined.
9468 Otherwise, the decl returned currently is either a VAR_DECL or a
9471 The offset returned is always valid, but of course not necessarily
9472 a constant, and not necessarily converted into the appropriate
9473 type, leaving that up to the caller (so as to avoid that overhead
9474 if the decls being looked at are different anyway).
9476 If the size cannot be determined (e.g. an adjustable array),
9477 an ERROR_MARK node is returned for the size. Otherwise, the
9478 size returned is valid, not necessarily a constant, and not
9479 necessarily converted into the appropriate type as with the
9482 Note that the offset and size expressions are expressed in the
9483 base storage units (usually bits) rather than in the units of
9484 the type of the decl, because two decls with different types
9485 might overlap but with apparently non-overlapping array offsets,
9486 whereas converting the array offsets to consistant offsets will
9487 reveal the overlap. */
9489 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9491 ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
9494 /* The default path is to report a nonexistant decl. */
9500 switch (TREE_CODE (t
))
9503 case IDENTIFIER_NODE
:
9512 case TRUNC_DIV_EXPR
:
9514 case FLOOR_DIV_EXPR
:
9515 case ROUND_DIV_EXPR
:
9516 case TRUNC_MOD_EXPR
:
9518 case FLOOR_MOD_EXPR
:
9519 case ROUND_MOD_EXPR
:
9521 case EXACT_DIV_EXPR
:
9522 case FIX_TRUNC_EXPR
:
9524 case FIX_FLOOR_EXPR
:
9525 case FIX_ROUND_EXPR
:
9540 case BIT_ANDTC_EXPR
:
9542 case TRUTH_ANDIF_EXPR
:
9543 case TRUTH_ORIF_EXPR
:
9544 case TRUTH_AND_EXPR
:
9546 case TRUTH_XOR_EXPR
:
9547 case TRUTH_NOT_EXPR
:
9567 *offset
= size_zero_node
;
9568 *size
= TYPE_SIZE (TREE_TYPE (t
));
9573 tree array
= TREE_OPERAND (t
, 0);
9574 tree element
= TREE_OPERAND (t
, 1);
9577 if ((array
== NULL_TREE
)
9578 || (element
== NULL_TREE
))
9580 *decl
= error_mark_node
;
9584 ffecom_tree_canonize_ref_ (decl
, &init_offset
, size
,
9586 if ((*decl
== NULL_TREE
)
9587 || (*decl
== error_mark_node
))
9590 *offset
= size_binop (MULT_EXPR
,
9591 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array
))),
9592 size_binop (MINUS_EXPR
,
9596 (TREE_TYPE (array
)))));
9598 *offset
= size_binop (PLUS_EXPR
,
9602 *size
= TYPE_SIZE (TREE_TYPE (t
));
9608 /* Most of this code is to handle references to COMMON. And so
9609 far that is useful only for calling library functions, since
9610 external (user) functions might reference common areas. But
9611 even calling an external function, it's worthwhile to decode
9612 COMMON references because if not storing into COMMON, we don't
9613 want COMMON-based arguments to gratuitously force use of a
9616 *size
= TYPE_SIZE (TREE_TYPE (t
));
9618 ffecom_tree_canonize_ptr_ (decl
, offset
,
9619 TREE_OPERAND (t
, 0));
9626 case NON_LVALUE_EXPR
:
9629 case COND_EXPR
: /* More cases than we can handle. */
9631 case REFERENCE_EXPR
:
9632 case PREDECREMENT_EXPR
:
9633 case PREINCREMENT_EXPR
:
9634 case POSTDECREMENT_EXPR
:
9635 case POSTINCREMENT_EXPR
:
9638 *decl
= error_mark_node
;
9644 /* Do divide operation appropriate to type of operands. */
9646 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9648 ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
9649 tree dest_tree
, ffebld dest
, bool *dest_used
)
9651 if ((left
== error_mark_node
)
9652 || (right
== error_mark_node
))
9653 return error_mark_node
;
9655 switch (TREE_CODE (tree_type
))
9658 return ffecom_2 (TRUNC_DIV_EXPR
, tree_type
,
9666 if (TREE_TYPE (tree_type
)
9667 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9668 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9670 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9672 left
= ffecom_1 (ADDR_EXPR
,
9673 build_pointer_type (TREE_TYPE (left
)),
9675 left
= build_tree_list (NULL_TREE
, left
);
9676 right
= ffecom_1 (ADDR_EXPR
,
9677 build_pointer_type (TREE_TYPE (right
)),
9679 right
= build_tree_list (NULL_TREE
, right
);
9680 TREE_CHAIN (left
) = right
;
9682 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9683 ffecom_gfrt_kindtype (ix
),
9684 ffe_is_f2c_library (),
9687 dest_tree
, dest
, dest_used
,
9696 if (TREE_TYPE (TYPE_FIELDS (tree_type
))
9697 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9698 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9700 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9702 left
= ffecom_1 (ADDR_EXPR
,
9703 build_pointer_type (TREE_TYPE (left
)),
9705 left
= build_tree_list (NULL_TREE
, left
);
9706 right
= ffecom_1 (ADDR_EXPR
,
9707 build_pointer_type (TREE_TYPE (right
)),
9709 right
= build_tree_list (NULL_TREE
, right
);
9710 TREE_CHAIN (left
) = right
;
9712 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9713 ffecom_gfrt_kindtype (ix
),
9714 ffe_is_f2c_library (),
9717 dest_tree
, dest
, dest_used
,
9723 return ffecom_2 (RDIV_EXPR
, tree_type
,
9730 /* ffecom_type_localvar_ -- Build type info for non-dummy variable
9733 ffesymbol s; // the variable's symbol
9734 ffeinfoBasictype bt; // it's basictype
9735 ffeinfoKindtype kt; // it's kindtype
9737 type = ffecom_type_localvar_(s,bt,kt);
9739 Handles static arrays, CHARACTER type, etc. */
9741 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9743 ffecom_type_localvar_ (ffesymbol s
, ffeinfoBasictype bt
,
9752 type
= ffecom_tree_type
[bt
][kt
];
9753 if (bt
== FFEINFO_basictypeCHARACTER
)
9755 hight
= build_int_2 (ffesymbol_size (s
), 0);
9756 TREE_TYPE (hight
) = ffecom_f2c_ftnlen_type_node
;
9761 build_range_type (ffecom_f2c_ftnlen_type_node
,
9762 ffecom_f2c_ftnlen_one_node
,
9764 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9767 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
9769 if (type
== error_mark_node
)
9772 dim
= ffebld_head (dl
);
9773 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
9775 if (ffebld_left (dim
) == NULL
)
9776 lowt
= integer_one_node
;
9778 lowt
= ffecom_expr (ffebld_left (dim
));
9780 if (TREE_CODE (lowt
) != INTEGER_CST
)
9781 lowt
= variable_size (lowt
);
9783 assert (ffebld_right (dim
) != NULL
);
9784 hight
= ffecom_expr (ffebld_right (dim
));
9786 if (TREE_CODE (hight
) != INTEGER_CST
)
9787 hight
= variable_size (hight
);
9789 type
= build_array_type (type
,
9790 build_range_type (ffecom_integer_type_node
,
9792 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9799 /* Build Namelist type. */
9801 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9803 ffecom_type_namelist_ ()
9805 static tree type
= NULL_TREE
;
9807 if (type
== NULL_TREE
)
9809 static tree namefield
, varsfield
, nvarsfield
;
9812 vardesctype
= ffecom_type_vardesc_ ();
9814 push_obstacks_nochange ();
9815 end_temporary_allocation ();
9817 type
= make_node (RECORD_TYPE
);
9819 vardesctype
= build_pointer_type (build_pointer_type (vardesctype
));
9821 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9823 varsfield
= ffecom_decl_field (type
, namefield
, "vars", vardesctype
);
9824 nvarsfield
= ffecom_decl_field (type
, varsfield
, "nvars",
9827 TYPE_FIELDS (type
) = namefield
;
9830 resume_temporary_allocation ();
9839 /* Make a copy of a type, assuming caller has switched to the permanent
9840 obstacks and that the type is for an aggregate (array) initializer. */
9842 #if FFECOM_targetCURRENT == FFECOM_targetGCC && 0 /* Not used now. */
9844 ffecom_type_permanent_copy_ (tree t
)
9849 assert (TREE_TYPE (t
) != NULL_TREE
);
9851 domain
= TYPE_DOMAIN (t
);
9853 assert (TREE_CODE (t
) == ARRAY_TYPE
);
9854 assert (TREE_PERMANENT (TREE_TYPE (t
)));
9855 assert (TREE_PERMANENT (TREE_TYPE (domain
)));
9856 assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain
)));
9858 max
= TYPE_MAX_VALUE (domain
);
9859 if (!TREE_PERMANENT (max
))
9861 assert (TREE_CODE (max
) == INTEGER_CST
);
9863 max
= build_int_2 (TREE_INT_CST_LOW (max
), TREE_INT_CST_HIGH (max
));
9864 TREE_TYPE (max
) = TREE_TYPE (TYPE_MIN_VALUE (domain
));
9867 return build_array_type (TREE_TYPE (t
),
9868 build_range_type (TREE_TYPE (domain
),
9869 TYPE_MIN_VALUE (domain
),
9874 /* Build Vardesc type. */
9876 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9878 ffecom_type_vardesc_ ()
9880 static tree type
= NULL_TREE
;
9881 static tree namefield
, addrfield
, dimsfield
, typefield
;
9883 if (type
== NULL_TREE
)
9885 push_obstacks_nochange ();
9886 end_temporary_allocation ();
9888 type
= make_node (RECORD_TYPE
);
9890 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9892 addrfield
= ffecom_decl_field (type
, namefield
, "addr",
9894 dimsfield
= ffecom_decl_field (type
, addrfield
, "dims",
9895 ffecom_f2c_ftnlen_type_node
);
9896 typefield
= ffecom_decl_field (type
, dimsfield
, "type",
9899 TYPE_FIELDS (type
) = namefield
;
9902 resume_temporary_allocation ();
9911 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9913 ffecom_vardesc_ (ffebld expr
)
9917 assert (ffebld_op (expr
) == FFEBLD_opSYMTER
);
9918 s
= ffebld_symter (expr
);
9920 if (ffesymbol_hook (s
).vardesc_tree
== NULL_TREE
)
9923 tree vardesctype
= ffecom_type_vardesc_ ();
9932 static int mynumber
= 0;
9934 yes
= suspend_momentary ();
9936 var
= build_decl (VAR_DECL
,
9937 ffecom_get_invented_identifier ("__g77_vardesc_%d",
9940 TREE_STATIC (var
) = 1;
9941 DECL_INITIAL (var
) = error_mark_node
;
9943 var
= start_decl (var
, FALSE
);
9945 /* Process inits. */
9947 nameinit
= ffecom_build_f2c_string_ ((i
= strlen (ffesymbol_text (s
)))
9949 ffesymbol_text (s
));
9950 TREE_TYPE (nameinit
)
9951 = build_type_variant
9954 build_range_type (integer_type_node
,
9956 build_int_2 (i
, 0))),
9958 TREE_CONSTANT (nameinit
) = 1;
9959 TREE_STATIC (nameinit
) = 1;
9960 nameinit
= ffecom_1 (ADDR_EXPR
,
9961 build_pointer_type (TREE_TYPE (nameinit
)),
9964 addrinit
= ffecom_arg_ptr_to_expr (expr
, &typeinit
);
9966 dimsinit
= ffecom_vardesc_dims_ (s
);
9968 if (typeinit
== NULL_TREE
)
9970 ffeinfoBasictype bt
= ffesymbol_basictype (s
);
9971 ffeinfoKindtype kt
= ffesymbol_kindtype (s
);
9972 int tc
= ffecom_f2c_typecode (bt
, kt
);
9975 typeinit
= build_int_2 (tc
, (tc
< 0) ? -1 : 0);
9978 typeinit
= ffecom_1 (NEGATE_EXPR
, TREE_TYPE (typeinit
), typeinit
);
9980 varinits
= build_tree_list ((field
= TYPE_FIELDS (vardesctype
)),
9982 TREE_CHAIN (varinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
9984 TREE_CHAIN (TREE_CHAIN (varinits
))
9985 = build_tree_list ((field
= TREE_CHAIN (field
)), dimsinit
);
9986 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits
)))
9987 = build_tree_list ((field
= TREE_CHAIN (field
)), typeinit
);
9989 varinits
= build (CONSTRUCTOR
, vardesctype
, NULL_TREE
, varinits
);
9990 TREE_CONSTANT (varinits
) = 1;
9991 TREE_STATIC (varinits
) = 1;
9993 finish_decl (var
, varinits
, FALSE
);
9995 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (vardesctype
), var
);
9997 resume_momentary (yes
);
9999 ffesymbol_hook (s
).vardesc_tree
= var
;
10002 return ffesymbol_hook (s
).vardesc_tree
;
10006 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10008 ffecom_vardesc_array_ (ffesymbol s
)
10012 tree item
= NULL_TREE
;
10016 static int mynumber
= 0;
10018 for (i
= 0, list
= NULL_TREE
, b
= ffesymbol_namelist (s
);
10020 b
= ffebld_trail (b
), ++i
)
10024 t
= ffecom_vardesc_ (ffebld_head (b
));
10026 if (list
== NULL_TREE
)
10027 list
= item
= build_tree_list (NULL_TREE
, t
);
10030 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
10031 item
= TREE_CHAIN (item
);
10035 yes
= suspend_momentary ();
10037 item
= build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
10038 build_range_type (integer_type_node
,
10040 build_int_2 (i
, 0)));
10041 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
10042 TREE_CONSTANT (list
) = 1;
10043 TREE_STATIC (list
) = 1;
10045 var
= ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL
,
10047 var
= build_decl (VAR_DECL
, var
, item
);
10048 TREE_STATIC (var
) = 1;
10049 DECL_INITIAL (var
) = error_mark_node
;
10050 var
= start_decl (var
, FALSE
);
10051 finish_decl (var
, list
, FALSE
);
10053 resume_momentary (yes
);
10059 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10061 ffecom_vardesc_dims_ (ffesymbol s
)
10063 if (ffesymbol_dims (s
) == NULL
)
10064 return convert (ffecom_f2c_ptr_to_ftnlen_type_node
,
10065 integer_zero_node
);
10072 tree item
= NULL_TREE
;
10077 tree baseoff
= NULL_TREE
;
10078 static int mynumber
= 0;
10080 numdim
= build_int_2 ((int) ffesymbol_rank (s
), 0);
10081 TREE_TYPE (numdim
) = ffecom_f2c_ftnlen_type_node
;
10083 numelem
= ffecom_expr (ffesymbol_arraysize (s
));
10084 TREE_TYPE (numelem
) = ffecom_f2c_ftnlen_type_node
;
10087 backlist
= NULL_TREE
;
10088 for (b
= ffesymbol_dims (s
), e
= ffesymbol_extents (s
);
10090 b
= ffebld_trail (b
), e
= ffebld_trail (e
))
10096 if (ffebld_trail (b
) == NULL
)
10100 t
= convert (ffecom_f2c_ftnlen_type_node
,
10101 ffecom_expr (ffebld_head (e
)));
10103 if (list
== NULL_TREE
)
10104 list
= item
= build_tree_list (NULL_TREE
, t
);
10107 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
10108 item
= TREE_CHAIN (item
);
10112 if (ffebld_left (ffebld_head (b
)) == NULL
)
10113 low
= ffecom_integer_one_node
;
10115 low
= ffecom_expr (ffebld_left (ffebld_head (b
)));
10116 low
= convert (ffecom_f2c_ftnlen_type_node
, low
);
10118 back
= build_tree_list (low
, t
);
10119 TREE_CHAIN (back
) = backlist
;
10123 for (item
= backlist
; item
!= NULL_TREE
; item
= TREE_CHAIN (item
))
10125 if (TREE_VALUE (item
) == NULL_TREE
)
10126 baseoff
= TREE_PURPOSE (item
);
10128 baseoff
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
10129 TREE_PURPOSE (item
),
10130 ffecom_2 (MULT_EXPR
,
10131 ffecom_f2c_ftnlen_type_node
,
10136 /* backlist now dead, along with all TREE_PURPOSEs on it. */
10138 baseoff
= build_tree_list (NULL_TREE
, baseoff
);
10139 TREE_CHAIN (baseoff
) = list
;
10141 numelem
= build_tree_list (NULL_TREE
, numelem
);
10142 TREE_CHAIN (numelem
) = baseoff
;
10144 numdim
= build_tree_list (NULL_TREE
, numdim
);
10145 TREE_CHAIN (numdim
) = numelem
;
10147 yes
= suspend_momentary ();
10149 item
= build_array_type (ffecom_f2c_ftnlen_type_node
,
10150 build_range_type (integer_type_node
,
10153 ((int) ffesymbol_rank (s
)
10155 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, numdim
);
10156 TREE_CONSTANT (list
) = 1;
10157 TREE_STATIC (list
) = 1;
10159 var
= ffecom_get_invented_identifier ("__g77_dims_%d", NULL
,
10161 var
= build_decl (VAR_DECL
, var
, item
);
10162 TREE_STATIC (var
) = 1;
10163 DECL_INITIAL (var
) = error_mark_node
;
10164 var
= start_decl (var
, FALSE
);
10165 finish_decl (var
, list
, FALSE
);
10167 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (item
), var
);
10169 resume_momentary (yes
);
10176 /* Essentially does a "fold (build1 (code, type, node))" while checking
10177 for certain housekeeping things.
10179 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
10180 ffecom_1_fn instead. */
10182 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10184 ffecom_1 (enum tree_code code
, tree type
, tree node
)
10188 if ((node
== error_mark_node
)
10189 || (type
== error_mark_node
))
10190 return error_mark_node
;
10192 if (code
== ADDR_EXPR
)
10194 if (!mark_addressable (node
))
10195 assert ("can't mark_addressable this node!" == NULL
);
10198 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
10202 case REALPART_EXPR
:
10203 item
= build (COMPONENT_REF
, type
, node
, TYPE_FIELDS (TREE_TYPE (node
)));
10206 case IMAGPART_EXPR
:
10207 item
= build (COMPONENT_REF
, type
, node
, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node
))));
10212 if (TREE_CODE (type
) != RECORD_TYPE
)
10214 item
= build1 (code
, type
, node
);
10217 node
= ffecom_stabilize_aggregate_ (node
);
10218 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10220 ffecom_2 (COMPLEX_EXPR
, type
,
10221 ffecom_1 (NEGATE_EXPR
, realtype
,
10222 ffecom_1 (REALPART_EXPR
, realtype
,
10224 ffecom_1 (NEGATE_EXPR
, realtype
,
10225 ffecom_1 (IMAGPART_EXPR
, realtype
,
10230 item
= build1 (code
, type
, node
);
10234 if (TREE_SIDE_EFFECTS (node
))
10235 TREE_SIDE_EFFECTS (item
) = 1;
10236 if ((code
== ADDR_EXPR
) && staticp (node
))
10237 TREE_CONSTANT (item
) = 1;
10238 return fold (item
);
10242 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
10243 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
10244 does not set TREE_ADDRESSABLE (because calling an inline
10245 function does not mean the function needs to be separately
10248 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10250 ffecom_1_fn (tree node
)
10255 if (node
== error_mark_node
)
10256 return error_mark_node
;
10258 type
= build_type_variant (TREE_TYPE (node
),
10259 TREE_READONLY (node
),
10260 TREE_THIS_VOLATILE (node
));
10261 item
= build1 (ADDR_EXPR
,
10262 build_pointer_type (type
), node
);
10263 if (TREE_SIDE_EFFECTS (node
))
10264 TREE_SIDE_EFFECTS (item
) = 1;
10265 if (staticp (node
))
10266 TREE_CONSTANT (item
) = 1;
10267 return fold (item
);
10271 /* Essentially does a "fold (build (code, type, node1, node2))" while
10272 checking for certain housekeeping things. */
10274 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10276 ffecom_2 (enum tree_code code
, tree type
, tree node1
,
10281 if ((node1
== error_mark_node
)
10282 || (node2
== error_mark_node
)
10283 || (type
== error_mark_node
))
10284 return error_mark_node
;
10286 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
10288 tree a
, b
, c
, d
, realtype
;
10291 assert ("no CONJ_EXPR support yet" == NULL
);
10292 return error_mark_node
;
10295 item
= build_tree_list (TYPE_FIELDS (type
), node1
);
10296 TREE_CHAIN (item
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), node2
);
10297 item
= build (CONSTRUCTOR
, type
, NULL_TREE
, item
);
10301 if (TREE_CODE (type
) != RECORD_TYPE
)
10303 item
= build (code
, type
, node1
, node2
);
10306 node1
= ffecom_stabilize_aggregate_ (node1
);
10307 node2
= ffecom_stabilize_aggregate_ (node2
);
10308 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10310 ffecom_2 (COMPLEX_EXPR
, type
,
10311 ffecom_2 (PLUS_EXPR
, realtype
,
10312 ffecom_1 (REALPART_EXPR
, realtype
,
10314 ffecom_1 (REALPART_EXPR
, realtype
,
10316 ffecom_2 (PLUS_EXPR
, realtype
,
10317 ffecom_1 (IMAGPART_EXPR
, realtype
,
10319 ffecom_1 (IMAGPART_EXPR
, realtype
,
10324 if (TREE_CODE (type
) != RECORD_TYPE
)
10326 item
= build (code
, type
, node1
, node2
);
10329 node1
= ffecom_stabilize_aggregate_ (node1
);
10330 node2
= ffecom_stabilize_aggregate_ (node2
);
10331 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10333 ffecom_2 (COMPLEX_EXPR
, type
,
10334 ffecom_2 (MINUS_EXPR
, realtype
,
10335 ffecom_1 (REALPART_EXPR
, realtype
,
10337 ffecom_1 (REALPART_EXPR
, realtype
,
10339 ffecom_2 (MINUS_EXPR
, realtype
,
10340 ffecom_1 (IMAGPART_EXPR
, realtype
,
10342 ffecom_1 (IMAGPART_EXPR
, realtype
,
10347 if (TREE_CODE (type
) != RECORD_TYPE
)
10349 item
= build (code
, type
, node1
, node2
);
10352 node1
= ffecom_stabilize_aggregate_ (node1
);
10353 node2
= ffecom_stabilize_aggregate_ (node2
);
10354 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10355 a
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
10357 b
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
10359 c
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
10361 d
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
10364 ffecom_2 (COMPLEX_EXPR
, type
,
10365 ffecom_2 (MINUS_EXPR
, realtype
,
10366 ffecom_2 (MULT_EXPR
, realtype
,
10369 ffecom_2 (MULT_EXPR
, realtype
,
10372 ffecom_2 (PLUS_EXPR
, realtype
,
10373 ffecom_2 (MULT_EXPR
, realtype
,
10376 ffecom_2 (MULT_EXPR
, realtype
,
10382 if ((TREE_CODE (node1
) != RECORD_TYPE
)
10383 && (TREE_CODE (node2
) != RECORD_TYPE
))
10385 item
= build (code
, type
, node1
, node2
);
10388 assert (TREE_CODE (node1
) == RECORD_TYPE
);
10389 assert (TREE_CODE (node2
) == RECORD_TYPE
);
10390 node1
= ffecom_stabilize_aggregate_ (node1
);
10391 node2
= ffecom_stabilize_aggregate_ (node2
);
10392 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10394 ffecom_2 (TRUTH_ANDIF_EXPR
, type
,
10395 ffecom_2 (code
, type
,
10396 ffecom_1 (REALPART_EXPR
, realtype
,
10398 ffecom_1 (REALPART_EXPR
, realtype
,
10400 ffecom_2 (code
, type
,
10401 ffecom_1 (IMAGPART_EXPR
, realtype
,
10403 ffecom_1 (IMAGPART_EXPR
, realtype
,
10408 if ((TREE_CODE (node1
) != RECORD_TYPE
)
10409 && (TREE_CODE (node2
) != RECORD_TYPE
))
10411 item
= build (code
, type
, node1
, node2
);
10414 assert (TREE_CODE (node1
) == RECORD_TYPE
);
10415 assert (TREE_CODE (node2
) == RECORD_TYPE
);
10416 node1
= ffecom_stabilize_aggregate_ (node1
);
10417 node2
= ffecom_stabilize_aggregate_ (node2
);
10418 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10420 ffecom_2 (TRUTH_ORIF_EXPR
, type
,
10421 ffecom_2 (code
, type
,
10422 ffecom_1 (REALPART_EXPR
, realtype
,
10424 ffecom_1 (REALPART_EXPR
, realtype
,
10426 ffecom_2 (code
, type
,
10427 ffecom_1 (IMAGPART_EXPR
, realtype
,
10429 ffecom_1 (IMAGPART_EXPR
, realtype
,
10434 item
= build (code
, type
, node1
, node2
);
10438 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
))
10439 TREE_SIDE_EFFECTS (item
) = 1;
10440 return fold (item
);
10444 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
10446 ffesymbol s; // the ENTRY point itself
10447 if (ffecom_2pass_advise_entrypoint(s))
10448 // the ENTRY point has been accepted
10450 Does whatever compiler needs to do when it learns about the entrypoint,
10451 like determine the return type of the master function, count the
10452 number of entrypoints, etc. Returns FALSE if the return type is
10453 not compatible with the return type(s) of other entrypoint(s).
10455 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
10456 later (after _finish_progunit) be called with the same entrypoint(s)
10457 as passed to this fn for which TRUE was returned.
10460 Return FALSE if the return type conflicts with previous entrypoints. */
10462 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10464 ffecom_2pass_advise_entrypoint (ffesymbol entry
)
10466 ffebld list
; /* opITEM. */
10467 ffebld mlist
; /* opITEM. */
10468 ffebld plist
; /* opITEM. */
10469 ffebld arg
; /* ffebld_head(opITEM). */
10470 ffebld item
; /* opITEM. */
10471 ffesymbol s
; /* ffebld_symter(arg). */
10472 ffeinfoBasictype bt
= ffesymbol_basictype (entry
);
10473 ffeinfoKindtype kt
= ffesymbol_kindtype (entry
);
10474 ffetargetCharacterSize size
= ffesymbol_size (entry
);
10477 if (ffecom_num_entrypoints_
== 0)
10478 { /* First entrypoint, make list of main
10479 arglist's dummies. */
10480 assert (ffecom_primary_entry_
!= NULL
);
10482 ffecom_master_bt_
= ffesymbol_basictype (ffecom_primary_entry_
);
10483 ffecom_master_kt_
= ffesymbol_kindtype (ffecom_primary_entry_
);
10484 ffecom_master_size_
= ffesymbol_size (ffecom_primary_entry_
);
10486 for (plist
= NULL
, list
= ffesymbol_dummyargs (ffecom_primary_entry_
);
10488 list
= ffebld_trail (list
))
10490 arg
= ffebld_head (list
);
10491 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
10492 continue; /* Alternate return or some such thing. */
10493 item
= ffebld_new_item (arg
, NULL
);
10495 ffecom_master_arglist_
= item
;
10497 ffebld_set_trail (plist
, item
);
10502 /* If necessary, scan entry arglist for alternate returns. Do this scan
10503 apparently redundantly (it's done below to UNIONize the arglists) so
10504 that we don't complain about RETURN 1 if an offending ENTRY is the only
10505 one with an alternate return. */
10507 if (!ffecom_is_altreturning_
)
10509 for (list
= ffesymbol_dummyargs (entry
);
10511 list
= ffebld_trail (list
))
10513 arg
= ffebld_head (list
);
10514 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
10516 ffecom_is_altreturning_
= TRUE
;
10522 /* Now check type compatibility. */
10524 switch (ffecom_master_bt_
)
10526 case FFEINFO_basictypeNONE
:
10527 ok
= (bt
!= FFEINFO_basictypeCHARACTER
);
10530 case FFEINFO_basictypeCHARACTER
:
10532 = (bt
== FFEINFO_basictypeCHARACTER
)
10533 && (kt
== ffecom_master_kt_
)
10534 && (size
== ffecom_master_size_
);
10537 case FFEINFO_basictypeANY
:
10538 return FALSE
; /* Just don't bother. */
10541 if (bt
== FFEINFO_basictypeCHARACTER
)
10547 if ((bt
!= ffecom_master_bt_
) || (kt
!= ffecom_master_kt_
))
10549 ffecom_master_bt_
= FFEINFO_basictypeNONE
;
10550 ffecom_master_kt_
= FFEINFO_kindtypeNONE
;
10557 ffebad_start (FFEBAD_ENTRY_CONFLICTS
);
10558 ffest_ffebad_here_current_stmt (0);
10560 return FALSE
; /* Can't handle entrypoint. */
10563 /* Entrypoint type compatible with previous types. */
10565 ++ffecom_num_entrypoints_
;
10567 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10569 for (list
= ffesymbol_dummyargs (entry
);
10571 list
= ffebld_trail (list
))
10573 arg
= ffebld_head (list
);
10574 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
10575 continue; /* Alternate return or some such thing. */
10576 s
= ffebld_symter (arg
);
10577 for (plist
= NULL
, mlist
= ffecom_master_arglist_
;
10579 plist
= mlist
, mlist
= ffebld_trail (mlist
))
10580 { /* plist points to previous item for easy
10581 appending of arg. */
10582 if (ffebld_symter (ffebld_head (mlist
)) == s
)
10583 break; /* Already have this arg in the master list. */
10586 continue; /* Already have this arg in the master list. */
10588 /* Append this arg to the master list. */
10590 item
= ffebld_new_item (arg
, NULL
);
10592 ffecom_master_arglist_
= item
;
10594 ffebld_set_trail (plist
, item
);
10601 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10603 ffesymbol s; // the ENTRY point itself
10604 ffecom_2pass_do_entrypoint(s);
10606 Does whatever compiler needs to do to make the entrypoint actually
10607 happen. Must be called for each entrypoint after
10608 ffecom_finish_progunit is called. */
10610 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10612 ffecom_2pass_do_entrypoint (ffesymbol entry
)
10614 static int mfn_num
= 0;
10615 static int ent_num
;
10617 if (mfn_num
!= ffecom_num_fns_
)
10618 { /* First entrypoint for this program unit. */
10620 mfn_num
= ffecom_num_fns_
;
10621 ffecom_do_entry_ (ffecom_primary_entry_
, 0);
10626 --ffecom_num_entrypoints_
;
10628 ffecom_do_entry_ (entry
, ent_num
);
10633 /* Essentially does a "fold (build (code, type, node1, node2))" while
10634 checking for certain housekeeping things. Always sets
10635 TREE_SIDE_EFFECTS. */
10637 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10639 ffecom_2s (enum tree_code code
, tree type
, tree node1
,
10644 if ((node1
== error_mark_node
)
10645 || (node2
== error_mark_node
)
10646 || (type
== error_mark_node
))
10647 return error_mark_node
;
10649 item
= build (code
, type
, node1
, node2
);
10650 TREE_SIDE_EFFECTS (item
) = 1;
10651 return fold (item
);
10655 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10656 checking for certain housekeeping things. */
10658 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10660 ffecom_3 (enum tree_code code
, tree type
, tree node1
,
10661 tree node2
, tree node3
)
10665 if ((node1
== error_mark_node
)
10666 || (node2
== error_mark_node
)
10667 || (node3
== error_mark_node
)
10668 || (type
== error_mark_node
))
10669 return error_mark_node
;
10671 item
= build (code
, type
, node1
, node2
, node3
);
10672 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
)
10673 || (node3
!= NULL_TREE
&& TREE_SIDE_EFFECTS (node3
)))
10674 TREE_SIDE_EFFECTS (item
) = 1;
10675 return fold (item
);
10679 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10680 checking for certain housekeeping things. Always sets
10681 TREE_SIDE_EFFECTS. */
10683 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10685 ffecom_3s (enum tree_code code
, tree type
, tree node1
,
10686 tree node2
, tree node3
)
10690 if ((node1
== error_mark_node
)
10691 || (node2
== error_mark_node
)
10692 || (node3
== error_mark_node
)
10693 || (type
== error_mark_node
))
10694 return error_mark_node
;
10696 item
= build (code
, type
, node1
, node2
, node3
);
10697 TREE_SIDE_EFFECTS (item
) = 1;
10698 return fold (item
);
10702 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10704 See use by ffecom_list_expr.
10706 If expression is NULL, returns an integer zero tree. If it is not
10707 a CHARACTER expression, returns whatever ffecom_expr
10708 returns and sets the length return value to NULL_TREE. Otherwise
10709 generates code to evaluate the character expression, returns the proper
10710 pointer to the result, but does NOT set the length return value to a tree
10711 that specifies the length of the result. (In other words, the length
10712 variable is always set to NULL_TREE, because a length is never passed.)
10715 Don't set returned length, since nobody needs it (yet; someday if
10716 we allow CHARACTER*(*) dummies to statement functions, we'll need
10719 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10721 ffecom_arg_expr (ffebld expr
, tree
*length
)
10725 *length
= NULL_TREE
;
10728 return integer_zero_node
;
10730 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10731 return ffecom_expr (expr
);
10733 return ffecom_arg_ptr_to_expr (expr
, &ign
);
10737 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10739 See use by ffecom_list_ptr_to_expr.
10741 If expression is NULL, returns an integer zero tree. If it is not
10742 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10743 returns and sets the length return value to NULL_TREE. Otherwise
10744 generates code to evaluate the character expression, returns the proper
10745 pointer to the result, AND sets the length return value to a tree that
10746 specifies the length of the result. */
10748 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10750 ffecom_arg_ptr_to_expr (ffebld expr
, tree
*length
)
10754 ffecomConcatList_ catlist
;
10756 *length
= NULL_TREE
;
10759 return integer_zero_node
;
10761 switch (ffebld_op (expr
))
10763 case FFEBLD_opPERCENT_VAL
:
10764 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10765 return ffecom_expr (ffebld_left (expr
));
10770 temp_exp
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &temp_length
);
10771 return ffecom_1 (INDIRECT_REF
, TREE_TYPE (TREE_TYPE (temp_exp
)),
10775 case FFEBLD_opPERCENT_REF
:
10776 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10777 return ffecom_ptr_to_expr (ffebld_left (expr
));
10778 ign_length
= NULL_TREE
;
10779 length
= &ign_length
;
10780 expr
= ffebld_left (expr
);
10783 case FFEBLD_opPERCENT_DESCR
:
10784 switch (ffeinfo_basictype (ffebld_info (expr
)))
10786 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10787 case FFEINFO_basictypeHOLLERITH
:
10789 case FFEINFO_basictypeCHARACTER
:
10790 break; /* Passed by descriptor anyway. */
10793 item
= ffecom_ptr_to_expr (expr
);
10794 if (item
!= error_mark_node
)
10795 *length
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (item
)));
10804 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10805 if (ffeinfo_basictype (ffebld_info (expr
)) == FFEINFO_basictypeHOLLERITH
)
10806 { /* Pass Hollerith by descriptor. */
10807 ffetargetHollerith h
;
10809 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
10810 h
= ffebld_cu_val_hollerith (ffebld_constant_union
10811 (ffebld_conter (expr
)));
10813 = build_int_2 (h
.length
, 0);
10814 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10818 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10819 return ffecom_ptr_to_expr (expr
);
10821 assert (ffeinfo_kindtype (ffebld_info (expr
))
10822 == FFEINFO_kindtypeCHARACTER1
);
10824 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
10825 switch (ffecom_concat_list_count_ (catlist
))
10827 case 0: /* Shouldn't happen, but in case it does... */
10828 *length
= ffecom_f2c_ftnlen_zero_node
;
10829 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10830 ffecom_concat_list_kill_ (catlist
);
10831 return null_pointer_node
;
10833 case 1: /* The (fairly) easy case. */
10834 ffecom_char_args_ (&item
, length
,
10835 ffecom_concat_list_expr_ (catlist
, 0));
10836 ffecom_concat_list_kill_ (catlist
);
10837 assert (item
!= NULL_TREE
);
10840 default: /* Must actually concatenate things. */
10845 int count
= ffecom_concat_list_count_ (catlist
);
10856 ffetargetCharacterSize sz
;
10860 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
10861 FFETARGET_charactersizeNONE
, count
, TRUE
);
10864 = ffecom_push_tempvar (ffecom_f2c_address_type_node
,
10865 FFETARGET_charactersizeNONE
, count
, TRUE
);
10867 known_length
= ffecom_f2c_ftnlen_zero_node
;
10869 for (i
= 0; i
< count
; ++i
)
10871 ffecom_char_args_ (&citem
, &clength
,
10872 ffecom_concat_list_expr_ (catlist
, i
));
10873 if ((citem
== error_mark_node
)
10874 || (clength
== error_mark_node
))
10876 ffecom_concat_list_kill_ (catlist
);
10877 *length
= error_mark_node
;
10878 return error_mark_node
;
10882 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
10883 ffecom_modify (void_type_node
,
10884 ffecom_2 (ARRAY_REF
,
10885 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
10887 build_int_2 (i
, 0)),
10890 clength
= ffecom_save_tree (clength
);
10892 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
10896 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
10897 ffecom_modify (void_type_node
,
10898 ffecom_2 (ARRAY_REF
,
10899 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
10901 build_int_2 (i
, 0)),
10906 sz
= ffecom_concat_list_maxlen_ (catlist
);
10907 assert (sz
!= FFETARGET_charactersizeNONE
);
10909 temporary
= ffecom_push_tempvar (char_type_node
,
10911 temporary
= ffecom_1 (ADDR_EXPR
,
10912 build_pointer_type (TREE_TYPE (temporary
)),
10915 item
= build_tree_list (NULL_TREE
, temporary
);
10917 = build_tree_list (NULL_TREE
,
10918 ffecom_1 (ADDR_EXPR
,
10919 build_pointer_type (TREE_TYPE (items
)),
10921 TREE_CHAIN (TREE_CHAIN (item
))
10922 = build_tree_list (NULL_TREE
,
10923 ffecom_1 (ADDR_EXPR
,
10924 build_pointer_type (TREE_TYPE (lengths
)),
10926 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
10929 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
10930 convert (ffecom_f2c_ftnlen_type_node
,
10931 build_int_2 (count
, 0))));
10932 num
= build_int_2 (sz
, 0);
10933 TREE_TYPE (num
) = ffecom_f2c_ftnlen_type_node
;
10934 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
))))
10935 = build_tree_list (NULL_TREE
, num
);
10937 item
= ffecom_call_gfrt (FFECOM_gfrtCAT
, item
);
10938 TREE_SIDE_EFFECTS (item
) = 1;
10939 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (temporary
),
10943 *length
= known_length
;
10946 ffecom_concat_list_kill_ (catlist
);
10947 assert (item
!= NULL_TREE
);
10952 /* ffecom_call_gfrt -- Generate call to run-time function
10955 expr = ffecom_call_gfrt(FFECOM_gfrtSTOPNIL,NULL_TREE);
10957 The first arg is the GNU Fortran Run-Time function index, the second
10958 arg is the list of arguments to pass to it. Returned is the expression
10959 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10960 result (which may be void). */
10962 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10964 ffecom_call_gfrt (ffecomGfrt ix
, tree args
)
10966 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
10967 ffecom_gfrt_kindtype (ix
),
10968 ffe_is_f2c_library () && ffecom_gfrt_complex_
[ix
],
10969 NULL_TREE
, args
, NULL_TREE
, NULL
,
10970 NULL
, NULL_TREE
, TRUE
);
10974 /* ffecom_constantunion -- Transform constant-union to tree
10976 ffebldConstantUnion cu; // the constant to transform
10977 ffeinfoBasictype bt; // its basic type
10978 ffeinfoKindtype kt; // its kind type
10979 tree tree_type; // ffecom_tree_type[bt][kt]
10980 ffecom_constantunion(&cu,bt,kt,tree_type); */
10982 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10984 ffecom_constantunion (ffebldConstantUnion
*cu
, ffeinfoBasictype bt
,
10985 ffeinfoKindtype kt
, tree tree_type
)
10991 case FFEINFO_basictypeINTEGER
:
10997 #if FFETARGET_okINTEGER1
10998 case FFEINFO_kindtypeINTEGER1
:
10999 val
= ffebld_cu_val_integer1 (*cu
);
11003 #if FFETARGET_okINTEGER2
11004 case FFEINFO_kindtypeINTEGER2
:
11005 val
= ffebld_cu_val_integer2 (*cu
);
11009 #if FFETARGET_okINTEGER3
11010 case FFEINFO_kindtypeINTEGER3
:
11011 val
= ffebld_cu_val_integer3 (*cu
);
11015 #if FFETARGET_okINTEGER4
11016 case FFEINFO_kindtypeINTEGER4
:
11017 val
= ffebld_cu_val_integer4 (*cu
);
11022 assert ("bad INTEGER constant kind type" == NULL
);
11023 /* Fall through. */
11024 case FFEINFO_kindtypeANY
:
11025 return error_mark_node
;
11027 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
11028 TREE_TYPE (item
) = tree_type
;
11032 case FFEINFO_basictypeLOGICAL
:
11038 #if FFETARGET_okLOGICAL1
11039 case FFEINFO_kindtypeLOGICAL1
:
11040 val
= ffebld_cu_val_logical1 (*cu
);
11044 #if FFETARGET_okLOGICAL2
11045 case FFEINFO_kindtypeLOGICAL2
:
11046 val
= ffebld_cu_val_logical2 (*cu
);
11050 #if FFETARGET_okLOGICAL3
11051 case FFEINFO_kindtypeLOGICAL3
:
11052 val
= ffebld_cu_val_logical3 (*cu
);
11056 #if FFETARGET_okLOGICAL4
11057 case FFEINFO_kindtypeLOGICAL4
:
11058 val
= ffebld_cu_val_logical4 (*cu
);
11063 assert ("bad LOGICAL constant kind type" == NULL
);
11064 /* Fall through. */
11065 case FFEINFO_kindtypeANY
:
11066 return error_mark_node
;
11068 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
11069 TREE_TYPE (item
) = tree_type
;
11073 case FFEINFO_basictypeREAL
:
11075 REAL_VALUE_TYPE val
;
11079 #if FFETARGET_okREAL1
11080 case FFEINFO_kindtypeREAL1
:
11081 val
= ffetarget_value_real1 (ffebld_cu_val_real1 (*cu
));
11085 #if FFETARGET_okREAL2
11086 case FFEINFO_kindtypeREAL2
:
11087 val
= ffetarget_value_real2 (ffebld_cu_val_real2 (*cu
));
11091 #if FFETARGET_okREAL3
11092 case FFEINFO_kindtypeREAL3
:
11093 val
= ffetarget_value_real3 (ffebld_cu_val_real3 (*cu
));
11097 #if FFETARGET_okREAL4
11098 case FFEINFO_kindtypeREAL4
:
11099 val
= ffetarget_value_real4 (ffebld_cu_val_real4 (*cu
));
11104 assert ("bad REAL constant kind type" == NULL
);
11105 /* Fall through. */
11106 case FFEINFO_kindtypeANY
:
11107 return error_mark_node
;
11109 item
= build_real (tree_type
, val
);
11113 case FFEINFO_basictypeCOMPLEX
:
11115 REAL_VALUE_TYPE real
;
11116 REAL_VALUE_TYPE imag
;
11117 tree el_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
11121 #if FFETARGET_okCOMPLEX1
11122 case FFEINFO_kindtypeREAL1
:
11123 real
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).real
);
11124 imag
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).imaginary
);
11128 #if FFETARGET_okCOMPLEX2
11129 case FFEINFO_kindtypeREAL2
:
11130 real
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).real
);
11131 imag
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).imaginary
);
11135 #if FFETARGET_okCOMPLEX3
11136 case FFEINFO_kindtypeREAL3
:
11137 real
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).real
);
11138 imag
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).imaginary
);
11142 #if FFETARGET_okCOMPLEX4
11143 case FFEINFO_kindtypeREAL4
:
11144 real
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).real
);
11145 imag
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).imaginary
);
11150 assert ("bad REAL constant kind type" == NULL
);
11151 /* Fall through. */
11152 case FFEINFO_kindtypeANY
:
11153 return error_mark_node
;
11155 item
= ffecom_build_complex_constant_ (tree_type
,
11156 build_real (el_type
, real
),
11157 build_real (el_type
, imag
));
11161 case FFEINFO_basictypeCHARACTER
:
11162 { /* Happens only in DATA and similar contexts. */
11163 ffetargetCharacter1 val
;
11167 #if FFETARGET_okCHARACTER1
11168 case FFEINFO_kindtypeLOGICAL1
:
11169 val
= ffebld_cu_val_character1 (*cu
);
11174 assert ("bad CHARACTER constant kind type" == NULL
);
11175 /* Fall through. */
11176 case FFEINFO_kindtypeANY
:
11177 return error_mark_node
;
11179 item
= build_string (ffetarget_length_character1 (val
),
11180 ffetarget_text_character1 (val
));
11182 = build_type_variant (build_array_type (char_type_node
,
11184 (integer_type_node
,
11187 (ffetarget_length_character1
11193 case FFEINFO_basictypeHOLLERITH
:
11195 ffetargetHollerith h
;
11197 h
= ffebld_cu_val_hollerith (*cu
);
11199 /* If not at least as wide as default INTEGER, widen it. */
11200 if (h
.length
>= FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
)
11201 item
= build_string (h
.length
, h
.text
);
11204 char str
[FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
];
11206 memcpy (str
, h
.text
, h
.length
);
11207 memset (&str
[h
.length
], ' ',
11208 FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
11210 item
= build_string (FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
,
11214 = build_type_variant (build_array_type (char_type_node
,
11216 (integer_type_node
,
11224 case FFEINFO_basictypeTYPELESS
:
11226 ffetargetInteger1 ival
;
11227 ffetargetTypeless tless
;
11230 tless
= ffebld_cu_val_typeless (*cu
);
11231 error
= ffetarget_convert_integer1_typeless (&ival
, tless
);
11232 assert (error
== FFEBAD
);
11234 item
= build_int_2 ((int) ival
, 0);
11239 assert ("not yet on constant type" == NULL
);
11240 /* Fall through. */
11241 case FFEINFO_basictypeANY
:
11242 return error_mark_node
;
11245 TREE_CONSTANT (item
) = 1;
11252 /* Handy way to make a field in a struct/union. */
11254 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11256 ffecom_decl_field (tree context
, tree prevfield
,
11257 char *name
, tree type
)
11261 field
= build_decl (FIELD_DECL
, get_identifier (name
), type
);
11262 DECL_CONTEXT (field
) = context
;
11263 DECL_FRAME_SIZE (field
) = 0;
11264 if (prevfield
!= NULL_TREE
)
11265 TREE_CHAIN (prevfield
) = field
;
11273 ffecom_close_include (FILE *f
)
11275 #if FFECOM_GCC_INCLUDE
11276 ffecom_close_include_ (f
);
11281 ffecom_decode_include_option (char *spec
)
11283 #if FFECOM_GCC_INCLUDE
11284 return ffecom_decode_include_option_ (spec
);
11290 /* ffecom_end_transition -- Perform end transition on all symbols
11292 ffecom_end_transition();
11294 Calls ffecom_sym_end_transition for each global and local symbol. */
11297 ffecom_end_transition ()
11299 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11303 if (ffe_is_ffedebug ())
11304 fprintf (dmpout
, "; end_stmt_transition\n");
11306 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11307 ffecom_list_blockdata_
= NULL
;
11308 ffecom_list_common_
= NULL
;
11311 ffesymbol_drive (ffecom_sym_end_transition
);
11312 if (ffe_is_ffedebug ())
11314 ffestorag_report ();
11315 ffesymbol_report_all ();
11318 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11319 ffecom_start_progunit_ ();
11321 for (item
= ffecom_list_blockdata_
;
11323 item
= ffebld_trail (item
))
11331 static int number
= 0;
11333 callee
= ffebld_head (item
);
11334 s
= ffebld_symter (callee
);
11335 t
= ffesymbol_hook (s
).decl_tree
;
11336 if (t
== NULL_TREE
)
11338 s
= ffecom_sym_transform_ (s
);
11339 t
= ffesymbol_hook (s
).decl_tree
;
11342 yes
= suspend_momentary ();
11344 dt
= build_pointer_type (TREE_TYPE (t
));
11346 var
= build_decl (VAR_DECL
,
11347 ffecom_get_invented_identifier ("__g77_forceload_%d",
11350 DECL_EXTERNAL (var
) = 0;
11351 TREE_STATIC (var
) = 1;
11352 TREE_PUBLIC (var
) = 0;
11353 DECL_INITIAL (var
) = error_mark_node
;
11354 TREE_USED (var
) = 1;
11356 var
= start_decl (var
, FALSE
);
11358 t
= ffecom_1 (ADDR_EXPR
, dt
, t
);
11360 finish_decl (var
, t
, FALSE
);
11362 resume_momentary (yes
);
11365 /* This handles any COMMON areas that weren't referenced but have, for
11366 example, important initial data. */
11368 for (item
= ffecom_list_common_
;
11370 item
= ffebld_trail (item
))
11371 ffecom_transform_common_ (ffebld_symter (ffebld_head (item
)));
11373 ffecom_list_common_
= NULL
;
11377 /* ffecom_exec_transition -- Perform exec transition on all symbols
11379 ffecom_exec_transition();
11381 Calls ffecom_sym_exec_transition for each global and local symbol.
11382 Make sure error updating not inhibited. */
11385 ffecom_exec_transition ()
11389 if (ffe_is_ffedebug ())
11390 fprintf (dmpout
, "; exec_stmt_transition\n");
11392 inhibited
= ffebad_inhibit ();
11393 ffebad_set_inhibit (FALSE
);
11395 ffesymbol_drive (ffecom_sym_exec_transition
); /* Don't retract! */
11396 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
11397 if (ffe_is_ffedebug ())
11399 ffestorag_report ();
11400 ffesymbol_report_all ();
11404 ffebad_set_inhibit (TRUE
);
11407 /* ffecom_expand_let_stmt -- Compile let (assignment) statement
11411 ffecom_expand_let_stmt(dest,source);
11413 Convert dest and source using ffecom_expr, then join them
11414 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
11416 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11418 ffecom_expand_let_stmt (ffebld dest
, ffebld source
)
11425 if (ffeinfo_basictype (ffebld_info (dest
)) != FFEINFO_basictypeCHARACTER
)
11429 dest_tree
= ffecom_expr_rw (dest
);
11430 if (dest_tree
== error_mark_node
)
11433 if ((TREE_CODE (dest_tree
) != VAR_DECL
)
11434 || TREE_ADDRESSABLE (dest_tree
))
11435 source_tree
= ffecom_expr_ (source
, dest_tree
, dest
,
11436 &dest_used
, FALSE
);
11439 source_tree
= ffecom_expr (source
);
11442 if (source_tree
== error_mark_node
)
11446 expr_tree
= source_tree
;
11448 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
11452 expand_expr_stmt (expr_tree
);
11456 ffecom_push_calltemps ();
11457 ffecom_char_args_ (&dest_tree
, &dest_length
, dest
);
11458 ffecom_let_char_ (dest_tree
, dest_length
, ffebld_size_known (dest
),
11460 ffecom_pop_calltemps ();
11464 /* ffecom_expr -- Transform expr into gcc tree
11467 ffebld expr; // FFE expression.
11468 tree = ffecom_expr(expr);
11470 Recursive descent on expr while making corresponding tree nodes and
11471 attaching type info and such. */
11473 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11475 ffecom_expr (ffebld expr
)
11477 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
,
11482 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
11484 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11486 ffecom_expr_assign (ffebld expr
)
11488 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
,
11493 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
11495 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11497 ffecom_expr_assign_w (ffebld expr
)
11499 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
,
11504 /* Transform expr for use as into read/write tree and stabilize the
11505 reference. Not for use on CHARACTER expressions.
11507 Recursive descent on expr while making corresponding tree nodes and
11508 attaching type info and such. */
11510 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11512 ffecom_expr_rw (ffebld expr
)
11514 assert (expr
!= NULL
);
11516 return stabilize_reference (ffecom_expr (expr
));
11520 /* Do global stuff. */
11522 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11524 ffecom_finish_compile ()
11526 assert (ffecom_outer_function_decl_
== NULL_TREE
);
11527 assert (current_function_decl
== NULL_TREE
);
11529 ffeglobal_drive (ffecom_finish_global_
);
11533 /* Public entry point for front end to access finish_decl. */
11535 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11537 ffecom_finish_decl (tree decl
, tree init
, bool is_top_level
)
11539 assert (!is_top_level
);
11540 finish_decl (decl
, init
, FALSE
);
11544 /* Finish a program unit. */
11546 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11548 ffecom_finish_progunit ()
11550 ffecom_end_compstmt_ ();
11552 ffecom_previous_function_decl_
= current_function_decl
;
11553 ffecom_which_entrypoint_decl_
= NULL_TREE
;
11555 finish_function (0);
11559 /* Wrapper for get_identifier. pattern is like "...%s...", text is
11560 inserted into final name in place of "%s", or if text is NULL,
11561 pattern is like "...%d..." and text form of number is inserted
11562 in place of "%d". */
11564 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11566 ffecom_get_invented_identifier (char *pattern
, char *text
, int number
)
11574 lenlen
= strlen (pattern
) + 20;
11576 lenlen
= strlen (pattern
) + strlen (text
) - 1;
11577 if (lenlen
> ARRAY_SIZE (space
))
11578 nam
= malloc_new_ks (malloc_pool_image (), pattern
, lenlen
);
11582 sprintf (&nam
[0], pattern
, number
);
11584 sprintf (&nam
[0], pattern
, text
);
11585 decl
= get_identifier (nam
);
11586 if (lenlen
> ARRAY_SIZE (space
))
11587 malloc_kill_ks (malloc_pool_image (), nam
, lenlen
);
11589 IDENTIFIER_INVENTED (decl
) = 1;
11595 ffecom_gfrt_basictype (ffecomGfrt gfrt
)
11597 assert (gfrt
< FFECOM_gfrt
);
11599 switch (ffecom_gfrt_type_
[gfrt
])
11601 case FFECOM_rttypeVOID_
:
11602 return FFEINFO_basictypeNONE
;
11604 case FFECOM_rttypeINT_
:
11605 return FFEINFO_basictypeINTEGER
;
11607 case FFECOM_rttypeINTEGER_
:
11608 return FFEINFO_basictypeINTEGER
;
11610 case FFECOM_rttypeLONGINT_
:
11611 return FFEINFO_basictypeINTEGER
;
11613 case FFECOM_rttypeLOGICAL_
:
11614 return FFEINFO_basictypeLOGICAL
;
11616 case FFECOM_rttypeREAL_F2C_
:
11617 case FFECOM_rttypeREAL_GNU_
:
11618 return FFEINFO_basictypeREAL
;
11620 case FFECOM_rttypeCOMPLEX_F2C_
:
11621 case FFECOM_rttypeCOMPLEX_GNU_
:
11622 return FFEINFO_basictypeCOMPLEX
;
11624 case FFECOM_rttypeDOUBLE_
:
11625 return FFEINFO_basictypeREAL
;
11627 case FFECOM_rttypeDBLCMPLX_F2C_
:
11628 case FFECOM_rttypeDBLCMPLX_GNU_
:
11629 return FFEINFO_basictypeCOMPLEX
;
11631 case FFECOM_rttypeCHARACTER_
:
11632 return FFEINFO_basictypeCHARACTER
;
11635 return FFEINFO_basictypeANY
;
11640 ffecom_gfrt_kindtype (ffecomGfrt gfrt
)
11642 assert (gfrt
< FFECOM_gfrt
);
11644 switch (ffecom_gfrt_type_
[gfrt
])
11646 case FFECOM_rttypeVOID_
:
11647 return FFEINFO_kindtypeNONE
;
11649 case FFECOM_rttypeINT_
:
11650 return FFEINFO_kindtypeINTEGER1
;
11652 case FFECOM_rttypeINTEGER_
:
11653 return FFEINFO_kindtypeINTEGER1
;
11655 case FFECOM_rttypeLONGINT_
:
11656 return FFEINFO_kindtypeINTEGER4
;
11658 case FFECOM_rttypeLOGICAL_
:
11659 return FFEINFO_kindtypeLOGICAL1
;
11661 case FFECOM_rttypeREAL_F2C_
:
11662 case FFECOM_rttypeREAL_GNU_
:
11663 return FFEINFO_kindtypeREAL1
;
11665 case FFECOM_rttypeCOMPLEX_F2C_
:
11666 case FFECOM_rttypeCOMPLEX_GNU_
:
11667 return FFEINFO_kindtypeREAL1
;
11669 case FFECOM_rttypeDOUBLE_
:
11670 return FFEINFO_kindtypeREAL2
;
11672 case FFECOM_rttypeDBLCMPLX_F2C_
:
11673 case FFECOM_rttypeDBLCMPLX_GNU_
:
11674 return FFEINFO_kindtypeREAL2
;
11676 case FFECOM_rttypeCHARACTER_
:
11677 return FFEINFO_kindtypeCHARACTER1
;
11680 return FFEINFO_kindtypeANY
;
11695 /* This block of code comes from the now-obsolete cktyps.c. It checks
11696 whether the compiler environment is buggy in known ways, some of which
11697 would, if not explicitly checked here, result in subtle bugs in g77. */
11699 if (ffe_is_do_internal_checks ())
11701 static char names
[][12]
11703 {"bar", "bletch", "foo", "foobar"};
11708 name
= bsearch ("foo", &names
[0], ARRAY_SIZE (names
), sizeof (names
[0]),
11709 (int (*)()) strcmp
);
11710 if (name
!= (char *) &names
[2])
11712 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11717 ul
= strtoul ("123456789", NULL
, 10);
11718 if (ul
!= 123456789L)
11720 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11721 in proj.h" == NULL
);
11725 fl
= atof ("56.789");
11726 if ((fl
< 56.788) || (fl
> 56.79))
11728 assert ("atof not type double, fix your #include <stdio.h>"
11734 #if FFECOM_GCC_INCLUDE
11735 ffecom_initialize_char_syntax_ ();
11738 ffecom_outer_function_decl_
= NULL_TREE
;
11739 current_function_decl
= NULL_TREE
;
11740 named_labels
= NULL_TREE
;
11741 current_binding_level
= NULL_BINDING_LEVEL
;
11742 free_binding_level
= NULL_BINDING_LEVEL
;
11743 pushlevel (0); /* make the binding_level structure for
11745 global_binding_level
= current_binding_level
;
11747 /* Define `int' and `char' first so that dbx will output them first. */
11749 integer_type_node
= make_signed_type (INT_TYPE_SIZE
);
11750 pushdecl (build_decl (TYPE_DECL
, get_identifier ("int"),
11751 integer_type_node
));
11753 char_type_node
= make_unsigned_type (CHAR_TYPE_SIZE
);
11754 pushdecl (build_decl (TYPE_DECL
, get_identifier ("char"),
11757 long_integer_type_node
= make_signed_type (LONG_TYPE_SIZE
);
11758 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long int"),
11759 long_integer_type_node
));
11761 unsigned_type_node
= make_unsigned_type (INT_TYPE_SIZE
);
11762 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned int"),
11763 unsigned_type_node
));
11765 long_unsigned_type_node
= make_unsigned_type (LONG_TYPE_SIZE
);
11766 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long unsigned int"),
11767 long_unsigned_type_node
));
11769 long_long_integer_type_node
= make_signed_type (LONG_LONG_TYPE_SIZE
);
11770 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long int"),
11771 long_long_integer_type_node
));
11773 long_long_unsigned_type_node
= make_unsigned_type (LONG_LONG_TYPE_SIZE
);
11774 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long unsigned int"),
11775 long_long_unsigned_type_node
));
11778 = TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE
)));
11780 TREE_TYPE (TYPE_SIZE (integer_type_node
)) = sizetype
;
11781 TREE_TYPE (TYPE_SIZE (char_type_node
)) = sizetype
;
11782 TREE_TYPE (TYPE_SIZE (unsigned_type_node
)) = sizetype
;
11783 TREE_TYPE (TYPE_SIZE (long_unsigned_type_node
)) = sizetype
;
11784 TREE_TYPE (TYPE_SIZE (long_integer_type_node
)) = sizetype
;
11785 TREE_TYPE (TYPE_SIZE (long_long_integer_type_node
)) = sizetype
;
11786 TREE_TYPE (TYPE_SIZE (long_long_unsigned_type_node
)) = sizetype
;
11788 error_mark_node
= make_node (ERROR_MARK
);
11789 TREE_TYPE (error_mark_node
) = error_mark_node
;
11791 short_integer_type_node
= make_signed_type (SHORT_TYPE_SIZE
);
11792 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short int"),
11793 short_integer_type_node
));
11795 short_unsigned_type_node
= make_unsigned_type (SHORT_TYPE_SIZE
);
11796 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short unsigned int"),
11797 short_unsigned_type_node
));
11799 /* Define both `signed char' and `unsigned char'. */
11800 signed_char_type_node
= make_signed_type (CHAR_TYPE_SIZE
);
11801 pushdecl (build_decl (TYPE_DECL
, get_identifier ("signed char"),
11802 signed_char_type_node
));
11804 unsigned_char_type_node
= make_unsigned_type (CHAR_TYPE_SIZE
);
11805 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned char"),
11806 unsigned_char_type_node
));
11808 float_type_node
= make_node (REAL_TYPE
);
11809 TYPE_PRECISION (float_type_node
) = FLOAT_TYPE_SIZE
;
11810 layout_type (float_type_node
);
11811 pushdecl (build_decl (TYPE_DECL
, get_identifier ("float"),
11814 double_type_node
= make_node (REAL_TYPE
);
11815 TYPE_PRECISION (double_type_node
) = DOUBLE_TYPE_SIZE
;
11816 layout_type (double_type_node
);
11817 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double"),
11818 double_type_node
));
11820 long_double_type_node
= make_node (REAL_TYPE
);
11821 TYPE_PRECISION (long_double_type_node
) = LONG_DOUBLE_TYPE_SIZE
;
11822 layout_type (long_double_type_node
);
11823 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long double"),
11824 long_double_type_node
));
11826 complex_integer_type_node
= ffecom_make_complex_type_ (integer_type_node
);
11827 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex int"),
11828 complex_integer_type_node
));
11830 complex_float_type_node
= ffecom_make_complex_type_ (float_type_node
);
11831 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex float"),
11832 complex_float_type_node
));
11834 complex_double_type_node
= ffecom_make_complex_type_ (double_type_node
);
11835 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex double"),
11836 complex_double_type_node
));
11838 complex_long_double_type_node
= ffecom_make_complex_type_ (long_double_type_node
);
11839 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex long double"),
11840 complex_long_double_type_node
));
11842 integer_zero_node
= build_int_2 (0, 0);
11843 TREE_TYPE (integer_zero_node
) = integer_type_node
;
11844 integer_one_node
= build_int_2 (1, 0);
11845 TREE_TYPE (integer_one_node
) = integer_type_node
;
11847 size_zero_node
= build_int_2 (0, 0);
11848 TREE_TYPE (size_zero_node
) = sizetype
;
11849 size_one_node
= build_int_2 (1, 0);
11850 TREE_TYPE (size_one_node
) = sizetype
;
11852 void_type_node
= make_node (VOID_TYPE
);
11853 pushdecl (build_decl (TYPE_DECL
, get_identifier ("void"),
11855 layout_type (void_type_node
); /* Uses integer_zero_node */
11856 /* We are not going to have real types in C with less than byte alignment,
11857 so we might as well not have any types that claim to have it. */
11858 TYPE_ALIGN (void_type_node
) = BITS_PER_UNIT
;
11860 null_pointer_node
= build_int_2 (0, 0);
11861 TREE_TYPE (null_pointer_node
) = build_pointer_type (void_type_node
);
11862 layout_type (TREE_TYPE (null_pointer_node
));
11864 string_type_node
= build_pointer_type (char_type_node
);
11866 ffecom_tree_fun_type_void
11867 = build_function_type (void_type_node
, NULL_TREE
);
11869 ffecom_tree_ptr_to_fun_type_void
11870 = build_pointer_type (ffecom_tree_fun_type_void
);
11872 endlink
= tree_cons (NULL_TREE
, void_type_node
, NULL_TREE
);
11875 = build_function_type (float_type_node
,
11876 tree_cons (NULL_TREE
, float_type_node
, endlink
));
11878 double_ftype_double
11879 = build_function_type (double_type_node
,
11880 tree_cons (NULL_TREE
, double_type_node
, endlink
));
11882 ldouble_ftype_ldouble
11883 = build_function_type (long_double_type_node
,
11884 tree_cons (NULL_TREE
, long_double_type_node
,
11887 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11888 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11890 ffecom_tree_type
[i
][j
] = NULL_TREE
;
11891 ffecom_tree_fun_type
[i
][j
] = NULL_TREE
;
11892 ffecom_tree_ptr_to_fun_type
[i
][j
] = NULL_TREE
;
11893 ffecom_f2c_typecode_
[i
][j
] = -1;
11896 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11897 to size FLOAT_TYPE_SIZE because they have to be the same size as
11898 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11899 Compiler options and other such stuff that change the ways these
11900 types are set should not affect this particular setup. */
11902 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
]
11903 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
11904 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer"),
11906 type
= ffetype_new ();
11908 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER1
,
11910 ffetype_set_ams (type
,
11911 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11912 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11913 ffetype_set_star (base_type
,
11914 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11916 ffetype_set_kind (base_type
, 1, type
);
11917 assert (ffetype_size (type
) == sizeof (ffetargetInteger1
));
11919 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER1
]
11920 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
); /* HOLLERITH means unsigned. */
11921 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned"),
11924 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER2
]
11925 = t
= make_signed_type (CHAR_TYPE_SIZE
);
11926 pushdecl (build_decl (TYPE_DECL
, get_identifier ("byte"),
11928 type
= ffetype_new ();
11929 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER2
,
11931 ffetype_set_ams (type
,
11932 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11933 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11934 ffetype_set_star (base_type
,
11935 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11937 ffetype_set_kind (base_type
, 3, type
);
11938 assert (ffetype_size (type
) == sizeof (ffetargetInteger2
));
11940 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER2
]
11941 = t
= make_unsigned_type (CHAR_TYPE_SIZE
);
11942 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned byte"),
11945 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER3
]
11946 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
11947 pushdecl (build_decl (TYPE_DECL
, get_identifier ("word"),
11949 type
= ffetype_new ();
11950 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER3
,
11952 ffetype_set_ams (type
,
11953 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11954 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11955 ffetype_set_star (base_type
,
11956 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11958 ffetype_set_kind (base_type
, 6, type
);
11959 assert (ffetype_size (type
) == sizeof (ffetargetInteger3
));
11961 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER3
]
11962 = t
= make_unsigned_type (CHAR_TYPE_SIZE
* 2);
11963 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned word"),
11966 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER4
]
11967 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
11968 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer4"),
11970 type
= ffetype_new ();
11971 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER4
,
11973 ffetype_set_ams (type
,
11974 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11975 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11976 ffetype_set_star (base_type
,
11977 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11979 ffetype_set_kind (base_type
, 2, type
);
11980 assert (ffetype_size (type
) == sizeof (ffetargetInteger4
));
11982 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER4
]
11983 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
* 2);
11984 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned4"),
11988 if (ffe_is_do_internal_checks ()
11989 && LONG_TYPE_SIZE
!= FLOAT_TYPE_SIZE
11990 && LONG_TYPE_SIZE
!= CHAR_TYPE_SIZE
11991 && LONG_TYPE_SIZE
!= SHORT_TYPE_SIZE
11992 && LONG_TYPE_SIZE
!= LONG_LONG_TYPE_SIZE
)
11994 fprintf (stderr
, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11999 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL1
]
12000 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
12001 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical"),
12003 type
= ffetype_new ();
12005 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL1
,
12007 ffetype_set_ams (type
,
12008 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12009 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12010 ffetype_set_star (base_type
,
12011 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12013 ffetype_set_kind (base_type
, 1, type
);
12014 assert (ffetype_size (type
) == sizeof (ffetargetLogical1
));
12016 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL2
]
12017 = t
= make_signed_type (CHAR_TYPE_SIZE
);
12018 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical2"),
12020 type
= ffetype_new ();
12021 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL2
,
12023 ffetype_set_ams (type
,
12024 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12025 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12026 ffetype_set_star (base_type
,
12027 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12029 ffetype_set_kind (base_type
, 3, type
);
12030 assert (ffetype_size (type
) == sizeof (ffetargetLogical2
));
12032 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL3
]
12033 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
12034 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical3"),
12036 type
= ffetype_new ();
12037 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL3
,
12039 ffetype_set_ams (type
,
12040 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12041 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12042 ffetype_set_star (base_type
,
12043 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12045 ffetype_set_kind (base_type
, 6, type
);
12046 assert (ffetype_size (type
) == sizeof (ffetargetLogical3
));
12048 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL4
]
12049 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
12050 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical4"),
12052 type
= ffetype_new ();
12053 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL4
,
12055 ffetype_set_ams (type
,
12056 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12057 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12058 ffetype_set_star (base_type
,
12059 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12061 ffetype_set_kind (base_type
, 2, type
);
12062 assert (ffetype_size (type
) == sizeof (ffetargetLogical4
));
12064 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
12065 = t
= make_node (REAL_TYPE
);
12066 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
;
12067 pushdecl (build_decl (TYPE_DECL
, get_identifier ("real"),
12070 type
= ffetype_new ();
12072 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREAL1
,
12074 ffetype_set_ams (type
,
12075 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12076 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12077 ffetype_set_star (base_type
,
12078 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12080 ffetype_set_kind (base_type
, 1, type
);
12081 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
12082 = FFETARGET_f2cTYREAL
;
12083 assert (ffetype_size (type
) == sizeof (ffetargetReal1
));
12085 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREALDOUBLE
]
12086 = t
= make_node (REAL_TYPE
);
12087 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
* 2; /* Always twice REAL. */
12088 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double precision"),
12091 type
= ffetype_new ();
12092 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREALDOUBLE
,
12094 ffetype_set_ams (type
,
12095 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12096 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12097 ffetype_set_star (base_type
,
12098 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12100 ffetype_set_kind (base_type
, 2, type
);
12101 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]
12102 = FFETARGET_f2cTYDREAL
;
12103 assert (ffetype_size (type
) == sizeof (ffetargetReal2
));
12105 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
12106 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]);
12107 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex"),
12109 type
= ffetype_new ();
12111 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREAL1
,
12113 ffetype_set_ams (type
,
12114 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12115 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12116 ffetype_set_star (base_type
,
12117 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12119 ffetype_set_kind (base_type
, 1, type
);
12120 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
12121 = FFETARGET_f2cTYCOMPLEX
;
12122 assert (ffetype_size (type
) == sizeof (ffetargetComplex1
));
12124 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREALDOUBLE
]
12125 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]);
12126 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double complex"),
12128 type
= ffetype_new ();
12129 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREALDOUBLE
,
12131 ffetype_set_ams (type
,
12132 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12133 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12134 ffetype_set_star (base_type
,
12135 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12137 ffetype_set_kind (base_type
, 2,
12139 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL2
]
12140 = FFETARGET_f2cTYDCOMPLEX
;
12141 assert (ffetype_size (type
) == sizeof (ffetargetComplex2
));
12143 /* Make function and ptr-to-function types for non-CHARACTER types. */
12145 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
12146 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
12148 if ((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
12150 if (i
== FFEINFO_basictypeINTEGER
)
12152 /* Figure out the smallest INTEGER type that can hold
12153 a pointer on this machine. */
12154 if (GET_MODE_SIZE (TYPE_MODE (t
))
12155 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
12157 if ((ffecom_pointer_kind_
== FFEINFO_kindtypeNONE
)
12158 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type
[i
][ffecom_pointer_kind_
]))
12159 > GET_MODE_SIZE (TYPE_MODE (t
))))
12160 ffecom_pointer_kind_
= j
;
12163 else if (i
== FFEINFO_basictypeCOMPLEX
)
12164 t
= void_type_node
;
12165 /* For f2c compatibility, REAL functions are really
12166 implemented as DOUBLE PRECISION. */
12167 else if ((i
== FFEINFO_basictypeREAL
)
12168 && (j
== FFEINFO_kindtypeREAL1
))
12169 t
= ffecom_tree_type
12170 [FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
];
12172 t
= ffecom_tree_fun_type
[i
][j
] = build_function_type (t
,
12174 ffecom_tree_ptr_to_fun_type
[i
][j
] = build_pointer_type (t
);
12178 /* Set up pointer types. */
12180 if (ffecom_pointer_kind_
== FFEINFO_basictypeNONE
)
12181 fatal ("no INTEGER type can hold a pointer on this configuration");
12182 else if (0 && ffe_is_do_internal_checks ())
12183 fprintf (stderr
, "Pointer type kt=%d\n", ffecom_pointer_kind_
);
12184 type
= ffetype_new ();
12185 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER
,
12186 FFEINFO_kindtypeINTEGERDEFAULT
),
12189 if (ffe_is_ugly_assign ())
12190 ffecom_label_kind_
= ffecom_pointer_kind_
; /* Require ASSIGN etc to this. */
12192 ffecom_label_kind_
= FFEINFO_kindtypeINTEGERDEFAULT
;
12193 if (0 && ffe_is_do_internal_checks ())
12194 fprintf (stderr
, "Label type kt=%d\n", ffecom_label_kind_
);
12196 ffecom_integer_type_node
12197 = ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
];
12198 ffecom_integer_zero_node
= convert (ffecom_integer_type_node
,
12199 integer_zero_node
);
12200 ffecom_integer_one_node
= convert (ffecom_integer_type_node
,
12203 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
12204 Turns out that by TYLONG, runtime/libI77/lio.h really means
12205 "whatever size an ftnint is". For consistency and sanity,
12206 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
12207 all are INTEGER, which we also make out of whatever back-end
12208 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
12209 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
12210 accommodate machines like the Alpha. Note that this suggests
12211 f2c and libf2c are missing a distinction perhaps needed on
12212 some machines between "int" and "long int". -- burley 0.5.5 950215 */
12214 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, FLOAT_TYPE_SIZE
,
12215 FFETARGET_f2cTYLONG
);
12216 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, SHORT_TYPE_SIZE
,
12217 FFETARGET_f2cTYSHORT
);
12218 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, CHAR_TYPE_SIZE
,
12219 FFETARGET_f2cTYINT1
);
12220 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, LONG_LONG_TYPE_SIZE
,
12221 FFETARGET_f2cTYQUAD
);
12222 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, FLOAT_TYPE_SIZE
,
12223 FFETARGET_f2cTYLOGICAL
);
12224 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, SHORT_TYPE_SIZE
,
12225 FFETARGET_f2cTYLOGICAL2
);
12226 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, CHAR_TYPE_SIZE
,
12227 FFETARGET_f2cTYLOGICAL1
);
12228 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, LONG_LONG_TYPE_SIZE
,
12229 FFETARGET_f2cTYQUAD
/* ~~~ */);
12231 /* CHARACTER stuff is all special-cased, so it is not handled in the above
12232 loop. CHARACTER items are built as arrays of unsigned char. */
12234 ffecom_tree_type
[FFEINFO_basictypeCHARACTER
]
12235 [FFEINFO_kindtypeCHARACTER1
] = t
= char_type_node
;
12236 type
= ffetype_new ();
12238 ffeinfo_set_type (FFEINFO_basictypeCHARACTER
,
12239 FFEINFO_kindtypeCHARACTER1
,
12241 ffetype_set_ams (type
,
12242 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12243 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12244 ffetype_set_kind (base_type
, 1, type
);
12245 assert (ffetype_size (type
)
12246 == sizeof (((ffetargetCharacter1
) { 0, NULL
}).text
[0]));
12248 ffecom_tree_fun_type
[FFEINFO_basictypeCHARACTER
]
12249 [FFEINFO_kindtypeCHARACTER1
] = ffecom_tree_fun_type_void
;
12250 ffecom_tree_ptr_to_fun_type
[FFEINFO_basictypeCHARACTER
]
12251 [FFEINFO_kindtypeCHARACTER1
]
12252 = ffecom_tree_ptr_to_fun_type_void
;
12253 ffecom_f2c_typecode_
[FFEINFO_basictypeCHARACTER
][FFEINFO_kindtypeCHARACTER1
]
12254 = FFETARGET_f2cTYCHAR
;
12256 ffecom_f2c_typecode_
[FFEINFO_basictypeANY
][FFEINFO_kindtypeANY
]
12259 /* Make multi-return-value type and fields. */
12261 ffecom_multi_type_node_
= make_node (UNION_TYPE
);
12265 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
12266 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
12270 if (ffecom_tree_type
[i
][j
] == NULL_TREE
)
12271 continue; /* Not supported. */
12272 sprintf (&name
[0], "bt_%s_kt_%s",
12273 ffeinfo_basictype_string ((ffeinfoBasictype
) i
),
12274 ffeinfo_kindtype_string ((ffeinfoKindtype
) j
));
12275 ffecom_multi_fields_
[i
][j
] = build_decl (FIELD_DECL
,
12276 get_identifier (name
),
12277 ffecom_tree_type
[i
][j
]);
12278 DECL_CONTEXT (ffecom_multi_fields_
[i
][j
])
12279 = ffecom_multi_type_node_
;
12280 DECL_FRAME_SIZE (ffecom_multi_fields_
[i
][j
]) = 0;
12281 TREE_CHAIN (ffecom_multi_fields_
[i
][j
]) = field
;
12282 field
= ffecom_multi_fields_
[i
][j
];
12285 TYPE_FIELDS (ffecom_multi_type_node_
) = field
;
12286 layout_type (ffecom_multi_type_node_
);
12288 /* Subroutines usually return integer because they might have alternate
12291 ffecom_tree_subr_type
12292 = build_function_type (integer_type_node
, NULL_TREE
);
12293 ffecom_tree_ptr_to_subr_type
12294 = build_pointer_type (ffecom_tree_subr_type
);
12295 ffecom_tree_blockdata_type
12296 = build_function_type (void_type_node
, NULL_TREE
);
12298 builtin_function ("__builtin_sqrtf", float_ftype_float
,
12299 BUILT_IN_FSQRT
, "sqrtf");
12300 builtin_function ("__builtin_fsqrt", double_ftype_double
,
12301 BUILT_IN_FSQRT
, "sqrt");
12302 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble
,
12303 BUILT_IN_FSQRT
, "sqrtl");
12304 builtin_function ("__builtin_sinf", float_ftype_float
,
12305 BUILT_IN_SIN
, "sinf");
12306 builtin_function ("__builtin_sin", double_ftype_double
,
12307 BUILT_IN_SIN
, "sin");
12308 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble
,
12309 BUILT_IN_SIN
, "sinl");
12310 builtin_function ("__builtin_cosf", float_ftype_float
,
12311 BUILT_IN_COS
, "cosf");
12312 builtin_function ("__builtin_cos", double_ftype_double
,
12313 BUILT_IN_COS
, "cos");
12314 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble
,
12315 BUILT_IN_COS
, "cosl");
12318 pedantic_lvalues
= FALSE
;
12321 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node
,
12324 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node
,
12327 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node
,
12330 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node
,
12331 FFECOM_f2cDOUBLEREAL
,
12333 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node
,
12336 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node
,
12337 FFECOM_f2cDOUBLECOMPLEX
,
12339 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node
,
12342 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node
,
12345 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node
,
12348 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node
,
12351 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node
,
12355 ffecom_f2c_ftnlen_zero_node
12356 = convert (ffecom_f2c_ftnlen_type_node
, integer_zero_node
);
12358 ffecom_f2c_ftnlen_one_node
12359 = convert (ffecom_f2c_ftnlen_type_node
, integer_one_node
);
12361 ffecom_f2c_ftnlen_two_node
= build_int_2 (2, 0);
12362 TREE_TYPE (ffecom_f2c_ftnlen_two_node
) = ffecom_integer_type_node
;
12364 ffecom_f2c_ptr_to_ftnlen_type_node
12365 = build_pointer_type (ffecom_f2c_ftnlen_type_node
);
12367 ffecom_f2c_ptr_to_ftnint_type_node
12368 = build_pointer_type (ffecom_f2c_ftnint_type_node
);
12370 ffecom_f2c_ptr_to_integer_type_node
12371 = build_pointer_type (ffecom_f2c_integer_type_node
);
12373 ffecom_f2c_ptr_to_real_type_node
12374 = build_pointer_type (ffecom_f2c_real_type_node
);
12376 ffecom_float_zero_
= build_real (float_type_node
, dconst0
);
12377 ffecom_double_zero_
= build_real (double_type_node
, dconst0
);
12379 REAL_VALUE_TYPE point_5
;
12381 #ifdef REAL_ARITHMETIC
12382 REAL_ARITHMETIC (point_5
, RDIV_EXPR
, dconst1
, dconst2
);
12386 ffecom_float_half_
= build_real (float_type_node
, point_5
);
12387 ffecom_double_half_
= build_real (double_type_node
, point_5
);
12390 /* Do "extern int xargc;". */
12392 ffecom_tree_xargc_
= build_decl (VAR_DECL
,
12393 get_identifier ("xargc"),
12394 integer_type_node
);
12395 DECL_EXTERNAL (ffecom_tree_xargc_
) = 1;
12396 TREE_STATIC (ffecom_tree_xargc_
) = 1;
12397 TREE_PUBLIC (ffecom_tree_xargc_
) = 1;
12398 ffecom_tree_xargc_
= start_decl (ffecom_tree_xargc_
, FALSE
);
12399 finish_decl (ffecom_tree_xargc_
, NULL_TREE
, FALSE
);
12401 #if 0 /* This is being fixed, and seems to be working now. */
12402 if ((FLOAT_TYPE_SIZE
!= 32)
12403 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))) != 32))
12405 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12406 (int) FLOAT_TYPE_SIZE
);
12407 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12408 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))));
12409 warning ("properly unless they all are 32 bits wide.");
12410 warning ("Please keep this in mind before you report bugs. g77 should");
12411 warning ("support non-32-bit machines better as of version 0.6.");
12415 #if 0 /* Code in ste.c that would crash has been commented out. */
12416 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
12417 < TYPE_PRECISION (string_type_node
))
12418 /* I/O will probably crash. */
12419 warning ("configuration: char * holds %d bits, but ftnlen only %d",
12420 TYPE_PRECISION (string_type_node
),
12421 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
));
12424 #if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
12425 if (TYPE_PRECISION (ffecom_integer_type_node
)
12426 < TYPE_PRECISION (string_type_node
))
12427 /* ASSIGN 10 TO I will crash. */
12428 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12429 ASSIGN statement might fail",
12430 TYPE_PRECISION (string_type_node
),
12431 TYPE_PRECISION (ffecom_integer_type_node
));
12436 /* ffecom_init_2 -- Initialize
12438 ffecom_init_2(); */
12440 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12444 assert (ffecom_outer_function_decl_
== NULL_TREE
);
12445 assert (current_function_decl
== NULL_TREE
);
12446 assert (ffecom_which_entrypoint_decl_
== NULL_TREE
);
12448 ffecom_master_arglist_
= NULL
;
12450 ffecom_latest_temp_
= NULL
;
12451 ffecom_primary_entry_
= NULL
;
12452 ffecom_is_altreturning_
= FALSE
;
12453 ffecom_func_result_
= NULL_TREE
;
12454 ffecom_multi_retval_
= NULL_TREE
;
12458 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12461 ffebld expr; // FFE opITEM list.
12462 tree = ffecom_list_expr(expr);
12464 List of actual args is transformed into corresponding gcc backend list. */
12466 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12468 ffecom_list_expr (ffebld expr
)
12471 tree
*plist
= &list
;
12472 tree trail
= NULL_TREE
; /* Append char length args here. */
12473 tree
*ptrail
= &trail
;
12476 while (expr
!= NULL
)
12479 = build_tree_list (NULL_TREE
, ffecom_arg_expr (ffebld_head (expr
),
12481 plist
= &TREE_CHAIN (*plist
);
12482 expr
= ffebld_trail (expr
);
12483 if (length
!= NULL_TREE
)
12485 *ptrail
= build_tree_list (NULL_TREE
, length
);
12486 ptrail
= &TREE_CHAIN (*ptrail
);
12496 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12499 ffebld expr; // FFE opITEM list.
12500 tree = ffecom_list_ptr_to_expr(expr);
12502 List of actual args is transformed into corresponding gcc backend list for
12503 use in calling an external procedure (vs. a statement function). */
12505 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12507 ffecom_list_ptr_to_expr (ffebld expr
)
12510 tree
*plist
= &list
;
12511 tree trail
= NULL_TREE
; /* Append char length args here. */
12512 tree
*ptrail
= &trail
;
12515 while (expr
!= NULL
)
12518 = build_tree_list (NULL_TREE
,
12519 ffecom_arg_ptr_to_expr (ffebld_head (expr
),
12521 plist
= &TREE_CHAIN (*plist
);
12522 expr
= ffebld_trail (expr
);
12523 if (length
!= NULL_TREE
)
12525 *ptrail
= build_tree_list (NULL_TREE
, length
);
12526 ptrail
= &TREE_CHAIN (*ptrail
);
12536 /* Obtain gcc's LABEL_DECL tree for label. */
12538 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12540 ffecom_lookup_label (ffelab label
)
12544 if (ffelab_hook (label
) == NULL_TREE
)
12546 char labelname
[16];
12548 switch (ffelab_type (label
))
12550 case FFELAB_typeLOOPEND
:
12551 case FFELAB_typeNOTLOOP
:
12552 case FFELAB_typeENDIF
:
12553 sprintf (labelname
, "%" ffelabValue_f
"u", ffelab_value (label
));
12554 glabel
= build_decl (LABEL_DECL
, get_identifier (labelname
),
12556 DECL_CONTEXT (glabel
) = current_function_decl
;
12557 DECL_MODE (glabel
) = VOIDmode
;
12560 case FFELAB_typeFORMAT
:
12561 push_obstacks_nochange ();
12562 end_temporary_allocation ();
12564 glabel
= build_decl (VAR_DECL
,
12565 ffecom_get_invented_identifier
12566 ("__g77_format_%d", NULL
,
12567 (int) ffelab_value (label
)),
12568 build_type_variant (build_array_type
12572 TREE_CONSTANT (glabel
) = 1;
12573 TREE_STATIC (glabel
) = 1;
12574 DECL_CONTEXT (glabel
) = 0;
12575 DECL_INITIAL (glabel
) = NULL
;
12576 make_decl_rtl (glabel
, NULL
, 0);
12577 expand_decl (glabel
);
12579 resume_temporary_allocation ();
12584 case FFELAB_typeANY
:
12585 glabel
= error_mark_node
;
12589 assert ("bad label type" == NULL
);
12593 ffelab_set_hook (label
, glabel
);
12597 glabel
= ffelab_hook (label
);
12604 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12605 a single source specification (as in the fourth argument of MVBITS).
12606 If the type is NULL_TREE, the type of lhs is used to make the type of
12607 the MODIFY_EXPR. */
12609 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12611 ffecom_modify (tree newtype
, tree lhs
,
12614 if (lhs
== error_mark_node
|| rhs
== error_mark_node
)
12615 return error_mark_node
;
12617 if (newtype
== NULL_TREE
)
12618 newtype
= TREE_TYPE (lhs
);
12620 if (TREE_SIDE_EFFECTS (lhs
))
12621 lhs
= stabilize_reference (lhs
);
12623 return ffecom_2s (MODIFY_EXPR
, newtype
, lhs
, rhs
);
12628 /* Register source file name. */
12631 ffecom_file (char *name
)
12633 #if FFECOM_GCC_INCLUDE
12634 ffecom_file_ (name
);
12638 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12641 ffecom_notify_init_storage(st);
12643 Gets called when all possible units in an aggregate storage area (a LOCAL
12644 with equivalences or a COMMON) have been initialized. The initialization
12645 info either is in ffestorag_init or, if that is NULL,
12646 ffestorag_accretion:
12648 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12649 even for an array if the array is one element in length!
12651 ffestorag_accretion will contain an opACCTER. It is much like an
12652 opARRTER except it has an ffebit object in it instead of just a size.
12653 The back end can use the info in the ffebit object, if it wants, to
12654 reduce the amount of actual initialization, but in any case it should
12655 kill the ffebit object when done. Also, set accretion to NULL but
12656 init to a non-NULL value.
12658 After performing initialization, DO NOT set init to NULL, because that'll
12659 tell the front end it is ok for more initialization to happen. Instead,
12660 set init to an opANY expression or some such thing that you can use to
12661 tell that you've already initialized the object.
12664 Support two-pass FFE. */
12667 ffecom_notify_init_storage (ffestorag st
)
12669 ffebld init
; /* The initialization expression. */
12670 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12671 ffetargetOffset size
; /* The size of the entity. */
12674 if (ffestorag_init (st
) == NULL
)
12676 init
= ffestorag_accretion (st
);
12677 assert (init
!= NULL
);
12678 ffestorag_set_accretion (st
, NULL
);
12679 ffestorag_set_accretes (st
, 0);
12681 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12682 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12683 size
= ffebld_accter_size (init
);
12684 ffebit_kill (ffebld_accter_bits (init
));
12685 ffebld_set_op (init
, FFEBLD_opARRTER
);
12686 ffebld_set_arrter (init
, ffebld_accter (init
));
12687 ffebld_arrter_set_size (init
, size
);
12691 ffestorag_set_init (st
, init
);
12696 init
= ffestorag_init (st
);
12699 #if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
12700 ffestorag_set_init (st
, ffebld_new_any ());
12702 if (ffebld_op (init
) == FFEBLD_opANY
)
12703 return; /* Oh, we already did this! */
12705 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12709 if (ffestorag_symbol (st
) != NULL
)
12710 s
= ffestorag_symbol (st
);
12712 s
= ffestorag_typesymbol (st
);
12714 fprintf (dmpout
, "= initialize_storage \"%s\" ",
12715 (s
!= NULL
) ? ffesymbol_text (s
) : "(unnamed)");
12716 ffebld_dump (init
);
12717 fputc ('\n', dmpout
);
12721 #endif /* if FFECOM_ONEPASS */
12724 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12727 ffecom_notify_init_symbol(s);
12729 Gets called when all possible units in a symbol (not placed in COMMON
12730 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12731 have been initialized. The initialization info either is in
12732 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12734 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12735 even for an array if the array is one element in length!
12737 ffesymbol_accretion will contain an opACCTER. It is much like an
12738 opARRTER except it has an ffebit object in it instead of just a size.
12739 The back end can use the info in the ffebit object, if it wants, to
12740 reduce the amount of actual initialization, but in any case it should
12741 kill the ffebit object when done. Also, set accretion to NULL but
12742 init to a non-NULL value.
12744 After performing initialization, DO NOT set init to NULL, because that'll
12745 tell the front end it is ok for more initialization to happen. Instead,
12746 set init to an opANY expression or some such thing that you can use to
12747 tell that you've already initialized the object.
12750 Support two-pass FFE. */
12753 ffecom_notify_init_symbol (ffesymbol s
)
12755 ffebld init
; /* The initialization expression. */
12756 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12757 ffetargetOffset size
; /* The size of the entity. */
12760 if (ffesymbol_storage (s
) == NULL
)
12761 return; /* Do nothing until COMMON/EQUIVALENCE
12762 possibilities checked. */
12764 if ((ffesymbol_init (s
) == NULL
)
12765 && ((init
= ffesymbol_accretion (s
)) != NULL
))
12767 ffesymbol_set_accretion (s
, NULL
);
12768 ffesymbol_set_accretes (s
, 0);
12770 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12771 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12772 size
= ffebld_accter_size (init
);
12773 ffebit_kill (ffebld_accter_bits (init
));
12774 ffebld_set_op (init
, FFEBLD_opARRTER
);
12775 ffebld_set_arrter (init
, ffebld_accter (init
));
12776 ffebld_arrter_set_size (init
, size
);
12780 ffesymbol_set_init (s
, init
);
12785 init
= ffesymbol_init (s
);
12789 ffesymbol_set_init (s
, ffebld_new_any ());
12791 if (ffebld_op (init
) == FFEBLD_opANY
)
12792 return; /* Oh, we already did this! */
12794 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12795 fprintf (dmpout
, "= initialize_symbol \"%s\" ", ffesymbol_text (s
));
12796 ffebld_dump (init
);
12797 fputc ('\n', dmpout
);
12800 #endif /* if FFECOM_ONEPASS */
12803 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12806 ffecom_notify_primary_entry(s);
12808 Gets called when implicit or explicit PROGRAM statement seen or when
12809 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12810 global symbol that serves as the entry point. */
12813 ffecom_notify_primary_entry (ffesymbol s
)
12815 ffecom_primary_entry_
= s
;
12816 ffecom_primary_entry_kind_
= ffesymbol_kind (s
);
12818 if ((ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
12819 || (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
))
12820 ffecom_primary_entry_is_proc_
= TRUE
;
12822 ffecom_primary_entry_is_proc_
= FALSE
;
12824 if (!ffe_is_silent ())
12826 if (ffecom_primary_entry_kind_
== FFEINFO_kindPROGRAM
)
12827 fprintf (stderr
, "%s:\n", ffesymbol_text (s
));
12829 fprintf (stderr
, " %s:\n", ffesymbol_text (s
));
12832 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12833 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
12838 for (list
= ffesymbol_dummyargs (s
);
12840 list
= ffebld_trail (list
))
12842 arg
= ffebld_head (list
);
12843 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
12845 ffecom_is_altreturning_
= TRUE
;
12854 ffecom_open_include (char *name
, ffewhereLine l
, ffewhereColumn c
)
12856 #if FFECOM_GCC_INCLUDE
12857 return ffecom_open_include_ (name
, l
, c
);
12859 return fopen (name
, "r");
12863 /* Clean up after making automatically popped call-arg temps.
12865 Call this in pairs with push_calltemps around calls to
12866 ffecom_arg_ptr_to_expr if the latter might use temporaries.
12867 Any temporaries made within the outermost sequence of
12868 push_calltemps and pop_calltemps, that are marked as "auto-pop"
12869 meaning they won't be explicitly popped (freed), are popped
12870 at this point so they can be reused later.
12872 NOTE: when called by ffecom_gen_sfuncdef_, ffecom_pending_calls_
12873 should come in == 1, and all of the in-use auto-pop temps
12874 should have DECL_CONTEXT (temp->t) == current_function_decl.
12875 Moreover, these temps should _never_ be re-used in future
12876 calls to ffecom_push_tempvar -- since current_function_decl will
12877 never be the same again.
12879 SO, it could be a minor win in terms of compile time to just
12880 strip these temps off the list. That is, if the above assumptions
12881 are correct, just remove from the list of temps any temp
12882 that is both in-use and has DECL_CONTEXT (temp->t)
12883 == current_function_decl, when called from ffecom_gen_sfuncdef_. */
12885 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12887 ffecom_pop_calltemps ()
12891 assert (ffecom_pending_calls_
> 0);
12893 if (--ffecom_pending_calls_
== 0)
12894 for (temp
= ffecom_latest_temp_
; temp
!= NULL
; temp
= temp
->next
)
12895 if (temp
->auto_pop
)
12896 temp
->in_use
= FALSE
;
12900 /* Mark latest temp with given tree as no longer in use. */
12902 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12904 ffecom_pop_tempvar (tree t
)
12908 for (temp
= ffecom_latest_temp_
; temp
!= NULL
; temp
= temp
->next
)
12909 if (temp
->in_use
&& (temp
->t
== t
))
12911 assert (!temp
->auto_pop
);
12912 temp
->in_use
= FALSE
;
12916 assert (temp
->t
!= t
);
12918 assert ("couldn't ffecom_pop_tempvar!" != NULL
);
12922 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12925 ffebld expr; // FFE expression.
12926 tree = ffecom_ptr_to_expr(expr);
12928 Like ffecom_expr, but sticks address-of in front of most things. */
12930 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12932 ffecom_ptr_to_expr (ffebld expr
)
12935 ffeinfoBasictype bt
;
12936 ffeinfoKindtype kt
;
12939 assert (expr
!= NULL
);
12941 switch (ffebld_op (expr
))
12943 case FFEBLD_opSYMTER
:
12944 s
= ffebld_symter (expr
);
12945 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
12949 ix
= ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr
));
12950 assert (ix
!= FFECOM_gfrt
);
12951 if ((item
= ffecom_gfrt_
[ix
]) == NULL_TREE
)
12953 ffecom_make_gfrt_ (ix
);
12954 item
= ffecom_gfrt_
[ix
];
12959 item
= ffesymbol_hook (s
).decl_tree
;
12960 if (item
== NULL_TREE
)
12962 s
= ffecom_sym_transform_ (s
);
12963 item
= ffesymbol_hook (s
).decl_tree
;
12966 assert (item
!= NULL
);
12967 if (item
== error_mark_node
)
12969 if (!ffesymbol_hook (s
).addr
)
12970 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12974 case FFEBLD_opARRAYREF
:
12976 ffebld dims
[FFECOM_dimensionsMAX
];
12980 item
= ffecom_ptr_to_expr (ffebld_left (expr
));
12982 if (item
== error_mark_node
)
12985 if ((ffeinfo_where (ffebld_info (expr
)) == FFEINFO_whereFLEETING
)
12986 && !mark_addressable (item
))
12987 return error_mark_node
; /* Make sure non-const ref is to
12990 /* Build up ARRAY_REFs in reverse order (since we're column major
12991 here in Fortran land). */
12993 for (i
= 0, expr
= ffebld_right (expr
);
12995 expr
= ffebld_trail (expr
))
12996 dims
[i
++] = ffebld_head (expr
);
12998 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
13000 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
13003 = ffecom_2 (PLUS_EXPR
,
13004 build_pointer_type (TREE_TYPE (array
)),
13006 size_binop (MULT_EXPR
,
13007 size_in_bytes (TREE_TYPE (array
)),
13008 size_binop (MINUS_EXPR
,
13009 ffecom_expr (dims
[i
]),
13010 TYPE_MIN_VALUE (TYPE_DOMAIN (array
)))));
13015 case FFEBLD_opCONTER
:
13017 bt
= ffeinfo_basictype (ffebld_info (expr
));
13018 kt
= ffeinfo_kindtype (ffebld_info (expr
));
13020 item
= ffecom_constantunion (&ffebld_constant_union
13021 (ffebld_conter (expr
)), bt
, kt
,
13022 ffecom_tree_type
[bt
][kt
]);
13023 if (item
== error_mark_node
)
13024 return error_mark_node
;
13025 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
13030 return error_mark_node
;
13033 assert (ffecom_pending_calls_
> 0);
13035 bt
= ffeinfo_basictype (ffebld_info (expr
));
13036 kt
= ffeinfo_kindtype (ffebld_info (expr
));
13038 item
= ffecom_expr (expr
);
13039 if (item
== error_mark_node
)
13040 return error_mark_node
;
13042 /* The back end currently optimizes a bit too zealously for us, in that
13043 we fail JCB001 if the following block of code is omitted. It checks
13044 to see if the transformed expression is a symbol or array reference,
13045 and encloses it in a SAVE_EXPR if that is the case. */
13048 if ((TREE_CODE (item
) == VAR_DECL
)
13049 || (TREE_CODE (item
) == PARM_DECL
)
13050 || (TREE_CODE (item
) == RESULT_DECL
)
13051 || (TREE_CODE (item
) == INDIRECT_REF
)
13052 || (TREE_CODE (item
) == ARRAY_REF
)
13053 || (TREE_CODE (item
) == COMPONENT_REF
)
13055 || (TREE_CODE (item
) == OFFSET_REF
)
13057 || (TREE_CODE (item
) == BUFFER_REF
)
13058 || (TREE_CODE (item
) == REALPART_EXPR
)
13059 || (TREE_CODE (item
) == IMAGPART_EXPR
))
13061 item
= ffecom_save_tree (item
);
13064 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
13069 assert ("fall-through error" == NULL
);
13070 return error_mark_node
;
13074 /* Prepare to make call-arg temps.
13076 Call this in pairs with pop_calltemps around calls to
13077 ffecom_arg_ptr_to_expr if the latter might use temporaries. */
13079 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13081 ffecom_push_calltemps ()
13083 ffecom_pending_calls_
++;
13087 /* Obtain a temp var with given data type.
13089 Returns a VAR_DECL tree of a currently (that is, at the current
13090 statement being compiled) not in use and having the given data type,
13091 making a new one if necessary. size is FFETARGET_charactersizeNONE
13092 for a non-CHARACTER type or >= 0 for a CHARACTER type. elements is
13093 -1 for a scalar or > 0 for an array of type. auto_pop is TRUE if
13094 ffecom_pop_tempvar won't be called, meaning temp will be freed
13095 when #pending calls goes to zero. */
13097 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13099 ffecom_push_tempvar (tree type
, ffetargetCharacterSize size
, int elements
,
13105 static int mynumber
;
13107 assert (!auto_pop
|| (ffecom_pending_calls_
> 0));
13109 if (type
== error_mark_node
)
13110 return error_mark_node
;
13112 for (temp
= ffecom_latest_temp_
; temp
!= NULL
; temp
= temp
->next
)
13115 || (temp
->type
!= type
)
13116 || (temp
->size
!= size
)
13117 || (temp
->elements
!= elements
)
13118 || (DECL_CONTEXT (temp
->t
) != current_function_decl
))
13121 temp
->in_use
= TRUE
;
13122 temp
->auto_pop
= auto_pop
;
13126 /* Create a new temp. */
13128 yes
= suspend_momentary ();
13130 if (size
!= FFETARGET_charactersizeNONE
)
13131 type
= build_array_type (type
,
13132 build_range_type (ffecom_f2c_ftnlen_type_node
,
13133 ffecom_f2c_ftnlen_one_node
,
13134 build_int_2 (size
, 0)));
13135 if (elements
!= -1)
13136 type
= build_array_type (type
,
13137 build_range_type (integer_type_node
,
13139 build_int_2 (elements
- 1,
13141 t
= build_decl (VAR_DECL
,
13142 ffecom_get_invented_identifier ("__g77_expr_%d", NULL
,
13145 { /* ~~~~ kludge alert here!!! else temp gets reused outside
13146 a compound-statement sequence.... */
13147 extern tree sequence_rtl_expr
;
13148 tree back_end_bug
= sequence_rtl_expr
;
13150 sequence_rtl_expr
= NULL_TREE
;
13152 t
= start_decl (t
, FALSE
);
13153 finish_decl (t
, NULL_TREE
, FALSE
);
13155 sequence_rtl_expr
= back_end_bug
;
13158 resume_momentary (yes
);
13160 temp
= malloc_new_kp (ffe_pool_program_unit (), "ffecomTemp_",
13163 temp
->next
= ffecom_latest_temp_
;
13167 temp
->elements
= elements
;
13168 temp
->in_use
= TRUE
;
13169 temp
->auto_pop
= auto_pop
;
13171 ffecom_latest_temp_
= temp
;
13177 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13179 tree rtn; // NULL_TREE means use expand_null_return()
13180 ffebld expr; // NULL if no alt return expr to RETURN stmt
13181 rtn = ffecom_return_expr(expr);
13183 Based on the program unit type and other info (like return function
13184 type, return master function type when alternate ENTRY points,
13185 whether subroutine has any alternate RETURN points, etc), returns the
13186 appropriate expression to be returned to the caller, or NULL_TREE
13187 meaning no return value or the caller expects it to be returned somewhere
13188 else (which is handled by other parts of this module). */
13190 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13192 ffecom_return_expr (ffebld expr
)
13196 switch (ffecom_primary_entry_kind_
)
13198 case FFEINFO_kindPROGRAM
:
13199 case FFEINFO_kindBLOCKDATA
:
13203 case FFEINFO_kindSUBROUTINE
:
13204 if (!ffecom_is_altreturning_
)
13205 rtn
= NULL_TREE
; /* No alt returns, never an expr. */
13206 else if (expr
== NULL
)
13207 rtn
= integer_zero_node
;
13209 rtn
= ffecom_expr (expr
);
13212 case FFEINFO_kindFUNCTION
:
13213 if ((ffecom_multi_retval_
!= NULL_TREE
)
13214 || (ffesymbol_basictype (ffecom_primary_entry_
)
13215 == FFEINFO_basictypeCHARACTER
)
13216 || ((ffesymbol_basictype (ffecom_primary_entry_
)
13217 == FFEINFO_basictypeCOMPLEX
)
13218 && (ffecom_num_entrypoints_
== 0)
13219 && ffesymbol_is_f2c (ffecom_primary_entry_
)))
13220 { /* Value is returned by direct assignment
13221 into (implicit) dummy. */
13225 rtn
= ffecom_func_result_
;
13227 /* Spurious error if RETURN happens before first reference! So elide
13228 this code. In particular, for debugging registry, rtn should always
13229 be non-null after all, but TREE_USED won't be set until we encounter
13230 a reference in the code. Perfectly okay (but weird) code that,
13231 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13232 this diagnostic for no reason. Have people use -O -Wuninitialized
13233 and leave it to the back end to find obviously weird cases. */
13235 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13236 situation; if the return value has never been referenced, it won't
13237 have a tree under 2pass mode. */
13238 if ((rtn
== NULL_TREE
)
13239 || !TREE_USED (rtn
))
13241 ffebad_start (FFEBAD_RETURN_VALUE_UNSET
);
13242 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_
),
13243 ffesymbol_where_column (ffecom_primary_entry_
));
13244 ffebad_string (ffesymbol_text (ffesymbol_funcresult
13245 (ffecom_primary_entry_
)));
13252 assert ("bad unit kind" == NULL
);
13253 case FFEINFO_kindANY
:
13254 rtn
= error_mark_node
;
13262 /* Do save_expr only if tree is not error_mark_node. */
13264 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13265 tree
ffecom_save_tree (tree t
)
13267 return save_expr (t
);
13271 /* Public entry point for front end to access start_decl. */
13273 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13275 ffecom_start_decl (tree decl
, bool is_initialized
)
13277 DECL_INITIAL (decl
) = is_initialized
? error_mark_node
: NULL_TREE
;
13278 return start_decl (decl
, FALSE
);
13282 /* ffecom_sym_commit -- Symbol's state being committed to reality
13285 ffecom_sym_commit(s);
13287 Does whatever the backend needs when a symbol is committed after having
13288 been backtrackable for a period of time. */
13290 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13292 ffecom_sym_commit (ffesymbol s UNUSED
)
13294 assert (!ffesymbol_retractable ());
13298 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13300 ffecom_sym_end_transition();
13302 Does backend-specific stuff and also calls ffest_sym_end_transition
13303 to do the necessary FFE stuff.
13305 Backtracking is never enabled when this fn is called, so don't worry
13309 ffecom_sym_end_transition (ffesymbol s
)
13313 assert (!ffesymbol_retractable ());
13315 s
= ffest_sym_end_transition (s
);
13317 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13318 if ((ffesymbol_kind (s
) == FFEINFO_kindBLOCKDATA
)
13319 && (ffesymbol_where (s
) == FFEINFO_whereGLOBAL
))
13321 ffecom_list_blockdata_
13322 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
13323 FFEINTRIN_specNONE
,
13324 FFEINTRIN_impNONE
),
13325 ffecom_list_blockdata_
);
13329 /* This is where we finally notice that a symbol has partial initialization
13330 and finalize it. */
13332 if (ffesymbol_accretion (s
) != NULL
)
13334 assert (ffesymbol_init (s
) == NULL
);
13335 ffecom_notify_init_symbol (s
);
13337 else if (((st
= ffesymbol_storage (s
)) != NULL
)
13338 && ((st
= ffestorag_parent (st
)) != NULL
)
13339 && (ffestorag_accretion (st
) != NULL
))
13341 assert (ffestorag_init (st
) == NULL
);
13342 ffecom_notify_init_storage (st
);
13345 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13346 if ((ffesymbol_kind (s
) == FFEINFO_kindCOMMON
)
13347 && (ffesymbol_where (s
) == FFEINFO_whereLOCAL
)
13348 && (ffesymbol_storage (s
) != NULL
))
13350 ffecom_list_common_
13351 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
13352 FFEINTRIN_specNONE
,
13353 FFEINTRIN_impNONE
),
13354 ffecom_list_common_
);
13361 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13363 ffecom_sym_exec_transition();
13365 Does backend-specific stuff and also calls ffest_sym_exec_transition
13366 to do the necessary FFE stuff.
13368 See the long-winded description in ffecom_sym_learned for info
13369 on handling the situation where backtracking is inhibited. */
13372 ffecom_sym_exec_transition (ffesymbol s
)
13374 s
= ffest_sym_exec_transition (s
);
13379 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13382 s = ffecom_sym_learned(s);
13384 Called when a new symbol is seen after the exec transition or when more
13385 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
13386 it arrives here is that all its latest info is updated already, so its
13387 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13388 field filled in if its gone through here or exec_transition first, and
13391 The backend probably wants to check ffesymbol_retractable() to see if
13392 backtracking is in effect. If so, the FFE's changes to the symbol may
13393 be retracted (undone) or committed (ratified), at which time the
13394 appropriate ffecom_sym_retract or _commit function will be called
13397 If the backend has its own backtracking mechanism, great, use it so that
13398 committal is a simple operation. Though it doesn't make much difference,
13399 I suppose: the reason for tentative symbol evolution in the FFE is to
13400 enable error detection in weird incorrect statements early and to disable
13401 incorrect error detection on a correct statement. The backend is not
13402 likely to introduce any information that'll get involved in these
13403 considerations, so it is probably just fine that the implementation
13404 model for this fn and for _exec_transition is to not do anything
13405 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13406 and instead wait until ffecom_sym_commit is called (which it never
13407 will be as long as we're using ambiguity-detecting statement analysis in
13408 the FFE, which we are initially to shake out the code, but don't depend
13409 on this), otherwise go ahead and do whatever is needed.
13411 In essence, then, when this fn and _exec_transition get called while
13412 backtracking is enabled, a general mechanism would be to flag which (or
13413 both) of these were called (and in what order? neat question as to what
13414 might happen that I'm too lame to think through right now) and then when
13415 _commit is called reproduce the original calling sequence, if any, for
13416 the two fns (at which point backtracking will, of course, be disabled). */
13419 ffecom_sym_learned (ffesymbol s
)
13421 ffestorag_exec_layout (s
);
13426 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13429 ffecom_sym_retract(s);
13431 Does whatever the backend needs when a symbol is retracted after having
13432 been backtrackable for a period of time. */
13434 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13436 ffecom_sym_retract (ffesymbol s UNUSED
)
13438 assert (!ffesymbol_retractable ());
13440 #if 0 /* GCC doesn't commit any backtrackable sins,
13441 so nothing needed here. */
13442 switch (ffesymbol_hook (s
).state
)
13444 case 0: /* nothing happened yet. */
13447 case 1: /* exec transition happened. */
13450 case 2: /* learned happened. */
13453 case 3: /* learned then exec. */
13456 case 4: /* exec then learned. */
13460 assert ("bad hook state" == NULL
);
13467 /* Create temporary gcc label. */
13469 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13471 ffecom_temp_label ()
13474 static int mynumber
= 0;
13476 glabel
= build_decl (LABEL_DECL
,
13477 ffecom_get_invented_identifier ("__g77_label_%d",
13481 DECL_CONTEXT (glabel
) = current_function_decl
;
13482 DECL_MODE (glabel
) = VOIDmode
;
13488 /* Return an expression that is usable as an arg in a conditional context
13489 (IF, DO WHILE, .NOT., and so on).
13491 Use the one provided for the back end as of >2.6.0. */
13493 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13495 ffecom_truth_value (tree expr
)
13497 return truthvalue_conversion (expr
);
13501 /* Return the inversion of a truth value (the inversion of what
13502 ffecom_truth_value builds).
13504 Apparently invert_truthvalue, which is properly in the back end, is
13505 enough for now, so just use it. */
13507 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13509 ffecom_truth_value_invert (tree expr
)
13511 return invert_truthvalue (ffecom_truth_value (expr
));
13515 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13517 If the PARM_DECL already exists, return it, else create it. It's an
13518 integer_type_node argument for the master function that implements a
13519 subroutine or function with more than one entrypoint and is bound at
13520 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13521 first ENTRY statement, and so on). */
13523 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13525 ffecom_which_entrypoint_decl ()
13527 assert (ffecom_which_entrypoint_decl_
!= NULL_TREE
);
13529 return ffecom_which_entrypoint_decl_
;
13534 /* The following sections consists of private and public functions
13535 that have the same names and perform roughly the same functions
13536 as counterparts in the C front end. Changes in the C front end
13537 might affect how things should be done here. Only functions
13538 needed by the back end should be public here; the rest should
13539 be private (static in the C sense). Functions needed by other
13540 g77 front-end modules should be accessed by them via public
13541 ffecom_* names, which should themselves call private versions
13542 in this section so the private versions are easy to recognize
13543 when upgrading to a new gcc and finding interesting changes
13546 Functions named after rule "foo:" in c-parse.y are named
13547 "bison_rule_foo_" so they are easy to find. */
13549 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13552 bison_rule_compstmt_ ()
13554 emit_line_note (input_filename
, lineno
);
13555 expand_end_bindings (getdecls (), 1, 1);
13556 poplevel (1, 1, 0);
13561 bison_rule_pushlevel_ ()
13563 emit_line_note (input_filename
, lineno
);
13565 clear_last_expr ();
13567 expand_start_bindings (0);
13570 /* Return a definition for a builtin function named NAME and whose data type
13571 is TYPE. TYPE should be a function type with argument types.
13572 FUNCTION_CODE tells later passes how to compile calls to this function.
13573 See tree.h for its possible values.
13575 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13576 the name to be called if we can't opencode the function. */
13579 builtin_function (char *name
, tree type
,
13580 enum built_in_function function_code
, char *library_name
)
13582 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
13583 DECL_EXTERNAL (decl
) = 1;
13584 TREE_PUBLIC (decl
) = 1;
13586 DECL_ASSEMBLER_NAME (decl
) = get_identifier (library_name
);
13587 make_decl_rtl (decl
, NULL_PTR
, 1);
13589 if (function_code
!= NOT_BUILT_IN
)
13591 DECL_BUILT_IN (decl
) = 1;
13592 DECL_FUNCTION_CODE (decl
) = function_code
;
13598 /* Handle when a new declaration NEWDECL
13599 has the same name as an old one OLDDECL
13600 in the same binding contour.
13601 Prints an error message if appropriate.
13603 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13604 Otherwise, return 0. */
13607 duplicate_decls (tree newdecl
, tree olddecl
)
13609 int types_match
= 1;
13610 int new_is_definition
= (TREE_CODE (newdecl
) == FUNCTION_DECL
13611 && DECL_INITIAL (newdecl
) != 0);
13612 tree oldtype
= TREE_TYPE (olddecl
);
13613 tree newtype
= TREE_TYPE (newdecl
);
13615 if (olddecl
== newdecl
)
13618 if (TREE_CODE (newtype
) == ERROR_MARK
13619 || TREE_CODE (oldtype
) == ERROR_MARK
)
13622 /* New decl is completely inconsistent with the old one =>
13623 tell caller to replace the old one.
13624 This is always an error except in the case of shadowing a builtin. */
13625 if (TREE_CODE (olddecl
) != TREE_CODE (newdecl
))
13628 /* For real parm decl following a forward decl,
13629 return 1 so old decl will be reused. */
13630 if (types_match
&& TREE_CODE (newdecl
) == PARM_DECL
13631 && TREE_ASM_WRITTEN (olddecl
) && ! TREE_ASM_WRITTEN (newdecl
))
13634 /* The new declaration is the same kind of object as the old one.
13635 The declarations may partially match. Print warnings if they don't
13636 match enough. Ultimately, copy most of the information from the new
13637 decl to the old one, and keep using the old one. */
13639 if (TREE_CODE (olddecl
) == FUNCTION_DECL
13640 && DECL_BUILT_IN (olddecl
))
13642 /* A function declaration for a built-in function. */
13643 if (!TREE_PUBLIC (newdecl
))
13645 else if (!types_match
)
13647 /* Accept the return type of the new declaration if same modes. */
13648 tree oldreturntype
= TREE_TYPE (TREE_TYPE (olddecl
));
13649 tree newreturntype
= TREE_TYPE (TREE_TYPE (newdecl
));
13651 /* Make sure we put the new type in the same obstack as the old ones.
13652 If the old types are not both in the same obstack, use the
13654 if (TYPE_OBSTACK (oldtype
) == TYPE_OBSTACK (newtype
))
13655 push_obstacks (TYPE_OBSTACK (oldtype
), TYPE_OBSTACK (oldtype
));
13658 push_obstacks_nochange ();
13659 end_temporary_allocation ();
13662 if (TYPE_MODE (oldreturntype
) == TYPE_MODE (newreturntype
))
13664 /* Function types may be shared, so we can't just modify
13665 the return type of olddecl's function type. */
13667 = build_function_type (newreturntype
,
13668 TYPE_ARG_TYPES (TREE_TYPE (olddecl
)));
13672 TREE_TYPE (olddecl
) = newtype
;
13680 else if (TREE_CODE (olddecl
) == FUNCTION_DECL
13681 && DECL_SOURCE_LINE (olddecl
) == 0)
13683 /* A function declaration for a predeclared function
13684 that isn't actually built in. */
13685 if (!TREE_PUBLIC (newdecl
))
13687 else if (!types_match
)
13689 /* If the types don't match, preserve volatility indication.
13690 Later on, we will discard everything else about the
13691 default declaration. */
13692 TREE_THIS_VOLATILE (newdecl
) |= TREE_THIS_VOLATILE (olddecl
);
13696 /* Copy all the DECL_... slots specified in the new decl
13697 except for any that we copy here from the old type.
13699 Past this point, we don't change OLDTYPE and NEWTYPE
13700 even if we change the types of NEWDECL and OLDDECL. */
13704 /* Make sure we put the new type in the same obstack as the old ones.
13705 If the old types are not both in the same obstack, use the permanent
13707 if (TYPE_OBSTACK (oldtype
) == TYPE_OBSTACK (newtype
))
13708 push_obstacks (TYPE_OBSTACK (oldtype
), TYPE_OBSTACK (oldtype
));
13711 push_obstacks_nochange ();
13712 end_temporary_allocation ();
13715 /* Merge the data types specified in the two decls. */
13716 if (TREE_CODE (newdecl
) != FUNCTION_DECL
|| !DECL_BUILT_IN (olddecl
))
13717 TREE_TYPE (newdecl
)
13718 = TREE_TYPE (olddecl
)
13719 = TREE_TYPE (newdecl
);
13721 /* Lay the type out, unless already done. */
13722 if (oldtype
!= TREE_TYPE (newdecl
))
13724 if (TREE_TYPE (newdecl
) != error_mark_node
)
13725 layout_type (TREE_TYPE (newdecl
));
13726 if (TREE_CODE (newdecl
) != FUNCTION_DECL
13727 && TREE_CODE (newdecl
) != TYPE_DECL
13728 && TREE_CODE (newdecl
) != CONST_DECL
)
13729 layout_decl (newdecl
, 0);
13733 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13734 DECL_SIZE (newdecl
) = DECL_SIZE (olddecl
);
13735 if (TREE_CODE (olddecl
) != FUNCTION_DECL
)
13736 if (DECL_ALIGN (olddecl
) > DECL_ALIGN (newdecl
))
13737 DECL_ALIGN (newdecl
) = DECL_ALIGN (olddecl
);
13740 /* Keep the old rtl since we can safely use it. */
13741 DECL_RTL (newdecl
) = DECL_RTL (olddecl
);
13743 /* Merge the type qualifiers. */
13744 if (DECL_BUILT_IN_NONANSI (olddecl
) && TREE_THIS_VOLATILE (olddecl
)
13745 && !TREE_THIS_VOLATILE (newdecl
))
13746 TREE_THIS_VOLATILE (olddecl
) = 0;
13747 if (TREE_READONLY (newdecl
))
13748 TREE_READONLY (olddecl
) = 1;
13749 if (TREE_THIS_VOLATILE (newdecl
))
13751 TREE_THIS_VOLATILE (olddecl
) = 1;
13752 if (TREE_CODE (newdecl
) == VAR_DECL
)
13753 make_var_volatile (newdecl
);
13756 /* Keep source location of definition rather than declaration.
13757 Likewise, keep decl at outer scope. */
13758 if ((DECL_INITIAL (newdecl
) == 0 && DECL_INITIAL (olddecl
) != 0)
13759 || (DECL_CONTEXT (newdecl
) != 0 && DECL_CONTEXT (olddecl
) == 0))
13761 DECL_SOURCE_LINE (newdecl
) = DECL_SOURCE_LINE (olddecl
);
13762 DECL_SOURCE_FILE (newdecl
) = DECL_SOURCE_FILE (olddecl
);
13764 if (DECL_CONTEXT (olddecl
) == 0
13765 && TREE_CODE (newdecl
) != FUNCTION_DECL
)
13766 DECL_CONTEXT (newdecl
) = 0;
13769 /* Merge the unused-warning information. */
13770 if (DECL_IN_SYSTEM_HEADER (olddecl
))
13771 DECL_IN_SYSTEM_HEADER (newdecl
) = 1;
13772 else if (DECL_IN_SYSTEM_HEADER (newdecl
))
13773 DECL_IN_SYSTEM_HEADER (olddecl
) = 1;
13775 /* Merge the initialization information. */
13776 if (DECL_INITIAL (newdecl
) == 0)
13777 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13779 /* Merge the section attribute.
13780 We want to issue an error if the sections conflict but that must be
13781 done later in decl_attributes since we are called before attributes
13783 if (DECL_SECTION_NAME (newdecl
) == NULL_TREE
)
13784 DECL_SECTION_NAME (newdecl
) = DECL_SECTION_NAME (olddecl
);
13787 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13789 DECL_STATIC_CONSTRUCTOR(newdecl
) |= DECL_STATIC_CONSTRUCTOR(olddecl
);
13790 DECL_STATIC_DESTRUCTOR (newdecl
) |= DECL_STATIC_DESTRUCTOR (olddecl
);
13796 /* If cannot merge, then use the new type and qualifiers,
13797 and don't preserve the old rtl. */
13800 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13801 TREE_READONLY (olddecl
) = TREE_READONLY (newdecl
);
13802 TREE_THIS_VOLATILE (olddecl
) = TREE_THIS_VOLATILE (newdecl
);
13803 TREE_SIDE_EFFECTS (olddecl
) = TREE_SIDE_EFFECTS (newdecl
);
13806 /* Merge the storage class information. */
13807 /* For functions, static overrides non-static. */
13808 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13810 TREE_PUBLIC (newdecl
) &= TREE_PUBLIC (olddecl
);
13811 /* This is since we don't automatically
13812 copy the attributes of NEWDECL into OLDDECL. */
13813 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13814 /* If this clears `static', clear it in the identifier too. */
13815 if (! TREE_PUBLIC (olddecl
))
13816 TREE_PUBLIC (DECL_NAME (olddecl
)) = 0;
13818 if (DECL_EXTERNAL (newdecl
))
13820 TREE_STATIC (newdecl
) = TREE_STATIC (olddecl
);
13821 DECL_EXTERNAL (newdecl
) = DECL_EXTERNAL (olddecl
);
13822 /* An extern decl does not override previous storage class. */
13823 TREE_PUBLIC (newdecl
) = TREE_PUBLIC (olddecl
);
13827 TREE_STATIC (olddecl
) = TREE_STATIC (newdecl
);
13828 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13831 /* If either decl says `inline', this fn is inline,
13832 unless its definition was passed already. */
13833 if (DECL_INLINE (newdecl
) && DECL_INITIAL (olddecl
) == 0)
13834 DECL_INLINE (olddecl
) = 1;
13835 DECL_INLINE (newdecl
) = DECL_INLINE (olddecl
);
13837 /* Get rid of any built-in function if new arg types don't match it
13838 or if we have a function definition. */
13839 if (TREE_CODE (newdecl
) == FUNCTION_DECL
13840 && DECL_BUILT_IN (olddecl
)
13841 && (!types_match
|| new_is_definition
))
13843 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13844 DECL_BUILT_IN (olddecl
) = 0;
13847 /* If redeclaring a builtin function, and not a definition,
13849 Also preserve various other info from the definition. */
13850 if (TREE_CODE (newdecl
) == FUNCTION_DECL
&& !new_is_definition
)
13852 if (DECL_BUILT_IN (olddecl
))
13854 DECL_BUILT_IN (newdecl
) = 1;
13855 DECL_FUNCTION_CODE (newdecl
) = DECL_FUNCTION_CODE (olddecl
);
13858 DECL_FRAME_SIZE (newdecl
) = DECL_FRAME_SIZE (olddecl
);
13860 DECL_RESULT (newdecl
) = DECL_RESULT (olddecl
);
13861 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13862 DECL_SAVED_INSNS (newdecl
) = DECL_SAVED_INSNS (olddecl
);
13863 DECL_ARGUMENTS (newdecl
) = DECL_ARGUMENTS (olddecl
);
13866 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13867 But preserve olddecl's DECL_UID. */
13869 register unsigned olddecl_uid
= DECL_UID (olddecl
);
13871 bcopy ((char *) newdecl
+ sizeof (struct tree_common
),
13872 (char *) olddecl
+ sizeof (struct tree_common
),
13873 sizeof (struct tree_decl
) - sizeof (struct tree_common
));
13874 DECL_UID (olddecl
) = olddecl_uid
;
13880 /* Finish processing of a declaration;
13881 install its initial value.
13882 If the length of an array type is not known before,
13883 it must be determined now, from the initial value, or it is an error. */
13886 finish_decl (tree decl
, tree init
, bool is_top_level
)
13888 register tree type
= TREE_TYPE (decl
);
13889 int was_incomplete
= (DECL_SIZE (decl
) == 0);
13890 int temporary
= allocation_temporary_p ();
13891 bool at_top_level
= (current_binding_level
== global_binding_level
);
13892 bool top_level
= is_top_level
|| at_top_level
;
13894 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13896 assert (!is_top_level
|| !at_top_level
);
13898 if (TREE_CODE (decl
) == PARM_DECL
)
13899 assert (init
== NULL_TREE
);
13900 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13901 overlaps DECL_ARG_TYPE. */
13902 else if (init
== NULL_TREE
)
13903 assert (DECL_INITIAL (decl
) == NULL_TREE
);
13905 assert (DECL_INITIAL (decl
) == error_mark_node
);
13907 if (init
!= NULL_TREE
)
13909 if (TREE_CODE (decl
) != TYPE_DECL
)
13910 DECL_INITIAL (decl
) = init
;
13913 /* typedef foo = bar; store the type of bar as the type of foo. */
13914 TREE_TYPE (decl
) = TREE_TYPE (init
);
13915 DECL_INITIAL (decl
) = init
= 0;
13919 /* Pop back to the obstack that is current for this binding level. This is
13920 because MAXINDEX, rtl, etc. to be made below must go in the permanent
13921 obstack. But don't discard the temporary data yet. */
13924 /* Deduce size of array from initialization, if not already known */
13926 if (TREE_CODE (type
) == ARRAY_TYPE
13927 && TYPE_DOMAIN (type
) == 0
13928 && TREE_CODE (decl
) != TYPE_DECL
)
13930 assert (top_level
);
13931 assert (was_incomplete
);
13933 layout_decl (decl
, 0);
13936 if (TREE_CODE (decl
) == VAR_DECL
)
13938 if (DECL_SIZE (decl
) == NULL_TREE
13939 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
13940 layout_decl (decl
, 0);
13942 if (DECL_SIZE (decl
) == NULL_TREE
13943 && (TREE_STATIC (decl
)
13945 /* A static variable with an incomplete type is an error if it is
13946 initialized. Also if it is not file scope. Otherwise, let it
13947 through, but if it is not `extern' then it may cause an error
13949 (DECL_INITIAL (decl
) != 0 || DECL_CONTEXT (decl
) != 0)
13951 /* An automatic variable with an incomplete type is an error. */
13952 !DECL_EXTERNAL (decl
)))
13954 assert ("storage size not known" == NULL
);
13958 if ((DECL_EXTERNAL (decl
) || TREE_STATIC (decl
))
13959 && (DECL_SIZE (decl
) != 0)
13960 && (TREE_CODE (DECL_SIZE (decl
)) != INTEGER_CST
))
13962 assert ("storage size not constant" == NULL
);
13967 /* Output the assembler code and/or RTL code for variables and functions,
13968 unless the type is an undefined structure or union. If not, it will get
13969 done when the type is completed. */
13971 if (TREE_CODE (decl
) == VAR_DECL
|| TREE_CODE (decl
) == FUNCTION_DECL
)
13973 rest_of_decl_compilation (decl
, NULL
,
13974 DECL_CONTEXT (decl
) == 0,
13977 if (DECL_CONTEXT (decl
) != 0)
13979 /* Recompute the RTL of a local array now if it used to be an
13980 incomplete type. */
13982 && !TREE_STATIC (decl
) && !DECL_EXTERNAL (decl
))
13984 /* If we used it already as memory, it must stay in memory. */
13985 TREE_ADDRESSABLE (decl
) = TREE_USED (decl
);
13986 /* If it's still incomplete now, no init will save it. */
13987 if (DECL_SIZE (decl
) == 0)
13988 DECL_INITIAL (decl
) = 0;
13989 expand_decl (decl
);
13991 /* Compute and store the initial value. */
13992 if (TREE_CODE (decl
) != FUNCTION_DECL
)
13993 expand_decl_init (decl
);
13996 else if (TREE_CODE (decl
) == TYPE_DECL
)
13998 rest_of_decl_compilation (decl
, NULL_PTR
,
13999 DECL_CONTEXT (decl
) == 0,
14003 /* This test used to include TREE_PERMANENT, however, we have the same
14004 problem with initializers at the function level. Such initializers get
14005 saved until the end of the function on the momentary_obstack. */
14006 if (!(TREE_CODE (decl
) == FUNCTION_DECL
&& DECL_INLINE (decl
))
14008 /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
14010 && TREE_CODE (decl
) != PARM_DECL
)
14012 /* We need to remember that this array HAD an initialization, but
14013 discard the actual temporary nodes, since we can't have a permanent
14014 node keep pointing to them. */
14015 /* We make an exception for inline functions, since it's normal for a
14016 local extern redeclaration of an inline function to have a copy of
14017 the top-level decl's DECL_INLINE. */
14018 if ((DECL_INITIAL (decl
) != 0)
14019 && (DECL_INITIAL (decl
) != error_mark_node
))
14021 /* If this is a const variable, then preserve the
14022 initializer instead of discarding it so that we can optimize
14023 references to it. */
14024 /* This test used to include TREE_STATIC, but this won't be set
14025 for function level initializers. */
14026 if (TREE_READONLY (decl
))
14028 preserve_initializer ();
14029 /* Hack? Set the permanent bit for something that is
14030 permanent, but not on the permenent obstack, so as to
14031 convince output_constant_def to make its rtl on the
14032 permanent obstack. */
14033 TREE_PERMANENT (DECL_INITIAL (decl
)) = 1;
14035 /* The initializer and DECL must have the same (or equivalent
14036 types), but if the initializer is a STRING_CST, its type
14037 might not be on the right obstack, so copy the type
14039 TREE_TYPE (DECL_INITIAL (decl
)) = type
;
14042 DECL_INITIAL (decl
) = error_mark_node
;
14046 /* If requested, warn about definitions of large data objects. */
14048 if (warn_larger_than
14049 && (TREE_CODE (decl
) == VAR_DECL
|| TREE_CODE (decl
) == PARM_DECL
)
14050 && !DECL_EXTERNAL (decl
))
14052 register tree decl_size
= DECL_SIZE (decl
);
14054 if (decl_size
&& TREE_CODE (decl_size
) == INTEGER_CST
)
14056 unsigned units
= TREE_INT_CST_LOW (decl_size
) / BITS_PER_UNIT
;
14058 if (units
> larger_than_size
)
14059 warning_with_decl (decl
, "size of `%s' is %u bytes", units
);
14063 /* If we have gone back from temporary to permanent allocation, actually
14064 free the temporary space that we no longer need. */
14065 if (temporary
&& !allocation_temporary_p ())
14066 permanent_allocation (0);
14068 /* At the end of a declaration, throw away any variable type sizes of types
14069 defined inside that declaration. There is no use computing them in the
14070 following function definition. */
14071 if (current_binding_level
== global_binding_level
)
14072 get_pending_sizes ();
14075 /* Finish up a function declaration and compile that function
14076 all the way to assembler language output. The free the storage
14077 for the function definition.
14079 This is called after parsing the body of the function definition.
14081 NESTED is nonzero if the function being finished is nested in another. */
14084 finish_function (int nested
)
14086 register tree fndecl
= current_function_decl
;
14088 assert (fndecl
!= NULL_TREE
);
14090 assert (DECL_CONTEXT (fndecl
) != NULL_TREE
);
14092 assert (DECL_CONTEXT (fndecl
) == NULL_TREE
);
14094 /* TREE_READONLY (fndecl) = 1;
14095 This caused &foo to be of type ptr-to-const-function
14096 which then got a warning when stored in a ptr-to-function variable. */
14098 poplevel (1, 0, 1);
14099 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
14101 /* Must mark the RESULT_DECL as being in this function. */
14103 DECL_CONTEXT (DECL_RESULT (fndecl
)) = fndecl
;
14105 /* Obey `register' declarations if `setjmp' is called in this fn. */
14106 /* Generate rtl for function exit. */
14107 expand_function_end (input_filename
, lineno
, 0);
14109 /* So we can tell if jump_optimize sets it to 1. */
14112 /* Run the optimizers and output the assembler code for this function. */
14113 rest_of_compilation (fndecl
);
14115 /* Free all the tree nodes making up this function. */
14116 /* Switch back to allocating nodes permanently until we start another
14119 permanent_allocation (1);
14121 if (DECL_SAVED_INSNS (fndecl
) == 0 && !nested
)
14123 /* Stop pointing to the local nodes about to be freed. */
14124 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14125 function definition. */
14126 /* For a nested function, this is done in pop_f_function_context. */
14127 /* If rest_of_compilation set this to 0, leave it 0. */
14128 if (DECL_INITIAL (fndecl
) != 0)
14129 DECL_INITIAL (fndecl
) = error_mark_node
;
14130 DECL_ARGUMENTS (fndecl
) = 0;
14135 /* Let the error reporting routines know that we're outside a function.
14136 For a nested function, this value is used in pop_c_function_context
14137 and then reset via pop_function_context. */
14138 ffecom_outer_function_decl_
= current_function_decl
= NULL
;
14142 /* Plug-in replacement for identifying the name of a decl and, for a
14143 function, what we call it in diagnostics. For now, "program unit"
14144 should suffice, since it's a bit of a hassle to figure out which
14145 of several kinds of things it is. Note that it could conceivably
14146 be a statement function, which probably isn't really a program unit
14147 per se, but if that comes up, it should be easy to check (being a
14148 nested function and all). */
14151 lang_printable_name (tree decl
, int v
)
14153 return IDENTIFIER_POINTER (DECL_NAME (decl
));
14156 /* g77's function to print out name of current function that caused
14161 lang_print_error_function (file
)
14164 static ffesymbol last_s
= NULL
;
14168 if (ffecom_primary_entry_
== NULL
)
14173 else if (ffecom_nested_entry_
== NULL
)
14175 s
= ffecom_primary_entry_
;
14176 switch (ffesymbol_kind (s
))
14178 case FFEINFO_kindFUNCTION
:
14182 case FFEINFO_kindSUBROUTINE
:
14183 kind
= "subroutine";
14186 case FFEINFO_kindPROGRAM
:
14190 case FFEINFO_kindBLOCKDATA
:
14191 kind
= "block-data";
14195 kind
= ffeinfo_kind_message (ffesymbol_kind (s
));
14201 s
= ffecom_nested_entry_
;
14202 kind
= "statement function";
14208 fprintf (stderr
, "%s: ", file
);
14211 fprintf (stderr
, "Outside of any program unit:\n");
14214 char *name
= ffesymbol_text (s
);
14216 fprintf (stderr
, "In %s `%s':\n", kind
, name
);
14224 /* Similar to `lookup_name' but look only at current binding level. */
14227 lookup_name_current_level (tree name
)
14231 if (current_binding_level
== global_binding_level
)
14232 return IDENTIFIER_GLOBAL_VALUE (name
);
14234 if (IDENTIFIER_LOCAL_VALUE (name
) == 0)
14237 for (t
= current_binding_level
->names
; t
; t
= TREE_CHAIN (t
))
14238 if (DECL_NAME (t
) == name
)
14244 /* Create a new `struct binding_level'. */
14246 static struct binding_level
*
14247 make_binding_level ()
14250 return (struct binding_level
*) xmalloc (sizeof (struct binding_level
));
14253 /* Save and restore the variables in this file and elsewhere
14254 that keep track of the progress of compilation of the current function.
14255 Used for nested functions. */
14259 struct f_function
*next
;
14261 tree shadowed_labels
;
14262 struct binding_level
*binding_level
;
14265 struct f_function
*f_function_chain
;
14267 /* Restore the variables used during compilation of a C function. */
14270 pop_f_function_context ()
14272 struct f_function
*p
= f_function_chain
;
14275 /* Bring back all the labels that were shadowed. */
14276 for (link
= shadowed_labels
; link
; link
= TREE_CHAIN (link
))
14277 if (DECL_NAME (TREE_VALUE (link
)) != 0)
14278 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link
)))
14279 = TREE_VALUE (link
);
14281 if (DECL_SAVED_INSNS (current_function_decl
) == 0)
14283 /* Stop pointing to the local nodes about to be freed. */
14284 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14285 function definition. */
14286 DECL_INITIAL (current_function_decl
) = error_mark_node
;
14287 DECL_ARGUMENTS (current_function_decl
) = 0;
14290 pop_function_context ();
14292 f_function_chain
= p
->next
;
14294 named_labels
= p
->named_labels
;
14295 shadowed_labels
= p
->shadowed_labels
;
14296 current_binding_level
= p
->binding_level
;
14301 /* Save and reinitialize the variables
14302 used during compilation of a C function. */
14305 push_f_function_context ()
14307 struct f_function
*p
14308 = (struct f_function
*) xmalloc (sizeof (struct f_function
));
14310 push_function_context ();
14312 p
->next
= f_function_chain
;
14313 f_function_chain
= p
;
14315 p
->named_labels
= named_labels
;
14316 p
->shadowed_labels
= shadowed_labels
;
14317 p
->binding_level
= current_binding_level
;
14321 push_parm_decl (tree parm
)
14323 int old_immediate_size_expand
= immediate_size_expand
;
14325 /* Don't try computing parm sizes now -- wait till fn is called. */
14327 immediate_size_expand
= 0;
14329 push_obstacks_nochange ();
14331 /* Fill in arg stuff. */
14333 DECL_ARG_TYPE (parm
) = TREE_TYPE (parm
);
14334 DECL_ARG_TYPE_AS_WRITTEN (parm
) = TREE_TYPE (parm
);
14335 TREE_READONLY (parm
) = 1; /* All implementation args are read-only. */
14337 parm
= pushdecl (parm
);
14339 immediate_size_expand
= old_immediate_size_expand
;
14341 finish_decl (parm
, NULL_TREE
, FALSE
);
14344 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
14347 pushdecl_top_level (x
)
14351 register struct binding_level
*b
= current_binding_level
;
14352 register tree f
= current_function_decl
;
14354 current_binding_level
= global_binding_level
;
14355 current_function_decl
= NULL_TREE
;
14357 current_binding_level
= b
;
14358 current_function_decl
= f
;
14362 /* Store the list of declarations of the current level.
14363 This is done for the parameter declarations of a function being defined,
14364 after they are modified in the light of any missing parameters. */
14370 return current_binding_level
->names
= decls
;
14373 /* Store the parameter declarations into the current function declaration.
14374 This is called after parsing the parameter declarations, before
14375 digesting the body of the function.
14377 For an old-style definition, modify the function's type
14378 to specify at least the number of arguments. */
14381 store_parm_decls (int is_main_program UNUSED
)
14383 register tree fndecl
= current_function_decl
;
14385 /* This is a chain of PARM_DECLs from old-style parm declarations. */
14386 DECL_ARGUMENTS (fndecl
) = storedecls (nreverse (getdecls ()));
14388 /* Initialize the RTL code for the function. */
14390 init_function_start (fndecl
, input_filename
, lineno
);
14392 /* Set up parameters and prepare for return, for the function. */
14394 expand_function_start (fndecl
, 0);
14398 start_decl (tree decl
, bool is_top_level
)
14401 bool at_top_level
= (current_binding_level
== global_binding_level
);
14402 bool top_level
= is_top_level
|| at_top_level
;
14404 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14406 assert (!is_top_level
|| !at_top_level
);
14408 /* The corresponding pop_obstacks is in finish_decl. */
14409 push_obstacks_nochange ();
14411 if (DECL_INITIAL (decl
) != NULL_TREE
)
14413 assert (DECL_INITIAL (decl
) == error_mark_node
);
14414 assert (!DECL_EXTERNAL (decl
));
14416 else if (top_level
)
14417 assert ((TREE_STATIC (decl
) == 1) || DECL_EXTERNAL (decl
) == 1);
14419 /* For Fortran, we by default put things in .common when possible. */
14420 DECL_COMMON (decl
) = 1;
14422 /* Add this decl to the current binding level. TEM may equal DECL or it may
14423 be a previous decl of the same name. */
14425 tem
= pushdecl_top_level (decl
);
14427 tem
= pushdecl (decl
);
14429 /* For a local variable, define the RTL now. */
14431 /* But not if this is a duplicate decl and we preserved the rtl from the
14432 previous one (which may or may not happen). */
14433 && DECL_RTL (tem
) == 0)
14435 if (TYPE_SIZE (TREE_TYPE (tem
)) != 0)
14437 else if (TREE_CODE (TREE_TYPE (tem
)) == ARRAY_TYPE
14438 && DECL_INITIAL (tem
) != 0)
14442 if (DECL_INITIAL (tem
) != NULL_TREE
)
14444 /* When parsing and digesting the initializer, use temporary storage.
14445 Do this even if we will ignore the value. */
14447 temporary_allocation ();
14453 /* Create the FUNCTION_DECL for a function definition.
14454 DECLSPECS and DECLARATOR are the parts of the declaration;
14455 they describe the function's name and the type it returns,
14456 but twisted together in a fashion that parallels the syntax of C.
14458 This function creates a binding context for the function body
14459 as well as setting up the FUNCTION_DECL in current_function_decl.
14461 Returns 1 on success. If the DECLARATOR is not suitable for a function
14462 (it defines a datum instead), we return 0, which tells
14463 yyparse to report a parse error.
14465 NESTED is nonzero for a function nested within another function. */
14468 start_function (tree name
, tree type
, int nested
, int public)
14472 int old_immediate_size_expand
= immediate_size_expand
;
14475 shadowed_labels
= 0;
14477 /* Don't expand any sizes in the return type of the function. */
14478 immediate_size_expand
= 0;
14483 assert (current_function_decl
!= NULL_TREE
);
14484 assert (DECL_CONTEXT (current_function_decl
) == NULL_TREE
);
14488 assert (current_function_decl
== NULL_TREE
);
14491 decl1
= build_decl (FUNCTION_DECL
,
14494 TREE_PUBLIC (decl1
) = public ? 1 : 0;
14496 DECL_INLINE (decl1
) = 1;
14497 TREE_STATIC (decl1
) = 1;
14498 DECL_EXTERNAL (decl1
) = 0;
14500 announce_function (decl1
);
14502 /* Make the init_value nonzero so pushdecl knows this is not tentative.
14503 error_mark_node is replaced below (in poplevel) with the BLOCK. */
14504 DECL_INITIAL (decl1
) = error_mark_node
;
14506 /* Record the decl so that the function name is defined. If we already have
14507 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
14509 current_function_decl
= pushdecl (decl1
);
14511 ffecom_outer_function_decl_
= current_function_decl
;
14515 make_function_rtl (current_function_decl
);
14517 restype
= TREE_TYPE (TREE_TYPE (current_function_decl
));
14518 DECL_RESULT (current_function_decl
)
14519 = build_decl (RESULT_DECL
, NULL_TREE
, restype
);
14522 /* Allocate further tree nodes temporarily during compilation of this
14524 temporary_allocation ();
14527 TREE_ADDRESSABLE (current_function_decl
) = 1;
14529 immediate_size_expand
= old_immediate_size_expand
;
14532 /* Here are the public functions the GNU back end needs. */
14534 /* This is used by the `assert' macro. It is provided in libgcc.a,
14535 which `cc' doesn't know how to link. Note that the C++ front-end
14536 no longer actually uses the `assert' macro (instead, it calls
14537 my_friendly_assert). But all of the back-end files still need this. */
14539 __eprintf (string
, expression
, line
, filename
)
14541 const char *string
;
14542 const char *expression
;
14544 const char *filename
;
14552 fprintf (stderr
, string
, expression
, line
, filename
);
14558 convert (type
, expr
)
14561 register tree e
= expr
;
14562 register enum tree_code code
= TREE_CODE (type
);
14564 if (type
== TREE_TYPE (e
)
14565 || TREE_CODE (e
) == ERROR_MARK
)
14567 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
14568 return fold (build1 (NOP_EXPR
, type
, e
));
14569 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
14570 || code
== ERROR_MARK
)
14571 return error_mark_node
;
14572 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
14574 assert ("void value not ignored as it ought to be" == NULL
);
14575 return error_mark_node
;
14577 if (code
== VOID_TYPE
)
14578 return build1 (CONVERT_EXPR
, type
, e
);
14579 if ((code
!= RECORD_TYPE
)
14580 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
14581 e
= ffecom_1 (REALPART_EXPR
, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
))),
14583 if (code
== INTEGER_TYPE
|| code
== ENUMERAL_TYPE
)
14584 return fold (convert_to_integer (type
, e
));
14585 if (code
== POINTER_TYPE
)
14586 return fold (convert_to_pointer (type
, e
));
14587 if (code
== REAL_TYPE
)
14588 return fold (convert_to_real (type
, e
));
14589 if (code
== COMPLEX_TYPE
)
14590 return fold (convert_to_complex (type
, e
));
14591 if (code
== RECORD_TYPE
)
14592 return fold (ffecom_convert_to_complex_ (type
, e
));
14594 assert ("conversion to non-scalar type requested" == NULL
);
14595 return error_mark_node
;
14598 /* integrate_decl_tree calls this function, but since we don't use the
14599 DECL_LANG_SPECIFIC field, this is a no-op. */
14602 copy_lang_decl (node
)
14607 /* Return the list of declarations of the current level.
14608 Note that this list is in reverse order unless/until
14609 you nreverse it; and when you do nreverse it, you must
14610 store the result back using `storedecls' or you will lose. */
14615 return current_binding_level
->names
;
14618 /* Nonzero if we are currently in the global binding level. */
14621 global_bindings_p ()
14623 return current_binding_level
== global_binding_level
;
14626 /* Insert BLOCK at the end of the list of subblocks of the
14627 current binding level. This is used when a BIND_EXPR is expanded,
14628 to handle the BLOCK node inside the BIND_EXPR. */
14631 incomplete_type_error (value
, type
)
14635 if (TREE_CODE (type
) == ERROR_MARK
)
14638 assert ("incomplete type?!?" == NULL
);
14642 init_decl_processing ()
14652 extern void (*print_error_function
) (char *);
14655 /* Make identifier nodes long enough for the language-specific slots. */
14656 set_identifier_size (sizeof (struct lang_identifier
));
14657 decl_printable_name
= lang_printable_name
;
14659 print_error_function
= lang_print_error_function
;
14664 insert_block (block
)
14667 TREE_USED (block
) = 1;
14668 current_binding_level
->blocks
14669 = chainon (current_binding_level
->blocks
, block
);
14673 lang_decode_option (p
)
14676 return ffe_decode_option (p
);
14682 ffe_terminate_0 ();
14684 if (ffe_is_ffedebug ())
14685 malloc_pool_display (malloc_pool_image ());
14697 extern FILE *finput
; /* Don't pollute com.h with this. */
14699 /* If the file is output from cpp, it should contain a first line
14700 `# 1 "real-filename"', and the current design of gcc (toplev.c
14701 in particular and the way it sets up information relied on by
14702 INCLUDE) requires that we read this now, and store the
14703 "real-filename" info in master_input_filename. Ask the lexer
14704 to try doing this. */
14705 ffelex_hash_kludge (finput
);
14709 mark_addressable (exp
)
14712 register tree x
= exp
;
14714 switch (TREE_CODE (x
))
14717 case COMPONENT_REF
:
14719 x
= TREE_OPERAND (x
, 0);
14723 TREE_ADDRESSABLE (x
) = 1;
14730 if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
)
14731 && DECL_NONLOCAL (x
))
14733 if (TREE_PUBLIC (x
))
14735 assert ("address of global register var requested" == NULL
);
14738 assert ("address of register variable requested" == NULL
);
14740 else if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
))
14742 if (TREE_PUBLIC (x
))
14744 assert ("address of global register var requested" == NULL
);
14747 assert ("address of register var requested" == NULL
);
14749 put_var_into_stack (x
);
14752 case FUNCTION_DECL
:
14753 TREE_ADDRESSABLE (x
) = 1;
14754 #if 0 /* poplevel deals with this now. */
14755 if (DECL_CONTEXT (x
) == 0)
14756 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x
)) = 1;
14764 /* If DECL has a cleanup, build and return that cleanup here.
14765 This is a callback called by expand_expr. */
14768 maybe_build_cleanup (decl
)
14771 /* There are no cleanups in Fortran. */
14775 /* Exit a binding level.
14776 Pop the level off, and restore the state of the identifier-decl mappings
14777 that were in effect when this level was entered.
14779 If KEEP is nonzero, this level had explicit declarations, so
14780 and create a "block" (a BLOCK node) for the level
14781 to record its declarations and subblocks for symbol table output.
14783 If FUNCTIONBODY is nonzero, this level is the body of a function,
14784 so create a block as if KEEP were set and also clear out all
14787 If REVERSE is nonzero, reverse the order of decls before putting
14788 them into the BLOCK. */
14791 poplevel (keep
, reverse
, functionbody
)
14796 register tree link
;
14797 /* The chain of decls was accumulated in reverse order. Put it into forward
14798 order, just for cleanliness. */
14800 tree subblocks
= current_binding_level
->blocks
;
14803 int block_previously_created
;
14805 /* Get the decls in the order they were written. Usually
14806 current_binding_level->names is in reverse order. But parameter decls
14807 were previously put in forward order. */
14810 current_binding_level
->names
14811 = decls
= nreverse (current_binding_level
->names
);
14813 decls
= current_binding_level
->names
;
14815 /* Output any nested inline functions within this block if they weren't
14818 for (decl
= decls
; decl
; decl
= TREE_CHAIN (decl
))
14819 if (TREE_CODE (decl
) == FUNCTION_DECL
14820 && !TREE_ASM_WRITTEN (decl
)
14821 && DECL_INITIAL (decl
) != 0
14822 && TREE_ADDRESSABLE (decl
))
14824 /* If this decl was copied from a file-scope decl on account of a
14825 block-scope extern decl, propagate TREE_ADDRESSABLE to the
14826 file-scope decl. */
14827 if (DECL_ABSTRACT_ORIGIN (decl
) != 0)
14828 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl
)) = 1;
14831 push_function_context ();
14832 output_inline_function (decl
);
14833 pop_function_context ();
14837 /* If there were any declarations or structure tags in that level, or if
14838 this level is a function body, create a BLOCK to record them for the
14839 life of this function. */
14842 block_previously_created
= (current_binding_level
->this_block
!= 0);
14843 if (block_previously_created
)
14844 block
= current_binding_level
->this_block
;
14845 else if (keep
|| functionbody
)
14846 block
= make_node (BLOCK
);
14849 BLOCK_VARS (block
) = decls
;
14850 BLOCK_SUBBLOCKS (block
) = subblocks
;
14851 remember_end_note (block
);
14854 /* In each subblock, record that this is its superior. */
14856 for (link
= subblocks
; link
; link
= TREE_CHAIN (link
))
14857 BLOCK_SUPERCONTEXT (link
) = block
;
14859 /* Clear out the meanings of the local variables of this level. */
14861 for (link
= decls
; link
; link
= TREE_CHAIN (link
))
14863 if (DECL_NAME (link
) != 0)
14865 /* If the ident. was used or addressed via a local extern decl,
14866 don't forget that fact. */
14867 if (DECL_EXTERNAL (link
))
14869 if (TREE_USED (link
))
14870 TREE_USED (DECL_NAME (link
)) = 1;
14871 if (TREE_ADDRESSABLE (link
))
14872 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link
)) = 1;
14874 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link
)) = 0;
14878 /* If the level being exited is the top level of a function, check over all
14879 the labels, and clear out the current (function local) meanings of their
14884 /* If this is the top level block of a function, the vars are the
14885 function's parameters. Don't leave them in the BLOCK because they
14886 are found in the FUNCTION_DECL instead. */
14888 BLOCK_VARS (block
) = 0;
14891 /* Pop the current level, and free the structure for reuse. */
14894 register struct binding_level
*level
= current_binding_level
;
14895 current_binding_level
= current_binding_level
->level_chain
;
14897 level
->level_chain
= free_binding_level
;
14898 free_binding_level
= level
;
14901 /* Dispose of the block that we just made inside some higher level. */
14903 DECL_INITIAL (current_function_decl
) = block
;
14906 if (!block_previously_created
)
14907 current_binding_level
->blocks
14908 = chainon (current_binding_level
->blocks
, block
);
14910 /* If we did not make a block for the level just exited, any blocks made
14911 for inner levels (since they cannot be recorded as subblocks in that
14912 level) must be carried forward so they will later become subblocks of
14914 else if (subblocks
)
14915 current_binding_level
->blocks
14916 = chainon (current_binding_level
->blocks
, subblocks
);
14918 /* Set the TYPE_CONTEXTs for all of the tagged types belonging to this
14919 binding contour so that they point to the appropriate construct, i.e.
14920 either to the current FUNCTION_DECL node, or else to the BLOCK node we
14923 Note that for tagged types whose scope is just the formal parameter list
14924 for some function type specification, we can't properly set their
14925 TYPE_CONTEXTs here, because we don't have a pointer to the appropriate
14926 FUNCTION_TYPE node readily available to us. For those cases, the
14927 TYPE_CONTEXTs of the relevant tagged type nodes get set in
14928 `grokdeclarator' as soon as we have created the FUNCTION_TYPE node which
14929 will represent the "scope" for these "parameter list local" tagged
14933 TREE_USED (block
) = 1;
14938 print_lang_decl (file
, node
, indent
)
14946 print_lang_identifier (file
, node
, indent
)
14951 print_node (file
, "global", IDENTIFIER_GLOBAL_VALUE (node
), indent
+ 4);
14952 print_node (file
, "local", IDENTIFIER_LOCAL_VALUE (node
), indent
+ 4);
14956 print_lang_statistics ()
14961 print_lang_type (file
, node
, indent
)
14968 /* Record a decl-node X as belonging to the current lexical scope.
14969 Check for errors (such as an incompatible declaration for the same
14970 name already seen in the same scope).
14972 Returns either X or an old decl for the same name.
14973 If an old decl is returned, it may have been smashed
14974 to agree with what X says. */
14981 register tree name
= DECL_NAME (x
);
14982 register struct binding_level
*b
= current_binding_level
;
14984 if ((TREE_CODE (x
) == FUNCTION_DECL
)
14985 && (DECL_INITIAL (x
) == 0)
14986 && DECL_EXTERNAL (x
))
14987 DECL_CONTEXT (x
) = NULL_TREE
;
14989 DECL_CONTEXT (x
) = current_function_decl
;
14993 if (IDENTIFIER_INVENTED (name
))
14996 DECL_ARTIFICIAL (x
) = 1;
14998 DECL_IN_SYSTEM_HEADER (x
) = 1;
14999 DECL_IGNORED_P (x
) = 1;
15001 if (TREE_CODE (x
) == TYPE_DECL
)
15002 TYPE_DECL_SUPPRESS_DEBUG (x
) = 1;
15005 t
= lookup_name_current_level (name
);
15007 assert ((t
== NULL_TREE
) || (DECL_CONTEXT (x
) == NULL_TREE
));
15009 /* Don't push non-parms onto list for parms until we understand
15010 why we're doing this and whether it works. */
15012 assert ((b
== global_binding_level
)
15013 || !ffecom_transform_only_dummies_
15014 || TREE_CODE (x
) == PARM_DECL
);
15016 if ((t
!= NULL_TREE
) && duplicate_decls (x
, t
))
15019 /* If we are processing a typedef statement, generate a whole new
15020 ..._TYPE node (which will be just an variant of the existing
15021 ..._TYPE node with identical properties) and then install the
15022 TYPE_DECL node generated to represent the typedef name as the
15023 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15025 The whole point here is to end up with a situation where each and every
15026 ..._TYPE node the compiler creates will be uniquely associated with
15027 AT MOST one node representing a typedef name. This way, even though
15028 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15029 (i.e. "typedef name") nodes very early on, later parts of the
15030 compiler can always do the reverse translation and get back the
15031 corresponding typedef name. For example, given:
15033 typedef struct S MY_TYPE; MY_TYPE object;
15035 Later parts of the compiler might only know that `object' was of type
15036 `struct S' if if were not for code just below. With this code
15037 however, later parts of the compiler see something like:
15039 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15041 And they can then deduce (from the node for type struct S') that the
15042 original object declaration was:
15046 Being able to do this is important for proper support of protoize, and
15047 also for generating precise symbolic debugging information which
15048 takes full account of the programmer's (typedef) vocabulary.
15050 Obviously, we don't want to generate a duplicate ..._TYPE node if the
15051 TYPE_DECL node that we are now processing really represents a
15052 standard built-in type.
15054 Since all standard types are effectively declared at line zero in the
15055 source file, we can easily check to see if we are working on a
15056 standard type by checking the current value of lineno. */
15058 if (TREE_CODE (x
) == TYPE_DECL
)
15060 if (DECL_SOURCE_LINE (x
) == 0)
15062 if (TYPE_NAME (TREE_TYPE (x
)) == 0)
15063 TYPE_NAME (TREE_TYPE (x
)) = x
;
15065 else if (TREE_TYPE (x
) != error_mark_node
)
15067 tree tt
= TREE_TYPE (x
);
15069 tt
= build_type_copy (tt
);
15070 TYPE_NAME (tt
) = x
;
15071 TREE_TYPE (x
) = tt
;
15075 /* This name is new in its binding level. Install the new declaration
15077 if (b
== global_binding_level
)
15078 IDENTIFIER_GLOBAL_VALUE (name
) = x
;
15080 IDENTIFIER_LOCAL_VALUE (name
) = x
;
15083 /* Put decls on list in reverse order. We will reverse them later if
15085 TREE_CHAIN (x
) = b
->names
;
15091 /* Enter a new binding level.
15092 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15093 not for that of tags. */
15096 pushlevel (tag_transparent
)
15097 int tag_transparent
;
15099 register struct binding_level
*newlevel
= NULL_BINDING_LEVEL
;
15101 assert (!tag_transparent
);
15103 /* Reuse or create a struct for this binding level. */
15105 if (free_binding_level
)
15107 newlevel
= free_binding_level
;
15108 free_binding_level
= free_binding_level
->level_chain
;
15112 newlevel
= make_binding_level ();
15115 /* Add this level to the front of the chain (stack) of levels that are
15118 *newlevel
= clear_binding_level
;
15119 newlevel
->level_chain
= current_binding_level
;
15120 current_binding_level
= newlevel
;
15123 /* Set the BLOCK node for the innermost scope
15124 (the one we are currently in). */
15128 register tree block
;
15130 current_binding_level
->this_block
= block
;
15133 /* ~~tree.h SHOULD declare this, because toplev.c references it. */
15135 /* Can't 'yydebug' a front end not generated by yacc/bison! */
15138 set_yydebug (value
)
15142 fprintf (stderr
, "warning: no yacc/bison-generated output to debug!\n");
15146 signed_or_unsigned_type (unsignedp
, type
)
15152 if (! INTEGRAL_TYPE_P (type
))
15154 if (TYPE_PRECISION (type
) == TYPE_PRECISION (signed_char_type_node
))
15155 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15156 if (TYPE_PRECISION (type
) == TYPE_PRECISION (integer_type_node
))
15157 return unsignedp
? unsigned_type_node
: integer_type_node
;
15158 if (TYPE_PRECISION (type
) == TYPE_PRECISION (short_integer_type_node
))
15159 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15160 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_integer_type_node
))
15161 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15162 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_long_integer_type_node
))
15163 return (unsignedp
? long_long_unsigned_type_node
15164 : long_long_integer_type_node
);
15166 type2
= type_for_size (TYPE_PRECISION (type
), unsignedp
);
15167 if (type2
== NULL_TREE
)
15177 tree type1
= TYPE_MAIN_VARIANT (type
);
15178 ffeinfoKindtype kt
;
15181 if (type1
== unsigned_char_type_node
|| type1
== char_type_node
)
15182 return signed_char_type_node
;
15183 if (type1
== unsigned_type_node
)
15184 return integer_type_node
;
15185 if (type1
== short_unsigned_type_node
)
15186 return short_integer_type_node
;
15187 if (type1
== long_unsigned_type_node
)
15188 return long_integer_type_node
;
15189 if (type1
== long_long_unsigned_type_node
)
15190 return long_long_integer_type_node
;
15191 #if 0 /* gcc/c-* files only */
15192 if (type1
== unsigned_intDI_type_node
)
15193 return intDI_type_node
;
15194 if (type1
== unsigned_intSI_type_node
)
15195 return intSI_type_node
;
15196 if (type1
== unsigned_intHI_type_node
)
15197 return intHI_type_node
;
15198 if (type1
== unsigned_intQI_type_node
)
15199 return intQI_type_node
;
15202 type2
= type_for_size (TYPE_PRECISION (type1
), 0);
15203 if (type2
!= NULL_TREE
)
15206 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15208 type2
= ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
15210 if (type1
== type2
)
15211 return ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15217 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15218 or validate its data type for an `if' or `while' statement or ?..: exp.
15220 This preparation consists of taking the ordinary
15221 representation of an expression expr and producing a valid tree
15222 boolean expression describing whether expr is nonzero. We could
15223 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15224 but we optimize comparisons, &&, ||, and !.
15226 The resulting type should always be `integer_type_node'. */
15229 truthvalue_conversion (expr
)
15232 if (TREE_CODE (expr
) == ERROR_MARK
)
15235 #if 0 /* This appears to be wrong for C++. */
15236 /* These really should return error_mark_node after 2.4 is stable.
15237 But not all callers handle ERROR_MARK properly. */
15238 switch (TREE_CODE (TREE_TYPE (expr
)))
15241 error ("struct type value used where scalar is required");
15242 return integer_zero_node
;
15245 error ("union type value used where scalar is required");
15246 return integer_zero_node
;
15249 error ("array type value used where scalar is required");
15250 return integer_zero_node
;
15257 switch (TREE_CODE (expr
))
15259 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15260 or comparison expressions as truth values at this level. */
15262 case COMPONENT_REF
:
15263 /* A one-bit unsigned bit-field is already acceptable. */
15264 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr
, 1)))
15265 && TREE_UNSIGNED (TREE_OPERAND (expr
, 1)))
15271 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15272 or comparison expressions as truth values at this level. */
15274 if (integer_zerop (TREE_OPERAND (expr
, 1)))
15275 return build_unary_op (TRUTH_NOT_EXPR
, TREE_OPERAND (expr
, 0), 0);
15277 case NE_EXPR
: case LE_EXPR
: case GE_EXPR
: case LT_EXPR
: case GT_EXPR
:
15278 case TRUTH_ANDIF_EXPR
:
15279 case TRUTH_ORIF_EXPR
:
15280 case TRUTH_AND_EXPR
:
15281 case TRUTH_OR_EXPR
:
15282 case TRUTH_XOR_EXPR
:
15283 TREE_TYPE (expr
) = integer_type_node
;
15290 return integer_zerop (expr
) ? integer_zero_node
: integer_one_node
;
15293 return real_zerop (expr
) ? integer_zero_node
: integer_one_node
;
15296 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 0)))
15297 return build (COMPOUND_EXPR
, integer_type_node
,
15298 TREE_OPERAND (expr
, 0), integer_one_node
);
15300 return integer_one_node
;
15303 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1))
15304 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
15306 truthvalue_conversion (TREE_OPERAND (expr
, 0)),
15307 truthvalue_conversion (TREE_OPERAND (expr
, 1)));
15313 /* These don't change whether an object is non-zero or zero. */
15314 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15318 /* These don't change whether an object is zero or non-zero, but
15319 we can't ignore them if their second arg has side-effects. */
15320 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1)))
15321 return build (COMPOUND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 1),
15322 truthvalue_conversion (TREE_OPERAND (expr
, 0)));
15324 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15327 /* Distribute the conversion into the arms of a COND_EXPR. */
15328 return fold (build (COND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 0),
15329 truthvalue_conversion (TREE_OPERAND (expr
, 1)),
15330 truthvalue_conversion (TREE_OPERAND (expr
, 2))));
15333 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15334 since that affects how `default_conversion' will behave. */
15335 if (TREE_CODE (TREE_TYPE (expr
)) == REFERENCE_TYPE
15336 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == REFERENCE_TYPE
)
15338 /* fall through... */
15340 /* If this is widening the argument, we can ignore it. */
15341 if (TYPE_PRECISION (TREE_TYPE (expr
))
15342 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr
, 0))))
15343 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15347 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15349 if (TARGET_FLOAT_FORMAT
== IEEE_FLOAT_FORMAT
15350 && TREE_CODE (TREE_TYPE (expr
)) == REAL_TYPE
)
15352 /* fall through... */
15354 /* This and MINUS_EXPR can be changed into a comparison of the
15356 if (TREE_TYPE (TREE_OPERAND (expr
, 0))
15357 == TREE_TYPE (TREE_OPERAND (expr
, 1)))
15358 return ffecom_2 (NE_EXPR
, integer_type_node
,
15359 TREE_OPERAND (expr
, 0),
15360 TREE_OPERAND (expr
, 1));
15361 return ffecom_2 (NE_EXPR
, integer_type_node
,
15362 TREE_OPERAND (expr
, 0),
15363 fold (build1 (NOP_EXPR
,
15364 TREE_TYPE (TREE_OPERAND (expr
, 0)),
15365 TREE_OPERAND (expr
, 1))));
15368 if (integer_onep (TREE_OPERAND (expr
, 1)))
15373 #if 0 /* No such thing in Fortran. */
15374 if (warn_parentheses
&& C_EXP_ORIGINAL_CODE (expr
) == MODIFY_EXPR
)
15375 warning ("suggest parentheses around assignment used as truth value");
15383 if (TREE_CODE (TREE_TYPE (expr
)) == COMPLEX_TYPE
)
15385 ((TREE_SIDE_EFFECTS (expr
)
15386 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
15388 truthvalue_conversion (ffecom_1 (REALPART_EXPR
,
15389 TREE_TYPE (TREE_TYPE (expr
)),
15391 truthvalue_conversion (ffecom_1 (IMAGPART_EXPR
,
15392 TREE_TYPE (TREE_TYPE (expr
)),
15395 return ffecom_2 (NE_EXPR
, integer_type_node
,
15397 convert (TREE_TYPE (expr
), integer_zero_node
));
15401 type_for_mode (mode
, unsignedp
)
15402 enum machine_mode mode
;
15409 if (mode
== TYPE_MODE (integer_type_node
))
15410 return unsignedp
? unsigned_type_node
: integer_type_node
;
15412 if (mode
== TYPE_MODE (signed_char_type_node
))
15413 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15415 if (mode
== TYPE_MODE (short_integer_type_node
))
15416 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15418 if (mode
== TYPE_MODE (long_integer_type_node
))
15419 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15421 if (mode
== TYPE_MODE (long_long_integer_type_node
))
15422 return unsignedp
? long_long_unsigned_type_node
: long_long_integer_type_node
;
15424 if (mode
== TYPE_MODE (float_type_node
))
15425 return float_type_node
;
15427 if (mode
== TYPE_MODE (double_type_node
))
15428 return double_type_node
;
15430 if (mode
== TYPE_MODE (build_pointer_type (char_type_node
)))
15431 return build_pointer_type (char_type_node
);
15433 if (mode
== TYPE_MODE (build_pointer_type (integer_type_node
)))
15434 return build_pointer_type (integer_type_node
);
15436 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
15437 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
15439 if (((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
15440 && (mode
== TYPE_MODE (t
)))
15441 if ((i
== FFEINFO_basictypeINTEGER
) && unsignedp
)
15442 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][j
];
15451 type_for_size (bits
, unsignedp
)
15455 ffeinfoKindtype kt
;
15458 if (bits
== TYPE_PRECISION (integer_type_node
))
15459 return unsignedp
? unsigned_type_node
: integer_type_node
;
15461 if (bits
== TYPE_PRECISION (signed_char_type_node
))
15462 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15464 if (bits
== TYPE_PRECISION (short_integer_type_node
))
15465 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15467 if (bits
== TYPE_PRECISION (long_integer_type_node
))
15468 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15470 if (bits
== TYPE_PRECISION (long_long_integer_type_node
))
15471 return (unsignedp
? long_long_unsigned_type_node
15472 : long_long_integer_type_node
);
15474 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15476 type_node
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15478 if ((type_node
!= NULL_TREE
) && (bits
== TYPE_PRECISION (type_node
)))
15479 return unsignedp
? ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
]
15487 unsigned_type (type
)
15490 tree type1
= TYPE_MAIN_VARIANT (type
);
15491 ffeinfoKindtype kt
;
15494 if (type1
== signed_char_type_node
|| type1
== char_type_node
)
15495 return unsigned_char_type_node
;
15496 if (type1
== integer_type_node
)
15497 return unsigned_type_node
;
15498 if (type1
== short_integer_type_node
)
15499 return short_unsigned_type_node
;
15500 if (type1
== long_integer_type_node
)
15501 return long_unsigned_type_node
;
15502 if (type1
== long_long_integer_type_node
)
15503 return long_long_unsigned_type_node
;
15504 #if 0 /* gcc/c-* files only */
15505 if (type1
== intDI_type_node
)
15506 return unsigned_intDI_type_node
;
15507 if (type1
== intSI_type_node
)
15508 return unsigned_intSI_type_node
;
15509 if (type1
== intHI_type_node
)
15510 return unsigned_intHI_type_node
;
15511 if (type1
== intQI_type_node
)
15512 return unsigned_intQI_type_node
;
15515 type2
= type_for_size (TYPE_PRECISION (type1
), 1);
15516 if (type2
!= NULL_TREE
)
15519 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15521 type2
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15523 if (type1
== type2
)
15524 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
15530 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15532 #if FFECOM_GCC_INCLUDE
15534 /* From gcc/cccp.c, the code to handle -I. */
15536 /* Skip leading "./" from a directory name.
15537 This may yield the empty string, which represents the current directory. */
15540 skip_redundant_dir_prefix (char *dir
)
15542 while (dir
[0] == '.' && dir
[1] == '/')
15543 for (dir
+= 2; *dir
== '/'; dir
++)
15545 if (dir
[0] == '.' && !dir
[1])
15550 /* The file_name_map structure holds a mapping of file names for a
15551 particular directory. This mapping is read from the file named
15552 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15553 map filenames on a file system with severe filename restrictions,
15554 such as DOS. The format of the file name map file is just a series
15555 of lines with two tokens on each line. The first token is the name
15556 to map, and the second token is the actual name to use. */
15558 struct file_name_map
15560 struct file_name_map
*map_next
;
15565 #define FILE_NAME_MAP_FILE "header.gcc"
15567 /* Current maximum length of directory names in the search path
15568 for include files. (Altered as we get more of them.) */
15570 static int max_include_len
= 0;
15572 struct file_name_list
15574 struct file_name_list
*next
;
15576 /* Mapping of file names for this directory. */
15577 struct file_name_map
*name_map
;
15578 /* Non-zero if name_map is valid. */
15582 static struct file_name_list
*include
= NULL
; /* First dir to search */
15583 static struct file_name_list
*last_include
= NULL
; /* Last in chain */
15585 /* I/O buffer structure.
15586 The `fname' field is nonzero for source files and #include files
15587 and for the dummy text used for -D and -U.
15588 It is zero for rescanning results of macro expansion
15589 and for expanding macro arguments. */
15590 #define INPUT_STACK_MAX 400
15591 static struct file_buf
{
15593 /* Filename specified with #line command. */
15594 char *nominal_fname
;
15595 /* Record where in the search path this file was found.
15596 For #include_next. */
15597 struct file_name_list
*dir
;
15599 ffewhereColumn column
;
15600 } instack
[INPUT_STACK_MAX
];
15602 static int last_error_tick
= 0; /* Incremented each time we print it. */
15603 static int input_file_stack_tick
= 0; /* Incremented when status changes. */
15605 /* Current nesting level of input sources.
15606 `instack[indepth]' is the level currently being read. */
15607 static int indepth
= -1;
15609 typedef struct file_buf FILE_BUF
;
15611 typedef unsigned char U_CHAR
;
15613 /* table to tell if char can be part of a C identifier. */
15614 U_CHAR is_idchar
[256];
15615 /* table to tell if char can be first char of a c identifier. */
15616 U_CHAR is_idstart
[256];
15617 /* table to tell if c is horizontal space. */
15618 U_CHAR is_hor_space
[256];
15619 /* table to tell if c is horizontal or vertical space. */
15620 static U_CHAR is_space
[256];
15622 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15623 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15625 /* Nonzero means -I- has been seen,
15626 so don't look for #include "foo" the source-file directory. */
15627 static int ignore_srcdir
;
15629 #ifndef INCLUDE_LEN_FUDGE
15630 #define INCLUDE_LEN_FUDGE 0
15633 static void append_include_chain (struct file_name_list
*first
,
15634 struct file_name_list
*last
);
15635 static FILE *open_include_file (char *filename
,
15636 struct file_name_list
*searchptr
);
15637 static void print_containing_files (ffebadSeverity sev
);
15638 static char *skip_redundant_dir_prefix (char *);
15639 static char *read_filename_string (int ch
, FILE *f
);
15640 static struct file_name_map
*read_name_map (char *dirname
);
15641 static char *savestring (char *input
);
15643 /* Append a chain of `struct file_name_list's
15644 to the end of the main include chain.
15645 FIRST is the beginning of the chain to append, and LAST is the end. */
15648 append_include_chain (first
, last
)
15649 struct file_name_list
*first
, *last
;
15651 struct file_name_list
*dir
;
15653 if (!first
|| !last
)
15659 last_include
->next
= first
;
15661 for (dir
= first
; ; dir
= dir
->next
) {
15662 int len
= strlen (dir
->fname
) + INCLUDE_LEN_FUDGE
;
15663 if (len
> max_include_len
)
15664 max_include_len
= len
;
15670 last_include
= last
;
15673 /* Try to open include file FILENAME. SEARCHPTR is the directory
15674 being tried from the include file search path. This function maps
15675 filenames on file systems based on information read by
15679 open_include_file (filename
, searchptr
)
15681 struct file_name_list
*searchptr
;
15683 register struct file_name_map
*map
;
15684 register char *from
;
15687 if (searchptr
&& ! searchptr
->got_name_map
)
15689 searchptr
->name_map
= read_name_map (searchptr
->fname
15690 ? searchptr
->fname
: ".");
15691 searchptr
->got_name_map
= 1;
15694 /* First check the mapping for the directory we are using. */
15695 if (searchptr
&& searchptr
->name_map
)
15698 if (searchptr
->fname
)
15699 from
+= strlen (searchptr
->fname
) + 1;
15700 for (map
= searchptr
->name_map
; map
; map
= map
->map_next
)
15702 if (! strcmp (map
->map_from
, from
))
15704 /* Found a match. */
15705 return fopen (map
->map_to
, "r");
15710 /* Try to find a mapping file for the particular directory we are
15711 looking in. Thus #include <sys/types.h> will look up sys/types.h
15712 in /usr/include/header.gcc and look up types.h in
15713 /usr/include/sys/header.gcc. */
15714 p
= rindex (filename
, '/');
15715 #ifdef DIR_SEPARATOR
15716 if (! p
) p
= rindex (filename
, DIR_SEPARATOR
);
15718 char *tmp
= rindex (filename
, DIR_SEPARATOR
);
15719 if (tmp
!= NULL
&& tmp
> p
) p
= tmp
;
15725 && searchptr
->fname
15726 && strlen (searchptr
->fname
) == (size_t) (p
- filename
)
15727 && ! strncmp (searchptr
->fname
, filename
, (int) (p
- filename
)))
15729 /* FILENAME is in SEARCHPTR, which we've already checked. */
15730 return fopen (filename
, "r");
15736 map
= read_name_map (".");
15740 dir
= (char *) xmalloc (p
- filename
+ 1);
15741 bcopy (filename
, dir
, p
- filename
);
15742 dir
[p
- filename
] = '\0';
15744 map
= read_name_map (dir
);
15747 for (; map
; map
= map
->map_next
)
15748 if (! strcmp (map
->map_from
, from
))
15749 return fopen (map
->map_to
, "r");
15751 return fopen (filename
, "r");
15754 /* Print the file names and line numbers of the #include
15755 commands which led to the current file. */
15758 print_containing_files (ffebadSeverity sev
)
15760 FILE_BUF
*ip
= NULL
;
15766 /* If stack of files hasn't changed since we last printed
15767 this info, don't repeat it. */
15768 if (last_error_tick
== input_file_stack_tick
)
15771 for (i
= indepth
; i
>= 0; i
--)
15772 if (instack
[i
].fname
!= NULL
) {
15777 /* Give up if we don't find a source file. */
15781 /* Find the other, outer source files. */
15782 for (i
--; i
>= 0; i
--)
15783 if (instack
[i
].fname
!= NULL
)
15789 str1
= "In file included";
15801 ffebad_start_msg ("%A from %B at %0%C", sev
);
15802 ffebad_here (0, ip
->line
, ip
->column
);
15803 ffebad_string (str1
);
15804 ffebad_string (ip
->nominal_fname
);
15805 ffebad_string (str2
);
15809 /* Record we have printed the status as of this time. */
15810 last_error_tick
= input_file_stack_tick
;
15813 /* Read a space delimited string of unlimited length from a stdio
15817 read_filename_string (ch
, f
)
15825 set
= alloc
= xmalloc (len
+ 1);
15826 if (! is_space
[ch
])
15829 while ((ch
= getc (f
)) != EOF
&& ! is_space
[ch
])
15831 if (set
- alloc
== len
)
15834 alloc
= xrealloc (alloc
, len
+ 1);
15835 set
= alloc
+ len
/ 2;
15845 /* Read the file name map file for DIRNAME. */
15847 static struct file_name_map
*
15848 read_name_map (dirname
)
15851 /* This structure holds a linked list of file name maps, one per
15853 struct file_name_map_list
15855 struct file_name_map_list
*map_list_next
;
15856 char *map_list_name
;
15857 struct file_name_map
*map_list_map
;
15859 static struct file_name_map_list
*map_list
;
15860 register struct file_name_map_list
*map_list_ptr
;
15864 int separator_needed
;
15866 dirname
= skip_redundant_dir_prefix (dirname
);
15868 for (map_list_ptr
= map_list
; map_list_ptr
;
15869 map_list_ptr
= map_list_ptr
->map_list_next
)
15870 if (! strcmp (map_list_ptr
->map_list_name
, dirname
))
15871 return map_list_ptr
->map_list_map
;
15873 map_list_ptr
= ((struct file_name_map_list
*)
15874 xmalloc (sizeof (struct file_name_map_list
)));
15875 map_list_ptr
->map_list_name
= savestring (dirname
);
15876 map_list_ptr
->map_list_map
= NULL
;
15878 dirlen
= strlen (dirname
);
15879 separator_needed
= dirlen
!= 0 && dirname
[dirlen
- 1] != '/';
15880 name
= (char *) xmalloc (dirlen
+ strlen (FILE_NAME_MAP_FILE
) + 2);
15881 strcpy (name
, dirname
);
15882 name
[dirlen
] = '/';
15883 strcpy (name
+ dirlen
+ separator_needed
, FILE_NAME_MAP_FILE
);
15884 f
= fopen (name
, "r");
15887 map_list_ptr
->map_list_map
= NULL
;
15892 while ((ch
= getc (f
)) != EOF
)
15895 struct file_name_map
*ptr
;
15899 from
= read_filename_string (ch
, f
);
15900 while ((ch
= getc (f
)) != EOF
&& is_hor_space
[ch
])
15902 to
= read_filename_string (ch
, f
);
15904 ptr
= ((struct file_name_map
*)
15905 xmalloc (sizeof (struct file_name_map
)));
15906 ptr
->map_from
= from
;
15908 /* Make the real filename absolute. */
15913 ptr
->map_to
= xmalloc (dirlen
+ strlen (to
) + 2);
15914 strcpy (ptr
->map_to
, dirname
);
15915 ptr
->map_to
[dirlen
] = '/';
15916 strcpy (ptr
->map_to
+ dirlen
+ separator_needed
, to
);
15920 ptr
->map_next
= map_list_ptr
->map_list_map
;
15921 map_list_ptr
->map_list_map
= ptr
;
15923 while ((ch
= getc (f
)) != '\n')
15930 map_list_ptr
->map_list_next
= map_list
;
15931 map_list
= map_list_ptr
;
15933 return map_list_ptr
->map_list_map
;
15940 unsigned size
= strlen (input
);
15941 char *output
= xmalloc (size
+ 1);
15942 strcpy (output
, input
);
15947 ffecom_file_ (char *name
)
15951 /* Do partial setup of input buffer for the sake of generating
15952 early #line directives (when -g is in effect). */
15954 fp
= &instack
[++indepth
];
15955 bzero ((char *) fp
, sizeof (FILE_BUF
));
15958 fp
->nominal_fname
= fp
->fname
= name
;
15961 /* Initialize syntactic classifications of characters. */
15964 ffecom_initialize_char_syntax_ ()
15969 * Set up is_idchar and is_idstart tables. These should be
15970 * faster than saying (is_alpha (c) || c == '_'), etc.
15971 * Set up these things before calling any routines tthat
15974 for (i
= 'a'; i
<= 'z'; i
++) {
15975 is_idchar
[i
- 'a' + 'A'] = 1;
15977 is_idstart
[i
- 'a' + 'A'] = 1;
15980 for (i
= '0'; i
<= '9'; i
++)
15982 is_idchar
['_'] = 1;
15983 is_idstart
['_'] = 1;
15985 /* horizontal space table */
15986 is_hor_space
[' '] = 1;
15987 is_hor_space
['\t'] = 1;
15988 is_hor_space
['\v'] = 1;
15989 is_hor_space
['\f'] = 1;
15990 is_hor_space
['\r'] = 1;
15993 is_space
['\t'] = 1;
15994 is_space
['\v'] = 1;
15995 is_space
['\f'] = 1;
15996 is_space
['\n'] = 1;
15997 is_space
['\r'] = 1;
16001 ffecom_close_include_ (FILE *f
)
16006 input_file_stack_tick
++;
16008 ffewhere_line_kill (instack
[indepth
].line
);
16009 ffewhere_column_kill (instack
[indepth
].column
);
16013 ffecom_decode_include_option_ (char *spec
)
16015 struct file_name_list
*dirtmp
;
16017 if (! ignore_srcdir
&& !strcmp (spec
, "-"))
16021 dirtmp
= (struct file_name_list
*)
16022 xmalloc (sizeof (struct file_name_list
));
16023 dirtmp
->next
= 0; /* New one goes on the end */
16025 dirtmp
->fname
= spec
;
16027 fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16028 dirtmp
->got_name_map
= 0;
16029 append_include_chain (dirtmp
, dirtmp
);
16034 /* Open INCLUDEd file. */
16037 ffecom_open_include_ (char *name
, ffewhereLine l
, ffewhereColumn c
)
16040 size_t flen
= strlen (fbeg
);
16041 struct file_name_list
*search_start
= include
; /* Chain of dirs to search */
16042 struct file_name_list dsp
[1]; /* First in chain, if #include "..." */
16043 struct file_name_list
*searchptr
= 0;
16044 char *fname
; /* Dynamically allocated fname buffer */
16051 dsp
[0].fname
= NULL
;
16053 /* If -I- was specified, don't search current dir, only spec'd ones. */
16054 if (!ignore_srcdir
)
16056 for (fp
= &instack
[indepth
]; fp
>= instack
; fp
--)
16062 if ((nam
= fp
->nominal_fname
) != NULL
)
16064 /* Found a named file. Figure out dir of the file,
16065 and put it in front of the search list. */
16066 dsp
[0].next
= search_start
;
16067 search_start
= dsp
;
16069 ep
= rindex (nam
, '/');
16070 #ifdef DIR_SEPARATOR
16071 if (ep
== NULL
) ep
= rindex (nam
, DIR_SEPARATOR
);
16073 char *tmp
= rindex (nam
, DIR_SEPARATOR
);
16074 if (tmp
!= NULL
&& tmp
> ep
) ep
= tmp
;
16078 ep
= rindex (nam
, ']');
16079 if (ep
== NULL
) ep
= rindex (nam
, '>');
16080 if (ep
== NULL
) ep
= rindex (nam
, ':');
16081 if (ep
!= NULL
) ep
++;
16086 dsp
[0].fname
= (char *) xmalloc (n
+ 1);
16087 strncpy (dsp
[0].fname
, nam
, n
);
16088 dsp
[0].fname
[n
] = '\0';
16089 if (n
+ INCLUDE_LEN_FUDGE
> max_include_len
)
16090 max_include_len
= n
+ INCLUDE_LEN_FUDGE
;
16093 dsp
[0].fname
= NULL
; /* Current directory */
16094 dsp
[0].got_name_map
= 0;
16100 /* Allocate this permanently, because it gets stored in the definitions
16102 fname
= xmalloc (max_include_len
+ flen
+ 4);
16103 /* + 2 above for slash and terminating null. */
16104 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16107 /* If specified file name is absolute, just open it. */
16110 #ifdef DIR_SEPARATOR
16111 || *fbeg
== DIR_SEPARATOR
16115 strncpy (fname
, (char *) fbeg
, flen
);
16117 f
= open_include_file (fname
, NULL_PTR
);
16123 /* Search directory path, trying to open the file.
16124 Copy each filename tried into FNAME. */
16126 for (searchptr
= search_start
; searchptr
; searchptr
= searchptr
->next
)
16128 if (searchptr
->fname
)
16130 /* The empty string in a search path is ignored.
16131 This makes it possible to turn off entirely
16132 a standard piece of the list. */
16133 if (searchptr
->fname
[0] == 0)
16135 strcpy (fname
, skip_redundant_dir_prefix (searchptr
->fname
));
16136 if (fname
[0] && fname
[strlen (fname
) - 1] != '/')
16137 strcat (fname
, "/");
16138 fname
[strlen (fname
) + flen
] = 0;
16143 strncat (fname
, fbeg
, flen
);
16145 /* Change this 1/2 Unix 1/2 VMS file specification into a
16146 full VMS file specification */
16147 if (searchptr
->fname
&& (searchptr
->fname
[0] != 0))
16149 /* Fix up the filename */
16150 hack_vms_include_specification (fname
);
16154 /* This is a normal VMS filespec, so use it unchanged. */
16155 strncpy (fname
, (char *) fbeg
, flen
);
16157 #if 0 /* Not for g77. */
16158 /* if it's '#include filename', add the missing .h */
16159 if (index (fname
, '.') == NULL
)
16160 strcat (fname
, ".h");
16164 f
= open_include_file (fname
, searchptr
);
16166 if (f
== NULL
&& errno
== EACCES
)
16168 print_containing_files (FFEBAD_severityWARNING
);
16169 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16170 FFEBAD_severityWARNING
);
16171 ffebad_string (fname
);
16172 ffebad_here (0, l
, c
);
16183 /* A file that was not found. */
16185 strncpy (fname
, (char *) fbeg
, flen
);
16187 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE
));
16188 ffebad_start (FFEBAD_OPEN_INCLUDE
);
16189 ffebad_here (0, l
, c
);
16190 ffebad_string (fname
);
16194 if (dsp
[0].fname
!= NULL
)
16195 free (dsp
[0].fname
);
16200 if (indepth
>= (INPUT_STACK_MAX
- 1))
16202 print_containing_files (FFEBAD_severityFATAL
);
16203 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16204 FFEBAD_severityFATAL
);
16205 ffebad_string (fname
);
16206 ffebad_here (0, l
, c
);
16211 instack
[indepth
].line
= ffewhere_line_use (l
);
16212 instack
[indepth
].column
= ffewhere_column_use (c
);
16214 fp
= &instack
[indepth
+ 1];
16215 bzero ((char *) fp
, sizeof (FILE_BUF
));
16216 fp
->nominal_fname
= fp
->fname
= fname
;
16217 fp
->dir
= searchptr
;
16220 input_file_stack_tick
++;
16224 #endif /* FFECOM_GCC_INCLUDE */