1 /* com.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995-1998 Free Software Foundation, Inc.
3 Contributed by James Craig Burley (burley@gnu.org).
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 /* Stream for reading from the input file. */
244 /* These definitions parallel those in c-decl.c so that code from that
245 module can be used pretty much as is. Much of these defs aren't
246 otherwise used, i.e. by g77 code per se, except some of them are used
247 to build some of them that are. The ones that are global (i.e. not
248 "static") are those that ste.c and such might use (directly
249 or by using com macros that reference them in their definitions). */
251 static tree short_integer_type_node
;
252 tree long_integer_type_node
;
253 static tree long_long_integer_type_node
;
255 static tree short_unsigned_type_node
;
256 static tree long_unsigned_type_node
;
257 static tree long_long_unsigned_type_node
;
259 static tree unsigned_char_type_node
;
260 static tree signed_char_type_node
;
262 static tree float_type_node
;
263 static tree double_type_node
;
264 static tree complex_float_type_node
;
265 tree complex_double_type_node
;
266 static tree long_double_type_node
;
267 static tree complex_integer_type_node
;
268 static tree complex_long_double_type_node
;
270 tree string_type_node
;
272 static tree double_ftype_double
;
273 static tree float_ftype_float
;
274 static tree ldouble_ftype_ldouble
;
276 /* The rest of these are inventions for g77, though there might be
277 similar things in the C front end. As they are found, these
278 inventions should be renamed to be canonical. Note that only
279 the ones currently required to be global are so. */
281 static tree ffecom_tree_fun_type_void
;
282 static tree ffecom_tree_ptr_to_fun_type_void
;
284 tree ffecom_integer_type_node
; /* Abbrev for _tree_type[blah][blah]. */
285 tree ffecom_integer_zero_node
; /* Like *_*_* with g77's integer type. */
286 tree ffecom_integer_one_node
; /* " */
287 tree ffecom_tree_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
289 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
290 just use build_function_type and build_pointer_type on the
291 appropriate _tree_type array element. */
293 static tree ffecom_tree_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
294 static tree ffecom_tree_ptr_to_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
295 static tree ffecom_tree_subr_type
;
296 static tree ffecom_tree_ptr_to_subr_type
;
297 static tree ffecom_tree_blockdata_type
;
299 static tree ffecom_tree_xargc_
;
301 ffecomSymbol ffecom_symbol_null_
308 ffeinfoKindtype ffecom_pointer_kind_
= FFEINFO_basictypeNONE
;
309 ffeinfoKindtype ffecom_label_kind_
= FFEINFO_basictypeNONE
;
311 int ffecom_f2c_typecode_
[FFEINFO_basictype
][FFEINFO_kindtype
];
312 tree ffecom_f2c_integer_type_node
;
313 tree ffecom_f2c_ptr_to_integer_type_node
;
314 tree ffecom_f2c_address_type_node
;
315 tree ffecom_f2c_real_type_node
;
316 tree ffecom_f2c_ptr_to_real_type_node
;
317 tree ffecom_f2c_doublereal_type_node
;
318 tree ffecom_f2c_complex_type_node
;
319 tree ffecom_f2c_doublecomplex_type_node
;
320 tree ffecom_f2c_longint_type_node
;
321 tree ffecom_f2c_logical_type_node
;
322 tree ffecom_f2c_flag_type_node
;
323 tree ffecom_f2c_ftnlen_type_node
;
324 tree ffecom_f2c_ftnlen_zero_node
;
325 tree ffecom_f2c_ftnlen_one_node
;
326 tree ffecom_f2c_ftnlen_two_node
;
327 tree ffecom_f2c_ptr_to_ftnlen_type_node
;
328 tree ffecom_f2c_ftnint_type_node
;
329 tree ffecom_f2c_ptr_to_ftnint_type_node
;
330 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
332 /* Simple definitions and enumerations. */
334 #ifndef FFECOM_sizeMAXSTACKITEM
335 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
336 larger than this # bytes
337 off stack if possible. */
340 /* For systems that have large enough stacks, they should define
341 this to 0, and here, for ease of use later on, we just undefine
344 #if FFECOM_sizeMAXSTACKITEM == 0
345 #undef FFECOM_sizeMAXSTACKITEM
351 FFECOM_rttypeVOIDSTAR_
, /* C's `void *' type. */
352 FFECOM_rttypeFTNINT_
, /* f2c's `ftnint' type. */
353 FFECOM_rttypeINTEGER_
, /* f2c's `integer' type. */
354 FFECOM_rttypeLONGINT_
, /* f2c's `longint' type. */
355 FFECOM_rttypeLOGICAL_
, /* f2c's `logical' type. */
356 FFECOM_rttypeREAL_F2C_
, /* f2c's `real' returned as `double'. */
357 FFECOM_rttypeREAL_GNU_
, /* `real' returned as such. */
358 FFECOM_rttypeCOMPLEX_F2C_
, /* f2c's `complex' returned via 1st arg. */
359 FFECOM_rttypeCOMPLEX_GNU_
, /* f2c's `complex' returned directly. */
360 FFECOM_rttypeDOUBLE_
, /* C's `double' type. */
361 FFECOM_rttypeDOUBLEREAL_
, /* f2c's `doublereal' type. */
362 FFECOM_rttypeDBLCMPLX_F2C_
, /* f2c's `doublecomplex' returned via 1st arg. */
363 FFECOM_rttypeDBLCMPLX_GNU_
, /* f2c's `doublecomplex' returned directly. */
364 FFECOM_rttypeCHARACTER_
, /* f2c `char *'/`ftnlen' pair. */
368 /* Internal typedefs. */
370 #if FFECOM_targetCURRENT == FFECOM_targetGCC
371 typedef struct _ffecom_concat_list_ ffecomConcatList_
;
372 typedef struct _ffecom_temp_
*ffecomTemp_
;
373 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
375 /* Private include files. */
378 /* Internal structure definitions. */
380 #if FFECOM_targetCURRENT == FFECOM_targetGCC
381 struct _ffecom_concat_list_
386 ffetargetCharacterSize minlen
;
387 ffetargetCharacterSize maxlen
;
393 tree type
; /* Base type (w/o size/array applied). */
395 ffetargetCharacterSize size
;
401 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
403 /* Static functions (internal). */
405 #if FFECOM_targetCURRENT == FFECOM_targetGCC
406 static tree
ffecom_arglist_expr_ (char *argstring
, ffebld args
);
407 static tree
ffecom_widest_expr_type_ (ffebld list
);
408 static bool ffecom_overlap_ (tree dest_decl
, tree dest_offset
,
409 tree dest_size
, tree source_tree
,
410 ffebld source
, bool scalar_arg
);
411 static bool ffecom_args_overlapping_ (tree dest_tree
, ffebld dest
,
412 tree args
, tree callee_commons
,
414 static tree
ffecom_build_f2c_string_ (int i
, char *s
);
415 static tree
ffecom_call_ (tree fn
, ffeinfoKindtype kt
,
416 bool is_f2c_complex
, tree type
,
417 tree args
, tree dest_tree
,
418 ffebld dest
, bool *dest_used
,
419 tree callee_commons
, bool scalar_args
);
420 static tree
ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
,
421 bool is_f2c_complex
, tree type
,
422 ffebld left
, ffebld right
,
423 tree dest_tree
, ffebld dest
,
424 bool *dest_used
, tree callee_commons
,
426 static void ffecom_char_args_x_ (tree
*xitem
, tree
*length
,
427 ffebld expr
, bool with_null
);
428 static tree
ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
);
429 static tree
ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
);
430 static ffecomConcatList_
431 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
,
433 ffetargetCharacterSize max
);
434 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist
);
435 static ffecomConcatList_
ffecom_concat_list_new_ (ffebld expr
,
436 ffetargetCharacterSize max
);
437 static void ffecom_debug_kludge_ (tree aggr
, char *aggr_type
, ffesymbol member
,
438 tree member_type
, ffetargetOffset offset
);
439 static void ffecom_do_entry_ (ffesymbol fn
, int entrynum
);
440 static tree
ffecom_expr_ (ffebld expr
, tree dest_tree
, ffebld dest
,
441 bool *dest_used
, bool assignp
, bool widenp
);
442 static tree
ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
443 ffebld dest
, bool *dest_used
);
444 static tree
ffecom_expr_power_integer_ (ffebld left
, ffebld right
);
445 static void ffecom_expr_transform_ (ffebld expr
);
446 static void ffecom_f2c_make_type_ (tree
*type
, int tcode
, char *name
);
447 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
449 static ffeglobal
ffecom_finish_global_ (ffeglobal global
);
450 static ffesymbol
ffecom_finish_symbol_transform_ (ffesymbol s
);
451 static tree
ffecom_get_appended_identifier_ (char us
, char *text
);
452 static tree
ffecom_get_external_identifier_ (ffesymbol s
);
453 static tree
ffecom_get_identifier_ (char *text
);
454 static tree
ffecom_gen_sfuncdef_ (ffesymbol s
,
457 static char *ffecom_gfrt_args_ (ffecomGfrt ix
);
458 static tree
ffecom_gfrt_tree_ (ffecomGfrt ix
);
459 static tree
ffecom_init_zero_ (tree decl
);
460 static tree
ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
462 static tree
ffecom_intrinsic_len_ (ffebld expr
);
463 static void ffecom_let_char_ (tree dest_tree
,
465 ffetargetCharacterSize dest_size
,
467 static void ffecom_make_gfrt_ (ffecomGfrt ix
);
468 static void ffecom_member_phase1_ (ffestorag mst
, ffestorag st
);
469 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
470 static void ffecom_member_phase2_ (ffestorag mst
, ffestorag st
);
472 static void ffecom_push_dummy_decls_ (ffebld dumlist
,
474 static void ffecom_start_progunit_ (void);
475 static ffesymbol
ffecom_sym_transform_ (ffesymbol s
);
476 static ffesymbol
ffecom_sym_transform_assign_ (ffesymbol s
);
477 static void ffecom_transform_common_ (ffesymbol s
);
478 static void ffecom_transform_equiv_ (ffestorag st
);
479 static tree
ffecom_transform_namelist_ (ffesymbol s
);
480 static void ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
482 static void ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
483 tree
*size
, tree tree
);
484 static tree
ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
485 tree dest_tree
, ffebld dest
,
487 static tree
ffecom_type_localvar_ (ffesymbol s
,
490 static tree
ffecom_type_namelist_ (void);
492 static tree
ffecom_type_permanent_copy_ (tree t
);
494 static tree
ffecom_type_vardesc_ (void);
495 static tree
ffecom_vardesc_ (ffebld expr
);
496 static tree
ffecom_vardesc_array_ (ffesymbol s
);
497 static tree
ffecom_vardesc_dims_ (ffesymbol s
);
498 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
500 /* These are static functions that parallel those found in the C front
501 end and thus have the same names. */
503 #if FFECOM_targetCURRENT == FFECOM_targetGCC
504 static void bison_rule_compstmt_ (void);
505 static void bison_rule_pushlevel_ (void);
506 static tree
builtin_function (char *name
, tree type
,
507 enum built_in_function function_code
,
509 static int duplicate_decls (tree newdecl
, tree olddecl
);
510 static void finish_decl (tree decl
, tree init
, bool is_top_level
);
511 static void finish_function (int nested
);
512 static char *lang_printable_name (tree decl
, int v
);
513 static tree
lookup_name_current_level (tree name
);
514 static struct binding_level
*make_binding_level (void);
515 static void pop_f_function_context (void);
516 static void push_f_function_context (void);
517 static void push_parm_decl (tree parm
);
518 static tree
pushdecl_top_level (tree decl
);
519 static tree
storedecls (tree decls
);
520 static void store_parm_decls (int is_main_program
);
521 static tree
start_decl (tree decl
, bool is_top_level
);
522 static void start_function (tree name
, tree type
, int nested
, int public);
523 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
524 #if FFECOM_GCC_INCLUDE
525 static void ffecom_file_ (char *name
);
526 static void ffecom_initialize_char_syntax_ (void);
527 static void ffecom_close_include_ (FILE *f
);
528 static int ffecom_decode_include_option_ (char *spec
);
529 static FILE *ffecom_open_include_ (char *name
, ffewhereLine l
,
531 #endif /* FFECOM_GCC_INCLUDE */
533 /* Static objects accessed by functions in this module. */
535 static ffesymbol ffecom_primary_entry_
= NULL
;
536 static ffesymbol ffecom_nested_entry_
= NULL
;
537 static ffeinfoKind ffecom_primary_entry_kind_
;
538 static bool ffecom_primary_entry_is_proc_
;
539 #if FFECOM_targetCURRENT == FFECOM_targetGCC
540 static tree ffecom_outer_function_decl_
;
541 static tree ffecom_previous_function_decl_
;
542 static tree ffecom_which_entrypoint_decl_
;
543 static ffecomTemp_ ffecom_latest_temp_
;
544 static int ffecom_pending_calls_
= 0;
545 static tree ffecom_float_zero_
= NULL_TREE
;
546 static tree ffecom_float_half_
= NULL_TREE
;
547 static tree ffecom_double_zero_
= NULL_TREE
;
548 static tree ffecom_double_half_
= NULL_TREE
;
549 static tree ffecom_func_result_
;/* For functions. */
550 static tree ffecom_func_length_
;/* For CHARACTER fns. */
551 static ffebld ffecom_list_blockdata_
;
552 static ffebld ffecom_list_common_
;
553 static ffebld ffecom_master_arglist_
;
554 static ffeinfoBasictype ffecom_master_bt_
;
555 static ffeinfoKindtype ffecom_master_kt_
;
556 static ffetargetCharacterSize ffecom_master_size_
;
557 static int ffecom_num_fns_
= 0;
558 static int ffecom_num_entrypoints_
= 0;
559 static bool ffecom_is_altreturning_
= FALSE
;
560 static tree ffecom_multi_type_node_
;
561 static tree ffecom_multi_retval_
;
563 ffecom_multi_fields_
[FFEINFO_basictype
][FFEINFO_kindtype
];
564 static bool ffecom_member_namelisted_
; /* _member_phase1_ namelisted? */
565 static bool ffecom_doing_entry_
= FALSE
;
566 static bool ffecom_transform_only_dummies_
= FALSE
;
568 /* Holds pointer-to-function expressions. */
570 static tree ffecom_gfrt_
[FFECOM_gfrt
]
573 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE,
574 #include "com-rt.def"
578 /* Holds the external names of the functions. */
580 static char *ffecom_gfrt_name_
[FFECOM_gfrt
]
583 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME,
584 #include "com-rt.def"
588 /* Whether the function returns. */
590 static bool ffecom_gfrt_volatile_
[FFECOM_gfrt
]
593 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE,
594 #include "com-rt.def"
598 /* Whether the function returns type complex. */
600 static bool ffecom_gfrt_complex_
[FFECOM_gfrt
]
603 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX,
604 #include "com-rt.def"
608 /* Type code for the function return value. */
610 static ffecomRttype_ ffecom_gfrt_type_
[FFECOM_gfrt
]
613 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE,
614 #include "com-rt.def"
618 /* String of codes for the function's arguments. */
620 static char *ffecom_gfrt_argstring_
[FFECOM_gfrt
]
623 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS,
624 #include "com-rt.def"
627 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
629 /* Internal macros. */
631 #if FFECOM_targetCURRENT == FFECOM_targetGCC
633 /* We let tm.h override the types used here, to handle trivial differences
634 such as the choice of unsigned int or long unsigned int for size_t.
635 When machines start needing nontrivial differences in the size type,
636 it would be best to do something here to figure out automatically
637 from other information what type to use. */
639 /* NOTE: g77 currently doesn't use these; see setting of sizetype and
640 change that if you need to. -- jcb 09/01/91. */
642 #define ffecom_concat_list_count_(catlist) ((catlist).count)
643 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
644 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
645 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
647 #define ffecom_start_compstmt_ bison_rule_pushlevel_
648 #define ffecom_end_compstmt_ bison_rule_compstmt_
650 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
651 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
653 /* For each binding contour we allocate a binding_level structure
654 * which records the names defined in that contour.
657 * 1) one for each function definition,
658 * where internal declarations of the parameters appear.
660 * The current meaning of a name can be found by searching the levels from
661 * the current one out to the global one.
664 /* Note that the information in the `names' component of the global contour
665 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
669 /* A chain of _DECL nodes for all variables, constants, functions, and
670 typedef types. These are in the reverse of the order supplied. */
673 /* For each level (except not the global one), a chain of BLOCK nodes for
674 all the levels that were entered and exited one level down. */
677 /* The BLOCK node for this level, if one has been preallocated. If 0, the
678 BLOCK is allocated (if needed) when the level is popped. */
681 /* The binding level which this one is contained in (inherits from). */
682 struct binding_level
*level_chain
;
685 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
687 /* The binding level currently in effect. */
689 static struct binding_level
*current_binding_level
;
691 /* A chain of binding_level structures awaiting reuse. */
693 static struct binding_level
*free_binding_level
;
695 /* The outermost binding level, for names of file scope.
696 This is created when the compiler is started and exists
697 through the entire run. */
699 static struct binding_level
*global_binding_level
;
701 /* Binding level structures are initialized by copying this one. */
703 static struct binding_level clear_binding_level
705 {NULL
, NULL
, NULL
, NULL_BINDING_LEVEL
};
707 /* Language-dependent contents of an identifier. */
709 struct lang_identifier
711 struct tree_identifier ignore
;
712 tree global_value
, local_value
, label_value
;
716 /* Macros for access to language-specific slots in an identifier. */
717 /* Each of these slots contains a DECL node or null. */
719 /* This represents the value which the identifier has in the
720 file-scope namespace. */
721 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
722 (((struct lang_identifier *)(NODE))->global_value)
723 /* This represents the value which the identifier has in the current
725 #define IDENTIFIER_LOCAL_VALUE(NODE) \
726 (((struct lang_identifier *)(NODE))->local_value)
727 /* This represents the value which the identifier has as a label in
728 the current label scope. */
729 #define IDENTIFIER_LABEL_VALUE(NODE) \
730 (((struct lang_identifier *)(NODE))->label_value)
731 /* This is nonzero if the identifier was "made up" by g77 code. */
732 #define IDENTIFIER_INVENTED(NODE) \
733 (((struct lang_identifier *)(NODE))->invented)
735 /* In identifiers, C uses the following fields in a special way:
736 TREE_PUBLIC to record that there was a previous local extern decl.
737 TREE_USED to record that such a decl was used.
738 TREE_ADDRESSABLE to record that the address of such a decl was used. */
740 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
741 that have names. Here so we can clear out their names' definitions
742 at the end of the function. */
744 static tree named_labels
;
746 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
748 static tree shadowed_labels
;
750 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
753 /* This is like gcc's stabilize_reference -- in fact, most of the code
754 comes from that -- but it handles the situation where the reference
755 is going to have its subparts picked at, and it shouldn't change
756 (or trigger extra invocations of functions in the subtrees) due to
757 this. save_expr is a bit overzealous, because we don't need the
758 entire thing calculated and saved like a temp. So, for DECLs, no
759 change is needed, because these are stable aggregates, and ARRAY_REF
760 and such might well be stable too, but for things like calculations,
761 we do need to calculate a snapshot of a value before picking at it. */
763 #if FFECOM_targetCURRENT == FFECOM_targetGCC
765 ffecom_stabilize_aggregate_ (tree ref
)
768 enum tree_code code
= TREE_CODE (ref
);
775 /* No action is needed in this case. */
785 result
= build_nt (code
, stabilize_reference (TREE_OPERAND (ref
, 0)));
789 result
= build_nt (INDIRECT_REF
,
790 stabilize_reference_1 (TREE_OPERAND (ref
, 0)));
794 result
= build_nt (COMPONENT_REF
,
795 stabilize_reference (TREE_OPERAND (ref
, 0)),
796 TREE_OPERAND (ref
, 1));
800 result
= build_nt (BIT_FIELD_REF
,
801 stabilize_reference (TREE_OPERAND (ref
, 0)),
802 stabilize_reference_1 (TREE_OPERAND (ref
, 1)),
803 stabilize_reference_1 (TREE_OPERAND (ref
, 2)));
807 result
= build_nt (ARRAY_REF
,
808 stabilize_reference (TREE_OPERAND (ref
, 0)),
809 stabilize_reference_1 (TREE_OPERAND (ref
, 1)));
813 result
= build_nt (COMPOUND_EXPR
,
814 stabilize_reference_1 (TREE_OPERAND (ref
, 0)),
815 stabilize_reference (TREE_OPERAND (ref
, 1)));
819 result
= build1 (INDIRECT_REF
, TREE_TYPE (ref
),
820 save_expr (build1 (ADDR_EXPR
,
821 build_pointer_type (TREE_TYPE (ref
)),
827 return save_expr (ref
);
830 return error_mark_node
;
833 TREE_TYPE (result
) = TREE_TYPE (ref
);
834 TREE_READONLY (result
) = TREE_READONLY (ref
);
835 TREE_SIDE_EFFECTS (result
) = TREE_SIDE_EFFECTS (ref
);
836 TREE_THIS_VOLATILE (result
) = TREE_THIS_VOLATILE (ref
);
837 TREE_RAISES (result
) = TREE_RAISES (ref
);
843 /* A rip-off of gcc's convert.c convert_to_complex function,
844 reworked to handle complex implemented as C structures
845 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
847 #if FFECOM_targetCURRENT == FFECOM_targetGCC
849 ffecom_convert_to_complex_ (tree type
, tree expr
)
851 register enum tree_code form
= TREE_CODE (TREE_TYPE (expr
));
854 assert (TREE_CODE (type
) == RECORD_TYPE
);
856 subtype
= TREE_TYPE (TYPE_FIELDS (type
));
858 if (form
== REAL_TYPE
|| form
== INTEGER_TYPE
|| form
== ENUMERAL_TYPE
)
860 expr
= convert (subtype
, expr
);
861 return ffecom_2 (COMPLEX_EXPR
, type
, expr
,
862 convert (subtype
, integer_zero_node
));
865 if (form
== RECORD_TYPE
)
867 tree elt_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
)));
868 if (TYPE_MAIN_VARIANT (elt_type
) == TYPE_MAIN_VARIANT (subtype
))
872 expr
= save_expr (expr
);
873 return ffecom_2 (COMPLEX_EXPR
,
876 ffecom_1 (REALPART_EXPR
,
877 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
880 ffecom_1 (IMAGPART_EXPR
,
881 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
886 if (form
== POINTER_TYPE
|| form
== REFERENCE_TYPE
)
887 error ("pointer value used where a complex was expected");
889 error ("aggregate value used where a complex was expected");
891 return ffecom_2 (COMPLEX_EXPR
, type
,
892 convert (subtype
, integer_zero_node
),
893 convert (subtype
, integer_zero_node
));
897 /* Like gcc's convert(), but crashes if widening might happen. */
899 #if FFECOM_targetCURRENT == FFECOM_targetGCC
901 ffecom_convert_narrow_ (type
, expr
)
904 register tree e
= expr
;
905 register enum tree_code code
= TREE_CODE (type
);
907 if (type
== TREE_TYPE (e
)
908 || TREE_CODE (e
) == ERROR_MARK
)
910 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
911 return fold (build1 (NOP_EXPR
, type
, e
));
912 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
913 || code
== ERROR_MARK
)
914 return error_mark_node
;
915 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
917 assert ("void value not ignored as it ought to be" == NULL
);
918 return error_mark_node
;
920 assert (code
!= VOID_TYPE
);
921 if ((code
!= RECORD_TYPE
)
922 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
923 assert ("converting COMPLEX to REAL" == NULL
);
924 assert (code
!= ENUMERAL_TYPE
);
925 if (code
== INTEGER_TYPE
)
927 assert (TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
);
928 assert (TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)));
929 return fold (convert_to_integer (type
, e
));
931 if (code
== POINTER_TYPE
)
933 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
934 return fold (convert_to_pointer (type
, e
));
936 if (code
== REAL_TYPE
)
938 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
939 assert (TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)));
940 return fold (convert_to_real (type
, e
));
942 if (code
== COMPLEX_TYPE
)
944 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
945 assert (TYPE_PRECISION (TREE_TYPE (type
)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
946 return fold (convert_to_complex (type
, e
));
948 if (code
== RECORD_TYPE
)
950 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
951 /* Check that at least the first field name agrees. */
952 assert (DECL_NAME (TYPE_FIELDS (type
))
953 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e
))));
954 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
955 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
956 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
957 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))))
959 return fold (ffecom_convert_to_complex_ (type
, e
));
962 assert ("conversion to non-scalar type requested" == NULL
);
963 return error_mark_node
;
967 /* Like gcc's convert(), but crashes if narrowing might happen. */
969 #if FFECOM_targetCURRENT == FFECOM_targetGCC
971 ffecom_convert_widen_ (type
, expr
)
974 register tree e
= expr
;
975 register enum tree_code code
= TREE_CODE (type
);
977 if (type
== TREE_TYPE (e
)
978 || TREE_CODE (e
) == ERROR_MARK
)
980 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
981 return fold (build1 (NOP_EXPR
, type
, e
));
982 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
983 || code
== ERROR_MARK
)
984 return error_mark_node
;
985 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
987 assert ("void value not ignored as it ought to be" == NULL
);
988 return error_mark_node
;
990 assert (code
!= VOID_TYPE
);
991 if ((code
!= RECORD_TYPE
)
992 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
993 assert ("narrowing COMPLEX to REAL" == NULL
);
994 assert (code
!= ENUMERAL_TYPE
);
995 if (code
== INTEGER_TYPE
)
997 assert (TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
);
998 assert (TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)));
999 return fold (convert_to_integer (type
, e
));
1001 if (code
== POINTER_TYPE
)
1003 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1004 return fold (convert_to_pointer (type
, e
));
1006 if (code
== REAL_TYPE
)
1008 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1009 assert (TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)));
1010 return fold (convert_to_real (type
, e
));
1012 if (code
== COMPLEX_TYPE
)
1014 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1015 assert (TYPE_PRECISION (TREE_TYPE (type
)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1016 return fold (convert_to_complex (type
, e
));
1018 if (code
== RECORD_TYPE
)
1020 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1021 /* Check that at least the first field name agrees. */
1022 assert (DECL_NAME (TYPE_FIELDS (type
))
1023 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e
))));
1024 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1025 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1026 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1027 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))))
1029 return fold (ffecom_convert_to_complex_ (type
, e
));
1032 assert ("conversion to non-scalar type requested" == NULL
);
1033 return error_mark_node
;
1037 /* Handles making a COMPLEX type, either the standard
1038 (but buggy?) gbe way, or the safer (but less elegant?)
1041 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1043 ffecom_make_complex_type_ (tree subtype
)
1049 if (ffe_is_emulate_complex ())
1051 type
= make_node (RECORD_TYPE
);
1052 realfield
= ffecom_decl_field (type
, NULL_TREE
, "r", subtype
);
1053 imagfield
= ffecom_decl_field (type
, realfield
, "i", subtype
);
1054 TYPE_FIELDS (type
) = realfield
;
1059 type
= make_node (COMPLEX_TYPE
);
1060 TREE_TYPE (type
) = subtype
;
1068 /* Chooses either the gbe or the f2c way to build a
1069 complex constant. */
1071 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1073 ffecom_build_complex_constant_ (tree type
, tree realpart
, tree imagpart
)
1077 if (ffe_is_emulate_complex ())
1079 bothparts
= build_tree_list (TYPE_FIELDS (type
), realpart
);
1080 TREE_CHAIN (bothparts
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), imagpart
);
1081 bothparts
= build (CONSTRUCTOR
, type
, NULL_TREE
, bothparts
);
1085 bothparts
= build_complex (type
, realpart
, imagpart
);
1092 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1094 ffecom_arglist_expr_ (char *c
, ffebld expr
)
1097 tree
*plist
= &list
;
1098 tree trail
= NULL_TREE
; /* Append char length args here. */
1099 tree
*ptrail
= &trail
;
1104 tree wanted
= NULL_TREE
;
1105 static char zed
[] = "0";
1110 while (expr
!= NULL
)
1133 wanted
= ffecom_f2c_complex_type_node
;
1137 wanted
= ffecom_f2c_doublereal_type_node
;
1141 wanted
= ffecom_f2c_doublecomplex_type_node
;
1145 wanted
= ffecom_f2c_real_type_node
;
1149 wanted
= ffecom_f2c_integer_type_node
;
1153 wanted
= ffecom_f2c_longint_type_node
;
1157 assert ("bad argstring code" == NULL
);
1163 exprh
= ffebld_head (expr
);
1167 if ((wanted
== NULL_TREE
)
1170 (ffecom_tree_type
[ffeinfo_basictype (ffebld_info (exprh
))]
1171 [ffeinfo_kindtype (ffebld_info (exprh
))])
1172 == TYPE_MODE (wanted
))))
1174 = build_tree_list (NULL_TREE
,
1175 ffecom_arg_ptr_to_expr (exprh
,
1179 item
= ffecom_arg_expr (exprh
, &length
);
1180 item
= ffecom_convert_widen_ (wanted
, item
);
1183 item
= ffecom_1 (ADDR_EXPR
,
1184 build_pointer_type (TREE_TYPE (item
)),
1188 = build_tree_list (NULL_TREE
,
1192 plist
= &TREE_CHAIN (*plist
);
1193 expr
= ffebld_trail (expr
);
1194 if (length
!= NULL_TREE
)
1196 *ptrail
= build_tree_list (NULL_TREE
, length
);
1197 ptrail
= &TREE_CHAIN (*ptrail
);
1201 /* We've run out of args in the call; if the implementation expects
1202 more, supply null pointers for them, which the implementation can
1203 check to see if an arg was omitted. */
1205 while (*c
!= '\0' && *c
!= '0')
1210 assert ("missing arg to run-time routine!" == NULL
);
1225 assert ("bad arg string code" == NULL
);
1229 = build_tree_list (NULL_TREE
,
1231 plist
= &TREE_CHAIN (*plist
);
1240 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1242 ffecom_widest_expr_type_ (ffebld list
)
1245 ffebld widest
= NULL
;
1247 ffetype widest_type
= NULL
;
1250 for (; list
!= NULL
; list
= ffebld_trail (list
))
1252 item
= ffebld_head (list
);
1255 if ((widest
!= NULL
)
1256 && (ffeinfo_basictype (ffebld_info (item
))
1257 != ffeinfo_basictype (ffebld_info (widest
))))
1259 type
= ffeinfo_type (ffeinfo_basictype (ffebld_info (item
)),
1260 ffeinfo_kindtype (ffebld_info (item
)));
1261 if ((widest
== FFEINFO_kindtypeNONE
)
1262 || (ffetype_size (type
)
1263 > ffetype_size (widest_type
)))
1270 assert (widest
!= NULL
);
1271 t
= ffecom_tree_type
[ffeinfo_basictype (ffebld_info (widest
))]
1272 [ffeinfo_kindtype (ffebld_info (widest
))];
1273 assert (t
!= NULL_TREE
);
1278 /* Check whether dest and source might overlap. ffebld versions of these
1279 might or might not be passed, will be NULL if not.
1281 The test is really whether source_tree is modifiable and, if modified,
1282 might overlap destination such that the value(s) in the destination might
1283 change before it is finally modified. dest_* are the canonized
1284 destination itself. */
1286 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1288 ffecom_overlap_ (tree dest_decl
, tree dest_offset
, tree dest_size
,
1289 tree source_tree
, ffebld source UNUSED
,
1297 if (source_tree
== NULL_TREE
)
1300 switch (TREE_CODE (source_tree
))
1303 case IDENTIFIER_NODE
:
1314 case TRUNC_DIV_EXPR
:
1316 case FLOOR_DIV_EXPR
:
1317 case ROUND_DIV_EXPR
:
1318 case TRUNC_MOD_EXPR
:
1320 case FLOOR_MOD_EXPR
:
1321 case ROUND_MOD_EXPR
:
1323 case EXACT_DIV_EXPR
:
1324 case FIX_TRUNC_EXPR
:
1326 case FIX_FLOOR_EXPR
:
1327 case FIX_ROUND_EXPR
:
1342 case BIT_ANDTC_EXPR
:
1344 case TRUTH_ANDIF_EXPR
:
1345 case TRUTH_ORIF_EXPR
:
1346 case TRUTH_AND_EXPR
:
1348 case TRUTH_XOR_EXPR
:
1349 case TRUTH_NOT_EXPR
:
1365 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1366 TREE_OPERAND (source_tree
, 1), NULL
,
1370 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1371 TREE_OPERAND (source_tree
, 0), NULL
,
1376 case NON_LVALUE_EXPR
:
1378 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1381 ffecom_tree_canonize_ptr_ (&source_decl
, &source_offset
,
1383 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1388 ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1389 TREE_OPERAND (source_tree
, 1), NULL
,
1391 || ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1392 TREE_OPERAND (source_tree
, 2), NULL
,
1397 ffecom_tree_canonize_ref_ (&source_decl
, &source_offset
,
1399 TREE_OPERAND (source_tree
, 0));
1403 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1406 source_decl
= source_tree
;
1407 source_offset
= size_zero_node
;
1408 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1412 case REFERENCE_EXPR
:
1413 case PREDECREMENT_EXPR
:
1414 case PREINCREMENT_EXPR
:
1415 case POSTDECREMENT_EXPR
:
1416 case POSTINCREMENT_EXPR
:
1424 /* Come here when source_decl, source_offset, and source_size filled
1425 in appropriately. */
1427 if (source_decl
== NULL_TREE
)
1428 return FALSE
; /* No decl involved, so no overlap. */
1430 if (source_decl
!= dest_decl
)
1431 return FALSE
; /* Different decl, no overlap. */
1433 if (TREE_CODE (dest_size
) == ERROR_MARK
)
1434 return TRUE
; /* Assignment into entire assumed-size
1435 array? Shouldn't happen.... */
1437 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1438 ffecom_2 (PLUS_EXPR
, TREE_TYPE (dest_offset
),
1440 convert (TREE_TYPE (dest_offset
),
1442 convert (TREE_TYPE (dest_offset
),
1445 if (integer_onep (t
))
1446 return FALSE
; /* Destination precedes source. */
1449 || (source_size
== NULL_TREE
)
1450 || (TREE_CODE (source_size
) == ERROR_MARK
)
1451 || integer_zerop (source_size
))
1452 return TRUE
; /* No way to tell if dest follows source. */
1454 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1455 ffecom_2 (PLUS_EXPR
, TREE_TYPE (source_offset
),
1457 convert (TREE_TYPE (source_offset
),
1459 convert (TREE_TYPE (source_offset
),
1462 if (integer_onep (t
))
1463 return FALSE
; /* Destination follows source. */
1465 return TRUE
; /* Destination and source overlap. */
1469 /* Check whether dest might overlap any of a list of arguments or is
1470 in a COMMON area the callee might know about (and thus modify). */
1472 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1474 ffecom_args_overlapping_ (tree dest_tree
, ffebld dest UNUSED
,
1475 tree args
, tree callee_commons
,
1483 ffecom_tree_canonize_ref_ (&dest_decl
, &dest_offset
, &dest_size
,
1486 if (dest_decl
== NULL_TREE
)
1487 return FALSE
; /* Seems unlikely! */
1489 /* If the decl cannot be determined reliably, or if its in COMMON
1490 and the callee isn't known to not futz with COMMON via other
1491 means, overlap might happen. */
1493 if ((TREE_CODE (dest_decl
) == ERROR_MARK
)
1494 || ((callee_commons
!= NULL_TREE
)
1495 && TREE_PUBLIC (dest_decl
)))
1498 for (; args
!= NULL_TREE
; args
= TREE_CHAIN (args
))
1500 if (((arg
= TREE_VALUE (args
)) != NULL_TREE
)
1501 && ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1502 arg
, NULL
, scalar_args
))
1510 /* Build a string for a variable name as used by NAMELIST. This means that
1511 if we're using the f2c library, we build an uppercase string, since
1514 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1516 ffecom_build_f2c_string_ (int i
, char *s
)
1518 if (!ffe_is_f2c_library ())
1519 return build_string (i
, s
);
1528 if (((size_t) i
) > ARRAY_SIZE (space
))
1529 tmp
= malloc_new_ks (malloc_pool_image (), "f2c_string", i
);
1533 for (p
= s
, q
= tmp
; *p
!= '\0'; ++p
, ++q
)
1534 *q
= ffesrc_toupper (*p
);
1537 t
= build_string (i
, tmp
);
1539 if (((size_t) i
) > ARRAY_SIZE (space
))
1540 malloc_kill_ks (malloc_pool_image (), tmp
, i
);
1547 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1548 type to just get whatever the function returns), handling the
1549 f2c value-returning convention, if required, by prepending
1550 to the arglist a pointer to a temporary to receive the return value. */
1552 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1554 ffecom_call_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1555 tree type
, tree args
, tree dest_tree
,
1556 ffebld dest
, bool *dest_used
, tree callee_commons
,
1562 if (dest_used
!= NULL
)
1567 if ((dest_used
== NULL
)
1569 || (ffeinfo_basictype (ffebld_info (dest
))
1570 != FFEINFO_basictypeCOMPLEX
)
1571 || (ffeinfo_kindtype (ffebld_info (dest
)) != kt
)
1572 || ((type
!= NULL_TREE
) && (TREE_TYPE (dest_tree
) != type
))
1573 || ffecom_args_overlapping_ (dest_tree
, dest
, args
,
1577 tempvar
= ffecom_push_tempvar (ffecom_tree_type
1578 [FFEINFO_basictypeCOMPLEX
][kt
],
1579 FFETARGET_charactersizeNONE
,
1585 tempvar
= dest_tree
;
1590 = build_tree_list (NULL_TREE
,
1591 ffecom_1 (ADDR_EXPR
,
1592 build_pointer_type (TREE_TYPE (tempvar
)),
1594 TREE_CHAIN (item
) = args
;
1596 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1599 if (tempvar
!= dest_tree
)
1600 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
, tempvar
);
1603 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1606 if ((type
!= NULL_TREE
) && (TREE_TYPE (item
) != type
))
1607 item
= ffecom_convert_narrow_ (type
, item
);
1613 /* Given two arguments, transform them and make a call to the given
1614 function via ffecom_call_. */
1616 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1618 ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1619 tree type
, ffebld left
, ffebld right
,
1620 tree dest_tree
, ffebld dest
, bool *dest_used
,
1621 tree callee_commons
, bool scalar_args
)
1628 ffecom_push_calltemps ();
1629 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
1630 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
1631 ffecom_pop_calltemps ();
1633 left_tree
= build_tree_list (NULL_TREE
, left_tree
);
1634 right_tree
= build_tree_list (NULL_TREE
, right_tree
);
1635 TREE_CHAIN (left_tree
) = right_tree
;
1637 if (left_length
!= NULL_TREE
)
1639 left_length
= build_tree_list (NULL_TREE
, left_length
);
1640 TREE_CHAIN (right_tree
) = left_length
;
1643 if (right_length
!= NULL_TREE
)
1645 right_length
= build_tree_list (NULL_TREE
, right_length
);
1646 if (left_length
!= NULL_TREE
)
1647 TREE_CHAIN (left_length
) = right_length
;
1649 TREE_CHAIN (right_tree
) = right_length
;
1652 return ffecom_call_ (fn
, kt
, is_f2c_complex
, type
, left_tree
,
1653 dest_tree
, dest
, dest_used
, callee_commons
,
1658 /* ffecom_char_args_x_ -- Return ptr/length args for char subexpression
1664 ffecom_char_args_x_(&ptr_arg,&length_arg,expr,with_null);
1666 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1667 subexpressions by constructing the appropriate trees for the ptr-to-
1668 character-text and length-of-character-text arguments in a calling
1671 Note that if with_null is TRUE, and the expression is an opCONTER,
1672 a null byte is appended to the string. */
1674 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1676 ffecom_char_args_x_ (tree
*xitem
, tree
*length
, ffebld expr
, bool with_null
)
1680 ffetargetCharacter1 val
;
1681 ffetargetCharacterSize newlen
;
1683 switch (ffebld_op (expr
))
1685 case FFEBLD_opCONTER
:
1686 val
= ffebld_constant_character1 (ffebld_conter (expr
));
1687 newlen
= ffetarget_length_character1 (val
);
1691 ++newlen
; /* begin FFETARGET-NULL-KLUDGE. */
1693 *length
= build_int_2 (newlen
, 0);
1694 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1695 high
= build_int_2 (newlen
, 0);
1696 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
1697 item
= build_string (newlen
, /* end FFETARGET-NULL-KLUDGE. */
1698 ffetarget_text_character1 (val
));
1700 = build_type_variant
1704 (ffecom_f2c_ftnlen_type_node
,
1705 ffecom_f2c_ftnlen_one_node
,
1708 TREE_CONSTANT (item
) = 1;
1709 TREE_STATIC (item
) = 1;
1710 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
1714 case FFEBLD_opSYMTER
:
1716 ffesymbol s
= ffebld_symter (expr
);
1718 item
= ffesymbol_hook (s
).decl_tree
;
1719 if (item
== NULL_TREE
)
1721 s
= ffecom_sym_transform_ (s
);
1722 item
= ffesymbol_hook (s
).decl_tree
;
1724 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
1726 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
1727 *length
= ffesymbol_hook (s
).length_tree
;
1730 *length
= build_int_2 (ffesymbol_size (s
), 0);
1731 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1734 else if (item
== error_mark_node
)
1735 *length
= error_mark_node
;
1736 else /* FFEINFO_kindFUNCTION: */
1737 *length
= NULL_TREE
;
1738 if (!ffesymbol_hook (s
).addr
1739 && (item
!= error_mark_node
))
1740 item
= ffecom_1 (ADDR_EXPR
,
1741 build_pointer_type (TREE_TYPE (item
)),
1746 case FFEBLD_opARRAYREF
:
1748 ffebld dims
[FFECOM_dimensionsMAX
];
1752 ffecom_push_calltemps ();
1753 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1754 ffecom_pop_calltemps ();
1756 if (item
== error_mark_node
|| *length
== error_mark_node
)
1758 item
= *length
= error_mark_node
;
1762 /* Build up ARRAY_REFs in reverse order (since we're column major
1763 here in Fortran land). */
1765 for (i
= 0, expr
= ffebld_right (expr
);
1767 expr
= ffebld_trail (expr
))
1768 dims
[i
++] = ffebld_head (expr
);
1770 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
1772 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
1774 item
= ffecom_2 (PLUS_EXPR
, build_pointer_type (TREE_TYPE (array
)),
1776 size_binop (MULT_EXPR
,
1777 size_in_bytes (TREE_TYPE (array
)),
1778 size_binop (MINUS_EXPR
,
1779 ffecom_expr (dims
[i
]),
1780 TYPE_MIN_VALUE (TYPE_DOMAIN (array
)))));
1785 case FFEBLD_opSUBSTR
:
1789 ffebld thing
= ffebld_right (expr
);
1793 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
1794 start
= ffebld_head (thing
);
1795 thing
= ffebld_trail (thing
);
1796 assert (ffebld_trail (thing
) == NULL
);
1797 end
= ffebld_head (thing
);
1799 ffecom_push_calltemps ();
1800 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1801 ffecom_pop_calltemps ();
1803 if (item
== error_mark_node
|| *length
== error_mark_node
)
1805 item
= *length
= error_mark_node
;
1815 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
1818 if (end_tree
== error_mark_node
)
1820 item
= *length
= error_mark_node
;
1829 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
1830 ffecom_expr (start
));
1832 if (start_tree
== error_mark_node
)
1834 item
= *length
= error_mark_node
;
1838 start_tree
= ffecom_save_tree (start_tree
);
1840 item
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (item
),
1842 ffecom_2 (MINUS_EXPR
,
1843 TREE_TYPE (start_tree
),
1845 ffecom_f2c_ftnlen_one_node
));
1849 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
1850 ffecom_f2c_ftnlen_one_node
,
1851 ffecom_2 (MINUS_EXPR
,
1852 ffecom_f2c_ftnlen_type_node
,
1858 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
1861 if (end_tree
== error_mark_node
)
1863 item
= *length
= error_mark_node
;
1867 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
1868 ffecom_f2c_ftnlen_one_node
,
1869 ffecom_2 (MINUS_EXPR
,
1870 ffecom_f2c_ftnlen_type_node
,
1871 end_tree
, start_tree
));
1877 case FFEBLD_opFUNCREF
:
1879 ffesymbol s
= ffebld_symter (ffebld_left (expr
));
1882 ffetargetCharacterSize size
= ffeinfo_size (ffebld_info (expr
));
1885 if (size
== FFETARGET_charactersizeNONE
)
1886 size
= 24; /* ~~~~ Kludge alert! This should someday be fixed. */
1888 *length
= build_int_2 (size
, 0);
1889 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1891 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
1892 == FFEINFO_whereINTRINSIC
)
1895 { /* Invocation of an intrinsic returning CHARACTER*1. */
1896 item
= ffecom_expr_intrinsic_ (expr
, NULL_TREE
,
1900 ix
= ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr
)));
1901 assert (ix
!= FFECOM_gfrt
);
1902 item
= ffecom_gfrt_tree_ (ix
);
1907 item
= ffesymbol_hook (s
).decl_tree
;
1908 if (item
== NULL_TREE
)
1910 s
= ffecom_sym_transform_ (s
);
1911 item
= ffesymbol_hook (s
).decl_tree
;
1913 if (item
== error_mark_node
)
1915 item
= *length
= error_mark_node
;
1919 if (!ffesymbol_hook (s
).addr
)
1920 item
= ffecom_1_fn (item
);
1923 assert (ffecom_pending_calls_
!= 0);
1924 tempvar
= ffecom_push_tempvar (char_type_node
, size
, -1, TRUE
);
1925 tempvar
= ffecom_1 (ADDR_EXPR
,
1926 build_pointer_type (TREE_TYPE (tempvar
)),
1929 ffecom_push_calltemps ();
1931 args
= build_tree_list (NULL_TREE
, tempvar
);
1933 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
) /* Sfunc args by value. */
1934 TREE_CHAIN (args
) = ffecom_list_expr (ffebld_right (expr
));
1937 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, *length
);
1938 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
1940 TREE_CHAIN (TREE_CHAIN (args
))
1941 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix
),
1942 ffebld_right (expr
));
1946 TREE_CHAIN (TREE_CHAIN (args
))
1947 = ffecom_list_ptr_to_expr (ffebld_right (expr
));
1951 item
= ffecom_3s (CALL_EXPR
,
1952 TREE_TYPE (TREE_TYPE (TREE_TYPE (item
))),
1953 item
, args
, NULL_TREE
);
1954 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
,
1957 ffecom_pop_calltemps ();
1961 case FFEBLD_opCONVERT
:
1963 ffecom_push_calltemps ();
1964 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1965 ffecom_pop_calltemps ();
1967 if (item
== error_mark_node
|| *length
== error_mark_node
)
1969 item
= *length
= error_mark_node
;
1973 if ((ffebld_size_known (ffebld_left (expr
))
1974 == FFETARGET_charactersizeNONE
)
1975 || (ffebld_size_known (ffebld_left (expr
)) < (ffebld_size (expr
))))
1976 { /* Possible blank-padding needed, copy into
1982 assert (ffecom_pending_calls_
!= 0);
1983 tempvar
= ffecom_push_tempvar (char_type_node
,
1984 ffebld_size (expr
), -1, TRUE
);
1985 tempvar
= ffecom_1 (ADDR_EXPR
,
1986 build_pointer_type (TREE_TYPE (tempvar
)),
1989 newlen
= build_int_2 (ffebld_size (expr
), 0);
1990 TREE_TYPE (newlen
) = ffecom_f2c_ftnlen_type_node
;
1992 args
= build_tree_list (NULL_TREE
, tempvar
);
1993 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, item
);
1994 TREE_CHAIN (TREE_CHAIN (args
)) = build_tree_list (NULL_TREE
, newlen
);
1995 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args
)))
1996 = build_tree_list (NULL_TREE
, *length
);
1998 item
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, args
);
1999 TREE_SIDE_EFFECTS (item
) = 1;
2000 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), fold (item
),
2005 { /* Just truncate the length. */
2006 *length
= build_int_2 (ffebld_size (expr
), 0);
2007 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2012 assert ("bad op for single char arg expr" == NULL
);
2021 /* Check the size of the type to be sure it doesn't overflow the
2022 "portable" capacities of the compiler back end. `dummy' types
2023 can generally overflow the normal sizes as long as the computations
2024 themselves don't overflow. A particular target of the back end
2025 must still enforce its size requirements, though, and the back
2026 end takes care of this in stor-layout.c. */
2028 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2030 ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
)
2032 if (TREE_CODE (type
) == ERROR_MARK
)
2035 if (TYPE_SIZE (type
) == NULL_TREE
)
2038 if (TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
)
2041 if ((tree_int_cst_sgn (TYPE_SIZE (type
)) < 0)
2042 || (!dummy
&& (((TREE_INT_CST_HIGH (TYPE_SIZE (type
)) != 0))
2043 || TREE_OVERFLOW (TYPE_SIZE (type
)))))
2045 ffebad_start (FFEBAD_ARRAY_LARGE
);
2046 ffebad_string (ffesymbol_text (s
));
2047 ffebad_here (0, ffesymbol_where_line (s
), ffesymbol_where_column (s
));
2050 return error_mark_node
;
2057 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2058 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2059 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2061 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2063 ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
)
2065 ffetargetCharacterSize sz
= ffesymbol_size (s
);
2070 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
2071 tlen
= NULL_TREE
; /* A statement function, no length passed. */
2074 if (ffesymbol_where (s
) == FFEINFO_whereDUMMY
)
2075 tlen
= ffecom_get_invented_identifier ("__g77_length_%s",
2076 ffesymbol_text (s
), 0);
2078 tlen
= ffecom_get_invented_identifier ("__g77_%s",
2080 tlen
= build_decl (PARM_DECL
, tlen
, ffecom_f2c_ftnlen_type_node
);
2082 DECL_ARTIFICIAL (tlen
) = 1;
2086 if (sz
== FFETARGET_charactersizeNONE
)
2088 assert (tlen
!= NULL_TREE
);
2089 highval
= variable_size (tlen
);
2093 highval
= build_int_2 (sz
, 0);
2094 TREE_TYPE (highval
) = ffecom_f2c_ftnlen_type_node
;
2097 type
= build_array_type (type
,
2098 build_range_type (ffecom_f2c_ftnlen_type_node
,
2099 ffecom_f2c_ftnlen_one_node
,
2107 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2109 ffecomConcatList_ catlist;
2110 ffebld expr; // expr of CHARACTER basictype.
2111 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2112 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2114 Scans expr for character subexpressions, updates and returns catlist
2117 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2118 static ffecomConcatList_
2119 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
, ffebld expr
,
2120 ffetargetCharacterSize max
)
2122 ffetargetCharacterSize sz
;
2124 recurse
: /* :::::::::::::::::::: */
2129 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
>= max
))
2130 return catlist
; /* Don't append any more items. */
2132 switch (ffebld_op (expr
))
2134 case FFEBLD_opCONTER
:
2135 case FFEBLD_opSYMTER
:
2136 case FFEBLD_opARRAYREF
:
2137 case FFEBLD_opFUNCREF
:
2138 case FFEBLD_opSUBSTR
:
2139 case FFEBLD_opCONVERT
: /* Callers should strip this off beforehand
2140 if they don't need to preserve it. */
2141 if (catlist
.count
== catlist
.max
)
2142 { /* Make a (larger) list. */
2146 newmax
= (catlist
.max
== 0) ? 8 : catlist
.max
* 2;
2147 newx
= malloc_new_ks (malloc_pool_image (), "catlist",
2148 newmax
* sizeof (newx
[0]));
2149 if (catlist
.max
!= 0)
2151 memcpy (newx
, catlist
.exprs
, catlist
.max
* sizeof (newx
[0]));
2152 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2153 catlist
.max
* sizeof (newx
[0]));
2155 catlist
.max
= newmax
;
2156 catlist
.exprs
= newx
;
2158 if ((sz
= ffebld_size_known (expr
)) != FFETARGET_charactersizeNONE
)
2159 catlist
.minlen
+= sz
;
2161 ++catlist
.minlen
; /* Not true for F90; can be 0 length. */
2162 if ((sz
= ffebld_size_max (expr
)) == FFETARGET_charactersizeNONE
)
2163 catlist
.maxlen
= sz
;
2165 catlist
.maxlen
+= sz
;
2166 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
> max
))
2167 { /* This item overlaps (or is beyond) the end
2168 of the destination. */
2169 switch (ffebld_op (expr
))
2171 case FFEBLD_opCONTER
:
2172 case FFEBLD_opSYMTER
:
2173 case FFEBLD_opARRAYREF
:
2174 case FFEBLD_opFUNCREF
:
2175 case FFEBLD_opSUBSTR
:
2176 break; /* ~~Do useful truncations here. */
2179 assert ("op changed or inconsistent switches!" == NULL
);
2183 catlist
.exprs
[catlist
.count
++] = expr
;
2186 case FFEBLD_opPAREN
:
2187 expr
= ffebld_left (expr
);
2188 goto recurse
; /* :::::::::::::::::::: */
2190 case FFEBLD_opCONCATENATE
:
2191 catlist
= ffecom_concat_list_gather_ (catlist
, ffebld_left (expr
), max
);
2192 expr
= ffebld_right (expr
);
2193 goto recurse
; /* :::::::::::::::::::: */
2195 #if 0 /* Breaks passing small actual arg to larger
2196 dummy arg of sfunc */
2197 case FFEBLD_opCONVERT
:
2198 expr
= ffebld_left (expr
);
2200 ffetargetCharacterSize cmax
;
2202 cmax
= catlist
.len
+ ffebld_size_known (expr
);
2204 if ((max
== FFETARGET_charactersizeNONE
) || (max
> cmax
))
2207 goto recurse
; /* :::::::::::::::::::: */
2214 assert ("bad op in _gather_" == NULL
);
2220 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2222 ffecomConcatList_ catlist;
2223 ffecom_concat_list_kill_(catlist);
2225 Anything allocated within the list info is deallocated. */
2227 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2229 ffecom_concat_list_kill_ (ffecomConcatList_ catlist
)
2231 if (catlist
.max
!= 0)
2232 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2233 catlist
.max
* sizeof (catlist
.exprs
[0]));
2237 /* ffecom_concat_list_new_ -- Make list of concatenated string exprs
2239 ffecomConcatList_ catlist;
2240 ffebld expr; // Root expr of CHARACTER basictype.
2241 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2242 catlist = ffecom_concat_list_new_(expr,max);
2244 Returns a flattened list of concatenated subexpressions given a
2245 tree of such expressions. */
2247 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2248 static ffecomConcatList_
2249 ffecom_concat_list_new_ (ffebld expr
, ffetargetCharacterSize max
)
2251 ffecomConcatList_ catlist
;
2253 catlist
.maxlen
= catlist
.minlen
= catlist
.max
= catlist
.count
= 0;
2254 return ffecom_concat_list_gather_ (catlist
, expr
, max
);
2259 /* Provide some kind of useful info on member of aggregate area,
2260 since current g77/gcc technology does not provide debug info
2261 on these members. */
2263 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2265 ffecom_debug_kludge_ (tree aggr
, char *aggr_type
, ffesymbol member
,
2266 tree member_type UNUSED
, ffetargetOffset offset
)
2276 for (type_id
= member_type
;
2277 TREE_CODE (type_id
) != IDENTIFIER_NODE
;
2280 switch (TREE_CODE (type_id
))
2284 type_id
= TYPE_NAME (type_id
);
2289 type_id
= TREE_TYPE (type_id
);
2293 assert ("no IDENTIFIER_NODE for type!" == NULL
);
2294 type_id
= error_mark_node
;
2300 if (ffecom_transform_only_dummies_
2301 || !ffe_is_debug_kludge ())
2302 return; /* Can't do this yet, maybe later. */
2305 + strlen (aggr_type
)
2306 + IDENTIFIER_LENGTH (DECL_NAME (aggr
));
2308 + IDENTIFIER_LENGTH (type_id
);
2311 if (((size_t) len
) >= ARRAY_SIZE (space
))
2312 buff
= malloc_new_ks (malloc_pool_image (), "debug_kludge", len
+ 1);
2316 sprintf (&buff
[0], "At (%s) `%s' plus %ld bytes",
2318 IDENTIFIER_POINTER (DECL_NAME (aggr
)),
2321 value
= build_string (len
, buff
);
2323 = build_type_variant (build_array_type (char_type_node
,
2327 build_int_2 (strlen (buff
), 0))),
2329 decl
= build_decl (VAR_DECL
,
2330 ffecom_get_identifier_ (ffesymbol_text (member
)),
2332 TREE_CONSTANT (decl
) = 1;
2333 TREE_STATIC (decl
) = 1;
2334 DECL_INITIAL (decl
) = error_mark_node
;
2335 DECL_IN_SYSTEM_HEADER (decl
) = 1; /* Don't let -Wunused complain. */
2336 decl
= start_decl (decl
, FALSE
);
2337 finish_decl (decl
, value
, FALSE
);
2339 if (buff
!= &space
[0])
2340 malloc_kill_ks (malloc_pool_image (), buff
, len
+ 1);
2344 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2346 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2347 int i; // entry# for this entrypoint (used by master fn)
2348 ffecom_do_entrypoint_(s,i);
2350 Makes a public entry point that calls our private master fn (already
2353 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2355 ffecom_do_entry_ (ffesymbol fn
, int entrynum
)
2358 tree type
; /* Type of function. */
2359 tree multi_retval
; /* Var holding return value (union). */
2360 tree result
; /* Var holding result. */
2361 ffeinfoBasictype bt
;
2365 bool charfunc
; /* All entry points return same type
2367 bool cmplxfunc
; /* Use f2c way of returning COMPLEX. */
2368 bool multi
; /* Master fn has multiple return types. */
2369 bool altreturning
= FALSE
; /* This entry point has alternate returns. */
2371 int old_lineno
= lineno
;
2372 char *old_input_filename
= input_filename
;
2374 input_filename
= ffesymbol_where_filename (fn
);
2375 lineno
= ffesymbol_where_filelinenum (fn
);
2377 /* c-parse.y indeed does call suspend_momentary and not only ignores the
2378 return value, but also never calls resume_momentary, when starting an
2379 outer function (see "fndef:", "setspecs:", and so on). So g77 does the
2380 same thing. It shouldn't be a problem since start_function calls
2381 temporary_allocation, but it might be necessary. If it causes a problem
2382 here, then maybe there's a bug lurking in gcc. NOTE: This identical
2383 comment appears twice in thist file. */
2385 suspend_momentary ();
2387 ffecom_doing_entry_
= TRUE
; /* Don't bother with array dimensions. */
2389 switch (ffecom_primary_entry_kind_
)
2391 case FFEINFO_kindFUNCTION
:
2393 /* Determine actual return type for function. */
2395 gt
= FFEGLOBAL_typeFUNC
;
2396 bt
= ffesymbol_basictype (fn
);
2397 kt
= ffesymbol_kindtype (fn
);
2398 if (bt
== FFEINFO_basictypeNONE
)
2400 ffeimplic_establish_symbol (fn
);
2401 if (ffesymbol_funcresult (fn
) != NULL
)
2402 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
2403 bt
= ffesymbol_basictype (fn
);
2404 kt
= ffesymbol_kindtype (fn
);
2407 if (bt
== FFEINFO_basictypeCHARACTER
)
2408 charfunc
= TRUE
, cmplxfunc
= FALSE
;
2409 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
2410 && ffesymbol_is_f2c (fn
))
2411 charfunc
= FALSE
, cmplxfunc
= TRUE
;
2413 charfunc
= cmplxfunc
= FALSE
;
2416 type
= ffecom_tree_fun_type_void
;
2417 else if (ffesymbol_is_f2c (fn
))
2418 type
= ffecom_tree_fun_type
[bt
][kt
];
2420 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
2422 if ((type
== NULL_TREE
)
2423 || (TREE_TYPE (type
) == NULL_TREE
))
2424 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
2426 multi
= (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
2429 case FFEINFO_kindSUBROUTINE
:
2430 gt
= FFEGLOBAL_typeSUBR
;
2431 bt
= FFEINFO_basictypeNONE
;
2432 kt
= FFEINFO_kindtypeNONE
;
2433 if (ffecom_is_altreturning_
)
2434 { /* Am _I_ altreturning? */
2435 for (item
= ffesymbol_dummyargs (fn
);
2437 item
= ffebld_trail (item
))
2439 if (ffebld_op (ffebld_head (item
)) == FFEBLD_opSTAR
)
2441 altreturning
= TRUE
;
2446 type
= ffecom_tree_subr_type
;
2448 type
= ffecom_tree_fun_type_void
;
2451 type
= ffecom_tree_fun_type_void
;
2458 assert ("say what??" == NULL
);
2460 case FFEINFO_kindANY
:
2461 gt
= FFEGLOBAL_typeANY
;
2462 bt
= FFEINFO_basictypeNONE
;
2463 kt
= FFEINFO_kindtypeNONE
;
2464 type
= error_mark_node
;
2471 /* build_decl uses the current lineno and input_filename to set the decl
2472 source info. So, I've putzed with ffestd and ffeste code to update that
2473 source info to point to the appropriate statement just before calling
2474 ffecom_do_entrypoint (which calls this fn). */
2476 start_function (ffecom_get_external_identifier_ (fn
),
2478 0, /* nested/inline */
2479 1); /* TREE_PUBLIC */
2481 if (((g
= ffesymbol_global (fn
)) != NULL
)
2482 && ((ffeglobal_type (g
) == gt
)
2483 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
2485 ffeglobal_set_hook (g
, current_function_decl
);
2488 /* Reset args in master arg list so they get retransitioned. */
2490 for (item
= ffecom_master_arglist_
;
2492 item
= ffebld_trail (item
))
2497 arg
= ffebld_head (item
);
2498 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2499 continue; /* Alternate return or some such thing. */
2500 s
= ffebld_symter (arg
);
2501 ffesymbol_hook (s
).decl_tree
= NULL_TREE
;
2502 ffesymbol_hook (s
).length_tree
= NULL_TREE
;
2505 /* Build dummy arg list for this entry point. */
2507 yes
= suspend_momentary ();
2509 if (charfunc
|| cmplxfunc
)
2510 { /* Prepend arg for where result goes. */
2515 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
2517 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
2519 result
= ffecom_get_invented_identifier ("__g77_%s",
2522 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2525 length
= ffecom_char_enhance_arg_ (&type
, fn
);
2527 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
2529 type
= build_pointer_type (type
);
2530 result
= build_decl (PARM_DECL
, result
, type
);
2532 push_parm_decl (result
);
2533 ffecom_func_result_
= result
;
2537 push_parm_decl (length
);
2538 ffecom_func_length_
= length
;
2542 result
= DECL_RESULT (current_function_decl
);
2544 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn
), FALSE
);
2546 resume_momentary (yes
);
2548 store_parm_decls (0);
2550 ffecom_start_compstmt_ ();
2552 /* Make local var to hold return type for multi-type master fn. */
2556 yes
= suspend_momentary ();
2558 multi_retval
= ffecom_get_invented_identifier ("__g77_%s",
2560 multi_retval
= build_decl (VAR_DECL
, multi_retval
,
2561 ffecom_multi_type_node_
);
2562 multi_retval
= start_decl (multi_retval
, FALSE
);
2563 finish_decl (multi_retval
, NULL_TREE
, FALSE
);
2565 resume_momentary (yes
);
2568 multi_retval
= NULL_TREE
; /* Not actually ref'd if !multi. */
2570 /* Here we emit the actual code for the entry point. */
2576 tree arglist
= NULL_TREE
;
2577 tree
*plist
= &arglist
;
2583 /* Prepare actual arg list based on master arg list. */
2585 for (list
= ffecom_master_arglist_
;
2587 list
= ffebld_trail (list
))
2589 arg
= ffebld_head (list
);
2590 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2592 s
= ffebld_symter (arg
);
2593 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
)
2594 actarg
= null_pointer_node
; /* We don't have this arg. */
2596 actarg
= ffesymbol_hook (s
).decl_tree
;
2597 *plist
= build_tree_list (NULL_TREE
, actarg
);
2598 plist
= &TREE_CHAIN (*plist
);
2601 /* This code appends the length arguments for character
2602 variables/arrays. */
2604 for (list
= ffecom_master_arglist_
;
2606 list
= ffebld_trail (list
))
2608 arg
= ffebld_head (list
);
2609 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2611 s
= ffebld_symter (arg
);
2612 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
2613 continue; /* Only looking for CHARACTER arguments. */
2614 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
2615 continue; /* Only looking for variables and arrays. */
2616 if (ffesymbol_hook (s
).length_tree
== NULL_TREE
)
2617 actarg
= ffecom_f2c_ftnlen_zero_node
; /* We don't have this arg. */
2619 actarg
= ffesymbol_hook (s
).length_tree
;
2620 *plist
= build_tree_list (NULL_TREE
, actarg
);
2621 plist
= &TREE_CHAIN (*plist
);
2624 /* Prepend character-value return info to actual arg list. */
2628 prepend
= build_tree_list (NULL_TREE
, ffecom_func_result_
);
2629 TREE_CHAIN (prepend
)
2630 = build_tree_list (NULL_TREE
, ffecom_func_length_
);
2631 TREE_CHAIN (TREE_CHAIN (prepend
)) = arglist
;
2635 /* Prepend multi-type return value to actual arg list. */
2640 = build_tree_list (NULL_TREE
,
2641 ffecom_1 (ADDR_EXPR
,
2642 build_pointer_type (TREE_TYPE (multi_retval
)),
2644 TREE_CHAIN (prepend
) = arglist
;
2648 /* Prepend my entry-point number to the actual arg list. */
2650 prepend
= build_tree_list (NULL_TREE
, build_int_2 (entrynum
, 0));
2651 TREE_CHAIN (prepend
) = arglist
;
2654 /* Build the call to the master function. */
2656 master_fn
= ffecom_1_fn (ffecom_previous_function_decl_
);
2657 call
= ffecom_3s (CALL_EXPR
,
2658 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn
))),
2659 master_fn
, arglist
, NULL_TREE
);
2661 /* Decide whether the master function is a function or subroutine, and
2662 handle the return value for my entry point. */
2664 if (charfunc
|| ((ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
2667 expand_expr_stmt (call
);
2668 expand_null_return ();
2670 else if (multi
&& cmplxfunc
)
2672 expand_expr_stmt (call
);
2674 = ffecom_1 (INDIRECT_REF
,
2675 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2677 result
= ffecom_modify (NULL_TREE
, result
,
2678 ffecom_2 (COMPONENT_REF
, TREE_TYPE (result
),
2680 ffecom_multi_fields_
[bt
][kt
]));
2681 expand_expr_stmt (result
);
2682 expand_null_return ();
2686 expand_expr_stmt (call
);
2688 = ffecom_modify (NULL_TREE
, result
,
2689 convert (TREE_TYPE (result
),
2690 ffecom_2 (COMPONENT_REF
,
2691 ffecom_tree_type
[bt
][kt
],
2693 ffecom_multi_fields_
[bt
][kt
])));
2694 expand_return (result
);
2699 = ffecom_1 (INDIRECT_REF
,
2700 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2702 result
= ffecom_modify (NULL_TREE
, result
, call
);
2703 expand_expr_stmt (result
);
2704 expand_null_return ();
2708 result
= ffecom_modify (NULL_TREE
,
2710 convert (TREE_TYPE (result
),
2712 expand_return (result
);
2718 ffecom_end_compstmt_ ();
2720 finish_function (0);
2722 lineno
= old_lineno
;
2723 input_filename
= old_input_filename
;
2725 ffecom_doing_entry_
= FALSE
;
2729 /* Transform expr into gcc tree with possible destination
2731 Recursive descent on expr while making corresponding tree nodes and
2732 attaching type info and such. If destination supplied and compatible
2733 with temporary that would be made in certain cases, temporary isn't
2734 made, destination used instead, and dest_used flag set TRUE. */
2736 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2738 ffecom_expr_ (ffebld expr
, tree dest_tree
, ffebld dest
,
2739 bool *dest_used
, bool assignp
, bool widenp
)
2744 ffeinfoBasictype bt
;
2747 tree dt
; /* decl_tree for an ffesymbol. */
2748 tree tree_type
, tree_type_x
;
2751 enum tree_code code
;
2753 assert (expr
!= NULL
);
2755 if (dest_used
!= NULL
)
2758 bt
= ffeinfo_basictype (ffebld_info (expr
));
2759 kt
= ffeinfo_kindtype (ffebld_info (expr
));
2760 tree_type
= ffecom_tree_type
[bt
][kt
];
2762 /* Widen integral arithmetic as desired while preserving signedness. */
2763 tree_type_x
= NULL_TREE
;
2764 if (widenp
&& tree_type
2765 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
2766 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
2767 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
2769 switch (ffebld_op (expr
))
2771 case FFEBLD_opACCTER
:
2774 ffebit bits
= ffebld_accter_bits (expr
);
2775 ffetargetOffset source_offset
= 0;
2779 size
= ffetype_size (ffeinfo_type (bt
, kt
));
2784 ffebldConstantUnion cu
;
2787 ffebldConstantArray ca
= ffebld_accter (expr
);
2789 ffebit_test (bits
, source_offset
, &value
, &length
);
2795 for (i
= 0; i
< length
; ++i
)
2797 cu
= ffebld_constantarray_get (ca
, bt
, kt
,
2800 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
2803 purpose
= build_int_2 (source_offset
, 0);
2805 purpose
= NULL_TREE
;
2807 if (list
== NULL_TREE
)
2808 list
= item
= build_tree_list (purpose
, t
);
2811 TREE_CHAIN (item
) = build_tree_list (purpose
, t
);
2812 item
= TREE_CHAIN (item
);
2816 source_offset
+= length
;
2820 item
= build_int_2 (ffebld_accter_size (expr
), 0);
2821 ffebit_kill (ffebld_accter_bits (expr
));
2822 TREE_TYPE (item
) = ffecom_integer_type_node
;
2826 build_range_type (ffecom_integer_type_node
,
2827 ffecom_integer_zero_node
,
2829 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
2830 TREE_CONSTANT (list
) = 1;
2831 TREE_STATIC (list
) = 1;
2834 case FFEBLD_opARRTER
:
2838 list
= item
= NULL_TREE
;
2839 for (i
= 0; i
< ffebld_arrter_size (expr
); ++i
)
2841 ffebldConstantUnion cu
2842 = ffebld_constantarray_get (ffebld_arrter (expr
), bt
, kt
, i
);
2844 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
2846 if (list
== NULL_TREE
)
2847 list
= item
= build_tree_list (NULL_TREE
, t
);
2850 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
2851 item
= TREE_CHAIN (item
);
2856 item
= build_int_2 (ffebld_arrter_size (expr
), 0);
2857 TREE_TYPE (item
) = ffecom_integer_type_node
;
2861 build_range_type (ffecom_integer_type_node
,
2862 ffecom_integer_one_node
,
2864 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
2865 TREE_CONSTANT (list
) = 1;
2866 TREE_STATIC (list
) = 1;
2869 case FFEBLD_opCONTER
:
2871 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr
)),
2875 case FFEBLD_opSYMTER
:
2876 if ((ffebld_symter_generic (expr
) != FFEINTRIN_genNONE
)
2877 || (ffebld_symter_specific (expr
) != FFEINTRIN_specNONE
))
2878 return ffecom_ptr_to_expr (expr
); /* Same as %REF(intrinsic). */
2879 s
= ffebld_symter (expr
);
2880 t
= ffesymbol_hook (s
).decl_tree
;
2883 { /* ASSIGN'ed-label expr. */
2884 if (ffe_is_ugly_assign ())
2886 /* User explicitly wants ASSIGN'ed variables to be at the same
2887 memory address as the variables when used in non-ASSIGN
2888 contexts. That can make old, arcane, non-standard code
2889 work, but don't try to do it when a pointer wouldn't fit
2890 in the normal variable (take other approach, and warn,
2895 s
= ffecom_sym_transform_ (s
);
2896 t
= ffesymbol_hook (s
).decl_tree
;
2897 assert (t
!= NULL_TREE
);
2900 if (t
== error_mark_node
)
2903 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t
)))
2904 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
2906 if (ffesymbol_hook (s
).addr
)
2907 t
= ffecom_1 (INDIRECT_REF
,
2908 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
2912 if (ffesymbol_hook (s
).assign_tree
== NULL_TREE
)
2914 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
2915 FFEBAD_severityWARNING
);
2916 ffebad_string (ffesymbol_text (s
));
2917 ffebad_here (0, ffesymbol_where_line (s
),
2918 ffesymbol_where_column (s
));
2923 /* Don't use the normal variable's tree for ASSIGN, though mark
2924 it as in the system header (housekeeping). Use an explicit,
2925 specially created sibling that is known to be wide enough
2926 to hold pointers to labels. */
2929 && TREE_CODE (t
) == VAR_DECL
)
2930 DECL_IN_SYSTEM_HEADER (t
) = 1; /* Don't let -Wunused complain. */
2932 t
= ffesymbol_hook (s
).assign_tree
;
2935 s
= ffecom_sym_transform_assign_ (s
);
2936 t
= ffesymbol_hook (s
).assign_tree
;
2937 assert (t
!= NULL_TREE
);
2944 s
= ffecom_sym_transform_ (s
);
2945 t
= ffesymbol_hook (s
).decl_tree
;
2946 assert (t
!= NULL_TREE
);
2948 if (ffesymbol_hook (s
).addr
)
2949 t
= ffecom_1 (INDIRECT_REF
,
2950 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
2954 case FFEBLD_opARRAYREF
:
2956 ffebld dims
[FFECOM_dimensionsMAX
];
2957 #if FFECOM_FASTER_ARRAY_REFS
2962 #if FFECOM_FASTER_ARRAY_REFS
2963 t
= ffecom_ptr_to_expr (ffebld_left (expr
));
2965 t
= ffecom_expr (ffebld_left (expr
));
2967 if (t
== error_mark_node
)
2970 if ((ffeinfo_where (ffebld_info (expr
)) == FFEINFO_whereFLEETING
)
2971 && !mark_addressable (t
))
2972 return error_mark_node
; /* Make sure non-const ref is to
2975 /* Build up ARRAY_REFs in reverse order (since we're column major
2976 here in Fortran land). */
2978 for (i
= 0, expr
= ffebld_right (expr
);
2980 expr
= ffebld_trail (expr
))
2981 dims
[i
++] = ffebld_head (expr
);
2983 #if FFECOM_FASTER_ARRAY_REFS
2984 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
)));
2986 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
2987 t
= ffecom_2 (PLUS_EXPR
,
2988 build_pointer_type (TREE_TYPE (array
)),
2990 size_binop (MULT_EXPR
,
2991 size_in_bytes (TREE_TYPE (array
)),
2992 size_binop (MINUS_EXPR
,
2993 ffecom_expr (dims
[i
]),
2994 TYPE_MIN_VALUE (TYPE_DOMAIN (array
)))));
2995 t
= ffecom_1 (INDIRECT_REF
,
2996 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))),
3000 t
= ffecom_2 (ARRAY_REF
,
3001 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))),
3003 ffecom_expr_ (dims
[--i
], NULL
, NULL
, NULL
, FALSE
, TRUE
));
3009 case FFEBLD_opUPLUS
:
3010 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3011 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3013 case FFEBLD_opPAREN
: /* ~~~Make sure Fortran rules respected here */
3014 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3015 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3017 case FFEBLD_opUMINUS
:
3018 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3021 tree_type
= tree_type_x
;
3022 left
= convert (tree_type
, left
);
3024 return ffecom_1 (NEGATE_EXPR
, tree_type
, left
);
3027 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3028 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3031 tree_type
= tree_type_x
;
3032 left
= convert (tree_type
, left
);
3033 right
= convert (tree_type
, right
);
3035 return ffecom_2 (PLUS_EXPR
, tree_type
, left
, right
);
3037 case FFEBLD_opSUBTRACT
:
3038 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3039 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3042 tree_type
= tree_type_x
;
3043 left
= convert (tree_type
, left
);
3044 right
= convert (tree_type
, right
);
3046 return ffecom_2 (MINUS_EXPR
, tree_type
, left
, right
);
3048 case FFEBLD_opMULTIPLY
:
3049 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3050 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3053 tree_type
= tree_type_x
;
3054 left
= convert (tree_type
, left
);
3055 right
= convert (tree_type
, right
);
3057 return ffecom_2 (MULT_EXPR
, tree_type
, left
, right
);
3059 case FFEBLD_opDIVIDE
:
3060 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3061 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3064 tree_type
= tree_type_x
;
3065 left
= convert (tree_type
, left
);
3066 right
= convert (tree_type
, right
);
3068 return ffecom_tree_divide_ (tree_type
, left
, right
,
3069 dest_tree
, dest
, dest_used
);
3071 case FFEBLD_opPOWER
:
3073 ffebld left
= ffebld_left (expr
);
3074 ffebld right
= ffebld_right (expr
);
3076 ffeinfoKindtype rtkt
;
3077 ffeinfoKindtype ltkt
;
3079 switch (ffeinfo_basictype (ffebld_info (right
)))
3081 case FFEINFO_basictypeINTEGER
:
3084 item
= ffecom_expr_power_integer_ (left
, right
);
3085 if (item
!= NULL_TREE
)
3089 ltkt
= FFEINFO_kindtypeINTEGER1
;
3090 rtkt
= FFEINFO_kindtypeINTEGER1
;
3091 switch (ffeinfo_basictype (ffebld_info (left
)))
3093 case FFEINFO_basictypeINTEGER
:
3094 if ((ffeinfo_kindtype (ffebld_info (left
))
3095 == FFEINFO_kindtypeINTEGER4
)
3096 || (ffeinfo_kindtype (ffebld_info (right
))
3097 == FFEINFO_kindtypeINTEGER4
))
3099 code
= FFECOM_gfrtPOW_QQ
;
3100 ltkt
= FFEINFO_kindtypeINTEGER4
;
3101 rtkt
= FFEINFO_kindtypeINTEGER4
;
3104 code
= FFECOM_gfrtPOW_II
;
3107 case FFEINFO_basictypeREAL
:
3108 if (ffeinfo_kindtype (ffebld_info (left
))
3109 == FFEINFO_kindtypeREAL1
)
3110 code
= FFECOM_gfrtPOW_RI
;
3112 code
= FFECOM_gfrtPOW_DI
;
3115 case FFEINFO_basictypeCOMPLEX
:
3116 if (ffeinfo_kindtype (ffebld_info (left
))
3117 == FFEINFO_kindtypeREAL1
)
3118 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3120 code
= FFECOM_gfrtPOW_ZI
; /* Overlapping result okay. */
3124 assert ("bad pow_*i" == NULL
);
3125 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3128 if (ffeinfo_kindtype (ffebld_info (left
)) != ltkt
)
3129 left
= ffeexpr_convert (left
, NULL
, NULL
,
3130 FFEINFO_basictypeINTEGER
,
3132 FFETARGET_charactersizeNONE
,
3133 FFEEXPR_contextLET
);
3134 if (ffeinfo_kindtype (ffebld_info (right
)) != rtkt
)
3135 right
= ffeexpr_convert (right
, NULL
, NULL
,
3136 FFEINFO_basictypeINTEGER
,
3138 FFETARGET_charactersizeNONE
,
3139 FFEEXPR_contextLET
);
3142 case FFEINFO_basictypeREAL
:
3143 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3144 left
= ffeexpr_convert (left
, NULL
, NULL
, FFEINFO_basictypeREAL
,
3145 FFEINFO_kindtypeREALDOUBLE
, 0,
3146 FFETARGET_charactersizeNONE
,
3147 FFEEXPR_contextLET
);
3148 if (ffeinfo_kindtype (ffebld_info (right
))
3149 == FFEINFO_kindtypeREAL1
)
3150 right
= ffeexpr_convert (right
, NULL
, NULL
,
3151 FFEINFO_basictypeREAL
,
3152 FFEINFO_kindtypeREALDOUBLE
, 0,
3153 FFETARGET_charactersizeNONE
,
3154 FFEEXPR_contextLET
);
3155 code
= FFECOM_gfrtPOW_DD
;
3158 case FFEINFO_basictypeCOMPLEX
:
3159 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3160 left
= ffeexpr_convert (left
, NULL
, NULL
,
3161 FFEINFO_basictypeCOMPLEX
,
3162 FFEINFO_kindtypeREALDOUBLE
, 0,
3163 FFETARGET_charactersizeNONE
,
3164 FFEEXPR_contextLET
);
3165 if (ffeinfo_kindtype (ffebld_info (right
))
3166 == FFEINFO_kindtypeREAL1
)
3167 right
= ffeexpr_convert (right
, NULL
, NULL
,
3168 FFEINFO_basictypeCOMPLEX
,
3169 FFEINFO_kindtypeREALDOUBLE
, 0,
3170 FFETARGET_charactersizeNONE
,
3171 FFEEXPR_contextLET
);
3172 code
= FFECOM_gfrtPOW_ZZ
; /* Overlapping result okay. */
3176 assert ("bad pow_x*" == NULL
);
3177 code
= FFECOM_gfrtPOW_II
;
3180 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code
),
3181 ffecom_gfrt_kindtype (code
),
3182 (ffe_is_f2c_library ()
3183 && ffecom_gfrt_complex_
[code
]),
3184 tree_type
, left
, right
,
3185 dest_tree
, dest
, dest_used
,
3192 case FFEINFO_basictypeLOGICAL
:
3193 item
= ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr
)));
3194 return convert (tree_type
, item
);
3196 case FFEINFO_basictypeINTEGER
:
3197 return ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3198 ffecom_expr (ffebld_left (expr
)));
3201 assert ("NOT bad basictype" == NULL
);
3203 case FFEINFO_basictypeANY
:
3204 return error_mark_node
;
3208 case FFEBLD_opFUNCREF
:
3209 assert (ffeinfo_basictype (ffebld_info (expr
))
3210 != FFEINFO_basictypeCHARACTER
);
3212 case FFEBLD_opSUBRREF
:
3213 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
3214 == FFEINFO_whereINTRINSIC
)
3215 { /* Invocation of an intrinsic. */
3216 item
= ffecom_expr_intrinsic_ (expr
, dest_tree
, dest
,
3220 s
= ffebld_symter (ffebld_left (expr
));
3221 dt
= ffesymbol_hook (s
).decl_tree
;
3222 if (dt
== NULL_TREE
)
3224 s
= ffecom_sym_transform_ (s
);
3225 dt
= ffesymbol_hook (s
).decl_tree
;
3227 if (dt
== error_mark_node
)
3230 if (ffesymbol_hook (s
).addr
)
3233 item
= ffecom_1_fn (dt
);
3235 ffecom_push_calltemps ();
3236 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
3237 args
= ffecom_list_expr (ffebld_right (expr
));
3239 args
= ffecom_list_ptr_to_expr (ffebld_right (expr
));
3240 ffecom_pop_calltemps ();
3242 item
= ffecom_call_ (item
, kt
,
3243 ffesymbol_is_f2c (s
)
3244 && (bt
== FFEINFO_basictypeCOMPLEX
)
3245 && (ffesymbol_where (s
)
3246 != FFEINFO_whereCONSTANT
),
3249 dest_tree
, dest
, dest_used
,
3250 error_mark_node
, FALSE
);
3251 TREE_SIDE_EFFECTS (item
) = 1;
3257 case FFEINFO_basictypeLOGICAL
:
3259 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3260 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3261 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3262 return convert (tree_type
, item
);
3264 case FFEINFO_basictypeINTEGER
:
3265 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
3266 ffecom_expr (ffebld_left (expr
)),
3267 ffecom_expr (ffebld_right (expr
)));
3270 assert ("AND bad basictype" == NULL
);
3272 case FFEINFO_basictypeANY
:
3273 return error_mark_node
;
3280 case FFEINFO_basictypeLOGICAL
:
3282 = ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
3283 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3284 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3285 return convert (tree_type
, item
);
3287 case FFEINFO_basictypeINTEGER
:
3288 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
3289 ffecom_expr (ffebld_left (expr
)),
3290 ffecom_expr (ffebld_right (expr
)));
3293 assert ("OR bad basictype" == NULL
);
3295 case FFEINFO_basictypeANY
:
3296 return error_mark_node
;
3304 case FFEINFO_basictypeLOGICAL
:
3306 = ffecom_2 (NE_EXPR
, integer_type_node
,
3307 ffecom_expr (ffebld_left (expr
)),
3308 ffecom_expr (ffebld_right (expr
)));
3309 return convert (tree_type
, ffecom_truth_value (item
));
3311 case FFEINFO_basictypeINTEGER
:
3312 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3313 ffecom_expr (ffebld_left (expr
)),
3314 ffecom_expr (ffebld_right (expr
)));
3317 assert ("XOR/NEQV bad basictype" == NULL
);
3319 case FFEINFO_basictypeANY
:
3320 return error_mark_node
;
3327 case FFEINFO_basictypeLOGICAL
:
3329 = ffecom_2 (EQ_EXPR
, integer_type_node
,
3330 ffecom_expr (ffebld_left (expr
)),
3331 ffecom_expr (ffebld_right (expr
)));
3332 return convert (tree_type
, ffecom_truth_value (item
));
3334 case FFEINFO_basictypeINTEGER
:
3336 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3337 ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3338 ffecom_expr (ffebld_left (expr
)),
3339 ffecom_expr (ffebld_right (expr
))));
3342 assert ("EQV bad basictype" == NULL
);
3344 case FFEINFO_basictypeANY
:
3345 return error_mark_node
;
3349 case FFEBLD_opCONVERT
:
3350 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opANY
)
3351 return error_mark_node
;
3355 case FFEINFO_basictypeLOGICAL
:
3356 case FFEINFO_basictypeINTEGER
:
3357 case FFEINFO_basictypeREAL
:
3358 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3360 case FFEINFO_basictypeCOMPLEX
:
3361 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3363 case FFEINFO_basictypeINTEGER
:
3364 case FFEINFO_basictypeLOGICAL
:
3365 case FFEINFO_basictypeREAL
:
3366 item
= ffecom_expr (ffebld_left (expr
));
3367 if (item
== error_mark_node
)
3368 return error_mark_node
;
3369 /* convert() takes care of converting to the subtype first,
3370 at least in gcc-2.7.2. */
3371 item
= convert (tree_type
, item
);
3374 case FFEINFO_basictypeCOMPLEX
:
3375 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3378 assert ("CONVERT COMPLEX bad basictype" == NULL
);
3380 case FFEINFO_basictypeANY
:
3381 return error_mark_node
;
3386 assert ("CONVERT bad basictype" == NULL
);
3388 case FFEINFO_basictypeANY
:
3389 return error_mark_node
;
3395 goto relational
; /* :::::::::::::::::::: */
3399 goto relational
; /* :::::::::::::::::::: */
3403 goto relational
; /* :::::::::::::::::::: */
3407 goto relational
; /* :::::::::::::::::::: */
3411 goto relational
; /* :::::::::::::::::::: */
3416 relational
: /* :::::::::::::::::::: */
3417 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3419 case FFEINFO_basictypeLOGICAL
:
3420 case FFEINFO_basictypeINTEGER
:
3421 case FFEINFO_basictypeREAL
:
3422 item
= ffecom_2 (code
, integer_type_node
,
3423 ffecom_expr (ffebld_left (expr
)),
3424 ffecom_expr (ffebld_right (expr
)));
3425 return convert (tree_type
, item
);
3427 case FFEINFO_basictypeCOMPLEX
:
3428 assert (code
== EQ_EXPR
|| code
== NE_EXPR
);
3431 tree arg1
= ffecom_expr (ffebld_left (expr
));
3432 tree arg2
= ffecom_expr (ffebld_right (expr
));
3434 if (arg1
== error_mark_node
|| arg2
== error_mark_node
)
3435 return error_mark_node
;
3437 arg1
= ffecom_save_tree (arg1
);
3438 arg2
= ffecom_save_tree (arg2
);
3440 if (TREE_CODE (TREE_TYPE (arg1
)) == COMPLEX_TYPE
)
3442 real_type
= TREE_TYPE (TREE_TYPE (arg1
));
3443 assert (real_type
== TREE_TYPE (TREE_TYPE (arg2
)));
3447 real_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1
)));
3448 assert (real_type
== TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2
))));
3452 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3453 ffecom_2 (EQ_EXPR
, integer_type_node
,
3454 ffecom_1 (REALPART_EXPR
, real_type
, arg1
),
3455 ffecom_1 (REALPART_EXPR
, real_type
, arg2
)),
3456 ffecom_2 (EQ_EXPR
, integer_type_node
,
3457 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1
),
3458 ffecom_1 (IMAGPART_EXPR
, real_type
,
3460 if (code
== EQ_EXPR
)
3461 item
= ffecom_truth_value (item
);
3463 item
= ffecom_truth_value_invert (item
);
3464 return convert (tree_type
, item
);
3467 case FFEINFO_basictypeCHARACTER
:
3468 ffecom_push_calltemps (); /* Even though we might not call. */
3471 ffebld left
= ffebld_left (expr
);
3472 ffebld right
= ffebld_right (expr
);
3478 /* f2c run-time functions do the implicit blank-padding for us,
3479 so we don't usually have to implement blank-padding ourselves.
3480 (The exception is when we pass an argument to a separately
3481 compiled statement function -- if we know the arg is not the
3482 same length as the dummy, we must truncate or extend it. If
3483 we "inline" statement functions, that necessity goes away as
3486 Strip off the CONVERT operators that blank-pad. (Truncation by
3487 CONVERT shouldn't happen here, but it can happen in
3490 while (ffebld_op (left
) == FFEBLD_opCONVERT
)
3491 left
= ffebld_left (left
);
3492 while (ffebld_op (right
) == FFEBLD_opCONVERT
)
3493 right
= ffebld_left (right
);
3495 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
3496 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
3498 if (left_tree
== error_mark_node
|| left_length
== error_mark_node
3499 || right_tree
== error_mark_node
3500 || right_length
== error_mark_node
)
3502 ffecom_pop_calltemps ();
3503 return error_mark_node
;
3506 if ((ffebld_size_known (left
) == 1)
3507 && (ffebld_size_known (right
) == 1))
3510 = ffecom_1 (INDIRECT_REF
,
3511 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3514 = ffecom_1 (INDIRECT_REF
,
3515 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3519 = ffecom_2 (code
, integer_type_node
,
3520 ffecom_2 (ARRAY_REF
,
3521 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3524 ffecom_2 (ARRAY_REF
,
3525 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3531 item
= build_tree_list (NULL_TREE
, left_tree
);
3532 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, right_tree
);
3533 TREE_CHAIN (TREE_CHAIN (item
)) = build_tree_list (NULL_TREE
,
3535 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
3536 = build_tree_list (NULL_TREE
, right_length
);
3537 item
= ffecom_call_gfrt (FFECOM_gfrtCMP
, item
);
3538 item
= ffecom_2 (code
, integer_type_node
,
3540 convert (TREE_TYPE (item
),
3541 integer_zero_node
));
3543 item
= convert (tree_type
, item
);
3546 ffecom_pop_calltemps ();
3550 assert ("relational bad basictype" == NULL
);
3552 case FFEINFO_basictypeANY
:
3553 return error_mark_node
;
3557 case FFEBLD_opPERCENT_LOC
:
3558 item
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &list
);
3559 return convert (tree_type
, item
);
3563 case FFEBLD_opBOUNDS
:
3564 case FFEBLD_opREPEAT
:
3565 case FFEBLD_opLABTER
:
3566 case FFEBLD_opLABTOK
:
3567 case FFEBLD_opIMPDO
:
3568 case FFEBLD_opCONCATENATE
:
3569 case FFEBLD_opSUBSTR
:
3571 assert ("bad op" == NULL
);
3574 return error_mark_node
;
3578 assert ("didn't think anything got here anymore!!" == NULL
);
3580 switch (ffebld_arity (expr
))
3583 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3584 TREE_OPERAND (item
, 1) = ffecom_expr (ffebld_right (expr
));
3585 if (TREE_OPERAND (item
, 0) == error_mark_node
3586 || TREE_OPERAND (item
, 1) == error_mark_node
)
3587 return error_mark_node
;
3591 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3592 if (TREE_OPERAND (item
, 0) == error_mark_node
)
3593 return error_mark_node
;
3605 /* Returns the tree that does the intrinsic invocation.
3607 Note: this function applies only to intrinsics returning
3608 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3611 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3613 ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
3614 ffebld dest
, bool *dest_used
)
3617 tree saved_expr1
; /* For those who need it. */
3618 tree saved_expr2
; /* For those who need it. */
3619 ffeinfoBasictype bt
;
3623 tree real_type
; /* REAL type corresponding to COMPLEX. */
3625 ffebld list
= ffebld_right (expr
); /* List of (some) args. */
3626 ffebld arg1
; /* For handy reference. */
3629 ffeintrinImp codegen_imp
;
3632 assert (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
);
3634 if (dest_used
!= NULL
)
3637 bt
= ffeinfo_basictype (ffebld_info (expr
));
3638 kt
= ffeinfo_kindtype (ffebld_info (expr
));
3639 tree_type
= ffecom_tree_type
[bt
][kt
];
3643 arg1
= ffebld_head (list
);
3644 if (arg1
!= NULL
&& ffebld_op (arg1
) == FFEBLD_opANY
)
3645 return error_mark_node
;
3646 if ((list
= ffebld_trail (list
)) != NULL
)
3648 arg2
= ffebld_head (list
);
3649 if (arg2
!= NULL
&& ffebld_op (arg2
) == FFEBLD_opANY
)
3650 return error_mark_node
;
3651 if ((list
= ffebld_trail (list
)) != NULL
)
3653 arg3
= ffebld_head (list
);
3654 if (arg3
!= NULL
&& ffebld_op (arg3
) == FFEBLD_opANY
)
3655 return error_mark_node
;
3664 arg1
= arg2
= arg3
= NULL
;
3666 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3667 args. This is used by the MAX/MIN expansions. */
3670 arg1_type
= ffecom_tree_type
3671 [ffeinfo_basictype (ffebld_info (arg1
))]
3672 [ffeinfo_kindtype (ffebld_info (arg1
))];
3674 arg1_type
= NULL_TREE
; /* Really not needed, but might catch bugs
3677 /* There are several ways for each of the cases in the following switch
3678 statements to exit (from simplest to use to most complicated):
3680 break; (when expr_tree == NULL)
3682 A standard call is made to the specific intrinsic just as if it had been
3683 passed in as a dummy procedure and called as any old procedure. This
3684 method can produce slower code but in some cases it's the easiest way for
3685 now. However, if a (presumably faster) direct call is available,
3686 that is used, so this is the easiest way in many more cases now.
3688 gfrt = FFECOM_gfrtWHATEVER;
3691 gfrt contains the gfrt index of a library function to call, passing the
3692 argument(s) by value rather than by reference. Used when a more
3693 careful choice of library function is needed than that provided
3694 by the vanilla `break;'.
3698 The expr_tree has been completely set up and is ready to be returned
3699 as is. No further actions are taken. Use this when the tree is not
3700 in the simple form for one of the arity_n labels. */
3702 /* For info on how the switch statement cases were written, see the files
3703 enclosed in comments below the switch statement. */
3705 codegen_imp
= ffebld_symter_implementation (ffebld_left (expr
));
3706 gfrt
= ffeintrin_gfrt_direct (codegen_imp
);
3707 if (gfrt
== FFECOM_gfrt
)
3708 gfrt
= ffeintrin_gfrt_indirect (codegen_imp
);
3710 switch (codegen_imp
)
3712 case FFEINTRIN_impABS
:
3713 case FFEINTRIN_impCABS
:
3714 case FFEINTRIN_impCDABS
:
3715 case FFEINTRIN_impDABS
:
3716 case FFEINTRIN_impIABS
:
3717 if (ffeinfo_basictype (ffebld_info (arg1
))
3718 == FFEINFO_basictypeCOMPLEX
)
3720 if (kt
== FFEINFO_kindtypeREAL1
)
3721 gfrt
= FFECOM_gfrtCABS
;
3722 else if (kt
== FFEINFO_kindtypeREAL2
)
3723 gfrt
= FFECOM_gfrtCDABS
;
3726 return ffecom_1 (ABS_EXPR
, tree_type
,
3727 convert (tree_type
, ffecom_expr (arg1
)));
3729 case FFEINTRIN_impACOS
:
3730 case FFEINTRIN_impDACOS
:
3733 case FFEINTRIN_impAIMAG
:
3734 case FFEINTRIN_impDIMAG
:
3735 case FFEINTRIN_impIMAGPART
:
3736 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
3737 arg1_type
= TREE_TYPE (arg1_type
);
3739 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
3743 ffecom_1 (IMAGPART_EXPR
, arg1_type
,
3744 ffecom_expr (arg1
)));
3746 case FFEINTRIN_impAINT
:
3747 case FFEINTRIN_impDINT
:
3748 #if 0 /* ~~ someday implement FIX_TRUNC_EXPR
3749 yielding same type as arg */
3750 return ffecom_1 (FIX_TRUNC_EXPR
, tree_type
, ffecom_expr (arg1
));
3751 #else /* in the meantime, must use floor to avoid range problems with ints */
3752 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3753 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3756 ffecom_3 (COND_EXPR
, double_type_node
,
3758 (ffecom_2 (GE_EXPR
, integer_type_node
,
3761 ffecom_float_zero_
))),
3762 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3763 build_tree_list (NULL_TREE
,
3764 convert (double_type_node
,
3766 ffecom_1 (NEGATE_EXPR
, double_type_node
,
3767 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3768 build_tree_list (NULL_TREE
,
3769 convert (double_type_node
,
3770 ffecom_1 (NEGATE_EXPR
,
3777 case FFEINTRIN_impANINT
:
3778 case FFEINTRIN_impDNINT
:
3779 #if 0 /* This way of doing it won't handle real
3780 numbers of large magnitudes. */
3781 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3782 expr_tree
= convert (tree_type
,
3783 convert (integer_type_node
,
3784 ffecom_3 (COND_EXPR
, tree_type
,
3789 ffecom_float_zero_
)),
3790 ffecom_2 (PLUS_EXPR
,
3793 ffecom_float_half_
),
3794 ffecom_2 (MINUS_EXPR
,
3797 ffecom_float_half_
))));
3799 #else /* So we instead call floor. */
3800 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3801 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3804 ffecom_3 (COND_EXPR
, double_type_node
,
3806 (ffecom_2 (GE_EXPR
, integer_type_node
,
3809 ffecom_float_zero_
))),
3810 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3811 build_tree_list (NULL_TREE
,
3812 convert (double_type_node
,
3813 ffecom_2 (PLUS_EXPR
,
3817 ffecom_float_half_
))))),
3818 ffecom_1 (NEGATE_EXPR
, double_type_node
,
3819 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3820 build_tree_list (NULL_TREE
,
3821 convert (double_type_node
,
3822 ffecom_2 (MINUS_EXPR
,
3825 ffecom_float_half_
),
3831 case FFEINTRIN_impASIN
:
3832 case FFEINTRIN_impDASIN
:
3833 case FFEINTRIN_impATAN
:
3834 case FFEINTRIN_impDATAN
:
3835 case FFEINTRIN_impATAN2
:
3836 case FFEINTRIN_impDATAN2
:
3839 case FFEINTRIN_impCHAR
:
3840 case FFEINTRIN_impACHAR
:
3841 assert (ffecom_pending_calls_
!= 0);
3842 tempvar
= ffecom_push_tempvar (char_type_node
,
3845 tree tmv
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar
)));
3847 expr_tree
= ffecom_modify (tmv
,
3848 ffecom_2 (ARRAY_REF
, tmv
, tempvar
,
3850 convert (tmv
, ffecom_expr (arg1
)));
3852 expr_tree
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
),
3855 expr_tree
= ffecom_1 (ADDR_EXPR
,
3856 build_pointer_type (TREE_TYPE (expr_tree
)),
3860 case FFEINTRIN_impCMPLX
:
3861 case FFEINTRIN_impDCMPLX
:
3864 convert (tree_type
, ffecom_expr (arg1
));
3866 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
3868 ffecom_2 (COMPLEX_EXPR
, tree_type
,
3869 convert (real_type
, ffecom_expr (arg1
)),
3871 ffecom_expr (arg2
)));
3873 case FFEINTRIN_impCOMPLEX
:
3875 ffecom_2 (COMPLEX_EXPR
, tree_type
,
3877 ffecom_expr (arg2
));
3879 case FFEINTRIN_impCONJG
:
3880 case FFEINTRIN_impDCONJG
:
3884 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
3885 arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
3887 ffecom_2 (COMPLEX_EXPR
, tree_type
,
3888 ffecom_1 (REALPART_EXPR
, real_type
, arg1_tree
),
3889 ffecom_1 (NEGATE_EXPR
, real_type
,
3890 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1_tree
)));
3893 case FFEINTRIN_impCOS
:
3894 case FFEINTRIN_impCCOS
:
3895 case FFEINTRIN_impCDCOS
:
3896 case FFEINTRIN_impDCOS
:
3897 if (bt
== FFEINFO_basictypeCOMPLEX
)
3899 if (kt
== FFEINFO_kindtypeREAL1
)
3900 gfrt
= FFECOM_gfrtCCOS
; /* Overlapping result okay. */
3901 else if (kt
== FFEINFO_kindtypeREAL2
)
3902 gfrt
= FFECOM_gfrtCDCOS
; /* Overlapping result okay. */
3906 case FFEINTRIN_impCOSH
:
3907 case FFEINTRIN_impDCOSH
:
3910 case FFEINTRIN_impDBLE
:
3911 case FFEINTRIN_impDFLOAT
:
3912 case FFEINTRIN_impDREAL
:
3913 case FFEINTRIN_impFLOAT
:
3914 case FFEINTRIN_impIDINT
:
3915 case FFEINTRIN_impIFIX
:
3916 case FFEINTRIN_impINT2
:
3917 case FFEINTRIN_impINT8
:
3918 case FFEINTRIN_impINT
:
3919 case FFEINTRIN_impLONG
:
3920 case FFEINTRIN_impREAL
:
3921 case FFEINTRIN_impSHORT
:
3922 case FFEINTRIN_impSNGL
:
3923 return convert (tree_type
, ffecom_expr (arg1
));
3925 case FFEINTRIN_impDIM
:
3926 case FFEINTRIN_impDDIM
:
3927 case FFEINTRIN_impIDIM
:
3928 saved_expr1
= ffecom_save_tree (convert (tree_type
,
3929 ffecom_expr (arg1
)));
3930 saved_expr2
= ffecom_save_tree (convert (tree_type
,
3931 ffecom_expr (arg2
)));
3933 ffecom_3 (COND_EXPR
, tree_type
,
3935 (ffecom_2 (GT_EXPR
, integer_type_node
,
3938 ffecom_2 (MINUS_EXPR
, tree_type
,
3941 convert (tree_type
, ffecom_float_zero_
));
3943 case FFEINTRIN_impDPROD
:
3945 ffecom_2 (MULT_EXPR
, tree_type
,
3946 convert (tree_type
, ffecom_expr (arg1
)),
3947 convert (tree_type
, ffecom_expr (arg2
)));
3949 case FFEINTRIN_impEXP
:
3950 case FFEINTRIN_impCDEXP
:
3951 case FFEINTRIN_impCEXP
:
3952 case FFEINTRIN_impDEXP
:
3953 if (bt
== FFEINFO_basictypeCOMPLEX
)
3955 if (kt
== FFEINFO_kindtypeREAL1
)
3956 gfrt
= FFECOM_gfrtCEXP
; /* Overlapping result okay. */
3957 else if (kt
== FFEINFO_kindtypeREAL2
)
3958 gfrt
= FFECOM_gfrtCDEXP
; /* Overlapping result okay. */
3962 case FFEINTRIN_impICHAR
:
3963 case FFEINTRIN_impIACHAR
:
3964 #if 0 /* The simple approach. */
3965 ffecom_char_args_ (&expr_tree
, &saved_expr1
/* Ignored */ , arg1
);
3967 = ffecom_1 (INDIRECT_REF
,
3968 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
3971 = ffecom_2 (ARRAY_REF
,
3972 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
3975 return convert (tree_type
, expr_tree
);
3976 #else /* The more interesting (and more optimal) approach. */
3977 expr_tree
= ffecom_intrinsic_ichar_ (tree_type
, arg1
, &saved_expr1
);
3978 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
3981 convert (tree_type
, integer_zero_node
));
3985 case FFEINTRIN_impINDEX
:
3988 case FFEINTRIN_impLEN
:
3990 break; /* The simple approach. */
3992 return ffecom_intrinsic_len_ (arg1
); /* The more optimal approach. */
3995 case FFEINTRIN_impLGE
:
3996 case FFEINTRIN_impLGT
:
3997 case FFEINTRIN_impLLE
:
3998 case FFEINTRIN_impLLT
:
4001 case FFEINTRIN_impLOG
:
4002 case FFEINTRIN_impALOG
:
4003 case FFEINTRIN_impCDLOG
:
4004 case FFEINTRIN_impCLOG
:
4005 case FFEINTRIN_impDLOG
:
4006 if (bt
== FFEINFO_basictypeCOMPLEX
)
4008 if (kt
== FFEINFO_kindtypeREAL1
)
4009 gfrt
= FFECOM_gfrtCLOG
; /* Overlapping result okay. */
4010 else if (kt
== FFEINFO_kindtypeREAL2
)
4011 gfrt
= FFECOM_gfrtCDLOG
; /* Overlapping result okay. */
4015 case FFEINTRIN_impLOG10
:
4016 case FFEINTRIN_impALOG10
:
4017 case FFEINTRIN_impDLOG10
:
4018 if (gfrt
!= FFECOM_gfrt
)
4019 break; /* Already picked one, stick with it. */
4021 if (kt
== FFEINFO_kindtypeREAL1
)
4022 gfrt
= FFECOM_gfrtALOG10
;
4023 else if (kt
== FFEINFO_kindtypeREAL2
)
4024 gfrt
= FFECOM_gfrtDLOG10
;
4027 case FFEINTRIN_impMAX
:
4028 case FFEINTRIN_impAMAX0
:
4029 case FFEINTRIN_impAMAX1
:
4030 case FFEINTRIN_impDMAX1
:
4031 case FFEINTRIN_impMAX0
:
4032 case FFEINTRIN_impMAX1
:
4033 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4034 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4036 arg1_type
= tree_type
;
4037 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4038 convert (arg1_type
, ffecom_expr (arg1
)),
4039 convert (arg1_type
, ffecom_expr (arg2
)));
4040 for (; list
!= NULL
; list
= ffebld_trail (list
))
4042 if ((ffebld_head (list
) == NULL
)
4043 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4045 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4048 ffecom_expr (ffebld_head (list
))));
4050 return convert (tree_type
, expr_tree
);
4052 case FFEINTRIN_impMIN
:
4053 case FFEINTRIN_impAMIN0
:
4054 case FFEINTRIN_impAMIN1
:
4055 case FFEINTRIN_impDMIN1
:
4056 case FFEINTRIN_impMIN0
:
4057 case FFEINTRIN_impMIN1
:
4058 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4059 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4061 arg1_type
= tree_type
;
4062 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4063 convert (arg1_type
, ffecom_expr (arg1
)),
4064 convert (arg1_type
, ffecom_expr (arg2
)));
4065 for (; list
!= NULL
; list
= ffebld_trail (list
))
4067 if ((ffebld_head (list
) == NULL
)
4068 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4070 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4073 ffecom_expr (ffebld_head (list
))));
4075 return convert (tree_type
, expr_tree
);
4077 case FFEINTRIN_impMOD
:
4078 case FFEINTRIN_impAMOD
:
4079 case FFEINTRIN_impDMOD
:
4080 if (bt
!= FFEINFO_basictypeREAL
)
4081 return ffecom_2 (TRUNC_MOD_EXPR
, tree_type
,
4082 convert (tree_type
, ffecom_expr (arg1
)),
4083 convert (tree_type
, ffecom_expr (arg2
)));
4085 if (kt
== FFEINFO_kindtypeREAL1
)
4086 gfrt
= FFECOM_gfrtAMOD
;
4087 else if (kt
== FFEINFO_kindtypeREAL2
)
4088 gfrt
= FFECOM_gfrtDMOD
;
4091 case FFEINTRIN_impNINT
:
4092 case FFEINTRIN_impIDNINT
:
4093 #if 0 /* ~~ ideally FIX_ROUND_EXPR would be
4094 implemented, but it ain't yet */
4095 return ffecom_1 (FIX_ROUND_EXPR
, tree_type
, ffecom_expr (arg1
));
4097 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4098 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4100 convert (ffecom_integer_type_node
,
4101 ffecom_3 (COND_EXPR
, arg1_type
,
4103 (ffecom_2 (GE_EXPR
, integer_type_node
,
4106 ffecom_float_zero_
))),
4107 ffecom_2 (PLUS_EXPR
, arg1_type
,
4110 ffecom_float_half_
)),
4111 ffecom_2 (MINUS_EXPR
, arg1_type
,
4114 ffecom_float_half_
))));
4117 case FFEINTRIN_impSIGN
:
4118 case FFEINTRIN_impDSIGN
:
4119 case FFEINTRIN_impISIGN
:
4121 tree arg2_tree
= ffecom_expr (arg2
);
4125 (ffecom_1 (ABS_EXPR
, tree_type
,
4127 ffecom_expr (arg1
))));
4129 = ffecom_3 (COND_EXPR
, tree_type
,
4131 (ffecom_2 (GE_EXPR
, integer_type_node
,
4133 convert (TREE_TYPE (arg2_tree
),
4134 integer_zero_node
))),
4136 ffecom_1 (NEGATE_EXPR
, tree_type
, saved_expr1
));
4137 /* Make sure SAVE_EXPRs get referenced early enough. */
4139 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4140 convert (void_type_node
, saved_expr1
),
4145 case FFEINTRIN_impSIN
:
4146 case FFEINTRIN_impCDSIN
:
4147 case FFEINTRIN_impCSIN
:
4148 case FFEINTRIN_impDSIN
:
4149 if (bt
== FFEINFO_basictypeCOMPLEX
)
4151 if (kt
== FFEINFO_kindtypeREAL1
)
4152 gfrt
= FFECOM_gfrtCSIN
; /* Overlapping result okay. */
4153 else if (kt
== FFEINFO_kindtypeREAL2
)
4154 gfrt
= FFECOM_gfrtCDSIN
; /* Overlapping result okay. */
4158 case FFEINTRIN_impSINH
:
4159 case FFEINTRIN_impDSINH
:
4162 case FFEINTRIN_impSQRT
:
4163 case FFEINTRIN_impCDSQRT
:
4164 case FFEINTRIN_impCSQRT
:
4165 case FFEINTRIN_impDSQRT
:
4166 if (bt
== FFEINFO_basictypeCOMPLEX
)
4168 if (kt
== FFEINFO_kindtypeREAL1
)
4169 gfrt
= FFECOM_gfrtCSQRT
; /* Overlapping result okay. */
4170 else if (kt
== FFEINFO_kindtypeREAL2
)
4171 gfrt
= FFECOM_gfrtCDSQRT
; /* Overlapping result okay. */
4175 case FFEINTRIN_impTAN
:
4176 case FFEINTRIN_impDTAN
:
4177 case FFEINTRIN_impTANH
:
4178 case FFEINTRIN_impDTANH
:
4181 case FFEINTRIN_impREALPART
:
4182 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
4183 arg1_type
= TREE_TYPE (arg1_type
);
4185 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
4189 ffecom_1 (REALPART_EXPR
, arg1_type
,
4190 ffecom_expr (arg1
)));
4192 case FFEINTRIN_impIAND
:
4193 case FFEINTRIN_impAND
:
4194 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
4196 ffecom_expr (arg1
)),
4198 ffecom_expr (arg2
)));
4200 case FFEINTRIN_impIOR
:
4201 case FFEINTRIN_impOR
:
4202 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4204 ffecom_expr (arg1
)),
4206 ffecom_expr (arg2
)));
4208 case FFEINTRIN_impIEOR
:
4209 case FFEINTRIN_impXOR
:
4210 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
4212 ffecom_expr (arg1
)),
4214 ffecom_expr (arg2
)));
4216 case FFEINTRIN_impLSHIFT
:
4217 return ffecom_2 (LSHIFT_EXPR
, tree_type
,
4219 convert (integer_type_node
,
4220 ffecom_expr (arg2
)));
4222 case FFEINTRIN_impRSHIFT
:
4223 return ffecom_2 (RSHIFT_EXPR
, tree_type
,
4225 convert (integer_type_node
,
4226 ffecom_expr (arg2
)));
4228 case FFEINTRIN_impNOT
:
4229 return ffecom_1 (BIT_NOT_EXPR
, tree_type
, ffecom_expr (arg1
));
4231 case FFEINTRIN_impBIT_SIZE
:
4232 return convert (tree_type
, TYPE_SIZE (arg1_type
));
4234 case FFEINTRIN_impBTEST
:
4236 ffetargetLogical1
true;
4237 ffetargetLogical1
false;
4241 ffetarget_logical1 (&true, TRUE
);
4242 ffetarget_logical1 (&false, FALSE
);
4244 true_tree
= convert (tree_type
, integer_one_node
);
4246 true_tree
= convert (tree_type
, build_int_2 (true, 0));
4248 false_tree
= convert (tree_type
, integer_zero_node
);
4250 false_tree
= convert (tree_type
, build_int_2 (false, 0));
4253 ffecom_3 (COND_EXPR
, tree_type
,
4255 (ffecom_2 (EQ_EXPR
, integer_type_node
,
4256 ffecom_2 (BIT_AND_EXPR
, arg1_type
,
4258 ffecom_2 (LSHIFT_EXPR
, arg1_type
,
4261 convert (integer_type_node
,
4262 ffecom_expr (arg2
)))),
4264 integer_zero_node
))),
4269 case FFEINTRIN_impIBCLR
:
4271 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4273 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4274 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4277 convert (integer_type_node
,
4278 ffecom_expr (arg2
)))));
4280 case FFEINTRIN_impIBITS
:
4282 tree arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4283 ffecom_expr (arg3
)));
4285 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4288 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4289 ffecom_2 (RSHIFT_EXPR
, tree_type
,
4291 convert (integer_type_node
,
4292 ffecom_expr (arg2
))),
4294 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4295 ffecom_1 (BIT_NOT_EXPR
,
4298 integer_zero_node
)),
4299 ffecom_2 (MINUS_EXPR
,
4301 TYPE_SIZE (uns_type
),
4303 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4305 = ffecom_3 (COND_EXPR
, tree_type
,
4307 (ffecom_2 (NE_EXPR
, integer_type_node
,
4309 integer_zero_node
)),
4311 convert (tree_type
, integer_zero_node
));
4316 case FFEINTRIN_impIBSET
:
4318 ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4320 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4321 convert (tree_type
, integer_one_node
),
4322 convert (integer_type_node
,
4323 ffecom_expr (arg2
))));
4325 case FFEINTRIN_impISHFT
:
4327 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4328 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4329 ffecom_expr (arg2
)));
4331 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4334 = ffecom_3 (COND_EXPR
, tree_type
,
4336 (ffecom_2 (GE_EXPR
, integer_type_node
,
4338 integer_zero_node
)),
4339 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4343 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4344 convert (uns_type
, arg1_tree
),
4345 ffecom_1 (NEGATE_EXPR
,
4348 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4350 = ffecom_3 (COND_EXPR
, tree_type
,
4352 (ffecom_2 (NE_EXPR
, integer_type_node
,
4354 TYPE_SIZE (uns_type
))),
4356 convert (tree_type
, integer_zero_node
));
4358 /* Make sure SAVE_EXPRs get referenced early enough. */
4360 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4361 convert (void_type_node
, arg1_tree
),
4362 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4363 convert (void_type_node
, arg2_tree
),
4368 case FFEINTRIN_impISHFTC
:
4370 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4371 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4372 ffecom_expr (arg2
)));
4373 tree arg3_tree
= (arg3
== NULL
) ? TYPE_SIZE (tree_type
)
4374 : ffecom_save_tree (convert (integer_type_node
, ffecom_expr (arg3
)));
4380 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4383 = ffecom_2 (LSHIFT_EXPR
, tree_type
,
4384 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4385 convert (tree_type
, integer_zero_node
)),
4387 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4389 = ffecom_3 (COND_EXPR
, tree_type
,
4391 (ffecom_2 (NE_EXPR
, integer_type_node
,
4393 TYPE_SIZE (uns_type
))),
4395 convert (tree_type
, integer_zero_node
));
4397 mask_arg1
= ffecom_save_tree (mask_arg1
);
4399 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4401 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4403 masked_arg1
= ffecom_save_tree (masked_arg1
);
4405 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4407 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4408 convert (uns_type
, masked_arg1
),
4409 ffecom_1 (NEGATE_EXPR
,
4412 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4414 ffecom_2 (PLUS_EXPR
, integer_type_node
,
4418 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4419 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4423 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4424 convert (uns_type
, masked_arg1
),
4425 ffecom_2 (MINUS_EXPR
,
4430 = ffecom_3 (COND_EXPR
, tree_type
,
4432 (ffecom_2 (LT_EXPR
, integer_type_node
,
4434 integer_zero_node
)),
4438 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4439 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4442 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4443 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4447 = ffecom_3 (COND_EXPR
, tree_type
,
4449 (ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
4450 ffecom_2 (EQ_EXPR
, integer_type_node
,
4455 ffecom_2 (EQ_EXPR
, integer_type_node
,
4457 integer_zero_node
))),
4460 /* Make sure SAVE_EXPRs get referenced early enough. */
4462 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4463 convert (void_type_node
, arg1_tree
),
4464 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4465 convert (void_type_node
, arg2_tree
),
4466 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4467 convert (void_type_node
,
4469 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4470 convert (void_type_node
,
4474 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4475 convert (void_type_node
,
4481 case FFEINTRIN_impLOC
:
4483 tree arg1_tree
= ffecom_expr (arg1
);
4486 = convert (tree_type
,
4487 ffecom_1 (ADDR_EXPR
,
4488 build_pointer_type (TREE_TYPE (arg1_tree
)),
4493 case FFEINTRIN_impMVBITS
:
4498 ffebld arg4
= ffebld_head (ffebld_trail (list
));
4501 ffebld arg5
= ffebld_head (ffebld_trail (ffebld_trail (list
)));
4505 tree arg5_plus_arg3
;
4507 ffecom_push_calltemps ();
4509 arg2_tree
= convert (integer_type_node
,
4510 ffecom_expr (arg2
));
4511 arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4512 ffecom_expr (arg3
)));
4513 arg4_tree
= ffecom_expr_rw (arg4
);
4514 arg4_type
= TREE_TYPE (arg4_tree
);
4516 arg1_tree
= ffecom_save_tree (convert (arg4_type
,
4517 ffecom_expr (arg1
)));
4519 arg5_tree
= ffecom_save_tree (convert (integer_type_node
,
4520 ffecom_expr (arg5
)));
4522 ffecom_pop_calltemps ();
4525 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4526 ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4527 ffecom_2 (RSHIFT_EXPR
, arg4_type
,
4530 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4531 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4532 ffecom_1 (BIT_NOT_EXPR
,
4536 integer_zero_node
)),
4540 = ffecom_save_tree (ffecom_2 (PLUS_EXPR
, arg4_type
,
4544 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4545 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4547 integer_zero_node
)),
4549 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4551 = ffecom_3 (COND_EXPR
, arg4_type
,
4553 (ffecom_2 (NE_EXPR
, integer_type_node
,
4555 convert (TREE_TYPE (arg5_plus_arg3
),
4556 TYPE_SIZE (arg4_type
)))),
4558 convert (arg4_type
, integer_zero_node
));
4561 = ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4563 ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4565 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4566 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4567 ffecom_1 (BIT_NOT_EXPR
,
4571 integer_zero_node
)),
4574 = ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4577 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4579 = ffecom_3 (COND_EXPR
, arg4_type
,
4581 (ffecom_2 (NE_EXPR
, integer_type_node
,
4583 convert (TREE_TYPE (arg3_tree
),
4584 integer_zero_node
))),
4588 = ffecom_3 (COND_EXPR
, arg4_type
,
4590 (ffecom_2 (NE_EXPR
, integer_type_node
,
4592 convert (TREE_TYPE (arg3_tree
),
4593 TYPE_SIZE (arg4_type
)))),
4598 = ffecom_2s (MODIFY_EXPR
, void_type_node
,
4601 /* Make sure SAVE_EXPRs get referenced early enough. */
4603 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4605 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4607 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4609 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4613 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4620 case FFEINTRIN_impDERF
:
4621 case FFEINTRIN_impERF
:
4622 case FFEINTRIN_impDERFC
:
4623 case FFEINTRIN_impERFC
:
4626 case FFEINTRIN_impIARGC
:
4627 /* extern int xargc; i__1 = xargc - 1; */
4628 expr_tree
= ffecom_2 (MINUS_EXPR
, TREE_TYPE (ffecom_tree_xargc_
),
4630 convert (TREE_TYPE (ffecom_tree_xargc_
),
4634 case FFEINTRIN_impSIGNAL_func
:
4635 case FFEINTRIN_impSIGNAL_subr
:
4641 ffecom_push_calltemps ();
4643 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4644 ffecom_expr (arg1
));
4645 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4646 build_pointer_type (TREE_TYPE (arg1_tree
)),
4649 /* Pass procedure as a pointer to it, anything else by value. */
4650 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4651 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4653 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4654 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4658 arg3_tree
= ffecom_expr_rw (arg3
);
4660 arg3_tree
= NULL_TREE
;
4662 ffecom_pop_calltemps ();
4664 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4665 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4666 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4669 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4670 ffecom_gfrt_kindtype (gfrt
),
4672 ((codegen_imp
== FFEINTRIN_impSIGNAL_subr
) ?
4676 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4678 if (arg3_tree
!= NULL_TREE
)
4680 = ffecom_modify (NULL_TREE
, arg3_tree
,
4681 convert (TREE_TYPE (arg3_tree
),
4686 case FFEINTRIN_impALARM
:
4692 ffecom_push_calltemps ();
4694 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4695 ffecom_expr (arg1
));
4696 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4697 build_pointer_type (TREE_TYPE (arg1_tree
)),
4700 /* Pass procedure as a pointer to it, anything else by value. */
4701 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4702 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4704 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4705 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4709 arg3_tree
= ffecom_expr_rw (arg3
);
4711 arg3_tree
= NULL_TREE
;
4713 ffecom_pop_calltemps ();
4715 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4716 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4717 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4720 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4721 ffecom_gfrt_kindtype (gfrt
),
4725 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4727 if (arg3_tree
!= NULL_TREE
)
4729 = ffecom_modify (NULL_TREE
, arg3_tree
,
4730 convert (TREE_TYPE (arg3_tree
),
4735 case FFEINTRIN_impCHDIR_subr
:
4736 case FFEINTRIN_impFDATE_subr
:
4737 case FFEINTRIN_impFGET_subr
:
4738 case FFEINTRIN_impFPUT_subr
:
4739 case FFEINTRIN_impGETCWD_subr
:
4740 case FFEINTRIN_impHOSTNM_subr
:
4741 case FFEINTRIN_impSYSTEM_subr
:
4742 case FFEINTRIN_impUNLINK_subr
:
4744 tree arg1_len
= integer_zero_node
;
4748 ffecom_push_calltemps ();
4750 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4753 arg2_tree
= ffecom_expr_rw (arg2
);
4755 arg2_tree
= NULL_TREE
;
4757 ffecom_pop_calltemps ();
4759 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4760 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4761 TREE_CHAIN (arg1_tree
) = arg1_len
;
4764 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4765 ffecom_gfrt_kindtype (gfrt
),
4769 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4771 if (arg2_tree
!= NULL_TREE
)
4773 = ffecom_modify (NULL_TREE
, arg2_tree
,
4774 convert (TREE_TYPE (arg2_tree
),
4779 case FFEINTRIN_impEXIT
:
4783 expr_tree
= build_tree_list (NULL_TREE
,
4784 ffecom_1 (ADDR_EXPR
,
4786 (ffecom_integer_type_node
),
4787 integer_zero_node
));
4790 ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4791 ffecom_gfrt_kindtype (gfrt
),
4795 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4797 case FFEINTRIN_impFLUSH
:
4799 gfrt
= FFECOM_gfrtFLUSH
;
4801 gfrt
= FFECOM_gfrtFLUSH1
;
4804 case FFEINTRIN_impCHMOD_subr
:
4805 case FFEINTRIN_impLINK_subr
:
4806 case FFEINTRIN_impRENAME_subr
:
4807 case FFEINTRIN_impSYMLNK_subr
:
4809 tree arg1_len
= integer_zero_node
;
4811 tree arg2_len
= integer_zero_node
;
4815 ffecom_push_calltemps ();
4817 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4818 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
4820 arg3_tree
= ffecom_expr_rw (arg3
);
4822 arg3_tree
= NULL_TREE
;
4824 ffecom_pop_calltemps ();
4826 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4827 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4828 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4829 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
4830 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4831 TREE_CHAIN (arg2_tree
) = arg1_len
;
4832 TREE_CHAIN (arg1_len
) = arg2_len
;
4833 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4834 ffecom_gfrt_kindtype (gfrt
),
4838 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4839 if (arg3_tree
!= NULL_TREE
)
4840 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4841 convert (TREE_TYPE (arg3_tree
),
4846 case FFEINTRIN_impLSTAT_subr
:
4847 case FFEINTRIN_impSTAT_subr
:
4849 tree arg1_len
= integer_zero_node
;
4854 ffecom_push_calltemps ();
4856 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4858 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4861 arg3_tree
= ffecom_expr_rw (arg3
);
4863 arg3_tree
= NULL_TREE
;
4865 ffecom_pop_calltemps ();
4867 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4868 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4869 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4870 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4871 TREE_CHAIN (arg2_tree
) = arg1_len
;
4872 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4873 ffecom_gfrt_kindtype (gfrt
),
4877 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4878 if (arg3_tree
!= NULL_TREE
)
4879 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4880 convert (TREE_TYPE (arg3_tree
),
4885 case FFEINTRIN_impFGETC_subr
:
4886 case FFEINTRIN_impFPUTC_subr
:
4890 tree arg2_len
= integer_zero_node
;
4893 ffecom_push_calltemps ();
4895 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4896 ffecom_expr (arg1
));
4897 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4898 build_pointer_type (TREE_TYPE (arg1_tree
)),
4901 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
4902 arg3_tree
= ffecom_expr_rw (arg3
);
4904 ffecom_pop_calltemps ();
4906 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4907 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4908 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
4909 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4910 TREE_CHAIN (arg2_tree
) = arg2_len
;
4912 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4913 ffecom_gfrt_kindtype (gfrt
),
4917 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4918 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4919 convert (TREE_TYPE (arg3_tree
),
4924 case FFEINTRIN_impFSTAT_subr
:
4930 ffecom_push_calltemps ();
4932 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4933 ffecom_expr (arg1
));
4934 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4935 build_pointer_type (TREE_TYPE (arg1_tree
)),
4938 arg2_tree
= convert (ffecom_f2c_ptr_to_integer_type_node
,
4939 ffecom_ptr_to_expr (arg2
));
4942 arg3_tree
= NULL_TREE
;
4944 arg3_tree
= ffecom_expr_rw (arg3
);
4946 ffecom_pop_calltemps ();
4948 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4949 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4950 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4951 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4952 ffecom_gfrt_kindtype (gfrt
),
4956 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4957 if (arg3_tree
!= NULL_TREE
) {
4958 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4959 convert (TREE_TYPE (arg3_tree
),
4965 case FFEINTRIN_impKILL_subr
:
4971 ffecom_push_calltemps ();
4973 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4974 ffecom_expr (arg1
));
4975 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4976 build_pointer_type (TREE_TYPE (arg1_tree
)),
4979 arg2_tree
= convert (ffecom_f2c_integer_type_node
,
4980 ffecom_expr (arg2
));
4981 arg2_tree
= ffecom_1 (ADDR_EXPR
,
4982 build_pointer_type (TREE_TYPE (arg2_tree
)),
4986 arg3_tree
= NULL_TREE
;
4988 arg3_tree
= ffecom_expr_rw (arg3
);
4990 ffecom_pop_calltemps ();
4992 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4993 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4994 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4995 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4996 ffecom_gfrt_kindtype (gfrt
),
5000 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
5001 if (arg3_tree
!= NULL_TREE
) {
5002 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5003 convert (TREE_TYPE (arg3_tree
),
5009 case FFEINTRIN_impCTIME_subr
:
5010 case FFEINTRIN_impTTYNAM_subr
:
5012 tree arg1_len
= integer_zero_node
;
5016 ffecom_push_calltemps ();
5018 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
5020 arg2_tree
= convert (((gfrt
== FFEINTRIN_impCTIME_subr
) ?
5021 ffecom_f2c_longint_type_node
:
5022 ffecom_f2c_integer_type_node
),
5023 ffecom_expr (arg2
));
5024 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5025 build_pointer_type (TREE_TYPE (arg2_tree
)),
5028 ffecom_pop_calltemps ();
5030 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5031 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5032 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5033 TREE_CHAIN (arg1_len
) = arg2_tree
;
5034 TREE_CHAIN (arg1_tree
) = arg1_len
;
5037 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5038 ffecom_gfrt_kindtype (gfrt
),
5042 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
5046 case FFEINTRIN_impIRAND
:
5047 case FFEINTRIN_impRAND
:
5048 /* Arg defaults to 0 (normal random case) */
5053 arg1_tree
= ffecom_integer_zero_node
;
5055 arg1_tree
= ffecom_expr (arg1
);
5056 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5058 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5059 build_pointer_type (TREE_TYPE (arg1_tree
)),
5061 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5063 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5064 ffecom_gfrt_kindtype (gfrt
),
5066 ((codegen_imp
== FFEINTRIN_impIRAND
) ?
5067 ffecom_f2c_integer_type_node
:
5068 ffecom_f2c_doublereal_type_node
),
5070 dest_tree
, dest
, dest_used
,
5075 case FFEINTRIN_impFTELL_subr
:
5076 case FFEINTRIN_impUMASK_subr
:
5081 ffecom_push_calltemps ();
5083 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5084 ffecom_expr (arg1
));
5085 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5086 build_pointer_type (TREE_TYPE (arg1_tree
)),
5090 arg2_tree
= NULL_TREE
;
5092 arg2_tree
= ffecom_expr_rw (arg2
);
5094 ffecom_pop_calltemps ();
5096 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5097 ffecom_gfrt_kindtype (gfrt
),
5100 build_tree_list (NULL_TREE
, arg1_tree
),
5101 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5103 if (arg2_tree
!= NULL_TREE
) {
5104 expr_tree
= ffecom_modify (NULL_TREE
, arg2_tree
,
5105 convert (TREE_TYPE (arg2_tree
),
5111 case FFEINTRIN_impCPU_TIME
:
5112 case FFEINTRIN_impSECOND_subr
:
5116 ffecom_push_calltemps ();
5118 arg1_tree
= ffecom_expr_rw (arg1
);
5120 ffecom_pop_calltemps ();
5123 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5124 ffecom_gfrt_kindtype (gfrt
),
5128 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
5131 = ffecom_modify (NULL_TREE
, arg1_tree
,
5132 convert (TREE_TYPE (arg1_tree
),
5137 case FFEINTRIN_impDTIME_subr
:
5138 case FFEINTRIN_impETIME_subr
:
5143 ffecom_push_calltemps ();
5145 arg1_tree
= ffecom_expr_rw (arg1
);
5147 arg2_tree
= ffecom_ptr_to_expr (arg2
);
5149 ffecom_pop_calltemps ();
5151 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5152 ffecom_gfrt_kindtype (gfrt
),
5155 build_tree_list (NULL_TREE
, arg2_tree
),
5156 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5158 expr_tree
= ffecom_modify (NULL_TREE
, arg1_tree
,
5159 convert (TREE_TYPE (arg1_tree
),
5164 /* Straightforward calls of libf2c routines: */
5165 case FFEINTRIN_impABORT
:
5166 case FFEINTRIN_impACCESS
:
5167 case FFEINTRIN_impBESJ0
:
5168 case FFEINTRIN_impBESJ1
:
5169 case FFEINTRIN_impBESJN
:
5170 case FFEINTRIN_impBESY0
:
5171 case FFEINTRIN_impBESY1
:
5172 case FFEINTRIN_impBESYN
:
5173 case FFEINTRIN_impCHDIR_func
:
5174 case FFEINTRIN_impCHMOD_func
:
5175 case FFEINTRIN_impDATE
:
5176 case FFEINTRIN_impDBESJ0
:
5177 case FFEINTRIN_impDBESJ1
:
5178 case FFEINTRIN_impDBESJN
:
5179 case FFEINTRIN_impDBESY0
:
5180 case FFEINTRIN_impDBESY1
:
5181 case FFEINTRIN_impDBESYN
:
5182 case FFEINTRIN_impDTIME_func
:
5183 case FFEINTRIN_impETIME_func
:
5184 case FFEINTRIN_impFGETC_func
:
5185 case FFEINTRIN_impFGET_func
:
5186 case FFEINTRIN_impFNUM
:
5187 case FFEINTRIN_impFPUTC_func
:
5188 case FFEINTRIN_impFPUT_func
:
5189 case FFEINTRIN_impFSEEK
:
5190 case FFEINTRIN_impFSTAT_func
:
5191 case FFEINTRIN_impFTELL_func
:
5192 case FFEINTRIN_impGERROR
:
5193 case FFEINTRIN_impGETARG
:
5194 case FFEINTRIN_impGETCWD_func
:
5195 case FFEINTRIN_impGETENV
:
5196 case FFEINTRIN_impGETGID
:
5197 case FFEINTRIN_impGETLOG
:
5198 case FFEINTRIN_impGETPID
:
5199 case FFEINTRIN_impGETUID
:
5200 case FFEINTRIN_impGMTIME
:
5201 case FFEINTRIN_impHOSTNM_func
:
5202 case FFEINTRIN_impIDATE_unix
:
5203 case FFEINTRIN_impIDATE_vxt
:
5204 case FFEINTRIN_impIERRNO
:
5205 case FFEINTRIN_impISATTY
:
5206 case FFEINTRIN_impITIME
:
5207 case FFEINTRIN_impKILL_func
:
5208 case FFEINTRIN_impLINK_func
:
5209 case FFEINTRIN_impLNBLNK
:
5210 case FFEINTRIN_impLSTAT_func
:
5211 case FFEINTRIN_impLTIME
:
5212 case FFEINTRIN_impMCLOCK8
:
5213 case FFEINTRIN_impMCLOCK
:
5214 case FFEINTRIN_impPERROR
:
5215 case FFEINTRIN_impRENAME_func
:
5216 case FFEINTRIN_impSECNDS
:
5217 case FFEINTRIN_impSECOND_func
:
5218 case FFEINTRIN_impSLEEP
:
5219 case FFEINTRIN_impSRAND
:
5220 case FFEINTRIN_impSTAT_func
:
5221 case FFEINTRIN_impSYMLNK_func
:
5222 case FFEINTRIN_impSYSTEM_CLOCK
:
5223 case FFEINTRIN_impSYSTEM_func
:
5224 case FFEINTRIN_impTIME8
:
5225 case FFEINTRIN_impTIME_unix
:
5226 case FFEINTRIN_impTIME_vxt
:
5227 case FFEINTRIN_impUMASK_func
:
5228 case FFEINTRIN_impUNLINK_func
:
5231 case FFEINTRIN_impCTIME_func
: /* CHARACTER functions not handled here. */
5232 case FFEINTRIN_impFDATE_func
: /* CHARACTER functions not handled here. */
5233 case FFEINTRIN_impTTYNAM_func
: /* CHARACTER functions not handled here. */
5234 case FFEINTRIN_impNONE
:
5235 case FFEINTRIN_imp
: /* Hush up gcc warning. */
5236 fprintf (stderr
, "No %s implementation.\n",
5237 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr
))));
5238 assert ("unimplemented intrinsic" == NULL
);
5239 return error_mark_node
;
5242 assert (gfrt
!= FFECOM_gfrt
); /* Must have an implementation! */
5244 ffecom_push_calltemps ();
5245 expr_tree
= ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt
),
5246 ffebld_right (expr
));
5247 ffecom_pop_calltemps ();
5249 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt
), ffecom_gfrt_kindtype (gfrt
),
5250 (ffe_is_f2c_library () && ffecom_gfrt_complex_
[gfrt
]),
5252 expr_tree
, dest_tree
, dest
, dest_used
,
5255 /**INDENT* (Do not reformat this comment even with -fca option.)
5256 Data-gathering files: Given the source file listed below, compiled with
5257 f2c I obtained the output file listed after that, and from the output
5258 file I derived the above code.
5260 -------- (begin input file to f2c)
5266 double precision D1,D2
5268 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
5297 c FFEINTRIN_impAIMAG
5298 call fooR(AIMAG(C1))
5303 c FFEINTRIN_impALOG10
5304 call fooR(ALOG10(R1))
5305 c FFEINTRIN_impAMAX0
5306 call fooR(AMAX0(I1,I2))
5307 c FFEINTRIN_impAMAX1
5308 call fooR(AMAX1(R1,R2))
5309 c FFEINTRIN_impAMIN0
5310 call fooR(AMIN0(I1,I2))
5311 c FFEINTRIN_impAMIN1
5312 call fooR(AMIN1(R1,R2))
5314 call fooR(AMOD(R1,R2))
5315 c FFEINTRIN_impANINT
5316 call fooR(ANINT(R1))
5321 c FFEINTRIN_impATAN2
5322 call fooR(ATAN2(R1,R2))
5333 c FFEINTRIN_impCONJG
5334 call fooC(CONJG(C1))
5341 c FFEINTRIN_impCSQRT
5342 call fooC(CSQRT(C1))
5345 c FFEINTRIN_impDACOS
5346 call fooD(DACOS(D1))
5347 c FFEINTRIN_impDASIN
5348 call fooD(DASIN(D1))
5349 c FFEINTRIN_impDATAN
5350 call fooD(DATAN(D1))
5351 c FFEINTRIN_impDATAN2
5352 call fooD(DATAN2(D1,D2))
5355 c FFEINTRIN_impDCOSH
5356 call fooD(DCOSH(D1))
5358 call fooD(DDIM(D1,D2))
5362 call fooR(DIM(R1,R2))
5367 c FFEINTRIN_impDLOG10
5368 call fooD(DLOG10(D1))
5369 c FFEINTRIN_impDMAX1
5370 call fooD(DMAX1(D1,D2))
5371 c FFEINTRIN_impDMIN1
5372 call fooD(DMIN1(D1,D2))
5374 call fooD(DMOD(D1,D2))
5375 c FFEINTRIN_impDNINT
5376 call fooD(DNINT(D1))
5377 c FFEINTRIN_impDPROD
5378 call fooD(DPROD(R1,R2))
5379 c FFEINTRIN_impDSIGN
5380 call fooD(DSIGN(D1,D2))
5383 c FFEINTRIN_impDSINH
5384 call fooD(DSINH(D1))
5385 c FFEINTRIN_impDSQRT
5386 call fooD(DSQRT(D1))
5389 c FFEINTRIN_impDTANH
5390 call fooD(DTANH(D1))
5395 c FFEINTRIN_impICHAR
5396 call fooI(ICHAR(A1))
5398 call fooI(IDIM(I1,I2))
5399 c FFEINTRIN_impIDNINT
5400 call fooI(IDNINT(D1))
5401 c FFEINTRIN_impINDEX
5402 call fooI(INDEX(A1,A2))
5403 c FFEINTRIN_impISIGN
5404 call fooI(ISIGN(I1,I2))
5408 call fooL(LGE(A1,A2))
5410 call fooL(LGT(A1,A2))
5412 call fooL(LLE(A1,A2))
5414 call fooL(LLT(A1,A2))
5416 call fooI(MAX0(I1,I2))
5418 call fooI(MAX1(R1,R2))
5420 call fooI(MIN0(I1,I2))
5422 call fooI(MIN1(R1,R2))
5424 call fooI(MOD(I1,I2))
5428 call fooR(SIGN(R1,R2))
5439 c FFEINTRIN_imp_CMPLX_C
5440 call fooC(cmplx(C1,C2))
5441 c FFEINTRIN_imp_CMPLX_D
5442 call fooZ(cmplx(D1,D2))
5443 c FFEINTRIN_imp_CMPLX_I
5444 call fooC(cmplx(I1,I2))
5445 c FFEINTRIN_imp_CMPLX_R
5446 call fooC(cmplx(R1,R2))
5447 c FFEINTRIN_imp_DBLE_C
5449 c FFEINTRIN_imp_DBLE_D
5451 c FFEINTRIN_imp_DBLE_I
5453 c FFEINTRIN_imp_DBLE_R
5455 c FFEINTRIN_imp_INT_C
5457 c FFEINTRIN_imp_INT_D
5459 c FFEINTRIN_imp_INT_I
5461 c FFEINTRIN_imp_INT_R
5463 c FFEINTRIN_imp_REAL_C
5465 c FFEINTRIN_imp_REAL_D
5467 c FFEINTRIN_imp_REAL_I
5469 c FFEINTRIN_imp_REAL_R
5472 c FFEINTRIN_imp_INT_D:
5474 c FFEINTRIN_specIDINT
5475 call fooI(IDINT(D1))
5477 c FFEINTRIN_imp_INT_R:
5479 c FFEINTRIN_specIFIX
5484 c FFEINTRIN_imp_REAL_D:
5486 c FFEINTRIN_specSNGL
5489 c FFEINTRIN_imp_REAL_I:
5491 c FFEINTRIN_specFLOAT
5492 call fooR(FLOAT(I1))
5493 c FFEINTRIN_specREAL
5497 -------- (end input file to f2c)
5499 -------- (begin output from providing above input file as input to:
5500 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
5501 -------- -e "s:^#.*$::g"')
5503 // -- translated by f2c (version 19950223).
5504 You must link the resulting object file with the libraries:
5505 -lf2c -lm (in that order)
5509 // f2c.h -- Standard Fortran to C header file //
5511 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
5513 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
5518 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
5519 // we assume short, float are OK //
5520 typedef long int // long int // integer;
5521 typedef char *address;
5522 typedef short int shortint;
5524 typedef double doublereal;
5525 typedef struct { real r, i; } complex;
5526 typedef struct { doublereal r, i; } doublecomplex;
5527 typedef long int // long int // logical;
5528 typedef short int shortlogical;
5529 typedef char logical1;
5530 typedef char integer1;
5531 // typedef long long longint; // // system-dependent //
5536 // Extern is for use with -E //
5550 typedef long int // int or long int // flag;
5551 typedef long int // int or long int // ftnlen;
5552 typedef long int // int or long int // ftnint;
5555 //external read, write//
5564 //internal read, write//
5594 //rewind, backspace, endfile//
5606 ftnint *inex; //parameters in standard's order//
5632 union Multitype { // for multiple entry points //
5643 typedef union Multitype Multitype;
5645 typedef long Long; // No longer used; formerly in Namelist //
5647 struct Vardesc { // for Namelist //
5653 typedef struct Vardesc Vardesc;
5660 typedef struct Namelist Namelist;
5669 // procedure parameter types for -A and -C++ //
5674 typedef int // Unknown procedure type // (*U_fp)();
5675 typedef shortint (*J_fp)();
5676 typedef integer (*I_fp)();
5677 typedef real (*R_fp)();
5678 typedef doublereal (*D_fp)(), (*E_fp)();
5679 typedef // Complex // void (*C_fp)();
5680 typedef // Double Complex // void (*Z_fp)();
5681 typedef logical (*L_fp)();
5682 typedef shortlogical (*K_fp)();
5683 typedef // Character // void (*H_fp)();
5684 typedef // Subroutine // int (*S_fp)();
5686 // E_fp is for real functions when -R is not specified //
5687 typedef void C_f; // complex function //
5688 typedef void H_f; // character function //
5689 typedef void Z_f; // double complex function //
5690 typedef doublereal E_f; // real function with -R not specified //
5692 // undef any lower-case symbols that your C compiler predefines, e.g.: //
5695 // (No such symbols should be defined in a strict ANSI C compiler.
5696 We can avoid trouble with f2c-translated code by using
5697 gcc -ansi [-traditional].) //
5721 // Main program // MAIN__()
5723 // System generated locals //
5726 doublereal d__1, d__2;
5728 doublecomplex z__1, z__2, z__3;
5732 // Builtin functions //
5735 double pow_ri(), pow_di();
5739 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
5740 asin(), atan(), atan2(), c_abs();
5741 void c_cos(), c_exp(), c_log(), r_cnjg();
5742 double cos(), cosh();
5743 void c_sin(), c_sqrt();
5744 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
5745 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
5746 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
5747 logical l_ge(), l_gt(), l_le(), l_lt();
5751 // Local variables //
5752 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
5753 fool_(), fooz_(), getem_();
5754 static char a1[10], a2[10];
5755 static complex c1, c2;
5756 static doublereal d1, d2;
5757 static integer i1, i2;
5761 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
5769 d__1 = (doublereal) i1;
5770 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
5780 c_div(&q__1, &c1, &c2);
5782 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
5784 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
5787 i__1 = pow_ii(&i1, &i2);
5789 r__1 = pow_ri(&r1, &i1);
5791 d__1 = pow_di(&d1, &i1);
5793 pow_ci(&q__1, &c1, &i1);
5795 d__1 = (doublereal) r1;
5796 d__2 = (doublereal) r2;
5797 r__1 = pow_dd(&d__1, &d__2);
5799 d__2 = (doublereal) r1;
5800 d__1 = pow_dd(&d__2, &d1);
5802 d__1 = pow_dd(&d1, &d2);
5804 d__2 = (doublereal) r1;
5805 d__1 = pow_dd(&d1, &d__2);
5807 z__2.r = c1.r, z__2.i = c1.i;
5808 z__3.r = c2.r, z__3.i = c2.i;
5809 pow_zz(&z__1, &z__2, &z__3);
5810 q__1.r = z__1.r, q__1.i = z__1.i;
5812 z__2.r = c1.r, z__2.i = c1.i;
5813 z__3.r = r1, z__3.i = 0.;
5814 pow_zz(&z__1, &z__2, &z__3);
5815 q__1.r = z__1.r, q__1.i = z__1.i;
5817 z__2.r = c1.r, z__2.i = c1.i;
5818 z__3.r = d1, z__3.i = 0.;
5819 pow_zz(&z__1, &z__2, &z__3);
5821 // FFEINTRIN_impABS //
5822 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
5824 // FFEINTRIN_impACOS //
5827 // FFEINTRIN_impAIMAG //
5830 // FFEINTRIN_impAINT //
5833 // FFEINTRIN_impALOG //
5836 // FFEINTRIN_impALOG10 //
5839 // FFEINTRIN_impAMAX0 //
5840 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
5842 // FFEINTRIN_impAMAX1 //
5843 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
5845 // FFEINTRIN_impAMIN0 //
5846 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
5848 // FFEINTRIN_impAMIN1 //
5849 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
5851 // FFEINTRIN_impAMOD //
5852 r__1 = r_mod(&r1, &r2);
5854 // FFEINTRIN_impANINT //
5857 // FFEINTRIN_impASIN //
5860 // FFEINTRIN_impATAN //
5863 // FFEINTRIN_impATAN2 //
5864 r__1 = atan2(r1, r2);
5866 // FFEINTRIN_impCABS //
5869 // FFEINTRIN_impCCOS //
5872 // FFEINTRIN_impCEXP //
5875 // FFEINTRIN_impCHAR //
5876 *(unsigned char *)&ch__1[0] = i1;
5878 // FFEINTRIN_impCLOG //
5881 // FFEINTRIN_impCONJG //
5884 // FFEINTRIN_impCOS //
5887 // FFEINTRIN_impCOSH //
5890 // FFEINTRIN_impCSIN //
5893 // FFEINTRIN_impCSQRT //
5896 // FFEINTRIN_impDABS //
5897 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
5899 // FFEINTRIN_impDACOS //
5902 // FFEINTRIN_impDASIN //
5905 // FFEINTRIN_impDATAN //
5908 // FFEINTRIN_impDATAN2 //
5909 d__1 = atan2(d1, d2);
5911 // FFEINTRIN_impDCOS //
5914 // FFEINTRIN_impDCOSH //
5917 // FFEINTRIN_impDDIM //
5918 d__1 = d_dim(&d1, &d2);
5920 // FFEINTRIN_impDEXP //
5923 // FFEINTRIN_impDIM //
5924 r__1 = r_dim(&r1, &r2);
5926 // FFEINTRIN_impDINT //
5929 // FFEINTRIN_impDLOG //
5932 // FFEINTRIN_impDLOG10 //
5935 // FFEINTRIN_impDMAX1 //
5936 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
5938 // FFEINTRIN_impDMIN1 //
5939 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
5941 // FFEINTRIN_impDMOD //
5942 d__1 = d_mod(&d1, &d2);
5944 // FFEINTRIN_impDNINT //
5947 // FFEINTRIN_impDPROD //
5948 d__1 = (doublereal) r1 * r2;
5950 // FFEINTRIN_impDSIGN //
5951 d__1 = d_sign(&d1, &d2);
5953 // FFEINTRIN_impDSIN //
5956 // FFEINTRIN_impDSINH //
5959 // FFEINTRIN_impDSQRT //
5962 // FFEINTRIN_impDTAN //
5965 // FFEINTRIN_impDTANH //
5968 // FFEINTRIN_impEXP //
5971 // FFEINTRIN_impIABS //
5972 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
5974 // FFEINTRIN_impICHAR //
5975 i__1 = *(unsigned char *)a1;
5977 // FFEINTRIN_impIDIM //
5978 i__1 = i_dim(&i1, &i2);
5980 // FFEINTRIN_impIDNINT //
5983 // FFEINTRIN_impINDEX //
5984 i__1 = i_indx(a1, a2, 10L, 10L);
5986 // FFEINTRIN_impISIGN //
5987 i__1 = i_sign(&i1, &i2);
5989 // FFEINTRIN_impLEN //
5990 i__1 = i_len(a1, 10L);
5992 // FFEINTRIN_impLGE //
5993 L__1 = l_ge(a1, a2, 10L, 10L);
5995 // FFEINTRIN_impLGT //
5996 L__1 = l_gt(a1, a2, 10L, 10L);
5998 // FFEINTRIN_impLLE //
5999 L__1 = l_le(a1, a2, 10L, 10L);
6001 // FFEINTRIN_impLLT //
6002 L__1 = l_lt(a1, a2, 10L, 10L);
6004 // FFEINTRIN_impMAX0 //
6005 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
6007 // FFEINTRIN_impMAX1 //
6008 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
6010 // FFEINTRIN_impMIN0 //
6011 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
6013 // FFEINTRIN_impMIN1 //
6014 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
6016 // FFEINTRIN_impMOD //
6019 // FFEINTRIN_impNINT //
6022 // FFEINTRIN_impSIGN //
6023 r__1 = r_sign(&r1, &r2);
6025 // FFEINTRIN_impSIN //
6028 // FFEINTRIN_impSINH //
6031 // FFEINTRIN_impSQRT //
6034 // FFEINTRIN_impTAN //
6037 // FFEINTRIN_impTANH //
6040 // FFEINTRIN_imp_CMPLX_C //
6043 q__1.r = r__1, q__1.i = r__2;
6045 // FFEINTRIN_imp_CMPLX_D //
6046 z__1.r = d1, z__1.i = d2;
6048 // FFEINTRIN_imp_CMPLX_I //
6051 q__1.r = r__1, q__1.i = r__2;
6053 // FFEINTRIN_imp_CMPLX_R //
6054 q__1.r = r1, q__1.i = r2;
6056 // FFEINTRIN_imp_DBLE_C //
6057 d__1 = (doublereal) c1.r;
6059 // FFEINTRIN_imp_DBLE_D //
6062 // FFEINTRIN_imp_DBLE_I //
6063 d__1 = (doublereal) i1;
6065 // FFEINTRIN_imp_DBLE_R //
6066 d__1 = (doublereal) r1;
6068 // FFEINTRIN_imp_INT_C //
6069 i__1 = (integer) c1.r;
6071 // FFEINTRIN_imp_INT_D //
6072 i__1 = (integer) d1;
6074 // FFEINTRIN_imp_INT_I //
6077 // FFEINTRIN_imp_INT_R //
6078 i__1 = (integer) r1;
6080 // FFEINTRIN_imp_REAL_C //
6083 // FFEINTRIN_imp_REAL_D //
6086 // FFEINTRIN_imp_REAL_I //
6089 // FFEINTRIN_imp_REAL_R //
6093 // FFEINTRIN_imp_INT_D: //
6095 // FFEINTRIN_specIDINT //
6096 i__1 = (integer) d1;
6099 // FFEINTRIN_imp_INT_R: //
6101 // FFEINTRIN_specIFIX //
6102 i__1 = (integer) r1;
6104 // FFEINTRIN_specINT //
6105 i__1 = (integer) r1;
6108 // FFEINTRIN_imp_REAL_D: //
6110 // FFEINTRIN_specSNGL //
6114 // FFEINTRIN_imp_REAL_I: //
6116 // FFEINTRIN_specFLOAT //
6119 // FFEINTRIN_specREAL //
6125 -------- (end output file from f2c)
6131 /* For power (exponentiation) where right-hand operand is type INTEGER,
6132 generate in-line code to do it the fast way (which, if the operand
6133 is a constant, might just mean a series of multiplies). */
6135 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6137 ffecom_expr_power_integer_ (ffebld left
, ffebld right
)
6139 tree l
= ffecom_expr (left
);
6140 tree r
= ffecom_expr (right
);
6141 tree ltype
= TREE_TYPE (l
);
6142 tree rtype
= TREE_TYPE (r
);
6143 tree result
= NULL_TREE
;
6145 if (l
== error_mark_node
6146 || r
== error_mark_node
)
6147 return error_mark_node
;
6149 if (TREE_CODE (r
) == INTEGER_CST
)
6151 int sgn
= tree_int_cst_sgn (r
);
6154 return convert (ltype
, integer_one_node
);
6156 if ((TREE_CODE (ltype
) == INTEGER_TYPE
)
6159 /* Reciprocal of integer is either 0, -1, or 1, so after
6160 calculating that (which we leave to the back end to do
6161 or not do optimally), don't bother with any multiplying. */
6163 result
= ffecom_tree_divide_ (ltype
,
6164 convert (ltype
, integer_one_node
),
6166 NULL_TREE
, NULL
, NULL
);
6167 r
= ffecom_1 (NEGATE_EXPR
,
6170 if ((TREE_INT_CST_LOW (r
) & 1) == 0)
6171 result
= ffecom_1 (ABS_EXPR
, rtype
,
6175 /* Generate appropriate series of multiplies, preceded
6176 by divide if the exponent is negative. */
6182 l
= ffecom_tree_divide_ (ltype
,
6183 convert (ltype
, integer_one_node
),
6185 NULL_TREE
, NULL
, NULL
);
6186 r
= ffecom_1 (NEGATE_EXPR
, rtype
, r
);
6187 assert (TREE_CODE (r
) == INTEGER_CST
);
6189 if (tree_int_cst_sgn (r
) < 0)
6190 { /* The "most negative" number. */
6191 r
= ffecom_1 (NEGATE_EXPR
, rtype
,
6192 ffecom_2 (RSHIFT_EXPR
, rtype
,
6196 l
= ffecom_2 (MULT_EXPR
, ltype
,
6204 if (TREE_INT_CST_LOW (r
) & 1)
6206 if (result
== NULL_TREE
)
6209 result
= ffecom_2 (MULT_EXPR
, ltype
,
6214 r
= ffecom_2 (RSHIFT_EXPR
, rtype
,
6217 if (integer_zerop (r
))
6219 assert (TREE_CODE (r
) == INTEGER_CST
);
6222 l
= ffecom_2 (MULT_EXPR
, ltype
,
6229 /* Though rhs isn't a constant, in-line code cannot be expanded
6230 while transforming dummies
6231 because the back end cannot be easily convinced to generate
6232 stores (MODIFY_EXPR), handle temporaries, and so on before
6233 all the appropriate rtx's have been generated for things like
6234 dummy args referenced in rhs -- which doesn't happen until
6235 store_parm_decls() is called (expand_function_start, I believe,
6236 does the actual rtx-stuffing of PARM_DECLs).
6238 So, in this case, let the caller generate the call to the
6239 run-time-library function to evaluate the power for us. */
6241 if (ffecom_transform_only_dummies_
)
6244 /* Right-hand operand not a constant, expand in-line code to figure
6245 out how to do the multiplies, &c.
6247 The returned expression is expressed this way in GNU C, where l and
6250 ({ typeof (r) rtmp = r;
6251 typeof (l) ltmp = l;
6258 if ((basetypeof (l) == basetypeof (int))
6261 result = ((typeof (l)) 1) / ltmp;
6262 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
6268 if ((basetypeof (l) != basetypeof (int))
6271 ltmp = ((typeof (l)) 1) / ltmp;
6275 rtmp = -(rtmp >> 1);
6283 if ((rtmp >>= 1) == 0)
6292 Note that some of the above is compile-time collapsable, such as
6293 the first part of the if statements that checks the base type of
6294 l against int. The if statements are phrased that way to suggest
6295 an easy way to generate the if/else constructs here, knowing that
6296 the back end should (and probably does) eliminate the resulting
6297 dead code (either the int case or the non-int case), something
6298 it couldn't do without the redundant phrasing, requiring explicit
6299 dead-code elimination here, which would be kind of difficult to
6305 tree basetypeof_l_is_int
;
6309 = build_int_2 ((TREE_CODE (ltype
) == INTEGER_TYPE
), 0);
6311 se
= expand_start_stmt_expr ();
6312 ffecom_push_calltemps ();
6314 rtmp
= ffecom_push_tempvar (rtype
, FFETARGET_charactersizeNONE
, -1,
6316 ltmp
= ffecom_push_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1,
6318 result
= ffecom_push_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1,
6321 expand_expr_stmt (ffecom_modify (void_type_node
,
6324 expand_expr_stmt (ffecom_modify (void_type_node
,
6327 expand_start_cond (ffecom_truth_value
6328 (ffecom_2 (EQ_EXPR
, integer_type_node
,
6330 convert (rtype
, integer_zero_node
))),
6332 expand_expr_stmt (ffecom_modify (void_type_node
,
6334 convert (ltype
, integer_one_node
)));
6335 expand_start_else ();
6336 if (!integer_zerop (basetypeof_l_is_int
))
6338 expand_start_cond (ffecom_2 (LT_EXPR
, integer_type_node
,
6341 integer_zero_node
)),
6343 expand_expr_stmt (ffecom_modify (void_type_node
,
6347 convert (ltype
, integer_one_node
),
6349 NULL_TREE
, NULL
, NULL
)));
6350 expand_start_cond (ffecom_truth_value
6351 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
6352 ffecom_2 (LT_EXPR
, integer_type_node
,
6355 integer_zero_node
)),
6356 ffecom_2 (EQ_EXPR
, integer_type_node
,
6357 ffecom_2 (BIT_AND_EXPR
,
6359 ffecom_1 (NEGATE_EXPR
,
6365 integer_zero_node
)))),
6367 expand_expr_stmt (ffecom_modify (void_type_node
,
6369 ffecom_1 (NEGATE_EXPR
,
6373 expand_start_else ();
6375 expand_expr_stmt (ffecom_modify (void_type_node
,
6377 convert (ltype
, integer_one_node
)));
6378 expand_start_cond (ffecom_truth_value
6379 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
6380 ffecom_truth_value_invert
6381 (basetypeof_l_is_int
),
6382 ffecom_2 (LT_EXPR
, integer_type_node
,
6385 integer_zero_node
)))),
6387 expand_expr_stmt (ffecom_modify (void_type_node
,
6391 convert (ltype
, integer_one_node
),
6393 NULL_TREE
, NULL
, NULL
)));
6394 expand_expr_stmt (ffecom_modify (void_type_node
,
6396 ffecom_1 (NEGATE_EXPR
, rtype
,
6398 expand_start_cond (ffecom_truth_value
6399 (ffecom_2 (LT_EXPR
, integer_type_node
,
6401 convert (rtype
, integer_zero_node
))),
6403 expand_expr_stmt (ffecom_modify (void_type_node
,
6405 ffecom_1 (NEGATE_EXPR
, rtype
,
6406 ffecom_2 (RSHIFT_EXPR
,
6409 integer_one_node
))));
6410 expand_expr_stmt (ffecom_modify (void_type_node
,
6412 ffecom_2 (MULT_EXPR
, ltype
,
6417 expand_start_loop (1);
6418 expand_start_cond (ffecom_truth_value
6419 (ffecom_2 (BIT_AND_EXPR
, rtype
,
6421 convert (rtype
, integer_one_node
))),
6423 expand_expr_stmt (ffecom_modify (void_type_node
,
6425 ffecom_2 (MULT_EXPR
, ltype
,
6429 expand_exit_loop_if_false (NULL
,
6431 (ffecom_modify (rtype
,
6433 ffecom_2 (RSHIFT_EXPR
,
6436 integer_one_node
))));
6437 expand_expr_stmt (ffecom_modify (void_type_node
,
6439 ffecom_2 (MULT_EXPR
, ltype
,
6444 if (!integer_zerop (basetypeof_l_is_int
))
6446 expand_expr_stmt (result
);
6448 ffecom_pop_calltemps ();
6449 result
= expand_end_stmt_expr (se
);
6450 TREE_SIDE_EFFECTS (result
) = 1;
6457 /* ffecom_expr_transform_ -- Transform symbols in expr
6459 ffebld expr; // FFE expression.
6460 ffecom_expr_transform_ (expr);
6462 Recursive descent on expr while transforming any untransformed SYMTERs. */
6464 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6466 ffecom_expr_transform_ (ffebld expr
)
6471 tail_recurse
: /* :::::::::::::::::::: */
6476 switch (ffebld_op (expr
))
6478 case FFEBLD_opSYMTER
:
6479 s
= ffebld_symter (expr
);
6480 t
= ffesymbol_hook (s
).decl_tree
;
6481 if ((t
== NULL_TREE
)
6482 && ((ffesymbol_kind (s
) != FFEINFO_kindNONE
)
6483 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
6484 && (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
))))
6486 s
= ffecom_sym_transform_ (s
);
6487 t
= ffesymbol_hook (s
).decl_tree
; /* Sfunc expr non-dummy,
6490 break; /* Ok if (t == NULL) here. */
6493 ffecom_expr_transform_ (ffebld_head (expr
));
6494 expr
= ffebld_trail (expr
);
6495 goto tail_recurse
; /* :::::::::::::::::::: */
6501 switch (ffebld_arity (expr
))
6504 ffecom_expr_transform_ (ffebld_left (expr
));
6505 expr
= ffebld_right (expr
);
6506 goto tail_recurse
; /* :::::::::::::::::::: */
6509 expr
= ffebld_left (expr
);
6510 goto tail_recurse
; /* :::::::::::::::::::: */
6520 /* Make a type based on info in live f2c.h file. */
6522 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6524 ffecom_f2c_make_type_ (tree
*type
, int tcode
, char *name
)
6528 case FFECOM_f2ccodeCHAR
:
6529 *type
= make_signed_type (CHAR_TYPE_SIZE
);
6532 case FFECOM_f2ccodeSHORT
:
6533 *type
= make_signed_type (SHORT_TYPE_SIZE
);
6536 case FFECOM_f2ccodeINT
:
6537 *type
= make_signed_type (INT_TYPE_SIZE
);
6540 case FFECOM_f2ccodeLONG
:
6541 *type
= make_signed_type (LONG_TYPE_SIZE
);
6544 case FFECOM_f2ccodeLONGLONG
:
6545 *type
= make_signed_type (LONG_LONG_TYPE_SIZE
);
6548 case FFECOM_f2ccodeCHARPTR
:
6549 *type
= build_pointer_type (DEFAULT_SIGNED_CHAR
6550 ? signed_char_type_node
6551 : unsigned_char_type_node
);
6554 case FFECOM_f2ccodeFLOAT
:
6555 *type
= make_node (REAL_TYPE
);
6556 TYPE_PRECISION (*type
) = FLOAT_TYPE_SIZE
;
6557 layout_type (*type
);
6560 case FFECOM_f2ccodeDOUBLE
:
6561 *type
= make_node (REAL_TYPE
);
6562 TYPE_PRECISION (*type
) = DOUBLE_TYPE_SIZE
;
6563 layout_type (*type
);
6566 case FFECOM_f2ccodeLONGDOUBLE
:
6567 *type
= make_node (REAL_TYPE
);
6568 TYPE_PRECISION (*type
) = LONG_DOUBLE_TYPE_SIZE
;
6569 layout_type (*type
);
6572 case FFECOM_f2ccodeTWOREALS
:
6573 *type
= ffecom_make_complex_type_ (ffecom_f2c_real_type_node
);
6576 case FFECOM_f2ccodeTWODOUBLEREALS
:
6577 *type
= ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node
);
6581 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL
);
6582 *type
= error_mark_node
;
6586 pushdecl (build_decl (TYPE_DECL
,
6587 ffecom_get_invented_identifier ("__g77_f2c_%s",
6593 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6594 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6598 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
6604 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
6605 if (((t
= ffecom_tree_type
[bt
][j
]) != NULL_TREE
)
6606 && (TREE_INT_CST_LOW (TYPE_SIZE (t
)) == size
))
6608 assert (code
!= -1);
6609 ffecom_f2c_typecode_
[bt
][j
] = code
;
6615 /* Finish up globals after doing all program units in file
6617 Need to handle only uninitialized COMMON areas. */
6619 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6621 ffecom_finish_global_ (ffeglobal global
)
6627 if (ffeglobal_type (global
) != FFEGLOBAL_typeCOMMON
)
6630 if (ffeglobal_common_init (global
))
6633 cbt
= ffeglobal_hook (global
);
6634 if ((cbt
== NULL_TREE
)
6635 || !ffeglobal_common_have_size (global
))
6636 return global
; /* No need to make common, never ref'd. */
6638 suspend_momentary ();
6640 DECL_EXTERNAL (cbt
) = 0;
6642 /* Give the array a size now. */
6644 size
= build_int_2 (ffeglobal_common_size (global
), 0);
6646 cbtype
= TREE_TYPE (cbt
);
6647 TYPE_DOMAIN (cbtype
) = build_range_type (integer_type_node
,
6650 if (!TREE_TYPE (size
))
6651 TREE_TYPE (size
) = TYPE_DOMAIN (cbtype
);
6652 layout_type (cbtype
);
6654 cbt
= start_decl (cbt
, FALSE
);
6655 assert (cbt
== ffeglobal_hook (global
));
6657 finish_decl (cbt
, NULL_TREE
, FALSE
);
6663 /* Finish up any untransformed symbols. */
6665 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6667 ffecom_finish_symbol_transform_ (ffesymbol s
)
6669 if ((s
== NULL
) || (TREE_CODE (current_function_decl
) == ERROR_MARK
))
6672 /* It's easy to know to transform an untransformed symbol, to make sure
6673 we put out debugging info for it. But COMMON variables, unlike
6674 EQUIVALENCE ones, aren't given declarations in addition to the
6675 tree expressions that specify offsets, because COMMON variables
6676 can be referenced in the outer scope where only dummy arguments
6677 (PARM_DECLs) should really be seen. To be safe, just don't do any
6678 VAR_DECLs for COMMON variables when we transform them for real
6679 use, and therefore we do all the VAR_DECL creating here. */
6681 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
)
6683 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
6684 && (ffesymbol_kind (s
) == FFEINFO_kindFUNCTION
6685 || ffesymbol_kind (s
) == FFEINFO_kindSUBROUTINE
))
6687 /* An unreferenced statement function. If this refers to
6688 an undeclared array, it'll look like a reference to
6689 an external function that might not exist. Even if it
6690 does refer to an non-existent function, it seems silly
6691 to force a linker error when the function won't actually
6692 be called. But before the 1998-05-15 change to egcs/gcc
6693 toplev.c by Mark Mitchell, to fix other problems, this
6694 didn't actually happen, since gcc would defer nested
6695 functions to be compiled later only if needed. With that
6696 change, it makes sense to simply avoid telling the back
6697 end about the statement (nested) function at all. But
6698 if -Wunused is specified, might as well warn about it. */
6702 ffebad_start (FFEBAD_SFUNC_UNUSED
);
6703 ffebad_string (ffesymbol_text (s
));
6704 ffebad_here (0, ffesymbol_where_line (s
), ffesymbol_where_column (s
));
6708 else if (ffesymbol_kind (s
) != FFEINFO_kindNONE
6709 || (ffesymbol_where (s
) != FFEINFO_whereNONE
6710 && ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
6711 && ffesymbol_where (s
) != FFEINFO_whereDUMMY
))
6712 /* Not transformed, and not CHARACTER*(*), and not a dummy
6713 argument, which can happen only if the entry point names
6714 it "rides in on" are all invalidated for other reasons. */
6715 s
= ffecom_sym_transform_ (s
);
6718 if ((ffesymbol_where (s
) == FFEINFO_whereCOMMON
)
6719 && (ffesymbol_hook (s
).decl_tree
!= error_mark_node
))
6721 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
6722 int yes
= suspend_momentary ();
6724 /* This isn't working, at least for dbxout. The .s file looks
6725 okay to me (burley), but in gdb 4.9 at least, the variables
6726 appear to reside somewhere outside of the common area, so
6727 it doesn't make sense to mislead anyone by generating the info
6728 on those variables until this is fixed. NOTE: Same problem
6729 with EQUIVALENCE, sadly...see similar #if later. */
6730 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s
)),
6731 ffesymbol_storage (s
));
6733 resume_momentary (yes
);
6741 /* Append underscore(s) to name before calling get_identifier. "us"
6742 is nonzero if the name already contains an underscore and thus
6743 needs two underscores appended. */
6745 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6747 ffecom_get_appended_identifier_ (char us
, char *name
)
6753 newname
= xmalloc ((i
= strlen (name
)) + 1
6754 + ffe_is_underscoring ()
6756 memcpy (newname
, name
, i
);
6758 newname
[i
+ us
] = '_';
6759 newname
[i
+ 1 + us
] = '\0';
6760 id
= get_identifier (newname
);
6768 /* Decide whether to append underscore to name before calling
6771 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6773 ffecom_get_external_identifier_ (ffesymbol s
)
6776 char *name
= ffesymbol_text (s
);
6778 /* If name is a built-in name, just return it as is. */
6780 if (!ffe_is_underscoring ()
6781 || (strcmp (name
, FFETARGET_nameBLANK_COMMON
) == 0)
6782 #if FFETARGET_isENFORCED_MAIN_NAME
6783 || (strcmp (name
, FFETARGET_nameENFORCED_NAME
) == 0)
6785 || (strcmp (name
, FFETARGET_nameUNNAMED_MAIN
) == 0)
6787 || (strcmp (name
, FFETARGET_nameUNNAMED_BLOCK_DATA
) == 0))
6788 return get_identifier (name
);
6790 us
= ffe_is_second_underscore ()
6791 ? (strchr (name
, '_') != NULL
)
6794 return ffecom_get_appended_identifier_ (us
, name
);
6798 /* Decide whether to append underscore to internal name before calling
6801 This is for non-external, top-function-context names only. Transform
6802 identifier so it doesn't conflict with the transformed result
6803 of using a _different_ external name. E.g. if "CALL FOO" is
6804 transformed into "FOO_();", then the variable in "FOO_ = 3"
6805 must be transformed into something that does not conflict, since
6806 these two things should be independent.
6808 The transformation is as follows. If the name does not contain
6809 an underscore, there is no possible conflict, so just return.
6810 If the name does contain an underscore, then transform it just
6811 like we transform an external identifier. */
6813 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6815 ffecom_get_identifier_ (char *name
)
6817 /* If name does not contain an underscore, just return it as is. */
6819 if (!ffe_is_underscoring ()
6820 || (strchr (name
, '_') == NULL
))
6821 return get_identifier (name
);
6823 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6828 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6831 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6832 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6833 ffesymbol_kindtype(s));
6835 Call after setting up containing function and getting trees for all
6838 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6840 ffecom_gen_sfuncdef_ (ffesymbol s
, ffeinfoBasictype bt
, ffeinfoKindtype kt
)
6842 ffebld expr
= ffesymbol_sfexpr (s
);
6846 bool charfunc
= (bt
== FFEINFO_basictypeCHARACTER
);
6847 static bool recurse
= FALSE
;
6849 int old_lineno
= lineno
;
6850 char *old_input_filename
= input_filename
;
6852 ffecom_nested_entry_
= s
;
6854 /* For now, we don't have a handy pointer to where the sfunc is actually
6855 defined, though that should be easy to add to an ffesymbol. (The
6856 token/where info available might well point to the place where the type
6857 of the sfunc is declared, especially if that precedes the place where
6858 the sfunc itself is defined, which is typically the case.) We should
6859 put out a null pointer rather than point somewhere wrong, but I want to
6860 see how it works at this point. */
6862 input_filename
= ffesymbol_where_filename (s
);
6863 lineno
= ffesymbol_where_filelinenum (s
);
6865 /* Pretransform the expression so any newly discovered things belong to the
6866 outer program unit, not to the statement function. */
6868 ffecom_expr_transform_ (expr
);
6870 /* Make sure no recursive invocation of this fn (a specific case of failing
6871 to pretransform an sfunc's expression, i.e. where its expression
6872 references another untransformed sfunc) happens. */
6877 yes
= suspend_momentary ();
6879 push_f_function_context ();
6881 ffecom_push_calltemps ();
6884 type
= void_type_node
;
6887 type
= ffecom_tree_type
[bt
][kt
];
6888 if (type
== NULL_TREE
)
6889 type
= integer_type_node
; /* _sym_exec_transition reports
6893 start_function (ffecom_get_identifier_ (ffesymbol_text (s
)),
6894 build_function_type (type
, NULL_TREE
),
6895 1, /* nested/inline */
6896 0); /* TREE_PUBLIC */
6898 /* We don't worry about COMPLEX return values here, because this is
6899 entirely internal to our code, and gcc has the ability to return COMPLEX
6900 directly as a value. */
6902 yes
= suspend_momentary ();
6905 { /* Prepend arg for where result goes. */
6908 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
6910 result
= ffecom_get_invented_identifier ("__g77_%s",
6913 ffecom_char_enhance_arg_ (&type
, s
); /* Ignore returned length. */
6915 type
= build_pointer_type (type
);
6916 result
= build_decl (PARM_DECL
, result
, type
);
6918 push_parm_decl (result
);
6921 result
= NULL_TREE
; /* Not ref'd if !charfunc. */
6923 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s
), TRUE
);
6925 resume_momentary (yes
);
6927 store_parm_decls (0);
6929 ffecom_start_compstmt_ ();
6935 ffetargetCharacterSize sz
= ffesymbol_size (s
);
6938 result_length
= build_int_2 (sz
, 0);
6939 TREE_TYPE (result_length
) = ffecom_f2c_ftnlen_type_node
;
6941 ffecom_let_char_ (result
, result_length
, sz
, expr
);
6942 expand_null_return ();
6945 expand_return (ffecom_modify (NULL_TREE
,
6946 DECL_RESULT (current_function_decl
),
6947 ffecom_expr (expr
)));
6952 ffecom_end_compstmt_ ();
6954 func
= current_function_decl
;
6955 finish_function (1);
6957 ffecom_pop_calltemps ();
6959 pop_f_function_context ();
6961 resume_momentary (yes
);
6965 lineno
= old_lineno
;
6966 input_filename
= old_input_filename
;
6968 ffecom_nested_entry_
= NULL
;
6975 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6977 ffecom_gfrt_args_ (ffecomGfrt ix
)
6979 return ffecom_gfrt_argstring_
[ix
];
6983 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6985 ffecom_gfrt_tree_ (ffecomGfrt ix
)
6987 if (ffecom_gfrt_
[ix
] == NULL_TREE
)
6988 ffecom_make_gfrt_ (ix
);
6990 return ffecom_1 (ADDR_EXPR
,
6991 build_pointer_type (TREE_TYPE (ffecom_gfrt_
[ix
])),
6996 /* Return initialize-to-zero expression for this VAR_DECL. */
6998 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7000 ffecom_init_zero_ (tree decl
)
7003 int incremental
= TREE_STATIC (decl
);
7004 tree type
= TREE_TYPE (decl
);
7008 int momentary
= suspend_momentary ();
7009 push_obstacks_nochange ();
7010 if (TREE_PERMANENT (decl
))
7011 end_temporary_allocation ();
7012 make_decl_rtl (decl
, NULL
, TREE_PUBLIC (decl
) ? 1 : 0);
7013 assemble_variable (decl
, TREE_PUBLIC (decl
) ? 1 : 0, 0, 1);
7015 resume_momentary (momentary
);
7020 if ((TREE_CODE (type
) != ARRAY_TYPE
)
7021 && (TREE_CODE (type
) != RECORD_TYPE
)
7022 && (TREE_CODE (type
) != UNION_TYPE
)
7024 init
= convert (type
, integer_zero_node
);
7025 else if (!incremental
)
7027 int momentary
= suspend_momentary ();
7029 init
= build (CONSTRUCTOR
, type
, NULL_TREE
, NULL_TREE
);
7030 TREE_CONSTANT (init
) = 1;
7031 TREE_STATIC (init
) = 1;
7033 resume_momentary (momentary
);
7037 int momentary
= suspend_momentary ();
7039 assemble_zeros (int_size_in_bytes (type
));
7040 init
= error_mark_node
;
7042 resume_momentary (momentary
);
7045 pop_momentary_nofree ();
7051 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7053 ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
7059 switch (ffebld_op (arg
))
7061 case FFEBLD_opCONTER
: /* For F90, check 0-length. */
7062 if (ffetarget_length_character1
7063 (ffebld_constant_character1
7064 (ffebld_conter (arg
))) == 0)
7066 *maybe_tree
= integer_zero_node
;
7067 return convert (tree_type
, integer_zero_node
);
7070 *maybe_tree
= integer_one_node
;
7071 expr_tree
= build_int_2 (*ffetarget_text_character1
7072 (ffebld_constant_character1
7073 (ffebld_conter (arg
))),
7075 TREE_TYPE (expr_tree
) = tree_type
;
7078 case FFEBLD_opSYMTER
:
7079 case FFEBLD_opARRAYREF
:
7080 case FFEBLD_opFUNCREF
:
7081 case FFEBLD_opSUBSTR
:
7082 ffecom_push_calltemps ();
7083 ffecom_char_args_ (&expr_tree
, &length_tree
, arg
);
7084 ffecom_pop_calltemps ();
7086 if ((expr_tree
== error_mark_node
)
7087 || (length_tree
== error_mark_node
))
7089 *maybe_tree
= error_mark_node
;
7090 return error_mark_node
;
7093 if (integer_zerop (length_tree
))
7095 *maybe_tree
= integer_zero_node
;
7096 return convert (tree_type
, integer_zero_node
);
7100 = ffecom_1 (INDIRECT_REF
,
7101 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
7104 = ffecom_2 (ARRAY_REF
,
7105 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
7108 expr_tree
= convert (tree_type
, expr_tree
);
7110 if (TREE_CODE (length_tree
) == INTEGER_CST
)
7111 *maybe_tree
= integer_one_node
;
7112 else /* Must check length at run time. */
7114 = ffecom_truth_value
7115 (ffecom_2 (GT_EXPR
, integer_type_node
,
7117 ffecom_f2c_ftnlen_zero_node
));
7120 case FFEBLD_opPAREN
:
7121 case FFEBLD_opCONVERT
:
7122 if (ffeinfo_size (ffebld_info (arg
)) == 0)
7124 *maybe_tree
= integer_zero_node
;
7125 return convert (tree_type
, integer_zero_node
);
7127 return ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
7130 case FFEBLD_opCONCATENATE
:
7137 expr_left
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
7139 expr_right
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_right (arg
),
7141 *maybe_tree
= ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
7144 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
7152 assert ("bad op in ICHAR" == NULL
);
7153 return error_mark_node
;
7158 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
7162 length_arg = ffecom_intrinsic_len_ (expr);
7164 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
7165 subexpressions by constructing the appropriate tree for the
7166 length-of-character-text argument in a calling sequence. */
7168 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7170 ffecom_intrinsic_len_ (ffebld expr
)
7172 ffetargetCharacter1 val
;
7175 switch (ffebld_op (expr
))
7177 case FFEBLD_opCONTER
:
7178 val
= ffebld_constant_character1 (ffebld_conter (expr
));
7179 length
= build_int_2 (ffetarget_length_character1 (val
), 0);
7180 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
7183 case FFEBLD_opSYMTER
:
7185 ffesymbol s
= ffebld_symter (expr
);
7188 item
= ffesymbol_hook (s
).decl_tree
;
7189 if (item
== NULL_TREE
)
7191 s
= ffecom_sym_transform_ (s
);
7192 item
= ffesymbol_hook (s
).decl_tree
;
7194 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
7196 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
7197 length
= ffesymbol_hook (s
).length_tree
;
7200 length
= build_int_2 (ffesymbol_size (s
), 0);
7201 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
7204 else if (item
== error_mark_node
)
7205 length
= error_mark_node
;
7206 else /* FFEINFO_kindFUNCTION: */
7211 case FFEBLD_opARRAYREF
:
7212 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
7215 case FFEBLD_opSUBSTR
:
7219 ffebld thing
= ffebld_right (expr
);
7223 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
7224 start
= ffebld_head (thing
);
7225 thing
= ffebld_trail (thing
);
7226 assert (ffebld_trail (thing
) == NULL
);
7227 end
= ffebld_head (thing
);
7229 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
7231 if (length
== error_mark_node
)
7240 length
= convert (ffecom_f2c_ftnlen_type_node
,
7246 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
7247 ffecom_expr (start
));
7249 if (start_tree
== error_mark_node
)
7251 length
= error_mark_node
;
7257 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
7258 ffecom_f2c_ftnlen_one_node
,
7259 ffecom_2 (MINUS_EXPR
,
7260 ffecom_f2c_ftnlen_type_node
,
7266 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
7269 if (end_tree
== error_mark_node
)
7271 length
= error_mark_node
;
7275 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
7276 ffecom_f2c_ftnlen_one_node
,
7277 ffecom_2 (MINUS_EXPR
,
7278 ffecom_f2c_ftnlen_type_node
,
7279 end_tree
, start_tree
));
7285 case FFEBLD_opCONCATENATE
:
7287 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
7288 ffecom_intrinsic_len_ (ffebld_left (expr
)),
7289 ffecom_intrinsic_len_ (ffebld_right (expr
)));
7292 case FFEBLD_opFUNCREF
:
7293 case FFEBLD_opCONVERT
:
7294 length
= build_int_2 (ffebld_size (expr
), 0);
7295 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
7299 assert ("bad op for single char arg expr" == NULL
);
7300 length
= ffecom_f2c_ftnlen_zero_node
;
7304 assert (length
!= NULL_TREE
);
7310 /* ffecom_let_char_ -- Do assignment stuff for character type
7312 tree dest_tree; // destination (ADDR_EXPR)
7313 tree dest_length; // length (INT_CST/INDIRECT_REF(PARM_DECL))
7314 ffetargetCharacterSize dest_size; // length
7315 ffebld source; // source expression
7316 ffecom_let_char_(dest_tree,dest_length,dest_size,source);
7318 Generates code to do the assignment. Used by ordinary assignment
7319 statement handler ffecom_let_stmt and by statement-function
7320 handler to generate code for a statement function. */
7322 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7324 ffecom_let_char_ (tree dest_tree
, tree dest_length
,
7325 ffetargetCharacterSize dest_size
, ffebld source
)
7327 ffecomConcatList_ catlist
;
7332 if ((dest_tree
== error_mark_node
)
7333 || (dest_length
== error_mark_node
))
7336 assert (dest_tree
!= NULL_TREE
);
7337 assert (dest_length
!= NULL_TREE
);
7339 /* Source might be an opCONVERT, which just means it is a different size
7340 than the destination. Since the underlying implementation here handles
7341 that (directly or via the s_copy or s_cat run-time-library functions),
7342 we don't need the "convenience" of an opCONVERT that tells us to
7343 truncate or blank-pad, particularly since the resulting implementation
7344 would probably be slower than otherwise. */
7346 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
7347 source
= ffebld_left (source
);
7349 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
7350 switch (ffecom_concat_list_count_ (catlist
))
7352 case 0: /* Shouldn't happen, but in case it does... */
7353 ffecom_concat_list_kill_ (catlist
);
7354 source_tree
= null_pointer_node
;
7355 source_length
= ffecom_f2c_ftnlen_zero_node
;
7356 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
7357 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
7358 TREE_CHAIN (TREE_CHAIN (expr_tree
))
7359 = build_tree_list (NULL_TREE
, dest_length
);
7360 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
7361 = build_tree_list (NULL_TREE
, source_length
);
7363 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
);
7364 TREE_SIDE_EFFECTS (expr_tree
) = 1;
7366 expand_expr_stmt (expr_tree
);
7370 case 1: /* The (fairly) easy case. */
7371 ffecom_char_args_ (&source_tree
, &source_length
,
7372 ffecom_concat_list_expr_ (catlist
, 0));
7373 ffecom_concat_list_kill_ (catlist
);
7374 assert (source_tree
!= NULL_TREE
);
7375 assert (source_length
!= NULL_TREE
);
7377 if ((source_tree
== error_mark_node
)
7378 || (source_length
== error_mark_node
))
7384 = ffecom_1 (INDIRECT_REF
,
7385 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7389 = ffecom_2 (ARRAY_REF
,
7390 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7395 = ffecom_1 (INDIRECT_REF
,
7396 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7400 = ffecom_2 (ARRAY_REF
,
7401 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7406 expr_tree
= ffecom_modify (void_type_node
, dest_tree
, source_tree
);
7408 expand_expr_stmt (expr_tree
);
7413 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
7414 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
7415 TREE_CHAIN (TREE_CHAIN (expr_tree
))
7416 = build_tree_list (NULL_TREE
, dest_length
);
7417 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
7418 = build_tree_list (NULL_TREE
, source_length
);
7420 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
);
7421 TREE_SIDE_EFFECTS (expr_tree
) = 1;
7423 expand_expr_stmt (expr_tree
);
7427 default: /* Must actually concatenate things. */
7431 /* Heavy-duty concatenation. */
7434 int count
= ffecom_concat_list_count_ (catlist
);
7445 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
7446 FFETARGET_charactersizeNONE
, count
, TRUE
);
7447 item_array
= items
= ffecom_push_tempvar (ffecom_f2c_address_type_node
,
7448 FFETARGET_charactersizeNONE
,
7451 for (i
= 0; i
< count
; ++i
)
7453 ffecom_char_args_ (&citem
, &clength
,
7454 ffecom_concat_list_expr_ (catlist
, i
));
7455 if ((citem
== error_mark_node
)
7456 || (clength
== error_mark_node
))
7458 ffecom_concat_list_kill_ (catlist
);
7463 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
7464 ffecom_modify (void_type_node
,
7465 ffecom_2 (ARRAY_REF
,
7466 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
7468 build_int_2 (i
, 0)),
7472 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
7473 ffecom_modify (void_type_node
,
7474 ffecom_2 (ARRAY_REF
,
7475 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
7477 build_int_2 (i
, 0)),
7482 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
7483 TREE_CHAIN (expr_tree
)
7484 = build_tree_list (NULL_TREE
,
7485 ffecom_1 (ADDR_EXPR
,
7486 build_pointer_type (TREE_TYPE (items
)),
7488 TREE_CHAIN (TREE_CHAIN (expr_tree
))
7489 = build_tree_list (NULL_TREE
,
7490 ffecom_1 (ADDR_EXPR
,
7491 build_pointer_type (TREE_TYPE (lengths
)),
7493 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
7496 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
7497 convert (ffecom_f2c_ftnlen_type_node
,
7498 build_int_2 (count
, 0))));
7499 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
))))
7500 = build_tree_list (NULL_TREE
, dest_length
);
7502 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCAT
, expr_tree
);
7503 TREE_SIDE_EFFECTS (expr_tree
) = 1;
7505 expand_expr_stmt (expr_tree
);
7508 ffecom_concat_list_kill_ (catlist
);
7512 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
7515 ffecom_make_gfrt_(ix);
7517 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
7518 for the indicated run-time routine (ix). */
7520 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7522 ffecom_make_gfrt_ (ffecomGfrt ix
)
7527 push_obstacks_nochange ();
7528 end_temporary_allocation ();
7530 switch (ffecom_gfrt_type_
[ix
])
7532 case FFECOM_rttypeVOID_
:
7533 ttype
= void_type_node
;
7536 case FFECOM_rttypeVOIDSTAR_
:
7537 ttype
= TREE_TYPE (null_pointer_node
); /* `void *'. */
7540 case FFECOM_rttypeFTNINT_
:
7541 ttype
= ffecom_f2c_ftnint_type_node
;
7544 case FFECOM_rttypeINTEGER_
:
7545 ttype
= ffecom_f2c_integer_type_node
;
7548 case FFECOM_rttypeLONGINT_
:
7549 ttype
= ffecom_f2c_longint_type_node
;
7552 case FFECOM_rttypeLOGICAL_
:
7553 ttype
= ffecom_f2c_logical_type_node
;
7556 case FFECOM_rttypeREAL_F2C_
:
7557 ttype
= double_type_node
;
7560 case FFECOM_rttypeREAL_GNU_
:
7561 ttype
= float_type_node
;
7564 case FFECOM_rttypeCOMPLEX_F2C_
:
7565 ttype
= void_type_node
;
7568 case FFECOM_rttypeCOMPLEX_GNU_
:
7569 ttype
= ffecom_f2c_complex_type_node
;
7572 case FFECOM_rttypeDOUBLE_
:
7573 ttype
= double_type_node
;
7576 case FFECOM_rttypeDOUBLEREAL_
:
7577 ttype
= ffecom_f2c_doublereal_type_node
;
7580 case FFECOM_rttypeDBLCMPLX_F2C_
:
7581 ttype
= void_type_node
;
7584 case FFECOM_rttypeDBLCMPLX_GNU_
:
7585 ttype
= ffecom_f2c_doublecomplex_type_node
;
7588 case FFECOM_rttypeCHARACTER_
:
7589 ttype
= void_type_node
;
7594 assert ("bad rttype" == NULL
);
7598 ttype
= build_function_type (ttype
, NULL_TREE
);
7599 t
= build_decl (FUNCTION_DECL
,
7600 get_identifier (ffecom_gfrt_name_
[ix
]),
7602 DECL_EXTERNAL (t
) = 1;
7603 TREE_PUBLIC (t
) = 1;
7604 TREE_THIS_VOLATILE (t
) = ffecom_gfrt_volatile_
[ix
] ? 1 : 0;
7606 t
= start_decl (t
, TRUE
);
7608 finish_decl (t
, NULL_TREE
, TRUE
);
7610 resume_temporary_allocation ();
7613 ffecom_gfrt_
[ix
] = t
;
7617 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
7619 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7621 ffecom_member_phase1_ (ffestorag mst UNUSED
, ffestorag st
)
7623 ffesymbol s
= ffestorag_symbol (st
);
7625 if (ffesymbol_namelisted (s
))
7626 ffecom_member_namelisted_
= TRUE
;
7630 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
7631 the member so debugger will see it. Otherwise nobody should be
7632 referencing the member. */
7634 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7635 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
7637 ffecom_member_phase2_ (ffestorag mst
, ffestorag st
)
7645 || ((mt
= ffestorag_hook (mst
)) == NULL
)
7646 || (mt
== error_mark_node
))
7650 || ((s
= ffestorag_symbol (st
)) == NULL
))
7653 type
= ffecom_type_localvar_ (s
,
7654 ffesymbol_basictype (s
),
7655 ffesymbol_kindtype (s
));
7656 if (type
== error_mark_node
)
7659 t
= build_decl (VAR_DECL
,
7660 ffecom_get_identifier_ (ffesymbol_text (s
)),
7663 TREE_STATIC (t
) = TREE_STATIC (mt
);
7664 DECL_INITIAL (t
) = NULL_TREE
;
7665 TREE_ASM_WRITTEN (t
) = 1;
7668 = gen_rtx (MEM
, TYPE_MODE (type
),
7669 plus_constant (XEXP (DECL_RTL (mt
), 0),
7670 ffestorag_modulo (mst
)
7671 + ffestorag_offset (st
)
7672 - ffestorag_offset (mst
)));
7674 t
= start_decl (t
, FALSE
);
7676 finish_decl (t
, NULL_TREE
, FALSE
);
7681 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7683 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7684 (which generates their trees) and then their trees get push_parm_decl'd.
7686 The second arg is TRUE if the dummies are for a statement function, in
7687 which case lengths are not pushed for character arguments (since they are
7688 always known by both the caller and the callee, though the code allows
7689 for someday permitting CHAR*(*) stmtfunc dummies). */
7691 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7693 ffecom_push_dummy_decls_ (ffebld dummy_list
, bool stmtfunc
)
7700 ffecom_transform_only_dummies_
= TRUE
;
7702 /* First push the parms corresponding to actual dummy "contents". */
7704 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7706 dummy
= ffebld_head (dumlist
);
7707 switch (ffebld_op (dummy
))
7711 continue; /* Forget alternate returns. */
7716 assert (ffebld_op (dummy
) == FFEBLD_opSYMTER
);
7717 s
= ffebld_symter (dummy
);
7718 parm
= ffesymbol_hook (s
).decl_tree
;
7719 if (parm
== NULL_TREE
)
7721 s
= ffecom_sym_transform_ (s
);
7722 parm
= ffesymbol_hook (s
).decl_tree
;
7723 assert (parm
!= NULL_TREE
);
7725 if (parm
!= error_mark_node
)
7726 push_parm_decl (parm
);
7729 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7731 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7733 dummy
= ffebld_head (dumlist
);
7734 switch (ffebld_op (dummy
))
7738 continue; /* Forget alternate returns, they mean
7744 s
= ffebld_symter (dummy
);
7745 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
7746 continue; /* Only looking for CHARACTER arguments. */
7747 if (stmtfunc
&& (ffesymbol_size (s
) != FFETARGET_charactersizeNONE
))
7748 continue; /* Stmtfunc arg with known size needs no
7750 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
7751 continue; /* Only looking for variables and arrays. */
7752 parm
= ffesymbol_hook (s
).length_tree
;
7753 assert (parm
!= NULL_TREE
);
7754 if (parm
!= error_mark_node
)
7755 push_parm_decl (parm
);
7758 ffecom_transform_only_dummies_
= FALSE
;
7762 /* ffecom_start_progunit_ -- Beginning of program unit
7764 Does GNU back end stuff necessary to teach it about the start of its
7765 equivalent of a Fortran program unit. */
7767 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7769 ffecom_start_progunit_ ()
7771 ffesymbol fn
= ffecom_primary_entry_
;
7773 tree id
; /* Identifier (name) of function. */
7774 tree type
; /* Type of function. */
7775 tree result
; /* Result of function. */
7776 ffeinfoBasictype bt
;
7780 ffeglobalType egt
= FFEGLOBAL_type
;
7783 bool altentries
= (ffecom_num_entrypoints_
!= 0);
7786 && (ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
7787 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
7788 bool main_program
= FALSE
;
7789 int old_lineno
= lineno
;
7790 char *old_input_filename
= input_filename
;
7793 assert (fn
!= NULL
);
7794 assert (ffesymbol_hook (fn
).decl_tree
== NULL_TREE
);
7796 input_filename
= ffesymbol_where_filename (fn
);
7797 lineno
= ffesymbol_where_filelinenum (fn
);
7799 /* c-parse.y indeed does call suspend_momentary and not only ignores the
7800 return value, but also never calls resume_momentary, when starting an
7801 outer function (see "fndef:", "setspecs:", and so on). So g77 does the
7802 same thing. It shouldn't be a problem since start_function calls
7803 temporary_allocation, but it might be necessary. If it causes a problem
7804 here, then maybe there's a bug lurking in gcc. NOTE: This identical
7805 comment appears twice in thist file. */
7807 suspend_momentary ();
7809 switch (ffecom_primary_entry_kind_
)
7811 case FFEINFO_kindPROGRAM
:
7812 main_program
= TRUE
;
7813 gt
= FFEGLOBAL_typeMAIN
;
7814 bt
= FFEINFO_basictypeNONE
;
7815 kt
= FFEINFO_kindtypeNONE
;
7816 type
= ffecom_tree_fun_type_void
;
7821 case FFEINFO_kindBLOCKDATA
:
7822 gt
= FFEGLOBAL_typeBDATA
;
7823 bt
= FFEINFO_basictypeNONE
;
7824 kt
= FFEINFO_kindtypeNONE
;
7825 type
= ffecom_tree_fun_type_void
;
7830 case FFEINFO_kindFUNCTION
:
7831 gt
= FFEGLOBAL_typeFUNC
;
7832 egt
= FFEGLOBAL_typeEXT
;
7833 bt
= ffesymbol_basictype (fn
);
7834 kt
= ffesymbol_kindtype (fn
);
7835 if (bt
== FFEINFO_basictypeNONE
)
7837 ffeimplic_establish_symbol (fn
);
7838 if (ffesymbol_funcresult (fn
) != NULL
)
7839 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
7840 bt
= ffesymbol_basictype (fn
);
7841 kt
= ffesymbol_kindtype (fn
);
7845 charfunc
= cmplxfunc
= FALSE
;
7846 else if (bt
== FFEINFO_basictypeCHARACTER
)
7847 charfunc
= TRUE
, cmplxfunc
= FALSE
;
7848 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
7849 && ffesymbol_is_f2c (fn
)
7851 charfunc
= FALSE
, cmplxfunc
= TRUE
;
7853 charfunc
= cmplxfunc
= FALSE
;
7855 if (multi
|| charfunc
)
7856 type
= ffecom_tree_fun_type_void
;
7857 else if (ffesymbol_is_f2c (fn
) && !altentries
)
7858 type
= ffecom_tree_fun_type
[bt
][kt
];
7860 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
7862 if ((type
== NULL_TREE
)
7863 || (TREE_TYPE (type
) == NULL_TREE
))
7864 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
7867 case FFEINFO_kindSUBROUTINE
:
7868 gt
= FFEGLOBAL_typeSUBR
;
7869 egt
= FFEGLOBAL_typeEXT
;
7870 bt
= FFEINFO_basictypeNONE
;
7871 kt
= FFEINFO_kindtypeNONE
;
7872 if (ffecom_is_altreturning_
)
7873 type
= ffecom_tree_subr_type
;
7875 type
= ffecom_tree_fun_type_void
;
7881 assert ("say what??" == NULL
);
7883 case FFEINFO_kindANY
:
7884 gt
= FFEGLOBAL_typeANY
;
7885 bt
= FFEINFO_basictypeNONE
;
7886 kt
= FFEINFO_kindtypeNONE
;
7887 type
= error_mark_node
;
7895 id
= ffecom_get_invented_identifier ("__g77_masterfun_%s",
7896 ffesymbol_text (fn
),
7898 IDENTIFIER_INVENTED (id
) = 0; /* Allow this to be debugged. */
7900 #if FFETARGET_isENFORCED_MAIN
7901 else if (main_program
)
7902 id
= get_identifier (FFETARGET_nameENFORCED_MAIN_NAME
);
7905 id
= ffecom_get_external_identifier_ (fn
);
7909 0, /* nested/inline */
7910 !altentries
); /* TREE_PUBLIC */
7912 TREE_USED (current_function_decl
) = 1; /* Avoid spurious warning if altentries. */
7915 && ((g
= ffesymbol_global (fn
)) != NULL
)
7916 && ((ffeglobal_type (g
) == gt
)
7917 || (ffeglobal_type (g
) == egt
)))
7919 ffeglobal_set_hook (g
, current_function_decl
);
7922 yes
= suspend_momentary ();
7924 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7925 exec-transitioning needs current_function_decl to be filled in. So we
7926 do these things in two phases. */
7929 { /* 1st arg identifies which entrypoint. */
7930 ffecom_which_entrypoint_decl_
7931 = build_decl (PARM_DECL
,
7932 ffecom_get_invented_identifier ("__g77_%s",
7936 push_parm_decl (ffecom_which_entrypoint_decl_
);
7942 { /* Arg for result (return value). */
7947 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
7949 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
7951 type
= ffecom_multi_type_node_
;
7953 result
= ffecom_get_invented_identifier ("__g77_%s",
7956 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7959 length
= ffecom_char_enhance_arg_ (&type
, fn
);
7961 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
7963 type
= build_pointer_type (type
);
7964 result
= build_decl (PARM_DECL
, result
, type
);
7966 push_parm_decl (result
);
7968 ffecom_multi_retval_
= result
;
7970 ffecom_func_result_
= result
;
7974 push_parm_decl (length
);
7975 ffecom_func_length_
= length
;
7979 if (ffecom_primary_entry_is_proc_
)
7982 arglist
= ffecom_master_arglist_
;
7984 arglist
= ffesymbol_dummyargs (fn
);
7985 ffecom_push_dummy_decls_ (arglist
, FALSE
);
7988 resume_momentary (yes
);
7990 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
7991 store_parm_decls (main_program
? 1 : 0);
7993 ffecom_start_compstmt_ ();
7995 lineno
= old_lineno
;
7996 input_filename
= old_input_filename
;
7998 /* This handles any symbols still untransformed, in case -g specified.
7999 This used to be done in ffecom_finish_progunit, but it turns out to
8000 be necessary to do it here so that statement functions are
8001 expanded before code. But don't bother for BLOCK DATA. */
8003 if (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
8004 ffesymbol_drive (ffecom_finish_symbol_transform_
);
8008 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
8011 ffecom_sym_transform_(s);
8013 The ffesymbol_hook info for s is updated with appropriate backend info
8016 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8018 ffecom_sym_transform_ (ffesymbol s
)
8020 tree t
; /* Transformed thingy. */
8021 tree tlen
; /* Length if CHAR*(*). */
8022 bool addr
; /* Is t the address of the thingy? */
8023 ffeinfoBasictype bt
;
8027 int old_lineno
= lineno
;
8028 char *old_input_filename
= input_filename
;
8030 if (ffesymbol_sfdummyparent (s
) == NULL
)
8032 input_filename
= ffesymbol_where_filename (s
);
8033 lineno
= ffesymbol_where_filelinenum (s
);
8037 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
8039 input_filename
= ffesymbol_where_filename (sf
);
8040 lineno
= ffesymbol_where_filelinenum (sf
);
8043 bt
= ffeinfo_basictype (ffebld_info (s
));
8044 kt
= ffeinfo_kindtype (ffebld_info (s
));
8050 switch (ffesymbol_kind (s
))
8052 case FFEINFO_kindNONE
:
8053 switch (ffesymbol_where (s
))
8055 case FFEINFO_whereDUMMY
: /* Subroutine or function. */
8056 assert (ffecom_transform_only_dummies_
);
8058 /* Before 0.4, this could be ENTITY/DUMMY, but see
8059 ffestu_sym_end_transition -- no longer true (in particular, if
8060 it could be an ENTITY, it _will_ be made one, so that
8061 possibility won't come through here). So we never make length
8062 arg for CHARACTER type. */
8064 t
= build_decl (PARM_DECL
,
8065 ffecom_get_identifier_ (ffesymbol_text (s
)),
8066 ffecom_tree_ptr_to_subr_type
);
8068 DECL_ARTIFICIAL (t
) = 1;
8073 case FFEINFO_whereGLOBAL
: /* Subroutine or function. */
8074 assert (!ffecom_transform_only_dummies_
);
8076 if (((g
= ffesymbol_global (s
)) != NULL
)
8077 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8078 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8079 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8080 && (ffeglobal_hook (g
) != NULL_TREE
)
8081 && ffe_is_globals ())
8083 t
= ffeglobal_hook (g
);
8087 push_obstacks_nochange ();
8088 end_temporary_allocation ();
8090 t
= build_decl (FUNCTION_DECL
,
8091 ffecom_get_external_identifier_ (s
),
8092 ffecom_tree_subr_type
); /* Assume subr. */
8093 DECL_EXTERNAL (t
) = 1;
8094 TREE_PUBLIC (t
) = 1;
8096 t
= start_decl (t
, FALSE
);
8097 finish_decl (t
, NULL_TREE
, FALSE
);
8100 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8101 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8102 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8103 ffeglobal_set_hook (g
, t
);
8105 resume_temporary_allocation ();
8111 assert ("NONE where unexpected" == NULL
);
8113 case FFEINFO_whereANY
:
8118 case FFEINFO_kindENTITY
:
8119 switch (ffeinfo_where (ffesymbol_info (s
)))
8122 case FFEINFO_whereCONSTANT
: /* ~~debugging info needed? */
8123 assert (!ffecom_transform_only_dummies_
);
8124 t
= error_mark_node
; /* Shouldn't ever see this in expr. */
8127 case FFEINFO_whereLOCAL
:
8128 assert (!ffecom_transform_only_dummies_
);
8131 ffestorag st
= ffesymbol_storage (s
);
8135 && (ffestorag_size (st
) == 0))
8137 t
= error_mark_node
;
8141 yes
= suspend_momentary ();
8142 type
= ffecom_type_localvar_ (s
, bt
, kt
);
8143 resume_momentary (yes
);
8145 if (type
== error_mark_node
)
8147 t
= error_mark_node
;
8152 && (ffestorag_parent (st
) != NULL
))
8153 { /* Child of EQUIVALENCE parent. */
8157 ffetargetOffset offset
;
8159 est
= ffestorag_parent (st
);
8160 ffecom_transform_equiv_ (est
);
8162 et
= ffestorag_hook (est
);
8163 assert (et
!= NULL_TREE
);
8165 if (! TREE_STATIC (et
))
8166 put_var_into_stack (et
);
8168 yes
= suspend_momentary ();
8170 offset
= ffestorag_modulo (est
)
8171 + ffestorag_offset (ffesymbol_storage (s
))
8172 - ffestorag_offset (est
);
8174 ffecom_debug_kludge_ (et
, "EQUIVALENCE", s
, type
, offset
);
8176 /* (t_type *) (((char *) &et) + offset) */
8178 t
= convert (string_type_node
, /* (char *) */
8179 ffecom_1 (ADDR_EXPR
,
8180 build_pointer_type (TREE_TYPE (et
)),
8182 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
8184 build_int_2 (offset
, 0));
8185 t
= convert (build_pointer_type (type
),
8190 resume_momentary (yes
);
8195 bool init
= ffesymbol_is_init (s
);
8197 yes
= suspend_momentary ();
8199 t
= build_decl (VAR_DECL
,
8200 ffecom_get_identifier_ (ffesymbol_text (s
)),
8204 || ffesymbol_namelisted (s
)
8205 #ifdef FFECOM_sizeMAXSTACKITEM
8207 && (ffestorag_size (st
) > FFECOM_sizeMAXSTACKITEM
))
8209 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8210 && (ffecom_primary_entry_kind_
8211 != FFEINFO_kindBLOCKDATA
)
8212 && (ffesymbol_is_save (s
) || ffe_is_saveall ())))
8213 TREE_STATIC (t
) = !ffesymbol_attr (s
, FFESYMBOL_attrADJUSTABLE
);
8215 TREE_STATIC (t
) = 0; /* No need to make static. */
8217 if (init
|| ffe_is_init_local_zero ())
8218 DECL_INITIAL (t
) = error_mark_node
;
8220 /* Keep -Wunused from complaining about var if it
8221 is used as sfunc arg or DATA implied-DO. */
8222 if (ffesymbol_attrs (s
) & FFESYMBOL_attrsSFARG
)
8223 DECL_IN_SYSTEM_HEADER (t
) = 1;
8225 t
= start_decl (t
, FALSE
);
8229 if (ffesymbol_init (s
) != NULL
)
8230 initexpr
= ffecom_expr (ffesymbol_init (s
));
8232 initexpr
= ffecom_init_zero_ (t
);
8234 else if (ffe_is_init_local_zero ())
8235 initexpr
= ffecom_init_zero_ (t
);
8237 initexpr
= NULL_TREE
; /* Not ref'd if !init. */
8239 finish_decl (t
, initexpr
, FALSE
);
8241 if ((st
!= NULL
) && (DECL_SIZE (t
) != error_mark_node
))
8245 size_tree
= size_binop (CEIL_DIV_EXPR
,
8247 size_int (BITS_PER_UNIT
));
8248 assert (TREE_INT_CST_HIGH (size_tree
) == 0);
8249 assert (TREE_INT_CST_LOW (size_tree
) == ffestorag_size (st
));
8252 resume_momentary (yes
);
8257 case FFEINFO_whereRESULT
:
8258 assert (!ffecom_transform_only_dummies_
);
8260 if (bt
== FFEINFO_basictypeCHARACTER
)
8261 { /* Result is already in list of dummies, use
8263 t
= ffecom_func_result_
;
8264 tlen
= ffecom_func_length_
;
8268 if ((ffecom_num_entrypoints_
== 0)
8269 && (bt
== FFEINFO_basictypeCOMPLEX
)
8270 && (ffesymbol_is_f2c (ffecom_primary_entry_
)))
8271 { /* Result is already in list of dummies, use
8273 t
= ffecom_func_result_
;
8277 if (ffecom_func_result_
!= NULL_TREE
)
8279 t
= ffecom_func_result_
;
8282 if ((ffecom_num_entrypoints_
!= 0)
8283 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
))
8285 yes
= suspend_momentary ();
8287 assert (ffecom_multi_retval_
!= NULL_TREE
);
8288 t
= ffecom_1 (INDIRECT_REF
, ffecom_multi_type_node_
,
8289 ffecom_multi_retval_
);
8290 t
= ffecom_2 (COMPONENT_REF
, ffecom_tree_type
[bt
][kt
],
8291 t
, ffecom_multi_fields_
[bt
][kt
]);
8293 resume_momentary (yes
);
8297 yes
= suspend_momentary ();
8299 t
= build_decl (VAR_DECL
,
8300 ffecom_get_identifier_ (ffesymbol_text (s
)),
8301 ffecom_tree_type
[bt
][kt
]);
8302 TREE_STATIC (t
) = 0; /* Put result on stack. */
8303 t
= start_decl (t
, FALSE
);
8304 finish_decl (t
, NULL_TREE
, FALSE
);
8306 ffecom_func_result_
= t
;
8308 resume_momentary (yes
);
8311 case FFEINFO_whereDUMMY
:
8319 bool adjustable
= FALSE
; /* Conditionally adjustable? */
8321 type
= ffecom_tree_type
[bt
][kt
];
8322 if (ffesymbol_sfdummyparent (s
) != NULL
)
8324 if (current_function_decl
== ffecom_outer_function_decl_
)
8325 { /* Exec transition before sfunc
8326 context; get it later. */
8329 t
= ffecom_get_identifier_ (ffesymbol_text
8330 (ffesymbol_sfdummyparent (s
)));
8333 t
= ffecom_get_identifier_ (ffesymbol_text (s
));
8335 assert (ffecom_transform_only_dummies_
);
8337 old_sizes
= get_pending_sizes ();
8338 put_pending_sizes (old_sizes
);
8340 if (bt
== FFEINFO_basictypeCHARACTER
)
8341 tlen
= ffecom_char_enhance_arg_ (&type
, s
);
8342 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
8344 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
8346 if (type
== error_mark_node
)
8349 dim
= ffebld_head (dl
);
8350 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
8351 if ((ffebld_left (dim
) == NULL
) || ffecom_doing_entry_
)
8352 low
= ffecom_integer_one_node
;
8354 low
= ffecom_expr (ffebld_left (dim
));
8355 assert (ffebld_right (dim
) != NULL
);
8356 if ((ffebld_op (ffebld_right (dim
)) == FFEBLD_opSTAR
)
8357 || ffecom_doing_entry_
)
8359 /* Used to just do high=low. But for ffecom_tree_
8360 canonize_ref_, it probably is important to correctly
8361 assess the size. E.g. given COMPLEX C(*),CFUNC and
8362 C(2)=CFUNC(C), overlap can happen, while it can't
8363 for, say, C(1)=CFUNC(C(2)). */
8364 /* Even more recently used to set to INT_MAX, but that
8365 broke when some overflow checking went into the back
8366 end. Now we just leave the upper bound unspecified. */
8370 high
= ffecom_expr (ffebld_right (dim
));
8372 /* Determine whether array is conditionally adjustable,
8373 to decide whether back-end magic is needed.
8375 Normally the front end uses the back-end function
8376 variable_size to wrap SAVE_EXPR's around expressions
8377 affecting the size/shape of an array so that the
8378 size/shape info doesn't change during execution
8379 of the compiled code even though variables and
8380 functions referenced in those expressions might.
8382 variable_size also makes sure those saved expressions
8383 get evaluated immediately upon entry to the
8384 compiled procedure -- the front end normally doesn't
8385 have to worry about that.
8387 However, there is a problem with this that affects
8388 g77's implementation of entry points, and that is
8389 that it is _not_ true that each invocation of the
8390 compiled procedure is permitted to evaluate
8391 array size/shape info -- because it is possible
8392 that, for some invocations, that info is invalid (in
8393 which case it is "promised" -- i.e. a violation of
8394 the Fortran standard -- that the compiled code
8395 won't reference the array or its size/shape
8396 during that particular invocation).
8398 To phrase this in C terms, consider this gcc function:
8400 void foo (int *n, float (*a)[*n])
8402 // a is "pointer to array ...", fyi.
8405 Suppose that, for some invocations, it is permitted
8406 for a caller of foo to do this:
8410 Now the _written_ code for foo can take such a call
8411 into account by either testing explicitly for whether
8412 (a == NULL) || (n == NULL) -- presumably it is
8413 not permitted to reference *a in various fashions
8414 if (n == NULL) I suppose -- or it can avoid it by
8415 looking at other info (other arguments, static/global
8418 However, this won't work in gcc 2.5.8 because it'll
8419 automatically emit the code to save the "*n"
8420 expression, which'll yield a NULL dereference for
8421 the "foo (NULL, NULL)" call, something the code
8422 for foo cannot prevent.
8424 g77 definitely needs to avoid executing such
8425 code anytime the pointer to the adjustable array
8426 is NULL, because even if its bounds expressions
8427 don't have any references to possible "absent"
8428 variables like "*n" -- say all variable references
8429 are to COMMON variables, i.e. global (though in C,
8430 local static could actually make sense) -- the
8431 expressions could yield other run-time problems
8432 for allowably "dead" values in those variables.
8434 For example, let's consider a more complicated
8440 void foo (float (*a)[i/j])
8445 The above is (essentially) quite valid for Fortran
8446 but, again, for a call like "foo (NULL);", it is
8447 permitted for i and j to be undefined when the
8448 call is made. If j happened to be zero, for
8449 example, emitting the code to evaluate "i/j"
8450 could result in a run-time error.
8452 Offhand, though I don't have my F77 or F90
8453 standards handy, it might even be valid for a
8454 bounds expression to contain a function reference,
8455 in which case I doubt it is permitted for an
8456 implementation to invoke that function in the
8457 Fortran case involved here (invocation of an
8458 alternate ENTRY point that doesn't have the adjustable
8459 array as one of its arguments).
8461 So, the code that the compiler would normally emit
8462 to preevaluate the size/shape info for an
8463 adjustable array _must not_ be executed at run time
8464 in certain cases. Specifically, for Fortran,
8465 the case is when the pointer to the adjustable
8466 array == NULL. (For gnu-ish C, it might be nice
8467 for the source code itself to specify an expression
8468 that, if TRUE, inhibits execution of the code. Or
8469 reverse the sense for elegance.)
8471 (Note that g77 could use a different test than NULL,
8472 actually, since it happens to always pass an
8473 integer to the called function that specifies which
8474 entry point is being invoked. Hmm, this might
8475 solve the next problem.)
8477 One way a user could, I suppose, write "foo" so
8478 it works is to insert COND_EXPR's for the
8479 size/shape info so the dangerous stuff isn't
8480 actually done, as in:
8482 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
8487 The next problem is that the front end needs to
8488 be able to tell the back end about the array's
8489 decl _before_ it tells it about the conditional
8490 expression to inhibit evaluation of size/shape info,
8493 To solve this, the front end needs to be able
8494 to give the back end the expression to inhibit
8495 generation of the preevaluation code _after_
8496 it makes the decl for the adjustable array.
8498 Until then, the above example using the COND_EXPR
8499 doesn't pass muster with gcc because the "(a == NULL)"
8500 part has a reference to "a", which is still
8501 undefined at that point.
8503 g77 will therefore use a different mechanism in the
8507 && ((TREE_CODE (low
) != INTEGER_CST
)
8508 || (high
&& TREE_CODE (high
) != INTEGER_CST
)))
8511 #if 0 /* Old approach -- see below. */
8512 if (TREE_CODE (low
) != INTEGER_CST
)
8513 low
= ffecom_3 (COND_EXPR
, integer_type_node
,
8514 ffecom_adjarray_passed_ (s
),
8516 ffecom_integer_zero_node
);
8518 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
8519 high
= ffecom_3 (COND_EXPR
, integer_type_node
,
8520 ffecom_adjarray_passed_ (s
),
8522 ffecom_integer_zero_node
);
8525 /* ~~~gcc/stor-layout.c/layout_type should do this,
8526 probably. Fixes 950302-1.f. */
8528 if (TREE_CODE (low
) != INTEGER_CST
)
8529 low
= variable_size (low
);
8531 /* ~~~similarly, this fixes dumb0.f. The C front end
8532 does this, which is why dumb0.c would work. */
8534 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
8535 high
= variable_size (high
);
8540 build_range_type (ffecom_integer_type_node
,
8542 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
8545 if (type
== error_mark_node
)
8547 t
= error_mark_node
;
8551 if ((ffesymbol_sfdummyparent (s
) == NULL
)
8552 || (ffesymbol_basictype (s
) == FFEINFO_basictypeCHARACTER
))
8554 type
= build_pointer_type (type
);
8558 t
= build_decl (PARM_DECL
, t
, type
);
8560 DECL_ARTIFICIAL (t
) = 1;
8563 /* If this arg is present in every entry point's list of
8564 dummy args, then we're done. */
8566 if (ffesymbol_numentries (s
)
8567 == (ffecom_num_entrypoints_
+ 1))
8572 /* If variable_size in stor-layout has been called during
8573 the above, then get_pending_sizes should have the
8574 yet-to-be-evaluated saved expressions pending.
8575 Make the whole lot of them get emitted, conditionally
8576 on whether the array decl ("t" above) is not NULL. */
8579 tree sizes
= get_pending_sizes ();
8584 tem
= TREE_CHAIN (tem
))
8586 tree temv
= TREE_VALUE (tem
);
8592 = ffecom_2 (COMPOUND_EXPR
,
8601 = ffecom_3 (COND_EXPR
,
8608 convert (TREE_TYPE (sizes
),
8609 integer_zero_node
));
8610 sizes
= ffecom_save_tree (sizes
);
8613 = tree_cons (NULL_TREE
, sizes
, tem
);
8617 put_pending_sizes (sizes
);
8623 && (ffesymbol_numentries (s
)
8624 != ffecom_num_entrypoints_
+ 1))
8626 = ffecom_2 (NE_EXPR
, integer_type_node
,
8632 && (ffesymbol_numentries (s
)
8633 != ffecom_num_entrypoints_
+ 1))
8635 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED
);
8636 ffebad_here (0, ffesymbol_where_line (s
),
8637 ffesymbol_where_column (s
));
8638 ffebad_string (ffesymbol_text (s
));
8647 case FFEINFO_whereCOMMON
:
8652 ffestorag st
= ffesymbol_storage (s
);
8656 cs
= ffesymbol_common (s
); /* The COMMON area itself. */
8657 if (st
!= NULL
) /* Else not laid out. */
8659 ffecom_transform_common_ (cs
);
8660 st
= ffesymbol_storage (s
);
8663 yes
= suspend_momentary ();
8665 type
= ffecom_type_localvar_ (s
, bt
, kt
);
8667 cg
= ffesymbol_global (cs
); /* The global COMMON info. */
8669 || (ffeglobal_type (cg
) != FFEGLOBAL_typeCOMMON
))
8672 ct
= ffeglobal_hook (cg
); /* The common area's tree. */
8674 if ((ct
== NULL_TREE
)
8676 || (type
== error_mark_node
))
8677 t
= error_mark_node
;
8680 ffetargetOffset offset
;
8683 cst
= ffestorag_parent (st
);
8684 assert (cst
== ffesymbol_storage (cs
));
8686 offset
= ffestorag_modulo (cst
)
8687 + ffestorag_offset (st
)
8688 - ffestorag_offset (cst
);
8690 ffecom_debug_kludge_ (ct
, "COMMON", s
, type
, offset
);
8692 /* (t_type *) (((char *) &ct) + offset) */
8694 t
= convert (string_type_node
, /* (char *) */
8695 ffecom_1 (ADDR_EXPR
,
8696 build_pointer_type (TREE_TYPE (ct
)),
8698 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
8700 build_int_2 (offset
, 0));
8701 t
= convert (build_pointer_type (type
),
8707 resume_momentary (yes
);
8711 case FFEINFO_whereIMMEDIATE
:
8712 case FFEINFO_whereGLOBAL
:
8713 case FFEINFO_whereFLEETING
:
8714 case FFEINFO_whereFLEETING_CADDR
:
8715 case FFEINFO_whereFLEETING_IADDR
:
8716 case FFEINFO_whereINTRINSIC
:
8717 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8719 assert ("ENTITY where unheard of" == NULL
);
8721 case FFEINFO_whereANY
:
8722 t
= error_mark_node
;
8727 case FFEINFO_kindFUNCTION
:
8728 switch (ffeinfo_where (ffesymbol_info (s
)))
8730 case FFEINFO_whereLOCAL
: /* Me. */
8731 assert (!ffecom_transform_only_dummies_
);
8732 t
= current_function_decl
;
8735 case FFEINFO_whereGLOBAL
:
8736 assert (!ffecom_transform_only_dummies_
);
8738 if (((g
= ffesymbol_global (s
)) != NULL
)
8739 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8740 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8741 && (ffeglobal_hook (g
) != NULL_TREE
)
8742 && ffe_is_globals ())
8744 t
= ffeglobal_hook (g
);
8748 push_obstacks_nochange ();
8749 end_temporary_allocation ();
8751 if (ffesymbol_is_f2c (s
)
8752 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8753 t
= ffecom_tree_fun_type
[bt
][kt
];
8755 t
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
8757 t
= build_decl (FUNCTION_DECL
,
8758 ffecom_get_external_identifier_ (s
),
8760 DECL_EXTERNAL (t
) = 1;
8761 TREE_PUBLIC (t
) = 1;
8763 t
= start_decl (t
, FALSE
);
8764 finish_decl (t
, NULL_TREE
, FALSE
);
8767 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8768 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8769 ffeglobal_set_hook (g
, t
);
8771 resume_temporary_allocation ();
8776 case FFEINFO_whereDUMMY
:
8777 assert (ffecom_transform_only_dummies_
);
8779 if (ffesymbol_is_f2c (s
)
8780 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8781 t
= ffecom_tree_ptr_to_fun_type
[bt
][kt
];
8783 t
= build_pointer_type
8784 (build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
));
8786 t
= build_decl (PARM_DECL
,
8787 ffecom_get_identifier_ (ffesymbol_text (s
)),
8790 DECL_ARTIFICIAL (t
) = 1;
8795 case FFEINFO_whereCONSTANT
: /* Statement function. */
8796 assert (!ffecom_transform_only_dummies_
);
8797 t
= ffecom_gen_sfuncdef_ (s
, bt
, kt
);
8800 case FFEINFO_whereINTRINSIC
:
8801 assert (!ffecom_transform_only_dummies_
);
8802 break; /* Let actual references generate their
8806 assert ("FUNCTION where unheard of" == NULL
);
8808 case FFEINFO_whereANY
:
8809 t
= error_mark_node
;
8814 case FFEINFO_kindSUBROUTINE
:
8815 switch (ffeinfo_where (ffesymbol_info (s
)))
8817 case FFEINFO_whereLOCAL
: /* Me. */
8818 assert (!ffecom_transform_only_dummies_
);
8819 t
= current_function_decl
;
8822 case FFEINFO_whereGLOBAL
:
8823 assert (!ffecom_transform_only_dummies_
);
8825 if (((g
= ffesymbol_global (s
)) != NULL
)
8826 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8827 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8828 && (ffeglobal_hook (g
) != NULL_TREE
)
8829 && ffe_is_globals ())
8831 t
= ffeglobal_hook (g
);
8835 push_obstacks_nochange ();
8836 end_temporary_allocation ();
8838 t
= build_decl (FUNCTION_DECL
,
8839 ffecom_get_external_identifier_ (s
),
8840 ffecom_tree_subr_type
);
8841 DECL_EXTERNAL (t
) = 1;
8842 TREE_PUBLIC (t
) = 1;
8844 t
= start_decl (t
, FALSE
);
8845 finish_decl (t
, NULL_TREE
, FALSE
);
8848 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8849 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8850 ffeglobal_set_hook (g
, t
);
8852 resume_temporary_allocation ();
8857 case FFEINFO_whereDUMMY
:
8858 assert (ffecom_transform_only_dummies_
);
8860 t
= build_decl (PARM_DECL
,
8861 ffecom_get_identifier_ (ffesymbol_text (s
)),
8862 ffecom_tree_ptr_to_subr_type
);
8864 DECL_ARTIFICIAL (t
) = 1;
8869 case FFEINFO_whereINTRINSIC
:
8870 assert (!ffecom_transform_only_dummies_
);
8871 break; /* Let actual references generate their
8875 assert ("SUBROUTINE where unheard of" == NULL
);
8877 case FFEINFO_whereANY
:
8878 t
= error_mark_node
;
8883 case FFEINFO_kindPROGRAM
:
8884 switch (ffeinfo_where (ffesymbol_info (s
)))
8886 case FFEINFO_whereLOCAL
: /* Me. */
8887 assert (!ffecom_transform_only_dummies_
);
8888 t
= current_function_decl
;
8891 case FFEINFO_whereCOMMON
:
8892 case FFEINFO_whereDUMMY
:
8893 case FFEINFO_whereGLOBAL
:
8894 case FFEINFO_whereRESULT
:
8895 case FFEINFO_whereFLEETING
:
8896 case FFEINFO_whereFLEETING_CADDR
:
8897 case FFEINFO_whereFLEETING_IADDR
:
8898 case FFEINFO_whereIMMEDIATE
:
8899 case FFEINFO_whereINTRINSIC
:
8900 case FFEINFO_whereCONSTANT
:
8901 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8903 assert ("PROGRAM where unheard of" == NULL
);
8905 case FFEINFO_whereANY
:
8906 t
= error_mark_node
;
8911 case FFEINFO_kindBLOCKDATA
:
8912 switch (ffeinfo_where (ffesymbol_info (s
)))
8914 case FFEINFO_whereLOCAL
: /* Me. */
8915 assert (!ffecom_transform_only_dummies_
);
8916 t
= current_function_decl
;
8919 case FFEINFO_whereGLOBAL
:
8920 assert (!ffecom_transform_only_dummies_
);
8922 push_obstacks_nochange ();
8923 end_temporary_allocation ();
8925 t
= build_decl (FUNCTION_DECL
,
8926 ffecom_get_external_identifier_ (s
),
8927 ffecom_tree_blockdata_type
);
8928 DECL_EXTERNAL (t
) = 1;
8929 TREE_PUBLIC (t
) = 1;
8931 t
= start_decl (t
, FALSE
);
8932 finish_decl (t
, NULL_TREE
, FALSE
);
8934 resume_temporary_allocation ();
8939 case FFEINFO_whereCOMMON
:
8940 case FFEINFO_whereDUMMY
:
8941 case FFEINFO_whereRESULT
:
8942 case FFEINFO_whereFLEETING
:
8943 case FFEINFO_whereFLEETING_CADDR
:
8944 case FFEINFO_whereFLEETING_IADDR
:
8945 case FFEINFO_whereIMMEDIATE
:
8946 case FFEINFO_whereINTRINSIC
:
8947 case FFEINFO_whereCONSTANT
:
8948 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8950 assert ("BLOCKDATA where unheard of" == NULL
);
8952 case FFEINFO_whereANY
:
8953 t
= error_mark_node
;
8958 case FFEINFO_kindCOMMON
:
8959 switch (ffeinfo_where (ffesymbol_info (s
)))
8961 case FFEINFO_whereLOCAL
:
8962 assert (!ffecom_transform_only_dummies_
);
8963 ffecom_transform_common_ (s
);
8966 case FFEINFO_whereNONE
:
8967 case FFEINFO_whereCOMMON
:
8968 case FFEINFO_whereDUMMY
:
8969 case FFEINFO_whereGLOBAL
:
8970 case FFEINFO_whereRESULT
:
8971 case FFEINFO_whereFLEETING
:
8972 case FFEINFO_whereFLEETING_CADDR
:
8973 case FFEINFO_whereFLEETING_IADDR
:
8974 case FFEINFO_whereIMMEDIATE
:
8975 case FFEINFO_whereINTRINSIC
:
8976 case FFEINFO_whereCONSTANT
:
8977 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8979 assert ("COMMON where unheard of" == NULL
);
8981 case FFEINFO_whereANY
:
8982 t
= error_mark_node
;
8987 case FFEINFO_kindCONSTRUCT
:
8988 switch (ffeinfo_where (ffesymbol_info (s
)))
8990 case FFEINFO_whereLOCAL
:
8991 assert (!ffecom_transform_only_dummies_
);
8994 case FFEINFO_whereNONE
:
8995 case FFEINFO_whereCOMMON
:
8996 case FFEINFO_whereDUMMY
:
8997 case FFEINFO_whereGLOBAL
:
8998 case FFEINFO_whereRESULT
:
8999 case FFEINFO_whereFLEETING
:
9000 case FFEINFO_whereFLEETING_CADDR
:
9001 case FFEINFO_whereFLEETING_IADDR
:
9002 case FFEINFO_whereIMMEDIATE
:
9003 case FFEINFO_whereINTRINSIC
:
9004 case FFEINFO_whereCONSTANT
:
9005 case FFEINFO_whereCONSTANT_SUBOBJECT
:
9007 assert ("CONSTRUCT where unheard of" == NULL
);
9009 case FFEINFO_whereANY
:
9010 t
= error_mark_node
;
9015 case FFEINFO_kindNAMELIST
:
9016 switch (ffeinfo_where (ffesymbol_info (s
)))
9018 case FFEINFO_whereLOCAL
:
9019 assert (!ffecom_transform_only_dummies_
);
9020 t
= ffecom_transform_namelist_ (s
);
9023 case FFEINFO_whereNONE
:
9024 case FFEINFO_whereCOMMON
:
9025 case FFEINFO_whereDUMMY
:
9026 case FFEINFO_whereGLOBAL
:
9027 case FFEINFO_whereRESULT
:
9028 case FFEINFO_whereFLEETING
:
9029 case FFEINFO_whereFLEETING_CADDR
:
9030 case FFEINFO_whereFLEETING_IADDR
:
9031 case FFEINFO_whereIMMEDIATE
:
9032 case FFEINFO_whereINTRINSIC
:
9033 case FFEINFO_whereCONSTANT
:
9034 case FFEINFO_whereCONSTANT_SUBOBJECT
:
9036 assert ("NAMELIST where unheard of" == NULL
);
9038 case FFEINFO_whereANY
:
9039 t
= error_mark_node
;
9045 assert ("kind unheard of" == NULL
);
9047 case FFEINFO_kindANY
:
9048 t
= error_mark_node
;
9052 ffesymbol_hook (s
).decl_tree
= t
;
9053 ffesymbol_hook (s
).length_tree
= tlen
;
9054 ffesymbol_hook (s
).addr
= addr
;
9056 lineno
= old_lineno
;
9057 input_filename
= old_input_filename
;
9063 /* Transform into ASSIGNable symbol.
9065 Symbol has already been transformed, but for whatever reason, the
9066 resulting decl_tree has been deemed not usable for an ASSIGN target.
9067 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
9068 another local symbol of type void * and stuff that in the assign_tree
9069 argument. The F77/F90 standards allow this implementation. */
9071 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9073 ffecom_sym_transform_assign_ (ffesymbol s
)
9075 tree t
; /* Transformed thingy. */
9077 int old_lineno
= lineno
;
9078 char *old_input_filename
= input_filename
;
9080 if (ffesymbol_sfdummyparent (s
) == NULL
)
9082 input_filename
= ffesymbol_where_filename (s
);
9083 lineno
= ffesymbol_where_filelinenum (s
);
9087 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
9089 input_filename
= ffesymbol_where_filename (sf
);
9090 lineno
= ffesymbol_where_filelinenum (sf
);
9093 assert (!ffecom_transform_only_dummies_
);
9095 yes
= suspend_momentary ();
9097 t
= build_decl (VAR_DECL
,
9098 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
9101 TREE_TYPE (null_pointer_node
));
9103 switch (ffesymbol_where (s
))
9105 case FFEINFO_whereLOCAL
:
9106 /* Unlike for regular vars, SAVE status is easy to determine for
9107 ASSIGNed vars, since there's no initialization, there's no
9108 effective storage association (so "SAVE J" does not apply to
9109 K even given "EQUIVALENCE (J,K)"), there's no size issue
9110 to worry about, etc. */
9111 if ((ffesymbol_is_save (s
) || ffe_is_saveall ())
9112 && (ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
9113 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
))
9114 TREE_STATIC (t
) = 1; /* SAVEd in proc, make static. */
9116 TREE_STATIC (t
) = 0; /* No need to make static. */
9119 case FFEINFO_whereCOMMON
:
9120 TREE_STATIC (t
) = 1; /* Assume COMMONs always SAVEd. */
9123 case FFEINFO_whereDUMMY
:
9124 /* Note that twinning a DUMMY means the caller won't see
9125 the ASSIGNed value. But both F77 and F90 allow implementations
9126 to do this, i.e. disallow Fortran code that would try and
9127 take advantage of actually putting a label into a variable
9128 via a dummy argument (or any other storage association, for
9130 TREE_STATIC (t
) = 0;
9134 TREE_STATIC (t
) = 0;
9138 t
= start_decl (t
, FALSE
);
9139 finish_decl (t
, NULL_TREE
, FALSE
);
9141 resume_momentary (yes
);
9143 ffesymbol_hook (s
).assign_tree
= t
;
9145 lineno
= old_lineno
;
9146 input_filename
= old_input_filename
;
9152 /* Implement COMMON area in back end.
9154 Because COMMON-based variables can be referenced in the dimension
9155 expressions of dummy (adjustable) arrays, and because dummies
9156 (in the gcc back end) need to be put in the outer binding level
9157 of a function (which has two binding levels, the outer holding
9158 the dummies and the inner holding the other vars), special care
9159 must be taken to handle COMMON areas.
9161 The current strategy is basically to always tell the back end about
9162 the COMMON area as a top-level external reference to just a block
9163 of storage of the master type of that area (e.g. integer, real,
9164 character, whatever -- not a structure). As a distinct action,
9165 if initial values are provided, tell the back end about the area
9166 as a top-level non-external (initialized) area and remember not to
9167 allow further initialization or expansion of the area. Meanwhile,
9168 if no initialization happens at all, tell the back end about
9169 the largest size we've seen declared so the space does get reserved.
9170 (This function doesn't handle all that stuff, but it does some
9171 of the important things.)
9173 Meanwhile, for COMMON variables themselves, just keep creating
9174 references like *((float *) (&common_area + offset)) each time
9175 we reference the variable. In other words, don't make a VAR_DECL
9176 or any kind of component reference (like we used to do before 0.4),
9177 though we might do that as well just for debugging purposes (and
9178 stuff the rtl with the appropriate offset expression). */
9180 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9182 ffecom_transform_common_ (ffesymbol s
)
9184 ffestorag st
= ffesymbol_storage (s
);
9185 ffeglobal g
= ffesymbol_global (s
);
9189 bool is_init
= ffestorag_is_init (st
);
9191 assert (st
!= NULL
);
9194 || (ffeglobal_type (g
) != FFEGLOBAL_typeCOMMON
))
9197 /* First update the size of the area in global terms. */
9199 ffeglobal_size_common (s
, ffestorag_size (st
));
9201 if (!ffeglobal_common_init (g
))
9202 is_init
= FALSE
; /* No explicit init, don't let erroneous joins init. */
9204 cbt
= ffeglobal_hook (g
);
9206 /* If we already have declared this common block for a previous program
9207 unit, and either we already initialized it or we don't have new
9208 initialization for it, just return what we have without changing it. */
9210 if ((cbt
!= NULL_TREE
)
9212 || !DECL_EXTERNAL (cbt
)))
9215 /* Process inits. */
9219 if (ffestorag_init (st
) != NULL
)
9221 init
= ffecom_expr (ffestorag_init (st
));
9222 if (init
== error_mark_node
)
9223 { /* Hopefully the back end complained! */
9225 if (cbt
!= NULL_TREE
)
9230 init
= error_mark_node
;
9235 push_obstacks_nochange ();
9236 end_temporary_allocation ();
9238 /* cbtype must be permanently allocated! */
9241 cbtype
= build_array_type (char_type_node
,
9242 build_range_type (integer_type_node
,
9245 (ffeglobal_common_size (g
),
9248 cbtype
= build_array_type (char_type_node
, NULL_TREE
);
9250 if (cbt
== NULL_TREE
)
9253 = build_decl (VAR_DECL
,
9254 ffecom_get_external_identifier_ (s
),
9256 TREE_STATIC (cbt
) = 1;
9257 TREE_PUBLIC (cbt
) = 1;
9262 TREE_TYPE (cbt
) = cbtype
;
9264 DECL_EXTERNAL (cbt
) = init
? 0 : 1;
9265 DECL_INITIAL (cbt
) = init
? error_mark_node
: NULL_TREE
;
9267 cbt
= start_decl (cbt
, TRUE
);
9268 if (ffeglobal_hook (g
) != NULL
)
9269 assert (cbt
== ffeglobal_hook (g
));
9271 assert (!init
|| !DECL_EXTERNAL (cbt
));
9273 /* Make sure that any type can live in COMMON and be referenced
9274 without getting a bus error. We could pick the most restrictive
9275 alignment of all entities actually placed in the COMMON, but
9276 this seems easy enough. */
9278 DECL_ALIGN (cbt
) = BIGGEST_ALIGNMENT
;
9280 if (is_init
&& (ffestorag_init (st
) == NULL
))
9281 init
= ffecom_init_zero_ (cbt
);
9283 finish_decl (cbt
, init
, TRUE
);
9286 ffestorag_set_init (st
, ffebld_new_any ());
9292 assert (DECL_SIZE (cbt
) != NULL_TREE
);
9293 assert (TREE_CODE (DECL_SIZE (cbt
)) == INTEGER_CST
);
9294 size_tree
= size_binop (CEIL_DIV_EXPR
,
9296 size_int (BITS_PER_UNIT
));
9297 assert (TREE_INT_CST_HIGH (size_tree
) == 0);
9298 assert (TREE_INT_CST_LOW (size_tree
) == ffeglobal_common_size (g
));
9301 ffeglobal_set_hook (g
, cbt
);
9303 ffestorag_set_hook (st
, cbt
);
9305 resume_temporary_allocation ();
9310 /* Make master area for local EQUIVALENCE. */
9312 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9314 ffecom_transform_equiv_ (ffestorag eqst
)
9320 bool is_init
= ffestorag_is_init (eqst
);
9323 assert (eqst
!= NULL
);
9325 eqt
= ffestorag_hook (eqst
);
9327 if (eqt
!= NULL_TREE
)
9330 /* Process inits. */
9334 if (ffestorag_init (eqst
) != NULL
)
9336 init
= ffecom_expr (ffestorag_init (eqst
));
9337 if (init
== error_mark_node
)
9338 init
= NULL_TREE
; /* Hopefully the back end complained! */
9341 init
= error_mark_node
;
9343 else if (ffe_is_init_local_zero ())
9344 init
= error_mark_node
;
9348 ffecom_member_namelisted_
= FALSE
;
9349 ffestorag_drive (ffestorag_list_equivs (eqst
),
9350 &ffecom_member_phase1_
,
9353 yes
= suspend_momentary ();
9355 high
= build_int_2 (ffestorag_size (eqst
), 0);
9356 TREE_TYPE (high
) = ffecom_integer_type_node
;
9358 eqtype
= build_array_type (char_type_node
,
9359 build_range_type (ffecom_integer_type_node
,
9360 ffecom_integer_one_node
,
9363 eqt
= build_decl (VAR_DECL
,
9364 ffecom_get_invented_identifier ("__g77_equiv_%s",
9370 DECL_EXTERNAL (eqt
) = 0;
9372 || ffecom_member_namelisted_
9373 #ifdef FFECOM_sizeMAXSTACKITEM
9374 || (ffestorag_size (eqst
) > FFECOM_sizeMAXSTACKITEM
)
9376 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
9377 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
9378 && (ffestorag_is_save (eqst
) || ffe_is_saveall ())))
9379 TREE_STATIC (eqt
) = 1;
9381 TREE_STATIC (eqt
) = 0;
9382 TREE_PUBLIC (eqt
) = 0;
9383 DECL_CONTEXT (eqt
) = current_function_decl
;
9385 DECL_INITIAL (eqt
) = error_mark_node
;
9387 DECL_INITIAL (eqt
) = NULL_TREE
;
9389 eqt
= start_decl (eqt
, FALSE
);
9391 /* Make sure this shows up as a debug symbol, which is not normally
9392 the case for invented identifiers. */
9394 DECL_IGNORED_P (eqt
) = 0;
9396 /* Make sure that any type can live in EQUIVALENCE and be referenced
9397 without getting a bus error. We could pick the most restrictive
9398 alignment of all entities actually placed in the EQUIVALENCE, but
9399 this seems easy enough. */
9401 DECL_ALIGN (eqt
) = BIGGEST_ALIGNMENT
;
9403 if ((!is_init
&& ffe_is_init_local_zero ())
9404 || (is_init
&& (ffestorag_init (eqst
) == NULL
)))
9405 init
= ffecom_init_zero_ (eqt
);
9407 finish_decl (eqt
, init
, FALSE
);
9410 ffestorag_set_init (eqst
, ffebld_new_any ());
9415 size_tree
= size_binop (CEIL_DIV_EXPR
,
9417 size_int (BITS_PER_UNIT
));
9418 assert (TREE_INT_CST_HIGH (size_tree
) == 0);
9419 assert (TREE_INT_CST_LOW (size_tree
) == ffestorag_size (eqst
));
9422 ffestorag_set_hook (eqst
, eqt
);
9424 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
9425 ffestorag_drive (ffestorag_list_equivs (eqst
),
9426 &ffecom_member_phase2_
,
9430 resume_momentary (yes
);
9434 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
9436 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9438 ffecom_transform_namelist_ (ffesymbol s
)
9441 tree nmltype
= ffecom_type_namelist_ ();
9450 static int mynumber
= 0;
9452 yes
= suspend_momentary ();
9454 nmlt
= build_decl (VAR_DECL
,
9455 ffecom_get_invented_identifier ("__g77_namelist_%d",
9458 TREE_STATIC (nmlt
) = 1;
9459 DECL_INITIAL (nmlt
) = error_mark_node
;
9461 nmlt
= start_decl (nmlt
, FALSE
);
9463 /* Process inits. */
9465 i
= strlen (ffesymbol_text (s
));
9467 high
= build_int_2 (i
, 0);
9468 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
9470 nameinit
= ffecom_build_f2c_string_ (i
+ 1,
9471 ffesymbol_text (s
));
9472 TREE_TYPE (nameinit
)
9473 = build_type_variant
9476 build_range_type (ffecom_f2c_ftnlen_type_node
,
9477 ffecom_f2c_ftnlen_one_node
,
9480 TREE_CONSTANT (nameinit
) = 1;
9481 TREE_STATIC (nameinit
) = 1;
9482 nameinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (nameinit
)),
9485 varsinit
= ffecom_vardesc_array_ (s
);
9486 varsinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (varsinit
)),
9488 TREE_CONSTANT (varsinit
) = 1;
9489 TREE_STATIC (varsinit
) = 1;
9494 for (i
= 0, b
= ffesymbol_namelist (s
); b
!= NULL
; b
= ffebld_trail (b
))
9497 nvarsinit
= build_int_2 (i
, 0);
9498 TREE_TYPE (nvarsinit
) = integer_type_node
;
9499 TREE_CONSTANT (nvarsinit
) = 1;
9500 TREE_STATIC (nvarsinit
) = 1;
9502 nmlinits
= build_tree_list ((field
= TYPE_FIELDS (nmltype
)), nameinit
);
9503 TREE_CHAIN (nmlinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
9505 TREE_CHAIN (TREE_CHAIN (nmlinits
))
9506 = build_tree_list ((field
= TREE_CHAIN (field
)), nvarsinit
);
9508 nmlinits
= build (CONSTRUCTOR
, nmltype
, NULL_TREE
, nmlinits
);
9509 TREE_CONSTANT (nmlinits
) = 1;
9510 TREE_STATIC (nmlinits
) = 1;
9512 finish_decl (nmlt
, nmlinits
, FALSE
);
9514 nmlt
= ffecom_1 (ADDR_EXPR
, build_pointer_type (nmltype
), nmlt
);
9516 resume_momentary (yes
);
9523 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
9524 analyzed on the assumption it is calculating a pointer to be
9525 indirected through. It must return the proper decl and offset,
9526 taking into account different units of measurements for offsets. */
9528 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9530 ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
9533 switch (TREE_CODE (t
))
9537 case NON_LVALUE_EXPR
:
9538 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
9542 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
9543 if ((*decl
== NULL_TREE
)
9544 || (*decl
== error_mark_node
))
9547 if (TREE_CODE (TREE_OPERAND (t
, 1)) == INTEGER_CST
)
9549 /* An offset into COMMON. */
9550 *offset
= size_binop (PLUS_EXPR
,
9552 TREE_OPERAND (t
, 1));
9553 /* Convert offset (presumably in bytes) into canonical units
9554 (presumably bits). */
9555 *offset
= size_binop (MULT_EXPR
,
9556 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t
))),
9560 /* Not a COMMON reference, so an unrecognized pattern. */
9561 *decl
= error_mark_node
;
9566 *offset
= bitsize_int (0L, 0L);
9570 if (TREE_CODE (TREE_OPERAND (t
, 0)) == VAR_DECL
)
9572 /* A reference to COMMON. */
9573 *decl
= TREE_OPERAND (t
, 0);
9574 *offset
= bitsize_int (0L, 0L);
9579 /* Not a COMMON reference, so an unrecognized pattern. */
9580 *decl
= error_mark_node
;
9586 /* Given a tree that is possibly intended for use as an lvalue, return
9587 information representing a canonical view of that tree as a decl, an
9588 offset into that decl, and a size for the lvalue.
9590 If there's no applicable decl, NULL_TREE is returned for the decl,
9591 and the other fields are left undefined.
9593 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9594 is returned for the decl, and the other fields are left undefined.
9596 Otherwise, the decl returned currently is either a VAR_DECL or a
9599 The offset returned is always valid, but of course not necessarily
9600 a constant, and not necessarily converted into the appropriate
9601 type, leaving that up to the caller (so as to avoid that overhead
9602 if the decls being looked at are different anyway).
9604 If the size cannot be determined (e.g. an adjustable array),
9605 an ERROR_MARK node is returned for the size. Otherwise, the
9606 size returned is valid, not necessarily a constant, and not
9607 necessarily converted into the appropriate type as with the
9610 Note that the offset and size expressions are expressed in the
9611 base storage units (usually bits) rather than in the units of
9612 the type of the decl, because two decls with different types
9613 might overlap but with apparently non-overlapping array offsets,
9614 whereas converting the array offsets to consistant offsets will
9615 reveal the overlap. */
9617 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9619 ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
9622 /* The default path is to report a nonexistant decl. */
9628 switch (TREE_CODE (t
))
9631 case IDENTIFIER_NODE
:
9640 case TRUNC_DIV_EXPR
:
9642 case FLOOR_DIV_EXPR
:
9643 case ROUND_DIV_EXPR
:
9644 case TRUNC_MOD_EXPR
:
9646 case FLOOR_MOD_EXPR
:
9647 case ROUND_MOD_EXPR
:
9649 case EXACT_DIV_EXPR
:
9650 case FIX_TRUNC_EXPR
:
9652 case FIX_FLOOR_EXPR
:
9653 case FIX_ROUND_EXPR
:
9668 case BIT_ANDTC_EXPR
:
9670 case TRUTH_ANDIF_EXPR
:
9671 case TRUTH_ORIF_EXPR
:
9672 case TRUTH_AND_EXPR
:
9674 case TRUTH_XOR_EXPR
:
9675 case TRUTH_NOT_EXPR
:
9695 *offset
= bitsize_int (0L, 0L);
9696 *size
= TYPE_SIZE (TREE_TYPE (t
));
9701 tree array
= TREE_OPERAND (t
, 0);
9702 tree element
= TREE_OPERAND (t
, 1);
9705 if ((array
== NULL_TREE
)
9706 || (element
== NULL_TREE
))
9708 *decl
= error_mark_node
;
9712 ffecom_tree_canonize_ref_ (decl
, &init_offset
, size
,
9714 if ((*decl
== NULL_TREE
)
9715 || (*decl
== error_mark_node
))
9718 *offset
= size_binop (MULT_EXPR
,
9719 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array
))),
9720 size_binop (MINUS_EXPR
,
9724 (TREE_TYPE (array
)))));
9726 *offset
= size_binop (PLUS_EXPR
,
9730 *size
= TYPE_SIZE (TREE_TYPE (t
));
9736 /* Most of this code is to handle references to COMMON. And so
9737 far that is useful only for calling library functions, since
9738 external (user) functions might reference common areas. But
9739 even calling an external function, it's worthwhile to decode
9740 COMMON references because if not storing into COMMON, we don't
9741 want COMMON-based arguments to gratuitously force use of a
9744 *size
= TYPE_SIZE (TREE_TYPE (t
));
9746 ffecom_tree_canonize_ptr_ (decl
, offset
,
9747 TREE_OPERAND (t
, 0));
9754 case NON_LVALUE_EXPR
:
9757 case COND_EXPR
: /* More cases than we can handle. */
9759 case REFERENCE_EXPR
:
9760 case PREDECREMENT_EXPR
:
9761 case PREINCREMENT_EXPR
:
9762 case POSTDECREMENT_EXPR
:
9763 case POSTINCREMENT_EXPR
:
9766 *decl
= error_mark_node
;
9772 /* Do divide operation appropriate to type of operands. */
9774 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9776 ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
9777 tree dest_tree
, ffebld dest
, bool *dest_used
)
9779 if ((left
== error_mark_node
)
9780 || (right
== error_mark_node
))
9781 return error_mark_node
;
9783 switch (TREE_CODE (tree_type
))
9786 return ffecom_2 (TRUNC_DIV_EXPR
, tree_type
,
9794 if (TREE_TYPE (tree_type
)
9795 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9796 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9798 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9800 left
= ffecom_1 (ADDR_EXPR
,
9801 build_pointer_type (TREE_TYPE (left
)),
9803 left
= build_tree_list (NULL_TREE
, left
);
9804 right
= ffecom_1 (ADDR_EXPR
,
9805 build_pointer_type (TREE_TYPE (right
)),
9807 right
= build_tree_list (NULL_TREE
, right
);
9808 TREE_CHAIN (left
) = right
;
9810 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9811 ffecom_gfrt_kindtype (ix
),
9812 ffe_is_f2c_library (),
9815 dest_tree
, dest
, dest_used
,
9824 if (TREE_TYPE (TYPE_FIELDS (tree_type
))
9825 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9826 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9828 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9830 left
= ffecom_1 (ADDR_EXPR
,
9831 build_pointer_type (TREE_TYPE (left
)),
9833 left
= build_tree_list (NULL_TREE
, left
);
9834 right
= ffecom_1 (ADDR_EXPR
,
9835 build_pointer_type (TREE_TYPE (right
)),
9837 right
= build_tree_list (NULL_TREE
, right
);
9838 TREE_CHAIN (left
) = right
;
9840 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9841 ffecom_gfrt_kindtype (ix
),
9842 ffe_is_f2c_library (),
9845 dest_tree
, dest
, dest_used
,
9851 return ffecom_2 (RDIV_EXPR
, tree_type
,
9858 /* ffecom_type_localvar_ -- Build type info for non-dummy variable
9861 ffesymbol s; // the variable's symbol
9862 ffeinfoBasictype bt; // it's basictype
9863 ffeinfoKindtype kt; // it's kindtype
9865 type = ffecom_type_localvar_(s,bt,kt);
9867 Handles static arrays, CHARACTER type, etc. */
9869 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9871 ffecom_type_localvar_ (ffesymbol s
, ffeinfoBasictype bt
,
9880 type
= ffecom_tree_type
[bt
][kt
];
9881 if (bt
== FFEINFO_basictypeCHARACTER
)
9883 hight
= build_int_2 (ffesymbol_size (s
), 0);
9884 TREE_TYPE (hight
) = ffecom_f2c_ftnlen_type_node
;
9889 build_range_type (ffecom_f2c_ftnlen_type_node
,
9890 ffecom_f2c_ftnlen_one_node
,
9892 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9895 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
9897 if (type
== error_mark_node
)
9900 dim
= ffebld_head (dl
);
9901 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
9903 if (ffebld_left (dim
) == NULL
)
9904 lowt
= integer_one_node
;
9906 lowt
= ffecom_expr (ffebld_left (dim
));
9908 if (TREE_CODE (lowt
) != INTEGER_CST
)
9909 lowt
= variable_size (lowt
);
9911 assert (ffebld_right (dim
) != NULL
);
9912 hight
= ffecom_expr (ffebld_right (dim
));
9914 if (TREE_CODE (hight
) != INTEGER_CST
)
9915 hight
= variable_size (hight
);
9917 type
= build_array_type (type
,
9918 build_range_type (ffecom_integer_type_node
,
9920 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9927 /* Build Namelist type. */
9929 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9931 ffecom_type_namelist_ ()
9933 static tree type
= NULL_TREE
;
9935 if (type
== NULL_TREE
)
9937 static tree namefield
, varsfield
, nvarsfield
;
9940 vardesctype
= ffecom_type_vardesc_ ();
9942 push_obstacks_nochange ();
9943 end_temporary_allocation ();
9945 type
= make_node (RECORD_TYPE
);
9947 vardesctype
= build_pointer_type (build_pointer_type (vardesctype
));
9949 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9951 varsfield
= ffecom_decl_field (type
, namefield
, "vars", vardesctype
);
9952 nvarsfield
= ffecom_decl_field (type
, varsfield
, "nvars",
9955 TYPE_FIELDS (type
) = namefield
;
9958 resume_temporary_allocation ();
9967 /* Make a copy of a type, assuming caller has switched to the permanent
9968 obstacks and that the type is for an aggregate (array) initializer. */
9970 #if FFECOM_targetCURRENT == FFECOM_targetGCC && 0 /* Not used now. */
9972 ffecom_type_permanent_copy_ (tree t
)
9977 assert (TREE_TYPE (t
) != NULL_TREE
);
9979 domain
= TYPE_DOMAIN (t
);
9981 assert (TREE_CODE (t
) == ARRAY_TYPE
);
9982 assert (TREE_PERMANENT (TREE_TYPE (t
)));
9983 assert (TREE_PERMANENT (TREE_TYPE (domain
)));
9984 assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain
)));
9986 max
= TYPE_MAX_VALUE (domain
);
9987 if (!TREE_PERMANENT (max
))
9989 assert (TREE_CODE (max
) == INTEGER_CST
);
9991 max
= build_int_2 (TREE_INT_CST_LOW (max
), TREE_INT_CST_HIGH (max
));
9992 TREE_TYPE (max
) = TREE_TYPE (TYPE_MIN_VALUE (domain
));
9995 return build_array_type (TREE_TYPE (t
),
9996 build_range_type (TREE_TYPE (domain
),
9997 TYPE_MIN_VALUE (domain
),
10002 /* Build Vardesc type. */
10004 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10006 ffecom_type_vardesc_ ()
10008 static tree type
= NULL_TREE
;
10009 static tree namefield
, addrfield
, dimsfield
, typefield
;
10011 if (type
== NULL_TREE
)
10013 push_obstacks_nochange ();
10014 end_temporary_allocation ();
10016 type
= make_node (RECORD_TYPE
);
10018 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
10020 addrfield
= ffecom_decl_field (type
, namefield
, "addr",
10022 dimsfield
= ffecom_decl_field (type
, addrfield
, "dims",
10023 ffecom_f2c_ptr_to_ftnlen_type_node
);
10024 typefield
= ffecom_decl_field (type
, dimsfield
, "type",
10025 integer_type_node
);
10027 TYPE_FIELDS (type
) = namefield
;
10028 layout_type (type
);
10030 resume_temporary_allocation ();
10039 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10041 ffecom_vardesc_ (ffebld expr
)
10045 assert (ffebld_op (expr
) == FFEBLD_opSYMTER
);
10046 s
= ffebld_symter (expr
);
10048 if (ffesymbol_hook (s
).vardesc_tree
== NULL_TREE
)
10051 tree vardesctype
= ffecom_type_vardesc_ ();
10060 static int mynumber
= 0;
10062 yes
= suspend_momentary ();
10064 var
= build_decl (VAR_DECL
,
10065 ffecom_get_invented_identifier ("__g77_vardesc_%d",
10068 TREE_STATIC (var
) = 1;
10069 DECL_INITIAL (var
) = error_mark_node
;
10071 var
= start_decl (var
, FALSE
);
10073 /* Process inits. */
10075 nameinit
= ffecom_build_f2c_string_ ((i
= strlen (ffesymbol_text (s
)))
10077 ffesymbol_text (s
));
10078 TREE_TYPE (nameinit
)
10079 = build_type_variant
10082 build_range_type (integer_type_node
,
10084 build_int_2 (i
, 0))),
10086 TREE_CONSTANT (nameinit
) = 1;
10087 TREE_STATIC (nameinit
) = 1;
10088 nameinit
= ffecom_1 (ADDR_EXPR
,
10089 build_pointer_type (TREE_TYPE (nameinit
)),
10092 addrinit
= ffecom_arg_ptr_to_expr (expr
, &typeinit
);
10094 dimsinit
= ffecom_vardesc_dims_ (s
);
10096 if (typeinit
== NULL_TREE
)
10098 ffeinfoBasictype bt
= ffesymbol_basictype (s
);
10099 ffeinfoKindtype kt
= ffesymbol_kindtype (s
);
10100 int tc
= ffecom_f2c_typecode (bt
, kt
);
10103 typeinit
= build_int_2 (tc
, (tc
< 0) ? -1 : 0);
10106 typeinit
= ffecom_1 (NEGATE_EXPR
, TREE_TYPE (typeinit
), typeinit
);
10108 varinits
= build_tree_list ((field
= TYPE_FIELDS (vardesctype
)),
10110 TREE_CHAIN (varinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
10112 TREE_CHAIN (TREE_CHAIN (varinits
))
10113 = build_tree_list ((field
= TREE_CHAIN (field
)), dimsinit
);
10114 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits
)))
10115 = build_tree_list ((field
= TREE_CHAIN (field
)), typeinit
);
10117 varinits
= build (CONSTRUCTOR
, vardesctype
, NULL_TREE
, varinits
);
10118 TREE_CONSTANT (varinits
) = 1;
10119 TREE_STATIC (varinits
) = 1;
10121 finish_decl (var
, varinits
, FALSE
);
10123 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (vardesctype
), var
);
10125 resume_momentary (yes
);
10127 ffesymbol_hook (s
).vardesc_tree
= var
;
10130 return ffesymbol_hook (s
).vardesc_tree
;
10134 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10136 ffecom_vardesc_array_ (ffesymbol s
)
10140 tree item
= NULL_TREE
;
10144 static int mynumber
= 0;
10146 for (i
= 0, list
= NULL_TREE
, b
= ffesymbol_namelist (s
);
10148 b
= ffebld_trail (b
), ++i
)
10152 t
= ffecom_vardesc_ (ffebld_head (b
));
10154 if (list
== NULL_TREE
)
10155 list
= item
= build_tree_list (NULL_TREE
, t
);
10158 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
10159 item
= TREE_CHAIN (item
);
10163 yes
= suspend_momentary ();
10165 item
= build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
10166 build_range_type (integer_type_node
,
10168 build_int_2 (i
, 0)));
10169 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
10170 TREE_CONSTANT (list
) = 1;
10171 TREE_STATIC (list
) = 1;
10173 var
= ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL
,
10175 var
= build_decl (VAR_DECL
, var
, item
);
10176 TREE_STATIC (var
) = 1;
10177 DECL_INITIAL (var
) = error_mark_node
;
10178 var
= start_decl (var
, FALSE
);
10179 finish_decl (var
, list
, FALSE
);
10181 resume_momentary (yes
);
10187 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10189 ffecom_vardesc_dims_ (ffesymbol s
)
10191 if (ffesymbol_dims (s
) == NULL
)
10192 return convert (ffecom_f2c_ptr_to_ftnlen_type_node
,
10193 integer_zero_node
);
10200 tree item
= NULL_TREE
;
10205 tree baseoff
= NULL_TREE
;
10206 static int mynumber
= 0;
10208 numdim
= build_int_2 ((int) ffesymbol_rank (s
), 0);
10209 TREE_TYPE (numdim
) = ffecom_f2c_ftnlen_type_node
;
10211 numelem
= ffecom_expr (ffesymbol_arraysize (s
));
10212 TREE_TYPE (numelem
) = ffecom_f2c_ftnlen_type_node
;
10215 backlist
= NULL_TREE
;
10216 for (b
= ffesymbol_dims (s
), e
= ffesymbol_extents (s
);
10218 b
= ffebld_trail (b
), e
= ffebld_trail (e
))
10224 if (ffebld_trail (b
) == NULL
)
10228 t
= convert (ffecom_f2c_ftnlen_type_node
,
10229 ffecom_expr (ffebld_head (e
)));
10231 if (list
== NULL_TREE
)
10232 list
= item
= build_tree_list (NULL_TREE
, t
);
10235 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
10236 item
= TREE_CHAIN (item
);
10240 if (ffebld_left (ffebld_head (b
)) == NULL
)
10241 low
= ffecom_integer_one_node
;
10243 low
= ffecom_expr (ffebld_left (ffebld_head (b
)));
10244 low
= convert (ffecom_f2c_ftnlen_type_node
, low
);
10246 back
= build_tree_list (low
, t
);
10247 TREE_CHAIN (back
) = backlist
;
10251 for (item
= backlist
; item
!= NULL_TREE
; item
= TREE_CHAIN (item
))
10253 if (TREE_VALUE (item
) == NULL_TREE
)
10254 baseoff
= TREE_PURPOSE (item
);
10256 baseoff
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
10257 TREE_PURPOSE (item
),
10258 ffecom_2 (MULT_EXPR
,
10259 ffecom_f2c_ftnlen_type_node
,
10264 /* backlist now dead, along with all TREE_PURPOSEs on it. */
10266 baseoff
= build_tree_list (NULL_TREE
, baseoff
);
10267 TREE_CHAIN (baseoff
) = list
;
10269 numelem
= build_tree_list (NULL_TREE
, numelem
);
10270 TREE_CHAIN (numelem
) = baseoff
;
10272 numdim
= build_tree_list (NULL_TREE
, numdim
);
10273 TREE_CHAIN (numdim
) = numelem
;
10275 yes
= suspend_momentary ();
10277 item
= build_array_type (ffecom_f2c_ftnlen_type_node
,
10278 build_range_type (integer_type_node
,
10281 ((int) ffesymbol_rank (s
)
10283 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, numdim
);
10284 TREE_CONSTANT (list
) = 1;
10285 TREE_STATIC (list
) = 1;
10287 var
= ffecom_get_invented_identifier ("__g77_dims_%d", NULL
,
10289 var
= build_decl (VAR_DECL
, var
, item
);
10290 TREE_STATIC (var
) = 1;
10291 DECL_INITIAL (var
) = error_mark_node
;
10292 var
= start_decl (var
, FALSE
);
10293 finish_decl (var
, list
, FALSE
);
10295 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (item
), var
);
10297 resume_momentary (yes
);
10304 /* Essentially does a "fold (build1 (code, type, node))" while checking
10305 for certain housekeeping things.
10307 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
10308 ffecom_1_fn instead. */
10310 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10312 ffecom_1 (enum tree_code code
, tree type
, tree node
)
10316 if ((node
== error_mark_node
)
10317 || (type
== error_mark_node
))
10318 return error_mark_node
;
10320 if (code
== ADDR_EXPR
)
10322 if (!mark_addressable (node
))
10323 assert ("can't mark_addressable this node!" == NULL
);
10326 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
10330 case REALPART_EXPR
:
10331 item
= build (COMPONENT_REF
, type
, node
, TYPE_FIELDS (TREE_TYPE (node
)));
10334 case IMAGPART_EXPR
:
10335 item
= build (COMPONENT_REF
, type
, node
, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node
))));
10340 if (TREE_CODE (type
) != RECORD_TYPE
)
10342 item
= build1 (code
, type
, node
);
10345 node
= ffecom_stabilize_aggregate_ (node
);
10346 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10348 ffecom_2 (COMPLEX_EXPR
, type
,
10349 ffecom_1 (NEGATE_EXPR
, realtype
,
10350 ffecom_1 (REALPART_EXPR
, realtype
,
10352 ffecom_1 (NEGATE_EXPR
, realtype
,
10353 ffecom_1 (IMAGPART_EXPR
, realtype
,
10358 item
= build1 (code
, type
, node
);
10362 if (TREE_SIDE_EFFECTS (node
))
10363 TREE_SIDE_EFFECTS (item
) = 1;
10364 if ((code
== ADDR_EXPR
) && staticp (node
))
10365 TREE_CONSTANT (item
) = 1;
10366 return fold (item
);
10370 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
10371 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
10372 does not set TREE_ADDRESSABLE (because calling an inline
10373 function does not mean the function needs to be separately
10376 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10378 ffecom_1_fn (tree node
)
10383 if (node
== error_mark_node
)
10384 return error_mark_node
;
10386 type
= build_type_variant (TREE_TYPE (node
),
10387 TREE_READONLY (node
),
10388 TREE_THIS_VOLATILE (node
));
10389 item
= build1 (ADDR_EXPR
,
10390 build_pointer_type (type
), node
);
10391 if (TREE_SIDE_EFFECTS (node
))
10392 TREE_SIDE_EFFECTS (item
) = 1;
10393 if (staticp (node
))
10394 TREE_CONSTANT (item
) = 1;
10395 return fold (item
);
10399 /* Essentially does a "fold (build (code, type, node1, node2))" while
10400 checking for certain housekeeping things. */
10402 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10404 ffecom_2 (enum tree_code code
, tree type
, tree node1
,
10409 if ((node1
== error_mark_node
)
10410 || (node2
== error_mark_node
)
10411 || (type
== error_mark_node
))
10412 return error_mark_node
;
10414 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
10416 tree a
, b
, c
, d
, realtype
;
10419 assert ("no CONJ_EXPR support yet" == NULL
);
10420 return error_mark_node
;
10423 item
= build_tree_list (TYPE_FIELDS (type
), node1
);
10424 TREE_CHAIN (item
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), node2
);
10425 item
= build (CONSTRUCTOR
, type
, NULL_TREE
, item
);
10429 if (TREE_CODE (type
) != RECORD_TYPE
)
10431 item
= build (code
, type
, node1
, node2
);
10434 node1
= ffecom_stabilize_aggregate_ (node1
);
10435 node2
= ffecom_stabilize_aggregate_ (node2
);
10436 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10438 ffecom_2 (COMPLEX_EXPR
, type
,
10439 ffecom_2 (PLUS_EXPR
, realtype
,
10440 ffecom_1 (REALPART_EXPR
, realtype
,
10442 ffecom_1 (REALPART_EXPR
, realtype
,
10444 ffecom_2 (PLUS_EXPR
, realtype
,
10445 ffecom_1 (IMAGPART_EXPR
, realtype
,
10447 ffecom_1 (IMAGPART_EXPR
, realtype
,
10452 if (TREE_CODE (type
) != RECORD_TYPE
)
10454 item
= build (code
, type
, node1
, node2
);
10457 node1
= ffecom_stabilize_aggregate_ (node1
);
10458 node2
= ffecom_stabilize_aggregate_ (node2
);
10459 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10461 ffecom_2 (COMPLEX_EXPR
, type
,
10462 ffecom_2 (MINUS_EXPR
, realtype
,
10463 ffecom_1 (REALPART_EXPR
, realtype
,
10465 ffecom_1 (REALPART_EXPR
, realtype
,
10467 ffecom_2 (MINUS_EXPR
, realtype
,
10468 ffecom_1 (IMAGPART_EXPR
, realtype
,
10470 ffecom_1 (IMAGPART_EXPR
, realtype
,
10475 if (TREE_CODE (type
) != RECORD_TYPE
)
10477 item
= build (code
, type
, node1
, node2
);
10480 node1
= ffecom_stabilize_aggregate_ (node1
);
10481 node2
= ffecom_stabilize_aggregate_ (node2
);
10482 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10483 a
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
10485 b
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
10487 c
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
10489 d
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
10492 ffecom_2 (COMPLEX_EXPR
, type
,
10493 ffecom_2 (MINUS_EXPR
, realtype
,
10494 ffecom_2 (MULT_EXPR
, realtype
,
10497 ffecom_2 (MULT_EXPR
, realtype
,
10500 ffecom_2 (PLUS_EXPR
, realtype
,
10501 ffecom_2 (MULT_EXPR
, realtype
,
10504 ffecom_2 (MULT_EXPR
, realtype
,
10510 if ((TREE_CODE (node1
) != RECORD_TYPE
)
10511 && (TREE_CODE (node2
) != RECORD_TYPE
))
10513 item
= build (code
, type
, node1
, node2
);
10516 assert (TREE_CODE (node1
) == RECORD_TYPE
);
10517 assert (TREE_CODE (node2
) == RECORD_TYPE
);
10518 node1
= ffecom_stabilize_aggregate_ (node1
);
10519 node2
= ffecom_stabilize_aggregate_ (node2
);
10520 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10522 ffecom_2 (TRUTH_ANDIF_EXPR
, type
,
10523 ffecom_2 (code
, type
,
10524 ffecom_1 (REALPART_EXPR
, realtype
,
10526 ffecom_1 (REALPART_EXPR
, realtype
,
10528 ffecom_2 (code
, type
,
10529 ffecom_1 (IMAGPART_EXPR
, realtype
,
10531 ffecom_1 (IMAGPART_EXPR
, realtype
,
10536 if ((TREE_CODE (node1
) != RECORD_TYPE
)
10537 && (TREE_CODE (node2
) != RECORD_TYPE
))
10539 item
= build (code
, type
, node1
, node2
);
10542 assert (TREE_CODE (node1
) == RECORD_TYPE
);
10543 assert (TREE_CODE (node2
) == RECORD_TYPE
);
10544 node1
= ffecom_stabilize_aggregate_ (node1
);
10545 node2
= ffecom_stabilize_aggregate_ (node2
);
10546 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10548 ffecom_2 (TRUTH_ORIF_EXPR
, type
,
10549 ffecom_2 (code
, type
,
10550 ffecom_1 (REALPART_EXPR
, realtype
,
10552 ffecom_1 (REALPART_EXPR
, realtype
,
10554 ffecom_2 (code
, type
,
10555 ffecom_1 (IMAGPART_EXPR
, realtype
,
10557 ffecom_1 (IMAGPART_EXPR
, realtype
,
10562 item
= build (code
, type
, node1
, node2
);
10566 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
))
10567 TREE_SIDE_EFFECTS (item
) = 1;
10568 return fold (item
);
10572 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
10574 ffesymbol s; // the ENTRY point itself
10575 if (ffecom_2pass_advise_entrypoint(s))
10576 // the ENTRY point has been accepted
10578 Does whatever compiler needs to do when it learns about the entrypoint,
10579 like determine the return type of the master function, count the
10580 number of entrypoints, etc. Returns FALSE if the return type is
10581 not compatible with the return type(s) of other entrypoint(s).
10583 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
10584 later (after _finish_progunit) be called with the same entrypoint(s)
10585 as passed to this fn for which TRUE was returned.
10588 Return FALSE if the return type conflicts with previous entrypoints. */
10590 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10592 ffecom_2pass_advise_entrypoint (ffesymbol entry
)
10594 ffebld list
; /* opITEM. */
10595 ffebld mlist
; /* opITEM. */
10596 ffebld plist
; /* opITEM. */
10597 ffebld arg
; /* ffebld_head(opITEM). */
10598 ffebld item
; /* opITEM. */
10599 ffesymbol s
; /* ffebld_symter(arg). */
10600 ffeinfoBasictype bt
= ffesymbol_basictype (entry
);
10601 ffeinfoKindtype kt
= ffesymbol_kindtype (entry
);
10602 ffetargetCharacterSize size
= ffesymbol_size (entry
);
10605 if (ffecom_num_entrypoints_
== 0)
10606 { /* First entrypoint, make list of main
10607 arglist's dummies. */
10608 assert (ffecom_primary_entry_
!= NULL
);
10610 ffecom_master_bt_
= ffesymbol_basictype (ffecom_primary_entry_
);
10611 ffecom_master_kt_
= ffesymbol_kindtype (ffecom_primary_entry_
);
10612 ffecom_master_size_
= ffesymbol_size (ffecom_primary_entry_
);
10614 for (plist
= NULL
, list
= ffesymbol_dummyargs (ffecom_primary_entry_
);
10616 list
= ffebld_trail (list
))
10618 arg
= ffebld_head (list
);
10619 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
10620 continue; /* Alternate return or some such thing. */
10621 item
= ffebld_new_item (arg
, NULL
);
10623 ffecom_master_arglist_
= item
;
10625 ffebld_set_trail (plist
, item
);
10630 /* If necessary, scan entry arglist for alternate returns. Do this scan
10631 apparently redundantly (it's done below to UNIONize the arglists) so
10632 that we don't complain about RETURN 1 if an offending ENTRY is the only
10633 one with an alternate return. */
10635 if (!ffecom_is_altreturning_
)
10637 for (list
= ffesymbol_dummyargs (entry
);
10639 list
= ffebld_trail (list
))
10641 arg
= ffebld_head (list
);
10642 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
10644 ffecom_is_altreturning_
= TRUE
;
10650 /* Now check type compatibility. */
10652 switch (ffecom_master_bt_
)
10654 case FFEINFO_basictypeNONE
:
10655 ok
= (bt
!= FFEINFO_basictypeCHARACTER
);
10658 case FFEINFO_basictypeCHARACTER
:
10660 = (bt
== FFEINFO_basictypeCHARACTER
)
10661 && (kt
== ffecom_master_kt_
)
10662 && (size
== ffecom_master_size_
);
10665 case FFEINFO_basictypeANY
:
10666 return FALSE
; /* Just don't bother. */
10669 if (bt
== FFEINFO_basictypeCHARACTER
)
10675 if ((bt
!= ffecom_master_bt_
) || (kt
!= ffecom_master_kt_
))
10677 ffecom_master_bt_
= FFEINFO_basictypeNONE
;
10678 ffecom_master_kt_
= FFEINFO_kindtypeNONE
;
10685 ffebad_start (FFEBAD_ENTRY_CONFLICTS
);
10686 ffest_ffebad_here_current_stmt (0);
10688 return FALSE
; /* Can't handle entrypoint. */
10691 /* Entrypoint type compatible with previous types. */
10693 ++ffecom_num_entrypoints_
;
10695 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10697 for (list
= ffesymbol_dummyargs (entry
);
10699 list
= ffebld_trail (list
))
10701 arg
= ffebld_head (list
);
10702 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
10703 continue; /* Alternate return or some such thing. */
10704 s
= ffebld_symter (arg
);
10705 for (plist
= NULL
, mlist
= ffecom_master_arglist_
;
10707 plist
= mlist
, mlist
= ffebld_trail (mlist
))
10708 { /* plist points to previous item for easy
10709 appending of arg. */
10710 if (ffebld_symter (ffebld_head (mlist
)) == s
)
10711 break; /* Already have this arg in the master list. */
10714 continue; /* Already have this arg in the master list. */
10716 /* Append this arg to the master list. */
10718 item
= ffebld_new_item (arg
, NULL
);
10720 ffecom_master_arglist_
= item
;
10722 ffebld_set_trail (plist
, item
);
10729 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10731 ffesymbol s; // the ENTRY point itself
10732 ffecom_2pass_do_entrypoint(s);
10734 Does whatever compiler needs to do to make the entrypoint actually
10735 happen. Must be called for each entrypoint after
10736 ffecom_finish_progunit is called. */
10738 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10740 ffecom_2pass_do_entrypoint (ffesymbol entry
)
10742 static int mfn_num
= 0;
10743 static int ent_num
;
10745 if (mfn_num
!= ffecom_num_fns_
)
10746 { /* First entrypoint for this program unit. */
10748 mfn_num
= ffecom_num_fns_
;
10749 ffecom_do_entry_ (ffecom_primary_entry_
, 0);
10754 --ffecom_num_entrypoints_
;
10756 ffecom_do_entry_ (entry
, ent_num
);
10761 /* Essentially does a "fold (build (code, type, node1, node2))" while
10762 checking for certain housekeeping things. Always sets
10763 TREE_SIDE_EFFECTS. */
10765 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10767 ffecom_2s (enum tree_code code
, tree type
, tree node1
,
10772 if ((node1
== error_mark_node
)
10773 || (node2
== error_mark_node
)
10774 || (type
== error_mark_node
))
10775 return error_mark_node
;
10777 item
= build (code
, type
, node1
, node2
);
10778 TREE_SIDE_EFFECTS (item
) = 1;
10779 return fold (item
);
10783 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10784 checking for certain housekeeping things. */
10786 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10788 ffecom_3 (enum tree_code code
, tree type
, tree node1
,
10789 tree node2
, tree node3
)
10793 if ((node1
== error_mark_node
)
10794 || (node2
== error_mark_node
)
10795 || (node3
== error_mark_node
)
10796 || (type
== error_mark_node
))
10797 return error_mark_node
;
10799 item
= build (code
, type
, node1
, node2
, node3
);
10800 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
)
10801 || (node3
!= NULL_TREE
&& TREE_SIDE_EFFECTS (node3
)))
10802 TREE_SIDE_EFFECTS (item
) = 1;
10803 return fold (item
);
10807 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10808 checking for certain housekeeping things. Always sets
10809 TREE_SIDE_EFFECTS. */
10811 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10813 ffecom_3s (enum tree_code code
, tree type
, tree node1
,
10814 tree node2
, tree node3
)
10818 if ((node1
== error_mark_node
)
10819 || (node2
== error_mark_node
)
10820 || (node3
== error_mark_node
)
10821 || (type
== error_mark_node
))
10822 return error_mark_node
;
10824 item
= build (code
, type
, node1
, node2
, node3
);
10825 TREE_SIDE_EFFECTS (item
) = 1;
10826 return fold (item
);
10830 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10832 See use by ffecom_list_expr.
10834 If expression is NULL, returns an integer zero tree. If it is not
10835 a CHARACTER expression, returns whatever ffecom_expr
10836 returns and sets the length return value to NULL_TREE. Otherwise
10837 generates code to evaluate the character expression, returns the proper
10838 pointer to the result, but does NOT set the length return value to a tree
10839 that specifies the length of the result. (In other words, the length
10840 variable is always set to NULL_TREE, because a length is never passed.)
10843 Don't set returned length, since nobody needs it (yet; someday if
10844 we allow CHARACTER*(*) dummies to statement functions, we'll need
10847 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10849 ffecom_arg_expr (ffebld expr
, tree
*length
)
10853 *length
= NULL_TREE
;
10856 return integer_zero_node
;
10858 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10859 return ffecom_expr (expr
);
10861 return ffecom_arg_ptr_to_expr (expr
, &ign
);
10865 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10867 See use by ffecom_list_ptr_to_expr.
10869 If expression is NULL, returns an integer zero tree. If it is not
10870 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10871 returns and sets the length return value to NULL_TREE. Otherwise
10872 generates code to evaluate the character expression, returns the proper
10873 pointer to the result, AND sets the length return value to a tree that
10874 specifies the length of the result.
10876 If the length argument is NULL, this is a slightly special
10877 case of building a FORMAT expression, that is, an expression that
10878 will be used at run time without regard to length. For the current
10879 implementation, which uses the libf2c library, this means it is nice
10880 to append a null byte to the end of the expression, where feasible,
10881 to make sure any diagnostic about the FORMAT string terminates at
10884 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10885 length argument. This might even be seen as a feature, if a null
10886 byte can always be appended. */
10888 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10890 ffecom_arg_ptr_to_expr (ffebld expr
, tree
*length
)
10894 ffecomConcatList_ catlist
;
10896 if (length
!= NULL
)
10897 *length
= NULL_TREE
;
10900 return integer_zero_node
;
10902 switch (ffebld_op (expr
))
10904 case FFEBLD_opPERCENT_VAL
:
10905 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10906 return ffecom_expr (ffebld_left (expr
));
10911 temp_exp
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &temp_length
);
10912 return ffecom_1 (INDIRECT_REF
, TREE_TYPE (TREE_TYPE (temp_exp
)),
10916 case FFEBLD_opPERCENT_REF
:
10917 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10918 return ffecom_ptr_to_expr (ffebld_left (expr
));
10919 if (length
!= NULL
)
10921 ign_length
= NULL_TREE
;
10922 length
= &ign_length
;
10924 expr
= ffebld_left (expr
);
10927 case FFEBLD_opPERCENT_DESCR
:
10928 switch (ffeinfo_basictype (ffebld_info (expr
)))
10930 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10931 case FFEINFO_basictypeHOLLERITH
:
10933 case FFEINFO_basictypeCHARACTER
:
10934 break; /* Passed by descriptor anyway. */
10937 item
= ffecom_ptr_to_expr (expr
);
10938 if (item
!= error_mark_node
)
10939 *length
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (item
)));
10948 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10949 if ((ffeinfo_basictype (ffebld_info (expr
)) == FFEINFO_basictypeHOLLERITH
)
10950 && (length
!= NULL
))
10951 { /* Pass Hollerith by descriptor. */
10952 ffetargetHollerith h
;
10954 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
10955 h
= ffebld_cu_val_hollerith (ffebld_constant_union
10956 (ffebld_conter (expr
)));
10958 = build_int_2 (h
.length
, 0);
10959 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10963 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10964 return ffecom_ptr_to_expr (expr
);
10966 assert (ffeinfo_kindtype (ffebld_info (expr
))
10967 == FFEINFO_kindtypeCHARACTER1
);
10969 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
10970 switch (ffecom_concat_list_count_ (catlist
))
10972 case 0: /* Shouldn't happen, but in case it does... */
10973 if (length
!= NULL
)
10975 *length
= ffecom_f2c_ftnlen_zero_node
;
10976 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10978 ffecom_concat_list_kill_ (catlist
);
10979 return null_pointer_node
;
10981 case 1: /* The (fairly) easy case. */
10982 if (length
== NULL
)
10983 ffecom_char_args_with_null_ (&item
, &ign_length
,
10984 ffecom_concat_list_expr_ (catlist
, 0));
10986 ffecom_char_args_ (&item
, length
,
10987 ffecom_concat_list_expr_ (catlist
, 0));
10988 ffecom_concat_list_kill_ (catlist
);
10989 assert (item
!= NULL_TREE
);
10992 default: /* Must actually concatenate things. */
10997 int count
= ffecom_concat_list_count_ (catlist
);
11008 ffetargetCharacterSize sz
;
11012 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
11013 FFETARGET_charactersizeNONE
, count
, TRUE
);
11016 = ffecom_push_tempvar (ffecom_f2c_address_type_node
,
11017 FFETARGET_charactersizeNONE
, count
, TRUE
);
11019 known_length
= ffecom_f2c_ftnlen_zero_node
;
11021 for (i
= 0; i
< count
; ++i
)
11024 && (length
== NULL
))
11025 ffecom_char_args_with_null_ (&citem
, &clength
,
11026 ffecom_concat_list_expr_ (catlist
, i
));
11028 ffecom_char_args_ (&citem
, &clength
,
11029 ffecom_concat_list_expr_ (catlist
, i
));
11030 if ((citem
== error_mark_node
)
11031 || (clength
== error_mark_node
))
11033 ffecom_concat_list_kill_ (catlist
);
11034 *length
= error_mark_node
;
11035 return error_mark_node
;
11039 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
11040 ffecom_modify (void_type_node
,
11041 ffecom_2 (ARRAY_REF
,
11042 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
11044 build_int_2 (i
, 0)),
11047 clength
= ffecom_save_tree (clength
);
11048 if (length
!= NULL
)
11050 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
11054 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
11055 ffecom_modify (void_type_node
,
11056 ffecom_2 (ARRAY_REF
,
11057 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
11059 build_int_2 (i
, 0)),
11064 sz
= ffecom_concat_list_maxlen_ (catlist
);
11065 assert (sz
!= FFETARGET_charactersizeNONE
);
11067 temporary
= ffecom_push_tempvar (char_type_node
,
11069 temporary
= ffecom_1 (ADDR_EXPR
,
11070 build_pointer_type (TREE_TYPE (temporary
)),
11073 item
= build_tree_list (NULL_TREE
, temporary
);
11075 = build_tree_list (NULL_TREE
,
11076 ffecom_1 (ADDR_EXPR
,
11077 build_pointer_type (TREE_TYPE (items
)),
11079 TREE_CHAIN (TREE_CHAIN (item
))
11080 = build_tree_list (NULL_TREE
,
11081 ffecom_1 (ADDR_EXPR
,
11082 build_pointer_type (TREE_TYPE (lengths
)),
11084 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
11087 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
11088 convert (ffecom_f2c_ftnlen_type_node
,
11089 build_int_2 (count
, 0))));
11090 num
= build_int_2 (sz
, 0);
11091 TREE_TYPE (num
) = ffecom_f2c_ftnlen_type_node
;
11092 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
))))
11093 = build_tree_list (NULL_TREE
, num
);
11095 item
= ffecom_call_gfrt (FFECOM_gfrtCAT
, item
);
11096 TREE_SIDE_EFFECTS (item
) = 1;
11097 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (temporary
),
11101 if (length
!= NULL
)
11102 *length
= known_length
;
11105 ffecom_concat_list_kill_ (catlist
);
11106 assert (item
!= NULL_TREE
);
11111 /* ffecom_call_gfrt -- Generate call to run-time function
11114 expr = ffecom_call_gfrt(FFECOM_gfrtSTOPNIL,NULL_TREE);
11116 The first arg is the GNU Fortran Run-Time function index, the second
11117 arg is the list of arguments to pass to it. Returned is the expression
11118 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
11119 result (which may be void). */
11121 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11123 ffecom_call_gfrt (ffecomGfrt ix
, tree args
)
11125 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
11126 ffecom_gfrt_kindtype (ix
),
11127 ffe_is_f2c_library () && ffecom_gfrt_complex_
[ix
],
11128 NULL_TREE
, args
, NULL_TREE
, NULL
,
11129 NULL
, NULL_TREE
, TRUE
);
11133 /* ffecom_constantunion -- Transform constant-union to tree
11135 ffebldConstantUnion cu; // the constant to transform
11136 ffeinfoBasictype bt; // its basic type
11137 ffeinfoKindtype kt; // its kind type
11138 tree tree_type; // ffecom_tree_type[bt][kt]
11139 ffecom_constantunion(&cu,bt,kt,tree_type); */
11141 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11143 ffecom_constantunion (ffebldConstantUnion
*cu
, ffeinfoBasictype bt
,
11144 ffeinfoKindtype kt
, tree tree_type
)
11150 case FFEINFO_basictypeINTEGER
:
11156 #if FFETARGET_okINTEGER1
11157 case FFEINFO_kindtypeINTEGER1
:
11158 val
= ffebld_cu_val_integer1 (*cu
);
11162 #if FFETARGET_okINTEGER2
11163 case FFEINFO_kindtypeINTEGER2
:
11164 val
= ffebld_cu_val_integer2 (*cu
);
11168 #if FFETARGET_okINTEGER3
11169 case FFEINFO_kindtypeINTEGER3
:
11170 val
= ffebld_cu_val_integer3 (*cu
);
11174 #if FFETARGET_okINTEGER4
11175 case FFEINFO_kindtypeINTEGER4
:
11176 val
= ffebld_cu_val_integer4 (*cu
);
11181 assert ("bad INTEGER constant kind type" == NULL
);
11182 /* Fall through. */
11183 case FFEINFO_kindtypeANY
:
11184 return error_mark_node
;
11186 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
11187 TREE_TYPE (item
) = tree_type
;
11191 case FFEINFO_basictypeLOGICAL
:
11197 #if FFETARGET_okLOGICAL1
11198 case FFEINFO_kindtypeLOGICAL1
:
11199 val
= ffebld_cu_val_logical1 (*cu
);
11203 #if FFETARGET_okLOGICAL2
11204 case FFEINFO_kindtypeLOGICAL2
:
11205 val
= ffebld_cu_val_logical2 (*cu
);
11209 #if FFETARGET_okLOGICAL3
11210 case FFEINFO_kindtypeLOGICAL3
:
11211 val
= ffebld_cu_val_logical3 (*cu
);
11215 #if FFETARGET_okLOGICAL4
11216 case FFEINFO_kindtypeLOGICAL4
:
11217 val
= ffebld_cu_val_logical4 (*cu
);
11222 assert ("bad LOGICAL constant kind type" == NULL
);
11223 /* Fall through. */
11224 case FFEINFO_kindtypeANY
:
11225 return error_mark_node
;
11227 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
11228 TREE_TYPE (item
) = tree_type
;
11232 case FFEINFO_basictypeREAL
:
11234 REAL_VALUE_TYPE val
;
11238 #if FFETARGET_okREAL1
11239 case FFEINFO_kindtypeREAL1
:
11240 val
= ffetarget_value_real1 (ffebld_cu_val_real1 (*cu
));
11244 #if FFETARGET_okREAL2
11245 case FFEINFO_kindtypeREAL2
:
11246 val
= ffetarget_value_real2 (ffebld_cu_val_real2 (*cu
));
11250 #if FFETARGET_okREAL3
11251 case FFEINFO_kindtypeREAL3
:
11252 val
= ffetarget_value_real3 (ffebld_cu_val_real3 (*cu
));
11256 #if FFETARGET_okREAL4
11257 case FFEINFO_kindtypeREAL4
:
11258 val
= ffetarget_value_real4 (ffebld_cu_val_real4 (*cu
));
11263 assert ("bad REAL constant kind type" == NULL
);
11264 /* Fall through. */
11265 case FFEINFO_kindtypeANY
:
11266 return error_mark_node
;
11268 item
= build_real (tree_type
, val
);
11272 case FFEINFO_basictypeCOMPLEX
:
11274 REAL_VALUE_TYPE real
;
11275 REAL_VALUE_TYPE imag
;
11276 tree el_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
11280 #if FFETARGET_okCOMPLEX1
11281 case FFEINFO_kindtypeREAL1
:
11282 real
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).real
);
11283 imag
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).imaginary
);
11287 #if FFETARGET_okCOMPLEX2
11288 case FFEINFO_kindtypeREAL2
:
11289 real
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).real
);
11290 imag
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).imaginary
);
11294 #if FFETARGET_okCOMPLEX3
11295 case FFEINFO_kindtypeREAL3
:
11296 real
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).real
);
11297 imag
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).imaginary
);
11301 #if FFETARGET_okCOMPLEX4
11302 case FFEINFO_kindtypeREAL4
:
11303 real
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).real
);
11304 imag
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).imaginary
);
11309 assert ("bad REAL constant kind type" == NULL
);
11310 /* Fall through. */
11311 case FFEINFO_kindtypeANY
:
11312 return error_mark_node
;
11314 item
= ffecom_build_complex_constant_ (tree_type
,
11315 build_real (el_type
, real
),
11316 build_real (el_type
, imag
));
11320 case FFEINFO_basictypeCHARACTER
:
11321 { /* Happens only in DATA and similar contexts. */
11322 ffetargetCharacter1 val
;
11326 #if FFETARGET_okCHARACTER1
11327 case FFEINFO_kindtypeLOGICAL1
:
11328 val
= ffebld_cu_val_character1 (*cu
);
11333 assert ("bad CHARACTER constant kind type" == NULL
);
11334 /* Fall through. */
11335 case FFEINFO_kindtypeANY
:
11336 return error_mark_node
;
11338 item
= build_string (ffetarget_length_character1 (val
),
11339 ffetarget_text_character1 (val
));
11341 = build_type_variant (build_array_type (char_type_node
,
11343 (integer_type_node
,
11346 (ffetarget_length_character1
11352 case FFEINFO_basictypeHOLLERITH
:
11354 ffetargetHollerith h
;
11356 h
= ffebld_cu_val_hollerith (*cu
);
11358 /* If not at least as wide as default INTEGER, widen it. */
11359 if (h
.length
>= FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
)
11360 item
= build_string (h
.length
, h
.text
);
11363 char str
[FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
];
11365 memcpy (str
, h
.text
, h
.length
);
11366 memset (&str
[h
.length
], ' ',
11367 FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
11369 item
= build_string (FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
,
11373 = build_type_variant (build_array_type (char_type_node
,
11375 (integer_type_node
,
11383 case FFEINFO_basictypeTYPELESS
:
11385 ffetargetInteger1 ival
;
11386 ffetargetTypeless tless
;
11389 tless
= ffebld_cu_val_typeless (*cu
);
11390 error
= ffetarget_convert_integer1_typeless (&ival
, tless
);
11391 assert (error
== FFEBAD
);
11393 item
= build_int_2 ((int) ival
, 0);
11398 assert ("not yet on constant type" == NULL
);
11399 /* Fall through. */
11400 case FFEINFO_basictypeANY
:
11401 return error_mark_node
;
11404 TREE_CONSTANT (item
) = 1;
11411 /* Handy way to make a field in a struct/union. */
11413 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11415 ffecom_decl_field (tree context
, tree prevfield
,
11416 char *name
, tree type
)
11420 field
= build_decl (FIELD_DECL
, get_identifier (name
), type
);
11421 DECL_CONTEXT (field
) = context
;
11422 DECL_FRAME_SIZE (field
) = 0;
11423 if (prevfield
!= NULL_TREE
)
11424 TREE_CHAIN (prevfield
) = field
;
11432 ffecom_close_include (FILE *f
)
11434 #if FFECOM_GCC_INCLUDE
11435 ffecom_close_include_ (f
);
11440 ffecom_decode_include_option (char *spec
)
11442 #if FFECOM_GCC_INCLUDE
11443 return ffecom_decode_include_option_ (spec
);
11449 /* ffecom_end_transition -- Perform end transition on all symbols
11451 ffecom_end_transition();
11453 Calls ffecom_sym_end_transition for each global and local symbol. */
11456 ffecom_end_transition ()
11458 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11462 if (ffe_is_ffedebug ())
11463 fprintf (dmpout
, "; end_stmt_transition\n");
11465 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11466 ffecom_list_blockdata_
= NULL
;
11467 ffecom_list_common_
= NULL
;
11470 ffesymbol_drive (ffecom_sym_end_transition
);
11471 if (ffe_is_ffedebug ())
11473 ffestorag_report ();
11474 ffesymbol_report_all ();
11477 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11478 ffecom_start_progunit_ ();
11480 for (item
= ffecom_list_blockdata_
;
11482 item
= ffebld_trail (item
))
11490 static int number
= 0;
11492 callee
= ffebld_head (item
);
11493 s
= ffebld_symter (callee
);
11494 t
= ffesymbol_hook (s
).decl_tree
;
11495 if (t
== NULL_TREE
)
11497 s
= ffecom_sym_transform_ (s
);
11498 t
= ffesymbol_hook (s
).decl_tree
;
11501 yes
= suspend_momentary ();
11503 dt
= build_pointer_type (TREE_TYPE (t
));
11505 var
= build_decl (VAR_DECL
,
11506 ffecom_get_invented_identifier ("__g77_forceload_%d",
11509 DECL_EXTERNAL (var
) = 0;
11510 TREE_STATIC (var
) = 1;
11511 TREE_PUBLIC (var
) = 0;
11512 DECL_INITIAL (var
) = error_mark_node
;
11513 TREE_USED (var
) = 1;
11515 var
= start_decl (var
, FALSE
);
11517 t
= ffecom_1 (ADDR_EXPR
, dt
, t
);
11519 finish_decl (var
, t
, FALSE
);
11521 resume_momentary (yes
);
11524 /* This handles any COMMON areas that weren't referenced but have, for
11525 example, important initial data. */
11527 for (item
= ffecom_list_common_
;
11529 item
= ffebld_trail (item
))
11530 ffecom_transform_common_ (ffebld_symter (ffebld_head (item
)));
11532 ffecom_list_common_
= NULL
;
11536 /* ffecom_exec_transition -- Perform exec transition on all symbols
11538 ffecom_exec_transition();
11540 Calls ffecom_sym_exec_transition for each global and local symbol.
11541 Make sure error updating not inhibited. */
11544 ffecom_exec_transition ()
11548 if (ffe_is_ffedebug ())
11549 fprintf (dmpout
, "; exec_stmt_transition\n");
11551 inhibited
= ffebad_inhibit ();
11552 ffebad_set_inhibit (FALSE
);
11554 ffesymbol_drive (ffecom_sym_exec_transition
); /* Don't retract! */
11555 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
11556 if (ffe_is_ffedebug ())
11558 ffestorag_report ();
11559 ffesymbol_report_all ();
11563 ffebad_set_inhibit (TRUE
);
11566 /* ffecom_expand_let_stmt -- Compile let (assignment) statement
11570 ffecom_expand_let_stmt(dest,source);
11572 Convert dest and source using ffecom_expr, then join them
11573 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
11575 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11577 ffecom_expand_let_stmt (ffebld dest
, ffebld source
)
11584 if (ffeinfo_basictype (ffebld_info (dest
)) != FFEINFO_basictypeCHARACTER
)
11588 dest_tree
= ffecom_expr_rw (dest
);
11589 if (dest_tree
== error_mark_node
)
11592 if ((TREE_CODE (dest_tree
) != VAR_DECL
)
11593 || TREE_ADDRESSABLE (dest_tree
))
11594 source_tree
= ffecom_expr_ (source
, dest_tree
, dest
, &dest_used
,
11598 source_tree
= ffecom_expr (source
);
11601 if (source_tree
== error_mark_node
)
11605 expr_tree
= source_tree
;
11607 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
11611 expand_expr_stmt (expr_tree
);
11615 ffecom_push_calltemps ();
11616 ffecom_char_args_ (&dest_tree
, &dest_length
, dest
);
11617 ffecom_let_char_ (dest_tree
, dest_length
, ffebld_size_known (dest
),
11619 ffecom_pop_calltemps ();
11623 /* ffecom_expr -- Transform expr into gcc tree
11626 ffebld expr; // FFE expression.
11627 tree = ffecom_expr(expr);
11629 Recursive descent on expr while making corresponding tree nodes and
11630 attaching type info and such. */
11632 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11634 ffecom_expr (ffebld expr
)
11636 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, FALSE
, FALSE
);
11640 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
11642 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11644 ffecom_expr_assign (ffebld expr
)
11646 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
11650 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
11652 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11654 ffecom_expr_assign_w (ffebld expr
)
11656 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
11660 /* Transform expr for use as into read/write tree and stabilize the
11661 reference. Not for use on CHARACTER expressions.
11663 Recursive descent on expr while making corresponding tree nodes and
11664 attaching type info and such. */
11666 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11668 ffecom_expr_rw (ffebld expr
)
11670 assert (expr
!= NULL
);
11672 return stabilize_reference (ffecom_expr (expr
));
11676 /* Do global stuff. */
11678 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11680 ffecom_finish_compile ()
11682 assert (ffecom_outer_function_decl_
== NULL_TREE
);
11683 assert (current_function_decl
== NULL_TREE
);
11685 ffeglobal_drive (ffecom_finish_global_
);
11689 /* Public entry point for front end to access finish_decl. */
11691 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11693 ffecom_finish_decl (tree decl
, tree init
, bool is_top_level
)
11695 assert (!is_top_level
);
11696 finish_decl (decl
, init
, FALSE
);
11700 /* Finish a program unit. */
11702 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11704 ffecom_finish_progunit ()
11706 ffecom_end_compstmt_ ();
11708 ffecom_previous_function_decl_
= current_function_decl
;
11709 ffecom_which_entrypoint_decl_
= NULL_TREE
;
11711 finish_function (0);
11715 /* Wrapper for get_identifier. pattern is like "...%s...", text is
11716 inserted into final name in place of "%s", or if text is NULL,
11717 pattern is like "...%d..." and text form of number is inserted
11718 in place of "%d". */
11720 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11722 ffecom_get_invented_identifier (char *pattern
, char *text
, int number
)
11730 lenlen
= strlen (pattern
) + 20;
11732 lenlen
= strlen (pattern
) + strlen (text
) - 1;
11733 if (lenlen
> ARRAY_SIZE (space
))
11734 nam
= malloc_new_ks (malloc_pool_image (), pattern
, lenlen
);
11738 sprintf (&nam
[0], pattern
, number
);
11740 sprintf (&nam
[0], pattern
, text
);
11741 decl
= get_identifier (nam
);
11742 if (lenlen
> ARRAY_SIZE (space
))
11743 malloc_kill_ks (malloc_pool_image (), nam
, lenlen
);
11745 IDENTIFIER_INVENTED (decl
) = 1;
11751 ffecom_gfrt_basictype (ffecomGfrt gfrt
)
11753 assert (gfrt
< FFECOM_gfrt
);
11755 switch (ffecom_gfrt_type_
[gfrt
])
11757 case FFECOM_rttypeVOID_
:
11758 case FFECOM_rttypeVOIDSTAR_
:
11759 return FFEINFO_basictypeNONE
;
11761 case FFECOM_rttypeFTNINT_
:
11762 return FFEINFO_basictypeINTEGER
;
11764 case FFECOM_rttypeINTEGER_
:
11765 return FFEINFO_basictypeINTEGER
;
11767 case FFECOM_rttypeLONGINT_
:
11768 return FFEINFO_basictypeINTEGER
;
11770 case FFECOM_rttypeLOGICAL_
:
11771 return FFEINFO_basictypeLOGICAL
;
11773 case FFECOM_rttypeREAL_F2C_
:
11774 case FFECOM_rttypeREAL_GNU_
:
11775 return FFEINFO_basictypeREAL
;
11777 case FFECOM_rttypeCOMPLEX_F2C_
:
11778 case FFECOM_rttypeCOMPLEX_GNU_
:
11779 return FFEINFO_basictypeCOMPLEX
;
11781 case FFECOM_rttypeDOUBLE_
:
11782 case FFECOM_rttypeDOUBLEREAL_
:
11783 return FFEINFO_basictypeREAL
;
11785 case FFECOM_rttypeDBLCMPLX_F2C_
:
11786 case FFECOM_rttypeDBLCMPLX_GNU_
:
11787 return FFEINFO_basictypeCOMPLEX
;
11789 case FFECOM_rttypeCHARACTER_
:
11790 return FFEINFO_basictypeCHARACTER
;
11793 return FFEINFO_basictypeANY
;
11798 ffecom_gfrt_kindtype (ffecomGfrt gfrt
)
11800 assert (gfrt
< FFECOM_gfrt
);
11802 switch (ffecom_gfrt_type_
[gfrt
])
11804 case FFECOM_rttypeVOID_
:
11805 case FFECOM_rttypeVOIDSTAR_
:
11806 return FFEINFO_kindtypeNONE
;
11808 case FFECOM_rttypeFTNINT_
:
11809 return FFEINFO_kindtypeINTEGER1
;
11811 case FFECOM_rttypeINTEGER_
:
11812 return FFEINFO_kindtypeINTEGER1
;
11814 case FFECOM_rttypeLONGINT_
:
11815 return FFEINFO_kindtypeINTEGER4
;
11817 case FFECOM_rttypeLOGICAL_
:
11818 return FFEINFO_kindtypeLOGICAL1
;
11820 case FFECOM_rttypeREAL_F2C_
:
11821 case FFECOM_rttypeREAL_GNU_
:
11822 return FFEINFO_kindtypeREAL1
;
11824 case FFECOM_rttypeCOMPLEX_F2C_
:
11825 case FFECOM_rttypeCOMPLEX_GNU_
:
11826 return FFEINFO_kindtypeREAL1
;
11828 case FFECOM_rttypeDOUBLE_
:
11829 case FFECOM_rttypeDOUBLEREAL_
:
11830 return FFEINFO_kindtypeREAL2
;
11832 case FFECOM_rttypeDBLCMPLX_F2C_
:
11833 case FFECOM_rttypeDBLCMPLX_GNU_
:
11834 return FFEINFO_kindtypeREAL2
;
11836 case FFECOM_rttypeCHARACTER_
:
11837 return FFEINFO_kindtypeCHARACTER1
;
11840 return FFEINFO_kindtypeANY
;
11855 /* This block of code comes from the now-obsolete cktyps.c. It checks
11856 whether the compiler environment is buggy in known ways, some of which
11857 would, if not explicitly checked here, result in subtle bugs in g77. */
11859 if (ffe_is_do_internal_checks ())
11861 static char names
[][12]
11863 {"bar", "bletch", "foo", "foobar"};
11868 name
= bsearch ("foo", &names
[0], ARRAY_SIZE (names
), sizeof (names
[0]),
11869 (int (*)()) strcmp
);
11870 if (name
!= (char *) &names
[2])
11872 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11877 ul
= strtoul ("123456789", NULL
, 10);
11878 if (ul
!= 123456789L)
11880 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11881 in proj.h" == NULL
);
11885 fl
= atof ("56.789");
11886 if ((fl
< 56.788) || (fl
> 56.79))
11888 assert ("atof not type double, fix your #include <stdio.h>"
11894 /* Set the sizetype before we do anything else. This _should_ be the
11895 first type we create. */
11897 t
= make_unsigned_type (POINTER_SIZE
);
11898 assert (t
== sizetype
);
11900 #if FFECOM_GCC_INCLUDE
11901 ffecom_initialize_char_syntax_ ();
11904 ffecom_outer_function_decl_
= NULL_TREE
;
11905 current_function_decl
= NULL_TREE
;
11906 named_labels
= NULL_TREE
;
11907 current_binding_level
= NULL_BINDING_LEVEL
;
11908 free_binding_level
= NULL_BINDING_LEVEL
;
11909 pushlevel (0); /* make the binding_level structure for
11911 global_binding_level
= current_binding_level
;
11913 /* Define `int' and `char' first so that dbx will output them first. */
11915 integer_type_node
= make_signed_type (INT_TYPE_SIZE
);
11916 pushdecl (build_decl (TYPE_DECL
, get_identifier ("int"),
11917 integer_type_node
));
11919 char_type_node
= make_unsigned_type (CHAR_TYPE_SIZE
);
11920 pushdecl (build_decl (TYPE_DECL
, get_identifier ("char"),
11923 long_integer_type_node
= make_signed_type (LONG_TYPE_SIZE
);
11924 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long int"),
11925 long_integer_type_node
));
11927 unsigned_type_node
= make_unsigned_type (INT_TYPE_SIZE
);
11928 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned int"),
11929 unsigned_type_node
));
11931 long_unsigned_type_node
= make_unsigned_type (LONG_TYPE_SIZE
);
11932 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long unsigned int"),
11933 long_unsigned_type_node
));
11935 long_long_integer_type_node
= make_signed_type (LONG_LONG_TYPE_SIZE
);
11936 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long int"),
11937 long_long_integer_type_node
));
11939 long_long_unsigned_type_node
= make_unsigned_type (LONG_LONG_TYPE_SIZE
);
11940 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long unsigned int"),
11941 long_long_unsigned_type_node
));
11943 error_mark_node
= make_node (ERROR_MARK
);
11944 TREE_TYPE (error_mark_node
) = error_mark_node
;
11946 short_integer_type_node
= make_signed_type (SHORT_TYPE_SIZE
);
11947 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short int"),
11948 short_integer_type_node
));
11950 short_unsigned_type_node
= make_unsigned_type (SHORT_TYPE_SIZE
);
11951 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short unsigned int"),
11952 short_unsigned_type_node
));
11954 /* Define both `signed char' and `unsigned char'. */
11955 signed_char_type_node
= make_signed_type (CHAR_TYPE_SIZE
);
11956 pushdecl (build_decl (TYPE_DECL
, get_identifier ("signed char"),
11957 signed_char_type_node
));
11959 unsigned_char_type_node
= make_unsigned_type (CHAR_TYPE_SIZE
);
11960 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned char"),
11961 unsigned_char_type_node
));
11963 float_type_node
= make_node (REAL_TYPE
);
11964 TYPE_PRECISION (float_type_node
) = FLOAT_TYPE_SIZE
;
11965 layout_type (float_type_node
);
11966 pushdecl (build_decl (TYPE_DECL
, get_identifier ("float"),
11969 double_type_node
= make_node (REAL_TYPE
);
11970 TYPE_PRECISION (double_type_node
) = DOUBLE_TYPE_SIZE
;
11971 layout_type (double_type_node
);
11972 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double"),
11973 double_type_node
));
11975 long_double_type_node
= make_node (REAL_TYPE
);
11976 TYPE_PRECISION (long_double_type_node
) = LONG_DOUBLE_TYPE_SIZE
;
11977 layout_type (long_double_type_node
);
11978 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long double"),
11979 long_double_type_node
));
11981 complex_integer_type_node
= ffecom_make_complex_type_ (integer_type_node
);
11982 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex int"),
11983 complex_integer_type_node
));
11985 complex_float_type_node
= ffecom_make_complex_type_ (float_type_node
);
11986 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex float"),
11987 complex_float_type_node
));
11989 complex_double_type_node
= ffecom_make_complex_type_ (double_type_node
);
11990 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex double"),
11991 complex_double_type_node
));
11993 complex_long_double_type_node
= ffecom_make_complex_type_ (long_double_type_node
);
11994 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex long double"),
11995 complex_long_double_type_node
));
11997 integer_zero_node
= build_int_2 (0, 0);
11998 TREE_TYPE (integer_zero_node
) = integer_type_node
;
11999 integer_one_node
= build_int_2 (1, 0);
12000 TREE_TYPE (integer_one_node
) = integer_type_node
;
12002 size_zero_node
= build_int_2 (0, 0);
12003 TREE_TYPE (size_zero_node
) = sizetype
;
12004 size_one_node
= build_int_2 (1, 0);
12005 TREE_TYPE (size_one_node
) = sizetype
;
12007 void_type_node
= make_node (VOID_TYPE
);
12008 pushdecl (build_decl (TYPE_DECL
, get_identifier ("void"),
12010 layout_type (void_type_node
); /* Uses integer_zero_node */
12011 /* We are not going to have real types in C with less than byte alignment,
12012 so we might as well not have any types that claim to have it. */
12013 TYPE_ALIGN (void_type_node
) = BITS_PER_UNIT
;
12015 null_pointer_node
= build_int_2 (0, 0);
12016 TREE_TYPE (null_pointer_node
) = build_pointer_type (void_type_node
);
12017 layout_type (TREE_TYPE (null_pointer_node
));
12019 string_type_node
= build_pointer_type (char_type_node
);
12021 ffecom_tree_fun_type_void
12022 = build_function_type (void_type_node
, NULL_TREE
);
12024 ffecom_tree_ptr_to_fun_type_void
12025 = build_pointer_type (ffecom_tree_fun_type_void
);
12027 endlink
= tree_cons (NULL_TREE
, void_type_node
, NULL_TREE
);
12030 = build_function_type (float_type_node
,
12031 tree_cons (NULL_TREE
, float_type_node
, endlink
));
12033 double_ftype_double
12034 = build_function_type (double_type_node
,
12035 tree_cons (NULL_TREE
, double_type_node
, endlink
));
12037 ldouble_ftype_ldouble
12038 = build_function_type (long_double_type_node
,
12039 tree_cons (NULL_TREE
, long_double_type_node
,
12042 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
12043 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
12045 ffecom_tree_type
[i
][j
] = NULL_TREE
;
12046 ffecom_tree_fun_type
[i
][j
] = NULL_TREE
;
12047 ffecom_tree_ptr_to_fun_type
[i
][j
] = NULL_TREE
;
12048 ffecom_f2c_typecode_
[i
][j
] = -1;
12051 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
12052 to size FLOAT_TYPE_SIZE because they have to be the same size as
12053 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
12054 Compiler options and other such stuff that change the ways these
12055 types are set should not affect this particular setup. */
12057 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
]
12058 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
12059 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer"),
12061 type
= ffetype_new ();
12063 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER1
,
12065 ffetype_set_ams (type
,
12066 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12067 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12068 ffetype_set_star (base_type
,
12069 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12071 ffetype_set_kind (base_type
, 1, type
);
12072 assert (ffetype_size (type
) == sizeof (ffetargetInteger1
));
12074 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER1
]
12075 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
); /* HOLLERITH means unsigned. */
12076 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned"),
12079 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER2
]
12080 = t
= make_signed_type (CHAR_TYPE_SIZE
);
12081 pushdecl (build_decl (TYPE_DECL
, get_identifier ("byte"),
12083 type
= ffetype_new ();
12084 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER2
,
12086 ffetype_set_ams (type
,
12087 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12088 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12089 ffetype_set_star (base_type
,
12090 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12092 ffetype_set_kind (base_type
, 3, type
);
12093 assert (ffetype_size (type
) == sizeof (ffetargetInteger2
));
12095 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER2
]
12096 = t
= make_unsigned_type (CHAR_TYPE_SIZE
);
12097 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned byte"),
12100 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER3
]
12101 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
12102 pushdecl (build_decl (TYPE_DECL
, get_identifier ("word"),
12104 type
= ffetype_new ();
12105 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER3
,
12107 ffetype_set_ams (type
,
12108 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12109 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12110 ffetype_set_star (base_type
,
12111 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12113 ffetype_set_kind (base_type
, 6, type
);
12114 assert (ffetype_size (type
) == sizeof (ffetargetInteger3
));
12116 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER3
]
12117 = t
= make_unsigned_type (CHAR_TYPE_SIZE
* 2);
12118 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned word"),
12121 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER4
]
12122 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
12123 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer4"),
12125 type
= ffetype_new ();
12126 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER4
,
12128 ffetype_set_ams (type
,
12129 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12130 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12131 ffetype_set_star (base_type
,
12132 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12134 ffetype_set_kind (base_type
, 2, type
);
12135 assert (ffetype_size (type
) == sizeof (ffetargetInteger4
));
12137 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER4
]
12138 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
* 2);
12139 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned4"),
12143 if (ffe_is_do_internal_checks ()
12144 && LONG_TYPE_SIZE
!= FLOAT_TYPE_SIZE
12145 && LONG_TYPE_SIZE
!= CHAR_TYPE_SIZE
12146 && LONG_TYPE_SIZE
!= SHORT_TYPE_SIZE
12147 && LONG_TYPE_SIZE
!= LONG_LONG_TYPE_SIZE
)
12149 fprintf (stderr
, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
12154 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL1
]
12155 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
12156 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical"),
12158 type
= ffetype_new ();
12160 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL1
,
12162 ffetype_set_ams (type
,
12163 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12164 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12165 ffetype_set_star (base_type
,
12166 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12168 ffetype_set_kind (base_type
, 1, type
);
12169 assert (ffetype_size (type
) == sizeof (ffetargetLogical1
));
12171 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL2
]
12172 = t
= make_signed_type (CHAR_TYPE_SIZE
);
12173 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical2"),
12175 type
= ffetype_new ();
12176 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL2
,
12178 ffetype_set_ams (type
,
12179 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12180 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12181 ffetype_set_star (base_type
,
12182 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12184 ffetype_set_kind (base_type
, 3, type
);
12185 assert (ffetype_size (type
) == sizeof (ffetargetLogical2
));
12187 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL3
]
12188 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
12189 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical3"),
12191 type
= ffetype_new ();
12192 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL3
,
12194 ffetype_set_ams (type
,
12195 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12196 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12197 ffetype_set_star (base_type
,
12198 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12200 ffetype_set_kind (base_type
, 6, type
);
12201 assert (ffetype_size (type
) == sizeof (ffetargetLogical3
));
12203 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL4
]
12204 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
12205 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical4"),
12207 type
= ffetype_new ();
12208 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL4
,
12210 ffetype_set_ams (type
,
12211 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12212 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12213 ffetype_set_star (base_type
,
12214 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12216 ffetype_set_kind (base_type
, 2, type
);
12217 assert (ffetype_size (type
) == sizeof (ffetargetLogical4
));
12219 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
12220 = t
= make_node (REAL_TYPE
);
12221 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
;
12222 pushdecl (build_decl (TYPE_DECL
, get_identifier ("real"),
12225 type
= ffetype_new ();
12227 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREAL1
,
12229 ffetype_set_ams (type
,
12230 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12231 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12232 ffetype_set_star (base_type
,
12233 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12235 ffetype_set_kind (base_type
, 1, type
);
12236 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
12237 = FFETARGET_f2cTYREAL
;
12238 assert (ffetype_size (type
) == sizeof (ffetargetReal1
));
12240 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREALDOUBLE
]
12241 = t
= make_node (REAL_TYPE
);
12242 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
* 2; /* Always twice REAL. */
12243 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double precision"),
12246 type
= ffetype_new ();
12247 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREALDOUBLE
,
12249 ffetype_set_ams (type
,
12250 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12251 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12252 ffetype_set_star (base_type
,
12253 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12255 ffetype_set_kind (base_type
, 2, type
);
12256 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]
12257 = FFETARGET_f2cTYDREAL
;
12258 assert (ffetype_size (type
) == sizeof (ffetargetReal2
));
12260 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
12261 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]);
12262 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex"),
12264 type
= ffetype_new ();
12266 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREAL1
,
12268 ffetype_set_ams (type
,
12269 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12270 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12271 ffetype_set_star (base_type
,
12272 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12274 ffetype_set_kind (base_type
, 1, type
);
12275 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
12276 = FFETARGET_f2cTYCOMPLEX
;
12277 assert (ffetype_size (type
) == sizeof (ffetargetComplex1
));
12279 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREALDOUBLE
]
12280 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]);
12281 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double complex"),
12283 type
= ffetype_new ();
12284 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREALDOUBLE
,
12286 ffetype_set_ams (type
,
12287 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12288 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12289 ffetype_set_star (base_type
,
12290 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12292 ffetype_set_kind (base_type
, 2,
12294 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL2
]
12295 = FFETARGET_f2cTYDCOMPLEX
;
12296 assert (ffetype_size (type
) == sizeof (ffetargetComplex2
));
12298 /* Make function and ptr-to-function types for non-CHARACTER types. */
12300 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
12301 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
12303 if ((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
12305 if (i
== FFEINFO_basictypeINTEGER
)
12307 /* Figure out the smallest INTEGER type that can hold
12308 a pointer on this machine. */
12309 if (GET_MODE_SIZE (TYPE_MODE (t
))
12310 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
12312 if ((ffecom_pointer_kind_
== FFEINFO_kindtypeNONE
)
12313 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type
[i
][ffecom_pointer_kind_
]))
12314 > GET_MODE_SIZE (TYPE_MODE (t
))))
12315 ffecom_pointer_kind_
= j
;
12318 else if (i
== FFEINFO_basictypeCOMPLEX
)
12319 t
= void_type_node
;
12320 /* For f2c compatibility, REAL functions are really
12321 implemented as DOUBLE PRECISION. */
12322 else if ((i
== FFEINFO_basictypeREAL
)
12323 && (j
== FFEINFO_kindtypeREAL1
))
12324 t
= ffecom_tree_type
12325 [FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
];
12327 t
= ffecom_tree_fun_type
[i
][j
] = build_function_type (t
,
12329 ffecom_tree_ptr_to_fun_type
[i
][j
] = build_pointer_type (t
);
12333 /* Set up pointer types. */
12335 if (ffecom_pointer_kind_
== FFEINFO_basictypeNONE
)
12336 fatal ("no INTEGER type can hold a pointer on this configuration");
12337 else if (0 && ffe_is_do_internal_checks ())
12338 fprintf (stderr
, "Pointer type kt=%d\n", ffecom_pointer_kind_
);
12339 type
= ffetype_new ();
12340 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER
,
12341 FFEINFO_kindtypeINTEGERDEFAULT
),
12344 if (ffe_is_ugly_assign ())
12345 ffecom_label_kind_
= ffecom_pointer_kind_
; /* Require ASSIGN etc to this. */
12347 ffecom_label_kind_
= FFEINFO_kindtypeINTEGERDEFAULT
;
12348 if (0 && ffe_is_do_internal_checks ())
12349 fprintf (stderr
, "Label type kt=%d\n", ffecom_label_kind_
);
12351 ffecom_integer_type_node
12352 = ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
];
12353 ffecom_integer_zero_node
= convert (ffecom_integer_type_node
,
12354 integer_zero_node
);
12355 ffecom_integer_one_node
= convert (ffecom_integer_type_node
,
12358 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
12359 Turns out that by TYLONG, runtime/libI77/lio.h really means
12360 "whatever size an ftnint is". For consistency and sanity,
12361 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
12362 all are INTEGER, which we also make out of whatever back-end
12363 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
12364 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
12365 accommodate machines like the Alpha. Note that this suggests
12366 f2c and libf2c are missing a distinction perhaps needed on
12367 some machines between "int" and "long int". -- burley 0.5.5 950215 */
12369 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, FLOAT_TYPE_SIZE
,
12370 FFETARGET_f2cTYLONG
);
12371 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, SHORT_TYPE_SIZE
,
12372 FFETARGET_f2cTYSHORT
);
12373 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, CHAR_TYPE_SIZE
,
12374 FFETARGET_f2cTYINT1
);
12375 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, LONG_LONG_TYPE_SIZE
,
12376 FFETARGET_f2cTYQUAD
);
12377 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, FLOAT_TYPE_SIZE
,
12378 FFETARGET_f2cTYLOGICAL
);
12379 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, SHORT_TYPE_SIZE
,
12380 FFETARGET_f2cTYLOGICAL2
);
12381 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, CHAR_TYPE_SIZE
,
12382 FFETARGET_f2cTYLOGICAL1
);
12383 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, LONG_LONG_TYPE_SIZE
,
12384 FFETARGET_f2cTYQUAD
/* ~~~ */);
12386 /* CHARACTER stuff is all special-cased, so it is not handled in the above
12387 loop. CHARACTER items are built as arrays of unsigned char. */
12389 ffecom_tree_type
[FFEINFO_basictypeCHARACTER
]
12390 [FFEINFO_kindtypeCHARACTER1
] = t
= char_type_node
;
12391 type
= ffetype_new ();
12393 ffeinfo_set_type (FFEINFO_basictypeCHARACTER
,
12394 FFEINFO_kindtypeCHARACTER1
,
12396 ffetype_set_ams (type
,
12397 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12398 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12399 ffetype_set_kind (base_type
, 1, type
);
12400 assert (ffetype_size (type
)
12401 == sizeof (((ffetargetCharacter1
) { 0, NULL
}).text
[0]));
12403 ffecom_tree_fun_type
[FFEINFO_basictypeCHARACTER
]
12404 [FFEINFO_kindtypeCHARACTER1
] = ffecom_tree_fun_type_void
;
12405 ffecom_tree_ptr_to_fun_type
[FFEINFO_basictypeCHARACTER
]
12406 [FFEINFO_kindtypeCHARACTER1
]
12407 = ffecom_tree_ptr_to_fun_type_void
;
12408 ffecom_f2c_typecode_
[FFEINFO_basictypeCHARACTER
][FFEINFO_kindtypeCHARACTER1
]
12409 = FFETARGET_f2cTYCHAR
;
12411 ffecom_f2c_typecode_
[FFEINFO_basictypeANY
][FFEINFO_kindtypeANY
]
12414 /* Make multi-return-value type and fields. */
12416 ffecom_multi_type_node_
= make_node (UNION_TYPE
);
12420 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
12421 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
12425 if (ffecom_tree_type
[i
][j
] == NULL_TREE
)
12426 continue; /* Not supported. */
12427 sprintf (&name
[0], "bt_%s_kt_%s",
12428 ffeinfo_basictype_string ((ffeinfoBasictype
) i
),
12429 ffeinfo_kindtype_string ((ffeinfoKindtype
) j
));
12430 ffecom_multi_fields_
[i
][j
] = build_decl (FIELD_DECL
,
12431 get_identifier (name
),
12432 ffecom_tree_type
[i
][j
]);
12433 DECL_CONTEXT (ffecom_multi_fields_
[i
][j
])
12434 = ffecom_multi_type_node_
;
12435 DECL_FRAME_SIZE (ffecom_multi_fields_
[i
][j
]) = 0;
12436 TREE_CHAIN (ffecom_multi_fields_
[i
][j
]) = field
;
12437 field
= ffecom_multi_fields_
[i
][j
];
12440 TYPE_FIELDS (ffecom_multi_type_node_
) = field
;
12441 layout_type (ffecom_multi_type_node_
);
12443 /* Subroutines usually return integer because they might have alternate
12446 ffecom_tree_subr_type
12447 = build_function_type (integer_type_node
, NULL_TREE
);
12448 ffecom_tree_ptr_to_subr_type
12449 = build_pointer_type (ffecom_tree_subr_type
);
12450 ffecom_tree_blockdata_type
12451 = build_function_type (void_type_node
, NULL_TREE
);
12453 builtin_function ("__builtin_sqrtf", float_ftype_float
,
12454 BUILT_IN_FSQRT
, "sqrtf");
12455 builtin_function ("__builtin_fsqrt", double_ftype_double
,
12456 BUILT_IN_FSQRT
, "sqrt");
12457 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble
,
12458 BUILT_IN_FSQRT
, "sqrtl");
12459 builtin_function ("__builtin_sinf", float_ftype_float
,
12460 BUILT_IN_SIN
, "sinf");
12461 builtin_function ("__builtin_sin", double_ftype_double
,
12462 BUILT_IN_SIN
, "sin");
12463 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble
,
12464 BUILT_IN_SIN
, "sinl");
12465 builtin_function ("__builtin_cosf", float_ftype_float
,
12466 BUILT_IN_COS
, "cosf");
12467 builtin_function ("__builtin_cos", double_ftype_double
,
12468 BUILT_IN_COS
, "cos");
12469 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble
,
12470 BUILT_IN_COS
, "cosl");
12473 pedantic_lvalues
= FALSE
;
12476 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node
,
12479 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node
,
12482 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node
,
12485 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node
,
12486 FFECOM_f2cDOUBLEREAL
,
12488 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node
,
12491 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node
,
12492 FFECOM_f2cDOUBLECOMPLEX
,
12494 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node
,
12497 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node
,
12500 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node
,
12503 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node
,
12506 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node
,
12510 ffecom_f2c_ftnlen_zero_node
12511 = convert (ffecom_f2c_ftnlen_type_node
, integer_zero_node
);
12513 ffecom_f2c_ftnlen_one_node
12514 = convert (ffecom_f2c_ftnlen_type_node
, integer_one_node
);
12516 ffecom_f2c_ftnlen_two_node
= build_int_2 (2, 0);
12517 TREE_TYPE (ffecom_f2c_ftnlen_two_node
) = ffecom_integer_type_node
;
12519 ffecom_f2c_ptr_to_ftnlen_type_node
12520 = build_pointer_type (ffecom_f2c_ftnlen_type_node
);
12522 ffecom_f2c_ptr_to_ftnint_type_node
12523 = build_pointer_type (ffecom_f2c_ftnint_type_node
);
12525 ffecom_f2c_ptr_to_integer_type_node
12526 = build_pointer_type (ffecom_f2c_integer_type_node
);
12528 ffecom_f2c_ptr_to_real_type_node
12529 = build_pointer_type (ffecom_f2c_real_type_node
);
12531 ffecom_float_zero_
= build_real (float_type_node
, dconst0
);
12532 ffecom_double_zero_
= build_real (double_type_node
, dconst0
);
12534 REAL_VALUE_TYPE point_5
;
12536 #ifdef REAL_ARITHMETIC
12537 REAL_ARITHMETIC (point_5
, RDIV_EXPR
, dconst1
, dconst2
);
12541 ffecom_float_half_
= build_real (float_type_node
, point_5
);
12542 ffecom_double_half_
= build_real (double_type_node
, point_5
);
12545 /* Do "extern int xargc;". */
12547 ffecom_tree_xargc_
= build_decl (VAR_DECL
,
12548 get_identifier ("f__xargc"),
12549 integer_type_node
);
12550 DECL_EXTERNAL (ffecom_tree_xargc_
) = 1;
12551 TREE_STATIC (ffecom_tree_xargc_
) = 1;
12552 TREE_PUBLIC (ffecom_tree_xargc_
) = 1;
12553 ffecom_tree_xargc_
= start_decl (ffecom_tree_xargc_
, FALSE
);
12554 finish_decl (ffecom_tree_xargc_
, NULL_TREE
, FALSE
);
12556 #if 0 /* This is being fixed, and seems to be working now. */
12557 if ((FLOAT_TYPE_SIZE
!= 32)
12558 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))) != 32))
12560 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12561 (int) FLOAT_TYPE_SIZE
);
12562 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12563 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))));
12564 warning ("properly unless they all are 32 bits wide.");
12565 warning ("Please keep this in mind before you report bugs. g77 should");
12566 warning ("support non-32-bit machines better as of version 0.6.");
12570 #if 0 /* Code in ste.c that would crash has been commented out. */
12571 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
12572 < TYPE_PRECISION (string_type_node
))
12573 /* I/O will probably crash. */
12574 warning ("configuration: char * holds %d bits, but ftnlen only %d",
12575 TYPE_PRECISION (string_type_node
),
12576 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
));
12579 #if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
12580 if (TYPE_PRECISION (ffecom_integer_type_node
)
12581 < TYPE_PRECISION (string_type_node
))
12582 /* ASSIGN 10 TO I will crash. */
12583 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12584 ASSIGN statement might fail",
12585 TYPE_PRECISION (string_type_node
),
12586 TYPE_PRECISION (ffecom_integer_type_node
));
12591 /* ffecom_init_2 -- Initialize
12593 ffecom_init_2(); */
12595 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12599 assert (ffecom_outer_function_decl_
== NULL_TREE
);
12600 assert (current_function_decl
== NULL_TREE
);
12601 assert (ffecom_which_entrypoint_decl_
== NULL_TREE
);
12603 ffecom_master_arglist_
= NULL
;
12605 ffecom_latest_temp_
= NULL
;
12606 ffecom_primary_entry_
= NULL
;
12607 ffecom_is_altreturning_
= FALSE
;
12608 ffecom_func_result_
= NULL_TREE
;
12609 ffecom_multi_retval_
= NULL_TREE
;
12613 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12616 ffebld expr; // FFE opITEM list.
12617 tree = ffecom_list_expr(expr);
12619 List of actual args is transformed into corresponding gcc backend list. */
12621 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12623 ffecom_list_expr (ffebld expr
)
12626 tree
*plist
= &list
;
12627 tree trail
= NULL_TREE
; /* Append char length args here. */
12628 tree
*ptrail
= &trail
;
12631 while (expr
!= NULL
)
12634 = build_tree_list (NULL_TREE
, ffecom_arg_expr (ffebld_head (expr
),
12636 plist
= &TREE_CHAIN (*plist
);
12637 expr
= ffebld_trail (expr
);
12638 if (length
!= NULL_TREE
)
12640 *ptrail
= build_tree_list (NULL_TREE
, length
);
12641 ptrail
= &TREE_CHAIN (*ptrail
);
12651 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12654 ffebld expr; // FFE opITEM list.
12655 tree = ffecom_list_ptr_to_expr(expr);
12657 List of actual args is transformed into corresponding gcc backend list for
12658 use in calling an external procedure (vs. a statement function). */
12660 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12662 ffecom_list_ptr_to_expr (ffebld expr
)
12665 tree
*plist
= &list
;
12666 tree trail
= NULL_TREE
; /* Append char length args here. */
12667 tree
*ptrail
= &trail
;
12670 while (expr
!= NULL
)
12673 = build_tree_list (NULL_TREE
,
12674 ffecom_arg_ptr_to_expr (ffebld_head (expr
),
12676 plist
= &TREE_CHAIN (*plist
);
12677 expr
= ffebld_trail (expr
);
12678 if (length
!= NULL_TREE
)
12680 *ptrail
= build_tree_list (NULL_TREE
, length
);
12681 ptrail
= &TREE_CHAIN (*ptrail
);
12691 /* Obtain gcc's LABEL_DECL tree for label. */
12693 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12695 ffecom_lookup_label (ffelab label
)
12699 if (ffelab_hook (label
) == NULL_TREE
)
12701 char labelname
[16];
12703 switch (ffelab_type (label
))
12705 case FFELAB_typeLOOPEND
:
12706 case FFELAB_typeNOTLOOP
:
12707 case FFELAB_typeENDIF
:
12708 sprintf (labelname
, "%" ffelabValue_f
"u", ffelab_value (label
));
12709 glabel
= build_decl (LABEL_DECL
, get_identifier (labelname
),
12711 DECL_CONTEXT (glabel
) = current_function_decl
;
12712 DECL_MODE (glabel
) = VOIDmode
;
12715 case FFELAB_typeFORMAT
:
12716 push_obstacks_nochange ();
12717 end_temporary_allocation ();
12719 glabel
= build_decl (VAR_DECL
,
12720 ffecom_get_invented_identifier
12721 ("__g77_format_%d", NULL
,
12722 (int) ffelab_value (label
)),
12723 build_type_variant (build_array_type
12727 TREE_CONSTANT (glabel
) = 1;
12728 TREE_STATIC (glabel
) = 1;
12729 DECL_CONTEXT (glabel
) = 0;
12730 DECL_INITIAL (glabel
) = NULL
;
12731 make_decl_rtl (glabel
, NULL
, 0);
12732 expand_decl (glabel
);
12734 resume_temporary_allocation ();
12739 case FFELAB_typeANY
:
12740 glabel
= error_mark_node
;
12744 assert ("bad label type" == NULL
);
12748 ffelab_set_hook (label
, glabel
);
12752 glabel
= ffelab_hook (label
);
12759 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12760 a single source specification (as in the fourth argument of MVBITS).
12761 If the type is NULL_TREE, the type of lhs is used to make the type of
12762 the MODIFY_EXPR. */
12764 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12766 ffecom_modify (tree newtype
, tree lhs
,
12769 if (lhs
== error_mark_node
|| rhs
== error_mark_node
)
12770 return error_mark_node
;
12772 if (newtype
== NULL_TREE
)
12773 newtype
= TREE_TYPE (lhs
);
12775 if (TREE_SIDE_EFFECTS (lhs
))
12776 lhs
= stabilize_reference (lhs
);
12778 return ffecom_2s (MODIFY_EXPR
, newtype
, lhs
, rhs
);
12783 /* Register source file name. */
12786 ffecom_file (char *name
)
12788 #if FFECOM_GCC_INCLUDE
12789 ffecom_file_ (name
);
12793 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12796 ffecom_notify_init_storage(st);
12798 Gets called when all possible units in an aggregate storage area (a LOCAL
12799 with equivalences or a COMMON) have been initialized. The initialization
12800 info either is in ffestorag_init or, if that is NULL,
12801 ffestorag_accretion:
12803 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12804 even for an array if the array is one element in length!
12806 ffestorag_accretion will contain an opACCTER. It is much like an
12807 opARRTER except it has an ffebit object in it instead of just a size.
12808 The back end can use the info in the ffebit object, if it wants, to
12809 reduce the amount of actual initialization, but in any case it should
12810 kill the ffebit object when done. Also, set accretion to NULL but
12811 init to a non-NULL value.
12813 After performing initialization, DO NOT set init to NULL, because that'll
12814 tell the front end it is ok for more initialization to happen. Instead,
12815 set init to an opANY expression or some such thing that you can use to
12816 tell that you've already initialized the object.
12819 Support two-pass FFE. */
12822 ffecom_notify_init_storage (ffestorag st
)
12824 ffebld init
; /* The initialization expression. */
12825 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12826 ffetargetOffset size
; /* The size of the entity. */
12829 if (ffestorag_init (st
) == NULL
)
12831 init
= ffestorag_accretion (st
);
12832 assert (init
!= NULL
);
12833 ffestorag_set_accretion (st
, NULL
);
12834 ffestorag_set_accretes (st
, 0);
12836 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12837 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12838 size
= ffebld_accter_size (init
);
12839 ffebit_kill (ffebld_accter_bits (init
));
12840 ffebld_set_op (init
, FFEBLD_opARRTER
);
12841 ffebld_set_arrter (init
, ffebld_accter (init
));
12842 ffebld_arrter_set_size (init
, size
);
12846 ffestorag_set_init (st
, init
);
12851 init
= ffestorag_init (st
);
12854 #if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
12855 ffestorag_set_init (st
, ffebld_new_any ());
12857 if (ffebld_op (init
) == FFEBLD_opANY
)
12858 return; /* Oh, we already did this! */
12860 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12864 if (ffestorag_symbol (st
) != NULL
)
12865 s
= ffestorag_symbol (st
);
12867 s
= ffestorag_typesymbol (st
);
12869 fprintf (dmpout
, "= initialize_storage \"%s\" ",
12870 (s
!= NULL
) ? ffesymbol_text (s
) : "(unnamed)");
12871 ffebld_dump (init
);
12872 fputc ('\n', dmpout
);
12876 #endif /* if FFECOM_ONEPASS */
12879 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12882 ffecom_notify_init_symbol(s);
12884 Gets called when all possible units in a symbol (not placed in COMMON
12885 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12886 have been initialized. The initialization info either is in
12887 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12889 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12890 even for an array if the array is one element in length!
12892 ffesymbol_accretion will contain an opACCTER. It is much like an
12893 opARRTER except it has an ffebit object in it instead of just a size.
12894 The back end can use the info in the ffebit object, if it wants, to
12895 reduce the amount of actual initialization, but in any case it should
12896 kill the ffebit object when done. Also, set accretion to NULL but
12897 init to a non-NULL value.
12899 After performing initialization, DO NOT set init to NULL, because that'll
12900 tell the front end it is ok for more initialization to happen. Instead,
12901 set init to an opANY expression or some such thing that you can use to
12902 tell that you've already initialized the object.
12905 Support two-pass FFE. */
12908 ffecom_notify_init_symbol (ffesymbol s
)
12910 ffebld init
; /* The initialization expression. */
12911 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12912 ffetargetOffset size
; /* The size of the entity. */
12915 if (ffesymbol_storage (s
) == NULL
)
12916 return; /* Do nothing until COMMON/EQUIVALENCE
12917 possibilities checked. */
12919 if ((ffesymbol_init (s
) == NULL
)
12920 && ((init
= ffesymbol_accretion (s
)) != NULL
))
12922 ffesymbol_set_accretion (s
, NULL
);
12923 ffesymbol_set_accretes (s
, 0);
12925 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12926 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12927 size
= ffebld_accter_size (init
);
12928 ffebit_kill (ffebld_accter_bits (init
));
12929 ffebld_set_op (init
, FFEBLD_opARRTER
);
12930 ffebld_set_arrter (init
, ffebld_accter (init
));
12931 ffebld_arrter_set_size (init
, size
);
12935 ffesymbol_set_init (s
, init
);
12940 init
= ffesymbol_init (s
);
12944 ffesymbol_set_init (s
, ffebld_new_any ());
12946 if (ffebld_op (init
) == FFEBLD_opANY
)
12947 return; /* Oh, we already did this! */
12949 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12950 fprintf (dmpout
, "= initialize_symbol \"%s\" ", ffesymbol_text (s
));
12951 ffebld_dump (init
);
12952 fputc ('\n', dmpout
);
12955 #endif /* if FFECOM_ONEPASS */
12958 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12961 ffecom_notify_primary_entry(s);
12963 Gets called when implicit or explicit PROGRAM statement seen or when
12964 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12965 global symbol that serves as the entry point. */
12968 ffecom_notify_primary_entry (ffesymbol s
)
12970 ffecom_primary_entry_
= s
;
12971 ffecom_primary_entry_kind_
= ffesymbol_kind (s
);
12973 if ((ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
12974 || (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
))
12975 ffecom_primary_entry_is_proc_
= TRUE
;
12977 ffecom_primary_entry_is_proc_
= FALSE
;
12979 if (!ffe_is_silent ())
12981 if (ffecom_primary_entry_kind_
== FFEINFO_kindPROGRAM
)
12982 fprintf (stderr
, "%s:\n", ffesymbol_text (s
));
12984 fprintf (stderr
, " %s:\n", ffesymbol_text (s
));
12987 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12988 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
12993 for (list
= ffesymbol_dummyargs (s
);
12995 list
= ffebld_trail (list
))
12997 arg
= ffebld_head (list
);
12998 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
13000 ffecom_is_altreturning_
= TRUE
;
13009 ffecom_open_include (char *name
, ffewhereLine l
, ffewhereColumn c
)
13011 #if FFECOM_GCC_INCLUDE
13012 return ffecom_open_include_ (name
, l
, c
);
13014 return fopen (name
, "r");
13018 /* Clean up after making automatically popped call-arg temps.
13020 Call this in pairs with push_calltemps around calls to
13021 ffecom_arg_ptr_to_expr if the latter might use temporaries.
13022 Any temporaries made within the outermost sequence of
13023 push_calltemps and pop_calltemps, that are marked as "auto-pop"
13024 meaning they won't be explicitly popped (freed), are popped
13025 at this point so they can be reused later.
13027 NOTE: when called by ffecom_gen_sfuncdef_, ffecom_pending_calls_
13028 should come in == 1, and all of the in-use auto-pop temps
13029 should have DECL_CONTEXT (temp->t) == current_function_decl.
13030 Moreover, these temps should _never_ be re-used in future
13031 calls to ffecom_push_tempvar -- since current_function_decl will
13032 never be the same again.
13034 SO, it could be a minor win in terms of compile time to just
13035 strip these temps off the list. That is, if the above assumptions
13036 are correct, just remove from the list of temps any temp
13037 that is both in-use and has DECL_CONTEXT (temp->t)
13038 == current_function_decl, when called from ffecom_gen_sfuncdef_. */
13040 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13042 ffecom_pop_calltemps ()
13046 assert (ffecom_pending_calls_
> 0);
13048 if (--ffecom_pending_calls_
== 0)
13049 for (temp
= ffecom_latest_temp_
; temp
!= NULL
; temp
= temp
->next
)
13050 if (temp
->auto_pop
)
13051 temp
->in_use
= FALSE
;
13055 /* Mark latest temp with given tree as no longer in use. */
13057 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13059 ffecom_pop_tempvar (tree t
)
13063 for (temp
= ffecom_latest_temp_
; temp
!= NULL
; temp
= temp
->next
)
13064 if (temp
->in_use
&& (temp
->t
== t
))
13066 assert (!temp
->auto_pop
);
13067 temp
->in_use
= FALSE
;
13071 assert (temp
->t
!= t
);
13073 assert ("couldn't ffecom_pop_tempvar!" != NULL
);
13077 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
13080 ffebld expr; // FFE expression.
13081 tree = ffecom_ptr_to_expr(expr);
13083 Like ffecom_expr, but sticks address-of in front of most things. */
13085 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13087 ffecom_ptr_to_expr (ffebld expr
)
13090 ffeinfoBasictype bt
;
13091 ffeinfoKindtype kt
;
13094 assert (expr
!= NULL
);
13096 switch (ffebld_op (expr
))
13098 case FFEBLD_opSYMTER
:
13099 s
= ffebld_symter (expr
);
13100 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
13104 ix
= ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr
));
13105 assert (ix
!= FFECOM_gfrt
);
13106 if ((item
= ffecom_gfrt_
[ix
]) == NULL_TREE
)
13108 ffecom_make_gfrt_ (ix
);
13109 item
= ffecom_gfrt_
[ix
];
13114 item
= ffesymbol_hook (s
).decl_tree
;
13115 if (item
== NULL_TREE
)
13117 s
= ffecom_sym_transform_ (s
);
13118 item
= ffesymbol_hook (s
).decl_tree
;
13121 assert (item
!= NULL
);
13122 if (item
== error_mark_node
)
13124 if (!ffesymbol_hook (s
).addr
)
13125 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
13129 case FFEBLD_opARRAYREF
:
13131 ffebld dims
[FFECOM_dimensionsMAX
];
13135 item
= ffecom_ptr_to_expr (ffebld_left (expr
));
13137 if (item
== error_mark_node
)
13140 if ((ffeinfo_where (ffebld_info (expr
)) == FFEINFO_whereFLEETING
)
13141 && !mark_addressable (item
))
13142 return error_mark_node
; /* Make sure non-const ref is to
13145 /* Build up ARRAY_REFs in reverse order (since we're column major
13146 here in Fortran land). */
13148 for (i
= 0, expr
= ffebld_right (expr
);
13150 expr
= ffebld_trail (expr
))
13151 dims
[i
++] = ffebld_head (expr
);
13153 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
13155 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
13157 /* The initial subtraction should happen in the original type so
13158 that (possible) negative values are handled appropriately. */
13160 = ffecom_2 (PLUS_EXPR
,
13161 build_pointer_type (TREE_TYPE (array
)),
13163 size_binop (MULT_EXPR
,
13164 size_in_bytes (TREE_TYPE (array
)),
13166 fold (build (MINUS_EXPR
,
13167 TREE_TYPE (TYPE_MIN_VALUE (TYPE_DOMAIN (array
))),
13168 ffecom_expr (dims
[i
]),
13169 TYPE_MIN_VALUE (TYPE_DOMAIN (array
)))))));
13174 case FFEBLD_opCONTER
:
13176 bt
= ffeinfo_basictype (ffebld_info (expr
));
13177 kt
= ffeinfo_kindtype (ffebld_info (expr
));
13179 item
= ffecom_constantunion (&ffebld_constant_union
13180 (ffebld_conter (expr
)), bt
, kt
,
13181 ffecom_tree_type
[bt
][kt
]);
13182 if (item
== error_mark_node
)
13183 return error_mark_node
;
13184 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
13189 return error_mark_node
;
13192 assert (ffecom_pending_calls_
> 0);
13194 bt
= ffeinfo_basictype (ffebld_info (expr
));
13195 kt
= ffeinfo_kindtype (ffebld_info (expr
));
13197 item
= ffecom_expr (expr
);
13198 if (item
== error_mark_node
)
13199 return error_mark_node
;
13201 /* The back end currently optimizes a bit too zealously for us, in that
13202 we fail JCB001 if the following block of code is omitted. It checks
13203 to see if the transformed expression is a symbol or array reference,
13204 and encloses it in a SAVE_EXPR if that is the case. */
13207 if ((TREE_CODE (item
) == VAR_DECL
)
13208 || (TREE_CODE (item
) == PARM_DECL
)
13209 || (TREE_CODE (item
) == RESULT_DECL
)
13210 || (TREE_CODE (item
) == INDIRECT_REF
)
13211 || (TREE_CODE (item
) == ARRAY_REF
)
13212 || (TREE_CODE (item
) == COMPONENT_REF
)
13214 || (TREE_CODE (item
) == OFFSET_REF
)
13216 || (TREE_CODE (item
) == BUFFER_REF
)
13217 || (TREE_CODE (item
) == REALPART_EXPR
)
13218 || (TREE_CODE (item
) == IMAGPART_EXPR
))
13220 item
= ffecom_save_tree (item
);
13223 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
13228 assert ("fall-through error" == NULL
);
13229 return error_mark_node
;
13233 /* Prepare to make call-arg temps.
13235 Call this in pairs with pop_calltemps around calls to
13236 ffecom_arg_ptr_to_expr if the latter might use temporaries. */
13238 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13240 ffecom_push_calltemps ()
13242 ffecom_pending_calls_
++;
13246 /* Obtain a temp var with given data type.
13248 Returns a VAR_DECL tree of a currently (that is, at the current
13249 statement being compiled) not in use and having the given data type,
13250 making a new one if necessary. size is FFETARGET_charactersizeNONE
13251 for a non-CHARACTER type or >= 0 for a CHARACTER type. elements is
13252 -1 for a scalar or > 0 for an array of type. auto_pop is TRUE if
13253 ffecom_pop_tempvar won't be called, meaning temp will be freed
13254 when #pending calls goes to zero. */
13256 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13258 ffecom_push_tempvar (tree type
, ffetargetCharacterSize size
, int elements
,
13264 static int mynumber
;
13266 assert (!auto_pop
|| (ffecom_pending_calls_
> 0));
13268 if (type
== error_mark_node
)
13269 return error_mark_node
;
13271 for (temp
= ffecom_latest_temp_
; temp
!= NULL
; temp
= temp
->next
)
13274 || (temp
->type
!= type
)
13275 || (temp
->size
!= size
)
13276 || (temp
->elements
!= elements
)
13277 || (DECL_CONTEXT (temp
->t
) != current_function_decl
))
13280 temp
->in_use
= TRUE
;
13281 temp
->auto_pop
= auto_pop
;
13285 /* Create a new temp. */
13287 yes
= suspend_momentary ();
13289 if (size
!= FFETARGET_charactersizeNONE
)
13290 type
= build_array_type (type
,
13291 build_range_type (ffecom_f2c_ftnlen_type_node
,
13292 ffecom_f2c_ftnlen_one_node
,
13293 build_int_2 (size
, 0)));
13294 if (elements
!= -1)
13295 type
= build_array_type (type
,
13296 build_range_type (integer_type_node
,
13298 build_int_2 (elements
- 1,
13300 t
= build_decl (VAR_DECL
,
13301 ffecom_get_invented_identifier ("__g77_expr_%d", NULL
,
13304 { /* ~~~~ kludge alert here!!! else temp gets reused outside
13305 a compound-statement sequence.... */
13306 extern tree sequence_rtl_expr
;
13307 tree back_end_bug
= sequence_rtl_expr
;
13309 sequence_rtl_expr
= NULL_TREE
;
13311 t
= start_decl (t
, FALSE
);
13312 finish_decl (t
, NULL_TREE
, FALSE
);
13314 sequence_rtl_expr
= back_end_bug
;
13317 resume_momentary (yes
);
13319 temp
= malloc_new_kp (ffe_pool_program_unit (), "ffecomTemp_",
13322 temp
->next
= ffecom_latest_temp_
;
13326 temp
->elements
= elements
;
13327 temp
->in_use
= TRUE
;
13328 temp
->auto_pop
= auto_pop
;
13330 ffecom_latest_temp_
= temp
;
13336 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13338 tree rtn; // NULL_TREE means use expand_null_return()
13339 ffebld expr; // NULL if no alt return expr to RETURN stmt
13340 rtn = ffecom_return_expr(expr);
13342 Based on the program unit type and other info (like return function
13343 type, return master function type when alternate ENTRY points,
13344 whether subroutine has any alternate RETURN points, etc), returns the
13345 appropriate expression to be returned to the caller, or NULL_TREE
13346 meaning no return value or the caller expects it to be returned somewhere
13347 else (which is handled by other parts of this module). */
13349 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13351 ffecom_return_expr (ffebld expr
)
13355 switch (ffecom_primary_entry_kind_
)
13357 case FFEINFO_kindPROGRAM
:
13358 case FFEINFO_kindBLOCKDATA
:
13362 case FFEINFO_kindSUBROUTINE
:
13363 if (!ffecom_is_altreturning_
)
13364 rtn
= NULL_TREE
; /* No alt returns, never an expr. */
13365 else if (expr
== NULL
)
13366 rtn
= integer_zero_node
;
13368 rtn
= ffecom_expr (expr
);
13371 case FFEINFO_kindFUNCTION
:
13372 if ((ffecom_multi_retval_
!= NULL_TREE
)
13373 || (ffesymbol_basictype (ffecom_primary_entry_
)
13374 == FFEINFO_basictypeCHARACTER
)
13375 || ((ffesymbol_basictype (ffecom_primary_entry_
)
13376 == FFEINFO_basictypeCOMPLEX
)
13377 && (ffecom_num_entrypoints_
== 0)
13378 && ffesymbol_is_f2c (ffecom_primary_entry_
)))
13379 { /* Value is returned by direct assignment
13380 into (implicit) dummy. */
13384 rtn
= ffecom_func_result_
;
13386 /* Spurious error if RETURN happens before first reference! So elide
13387 this code. In particular, for debugging registry, rtn should always
13388 be non-null after all, but TREE_USED won't be set until we encounter
13389 a reference in the code. Perfectly okay (but weird) code that,
13390 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13391 this diagnostic for no reason. Have people use -O -Wuninitialized
13392 and leave it to the back end to find obviously weird cases. */
13394 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13395 situation; if the return value has never been referenced, it won't
13396 have a tree under 2pass mode. */
13397 if ((rtn
== NULL_TREE
)
13398 || !TREE_USED (rtn
))
13400 ffebad_start (FFEBAD_RETURN_VALUE_UNSET
);
13401 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_
),
13402 ffesymbol_where_column (ffecom_primary_entry_
));
13403 ffebad_string (ffesymbol_text (ffesymbol_funcresult
13404 (ffecom_primary_entry_
)));
13411 assert ("bad unit kind" == NULL
);
13412 case FFEINFO_kindANY
:
13413 rtn
= error_mark_node
;
13421 /* Do save_expr only if tree is not error_mark_node. */
13423 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13425 ffecom_save_tree (tree t
)
13427 return save_expr (t
);
13431 /* Public entry point for front end to access start_decl. */
13433 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13435 ffecom_start_decl (tree decl
, bool is_initialized
)
13437 DECL_INITIAL (decl
) = is_initialized
? error_mark_node
: NULL_TREE
;
13438 return start_decl (decl
, FALSE
);
13442 /* ffecom_sym_commit -- Symbol's state being committed to reality
13445 ffecom_sym_commit(s);
13447 Does whatever the backend needs when a symbol is committed after having
13448 been backtrackable for a period of time. */
13450 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13452 ffecom_sym_commit (ffesymbol s UNUSED
)
13454 assert (!ffesymbol_retractable ());
13458 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13460 ffecom_sym_end_transition();
13462 Does backend-specific stuff and also calls ffest_sym_end_transition
13463 to do the necessary FFE stuff.
13465 Backtracking is never enabled when this fn is called, so don't worry
13469 ffecom_sym_end_transition (ffesymbol s
)
13473 assert (!ffesymbol_retractable ());
13475 s
= ffest_sym_end_transition (s
);
13477 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13478 if ((ffesymbol_kind (s
) == FFEINFO_kindBLOCKDATA
)
13479 && (ffesymbol_where (s
) == FFEINFO_whereGLOBAL
))
13481 ffecom_list_blockdata_
13482 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
13483 FFEINTRIN_specNONE
,
13484 FFEINTRIN_impNONE
),
13485 ffecom_list_blockdata_
);
13489 /* This is where we finally notice that a symbol has partial initialization
13490 and finalize it. */
13492 if (ffesymbol_accretion (s
) != NULL
)
13494 assert (ffesymbol_init (s
) == NULL
);
13495 ffecom_notify_init_symbol (s
);
13497 else if (((st
= ffesymbol_storage (s
)) != NULL
)
13498 && ((st
= ffestorag_parent (st
)) != NULL
)
13499 && (ffestorag_accretion (st
) != NULL
))
13501 assert (ffestorag_init (st
) == NULL
);
13502 ffecom_notify_init_storage (st
);
13505 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13506 if ((ffesymbol_kind (s
) == FFEINFO_kindCOMMON
)
13507 && (ffesymbol_where (s
) == FFEINFO_whereLOCAL
)
13508 && (ffesymbol_storage (s
) != NULL
))
13510 ffecom_list_common_
13511 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
13512 FFEINTRIN_specNONE
,
13513 FFEINTRIN_impNONE
),
13514 ffecom_list_common_
);
13521 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13523 ffecom_sym_exec_transition();
13525 Does backend-specific stuff and also calls ffest_sym_exec_transition
13526 to do the necessary FFE stuff.
13528 See the long-winded description in ffecom_sym_learned for info
13529 on handling the situation where backtracking is inhibited. */
13532 ffecom_sym_exec_transition (ffesymbol s
)
13534 s
= ffest_sym_exec_transition (s
);
13539 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13542 s = ffecom_sym_learned(s);
13544 Called when a new symbol is seen after the exec transition or when more
13545 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
13546 it arrives here is that all its latest info is updated already, so its
13547 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13548 field filled in if its gone through here or exec_transition first, and
13551 The backend probably wants to check ffesymbol_retractable() to see if
13552 backtracking is in effect. If so, the FFE's changes to the symbol may
13553 be retracted (undone) or committed (ratified), at which time the
13554 appropriate ffecom_sym_retract or _commit function will be called
13557 If the backend has its own backtracking mechanism, great, use it so that
13558 committal is a simple operation. Though it doesn't make much difference,
13559 I suppose: the reason for tentative symbol evolution in the FFE is to
13560 enable error detection in weird incorrect statements early and to disable
13561 incorrect error detection on a correct statement. The backend is not
13562 likely to introduce any information that'll get involved in these
13563 considerations, so it is probably just fine that the implementation
13564 model for this fn and for _exec_transition is to not do anything
13565 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13566 and instead wait until ffecom_sym_commit is called (which it never
13567 will be as long as we're using ambiguity-detecting statement analysis in
13568 the FFE, which we are initially to shake out the code, but don't depend
13569 on this), otherwise go ahead and do whatever is needed.
13571 In essence, then, when this fn and _exec_transition get called while
13572 backtracking is enabled, a general mechanism would be to flag which (or
13573 both) of these were called (and in what order? neat question as to what
13574 might happen that I'm too lame to think through right now) and then when
13575 _commit is called reproduce the original calling sequence, if any, for
13576 the two fns (at which point backtracking will, of course, be disabled). */
13579 ffecom_sym_learned (ffesymbol s
)
13581 ffestorag_exec_layout (s
);
13586 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13589 ffecom_sym_retract(s);
13591 Does whatever the backend needs when a symbol is retracted after having
13592 been backtrackable for a period of time. */
13594 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13596 ffecom_sym_retract (ffesymbol s UNUSED
)
13598 assert (!ffesymbol_retractable ());
13600 #if 0 /* GCC doesn't commit any backtrackable sins,
13601 so nothing needed here. */
13602 switch (ffesymbol_hook (s
).state
)
13604 case 0: /* nothing happened yet. */
13607 case 1: /* exec transition happened. */
13610 case 2: /* learned happened. */
13613 case 3: /* learned then exec. */
13616 case 4: /* exec then learned. */
13620 assert ("bad hook state" == NULL
);
13627 /* Create temporary gcc label. */
13629 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13631 ffecom_temp_label ()
13634 static int mynumber
= 0;
13636 glabel
= build_decl (LABEL_DECL
,
13637 ffecom_get_invented_identifier ("__g77_label_%d",
13641 DECL_CONTEXT (glabel
) = current_function_decl
;
13642 DECL_MODE (glabel
) = VOIDmode
;
13648 /* Return an expression that is usable as an arg in a conditional context
13649 (IF, DO WHILE, .NOT., and so on).
13651 Use the one provided for the back end as of >2.6.0. */
13653 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13655 ffecom_truth_value (tree expr
)
13657 return truthvalue_conversion (expr
);
13661 /* Return the inversion of a truth value (the inversion of what
13662 ffecom_truth_value builds).
13664 Apparently invert_truthvalue, which is properly in the back end, is
13665 enough for now, so just use it. */
13667 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13669 ffecom_truth_value_invert (tree expr
)
13671 return invert_truthvalue (ffecom_truth_value (expr
));
13675 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13677 If the PARM_DECL already exists, return it, else create it. It's an
13678 integer_type_node argument for the master function that implements a
13679 subroutine or function with more than one entrypoint and is bound at
13680 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13681 first ENTRY statement, and so on). */
13683 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13685 ffecom_which_entrypoint_decl ()
13687 assert (ffecom_which_entrypoint_decl_
!= NULL_TREE
);
13689 return ffecom_which_entrypoint_decl_
;
13694 /* The following sections consists of private and public functions
13695 that have the same names and perform roughly the same functions
13696 as counterparts in the C front end. Changes in the C front end
13697 might affect how things should be done here. Only functions
13698 needed by the back end should be public here; the rest should
13699 be private (static in the C sense). Functions needed by other
13700 g77 front-end modules should be accessed by them via public
13701 ffecom_* names, which should themselves call private versions
13702 in this section so the private versions are easy to recognize
13703 when upgrading to a new gcc and finding interesting changes
13706 Functions named after rule "foo:" in c-parse.y are named
13707 "bison_rule_foo_" so they are easy to find. */
13709 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13712 bison_rule_compstmt_ ()
13714 emit_line_note (input_filename
, lineno
);
13715 expand_end_bindings (getdecls (), 1, 1);
13716 poplevel (1, 1, 0);
13721 bison_rule_pushlevel_ ()
13723 emit_line_note (input_filename
, lineno
);
13725 clear_last_expr ();
13727 expand_start_bindings (0);
13730 /* Return a definition for a builtin function named NAME and whose data type
13731 is TYPE. TYPE should be a function type with argument types.
13732 FUNCTION_CODE tells later passes how to compile calls to this function.
13733 See tree.h for its possible values.
13735 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13736 the name to be called if we can't opencode the function. */
13739 builtin_function (char *name
, tree type
,
13740 enum built_in_function function_code
, char *library_name
)
13742 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
13743 DECL_EXTERNAL (decl
) = 1;
13744 TREE_PUBLIC (decl
) = 1;
13746 DECL_ASSEMBLER_NAME (decl
) = get_identifier (library_name
);
13747 make_decl_rtl (decl
, NULL_PTR
, 1);
13749 if (function_code
!= NOT_BUILT_IN
)
13751 DECL_BUILT_IN (decl
) = 1;
13752 DECL_FUNCTION_CODE (decl
) = function_code
;
13758 /* Handle when a new declaration NEWDECL
13759 has the same name as an old one OLDDECL
13760 in the same binding contour.
13761 Prints an error message if appropriate.
13763 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13764 Otherwise, return 0. */
13767 duplicate_decls (tree newdecl
, tree olddecl
)
13769 int types_match
= 1;
13770 int new_is_definition
= (TREE_CODE (newdecl
) == FUNCTION_DECL
13771 && DECL_INITIAL (newdecl
) != 0);
13772 tree oldtype
= TREE_TYPE (olddecl
);
13773 tree newtype
= TREE_TYPE (newdecl
);
13775 if (olddecl
== newdecl
)
13778 if (TREE_CODE (newtype
) == ERROR_MARK
13779 || TREE_CODE (oldtype
) == ERROR_MARK
)
13782 /* New decl is completely inconsistent with the old one =>
13783 tell caller to replace the old one.
13784 This is always an error except in the case of shadowing a builtin. */
13785 if (TREE_CODE (olddecl
) != TREE_CODE (newdecl
))
13788 /* For real parm decl following a forward decl,
13789 return 1 so old decl will be reused. */
13790 if (types_match
&& TREE_CODE (newdecl
) == PARM_DECL
13791 && TREE_ASM_WRITTEN (olddecl
) && ! TREE_ASM_WRITTEN (newdecl
))
13794 /* The new declaration is the same kind of object as the old one.
13795 The declarations may partially match. Print warnings if they don't
13796 match enough. Ultimately, copy most of the information from the new
13797 decl to the old one, and keep using the old one. */
13799 if (TREE_CODE (olddecl
) == FUNCTION_DECL
13800 && DECL_BUILT_IN (olddecl
))
13802 /* A function declaration for a built-in function. */
13803 if (!TREE_PUBLIC (newdecl
))
13805 else if (!types_match
)
13807 /* Accept the return type of the new declaration if same modes. */
13808 tree oldreturntype
= TREE_TYPE (TREE_TYPE (olddecl
));
13809 tree newreturntype
= TREE_TYPE (TREE_TYPE (newdecl
));
13811 /* Make sure we put the new type in the same obstack as the old ones.
13812 If the old types are not both in the same obstack, use the
13814 if (TYPE_OBSTACK (oldtype
) == TYPE_OBSTACK (newtype
))
13815 push_obstacks (TYPE_OBSTACK (oldtype
), TYPE_OBSTACK (oldtype
));
13818 push_obstacks_nochange ();
13819 end_temporary_allocation ();
13822 if (TYPE_MODE (oldreturntype
) == TYPE_MODE (newreturntype
))
13824 /* Function types may be shared, so we can't just modify
13825 the return type of olddecl's function type. */
13827 = build_function_type (newreturntype
,
13828 TYPE_ARG_TYPES (TREE_TYPE (olddecl
)));
13832 TREE_TYPE (olddecl
) = newtype
;
13840 else if (TREE_CODE (olddecl
) == FUNCTION_DECL
13841 && DECL_SOURCE_LINE (olddecl
) == 0)
13843 /* A function declaration for a predeclared function
13844 that isn't actually built in. */
13845 if (!TREE_PUBLIC (newdecl
))
13847 else if (!types_match
)
13849 /* If the types don't match, preserve volatility indication.
13850 Later on, we will discard everything else about the
13851 default declaration. */
13852 TREE_THIS_VOLATILE (newdecl
) |= TREE_THIS_VOLATILE (olddecl
);
13856 /* Copy all the DECL_... slots specified in the new decl
13857 except for any that we copy here from the old type.
13859 Past this point, we don't change OLDTYPE and NEWTYPE
13860 even if we change the types of NEWDECL and OLDDECL. */
13864 /* Make sure we put the new type in the same obstack as the old ones.
13865 If the old types are not both in the same obstack, use the permanent
13867 if (TYPE_OBSTACK (oldtype
) == TYPE_OBSTACK (newtype
))
13868 push_obstacks (TYPE_OBSTACK (oldtype
), TYPE_OBSTACK (oldtype
));
13871 push_obstacks_nochange ();
13872 end_temporary_allocation ();
13875 /* Merge the data types specified in the two decls. */
13876 if (TREE_CODE (newdecl
) != FUNCTION_DECL
|| !DECL_BUILT_IN (olddecl
))
13877 TREE_TYPE (newdecl
)
13878 = TREE_TYPE (olddecl
)
13879 = TREE_TYPE (newdecl
);
13881 /* Lay the type out, unless already done. */
13882 if (oldtype
!= TREE_TYPE (newdecl
))
13884 if (TREE_TYPE (newdecl
) != error_mark_node
)
13885 layout_type (TREE_TYPE (newdecl
));
13886 if (TREE_CODE (newdecl
) != FUNCTION_DECL
13887 && TREE_CODE (newdecl
) != TYPE_DECL
13888 && TREE_CODE (newdecl
) != CONST_DECL
)
13889 layout_decl (newdecl
, 0);
13893 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13894 DECL_SIZE (newdecl
) = DECL_SIZE (olddecl
);
13895 if (TREE_CODE (olddecl
) != FUNCTION_DECL
)
13896 if (DECL_ALIGN (olddecl
) > DECL_ALIGN (newdecl
))
13897 DECL_ALIGN (newdecl
) = DECL_ALIGN (olddecl
);
13900 /* Keep the old rtl since we can safely use it. */
13901 DECL_RTL (newdecl
) = DECL_RTL (olddecl
);
13903 /* Merge the type qualifiers. */
13904 if (DECL_BUILT_IN_NONANSI (olddecl
) && TREE_THIS_VOLATILE (olddecl
)
13905 && !TREE_THIS_VOLATILE (newdecl
))
13906 TREE_THIS_VOLATILE (olddecl
) = 0;
13907 if (TREE_READONLY (newdecl
))
13908 TREE_READONLY (olddecl
) = 1;
13909 if (TREE_THIS_VOLATILE (newdecl
))
13911 TREE_THIS_VOLATILE (olddecl
) = 1;
13912 if (TREE_CODE (newdecl
) == VAR_DECL
)
13913 make_var_volatile (newdecl
);
13916 /* Keep source location of definition rather than declaration.
13917 Likewise, keep decl at outer scope. */
13918 if ((DECL_INITIAL (newdecl
) == 0 && DECL_INITIAL (olddecl
) != 0)
13919 || (DECL_CONTEXT (newdecl
) != 0 && DECL_CONTEXT (olddecl
) == 0))
13921 DECL_SOURCE_LINE (newdecl
) = DECL_SOURCE_LINE (olddecl
);
13922 DECL_SOURCE_FILE (newdecl
) = DECL_SOURCE_FILE (olddecl
);
13924 if (DECL_CONTEXT (olddecl
) == 0
13925 && TREE_CODE (newdecl
) != FUNCTION_DECL
)
13926 DECL_CONTEXT (newdecl
) = 0;
13929 /* Merge the unused-warning information. */
13930 if (DECL_IN_SYSTEM_HEADER (olddecl
))
13931 DECL_IN_SYSTEM_HEADER (newdecl
) = 1;
13932 else if (DECL_IN_SYSTEM_HEADER (newdecl
))
13933 DECL_IN_SYSTEM_HEADER (olddecl
) = 1;
13935 /* Merge the initialization information. */
13936 if (DECL_INITIAL (newdecl
) == 0)
13937 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13939 /* Merge the section attribute.
13940 We want to issue an error if the sections conflict but that must be
13941 done later in decl_attributes since we are called before attributes
13943 if (DECL_SECTION_NAME (newdecl
) == NULL_TREE
)
13944 DECL_SECTION_NAME (newdecl
) = DECL_SECTION_NAME (olddecl
);
13947 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13949 DECL_STATIC_CONSTRUCTOR(newdecl
) |= DECL_STATIC_CONSTRUCTOR(olddecl
);
13950 DECL_STATIC_DESTRUCTOR (newdecl
) |= DECL_STATIC_DESTRUCTOR (olddecl
);
13956 /* If cannot merge, then use the new type and qualifiers,
13957 and don't preserve the old rtl. */
13960 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13961 TREE_READONLY (olddecl
) = TREE_READONLY (newdecl
);
13962 TREE_THIS_VOLATILE (olddecl
) = TREE_THIS_VOLATILE (newdecl
);
13963 TREE_SIDE_EFFECTS (olddecl
) = TREE_SIDE_EFFECTS (newdecl
);
13966 /* Merge the storage class information. */
13967 /* For functions, static overrides non-static. */
13968 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13970 TREE_PUBLIC (newdecl
) &= TREE_PUBLIC (olddecl
);
13971 /* This is since we don't automatically
13972 copy the attributes of NEWDECL into OLDDECL. */
13973 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13974 /* If this clears `static', clear it in the identifier too. */
13975 if (! TREE_PUBLIC (olddecl
))
13976 TREE_PUBLIC (DECL_NAME (olddecl
)) = 0;
13978 if (DECL_EXTERNAL (newdecl
))
13980 TREE_STATIC (newdecl
) = TREE_STATIC (olddecl
);
13981 DECL_EXTERNAL (newdecl
) = DECL_EXTERNAL (olddecl
);
13982 /* An extern decl does not override previous storage class. */
13983 TREE_PUBLIC (newdecl
) = TREE_PUBLIC (olddecl
);
13987 TREE_STATIC (olddecl
) = TREE_STATIC (newdecl
);
13988 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13991 /* If either decl says `inline', this fn is inline,
13992 unless its definition was passed already. */
13993 if (DECL_INLINE (newdecl
) && DECL_INITIAL (olddecl
) == 0)
13994 DECL_INLINE (olddecl
) = 1;
13995 DECL_INLINE (newdecl
) = DECL_INLINE (olddecl
);
13997 /* Get rid of any built-in function if new arg types don't match it
13998 or if we have a function definition. */
13999 if (TREE_CODE (newdecl
) == FUNCTION_DECL
14000 && DECL_BUILT_IN (olddecl
)
14001 && (!types_match
|| new_is_definition
))
14003 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
14004 DECL_BUILT_IN (olddecl
) = 0;
14007 /* If redeclaring a builtin function, and not a definition,
14009 Also preserve various other info from the definition. */
14010 if (TREE_CODE (newdecl
) == FUNCTION_DECL
&& !new_is_definition
)
14012 if (DECL_BUILT_IN (olddecl
))
14014 DECL_BUILT_IN (newdecl
) = 1;
14015 DECL_FUNCTION_CODE (newdecl
) = DECL_FUNCTION_CODE (olddecl
);
14018 DECL_FRAME_SIZE (newdecl
) = DECL_FRAME_SIZE (olddecl
);
14020 DECL_RESULT (newdecl
) = DECL_RESULT (olddecl
);
14021 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
14022 DECL_SAVED_INSNS (newdecl
) = DECL_SAVED_INSNS (olddecl
);
14023 DECL_ARGUMENTS (newdecl
) = DECL_ARGUMENTS (olddecl
);
14026 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
14027 But preserve olddecl's DECL_UID. */
14029 register unsigned olddecl_uid
= DECL_UID (olddecl
);
14031 memcpy ((char *) olddecl
+ sizeof (struct tree_common
),
14032 (char *) newdecl
+ sizeof (struct tree_common
),
14033 sizeof (struct tree_decl
) - sizeof (struct tree_common
));
14034 DECL_UID (olddecl
) = olddecl_uid
;
14040 /* Finish processing of a declaration;
14041 install its initial value.
14042 If the length of an array type is not known before,
14043 it must be determined now, from the initial value, or it is an error. */
14046 finish_decl (tree decl
, tree init
, bool is_top_level
)
14048 register tree type
= TREE_TYPE (decl
);
14049 int was_incomplete
= (DECL_SIZE (decl
) == 0);
14050 int temporary
= allocation_temporary_p ();
14051 bool at_top_level
= (current_binding_level
== global_binding_level
);
14052 bool top_level
= is_top_level
|| at_top_level
;
14054 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14056 assert (!is_top_level
|| !at_top_level
);
14058 if (TREE_CODE (decl
) == PARM_DECL
)
14059 assert (init
== NULL_TREE
);
14060 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
14061 overlaps DECL_ARG_TYPE. */
14062 else if (init
== NULL_TREE
)
14063 assert (DECL_INITIAL (decl
) == NULL_TREE
);
14065 assert (DECL_INITIAL (decl
) == error_mark_node
);
14067 if (init
!= NULL_TREE
)
14069 if (TREE_CODE (decl
) != TYPE_DECL
)
14070 DECL_INITIAL (decl
) = init
;
14073 /* typedef foo = bar; store the type of bar as the type of foo. */
14074 TREE_TYPE (decl
) = TREE_TYPE (init
);
14075 DECL_INITIAL (decl
) = init
= 0;
14079 /* Pop back to the obstack that is current for this binding level. This is
14080 because MAXINDEX, rtl, etc. to be made below must go in the permanent
14081 obstack. But don't discard the temporary data yet. */
14084 /* Deduce size of array from initialization, if not already known */
14086 if (TREE_CODE (type
) == ARRAY_TYPE
14087 && TYPE_DOMAIN (type
) == 0
14088 && TREE_CODE (decl
) != TYPE_DECL
)
14090 assert (top_level
);
14091 assert (was_incomplete
);
14093 layout_decl (decl
, 0);
14096 if (TREE_CODE (decl
) == VAR_DECL
)
14098 if (DECL_SIZE (decl
) == NULL_TREE
14099 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
14100 layout_decl (decl
, 0);
14102 if (DECL_SIZE (decl
) == NULL_TREE
14103 && (TREE_STATIC (decl
)
14105 /* A static variable with an incomplete type is an error if it is
14106 initialized. Also if it is not file scope. Otherwise, let it
14107 through, but if it is not `extern' then it may cause an error
14109 (DECL_INITIAL (decl
) != 0 || DECL_CONTEXT (decl
) != 0)
14111 /* An automatic variable with an incomplete type is an error. */
14112 !DECL_EXTERNAL (decl
)))
14114 assert ("storage size not known" == NULL
);
14118 if ((DECL_EXTERNAL (decl
) || TREE_STATIC (decl
))
14119 && (DECL_SIZE (decl
) != 0)
14120 && (TREE_CODE (DECL_SIZE (decl
)) != INTEGER_CST
))
14122 assert ("storage size not constant" == NULL
);
14127 /* Output the assembler code and/or RTL code for variables and functions,
14128 unless the type is an undefined structure or union. If not, it will get
14129 done when the type is completed. */
14131 if (TREE_CODE (decl
) == VAR_DECL
|| TREE_CODE (decl
) == FUNCTION_DECL
)
14133 rest_of_decl_compilation (decl
, NULL
,
14134 DECL_CONTEXT (decl
) == 0,
14137 if (DECL_CONTEXT (decl
) != 0)
14139 /* Recompute the RTL of a local array now if it used to be an
14140 incomplete type. */
14142 && !TREE_STATIC (decl
) && !DECL_EXTERNAL (decl
))
14144 /* If we used it already as memory, it must stay in memory. */
14145 TREE_ADDRESSABLE (decl
) = TREE_USED (decl
);
14146 /* If it's still incomplete now, no init will save it. */
14147 if (DECL_SIZE (decl
) == 0)
14148 DECL_INITIAL (decl
) = 0;
14149 expand_decl (decl
);
14151 /* Compute and store the initial value. */
14152 if (TREE_CODE (decl
) != FUNCTION_DECL
)
14153 expand_decl_init (decl
);
14156 else if (TREE_CODE (decl
) == TYPE_DECL
)
14158 rest_of_decl_compilation (decl
, NULL_PTR
,
14159 DECL_CONTEXT (decl
) == 0,
14163 /* This test used to include TREE_PERMANENT, however, we have the same
14164 problem with initializers at the function level. Such initializers get
14165 saved until the end of the function on the momentary_obstack. */
14166 if (!(TREE_CODE (decl
) == FUNCTION_DECL
&& DECL_INLINE (decl
))
14168 /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
14170 && TREE_CODE (decl
) != PARM_DECL
)
14172 /* We need to remember that this array HAD an initialization, but
14173 discard the actual temporary nodes, since we can't have a permanent
14174 node keep pointing to them. */
14175 /* We make an exception for inline functions, since it's normal for a
14176 local extern redeclaration of an inline function to have a copy of
14177 the top-level decl's DECL_INLINE. */
14178 if ((DECL_INITIAL (decl
) != 0)
14179 && (DECL_INITIAL (decl
) != error_mark_node
))
14181 /* If this is a const variable, then preserve the
14182 initializer instead of discarding it so that we can optimize
14183 references to it. */
14184 /* This test used to include TREE_STATIC, but this won't be set
14185 for function level initializers. */
14186 if (TREE_READONLY (decl
))
14188 preserve_initializer ();
14189 /* Hack? Set the permanent bit for something that is
14190 permanent, but not on the permenent obstack, so as to
14191 convince output_constant_def to make its rtl on the
14192 permanent obstack. */
14193 TREE_PERMANENT (DECL_INITIAL (decl
)) = 1;
14195 /* The initializer and DECL must have the same (or equivalent
14196 types), but if the initializer is a STRING_CST, its type
14197 might not be on the right obstack, so copy the type
14199 TREE_TYPE (DECL_INITIAL (decl
)) = type
;
14202 DECL_INITIAL (decl
) = error_mark_node
;
14206 /* If requested, warn about definitions of large data objects. */
14208 if (warn_larger_than
14209 && (TREE_CODE (decl
) == VAR_DECL
|| TREE_CODE (decl
) == PARM_DECL
)
14210 && !DECL_EXTERNAL (decl
))
14212 register tree decl_size
= DECL_SIZE (decl
);
14214 if (decl_size
&& TREE_CODE (decl_size
) == INTEGER_CST
)
14216 unsigned units
= TREE_INT_CST_LOW (decl_size
) / BITS_PER_UNIT
;
14218 if (units
> larger_than_size
)
14219 warning_with_decl (decl
, "size of `%s' is %u bytes", units
);
14223 /* If we have gone back from temporary to permanent allocation, actually
14224 free the temporary space that we no longer need. */
14225 if (temporary
&& !allocation_temporary_p ())
14226 permanent_allocation (0);
14228 /* At the end of a declaration, throw away any variable type sizes of types
14229 defined inside that declaration. There is no use computing them in the
14230 following function definition. */
14231 if (current_binding_level
== global_binding_level
)
14232 get_pending_sizes ();
14235 /* Finish up a function declaration and compile that function
14236 all the way to assembler language output. The free the storage
14237 for the function definition.
14239 This is called after parsing the body of the function definition.
14241 NESTED is nonzero if the function being finished is nested in another. */
14244 finish_function (int nested
)
14246 register tree fndecl
= current_function_decl
;
14248 assert (fndecl
!= NULL_TREE
);
14249 if (TREE_CODE (fndecl
) != ERROR_MARK
)
14252 assert (DECL_CONTEXT (fndecl
) != NULL_TREE
);
14254 assert (DECL_CONTEXT (fndecl
) == NULL_TREE
);
14257 /* TREE_READONLY (fndecl) = 1;
14258 This caused &foo to be of type ptr-to-const-function
14259 which then got a warning when stored in a ptr-to-function variable. */
14261 poplevel (1, 0, 1);
14263 if (TREE_CODE (fndecl
) != ERROR_MARK
)
14265 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
14267 /* Must mark the RESULT_DECL as being in this function. */
14269 DECL_CONTEXT (DECL_RESULT (fndecl
)) = fndecl
;
14271 /* Obey `register' declarations if `setjmp' is called in this fn. */
14272 /* Generate rtl for function exit. */
14273 expand_function_end (input_filename
, lineno
, 0);
14275 /* So we can tell if jump_optimize sets it to 1. */
14278 /* Run the optimizers and output the assembler code for this function. */
14279 rest_of_compilation (fndecl
);
14282 /* Free all the tree nodes making up this function. */
14283 /* Switch back to allocating nodes permanently until we start another
14286 permanent_allocation (1);
14288 if (DECL_SAVED_INSNS (fndecl
) == 0 && !nested
&& (TREE_CODE (fndecl
) != ERROR_MARK
))
14290 /* Stop pointing to the local nodes about to be freed. */
14291 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14292 function definition. */
14293 /* For a nested function, this is done in pop_f_function_context. */
14294 /* If rest_of_compilation set this to 0, leave it 0. */
14295 if (DECL_INITIAL (fndecl
) != 0)
14296 DECL_INITIAL (fndecl
) = error_mark_node
;
14297 DECL_ARGUMENTS (fndecl
) = 0;
14302 /* Let the error reporting routines know that we're outside a function.
14303 For a nested function, this value is used in pop_c_function_context
14304 and then reset via pop_function_context. */
14305 ffecom_outer_function_decl_
= current_function_decl
= NULL
;
14309 /* Plug-in replacement for identifying the name of a decl and, for a
14310 function, what we call it in diagnostics. For now, "program unit"
14311 should suffice, since it's a bit of a hassle to figure out which
14312 of several kinds of things it is. Note that it could conceivably
14313 be a statement function, which probably isn't really a program unit
14314 per se, but if that comes up, it should be easy to check (being a
14315 nested function and all). */
14318 lang_printable_name (tree decl
, int v
)
14320 /* Just to keep GCC quiet about the unused variable.
14321 In theory, differing values of V should produce different
14326 if (TREE_CODE (decl
) == ERROR_MARK
)
14327 return "erroneous code";
14328 return IDENTIFIER_POINTER (DECL_NAME (decl
));
14332 /* g77's function to print out name of current function that caused
14337 lang_print_error_function (file
)
14340 static ffeglobal last_g
= NULL
;
14341 static ffesymbol last_s
= NULL
;
14346 if ((ffecom_primary_entry_
== NULL
)
14347 || (ffesymbol_global (ffecom_primary_entry_
) == NULL
))
14355 g
= ffesymbol_global (ffecom_primary_entry_
);
14356 if (ffecom_nested_entry_
== NULL
)
14358 s
= ffecom_primary_entry_
;
14359 switch (ffesymbol_kind (s
))
14361 case FFEINFO_kindFUNCTION
:
14365 case FFEINFO_kindSUBROUTINE
:
14366 kind
= "subroutine";
14369 case FFEINFO_kindPROGRAM
:
14373 case FFEINFO_kindBLOCKDATA
:
14374 kind
= "block-data";
14378 kind
= ffeinfo_kind_message (ffesymbol_kind (s
));
14384 s
= ffecom_nested_entry_
;
14385 kind
= "statement function";
14389 if ((last_g
!= g
) || (last_s
!= s
))
14392 fprintf (stderr
, "%s: ", file
);
14395 fprintf (stderr
, "Outside of any program unit:\n");
14398 char *name
= ffesymbol_text (s
);
14400 fprintf (stderr
, "In %s `%s':\n", kind
, name
);
14409 /* Similar to `lookup_name' but look only at current binding level. */
14412 lookup_name_current_level (tree name
)
14416 if (current_binding_level
== global_binding_level
)
14417 return IDENTIFIER_GLOBAL_VALUE (name
);
14419 if (IDENTIFIER_LOCAL_VALUE (name
) == 0)
14422 for (t
= current_binding_level
->names
; t
; t
= TREE_CHAIN (t
))
14423 if (DECL_NAME (t
) == name
)
14429 /* Create a new `struct binding_level'. */
14431 static struct binding_level
*
14432 make_binding_level ()
14435 return (struct binding_level
*) xmalloc (sizeof (struct binding_level
));
14438 /* Save and restore the variables in this file and elsewhere
14439 that keep track of the progress of compilation of the current function.
14440 Used for nested functions. */
14444 struct f_function
*next
;
14446 tree shadowed_labels
;
14447 struct binding_level
*binding_level
;
14450 struct f_function
*f_function_chain
;
14452 /* Restore the variables used during compilation of a C function. */
14455 pop_f_function_context ()
14457 struct f_function
*p
= f_function_chain
;
14460 /* Bring back all the labels that were shadowed. */
14461 for (link
= shadowed_labels
; link
; link
= TREE_CHAIN (link
))
14462 if (DECL_NAME (TREE_VALUE (link
)) != 0)
14463 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link
)))
14464 = TREE_VALUE (link
);
14466 if (DECL_SAVED_INSNS (current_function_decl
) == 0)
14468 /* Stop pointing to the local nodes about to be freed. */
14469 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14470 function definition. */
14471 DECL_INITIAL (current_function_decl
) = error_mark_node
;
14472 DECL_ARGUMENTS (current_function_decl
) = 0;
14475 pop_function_context ();
14477 f_function_chain
= p
->next
;
14479 named_labels
= p
->named_labels
;
14480 shadowed_labels
= p
->shadowed_labels
;
14481 current_binding_level
= p
->binding_level
;
14486 /* Save and reinitialize the variables
14487 used during compilation of a C function. */
14490 push_f_function_context ()
14492 struct f_function
*p
14493 = (struct f_function
*) xmalloc (sizeof (struct f_function
));
14495 push_function_context ();
14497 p
->next
= f_function_chain
;
14498 f_function_chain
= p
;
14500 p
->named_labels
= named_labels
;
14501 p
->shadowed_labels
= shadowed_labels
;
14502 p
->binding_level
= current_binding_level
;
14506 push_parm_decl (tree parm
)
14508 int old_immediate_size_expand
= immediate_size_expand
;
14510 /* Don't try computing parm sizes now -- wait till fn is called. */
14512 immediate_size_expand
= 0;
14514 push_obstacks_nochange ();
14516 /* Fill in arg stuff. */
14518 DECL_ARG_TYPE (parm
) = TREE_TYPE (parm
);
14519 DECL_ARG_TYPE_AS_WRITTEN (parm
) = TREE_TYPE (parm
);
14520 TREE_READONLY (parm
) = 1; /* All implementation args are read-only. */
14522 parm
= pushdecl (parm
);
14524 immediate_size_expand
= old_immediate_size_expand
;
14526 finish_decl (parm
, NULL_TREE
, FALSE
);
14529 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
14532 pushdecl_top_level (x
)
14536 register struct binding_level
*b
= current_binding_level
;
14537 register tree f
= current_function_decl
;
14539 current_binding_level
= global_binding_level
;
14540 current_function_decl
= NULL_TREE
;
14542 current_binding_level
= b
;
14543 current_function_decl
= f
;
14547 /* Store the list of declarations of the current level.
14548 This is done for the parameter declarations of a function being defined,
14549 after they are modified in the light of any missing parameters. */
14555 return current_binding_level
->names
= decls
;
14558 /* Store the parameter declarations into the current function declaration.
14559 This is called after parsing the parameter declarations, before
14560 digesting the body of the function.
14562 For an old-style definition, modify the function's type
14563 to specify at least the number of arguments. */
14566 store_parm_decls (int is_main_program UNUSED
)
14568 register tree fndecl
= current_function_decl
;
14570 /* This is a chain of PARM_DECLs from old-style parm declarations. */
14571 DECL_ARGUMENTS (fndecl
) = storedecls (nreverse (getdecls ()));
14573 /* Initialize the RTL code for the function. */
14575 init_function_start (fndecl
, input_filename
, lineno
);
14577 /* Set up parameters and prepare for return, for the function. */
14579 expand_function_start (fndecl
, 0);
14583 start_decl (tree decl
, bool is_top_level
)
14586 bool at_top_level
= (current_binding_level
== global_binding_level
);
14587 bool top_level
= is_top_level
|| at_top_level
;
14589 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14591 assert (!is_top_level
|| !at_top_level
);
14593 /* The corresponding pop_obstacks is in finish_decl. */
14594 push_obstacks_nochange ();
14596 if (DECL_INITIAL (decl
) != NULL_TREE
)
14598 assert (DECL_INITIAL (decl
) == error_mark_node
);
14599 assert (!DECL_EXTERNAL (decl
));
14601 else if (top_level
)
14602 assert ((TREE_STATIC (decl
) == 1) || DECL_EXTERNAL (decl
) == 1);
14604 /* For Fortran, we by default put things in .common when possible. */
14605 DECL_COMMON (decl
) = 1;
14607 /* Add this decl to the current binding level. TEM may equal DECL or it may
14608 be a previous decl of the same name. */
14610 tem
= pushdecl_top_level (decl
);
14612 tem
= pushdecl (decl
);
14614 /* For a local variable, define the RTL now. */
14616 /* But not if this is a duplicate decl and we preserved the rtl from the
14617 previous one (which may or may not happen). */
14618 && DECL_RTL (tem
) == 0)
14620 if (TYPE_SIZE (TREE_TYPE (tem
)) != 0)
14622 else if (TREE_CODE (TREE_TYPE (tem
)) == ARRAY_TYPE
14623 && DECL_INITIAL (tem
) != 0)
14627 if (DECL_INITIAL (tem
) != NULL_TREE
)
14629 /* When parsing and digesting the initializer, use temporary storage.
14630 Do this even if we will ignore the value. */
14632 temporary_allocation ();
14638 /* Create the FUNCTION_DECL for a function definition.
14639 DECLSPECS and DECLARATOR are the parts of the declaration;
14640 they describe the function's name and the type it returns,
14641 but twisted together in a fashion that parallels the syntax of C.
14643 This function creates a binding context for the function body
14644 as well as setting up the FUNCTION_DECL in current_function_decl.
14646 Returns 1 on success. If the DECLARATOR is not suitable for a function
14647 (it defines a datum instead), we return 0, which tells
14648 yyparse to report a parse error.
14650 NESTED is nonzero for a function nested within another function. */
14653 start_function (tree name
, tree type
, int nested
, int public)
14657 int old_immediate_size_expand
= immediate_size_expand
;
14660 shadowed_labels
= 0;
14662 /* Don't expand any sizes in the return type of the function. */
14663 immediate_size_expand
= 0;
14668 assert (current_function_decl
!= NULL_TREE
);
14669 assert (DECL_CONTEXT (current_function_decl
) == NULL_TREE
);
14673 assert (current_function_decl
== NULL_TREE
);
14676 if (TREE_CODE (type
) == ERROR_MARK
)
14677 decl1
= current_function_decl
= error_mark_node
;
14680 decl1
= build_decl (FUNCTION_DECL
,
14683 TREE_PUBLIC (decl1
) = public ? 1 : 0;
14685 DECL_INLINE (decl1
) = 1;
14686 TREE_STATIC (decl1
) = 1;
14687 DECL_EXTERNAL (decl1
) = 0;
14689 announce_function (decl1
);
14691 /* Make the init_value nonzero so pushdecl knows this is not tentative.
14692 error_mark_node is replaced below (in poplevel) with the BLOCK. */
14693 DECL_INITIAL (decl1
) = error_mark_node
;
14695 /* Record the decl so that the function name is defined. If we already have
14696 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
14698 current_function_decl
= pushdecl (decl1
);
14702 ffecom_outer_function_decl_
= current_function_decl
;
14706 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
14708 make_function_rtl (current_function_decl
);
14710 restype
= TREE_TYPE (TREE_TYPE (current_function_decl
));
14711 DECL_RESULT (current_function_decl
)
14712 = build_decl (RESULT_DECL
, NULL_TREE
, restype
);
14716 /* Allocate further tree nodes temporarily during compilation of this
14718 temporary_allocation ();
14720 if (!nested
&& (TREE_CODE (current_function_decl
) != ERROR_MARK
))
14721 TREE_ADDRESSABLE (current_function_decl
) = 1;
14723 immediate_size_expand
= old_immediate_size_expand
;
14726 /* Here are the public functions the GNU back end needs. */
14728 /* This is used by the `assert' macro. It is provided in libgcc.a,
14729 which `cc' doesn't know how to link. Note that the C++ front-end
14730 no longer actually uses the `assert' macro (instead, it calls
14731 my_friendly_assert). But all of the back-end files still need this. */
14733 __eprintf (string
, expression
, line
, filename
)
14735 const char *string
;
14736 const char *expression
;
14738 const char *filename
;
14746 fprintf (stderr
, string
, expression
, line
, filename
);
14752 convert (type
, expr
)
14755 register tree e
= expr
;
14756 register enum tree_code code
= TREE_CODE (type
);
14758 if (type
== TREE_TYPE (e
)
14759 || TREE_CODE (e
) == ERROR_MARK
)
14761 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
14762 return fold (build1 (NOP_EXPR
, type
, e
));
14763 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
14764 || code
== ERROR_MARK
)
14765 return error_mark_node
;
14766 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
14768 assert ("void value not ignored as it ought to be" == NULL
);
14769 return error_mark_node
;
14771 if (code
== VOID_TYPE
)
14772 return build1 (CONVERT_EXPR
, type
, e
);
14773 if ((code
!= RECORD_TYPE
)
14774 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
14775 e
= ffecom_1 (REALPART_EXPR
, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
))),
14777 if (code
== INTEGER_TYPE
|| code
== ENUMERAL_TYPE
)
14778 return fold (convert_to_integer (type
, e
));
14779 if (code
== POINTER_TYPE
)
14780 return fold (convert_to_pointer (type
, e
));
14781 if (code
== REAL_TYPE
)
14782 return fold (convert_to_real (type
, e
));
14783 if (code
== COMPLEX_TYPE
)
14784 return fold (convert_to_complex (type
, e
));
14785 if (code
== RECORD_TYPE
)
14786 return fold (ffecom_convert_to_complex_ (type
, e
));
14788 assert ("conversion to non-scalar type requested" == NULL
);
14789 return error_mark_node
;
14792 /* integrate_decl_tree calls this function, but since we don't use the
14793 DECL_LANG_SPECIFIC field, this is a no-op. */
14796 copy_lang_decl (node
)
14801 /* Return the list of declarations of the current level.
14802 Note that this list is in reverse order unless/until
14803 you nreverse it; and when you do nreverse it, you must
14804 store the result back using `storedecls' or you will lose. */
14809 return current_binding_level
->names
;
14812 /* Nonzero if we are currently in the global binding level. */
14815 global_bindings_p ()
14817 return current_binding_level
== global_binding_level
;
14820 /* Insert BLOCK at the end of the list of subblocks of the
14821 current binding level. This is used when a BIND_EXPR is expanded,
14822 to handle the BLOCK node inside the BIND_EXPR. */
14825 incomplete_type_error (value
, type
)
14829 if (TREE_CODE (type
) == ERROR_MARK
)
14832 assert ("incomplete type?!?" == NULL
);
14836 init_decl_processing ()
14843 init_parse (filename
)
14847 extern void (*print_error_function
) (char *);
14850 /* Open input file. */
14851 if (filename
== 0 || !strcmp (filename
, "-"))
14854 filename
= "stdin";
14857 finput
= fopen (filename
, "r");
14859 pfatal_with_name (filename
);
14861 #ifdef IO_BUFFER_SIZE
14862 setvbuf (finput
, (char *) xmalloc (IO_BUFFER_SIZE
), _IOFBF
, IO_BUFFER_SIZE
);
14865 /* Make identifier nodes long enough for the language-specific slots. */
14866 set_identifier_size (sizeof (struct lang_identifier
));
14867 decl_printable_name
= lang_printable_name
;
14869 print_error_function
= lang_print_error_function
;
14882 insert_block (block
)
14885 TREE_USED (block
) = 1;
14886 current_binding_level
->blocks
14887 = chainon (current_binding_level
->blocks
, block
);
14891 lang_decode_option (p
)
14894 return ffe_decode_option (p
);
14897 /* used by print-tree.c */
14900 lang_print_xnode (file
, node
, indent
)
14910 ffe_terminate_0 ();
14912 if (ffe_is_ffedebug ())
14913 malloc_pool_display (malloc_pool_image ());
14925 /* If the file is output from cpp, it should contain a first line
14926 `# 1 "real-filename"', and the current design of gcc (toplev.c
14927 in particular and the way it sets up information relied on by
14928 INCLUDE) requires that we read this now, and store the
14929 "real-filename" info in master_input_filename. Ask the lexer
14930 to try doing this. */
14931 ffelex_hash_kludge (finput
);
14935 mark_addressable (exp
)
14938 register tree x
= exp
;
14940 switch (TREE_CODE (x
))
14943 case COMPONENT_REF
:
14945 x
= TREE_OPERAND (x
, 0);
14949 TREE_ADDRESSABLE (x
) = 1;
14956 if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
)
14957 && DECL_NONLOCAL (x
))
14959 if (TREE_PUBLIC (x
))
14961 assert ("address of global register var requested" == NULL
);
14964 assert ("address of register variable requested" == NULL
);
14966 else if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
))
14968 if (TREE_PUBLIC (x
))
14970 assert ("address of global register var requested" == NULL
);
14973 assert ("address of register var requested" == NULL
);
14975 put_var_into_stack (x
);
14978 case FUNCTION_DECL
:
14979 TREE_ADDRESSABLE (x
) = 1;
14980 #if 0 /* poplevel deals with this now. */
14981 if (DECL_CONTEXT (x
) == 0)
14982 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x
)) = 1;
14990 /* If DECL has a cleanup, build and return that cleanup here.
14991 This is a callback called by expand_expr. */
14994 maybe_build_cleanup (decl
)
14997 /* There are no cleanups in Fortran. */
15001 /* Exit a binding level.
15002 Pop the level off, and restore the state of the identifier-decl mappings
15003 that were in effect when this level was entered.
15005 If KEEP is nonzero, this level had explicit declarations, so
15006 and create a "block" (a BLOCK node) for the level
15007 to record its declarations and subblocks for symbol table output.
15009 If FUNCTIONBODY is nonzero, this level is the body of a function,
15010 so create a block as if KEEP were set and also clear out all
15013 If REVERSE is nonzero, reverse the order of decls before putting
15014 them into the BLOCK. */
15017 poplevel (keep
, reverse
, functionbody
)
15022 register tree link
;
15023 /* The chain of decls was accumulated in reverse order. Put it into forward
15024 order, just for cleanliness. */
15026 tree subblocks
= current_binding_level
->blocks
;
15029 int block_previously_created
;
15031 /* Get the decls in the order they were written. Usually
15032 current_binding_level->names is in reverse order. But parameter decls
15033 were previously put in forward order. */
15036 current_binding_level
->names
15037 = decls
= nreverse (current_binding_level
->names
);
15039 decls
= current_binding_level
->names
;
15041 /* Output any nested inline functions within this block if they weren't
15044 for (decl
= decls
; decl
; decl
= TREE_CHAIN (decl
))
15045 if (TREE_CODE (decl
) == FUNCTION_DECL
15046 && !TREE_ASM_WRITTEN (decl
)
15047 && DECL_INITIAL (decl
) != 0
15048 && TREE_ADDRESSABLE (decl
))
15050 /* If this decl was copied from a file-scope decl on account of a
15051 block-scope extern decl, propagate TREE_ADDRESSABLE to the
15052 file-scope decl. */
15053 if (DECL_ABSTRACT_ORIGIN (decl
) != 0)
15054 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl
)) = 1;
15057 push_function_context ();
15058 output_inline_function (decl
);
15059 pop_function_context ();
15063 /* If there were any declarations or structure tags in that level, or if
15064 this level is a function body, create a BLOCK to record them for the
15065 life of this function. */
15068 block_previously_created
= (current_binding_level
->this_block
!= 0);
15069 if (block_previously_created
)
15070 block
= current_binding_level
->this_block
;
15071 else if (keep
|| functionbody
)
15072 block
= make_node (BLOCK
);
15075 BLOCK_VARS (block
) = decls
;
15076 BLOCK_SUBBLOCKS (block
) = subblocks
;
15077 remember_end_note (block
);
15080 /* In each subblock, record that this is its superior. */
15082 for (link
= subblocks
; link
; link
= TREE_CHAIN (link
))
15083 BLOCK_SUPERCONTEXT (link
) = block
;
15085 /* Clear out the meanings of the local variables of this level. */
15087 for (link
= decls
; link
; link
= TREE_CHAIN (link
))
15089 if (DECL_NAME (link
) != 0)
15091 /* If the ident. was used or addressed via a local extern decl,
15092 don't forget that fact. */
15093 if (DECL_EXTERNAL (link
))
15095 if (TREE_USED (link
))
15096 TREE_USED (DECL_NAME (link
)) = 1;
15097 if (TREE_ADDRESSABLE (link
))
15098 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link
)) = 1;
15100 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link
)) = 0;
15104 /* If the level being exited is the top level of a function, check over all
15105 the labels, and clear out the current (function local) meanings of their
15110 /* If this is the top level block of a function, the vars are the
15111 function's parameters. Don't leave them in the BLOCK because they
15112 are found in the FUNCTION_DECL instead. */
15114 BLOCK_VARS (block
) = 0;
15117 /* Pop the current level, and free the structure for reuse. */
15120 register struct binding_level
*level
= current_binding_level
;
15121 current_binding_level
= current_binding_level
->level_chain
;
15123 level
->level_chain
= free_binding_level
;
15124 free_binding_level
= level
;
15127 /* Dispose of the block that we just made inside some higher level. */
15129 DECL_INITIAL (current_function_decl
) = block
;
15132 if (!block_previously_created
)
15133 current_binding_level
->blocks
15134 = chainon (current_binding_level
->blocks
, block
);
15136 /* If we did not make a block for the level just exited, any blocks made
15137 for inner levels (since they cannot be recorded as subblocks in that
15138 level) must be carried forward so they will later become subblocks of
15140 else if (subblocks
)
15141 current_binding_level
->blocks
15142 = chainon (current_binding_level
->blocks
, subblocks
);
15144 /* Set the TYPE_CONTEXTs for all of the tagged types belonging to this
15145 binding contour so that they point to the appropriate construct, i.e.
15146 either to the current FUNCTION_DECL node, or else to the BLOCK node we
15149 Note that for tagged types whose scope is just the formal parameter list
15150 for some function type specification, we can't properly set their
15151 TYPE_CONTEXTs here, because we don't have a pointer to the appropriate
15152 FUNCTION_TYPE node readily available to us. For those cases, the
15153 TYPE_CONTEXTs of the relevant tagged type nodes get set in
15154 `grokdeclarator' as soon as we have created the FUNCTION_TYPE node which
15155 will represent the "scope" for these "parameter list local" tagged
15159 TREE_USED (block
) = 1;
15164 print_lang_decl (file
, node
, indent
)
15172 print_lang_identifier (file
, node
, indent
)
15177 print_node (file
, "global", IDENTIFIER_GLOBAL_VALUE (node
), indent
+ 4);
15178 print_node (file
, "local", IDENTIFIER_LOCAL_VALUE (node
), indent
+ 4);
15182 print_lang_statistics ()
15187 print_lang_type (file
, node
, indent
)
15194 /* Record a decl-node X as belonging to the current lexical scope.
15195 Check for errors (such as an incompatible declaration for the same
15196 name already seen in the same scope).
15198 Returns either X or an old decl for the same name.
15199 If an old decl is returned, it may have been smashed
15200 to agree with what X says. */
15207 register tree name
= DECL_NAME (x
);
15208 register struct binding_level
*b
= current_binding_level
;
15210 if ((TREE_CODE (x
) == FUNCTION_DECL
)
15211 && (DECL_INITIAL (x
) == 0)
15212 && DECL_EXTERNAL (x
))
15213 DECL_CONTEXT (x
) = NULL_TREE
;
15215 DECL_CONTEXT (x
) = current_function_decl
;
15219 if (IDENTIFIER_INVENTED (name
))
15222 DECL_ARTIFICIAL (x
) = 1;
15224 DECL_IN_SYSTEM_HEADER (x
) = 1;
15225 DECL_IGNORED_P (x
) = 1;
15227 if (TREE_CODE (x
) == TYPE_DECL
)
15228 TYPE_DECL_SUPPRESS_DEBUG (x
) = 1;
15231 t
= lookup_name_current_level (name
);
15233 assert ((t
== NULL_TREE
) || (DECL_CONTEXT (x
) == NULL_TREE
));
15235 /* Don't push non-parms onto list for parms until we understand
15236 why we're doing this and whether it works. */
15238 assert ((b
== global_binding_level
)
15239 || !ffecom_transform_only_dummies_
15240 || TREE_CODE (x
) == PARM_DECL
);
15242 if ((t
!= NULL_TREE
) && duplicate_decls (x
, t
))
15245 /* If we are processing a typedef statement, generate a whole new
15246 ..._TYPE node (which will be just an variant of the existing
15247 ..._TYPE node with identical properties) and then install the
15248 TYPE_DECL node generated to represent the typedef name as the
15249 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15251 The whole point here is to end up with a situation where each and every
15252 ..._TYPE node the compiler creates will be uniquely associated with
15253 AT MOST one node representing a typedef name. This way, even though
15254 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15255 (i.e. "typedef name") nodes very early on, later parts of the
15256 compiler can always do the reverse translation and get back the
15257 corresponding typedef name. For example, given:
15259 typedef struct S MY_TYPE; MY_TYPE object;
15261 Later parts of the compiler might only know that `object' was of type
15262 `struct S' if it were not for code just below. With this code
15263 however, later parts of the compiler see something like:
15265 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15267 And they can then deduce (from the node for type struct S') that the
15268 original object declaration was:
15272 Being able to do this is important for proper support of protoize, and
15273 also for generating precise symbolic debugging information which
15274 takes full account of the programmer's (typedef) vocabulary.
15276 Obviously, we don't want to generate a duplicate ..._TYPE node if the
15277 TYPE_DECL node that we are now processing really represents a
15278 standard built-in type.
15280 Since all standard types are effectively declared at line zero in the
15281 source file, we can easily check to see if we are working on a
15282 standard type by checking the current value of lineno. */
15284 if (TREE_CODE (x
) == TYPE_DECL
)
15286 if (DECL_SOURCE_LINE (x
) == 0)
15288 if (TYPE_NAME (TREE_TYPE (x
)) == 0)
15289 TYPE_NAME (TREE_TYPE (x
)) = x
;
15291 else if (TREE_TYPE (x
) != error_mark_node
)
15293 tree tt
= TREE_TYPE (x
);
15295 tt
= build_type_copy (tt
);
15296 TYPE_NAME (tt
) = x
;
15297 TREE_TYPE (x
) = tt
;
15301 /* This name is new in its binding level. Install the new declaration
15303 if (b
== global_binding_level
)
15304 IDENTIFIER_GLOBAL_VALUE (name
) = x
;
15306 IDENTIFIER_LOCAL_VALUE (name
) = x
;
15309 /* Put decls on list in reverse order. We will reverse them later if
15311 TREE_CHAIN (x
) = b
->names
;
15317 /* Enter a new binding level.
15318 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15319 not for that of tags. */
15322 pushlevel (tag_transparent
)
15323 int tag_transparent
;
15325 register struct binding_level
*newlevel
= NULL_BINDING_LEVEL
;
15327 assert (!tag_transparent
);
15329 /* Reuse or create a struct for this binding level. */
15331 if (free_binding_level
)
15333 newlevel
= free_binding_level
;
15334 free_binding_level
= free_binding_level
->level_chain
;
15338 newlevel
= make_binding_level ();
15341 /* Add this level to the front of the chain (stack) of levels that are
15344 *newlevel
= clear_binding_level
;
15345 newlevel
->level_chain
= current_binding_level
;
15346 current_binding_level
= newlevel
;
15349 /* Set the BLOCK node for the innermost scope
15350 (the one we are currently in). */
15354 register tree block
;
15356 current_binding_level
->this_block
= block
;
15359 /* ~~tree.h SHOULD declare this, because toplev.c references it. */
15361 /* Can't 'yydebug' a front end not generated by yacc/bison! */
15364 set_yydebug (value
)
15368 fprintf (stderr
, "warning: no yacc/bison-generated output to debug!\n");
15372 signed_or_unsigned_type (unsignedp
, type
)
15378 if (! INTEGRAL_TYPE_P (type
))
15380 if (TYPE_PRECISION (type
) == TYPE_PRECISION (signed_char_type_node
))
15381 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15382 if (TYPE_PRECISION (type
) == TYPE_PRECISION (integer_type_node
))
15383 return unsignedp
? unsigned_type_node
: integer_type_node
;
15384 if (TYPE_PRECISION (type
) == TYPE_PRECISION (short_integer_type_node
))
15385 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15386 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_integer_type_node
))
15387 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15388 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_long_integer_type_node
))
15389 return (unsignedp
? long_long_unsigned_type_node
15390 : long_long_integer_type_node
);
15392 type2
= type_for_size (TYPE_PRECISION (type
), unsignedp
);
15393 if (type2
== NULL_TREE
)
15403 tree type1
= TYPE_MAIN_VARIANT (type
);
15404 ffeinfoKindtype kt
;
15407 if (type1
== unsigned_char_type_node
|| type1
== char_type_node
)
15408 return signed_char_type_node
;
15409 if (type1
== unsigned_type_node
)
15410 return integer_type_node
;
15411 if (type1
== short_unsigned_type_node
)
15412 return short_integer_type_node
;
15413 if (type1
== long_unsigned_type_node
)
15414 return long_integer_type_node
;
15415 if (type1
== long_long_unsigned_type_node
)
15416 return long_long_integer_type_node
;
15417 #if 0 /* gcc/c-* files only */
15418 if (type1
== unsigned_intDI_type_node
)
15419 return intDI_type_node
;
15420 if (type1
== unsigned_intSI_type_node
)
15421 return intSI_type_node
;
15422 if (type1
== unsigned_intHI_type_node
)
15423 return intHI_type_node
;
15424 if (type1
== unsigned_intQI_type_node
)
15425 return intQI_type_node
;
15428 type2
= type_for_size (TYPE_PRECISION (type1
), 0);
15429 if (type2
!= NULL_TREE
)
15432 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15434 type2
= ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
15436 if (type1
== type2
)
15437 return ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15443 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15444 or validate its data type for an `if' or `while' statement or ?..: exp.
15446 This preparation consists of taking the ordinary
15447 representation of an expression expr and producing a valid tree
15448 boolean expression describing whether expr is nonzero. We could
15449 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15450 but we optimize comparisons, &&, ||, and !.
15452 The resulting type should always be `integer_type_node'. */
15455 truthvalue_conversion (expr
)
15458 if (TREE_CODE (expr
) == ERROR_MARK
)
15461 #if 0 /* This appears to be wrong for C++. */
15462 /* These really should return error_mark_node after 2.4 is stable.
15463 But not all callers handle ERROR_MARK properly. */
15464 switch (TREE_CODE (TREE_TYPE (expr
)))
15467 error ("struct type value used where scalar is required");
15468 return integer_zero_node
;
15471 error ("union type value used where scalar is required");
15472 return integer_zero_node
;
15475 error ("array type value used where scalar is required");
15476 return integer_zero_node
;
15483 switch (TREE_CODE (expr
))
15485 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15486 or comparison expressions as truth values at this level. */
15488 case COMPONENT_REF
:
15489 /* A one-bit unsigned bit-field is already acceptable. */
15490 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr
, 1)))
15491 && TREE_UNSIGNED (TREE_OPERAND (expr
, 1)))
15497 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15498 or comparison expressions as truth values at this level. */
15500 if (integer_zerop (TREE_OPERAND (expr
, 1)))
15501 return build_unary_op (TRUTH_NOT_EXPR
, TREE_OPERAND (expr
, 0), 0);
15503 case NE_EXPR
: case LE_EXPR
: case GE_EXPR
: case LT_EXPR
: case GT_EXPR
:
15504 case TRUTH_ANDIF_EXPR
:
15505 case TRUTH_ORIF_EXPR
:
15506 case TRUTH_AND_EXPR
:
15507 case TRUTH_OR_EXPR
:
15508 case TRUTH_XOR_EXPR
:
15509 TREE_TYPE (expr
) = integer_type_node
;
15516 return integer_zerop (expr
) ? integer_zero_node
: integer_one_node
;
15519 return real_zerop (expr
) ? integer_zero_node
: integer_one_node
;
15522 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 0)))
15523 return build (COMPOUND_EXPR
, integer_type_node
,
15524 TREE_OPERAND (expr
, 0), integer_one_node
);
15526 return integer_one_node
;
15529 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1))
15530 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
15532 truthvalue_conversion (TREE_OPERAND (expr
, 0)),
15533 truthvalue_conversion (TREE_OPERAND (expr
, 1)));
15539 /* These don't change whether an object is non-zero or zero. */
15540 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15544 /* These don't change whether an object is zero or non-zero, but
15545 we can't ignore them if their second arg has side-effects. */
15546 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1)))
15547 return build (COMPOUND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 1),
15548 truthvalue_conversion (TREE_OPERAND (expr
, 0)));
15550 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15553 /* Distribute the conversion into the arms of a COND_EXPR. */
15554 return fold (build (COND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 0),
15555 truthvalue_conversion (TREE_OPERAND (expr
, 1)),
15556 truthvalue_conversion (TREE_OPERAND (expr
, 2))));
15559 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15560 since that affects how `default_conversion' will behave. */
15561 if (TREE_CODE (TREE_TYPE (expr
)) == REFERENCE_TYPE
15562 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == REFERENCE_TYPE
)
15564 /* fall through... */
15566 /* If this is widening the argument, we can ignore it. */
15567 if (TYPE_PRECISION (TREE_TYPE (expr
))
15568 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr
, 0))))
15569 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15573 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15575 if (TARGET_FLOAT_FORMAT
== IEEE_FLOAT_FORMAT
15576 && TREE_CODE (TREE_TYPE (expr
)) == REAL_TYPE
)
15578 /* fall through... */
15580 /* This and MINUS_EXPR can be changed into a comparison of the
15582 if (TREE_TYPE (TREE_OPERAND (expr
, 0))
15583 == TREE_TYPE (TREE_OPERAND (expr
, 1)))
15584 return ffecom_2 (NE_EXPR
, integer_type_node
,
15585 TREE_OPERAND (expr
, 0),
15586 TREE_OPERAND (expr
, 1));
15587 return ffecom_2 (NE_EXPR
, integer_type_node
,
15588 TREE_OPERAND (expr
, 0),
15589 fold (build1 (NOP_EXPR
,
15590 TREE_TYPE (TREE_OPERAND (expr
, 0)),
15591 TREE_OPERAND (expr
, 1))));
15594 if (integer_onep (TREE_OPERAND (expr
, 1)))
15599 #if 0 /* No such thing in Fortran. */
15600 if (warn_parentheses
&& C_EXP_ORIGINAL_CODE (expr
) == MODIFY_EXPR
)
15601 warning ("suggest parentheses around assignment used as truth value");
15609 if (TREE_CODE (TREE_TYPE (expr
)) == COMPLEX_TYPE
)
15611 ((TREE_SIDE_EFFECTS (expr
)
15612 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
15614 truthvalue_conversion (ffecom_1 (REALPART_EXPR
,
15615 TREE_TYPE (TREE_TYPE (expr
)),
15617 truthvalue_conversion (ffecom_1 (IMAGPART_EXPR
,
15618 TREE_TYPE (TREE_TYPE (expr
)),
15621 return ffecom_2 (NE_EXPR
, integer_type_node
,
15623 convert (TREE_TYPE (expr
), integer_zero_node
));
15627 type_for_mode (mode
, unsignedp
)
15628 enum machine_mode mode
;
15635 if (mode
== TYPE_MODE (integer_type_node
))
15636 return unsignedp
? unsigned_type_node
: integer_type_node
;
15638 if (mode
== TYPE_MODE (signed_char_type_node
))
15639 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15641 if (mode
== TYPE_MODE (short_integer_type_node
))
15642 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15644 if (mode
== TYPE_MODE (long_integer_type_node
))
15645 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15647 if (mode
== TYPE_MODE (long_long_integer_type_node
))
15648 return unsignedp
? long_long_unsigned_type_node
: long_long_integer_type_node
;
15650 if (mode
== TYPE_MODE (float_type_node
))
15651 return float_type_node
;
15653 if (mode
== TYPE_MODE (double_type_node
))
15654 return double_type_node
;
15656 if (mode
== TYPE_MODE (build_pointer_type (char_type_node
)))
15657 return build_pointer_type (char_type_node
);
15659 if (mode
== TYPE_MODE (build_pointer_type (integer_type_node
)))
15660 return build_pointer_type (integer_type_node
);
15662 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
15663 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
15665 if (((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
15666 && (mode
== TYPE_MODE (t
)))
15668 if ((i
== FFEINFO_basictypeINTEGER
) && unsignedp
)
15669 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][j
];
15679 type_for_size (bits
, unsignedp
)
15683 ffeinfoKindtype kt
;
15686 if (bits
== TYPE_PRECISION (integer_type_node
))
15687 return unsignedp
? unsigned_type_node
: integer_type_node
;
15689 if (bits
== TYPE_PRECISION (signed_char_type_node
))
15690 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15692 if (bits
== TYPE_PRECISION (short_integer_type_node
))
15693 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15695 if (bits
== TYPE_PRECISION (long_integer_type_node
))
15696 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15698 if (bits
== TYPE_PRECISION (long_long_integer_type_node
))
15699 return (unsignedp
? long_long_unsigned_type_node
15700 : long_long_integer_type_node
);
15702 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15704 type_node
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15706 if ((type_node
!= NULL_TREE
) && (bits
== TYPE_PRECISION (type_node
)))
15707 return unsignedp
? ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
]
15715 unsigned_type (type
)
15718 tree type1
= TYPE_MAIN_VARIANT (type
);
15719 ffeinfoKindtype kt
;
15722 if (type1
== signed_char_type_node
|| type1
== char_type_node
)
15723 return unsigned_char_type_node
;
15724 if (type1
== integer_type_node
)
15725 return unsigned_type_node
;
15726 if (type1
== short_integer_type_node
)
15727 return short_unsigned_type_node
;
15728 if (type1
== long_integer_type_node
)
15729 return long_unsigned_type_node
;
15730 if (type1
== long_long_integer_type_node
)
15731 return long_long_unsigned_type_node
;
15732 #if 0 /* gcc/c-* files only */
15733 if (type1
== intDI_type_node
)
15734 return unsigned_intDI_type_node
;
15735 if (type1
== intSI_type_node
)
15736 return unsigned_intSI_type_node
;
15737 if (type1
== intHI_type_node
)
15738 return unsigned_intHI_type_node
;
15739 if (type1
== intQI_type_node
)
15740 return unsigned_intQI_type_node
;
15743 type2
= type_for_size (TYPE_PRECISION (type1
), 1);
15744 if (type2
!= NULL_TREE
)
15747 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15749 type2
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15751 if (type1
== type2
)
15752 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
15758 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15760 #if FFECOM_GCC_INCLUDE
15762 /* From gcc/cccp.c, the code to handle -I. */
15764 /* Skip leading "./" from a directory name.
15765 This may yield the empty string, which represents the current directory. */
15768 skip_redundant_dir_prefix (char *dir
)
15770 while (dir
[0] == '.' && dir
[1] == '/')
15771 for (dir
+= 2; *dir
== '/'; dir
++)
15773 if (dir
[0] == '.' && !dir
[1])
15778 /* The file_name_map structure holds a mapping of file names for a
15779 particular directory. This mapping is read from the file named
15780 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15781 map filenames on a file system with severe filename restrictions,
15782 such as DOS. The format of the file name map file is just a series
15783 of lines with two tokens on each line. The first token is the name
15784 to map, and the second token is the actual name to use. */
15786 struct file_name_map
15788 struct file_name_map
*map_next
;
15793 #define FILE_NAME_MAP_FILE "header.gcc"
15795 /* Current maximum length of directory names in the search path
15796 for include files. (Altered as we get more of them.) */
15798 static int max_include_len
= 0;
15800 struct file_name_list
15802 struct file_name_list
*next
;
15804 /* Mapping of file names for this directory. */
15805 struct file_name_map
*name_map
;
15806 /* Non-zero if name_map is valid. */
15810 static struct file_name_list
*include
= NULL
; /* First dir to search */
15811 static struct file_name_list
*last_include
= NULL
; /* Last in chain */
15813 /* I/O buffer structure.
15814 The `fname' field is nonzero for source files and #include files
15815 and for the dummy text used for -D and -U.
15816 It is zero for rescanning results of macro expansion
15817 and for expanding macro arguments. */
15818 #define INPUT_STACK_MAX 400
15819 static struct file_buf
{
15821 /* Filename specified with #line command. */
15822 char *nominal_fname
;
15823 /* Record where in the search path this file was found.
15824 For #include_next. */
15825 struct file_name_list
*dir
;
15827 ffewhereColumn column
;
15828 } instack
[INPUT_STACK_MAX
];
15830 static int last_error_tick
= 0; /* Incremented each time we print it. */
15831 static int input_file_stack_tick
= 0; /* Incremented when status changes. */
15833 /* Current nesting level of input sources.
15834 `instack[indepth]' is the level currently being read. */
15835 static int indepth
= -1;
15837 typedef struct file_buf FILE_BUF
;
15839 typedef unsigned char U_CHAR
;
15841 /* table to tell if char can be part of a C identifier. */
15842 U_CHAR is_idchar
[256];
15843 /* table to tell if char can be first char of a c identifier. */
15844 U_CHAR is_idstart
[256];
15845 /* table to tell if c is horizontal space. */
15846 U_CHAR is_hor_space
[256];
15847 /* table to tell if c is horizontal or vertical space. */
15848 static U_CHAR is_space
[256];
15850 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15851 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15853 /* Nonzero means -I- has been seen,
15854 so don't look for #include "foo" the source-file directory. */
15855 static int ignore_srcdir
;
15857 #ifndef INCLUDE_LEN_FUDGE
15858 #define INCLUDE_LEN_FUDGE 0
15861 static void append_include_chain (struct file_name_list
*first
,
15862 struct file_name_list
*last
);
15863 static FILE *open_include_file (char *filename
,
15864 struct file_name_list
*searchptr
);
15865 static void print_containing_files (ffebadSeverity sev
);
15866 static char *skip_redundant_dir_prefix (char *);
15867 static char *read_filename_string (int ch
, FILE *f
);
15868 static struct file_name_map
*read_name_map (char *dirname
);
15869 static char *savestring (char *input
);
15871 /* Append a chain of `struct file_name_list's
15872 to the end of the main include chain.
15873 FIRST is the beginning of the chain to append, and LAST is the end. */
15876 append_include_chain (first
, last
)
15877 struct file_name_list
*first
, *last
;
15879 struct file_name_list
*dir
;
15881 if (!first
|| !last
)
15887 last_include
->next
= first
;
15889 for (dir
= first
; ; dir
= dir
->next
) {
15890 int len
= strlen (dir
->fname
) + INCLUDE_LEN_FUDGE
;
15891 if (len
> max_include_len
)
15892 max_include_len
= len
;
15898 last_include
= last
;
15901 /* Try to open include file FILENAME. SEARCHPTR is the directory
15902 being tried from the include file search path. This function maps
15903 filenames on file systems based on information read by
15907 open_include_file (filename
, searchptr
)
15909 struct file_name_list
*searchptr
;
15911 register struct file_name_map
*map
;
15912 register char *from
;
15915 if (searchptr
&& ! searchptr
->got_name_map
)
15917 searchptr
->name_map
= read_name_map (searchptr
->fname
15918 ? searchptr
->fname
: ".");
15919 searchptr
->got_name_map
= 1;
15922 /* First check the mapping for the directory we are using. */
15923 if (searchptr
&& searchptr
->name_map
)
15926 if (searchptr
->fname
)
15927 from
+= strlen (searchptr
->fname
) + 1;
15928 for (map
= searchptr
->name_map
; map
; map
= map
->map_next
)
15930 if (! strcmp (map
->map_from
, from
))
15932 /* Found a match. */
15933 return fopen (map
->map_to
, "r");
15938 /* Try to find a mapping file for the particular directory we are
15939 looking in. Thus #include <sys/types.h> will look up sys/types.h
15940 in /usr/include/header.gcc and look up types.h in
15941 /usr/include/sys/header.gcc. */
15942 p
= rindex (filename
, '/');
15943 #ifdef DIR_SEPARATOR
15944 if (! p
) p
= rindex (filename
, DIR_SEPARATOR
);
15946 char *tmp
= rindex (filename
, DIR_SEPARATOR
);
15947 if (tmp
!= NULL
&& tmp
> p
) p
= tmp
;
15953 && searchptr
->fname
15954 && strlen (searchptr
->fname
) == (size_t) (p
- filename
)
15955 && ! strncmp (searchptr
->fname
, filename
, (int) (p
- filename
)))
15957 /* FILENAME is in SEARCHPTR, which we've already checked. */
15958 return fopen (filename
, "r");
15964 map
= read_name_map (".");
15968 dir
= (char *) xmalloc (p
- filename
+ 1);
15969 memcpy (dir
, filename
, p
- filename
);
15970 dir
[p
- filename
] = '\0';
15972 map
= read_name_map (dir
);
15975 for (; map
; map
= map
->map_next
)
15976 if (! strcmp (map
->map_from
, from
))
15977 return fopen (map
->map_to
, "r");
15979 return fopen (filename
, "r");
15982 /* Print the file names and line numbers of the #include
15983 commands which led to the current file. */
15986 print_containing_files (ffebadSeverity sev
)
15988 FILE_BUF
*ip
= NULL
;
15994 /* If stack of files hasn't changed since we last printed
15995 this info, don't repeat it. */
15996 if (last_error_tick
== input_file_stack_tick
)
15999 for (i
= indepth
; i
>= 0; i
--)
16000 if (instack
[i
].fname
!= NULL
) {
16005 /* Give up if we don't find a source file. */
16009 /* Find the other, outer source files. */
16010 for (i
--; i
>= 0; i
--)
16011 if (instack
[i
].fname
!= NULL
)
16017 str1
= "In file included";
16029 ffebad_start_msg ("%A from %B at %0%C", sev
);
16030 ffebad_here (0, ip
->line
, ip
->column
);
16031 ffebad_string (str1
);
16032 ffebad_string (ip
->nominal_fname
);
16033 ffebad_string (str2
);
16037 /* Record we have printed the status as of this time. */
16038 last_error_tick
= input_file_stack_tick
;
16041 /* Read a space delimited string of unlimited length from a stdio
16045 read_filename_string (ch
, f
)
16053 set
= alloc
= xmalloc (len
+ 1);
16054 if (! is_space
[ch
])
16057 while ((ch
= getc (f
)) != EOF
&& ! is_space
[ch
])
16059 if (set
- alloc
== len
)
16062 alloc
= xrealloc (alloc
, len
+ 1);
16063 set
= alloc
+ len
/ 2;
16073 /* Read the file name map file for DIRNAME. */
16075 static struct file_name_map
*
16076 read_name_map (dirname
)
16079 /* This structure holds a linked list of file name maps, one per
16081 struct file_name_map_list
16083 struct file_name_map_list
*map_list_next
;
16084 char *map_list_name
;
16085 struct file_name_map
*map_list_map
;
16087 static struct file_name_map_list
*map_list
;
16088 register struct file_name_map_list
*map_list_ptr
;
16092 int separator_needed
;
16094 dirname
= skip_redundant_dir_prefix (dirname
);
16096 for (map_list_ptr
= map_list
; map_list_ptr
;
16097 map_list_ptr
= map_list_ptr
->map_list_next
)
16098 if (! strcmp (map_list_ptr
->map_list_name
, dirname
))
16099 return map_list_ptr
->map_list_map
;
16101 map_list_ptr
= ((struct file_name_map_list
*)
16102 xmalloc (sizeof (struct file_name_map_list
)));
16103 map_list_ptr
->map_list_name
= savestring (dirname
);
16104 map_list_ptr
->map_list_map
= NULL
;
16106 dirlen
= strlen (dirname
);
16107 separator_needed
= dirlen
!= 0 && dirname
[dirlen
- 1] != '/';
16108 name
= (char *) xmalloc (dirlen
+ strlen (FILE_NAME_MAP_FILE
) + 2);
16109 strcpy (name
, dirname
);
16110 name
[dirlen
] = '/';
16111 strcpy (name
+ dirlen
+ separator_needed
, FILE_NAME_MAP_FILE
);
16112 f
= fopen (name
, "r");
16115 map_list_ptr
->map_list_map
= NULL
;
16120 while ((ch
= getc (f
)) != EOF
)
16123 struct file_name_map
*ptr
;
16127 from
= read_filename_string (ch
, f
);
16128 while ((ch
= getc (f
)) != EOF
&& is_hor_space
[ch
])
16130 to
= read_filename_string (ch
, f
);
16132 ptr
= ((struct file_name_map
*)
16133 xmalloc (sizeof (struct file_name_map
)));
16134 ptr
->map_from
= from
;
16136 /* Make the real filename absolute. */
16141 ptr
->map_to
= xmalloc (dirlen
+ strlen (to
) + 2);
16142 strcpy (ptr
->map_to
, dirname
);
16143 ptr
->map_to
[dirlen
] = '/';
16144 strcpy (ptr
->map_to
+ dirlen
+ separator_needed
, to
);
16148 ptr
->map_next
= map_list_ptr
->map_list_map
;
16149 map_list_ptr
->map_list_map
= ptr
;
16151 while ((ch
= getc (f
)) != '\n')
16158 map_list_ptr
->map_list_next
= map_list
;
16159 map_list
= map_list_ptr
;
16161 return map_list_ptr
->map_list_map
;
16168 unsigned size
= strlen (input
);
16169 char *output
= xmalloc (size
+ 1);
16170 strcpy (output
, input
);
16175 ffecom_file_ (char *name
)
16179 /* Do partial setup of input buffer for the sake of generating
16180 early #line directives (when -g is in effect). */
16182 fp
= &instack
[++indepth
];
16183 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
16186 fp
->nominal_fname
= fp
->fname
= name
;
16189 /* Initialize syntactic classifications of characters. */
16192 ffecom_initialize_char_syntax_ ()
16197 * Set up is_idchar and is_idstart tables. These should be
16198 * faster than saying (is_alpha (c) || c == '_'), etc.
16199 * Set up these things before calling any routines tthat
16202 for (i
= 'a'; i
<= 'z'; i
++) {
16203 is_idchar
[i
- 'a' + 'A'] = 1;
16205 is_idstart
[i
- 'a' + 'A'] = 1;
16208 for (i
= '0'; i
<= '9'; i
++)
16210 is_idchar
['_'] = 1;
16211 is_idstart
['_'] = 1;
16213 /* horizontal space table */
16214 is_hor_space
[' '] = 1;
16215 is_hor_space
['\t'] = 1;
16216 is_hor_space
['\v'] = 1;
16217 is_hor_space
['\f'] = 1;
16218 is_hor_space
['\r'] = 1;
16221 is_space
['\t'] = 1;
16222 is_space
['\v'] = 1;
16223 is_space
['\f'] = 1;
16224 is_space
['\n'] = 1;
16225 is_space
['\r'] = 1;
16229 ffecom_close_include_ (FILE *f
)
16234 input_file_stack_tick
++;
16236 ffewhere_line_kill (instack
[indepth
].line
);
16237 ffewhere_column_kill (instack
[indepth
].column
);
16241 ffecom_decode_include_option_ (char *spec
)
16243 struct file_name_list
*dirtmp
;
16245 if (! ignore_srcdir
&& !strcmp (spec
, "-"))
16249 dirtmp
= (struct file_name_list
*)
16250 xmalloc (sizeof (struct file_name_list
));
16251 dirtmp
->next
= 0; /* New one goes on the end */
16253 dirtmp
->fname
= spec
;
16255 fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16256 dirtmp
->got_name_map
= 0;
16257 append_include_chain (dirtmp
, dirtmp
);
16262 /* Open INCLUDEd file. */
16265 ffecom_open_include_ (char *name
, ffewhereLine l
, ffewhereColumn c
)
16268 size_t flen
= strlen (fbeg
);
16269 struct file_name_list
*search_start
= include
; /* Chain of dirs to search */
16270 struct file_name_list dsp
[1]; /* First in chain, if #include "..." */
16271 struct file_name_list
*searchptr
= 0;
16272 char *fname
; /* Dynamically allocated fname buffer */
16279 dsp
[0].fname
= NULL
;
16281 /* If -I- was specified, don't search current dir, only spec'd ones. */
16282 if (!ignore_srcdir
)
16284 for (fp
= &instack
[indepth
]; fp
>= instack
; fp
--)
16290 if ((nam
= fp
->nominal_fname
) != NULL
)
16292 /* Found a named file. Figure out dir of the file,
16293 and put it in front of the search list. */
16294 dsp
[0].next
= search_start
;
16295 search_start
= dsp
;
16297 ep
= rindex (nam
, '/');
16298 #ifdef DIR_SEPARATOR
16299 if (ep
== NULL
) ep
= rindex (nam
, DIR_SEPARATOR
);
16301 char *tmp
= rindex (nam
, DIR_SEPARATOR
);
16302 if (tmp
!= NULL
&& tmp
> ep
) ep
= tmp
;
16306 ep
= rindex (nam
, ']');
16307 if (ep
== NULL
) ep
= rindex (nam
, '>');
16308 if (ep
== NULL
) ep
= rindex (nam
, ':');
16309 if (ep
!= NULL
) ep
++;
16314 dsp
[0].fname
= (char *) xmalloc (n
+ 1);
16315 strncpy (dsp
[0].fname
, nam
, n
);
16316 dsp
[0].fname
[n
] = '\0';
16317 if (n
+ INCLUDE_LEN_FUDGE
> max_include_len
)
16318 max_include_len
= n
+ INCLUDE_LEN_FUDGE
;
16321 dsp
[0].fname
= NULL
; /* Current directory */
16322 dsp
[0].got_name_map
= 0;
16328 /* Allocate this permanently, because it gets stored in the definitions
16330 fname
= xmalloc (max_include_len
+ flen
+ 4);
16331 /* + 2 above for slash and terminating null. */
16332 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16335 /* If specified file name is absolute, just open it. */
16338 #ifdef DIR_SEPARATOR
16339 || *fbeg
== DIR_SEPARATOR
16343 strncpy (fname
, (char *) fbeg
, flen
);
16345 f
= open_include_file (fname
, NULL_PTR
);
16351 /* Search directory path, trying to open the file.
16352 Copy each filename tried into FNAME. */
16354 for (searchptr
= search_start
; searchptr
; searchptr
= searchptr
->next
)
16356 if (searchptr
->fname
)
16358 /* The empty string in a search path is ignored.
16359 This makes it possible to turn off entirely
16360 a standard piece of the list. */
16361 if (searchptr
->fname
[0] == 0)
16363 strcpy (fname
, skip_redundant_dir_prefix (searchptr
->fname
));
16364 if (fname
[0] && fname
[strlen (fname
) - 1] != '/')
16365 strcat (fname
, "/");
16366 fname
[strlen (fname
) + flen
] = 0;
16371 strncat (fname
, fbeg
, flen
);
16373 /* Change this 1/2 Unix 1/2 VMS file specification into a
16374 full VMS file specification */
16375 if (searchptr
->fname
&& (searchptr
->fname
[0] != 0))
16377 /* Fix up the filename */
16378 hack_vms_include_specification (fname
);
16382 /* This is a normal VMS filespec, so use it unchanged. */
16383 strncpy (fname
, (char *) fbeg
, flen
);
16385 #if 0 /* Not for g77. */
16386 /* if it's '#include filename', add the missing .h */
16387 if (index (fname
, '.') == NULL
)
16388 strcat (fname
, ".h");
16392 f
= open_include_file (fname
, searchptr
);
16394 if (f
== NULL
&& errno
== EACCES
)
16396 print_containing_files (FFEBAD_severityWARNING
);
16397 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16398 FFEBAD_severityWARNING
);
16399 ffebad_string (fname
);
16400 ffebad_here (0, l
, c
);
16411 /* A file that was not found. */
16413 strncpy (fname
, (char *) fbeg
, flen
);
16415 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE
));
16416 ffebad_start (FFEBAD_OPEN_INCLUDE
);
16417 ffebad_here (0, l
, c
);
16418 ffebad_string (fname
);
16422 if (dsp
[0].fname
!= NULL
)
16423 free (dsp
[0].fname
);
16428 if (indepth
>= (INPUT_STACK_MAX
- 1))
16430 print_containing_files (FFEBAD_severityFATAL
);
16431 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16432 FFEBAD_severityFATAL
);
16433 ffebad_string (fname
);
16434 ffebad_here (0, l
, c
);
16439 instack
[indepth
].line
= ffewhere_line_use (l
);
16440 instack
[indepth
].column
= ffewhere_column_use (c
);
16442 fp
= &instack
[indepth
+ 1];
16443 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
16444 fp
->nominal_fname
= fp
->fname
= fname
;
16445 fp
->dir
= searchptr
;
16448 input_file_stack_tick
++;
16452 #endif /* FFECOM_GCC_INCLUDE */