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.ai.mit.edu).
5 This file is part of GNU Fortran.
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
26 Contains compiler-specific functions.
31 /* Understanding this module means understanding the interface between
32 the g77 front end and the gcc back end (or, perhaps, some other
33 back end). In here are the functions called by the front end proper
34 to notify whatever back end is in place about certain things, and
35 also the back-end-specific functions. It's a bear to deal with, so
36 lately I've been trying to simplify things, especially with regard
37 to the gcc-back-end-specific stuff.
39 Building expressions generally seems quite easy, but building decls
40 has been challenging and is undergoing revision. gcc has several
43 TYPE_DECL -- a type (int, float, struct, function, etc.)
44 CONST_DECL -- a constant of some type other than function
45 LABEL_DECL -- a variable or a constant?
46 PARM_DECL -- an argument to a function (a variable that is a dummy)
47 RESULT_DECL -- the return value of a function (a variable)
48 VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
49 FUNCTION_DECL -- a function (either the actual function or an extern ref)
50 FIELD_DECL -- a field in a struct or union (goes into types)
52 g77 has a set of functions that somewhat parallels the gcc front end
53 when it comes to building decls:
55 Internal Function (one we define, not just declare as extern):
57 yes = suspend_momentary ();
58 if (is_nested) push_f_function_context ();
59 start_function (get_identifier ("function_name"), function_type,
60 is_nested, is_public);
61 // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
62 store_parm_decls (is_main_program);
63 ffecom_start_compstmt_ ();
64 // for stmts and decls inside function, do appropriate things;
65 ffecom_end_compstmt_ ();
66 finish_function (is_nested);
67 if (is_nested) pop_f_function_context ();
68 if (is_nested) resume_momentary (yes);
74 yes = suspend_momentary ();
75 // fill in external, public, static, &c for decl, and
76 // set DECL_INITIAL to error_mark_node if going to initialize
77 // set is_top_level TRUE only if not at top level and decl
78 // must go in top level (i.e. not within current function decl context)
79 d = start_decl (decl, is_top_level);
80 init = ...; // if have initializer
81 finish_decl (d, init, is_top_level);
82 resume_momentary (yes);
88 #if FFECOM_targetCURRENT == FFECOM_targetGCC
94 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
96 #define FFECOM_GCC_INCLUDE 1 /* Enable -I. */
98 /* BEGIN stuff from gcc/cccp.c. */
100 /* The following symbols should be autoconfigured:
107 In the mean time, we'll get by with approximations based
108 on existing GCC configuration symbols. */
111 # ifndef HAVE_STDLIB_H
112 # define HAVE_STDLIB_H 1
114 # ifndef HAVE_UNISTD_H
115 # define HAVE_UNISTD_H 1
117 # ifndef STDC_HEADERS
118 # define STDC_HEADERS 1
120 #endif /* defined (POSIX) */
122 #if defined (POSIX) || (defined (USG) && !defined (VMS))
123 # ifndef HAVE_FCNTL_H
124 # define HAVE_FCNTL_H 1
131 # if TIME_WITH_SYS_TIME
132 # include <sys/time.h>
136 # include <sys/time.h>
141 # include <sys/resource.h>
148 /* This defines "errno" properly for VMS, and gives us EACCES. */
164 /* VMS-specific definitions */
167 #define O_RDONLY 0 /* Open arg for Read/Only */
168 #define O_WRONLY 1 /* Open arg for Write/Only */
169 #define read(fd,buf,size) VMS_read (fd,buf,size)
170 #define write(fd,buf,size) VMS_write (fd,buf,size)
171 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
172 #define fopen(fname,mode) VMS_fopen (fname,mode)
173 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
174 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
175 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
176 static int VMS_fstat (), VMS_stat ();
177 static char * VMS_strncat ();
178 static int VMS_read ();
179 static int VMS_write ();
180 static int VMS_open ();
181 static FILE * VMS_fopen ();
182 static FILE * VMS_freopen ();
183 static void hack_vms_include_specification ();
184 typedef struct { unsigned :16, :16, :16; } vms_ino_t
;
185 #define ino_t vms_ino_t
186 #define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */
188 #define BSTRING /* VMS/GCC supplies the bstring routines */
189 #endif /* __GNUC__ */
196 /* END stuff from gcc/cccp.c. */
199 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
216 /* Externals defined here. */
218 #define FFECOM_FASTER_ARRAY_REFS 0 /* Generates faster code? */
220 #if FFECOM_targetCURRENT == FFECOM_targetGCC
222 /* tree.h declares a bunch of stuff that it expects the front end to
223 define. Here are the definitions, which in the C front end are
224 found in the file c-decl.c. */
226 tree integer_zero_node
;
227 tree integer_one_node
;
228 tree null_pointer_node
;
229 tree error_mark_node
;
231 tree integer_type_node
;
232 tree unsigned_type_node
;
234 tree current_function_decl
;
236 /* ~~tree.h SHOULD declare this, because toplev.c and dwarfout.c reference
239 char *language_string
= "GNU F77";
241 /* 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 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
952 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
953 return fold (ffecom_convert_to_complex_ (type
, e
));
956 assert ("conversion to non-scalar type requested" == NULL
);
957 return error_mark_node
;
961 /* Like gcc's convert(), but crashes if narrowing might happen. */
963 #if FFECOM_targetCURRENT == FFECOM_targetGCC
965 ffecom_convert_widen_ (type
, expr
)
968 register tree e
= expr
;
969 register enum tree_code code
= TREE_CODE (type
);
971 if (type
== TREE_TYPE (e
)
972 || TREE_CODE (e
) == ERROR_MARK
)
974 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
975 return fold (build1 (NOP_EXPR
, type
, e
));
976 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
977 || code
== ERROR_MARK
)
978 return error_mark_node
;
979 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
981 assert ("void value not ignored as it ought to be" == NULL
);
982 return error_mark_node
;
984 assert (code
!= VOID_TYPE
);
985 if ((code
!= RECORD_TYPE
)
986 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
987 assert ("narrowing COMPLEX to REAL" == NULL
);
988 assert (code
!= ENUMERAL_TYPE
);
989 if (code
== INTEGER_TYPE
)
991 assert (TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
);
992 assert (TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)));
993 return fold (convert_to_integer (type
, e
));
995 if (code
== POINTER_TYPE
)
997 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
998 return fold (convert_to_pointer (type
, e
));
1000 if (code
== REAL_TYPE
)
1002 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1003 assert (TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)));
1004 return fold (convert_to_real (type
, e
));
1006 if (code
== COMPLEX_TYPE
)
1008 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1009 assert (TYPE_PRECISION (TREE_TYPE (type
)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1010 return fold (convert_to_complex (type
, e
));
1012 if (code
== RECORD_TYPE
)
1014 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1015 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1016 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1017 return fold (ffecom_convert_to_complex_ (type
, e
));
1020 assert ("conversion to non-scalar type requested" == NULL
);
1021 return error_mark_node
;
1025 /* Handles making a COMPLEX type, either the standard
1026 (but buggy?) gbe way, or the safer (but less elegant?)
1029 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1031 ffecom_make_complex_type_ (tree subtype
)
1037 if (ffe_is_emulate_complex ())
1039 type
= make_node (RECORD_TYPE
);
1040 realfield
= ffecom_decl_field (type
, NULL_TREE
, "r", subtype
);
1041 imagfield
= ffecom_decl_field (type
, realfield
, "i", subtype
);
1042 TYPE_FIELDS (type
) = realfield
;
1047 type
= make_node (COMPLEX_TYPE
);
1048 TREE_TYPE (type
) = subtype
;
1056 /* Chooses either the gbe or the f2c way to build a
1057 complex constant. */
1059 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1061 ffecom_build_complex_constant_ (tree type
, tree realpart
, tree imagpart
)
1065 if (ffe_is_emulate_complex ())
1067 bothparts
= build_tree_list (TYPE_FIELDS (type
), realpart
);
1068 TREE_CHAIN (bothparts
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), imagpart
);
1069 bothparts
= build (CONSTRUCTOR
, type
, NULL_TREE
, bothparts
);
1073 bothparts
= build_complex (type
, realpart
, imagpart
);
1080 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1082 ffecom_arglist_expr_ (char *c
, ffebld expr
)
1085 tree
*plist
= &list
;
1086 tree trail
= NULL_TREE
; /* Append char length args here. */
1087 tree
*ptrail
= &trail
;
1092 tree wanted
= NULL_TREE
;
1093 static char zed
[] = "0";
1098 while (expr
!= NULL
)
1121 wanted
= ffecom_f2c_complex_type_node
;
1125 wanted
= ffecom_f2c_doublereal_type_node
;
1129 wanted
= ffecom_f2c_doublecomplex_type_node
;
1133 wanted
= ffecom_f2c_real_type_node
;
1137 wanted
= ffecom_f2c_integer_type_node
;
1141 wanted
= ffecom_f2c_longint_type_node
;
1145 assert ("bad argstring code" == NULL
);
1151 exprh
= ffebld_head (expr
);
1155 if ((wanted
== NULL_TREE
)
1158 (ffecom_tree_type
[ffeinfo_basictype (ffebld_info (exprh
))]
1159 [ffeinfo_kindtype (ffebld_info (exprh
))])
1160 == TYPE_MODE (wanted
))))
1162 = build_tree_list (NULL_TREE
,
1163 ffecom_arg_ptr_to_expr (exprh
,
1167 item
= ffecom_arg_expr (exprh
, &length
);
1168 item
= ffecom_convert_widen_ (wanted
, item
);
1171 item
= ffecom_1 (ADDR_EXPR
,
1172 build_pointer_type (TREE_TYPE (item
)),
1176 = build_tree_list (NULL_TREE
,
1180 plist
= &TREE_CHAIN (*plist
);
1181 expr
= ffebld_trail (expr
);
1182 if (length
!= NULL_TREE
)
1184 *ptrail
= build_tree_list (NULL_TREE
, length
);
1185 ptrail
= &TREE_CHAIN (*ptrail
);
1189 /* We've run out of args in the call; if the implementation expects
1190 more, supply null pointers for them, which the implementation can
1191 check to see if an arg was omitted. */
1193 while (*c
!= '\0' && *c
!= '0')
1198 assert ("missing arg to run-time routine!" == NULL
);
1213 assert ("bad arg string code" == NULL
);
1217 = build_tree_list (NULL_TREE
,
1219 plist
= &TREE_CHAIN (*plist
);
1228 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1230 ffecom_widest_expr_type_ (ffebld list
)
1233 ffebld widest
= NULL
;
1235 ffetype widest_type
= NULL
;
1238 for (; list
!= NULL
; list
= ffebld_trail (list
))
1240 item
= ffebld_head (list
);
1243 if ((widest
!= NULL
)
1244 && (ffeinfo_basictype (ffebld_info (item
))
1245 != ffeinfo_basictype (ffebld_info (widest
))))
1247 type
= ffeinfo_type (ffeinfo_basictype (ffebld_info (item
)),
1248 ffeinfo_kindtype (ffebld_info (item
)));
1249 if ((widest
== FFEINFO_kindtypeNONE
)
1250 || (ffetype_size (type
)
1251 > ffetype_size (widest_type
)))
1258 assert (widest
!= NULL
);
1259 t
= ffecom_tree_type
[ffeinfo_basictype (ffebld_info (widest
))]
1260 [ffeinfo_kindtype (ffebld_info (widest
))];
1261 assert (t
!= NULL_TREE
);
1266 /* Check whether dest and source might overlap. ffebld versions of these
1267 might or might not be passed, will be NULL if not.
1269 The test is really whether source_tree is modifiable and, if modified,
1270 might overlap destination such that the value(s) in the destination might
1271 change before it is finally modified. dest_* are the canonized
1272 destination itself. */
1274 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1276 ffecom_overlap_ (tree dest_decl
, tree dest_offset
, tree dest_size
,
1277 tree source_tree
, ffebld source UNUSED
,
1285 if (source_tree
== NULL_TREE
)
1288 switch (TREE_CODE (source_tree
))
1291 case IDENTIFIER_NODE
:
1302 case TRUNC_DIV_EXPR
:
1304 case FLOOR_DIV_EXPR
:
1305 case ROUND_DIV_EXPR
:
1306 case TRUNC_MOD_EXPR
:
1308 case FLOOR_MOD_EXPR
:
1309 case ROUND_MOD_EXPR
:
1311 case EXACT_DIV_EXPR
:
1312 case FIX_TRUNC_EXPR
:
1314 case FIX_FLOOR_EXPR
:
1315 case FIX_ROUND_EXPR
:
1330 case BIT_ANDTC_EXPR
:
1332 case TRUTH_ANDIF_EXPR
:
1333 case TRUTH_ORIF_EXPR
:
1334 case TRUTH_AND_EXPR
:
1336 case TRUTH_XOR_EXPR
:
1337 case TRUTH_NOT_EXPR
:
1353 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1354 TREE_OPERAND (source_tree
, 1), NULL
,
1358 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1359 TREE_OPERAND (source_tree
, 0), NULL
,
1364 case NON_LVALUE_EXPR
:
1366 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1369 ffecom_tree_canonize_ptr_ (&source_decl
, &source_offset
,
1371 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1376 ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1377 TREE_OPERAND (source_tree
, 1), NULL
,
1379 || ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1380 TREE_OPERAND (source_tree
, 2), NULL
,
1385 ffecom_tree_canonize_ref_ (&source_decl
, &source_offset
,
1387 TREE_OPERAND (source_tree
, 0));
1391 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1394 source_decl
= source_tree
;
1395 source_offset
= size_zero_node
;
1396 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1400 case REFERENCE_EXPR
:
1401 case PREDECREMENT_EXPR
:
1402 case PREINCREMENT_EXPR
:
1403 case POSTDECREMENT_EXPR
:
1404 case POSTINCREMENT_EXPR
:
1412 /* Come here when source_decl, source_offset, and source_size filled
1413 in appropriately. */
1415 if (source_decl
== NULL_TREE
)
1416 return FALSE
; /* No decl involved, so no overlap. */
1418 if (source_decl
!= dest_decl
)
1419 return FALSE
; /* Different decl, no overlap. */
1421 if (TREE_CODE (dest_size
) == ERROR_MARK
)
1422 return TRUE
; /* Assignment into entire assumed-size
1423 array? Shouldn't happen.... */
1425 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1426 ffecom_2 (PLUS_EXPR
, TREE_TYPE (dest_offset
),
1428 convert (TREE_TYPE (dest_offset
),
1430 convert (TREE_TYPE (dest_offset
),
1433 if (integer_onep (t
))
1434 return FALSE
; /* Destination precedes source. */
1437 || (source_size
== NULL_TREE
)
1438 || (TREE_CODE (source_size
) == ERROR_MARK
)
1439 || integer_zerop (source_size
))
1440 return TRUE
; /* No way to tell if dest follows source. */
1442 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1443 ffecom_2 (PLUS_EXPR
, TREE_TYPE (source_offset
),
1445 convert (TREE_TYPE (source_offset
),
1447 convert (TREE_TYPE (source_offset
),
1450 if (integer_onep (t
))
1451 return FALSE
; /* Destination follows source. */
1453 return TRUE
; /* Destination and source overlap. */
1457 /* Check whether dest might overlap any of a list of arguments or is
1458 in a COMMON area the callee might know about (and thus modify). */
1460 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1462 ffecom_args_overlapping_ (tree dest_tree
, ffebld dest UNUSED
,
1463 tree args
, tree callee_commons
,
1471 ffecom_tree_canonize_ref_ (&dest_decl
, &dest_offset
, &dest_size
,
1474 if (dest_decl
== NULL_TREE
)
1475 return FALSE
; /* Seems unlikely! */
1477 /* If the decl cannot be determined reliably, or if its in COMMON
1478 and the callee isn't known to not futz with COMMON via other
1479 means, overlap might happen. */
1481 if ((TREE_CODE (dest_decl
) == ERROR_MARK
)
1482 || ((callee_commons
!= NULL_TREE
)
1483 && TREE_PUBLIC (dest_decl
)))
1486 for (; args
!= NULL_TREE
; args
= TREE_CHAIN (args
))
1488 if (((arg
= TREE_VALUE (args
)) != NULL_TREE
)
1489 && ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1490 arg
, NULL
, scalar_args
))
1498 /* Build a string for a variable name as used by NAMELIST. This means that
1499 if we're using the f2c library, we build an uppercase string, since
1502 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1504 ffecom_build_f2c_string_ (int i
, char *s
)
1506 if (!ffe_is_f2c_library ())
1507 return build_string (i
, s
);
1516 if (((size_t) i
) > ARRAY_SIZE (space
))
1517 tmp
= malloc_new_ks (malloc_pool_image (), "f2c_string", i
);
1521 for (p
= s
, q
= tmp
; *p
!= '\0'; ++p
, ++q
)
1522 *q
= ffesrc_toupper (*p
);
1525 t
= build_string (i
, tmp
);
1527 if (((size_t) i
) > ARRAY_SIZE (space
))
1528 malloc_kill_ks (malloc_pool_image (), tmp
, i
);
1535 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1536 type to just get whatever the function returns), handling the
1537 f2c value-returning convention, if required, by prepending
1538 to the arglist a pointer to a temporary to receive the return value. */
1540 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1542 ffecom_call_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1543 tree type
, tree args
, tree dest_tree
,
1544 ffebld dest
, bool *dest_used
, tree callee_commons
,
1550 if (dest_used
!= NULL
)
1555 if ((dest_used
== NULL
)
1557 || (ffeinfo_basictype (ffebld_info (dest
))
1558 != FFEINFO_basictypeCOMPLEX
)
1559 || (ffeinfo_kindtype (ffebld_info (dest
)) != kt
)
1560 || ((type
!= NULL_TREE
) && (TREE_TYPE (dest_tree
) != type
))
1561 || ffecom_args_overlapping_ (dest_tree
, dest
, args
,
1565 tempvar
= ffecom_push_tempvar (ffecom_tree_type
1566 [FFEINFO_basictypeCOMPLEX
][kt
],
1567 FFETARGET_charactersizeNONE
,
1573 tempvar
= dest_tree
;
1578 = build_tree_list (NULL_TREE
,
1579 ffecom_1 (ADDR_EXPR
,
1580 build_pointer_type (TREE_TYPE (tempvar
)),
1582 TREE_CHAIN (item
) = args
;
1584 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1587 if (tempvar
!= dest_tree
)
1588 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
, tempvar
);
1591 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1594 if ((type
!= NULL_TREE
) && (TREE_TYPE (item
) != type
))
1595 item
= ffecom_convert_narrow_ (type
, item
);
1601 /* Given two arguments, transform them and make a call to the given
1602 function via ffecom_call_. */
1604 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1606 ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1607 tree type
, ffebld left
, ffebld right
,
1608 tree dest_tree
, ffebld dest
, bool *dest_used
,
1609 tree callee_commons
, bool scalar_args
)
1616 ffecom_push_calltemps ();
1617 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
1618 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
1619 ffecom_pop_calltemps ();
1621 left_tree
= build_tree_list (NULL_TREE
, left_tree
);
1622 right_tree
= build_tree_list (NULL_TREE
, right_tree
);
1623 TREE_CHAIN (left_tree
) = right_tree
;
1625 if (left_length
!= NULL_TREE
)
1627 left_length
= build_tree_list (NULL_TREE
, left_length
);
1628 TREE_CHAIN (right_tree
) = left_length
;
1631 if (right_length
!= NULL_TREE
)
1633 right_length
= build_tree_list (NULL_TREE
, right_length
);
1634 if (left_length
!= NULL_TREE
)
1635 TREE_CHAIN (left_length
) = right_length
;
1637 TREE_CHAIN (right_tree
) = right_length
;
1640 return ffecom_call_ (fn
, kt
, is_f2c_complex
, type
, left_tree
,
1641 dest_tree
, dest
, dest_used
, callee_commons
,
1646 /* ffecom_char_args_x_ -- Return ptr/length args for char subexpression
1652 ffecom_char_args_x_(&ptr_arg,&length_arg,expr,with_null);
1654 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1655 subexpressions by constructing the appropriate trees for the ptr-to-
1656 character-text and length-of-character-text arguments in a calling
1659 Note that if with_null is TRUE, and the expression is an opCONTER,
1660 a null byte is appended to the string. */
1662 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1664 ffecom_char_args_x_ (tree
*xitem
, tree
*length
, ffebld expr
, bool with_null
)
1668 ffetargetCharacter1 val
;
1669 ffetargetCharacterSize newlen
;
1671 switch (ffebld_op (expr
))
1673 case FFEBLD_opCONTER
:
1674 val
= ffebld_constant_character1 (ffebld_conter (expr
));
1675 newlen
= ffetarget_length_character1 (val
);
1679 ++newlen
; /* begin FFETARGET-NULL-KLUDGE. */
1681 *length
= build_int_2 (newlen
, 0);
1682 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1683 high
= build_int_2 (newlen
, 0);
1684 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
1685 item
= build_string (newlen
, /* end FFETARGET-NULL-KLUDGE. */
1686 ffetarget_text_character1 (val
));
1688 = build_type_variant
1692 (ffecom_f2c_ftnlen_type_node
,
1693 ffecom_f2c_ftnlen_one_node
,
1696 TREE_CONSTANT (item
) = 1;
1697 TREE_STATIC (item
) = 1;
1698 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
1702 case FFEBLD_opSYMTER
:
1704 ffesymbol s
= ffebld_symter (expr
);
1706 item
= ffesymbol_hook (s
).decl_tree
;
1707 if (item
== NULL_TREE
)
1709 s
= ffecom_sym_transform_ (s
);
1710 item
= ffesymbol_hook (s
).decl_tree
;
1712 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
1714 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
1715 *length
= ffesymbol_hook (s
).length_tree
;
1718 *length
= build_int_2 (ffesymbol_size (s
), 0);
1719 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1722 else if (item
== error_mark_node
)
1723 *length
= error_mark_node
;
1724 else /* FFEINFO_kindFUNCTION: */
1725 *length
= NULL_TREE
;
1726 if (!ffesymbol_hook (s
).addr
1727 && (item
!= error_mark_node
))
1728 item
= ffecom_1 (ADDR_EXPR
,
1729 build_pointer_type (TREE_TYPE (item
)),
1734 case FFEBLD_opARRAYREF
:
1736 ffebld dims
[FFECOM_dimensionsMAX
];
1740 ffecom_push_calltemps ();
1741 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1742 ffecom_pop_calltemps ();
1744 if (item
== error_mark_node
|| *length
== error_mark_node
)
1746 item
= *length
= error_mark_node
;
1750 /* Build up ARRAY_REFs in reverse order (since we're column major
1751 here in Fortran land). */
1753 for (i
= 0, expr
= ffebld_right (expr
);
1755 expr
= ffebld_trail (expr
))
1756 dims
[i
++] = ffebld_head (expr
);
1758 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
1760 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
1762 item
= ffecom_2 (PLUS_EXPR
, build_pointer_type (TREE_TYPE (array
)),
1764 size_binop (MULT_EXPR
,
1765 size_in_bytes (TREE_TYPE (array
)),
1766 size_binop (MINUS_EXPR
,
1767 ffecom_expr (dims
[i
]),
1768 TYPE_MIN_VALUE (TYPE_DOMAIN (array
)))));
1773 case FFEBLD_opSUBSTR
:
1777 ffebld thing
= ffebld_right (expr
);
1781 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
1782 start
= ffebld_head (thing
);
1783 thing
= ffebld_trail (thing
);
1784 assert (ffebld_trail (thing
) == NULL
);
1785 end
= ffebld_head (thing
);
1787 ffecom_push_calltemps ();
1788 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1789 ffecom_pop_calltemps ();
1791 if (item
== error_mark_node
|| *length
== error_mark_node
)
1793 item
= *length
= error_mark_node
;
1803 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
1806 if (end_tree
== error_mark_node
)
1808 item
= *length
= error_mark_node
;
1817 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
1818 ffecom_expr (start
));
1820 if (start_tree
== error_mark_node
)
1822 item
= *length
= error_mark_node
;
1826 start_tree
= ffecom_save_tree (start_tree
);
1828 item
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (item
),
1830 ffecom_2 (MINUS_EXPR
,
1831 TREE_TYPE (start_tree
),
1833 ffecom_f2c_ftnlen_one_node
));
1837 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
1838 ffecom_f2c_ftnlen_one_node
,
1839 ffecom_2 (MINUS_EXPR
,
1840 ffecom_f2c_ftnlen_type_node
,
1846 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
1849 if (end_tree
== error_mark_node
)
1851 item
= *length
= error_mark_node
;
1855 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
1856 ffecom_f2c_ftnlen_one_node
,
1857 ffecom_2 (MINUS_EXPR
,
1858 ffecom_f2c_ftnlen_type_node
,
1859 end_tree
, start_tree
));
1865 case FFEBLD_opFUNCREF
:
1867 ffesymbol s
= ffebld_symter (ffebld_left (expr
));
1870 ffetargetCharacterSize size
= ffeinfo_size (ffebld_info (expr
));
1873 if (size
== FFETARGET_charactersizeNONE
)
1874 size
= 24; /* ~~~~ Kludge alert! This should someday be fixed. */
1876 *length
= build_int_2 (size
, 0);
1877 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1879 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
1880 == FFEINFO_whereINTRINSIC
)
1883 { /* Invocation of an intrinsic returning CHARACTER*1. */
1884 item
= ffecom_expr_intrinsic_ (expr
, NULL_TREE
,
1888 ix
= ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr
)));
1889 assert (ix
!= FFECOM_gfrt
);
1890 item
= ffecom_gfrt_tree_ (ix
);
1895 item
= ffesymbol_hook (s
).decl_tree
;
1896 if (item
== NULL_TREE
)
1898 s
= ffecom_sym_transform_ (s
);
1899 item
= ffesymbol_hook (s
).decl_tree
;
1901 if (item
== error_mark_node
)
1903 item
= *length
= error_mark_node
;
1907 if (!ffesymbol_hook (s
).addr
)
1908 item
= ffecom_1_fn (item
);
1911 assert (ffecom_pending_calls_
!= 0);
1912 tempvar
= ffecom_push_tempvar (char_type_node
, size
, -1, TRUE
);
1913 tempvar
= ffecom_1 (ADDR_EXPR
,
1914 build_pointer_type (TREE_TYPE (tempvar
)),
1917 ffecom_push_calltemps ();
1919 args
= build_tree_list (NULL_TREE
, tempvar
);
1921 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
) /* Sfunc args by value. */
1922 TREE_CHAIN (args
) = ffecom_list_expr (ffebld_right (expr
));
1925 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, *length
);
1926 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
1928 TREE_CHAIN (TREE_CHAIN (args
))
1929 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix
),
1930 ffebld_right (expr
));
1934 TREE_CHAIN (TREE_CHAIN (args
))
1935 = ffecom_list_ptr_to_expr (ffebld_right (expr
));
1939 item
= ffecom_3s (CALL_EXPR
,
1940 TREE_TYPE (TREE_TYPE (TREE_TYPE (item
))),
1941 item
, args
, NULL_TREE
);
1942 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
,
1945 ffecom_pop_calltemps ();
1949 case FFEBLD_opCONVERT
:
1951 ffecom_push_calltemps ();
1952 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1953 ffecom_pop_calltemps ();
1955 if (item
== error_mark_node
|| *length
== error_mark_node
)
1957 item
= *length
= error_mark_node
;
1961 if ((ffebld_size_known (ffebld_left (expr
))
1962 == FFETARGET_charactersizeNONE
)
1963 || (ffebld_size_known (ffebld_left (expr
)) < (ffebld_size (expr
))))
1964 { /* Possible blank-padding needed, copy into
1970 assert (ffecom_pending_calls_
!= 0);
1971 tempvar
= ffecom_push_tempvar (char_type_node
,
1972 ffebld_size (expr
), -1, TRUE
);
1973 tempvar
= ffecom_1 (ADDR_EXPR
,
1974 build_pointer_type (TREE_TYPE (tempvar
)),
1977 newlen
= build_int_2 (ffebld_size (expr
), 0);
1978 TREE_TYPE (newlen
) = ffecom_f2c_ftnlen_type_node
;
1980 args
= build_tree_list (NULL_TREE
, tempvar
);
1981 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, item
);
1982 TREE_CHAIN (TREE_CHAIN (args
)) = build_tree_list (NULL_TREE
, newlen
);
1983 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args
)))
1984 = build_tree_list (NULL_TREE
, *length
);
1986 item
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, args
);
1987 TREE_SIDE_EFFECTS (item
) = 1;
1988 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), fold (item
),
1993 { /* Just truncate the length. */
1994 *length
= build_int_2 (ffebld_size (expr
), 0);
1995 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2000 assert ("bad op for single char arg expr" == NULL
);
2009 /* Check the size of the type to be sure it doesn't overflow the
2010 "portable" capacities of the compiler back end. `dummy' types
2011 can generally overflow the normal sizes as long as the computations
2012 themselves don't overflow. A particular target of the back end
2013 must still enforce its size requirements, though, and the back
2014 end takes care of this in stor-layout.c. */
2016 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2018 ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
)
2020 if (TREE_CODE (type
) == ERROR_MARK
)
2023 if (TYPE_SIZE (type
) == NULL_TREE
)
2026 if (TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
)
2029 if ((tree_int_cst_sgn (TYPE_SIZE (type
)) < 0)
2030 || (!dummy
&& (TREE_INT_CST_HIGH (TYPE_SIZE (type
)) != 0))
2031 || TREE_OVERFLOW (TYPE_SIZE (type
)))
2033 ffebad_start (FFEBAD_ARRAY_LARGE
);
2034 ffebad_string (ffesymbol_text (s
));
2035 ffebad_here (0, ffesymbol_where_line (s
), ffesymbol_where_column (s
));
2038 return error_mark_node
;
2045 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2046 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2047 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2049 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2051 ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
)
2053 ffetargetCharacterSize sz
= ffesymbol_size (s
);
2058 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
2059 tlen
= NULL_TREE
; /* A statement function, no length passed. */
2062 if (ffesymbol_where (s
) == FFEINFO_whereDUMMY
)
2063 tlen
= ffecom_get_invented_identifier ("__g77_length_%s",
2064 ffesymbol_text (s
), 0);
2066 tlen
= ffecom_get_invented_identifier ("__g77_%s",
2068 tlen
= build_decl (PARM_DECL
, tlen
, ffecom_f2c_ftnlen_type_node
);
2070 DECL_ARTIFICIAL (tlen
) = 1;
2074 if (sz
== FFETARGET_charactersizeNONE
)
2076 assert (tlen
!= NULL_TREE
);
2081 highval
= build_int_2 (sz
, 0);
2082 TREE_TYPE (highval
) = ffecom_f2c_ftnlen_type_node
;
2085 type
= build_array_type (type
,
2086 build_range_type (ffecom_f2c_ftnlen_type_node
,
2087 ffecom_f2c_ftnlen_one_node
,
2095 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2097 ffecomConcatList_ catlist;
2098 ffebld expr; // expr of CHARACTER basictype.
2099 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2100 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2102 Scans expr for character subexpressions, updates and returns catlist
2105 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2106 static ffecomConcatList_
2107 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
, ffebld expr
,
2108 ffetargetCharacterSize max
)
2110 ffetargetCharacterSize sz
;
2112 recurse
: /* :::::::::::::::::::: */
2117 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
>= max
))
2118 return catlist
; /* Don't append any more items. */
2120 switch (ffebld_op (expr
))
2122 case FFEBLD_opCONTER
:
2123 case FFEBLD_opSYMTER
:
2124 case FFEBLD_opARRAYREF
:
2125 case FFEBLD_opFUNCREF
:
2126 case FFEBLD_opSUBSTR
:
2127 case FFEBLD_opCONVERT
: /* Callers should strip this off beforehand
2128 if they don't need to preserve it. */
2129 if (catlist
.count
== catlist
.max
)
2130 { /* Make a (larger) list. */
2134 newmax
= (catlist
.max
== 0) ? 8 : catlist
.max
* 2;
2135 newx
= malloc_new_ks (malloc_pool_image (), "catlist",
2136 newmax
* sizeof (newx
[0]));
2137 if (catlist
.max
!= 0)
2139 memcpy (newx
, catlist
.exprs
, catlist
.max
* sizeof (newx
[0]));
2140 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2141 catlist
.max
* sizeof (newx
[0]));
2143 catlist
.max
= newmax
;
2144 catlist
.exprs
= newx
;
2146 if ((sz
= ffebld_size_known (expr
)) != FFETARGET_charactersizeNONE
)
2147 catlist
.minlen
+= sz
;
2149 ++catlist
.minlen
; /* Not true for F90; can be 0 length. */
2150 if ((sz
= ffebld_size_max (expr
)) == FFETARGET_charactersizeNONE
)
2151 catlist
.maxlen
= sz
;
2153 catlist
.maxlen
+= sz
;
2154 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
> max
))
2155 { /* This item overlaps (or is beyond) the end
2156 of the destination. */
2157 switch (ffebld_op (expr
))
2159 case FFEBLD_opCONTER
:
2160 case FFEBLD_opSYMTER
:
2161 case FFEBLD_opARRAYREF
:
2162 case FFEBLD_opFUNCREF
:
2163 case FFEBLD_opSUBSTR
:
2164 break; /* ~~Do useful truncations here. */
2167 assert ("op changed or inconsistent switches!" == NULL
);
2171 catlist
.exprs
[catlist
.count
++] = expr
;
2174 case FFEBLD_opPAREN
:
2175 expr
= ffebld_left (expr
);
2176 goto recurse
; /* :::::::::::::::::::: */
2178 case FFEBLD_opCONCATENATE
:
2179 catlist
= ffecom_concat_list_gather_ (catlist
, ffebld_left (expr
), max
);
2180 expr
= ffebld_right (expr
);
2181 goto recurse
; /* :::::::::::::::::::: */
2183 #if 0 /* Breaks passing small actual arg to larger
2184 dummy arg of sfunc */
2185 case FFEBLD_opCONVERT
:
2186 expr
= ffebld_left (expr
);
2188 ffetargetCharacterSize cmax
;
2190 cmax
= catlist
.len
+ ffebld_size_known (expr
);
2192 if ((max
== FFETARGET_charactersizeNONE
) || (max
> cmax
))
2195 goto recurse
; /* :::::::::::::::::::: */
2202 assert ("bad op in _gather_" == NULL
);
2208 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2210 ffecomConcatList_ catlist;
2211 ffecom_concat_list_kill_(catlist);
2213 Anything allocated within the list info is deallocated. */
2215 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2217 ffecom_concat_list_kill_ (ffecomConcatList_ catlist
)
2219 if (catlist
.max
!= 0)
2220 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2221 catlist
.max
* sizeof (catlist
.exprs
[0]));
2225 /* ffecom_concat_list_new_ -- Make list of concatenated string exprs
2227 ffecomConcatList_ catlist;
2228 ffebld expr; // Root expr of CHARACTER basictype.
2229 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2230 catlist = ffecom_concat_list_new_(expr,max);
2232 Returns a flattened list of concatenated subexpressions given a
2233 tree of such expressions. */
2235 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2236 static ffecomConcatList_
2237 ffecom_concat_list_new_ (ffebld expr
, ffetargetCharacterSize max
)
2239 ffecomConcatList_ catlist
;
2241 catlist
.maxlen
= catlist
.minlen
= catlist
.max
= catlist
.count
= 0;
2242 return ffecom_concat_list_gather_ (catlist
, expr
, max
);
2247 /* Provide some kind of useful info on member of aggregate area,
2248 since current g77/gcc technology does not provide debug info
2249 on these members. */
2251 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2253 ffecom_debug_kludge_ (tree aggr
, char *aggr_type
, ffesymbol member
,
2254 tree member_type UNUSED
, ffetargetOffset offset
)
2264 for (type_id
= member_type
;
2265 TREE_CODE (type_id
) != IDENTIFIER_NODE
;
2268 switch (TREE_CODE (type_id
))
2272 type_id
= TYPE_NAME (type_id
);
2277 type_id
= TREE_TYPE (type_id
);
2281 assert ("no IDENTIFIER_NODE for type!" == NULL
);
2282 type_id
= error_mark_node
;
2288 if (ffecom_transform_only_dummies_
2289 || !ffe_is_debug_kludge ())
2290 return; /* Can't do this yet, maybe later. */
2293 + strlen (aggr_type
)
2294 + IDENTIFIER_LENGTH (DECL_NAME (aggr
));
2296 + IDENTIFIER_LENGTH (type_id
);
2299 if (((size_t) len
) >= ARRAY_SIZE (space
))
2300 buff
= malloc_new_ks (malloc_pool_image (), "debug_kludge", len
+ 1);
2304 sprintf (&buff
[0], "At (%s) `%s' plus %ld bytes",
2306 IDENTIFIER_POINTER (DECL_NAME (aggr
)),
2309 value
= build_string (len
, buff
);
2311 = build_type_variant (build_array_type (char_type_node
,
2315 build_int_2 (strlen (buff
), 0))),
2317 decl
= build_decl (VAR_DECL
,
2318 ffecom_get_identifier_ (ffesymbol_text (member
)),
2320 TREE_CONSTANT (decl
) = 1;
2321 TREE_STATIC (decl
) = 1;
2322 DECL_INITIAL (decl
) = error_mark_node
;
2323 DECL_IN_SYSTEM_HEADER (decl
) = 1; /* Don't let -Wunused complain. */
2324 decl
= start_decl (decl
, FALSE
);
2325 finish_decl (decl
, value
, FALSE
);
2327 if (buff
!= &space
[0])
2328 malloc_kill_ks (malloc_pool_image (), buff
, len
+ 1);
2332 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2334 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2335 int i; // entry# for this entrypoint (used by master fn)
2336 ffecom_do_entrypoint_(s,i);
2338 Makes a public entry point that calls our private master fn (already
2341 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2343 ffecom_do_entry_ (ffesymbol fn
, int entrynum
)
2346 tree type
; /* Type of function. */
2347 tree multi_retval
; /* Var holding return value (union). */
2348 tree result
; /* Var holding result. */
2349 ffeinfoBasictype bt
;
2353 bool charfunc
; /* All entry points return same type
2355 bool cmplxfunc
; /* Use f2c way of returning COMPLEX. */
2356 bool multi
; /* Master fn has multiple return types. */
2357 bool altreturning
= FALSE
; /* This entry point has alternate returns. */
2359 int old_lineno
= lineno
;
2360 char *old_input_filename
= input_filename
;
2362 input_filename
= ffesymbol_where_filename (fn
);
2363 lineno
= ffesymbol_where_filelinenum (fn
);
2365 /* c-parse.y indeed does call suspend_momentary and not only ignores the
2366 return value, but also never calls resume_momentary, when starting an
2367 outer function (see "fndef:", "setspecs:", and so on). So g77 does the
2368 same thing. It shouldn't be a problem since start_function calls
2369 temporary_allocation, but it might be necessary. If it causes a problem
2370 here, then maybe there's a bug lurking in gcc. NOTE: This identical
2371 comment appears twice in thist file. */
2373 suspend_momentary ();
2375 ffecom_doing_entry_
= TRUE
; /* Don't bother with array dimensions. */
2377 switch (ffecom_primary_entry_kind_
)
2379 case FFEINFO_kindFUNCTION
:
2381 /* Determine actual return type for function. */
2383 gt
= FFEGLOBAL_typeFUNC
;
2384 bt
= ffesymbol_basictype (fn
);
2385 kt
= ffesymbol_kindtype (fn
);
2386 if (bt
== FFEINFO_basictypeNONE
)
2388 ffeimplic_establish_symbol (fn
);
2389 if (ffesymbol_funcresult (fn
) != NULL
)
2390 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
2391 bt
= ffesymbol_basictype (fn
);
2392 kt
= ffesymbol_kindtype (fn
);
2395 if (bt
== FFEINFO_basictypeCHARACTER
)
2396 charfunc
= TRUE
, cmplxfunc
= FALSE
;
2397 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
2398 && ffesymbol_is_f2c (fn
))
2399 charfunc
= FALSE
, cmplxfunc
= TRUE
;
2401 charfunc
= cmplxfunc
= FALSE
;
2404 type
= ffecom_tree_fun_type_void
;
2405 else if (ffesymbol_is_f2c (fn
))
2406 type
= ffecom_tree_fun_type
[bt
][kt
];
2408 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
2410 if ((type
== NULL_TREE
)
2411 || (TREE_TYPE (type
) == NULL_TREE
))
2412 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
2414 multi
= (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
2417 case FFEINFO_kindSUBROUTINE
:
2418 gt
= FFEGLOBAL_typeSUBR
;
2419 bt
= FFEINFO_basictypeNONE
;
2420 kt
= FFEINFO_kindtypeNONE
;
2421 if (ffecom_is_altreturning_
)
2422 { /* Am _I_ altreturning? */
2423 for (item
= ffesymbol_dummyargs (fn
);
2425 item
= ffebld_trail (item
))
2427 if (ffebld_op (ffebld_head (item
)) == FFEBLD_opSTAR
)
2429 altreturning
= TRUE
;
2434 type
= ffecom_tree_subr_type
;
2436 type
= ffecom_tree_fun_type_void
;
2439 type
= ffecom_tree_fun_type_void
;
2446 assert ("say what??" == NULL
);
2448 case FFEINFO_kindANY
:
2449 gt
= FFEGLOBAL_typeANY
;
2450 bt
= FFEINFO_basictypeNONE
;
2451 kt
= FFEINFO_kindtypeNONE
;
2452 type
= error_mark_node
;
2459 /* build_decl uses the current lineno and input_filename to set the decl
2460 source info. So, I've putzed with ffestd and ffeste code to update that
2461 source info to point to the appropriate statement just before calling
2462 ffecom_do_entrypoint (which calls this fn). */
2464 start_function (ffecom_get_external_identifier_ (fn
),
2466 0, /* nested/inline */
2467 1); /* TREE_PUBLIC */
2469 if (((g
= ffesymbol_global (fn
)) != NULL
)
2470 && ((ffeglobal_type (g
) == gt
)
2471 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
2473 ffeglobal_set_hook (g
, current_function_decl
);
2476 /* Reset args in master arg list so they get retransitioned. */
2478 for (item
= ffecom_master_arglist_
;
2480 item
= ffebld_trail (item
))
2485 arg
= ffebld_head (item
);
2486 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2487 continue; /* Alternate return or some such thing. */
2488 s
= ffebld_symter (arg
);
2489 ffesymbol_hook (s
).decl_tree
= NULL_TREE
;
2490 ffesymbol_hook (s
).length_tree
= NULL_TREE
;
2493 /* Build dummy arg list for this entry point. */
2495 yes
= suspend_momentary ();
2497 if (charfunc
|| cmplxfunc
)
2498 { /* Prepend arg for where result goes. */
2503 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
2505 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
2507 result
= ffecom_get_invented_identifier ("__g77_%s",
2510 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2513 length
= ffecom_char_enhance_arg_ (&type
, fn
);
2515 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
2517 type
= build_pointer_type (type
);
2518 result
= build_decl (PARM_DECL
, result
, type
);
2520 push_parm_decl (result
);
2521 ffecom_func_result_
= result
;
2525 push_parm_decl (length
);
2526 ffecom_func_length_
= length
;
2530 result
= DECL_RESULT (current_function_decl
);
2532 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn
), FALSE
);
2534 resume_momentary (yes
);
2536 store_parm_decls (0);
2538 ffecom_start_compstmt_ ();
2540 /* Make local var to hold return type for multi-type master fn. */
2544 yes
= suspend_momentary ();
2546 multi_retval
= ffecom_get_invented_identifier ("__g77_%s",
2548 multi_retval
= build_decl (VAR_DECL
, multi_retval
,
2549 ffecom_multi_type_node_
);
2550 multi_retval
= start_decl (multi_retval
, FALSE
);
2551 finish_decl (multi_retval
, NULL_TREE
, FALSE
);
2553 resume_momentary (yes
);
2556 multi_retval
= NULL_TREE
; /* Not actually ref'd if !multi. */
2558 /* Here we emit the actual code for the entry point. */
2564 tree arglist
= NULL_TREE
;
2565 tree
*plist
= &arglist
;
2571 /* Prepare actual arg list based on master arg list. */
2573 for (list
= ffecom_master_arglist_
;
2575 list
= ffebld_trail (list
))
2577 arg
= ffebld_head (list
);
2578 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2580 s
= ffebld_symter (arg
);
2581 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
)
2582 actarg
= null_pointer_node
; /* We don't have this arg. */
2584 actarg
= ffesymbol_hook (s
).decl_tree
;
2585 *plist
= build_tree_list (NULL_TREE
, actarg
);
2586 plist
= &TREE_CHAIN (*plist
);
2589 /* This code appends the length arguments for character
2590 variables/arrays. */
2592 for (list
= ffecom_master_arglist_
;
2594 list
= ffebld_trail (list
))
2596 arg
= ffebld_head (list
);
2597 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2599 s
= ffebld_symter (arg
);
2600 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
2601 continue; /* Only looking for CHARACTER arguments. */
2602 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
2603 continue; /* Only looking for variables and arrays. */
2604 if (ffesymbol_hook (s
).length_tree
== NULL_TREE
)
2605 actarg
= ffecom_f2c_ftnlen_zero_node
; /* We don't have this arg. */
2607 actarg
= ffesymbol_hook (s
).length_tree
;
2608 *plist
= build_tree_list (NULL_TREE
, actarg
);
2609 plist
= &TREE_CHAIN (*plist
);
2612 /* Prepend character-value return info to actual arg list. */
2616 prepend
= build_tree_list (NULL_TREE
, ffecom_func_result_
);
2617 TREE_CHAIN (prepend
)
2618 = build_tree_list (NULL_TREE
, ffecom_func_length_
);
2619 TREE_CHAIN (TREE_CHAIN (prepend
)) = arglist
;
2623 /* Prepend multi-type return value to actual arg list. */
2628 = build_tree_list (NULL_TREE
,
2629 ffecom_1 (ADDR_EXPR
,
2630 build_pointer_type (TREE_TYPE (multi_retval
)),
2632 TREE_CHAIN (prepend
) = arglist
;
2636 /* Prepend my entry-point number to the actual arg list. */
2638 prepend
= build_tree_list (NULL_TREE
, build_int_2 (entrynum
, 0));
2639 TREE_CHAIN (prepend
) = arglist
;
2642 /* Build the call to the master function. */
2644 master_fn
= ffecom_1_fn (ffecom_previous_function_decl_
);
2645 call
= ffecom_3s (CALL_EXPR
,
2646 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn
))),
2647 master_fn
, arglist
, NULL_TREE
);
2649 /* Decide whether the master function is a function or subroutine, and
2650 handle the return value for my entry point. */
2652 if (charfunc
|| ((ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
2655 expand_expr_stmt (call
);
2656 expand_null_return ();
2658 else if (multi
&& cmplxfunc
)
2660 expand_expr_stmt (call
);
2662 = ffecom_1 (INDIRECT_REF
,
2663 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2665 result
= ffecom_modify (NULL_TREE
, result
,
2666 ffecom_2 (COMPONENT_REF
, TREE_TYPE (result
),
2668 ffecom_multi_fields_
[bt
][kt
]));
2669 expand_expr_stmt (result
);
2670 expand_null_return ();
2674 expand_expr_stmt (call
);
2676 = ffecom_modify (NULL_TREE
, result
,
2677 convert (TREE_TYPE (result
),
2678 ffecom_2 (COMPONENT_REF
,
2679 ffecom_tree_type
[bt
][kt
],
2681 ffecom_multi_fields_
[bt
][kt
])));
2682 expand_return (result
);
2687 = ffecom_1 (INDIRECT_REF
,
2688 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2690 result
= ffecom_modify (NULL_TREE
, result
, call
);
2691 expand_expr_stmt (result
);
2692 expand_null_return ();
2696 result
= ffecom_modify (NULL_TREE
,
2698 convert (TREE_TYPE (result
),
2700 expand_return (result
);
2706 ffecom_end_compstmt_ ();
2708 finish_function (0);
2710 lineno
= old_lineno
;
2711 input_filename
= old_input_filename
;
2713 ffecom_doing_entry_
= FALSE
;
2717 /* Transform expr into gcc tree with possible destination
2719 Recursive descent on expr while making corresponding tree nodes and
2720 attaching type info and such. If destination supplied and compatible
2721 with temporary that would be made in certain cases, temporary isn't
2722 made, destination used instead, and dest_used flag set TRUE. */
2724 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2726 ffecom_expr_ (ffebld expr
, tree dest_tree
, ffebld dest
,
2727 bool *dest_used
, bool assignp
, bool widenp
)
2732 ffeinfoBasictype bt
;
2735 tree dt
; /* decl_tree for an ffesymbol. */
2736 tree tree_type
, tree_type_x
;
2739 enum tree_code code
;
2741 assert (expr
!= NULL
);
2743 if (dest_used
!= NULL
)
2746 bt
= ffeinfo_basictype (ffebld_info (expr
));
2747 kt
= ffeinfo_kindtype (ffebld_info (expr
));
2748 tree_type
= ffecom_tree_type
[bt
][kt
];
2750 /* Widen integral arithmetic as desired while preserving signedness. */
2751 tree_type_x
= NULL_TREE
;
2752 if (widenp
&& tree_type
2753 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
2754 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
2755 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
2757 switch (ffebld_op (expr
))
2759 case FFEBLD_opACCTER
:
2762 ffebit bits
= ffebld_accter_bits (expr
);
2763 ffetargetOffset source_offset
= 0;
2767 size
= ffetype_size (ffeinfo_type (bt
, kt
));
2772 ffebldConstantUnion cu
;
2775 ffebldConstantArray ca
= ffebld_accter (expr
);
2777 ffebit_test (bits
, source_offset
, &value
, &length
);
2783 for (i
= 0; i
< length
; ++i
)
2785 cu
= ffebld_constantarray_get (ca
, bt
, kt
,
2788 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
2791 purpose
= build_int_2 (source_offset
, 0);
2793 purpose
= NULL_TREE
;
2795 if (list
== NULL_TREE
)
2796 list
= item
= build_tree_list (purpose
, t
);
2799 TREE_CHAIN (item
) = build_tree_list (purpose
, t
);
2800 item
= TREE_CHAIN (item
);
2804 source_offset
+= length
;
2808 item
= build_int_2 (ffebld_accter_size (expr
), 0);
2809 ffebit_kill (ffebld_accter_bits (expr
));
2810 TREE_TYPE (item
) = ffecom_integer_type_node
;
2814 build_range_type (ffecom_integer_type_node
,
2815 ffecom_integer_zero_node
,
2817 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
2818 TREE_CONSTANT (list
) = 1;
2819 TREE_STATIC (list
) = 1;
2822 case FFEBLD_opARRTER
:
2826 list
= item
= NULL_TREE
;
2827 for (i
= 0; i
< ffebld_arrter_size (expr
); ++i
)
2829 ffebldConstantUnion cu
2830 = ffebld_constantarray_get (ffebld_arrter (expr
), bt
, kt
, i
);
2832 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
2834 if (list
== NULL_TREE
)
2835 list
= item
= build_tree_list (NULL_TREE
, t
);
2838 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
2839 item
= TREE_CHAIN (item
);
2844 item
= build_int_2 (ffebld_arrter_size (expr
), 0);
2845 TREE_TYPE (item
) = ffecom_integer_type_node
;
2849 build_range_type (ffecom_integer_type_node
,
2850 ffecom_integer_one_node
,
2852 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
2853 TREE_CONSTANT (list
) = 1;
2854 TREE_STATIC (list
) = 1;
2857 case FFEBLD_opCONTER
:
2859 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr
)),
2863 case FFEBLD_opSYMTER
:
2864 if ((ffebld_symter_generic (expr
) != FFEINTRIN_genNONE
)
2865 || (ffebld_symter_specific (expr
) != FFEINTRIN_specNONE
))
2866 return ffecom_ptr_to_expr (expr
); /* Same as %REF(intrinsic). */
2867 s
= ffebld_symter (expr
);
2868 t
= ffesymbol_hook (s
).decl_tree
;
2871 { /* ASSIGN'ed-label expr. */
2872 if (ffe_is_ugly_assign ())
2874 /* User explicitly wants ASSIGN'ed variables to be at the same
2875 memory address as the variables when used in non-ASSIGN
2876 contexts. That can make old, arcane, non-standard code
2877 work, but don't try to do it when a pointer wouldn't fit
2878 in the normal variable (take other approach, and warn,
2883 s
= ffecom_sym_transform_ (s
);
2884 t
= ffesymbol_hook (s
).decl_tree
;
2885 assert (t
!= NULL_TREE
);
2888 if (t
== error_mark_node
)
2891 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t
)))
2892 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
2894 if (ffesymbol_hook (s
).addr
)
2895 t
= ffecom_1 (INDIRECT_REF
,
2896 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
2900 if (ffesymbol_hook (s
).assign_tree
== NULL_TREE
)
2902 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
2903 FFEBAD_severityWARNING
);
2904 ffebad_string (ffesymbol_text (s
));
2905 ffebad_here (0, ffesymbol_where_line (s
),
2906 ffesymbol_where_column (s
));
2911 /* Don't use the normal variable's tree for ASSIGN, though mark
2912 it as in the system header (housekeeping). Use an explicit,
2913 specially created sibling that is known to be wide enough
2914 to hold pointers to labels. */
2917 && TREE_CODE (t
) == VAR_DECL
)
2918 DECL_IN_SYSTEM_HEADER (t
) = 1; /* Don't let -Wunused complain. */
2920 t
= ffesymbol_hook (s
).assign_tree
;
2923 s
= ffecom_sym_transform_assign_ (s
);
2924 t
= ffesymbol_hook (s
).assign_tree
;
2925 assert (t
!= NULL_TREE
);
2932 s
= ffecom_sym_transform_ (s
);
2933 t
= ffesymbol_hook (s
).decl_tree
;
2934 assert (t
!= NULL_TREE
);
2936 if (ffesymbol_hook (s
).addr
)
2937 t
= ffecom_1 (INDIRECT_REF
,
2938 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
2942 case FFEBLD_opARRAYREF
:
2944 ffebld dims
[FFECOM_dimensionsMAX
];
2945 #if FFECOM_FASTER_ARRAY_REFS
2950 #if FFECOM_FASTER_ARRAY_REFS
2951 t
= ffecom_ptr_to_expr (ffebld_left (expr
));
2953 t
= ffecom_expr (ffebld_left (expr
));
2955 if (t
== error_mark_node
)
2958 if ((ffeinfo_where (ffebld_info (expr
)) == FFEINFO_whereFLEETING
)
2959 && !mark_addressable (t
))
2960 return error_mark_node
; /* Make sure non-const ref is to
2963 /* Build up ARRAY_REFs in reverse order (since we're column major
2964 here in Fortran land). */
2966 for (i
= 0, expr
= ffebld_right (expr
);
2968 expr
= ffebld_trail (expr
))
2969 dims
[i
++] = ffebld_head (expr
);
2971 #if FFECOM_FASTER_ARRAY_REFS
2972 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
)));
2974 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
2975 t
= ffecom_2 (PLUS_EXPR
,
2976 build_pointer_type (TREE_TYPE (array
)),
2978 size_binop (MULT_EXPR
,
2979 size_in_bytes (TREE_TYPE (array
)),
2980 size_binop (MINUS_EXPR
,
2981 ffecom_expr (dims
[i
]),
2982 TYPE_MIN_VALUE (TYPE_DOMAIN (array
)))));
2983 t
= ffecom_1 (INDIRECT_REF
,
2984 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))),
2988 t
= ffecom_2 (ARRAY_REF
,
2989 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))),
2991 ffecom_expr_ (dims
[--i
], NULL
, NULL
, NULL
, FALSE
, TRUE
));
2997 case FFEBLD_opUPLUS
:
2998 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
2999 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3001 case FFEBLD_opPAREN
: /* ~~~Make sure Fortran rules respected here */
3002 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3003 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3005 case FFEBLD_opUMINUS
:
3006 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3009 tree_type
= tree_type_x
;
3010 left
= convert (tree_type
, left
);
3012 return ffecom_1 (NEGATE_EXPR
, tree_type
, left
);
3015 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3016 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3019 tree_type
= tree_type_x
;
3020 left
= convert (tree_type
, left
);
3021 right
= convert (tree_type
, right
);
3023 return ffecom_2 (PLUS_EXPR
, tree_type
, left
, right
);
3025 case FFEBLD_opSUBTRACT
:
3026 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3027 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3030 tree_type
= tree_type_x
;
3031 left
= convert (tree_type
, left
);
3032 right
= convert (tree_type
, right
);
3034 return ffecom_2 (MINUS_EXPR
, tree_type
, left
, right
);
3036 case FFEBLD_opMULTIPLY
:
3037 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3038 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3041 tree_type
= tree_type_x
;
3042 left
= convert (tree_type
, left
);
3043 right
= convert (tree_type
, right
);
3045 return ffecom_2 (MULT_EXPR
, tree_type
, left
, right
);
3047 case FFEBLD_opDIVIDE
:
3048 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3049 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3052 tree_type
= tree_type_x
;
3053 left
= convert (tree_type
, left
);
3054 right
= convert (tree_type
, right
);
3056 return ffecom_tree_divide_ (tree_type
, left
, right
,
3057 dest_tree
, dest
, dest_used
);
3059 case FFEBLD_opPOWER
:
3061 ffebld left
= ffebld_left (expr
);
3062 ffebld right
= ffebld_right (expr
);
3064 ffeinfoKindtype rtkt
;
3066 switch (ffeinfo_basictype (ffebld_info (right
)))
3068 case FFEINFO_basictypeINTEGER
:
3071 item
= ffecom_expr_power_integer_ (left
, right
);
3072 if (item
!= NULL_TREE
)
3076 rtkt
= FFEINFO_kindtypeINTEGER1
;
3077 switch (ffeinfo_basictype (ffebld_info (left
)))
3079 case FFEINFO_basictypeINTEGER
:
3080 if ((ffeinfo_kindtype (ffebld_info (left
))
3081 == FFEINFO_kindtypeINTEGER4
)
3082 || (ffeinfo_kindtype (ffebld_info (right
))
3083 == FFEINFO_kindtypeINTEGER4
))
3085 code
= FFECOM_gfrtPOW_QQ
;
3086 rtkt
= FFEINFO_kindtypeINTEGER4
;
3089 code
= FFECOM_gfrtPOW_II
;
3092 case FFEINFO_basictypeREAL
:
3093 if (ffeinfo_kindtype (ffebld_info (left
))
3094 == FFEINFO_kindtypeREAL1
)
3095 code
= FFECOM_gfrtPOW_RI
;
3097 code
= FFECOM_gfrtPOW_DI
;
3100 case FFEINFO_basictypeCOMPLEX
:
3101 if (ffeinfo_kindtype (ffebld_info (left
))
3102 == FFEINFO_kindtypeREAL1
)
3103 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3105 code
= FFECOM_gfrtPOW_ZI
; /* Overlapping result okay. */
3109 assert ("bad pow_*i" == NULL
);
3110 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3113 if (ffeinfo_kindtype (ffebld_info (left
)) != rtkt
)
3114 left
= ffeexpr_convert (left
, NULL
, NULL
,
3115 FFEINFO_basictypeINTEGER
,
3117 FFETARGET_charactersizeNONE
,
3118 FFEEXPR_contextLET
);
3119 if (ffeinfo_kindtype (ffebld_info (right
)) != rtkt
)
3120 right
= ffeexpr_convert (right
, NULL
, NULL
,
3121 FFEINFO_basictypeINTEGER
,
3123 FFETARGET_charactersizeNONE
,
3124 FFEEXPR_contextLET
);
3127 case FFEINFO_basictypeREAL
:
3128 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3129 left
= ffeexpr_convert (left
, NULL
, NULL
, FFEINFO_basictypeREAL
,
3130 FFEINFO_kindtypeREALDOUBLE
, 0,
3131 FFETARGET_charactersizeNONE
,
3132 FFEEXPR_contextLET
);
3133 if (ffeinfo_kindtype (ffebld_info (right
))
3134 == FFEINFO_kindtypeREAL1
)
3135 right
= ffeexpr_convert (right
, NULL
, NULL
,
3136 FFEINFO_basictypeREAL
,
3137 FFEINFO_kindtypeREALDOUBLE
, 0,
3138 FFETARGET_charactersizeNONE
,
3139 FFEEXPR_contextLET
);
3140 code
= FFECOM_gfrtPOW_DD
;
3143 case FFEINFO_basictypeCOMPLEX
:
3144 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3145 left
= ffeexpr_convert (left
, NULL
, NULL
,
3146 FFEINFO_basictypeCOMPLEX
,
3147 FFEINFO_kindtypeREALDOUBLE
, 0,
3148 FFETARGET_charactersizeNONE
,
3149 FFEEXPR_contextLET
);
3150 if (ffeinfo_kindtype (ffebld_info (right
))
3151 == FFEINFO_kindtypeREAL1
)
3152 right
= ffeexpr_convert (right
, NULL
, NULL
,
3153 FFEINFO_basictypeCOMPLEX
,
3154 FFEINFO_kindtypeREALDOUBLE
, 0,
3155 FFETARGET_charactersizeNONE
,
3156 FFEEXPR_contextLET
);
3157 code
= FFECOM_gfrtPOW_ZZ
; /* Overlapping result okay. */
3161 assert ("bad pow_x*" == NULL
);
3162 code
= FFECOM_gfrtPOW_II
;
3165 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code
),
3166 ffecom_gfrt_kindtype (code
),
3167 (ffe_is_f2c_library ()
3168 && ffecom_gfrt_complex_
[code
]),
3169 tree_type
, left
, right
,
3170 dest_tree
, dest
, dest_used
,
3177 case FFEINFO_basictypeLOGICAL
:
3178 item
= ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr
)));
3179 return convert (tree_type
, item
);
3181 case FFEINFO_basictypeINTEGER
:
3182 return ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3183 ffecom_expr (ffebld_left (expr
)));
3186 assert ("NOT bad basictype" == NULL
);
3188 case FFEINFO_basictypeANY
:
3189 return error_mark_node
;
3193 case FFEBLD_opFUNCREF
:
3194 assert (ffeinfo_basictype (ffebld_info (expr
))
3195 != FFEINFO_basictypeCHARACTER
);
3197 case FFEBLD_opSUBRREF
:
3198 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
3199 == FFEINFO_whereINTRINSIC
)
3200 { /* Invocation of an intrinsic. */
3201 item
= ffecom_expr_intrinsic_ (expr
, dest_tree
, dest
,
3205 s
= ffebld_symter (ffebld_left (expr
));
3206 dt
= ffesymbol_hook (s
).decl_tree
;
3207 if (dt
== NULL_TREE
)
3209 s
= ffecom_sym_transform_ (s
);
3210 dt
= ffesymbol_hook (s
).decl_tree
;
3212 if (dt
== error_mark_node
)
3215 if (ffesymbol_hook (s
).addr
)
3218 item
= ffecom_1_fn (dt
);
3220 ffecom_push_calltemps ();
3221 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
3222 args
= ffecom_list_expr (ffebld_right (expr
));
3224 args
= ffecom_list_ptr_to_expr (ffebld_right (expr
));
3225 ffecom_pop_calltemps ();
3227 item
= ffecom_call_ (item
, kt
,
3228 ffesymbol_is_f2c (s
)
3229 && (bt
== FFEINFO_basictypeCOMPLEX
)
3230 && (ffesymbol_where (s
)
3231 != FFEINFO_whereCONSTANT
),
3234 dest_tree
, dest
, dest_used
,
3235 error_mark_node
, FALSE
);
3236 TREE_SIDE_EFFECTS (item
) = 1;
3242 case FFEINFO_basictypeLOGICAL
:
3244 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3245 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3246 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3247 return convert (tree_type
, item
);
3249 case FFEINFO_basictypeINTEGER
:
3250 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
3251 ffecom_expr (ffebld_left (expr
)),
3252 ffecom_expr (ffebld_right (expr
)));
3255 assert ("AND bad basictype" == NULL
);
3257 case FFEINFO_basictypeANY
:
3258 return error_mark_node
;
3265 case FFEINFO_basictypeLOGICAL
:
3267 = ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
3268 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3269 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3270 return convert (tree_type
, item
);
3272 case FFEINFO_basictypeINTEGER
:
3273 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
3274 ffecom_expr (ffebld_left (expr
)),
3275 ffecom_expr (ffebld_right (expr
)));
3278 assert ("OR bad basictype" == NULL
);
3280 case FFEINFO_basictypeANY
:
3281 return error_mark_node
;
3289 case FFEINFO_basictypeLOGICAL
:
3291 = ffecom_2 (NE_EXPR
, integer_type_node
,
3292 ffecom_expr (ffebld_left (expr
)),
3293 ffecom_expr (ffebld_right (expr
)));
3294 return convert (tree_type
, ffecom_truth_value (item
));
3296 case FFEINFO_basictypeINTEGER
:
3297 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3298 ffecom_expr (ffebld_left (expr
)),
3299 ffecom_expr (ffebld_right (expr
)));
3302 assert ("XOR/NEQV bad basictype" == NULL
);
3304 case FFEINFO_basictypeANY
:
3305 return error_mark_node
;
3312 case FFEINFO_basictypeLOGICAL
:
3314 = ffecom_2 (EQ_EXPR
, integer_type_node
,
3315 ffecom_expr (ffebld_left (expr
)),
3316 ffecom_expr (ffebld_right (expr
)));
3317 return convert (tree_type
, ffecom_truth_value (item
));
3319 case FFEINFO_basictypeINTEGER
:
3321 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3322 ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3323 ffecom_expr (ffebld_left (expr
)),
3324 ffecom_expr (ffebld_right (expr
))));
3327 assert ("EQV bad basictype" == NULL
);
3329 case FFEINFO_basictypeANY
:
3330 return error_mark_node
;
3334 case FFEBLD_opCONVERT
:
3335 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opANY
)
3336 return error_mark_node
;
3340 case FFEINFO_basictypeLOGICAL
:
3341 case FFEINFO_basictypeINTEGER
:
3342 case FFEINFO_basictypeREAL
:
3343 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3345 case FFEINFO_basictypeCOMPLEX
:
3346 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3348 case FFEINFO_basictypeINTEGER
:
3349 case FFEINFO_basictypeLOGICAL
:
3350 case FFEINFO_basictypeREAL
:
3351 item
= ffecom_expr (ffebld_left (expr
));
3352 if (item
== error_mark_node
)
3353 return error_mark_node
;
3354 /* convert() takes care of converting to the subtype first,
3355 at least in gcc-2.7.2. */
3356 item
= convert (tree_type
, item
);
3359 case FFEINFO_basictypeCOMPLEX
:
3360 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3363 assert ("CONVERT COMPLEX bad basictype" == NULL
);
3365 case FFEINFO_basictypeANY
:
3366 return error_mark_node
;
3371 assert ("CONVERT bad basictype" == NULL
);
3373 case FFEINFO_basictypeANY
:
3374 return error_mark_node
;
3380 goto relational
; /* :::::::::::::::::::: */
3384 goto relational
; /* :::::::::::::::::::: */
3388 goto relational
; /* :::::::::::::::::::: */
3392 goto relational
; /* :::::::::::::::::::: */
3396 goto relational
; /* :::::::::::::::::::: */
3401 relational
: /* :::::::::::::::::::: */
3402 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3404 case FFEINFO_basictypeLOGICAL
:
3405 case FFEINFO_basictypeINTEGER
:
3406 case FFEINFO_basictypeREAL
:
3407 item
= ffecom_2 (code
, integer_type_node
,
3408 ffecom_expr (ffebld_left (expr
)),
3409 ffecom_expr (ffebld_right (expr
)));
3410 return convert (tree_type
, item
);
3412 case FFEINFO_basictypeCOMPLEX
:
3413 assert (code
== EQ_EXPR
|| code
== NE_EXPR
);
3416 tree arg1
= ffecom_expr (ffebld_left (expr
));
3417 tree arg2
= ffecom_expr (ffebld_right (expr
));
3419 if (arg1
== error_mark_node
|| arg2
== error_mark_node
)
3420 return error_mark_node
;
3422 arg1
= ffecom_save_tree (arg1
);
3423 arg2
= ffecom_save_tree (arg2
);
3425 if (TREE_CODE (TREE_TYPE (arg1
)) == COMPLEX_TYPE
)
3427 real_type
= TREE_TYPE (TREE_TYPE (arg1
));
3428 assert (real_type
== TREE_TYPE (TREE_TYPE (arg2
)));
3432 real_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1
)));
3433 assert (real_type
== TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2
))));
3437 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3438 ffecom_2 (EQ_EXPR
, integer_type_node
,
3439 ffecom_1 (REALPART_EXPR
, real_type
, arg1
),
3440 ffecom_1 (REALPART_EXPR
, real_type
, arg2
)),
3441 ffecom_2 (EQ_EXPR
, integer_type_node
,
3442 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1
),
3443 ffecom_1 (IMAGPART_EXPR
, real_type
,
3445 if (code
== EQ_EXPR
)
3446 item
= ffecom_truth_value (item
);
3448 item
= ffecom_truth_value_invert (item
);
3449 return convert (tree_type
, item
);
3452 case FFEINFO_basictypeCHARACTER
:
3453 ffecom_push_calltemps (); /* Even though we might not call. */
3456 ffebld left
= ffebld_left (expr
);
3457 ffebld right
= ffebld_right (expr
);
3463 /* f2c run-time functions do the implicit blank-padding for us,
3464 so we don't usually have to implement blank-padding ourselves.
3465 (The exception is when we pass an argument to a separately
3466 compiled statement function -- if we know the arg is not the
3467 same length as the dummy, we must truncate or extend it. If
3468 we "inline" statement functions, that necessity goes away as
3471 Strip off the CONVERT operators that blank-pad. (Truncation by
3472 CONVERT shouldn't happen here, but it can happen in
3475 while (ffebld_op (left
) == FFEBLD_opCONVERT
)
3476 left
= ffebld_left (left
);
3477 while (ffebld_op (right
) == FFEBLD_opCONVERT
)
3478 right
= ffebld_left (right
);
3480 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
3481 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
3483 if (left_tree
== error_mark_node
|| left_length
== error_mark_node
3484 || right_tree
== error_mark_node
3485 || right_length
== error_mark_node
)
3487 ffecom_pop_calltemps ();
3488 return error_mark_node
;
3491 if ((ffebld_size_known (left
) == 1)
3492 && (ffebld_size_known (right
) == 1))
3495 = ffecom_1 (INDIRECT_REF
,
3496 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3499 = ffecom_1 (INDIRECT_REF
,
3500 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3504 = ffecom_2 (code
, integer_type_node
,
3505 ffecom_2 (ARRAY_REF
,
3506 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3509 ffecom_2 (ARRAY_REF
,
3510 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3516 item
= build_tree_list (NULL_TREE
, left_tree
);
3517 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, right_tree
);
3518 TREE_CHAIN (TREE_CHAIN (item
)) = build_tree_list (NULL_TREE
,
3520 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
3521 = build_tree_list (NULL_TREE
, right_length
);
3522 item
= ffecom_call_gfrt (FFECOM_gfrtCMP
, item
);
3523 item
= ffecom_2 (code
, integer_type_node
,
3525 convert (TREE_TYPE (item
),
3526 integer_zero_node
));
3528 item
= convert (tree_type
, item
);
3531 ffecom_pop_calltemps ();
3535 assert ("relational bad basictype" == NULL
);
3537 case FFEINFO_basictypeANY
:
3538 return error_mark_node
;
3542 case FFEBLD_opPERCENT_LOC
:
3543 item
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &list
);
3544 return convert (tree_type
, item
);
3548 case FFEBLD_opBOUNDS
:
3549 case FFEBLD_opREPEAT
:
3550 case FFEBLD_opLABTER
:
3551 case FFEBLD_opLABTOK
:
3552 case FFEBLD_opIMPDO
:
3553 case FFEBLD_opCONCATENATE
:
3554 case FFEBLD_opSUBSTR
:
3556 assert ("bad op" == NULL
);
3559 return error_mark_node
;
3563 assert ("didn't think anything got here anymore!!" == NULL
);
3565 switch (ffebld_arity (expr
))
3568 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3569 TREE_OPERAND (item
, 1) = ffecom_expr (ffebld_right (expr
));
3570 if (TREE_OPERAND (item
, 0) == error_mark_node
3571 || TREE_OPERAND (item
, 1) == error_mark_node
)
3572 return error_mark_node
;
3576 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3577 if (TREE_OPERAND (item
, 0) == error_mark_node
)
3578 return error_mark_node
;
3590 /* Returns the tree that does the intrinsic invocation.
3592 Note: this function applies only to intrinsics returning
3593 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3596 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3598 ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
3599 ffebld dest
, bool *dest_used
)
3602 tree saved_expr1
; /* For those who need it. */
3603 tree saved_expr2
; /* For those who need it. */
3604 ffeinfoBasictype bt
;
3608 tree real_type
; /* REAL type corresponding to COMPLEX. */
3610 ffebld list
= ffebld_right (expr
); /* List of (some) args. */
3611 ffebld arg1
; /* For handy reference. */
3614 ffeintrinImp codegen_imp
;
3617 assert (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
);
3619 if (dest_used
!= NULL
)
3622 bt
= ffeinfo_basictype (ffebld_info (expr
));
3623 kt
= ffeinfo_kindtype (ffebld_info (expr
));
3624 tree_type
= ffecom_tree_type
[bt
][kt
];
3628 arg1
= ffebld_head (list
);
3629 if (arg1
!= NULL
&& ffebld_op (arg1
) == FFEBLD_opANY
)
3630 return error_mark_node
;
3631 if ((list
= ffebld_trail (list
)) != NULL
)
3633 arg2
= ffebld_head (list
);
3634 if (arg2
!= NULL
&& ffebld_op (arg2
) == FFEBLD_opANY
)
3635 return error_mark_node
;
3636 if ((list
= ffebld_trail (list
)) != NULL
)
3638 arg3
= ffebld_head (list
);
3639 if (arg3
!= NULL
&& ffebld_op (arg3
) == FFEBLD_opANY
)
3640 return error_mark_node
;
3649 arg1
= arg2
= arg3
= NULL
;
3651 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3652 args. This is used by the MAX/MIN expansions. */
3655 arg1_type
= ffecom_tree_type
3656 [ffeinfo_basictype (ffebld_info (arg1
))]
3657 [ffeinfo_kindtype (ffebld_info (arg1
))];
3659 arg1_type
= NULL_TREE
; /* Really not needed, but might catch bugs
3662 /* There are several ways for each of the cases in the following switch
3663 statements to exit (from simplest to use to most complicated):
3665 break; (when expr_tree == NULL)
3667 A standard call is made to the specific intrinsic just as if it had been
3668 passed in as a dummy procedure and called as any old procedure. This
3669 method can produce slower code but in some cases it's the easiest way for
3670 now. However, if a (presumably faster) direct call is available,
3671 that is used, so this is the easiest way in many more cases now.
3673 gfrt = FFECOM_gfrtWHATEVER;
3676 gfrt contains the gfrt index of a library function to call, passing the
3677 argument(s) by value rather than by reference. Used when a more
3678 careful choice of library function is needed than that provided
3679 by the vanilla `break;'.
3683 The expr_tree has been completely set up and is ready to be returned
3684 as is. No further actions are taken. Use this when the tree is not
3685 in the simple form for one of the arity_n labels. */
3687 /* For info on how the switch statement cases were written, see the files
3688 enclosed in comments below the switch statement. */
3690 codegen_imp
= ffebld_symter_implementation (ffebld_left (expr
));
3691 gfrt
= ffeintrin_gfrt_direct (codegen_imp
);
3692 if (gfrt
== FFECOM_gfrt
)
3693 gfrt
= ffeintrin_gfrt_indirect (codegen_imp
);
3695 switch (codegen_imp
)
3697 case FFEINTRIN_impABS
:
3698 case FFEINTRIN_impCABS
:
3699 case FFEINTRIN_impCDABS
:
3700 case FFEINTRIN_impDABS
:
3701 case FFEINTRIN_impIABS
:
3702 if (ffeinfo_basictype (ffebld_info (arg1
))
3703 == FFEINFO_basictypeCOMPLEX
)
3705 if (kt
== FFEINFO_kindtypeREAL1
)
3706 gfrt
= FFECOM_gfrtCABS
;
3707 else if (kt
== FFEINFO_kindtypeREAL2
)
3708 gfrt
= FFECOM_gfrtCDABS
;
3711 return ffecom_1 (ABS_EXPR
, tree_type
,
3712 convert (tree_type
, ffecom_expr (arg1
)));
3714 case FFEINTRIN_impACOS
:
3715 case FFEINTRIN_impDACOS
:
3718 case FFEINTRIN_impAIMAG
:
3719 case FFEINTRIN_impDIMAG
:
3720 case FFEINTRIN_impIMAGPART
:
3721 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
3722 arg1_type
= TREE_TYPE (arg1_type
);
3724 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
3728 ffecom_1 (IMAGPART_EXPR
, arg1_type
,
3729 ffecom_expr (arg1
)));
3731 case FFEINTRIN_impAINT
:
3732 case FFEINTRIN_impDINT
:
3733 #if 0 /* ~~ someday implement FIX_TRUNC_EXPR
3734 yielding same type as arg */
3735 return ffecom_1 (FIX_TRUNC_EXPR
, tree_type
, ffecom_expr (arg1
));
3736 #else /* in the meantime, must use floor to avoid range problems with ints */
3737 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3738 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3741 ffecom_3 (COND_EXPR
, double_type_node
,
3743 (ffecom_2 (GE_EXPR
, integer_type_node
,
3746 ffecom_float_zero_
))),
3747 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3748 build_tree_list (NULL_TREE
,
3749 convert (double_type_node
,
3751 ffecom_1 (NEGATE_EXPR
, double_type_node
,
3752 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3753 build_tree_list (NULL_TREE
,
3754 convert (double_type_node
,
3755 ffecom_1 (NEGATE_EXPR
,
3762 case FFEINTRIN_impANINT
:
3763 case FFEINTRIN_impDNINT
:
3764 #if 0 /* This way of doing it won't handle real
3765 numbers of large magnitudes. */
3766 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3767 expr_tree
= convert (tree_type
,
3768 convert (integer_type_node
,
3769 ffecom_3 (COND_EXPR
, tree_type
,
3774 ffecom_float_zero_
)),
3775 ffecom_2 (PLUS_EXPR
,
3778 ffecom_float_half_
),
3779 ffecom_2 (MINUS_EXPR
,
3782 ffecom_float_half_
))));
3784 #else /* So we instead call floor. */
3785 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3786 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3789 ffecom_3 (COND_EXPR
, double_type_node
,
3791 (ffecom_2 (GE_EXPR
, integer_type_node
,
3794 ffecom_float_zero_
))),
3795 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3796 build_tree_list (NULL_TREE
,
3797 convert (double_type_node
,
3798 ffecom_2 (PLUS_EXPR
,
3802 ffecom_float_half_
))))),
3803 ffecom_1 (NEGATE_EXPR
, double_type_node
,
3804 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3805 build_tree_list (NULL_TREE
,
3806 convert (double_type_node
,
3807 ffecom_2 (MINUS_EXPR
,
3810 ffecom_float_half_
),
3816 case FFEINTRIN_impASIN
:
3817 case FFEINTRIN_impDASIN
:
3818 case FFEINTRIN_impATAN
:
3819 case FFEINTRIN_impDATAN
:
3820 case FFEINTRIN_impATAN2
:
3821 case FFEINTRIN_impDATAN2
:
3824 case FFEINTRIN_impCHAR
:
3825 case FFEINTRIN_impACHAR
:
3826 assert (ffecom_pending_calls_
!= 0);
3827 tempvar
= ffecom_push_tempvar (char_type_node
,
3830 tree tmv
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar
)));
3832 expr_tree
= ffecom_modify (tmv
,
3833 ffecom_2 (ARRAY_REF
, tmv
, tempvar
,
3835 convert (tmv
, ffecom_expr (arg1
)));
3837 expr_tree
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
),
3840 expr_tree
= ffecom_1 (ADDR_EXPR
,
3841 build_pointer_type (TREE_TYPE (expr_tree
)),
3845 case FFEINTRIN_impCMPLX
:
3846 case FFEINTRIN_impDCMPLX
:
3849 convert (tree_type
, ffecom_expr (arg1
));
3851 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
3853 ffecom_2 (COMPLEX_EXPR
, tree_type
,
3854 convert (real_type
, ffecom_expr (arg1
)),
3856 ffecom_expr (arg2
)));
3858 case FFEINTRIN_impCOMPLEX
:
3860 ffecom_2 (COMPLEX_EXPR
, tree_type
,
3862 ffecom_expr (arg2
));
3864 case FFEINTRIN_impCONJG
:
3865 case FFEINTRIN_impDCONJG
:
3869 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
3870 arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
3872 ffecom_2 (COMPLEX_EXPR
, tree_type
,
3873 ffecom_1 (REALPART_EXPR
, real_type
, arg1_tree
),
3874 ffecom_1 (NEGATE_EXPR
, real_type
,
3875 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1_tree
)));
3878 case FFEINTRIN_impCOS
:
3879 case FFEINTRIN_impCCOS
:
3880 case FFEINTRIN_impCDCOS
:
3881 case FFEINTRIN_impDCOS
:
3882 if (bt
== FFEINFO_basictypeCOMPLEX
)
3884 if (kt
== FFEINFO_kindtypeREAL1
)
3885 gfrt
= FFECOM_gfrtCCOS
; /* Overlapping result okay. */
3886 else if (kt
== FFEINFO_kindtypeREAL2
)
3887 gfrt
= FFECOM_gfrtCDCOS
; /* Overlapping result okay. */
3891 case FFEINTRIN_impCOSH
:
3892 case FFEINTRIN_impDCOSH
:
3895 case FFEINTRIN_impDBLE
:
3896 case FFEINTRIN_impDFLOAT
:
3897 case FFEINTRIN_impDREAL
:
3898 case FFEINTRIN_impFLOAT
:
3899 case FFEINTRIN_impIDINT
:
3900 case FFEINTRIN_impIFIX
:
3901 case FFEINTRIN_impINT2
:
3902 case FFEINTRIN_impINT8
:
3903 case FFEINTRIN_impINT
:
3904 case FFEINTRIN_impLONG
:
3905 case FFEINTRIN_impREAL
:
3906 case FFEINTRIN_impSHORT
:
3907 case FFEINTRIN_impSNGL
:
3908 return convert (tree_type
, ffecom_expr (arg1
));
3910 case FFEINTRIN_impDIM
:
3911 case FFEINTRIN_impDDIM
:
3912 case FFEINTRIN_impIDIM
:
3913 saved_expr1
= ffecom_save_tree (convert (tree_type
,
3914 ffecom_expr (arg1
)));
3915 saved_expr2
= ffecom_save_tree (convert (tree_type
,
3916 ffecom_expr (arg2
)));
3918 ffecom_3 (COND_EXPR
, tree_type
,
3920 (ffecom_2 (GT_EXPR
, integer_type_node
,
3923 ffecom_2 (MINUS_EXPR
, tree_type
,
3926 convert (tree_type
, ffecom_float_zero_
));
3928 case FFEINTRIN_impDPROD
:
3930 ffecom_2 (MULT_EXPR
, tree_type
,
3931 convert (tree_type
, ffecom_expr (arg1
)),
3932 convert (tree_type
, ffecom_expr (arg2
)));
3934 case FFEINTRIN_impEXP
:
3935 case FFEINTRIN_impCDEXP
:
3936 case FFEINTRIN_impCEXP
:
3937 case FFEINTRIN_impDEXP
:
3938 if (bt
== FFEINFO_basictypeCOMPLEX
)
3940 if (kt
== FFEINFO_kindtypeREAL1
)
3941 gfrt
= FFECOM_gfrtCEXP
; /* Overlapping result okay. */
3942 else if (kt
== FFEINFO_kindtypeREAL2
)
3943 gfrt
= FFECOM_gfrtCDEXP
; /* Overlapping result okay. */
3947 case FFEINTRIN_impICHAR
:
3948 case FFEINTRIN_impIACHAR
:
3949 #if 0 /* The simple approach. */
3950 ffecom_char_args_ (&expr_tree
, &saved_expr1
/* Ignored */ , arg1
);
3952 = ffecom_1 (INDIRECT_REF
,
3953 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
3956 = ffecom_2 (ARRAY_REF
,
3957 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
3960 return convert (tree_type
, expr_tree
);
3961 #else /* The more interesting (and more optimal) approach. */
3962 expr_tree
= ffecom_intrinsic_ichar_ (tree_type
, arg1
, &saved_expr1
);
3963 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
3966 convert (tree_type
, integer_zero_node
));
3970 case FFEINTRIN_impINDEX
:
3973 case FFEINTRIN_impLEN
:
3975 break; /* The simple approach. */
3977 return ffecom_intrinsic_len_ (arg1
); /* The more optimal approach. */
3980 case FFEINTRIN_impLGE
:
3981 case FFEINTRIN_impLGT
:
3982 case FFEINTRIN_impLLE
:
3983 case FFEINTRIN_impLLT
:
3986 case FFEINTRIN_impLOG
:
3987 case FFEINTRIN_impALOG
:
3988 case FFEINTRIN_impCDLOG
:
3989 case FFEINTRIN_impCLOG
:
3990 case FFEINTRIN_impDLOG
:
3991 if (bt
== FFEINFO_basictypeCOMPLEX
)
3993 if (kt
== FFEINFO_kindtypeREAL1
)
3994 gfrt
= FFECOM_gfrtCLOG
; /* Overlapping result okay. */
3995 else if (kt
== FFEINFO_kindtypeREAL2
)
3996 gfrt
= FFECOM_gfrtCDLOG
; /* Overlapping result okay. */
4000 case FFEINTRIN_impLOG10
:
4001 case FFEINTRIN_impALOG10
:
4002 case FFEINTRIN_impDLOG10
:
4003 if (gfrt
!= FFECOM_gfrt
)
4004 break; /* Already picked one, stick with it. */
4006 if (kt
== FFEINFO_kindtypeREAL1
)
4007 gfrt
= FFECOM_gfrtALOG10
;
4008 else if (kt
== FFEINFO_kindtypeREAL2
)
4009 gfrt
= FFECOM_gfrtDLOG10
;
4012 case FFEINTRIN_impMAX
:
4013 case FFEINTRIN_impAMAX0
:
4014 case FFEINTRIN_impAMAX1
:
4015 case FFEINTRIN_impDMAX1
:
4016 case FFEINTRIN_impMAX0
:
4017 case FFEINTRIN_impMAX1
:
4018 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4019 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4021 arg1_type
= tree_type
;
4022 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4023 convert (arg1_type
, ffecom_expr (arg1
)),
4024 convert (arg1_type
, ffecom_expr (arg2
)));
4025 for (; list
!= NULL
; list
= ffebld_trail (list
))
4027 if ((ffebld_head (list
) == NULL
)
4028 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4030 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4033 ffecom_expr (ffebld_head (list
))));
4035 return convert (tree_type
, expr_tree
);
4037 case FFEINTRIN_impMIN
:
4038 case FFEINTRIN_impAMIN0
:
4039 case FFEINTRIN_impAMIN1
:
4040 case FFEINTRIN_impDMIN1
:
4041 case FFEINTRIN_impMIN0
:
4042 case FFEINTRIN_impMIN1
:
4043 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4044 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4046 arg1_type
= tree_type
;
4047 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4048 convert (arg1_type
, ffecom_expr (arg1
)),
4049 convert (arg1_type
, ffecom_expr (arg2
)));
4050 for (; list
!= NULL
; list
= ffebld_trail (list
))
4052 if ((ffebld_head (list
) == NULL
)
4053 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4055 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4058 ffecom_expr (ffebld_head (list
))));
4060 return convert (tree_type
, expr_tree
);
4062 case FFEINTRIN_impMOD
:
4063 case FFEINTRIN_impAMOD
:
4064 case FFEINTRIN_impDMOD
:
4065 if (bt
!= FFEINFO_basictypeREAL
)
4066 return ffecom_2 (TRUNC_MOD_EXPR
, tree_type
,
4067 convert (tree_type
, ffecom_expr (arg1
)),
4068 convert (tree_type
, ffecom_expr (arg2
)));
4070 if (kt
== FFEINFO_kindtypeREAL1
)
4071 gfrt
= FFECOM_gfrtAMOD
;
4072 else if (kt
== FFEINFO_kindtypeREAL2
)
4073 gfrt
= FFECOM_gfrtDMOD
;
4076 case FFEINTRIN_impNINT
:
4077 case FFEINTRIN_impIDNINT
:
4078 #if 0 /* ~~ ideally FIX_ROUND_EXPR would be
4079 implemented, but it ain't yet */
4080 return ffecom_1 (FIX_ROUND_EXPR
, tree_type
, ffecom_expr (arg1
));
4082 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4083 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4085 convert (ffecom_integer_type_node
,
4086 ffecom_3 (COND_EXPR
, arg1_type
,
4088 (ffecom_2 (GE_EXPR
, integer_type_node
,
4091 ffecom_float_zero_
))),
4092 ffecom_2 (PLUS_EXPR
, arg1_type
,
4095 ffecom_float_half_
)),
4096 ffecom_2 (MINUS_EXPR
, arg1_type
,
4099 ffecom_float_half_
))));
4102 case FFEINTRIN_impSIGN
:
4103 case FFEINTRIN_impDSIGN
:
4104 case FFEINTRIN_impISIGN
:
4106 tree arg2_tree
= ffecom_expr (arg2
);
4110 (ffecom_1 (ABS_EXPR
, tree_type
,
4112 ffecom_expr (arg1
))));
4114 = ffecom_3 (COND_EXPR
, tree_type
,
4116 (ffecom_2 (GE_EXPR
, integer_type_node
,
4118 convert (TREE_TYPE (arg2_tree
),
4119 integer_zero_node
))),
4121 ffecom_1 (NEGATE_EXPR
, tree_type
, saved_expr1
));
4122 /* Make sure SAVE_EXPRs get referenced early enough. */
4124 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4125 convert (void_type_node
, saved_expr1
),
4130 case FFEINTRIN_impSIN
:
4131 case FFEINTRIN_impCDSIN
:
4132 case FFEINTRIN_impCSIN
:
4133 case FFEINTRIN_impDSIN
:
4134 if (bt
== FFEINFO_basictypeCOMPLEX
)
4136 if (kt
== FFEINFO_kindtypeREAL1
)
4137 gfrt
= FFECOM_gfrtCSIN
; /* Overlapping result okay. */
4138 else if (kt
== FFEINFO_kindtypeREAL2
)
4139 gfrt
= FFECOM_gfrtCDSIN
; /* Overlapping result okay. */
4143 case FFEINTRIN_impSINH
:
4144 case FFEINTRIN_impDSINH
:
4147 case FFEINTRIN_impSQRT
:
4148 case FFEINTRIN_impCDSQRT
:
4149 case FFEINTRIN_impCSQRT
:
4150 case FFEINTRIN_impDSQRT
:
4151 if (bt
== FFEINFO_basictypeCOMPLEX
)
4153 if (kt
== FFEINFO_kindtypeREAL1
)
4154 gfrt
= FFECOM_gfrtCSQRT
; /* Overlapping result okay. */
4155 else if (kt
== FFEINFO_kindtypeREAL2
)
4156 gfrt
= FFECOM_gfrtCDSQRT
; /* Overlapping result okay. */
4160 case FFEINTRIN_impTAN
:
4161 case FFEINTRIN_impDTAN
:
4162 case FFEINTRIN_impTANH
:
4163 case FFEINTRIN_impDTANH
:
4166 case FFEINTRIN_impREALPART
:
4167 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
4168 arg1_type
= TREE_TYPE (arg1_type
);
4170 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
4174 ffecom_1 (REALPART_EXPR
, arg1_type
,
4175 ffecom_expr (arg1
)));
4177 case FFEINTRIN_impIAND
:
4178 case FFEINTRIN_impAND
:
4179 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
4181 ffecom_expr (arg1
)),
4183 ffecom_expr (arg2
)));
4185 case FFEINTRIN_impIOR
:
4186 case FFEINTRIN_impOR
:
4187 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4189 ffecom_expr (arg1
)),
4191 ffecom_expr (arg2
)));
4193 case FFEINTRIN_impIEOR
:
4194 case FFEINTRIN_impXOR
:
4195 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
4197 ffecom_expr (arg1
)),
4199 ffecom_expr (arg2
)));
4201 case FFEINTRIN_impLSHIFT
:
4202 return ffecom_2 (LSHIFT_EXPR
, tree_type
,
4204 convert (integer_type_node
,
4205 ffecom_expr (arg2
)));
4207 case FFEINTRIN_impRSHIFT
:
4208 return ffecom_2 (RSHIFT_EXPR
, tree_type
,
4210 convert (integer_type_node
,
4211 ffecom_expr (arg2
)));
4213 case FFEINTRIN_impNOT
:
4214 return ffecom_1 (BIT_NOT_EXPR
, tree_type
, ffecom_expr (arg1
));
4216 case FFEINTRIN_impBIT_SIZE
:
4217 return convert (tree_type
, TYPE_SIZE (arg1_type
));
4219 case FFEINTRIN_impBTEST
:
4221 ffetargetLogical1
true;
4222 ffetargetLogical1
false;
4226 ffetarget_logical1 (&true, TRUE
);
4227 ffetarget_logical1 (&false, FALSE
);
4229 true_tree
= convert (tree_type
, integer_one_node
);
4231 true_tree
= convert (tree_type
, build_int_2 (true, 0));
4233 false_tree
= convert (tree_type
, integer_zero_node
);
4235 false_tree
= convert (tree_type
, build_int_2 (false, 0));
4238 ffecom_3 (COND_EXPR
, tree_type
,
4240 (ffecom_2 (EQ_EXPR
, integer_type_node
,
4241 ffecom_2 (BIT_AND_EXPR
, arg1_type
,
4243 ffecom_2 (LSHIFT_EXPR
, arg1_type
,
4246 convert (integer_type_node
,
4247 ffecom_expr (arg2
)))),
4249 integer_zero_node
))),
4254 case FFEINTRIN_impIBCLR
:
4256 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4258 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4259 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4262 convert (integer_type_node
,
4263 ffecom_expr (arg2
)))));
4265 case FFEINTRIN_impIBITS
:
4267 tree arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4268 ffecom_expr (arg3
)));
4270 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4273 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4274 ffecom_2 (RSHIFT_EXPR
, tree_type
,
4276 convert (integer_type_node
,
4277 ffecom_expr (arg2
))),
4279 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4280 ffecom_1 (BIT_NOT_EXPR
,
4283 integer_zero_node
)),
4284 ffecom_2 (MINUS_EXPR
,
4286 TYPE_SIZE (uns_type
),
4288 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4290 = ffecom_3 (COND_EXPR
, tree_type
,
4292 (ffecom_2 (NE_EXPR
, integer_type_node
,
4294 integer_zero_node
)),
4296 convert (tree_type
, integer_zero_node
));
4301 case FFEINTRIN_impIBSET
:
4303 ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4305 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4306 convert (tree_type
, integer_one_node
),
4307 convert (integer_type_node
,
4308 ffecom_expr (arg2
))));
4310 case FFEINTRIN_impISHFT
:
4312 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4313 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4314 ffecom_expr (arg2
)));
4316 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4319 = ffecom_3 (COND_EXPR
, tree_type
,
4321 (ffecom_2 (GE_EXPR
, integer_type_node
,
4323 integer_zero_node
)),
4324 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4328 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4329 convert (uns_type
, arg1_tree
),
4330 ffecom_1 (NEGATE_EXPR
,
4333 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4335 = ffecom_3 (COND_EXPR
, tree_type
,
4337 (ffecom_2 (NE_EXPR
, integer_type_node
,
4339 TYPE_SIZE (uns_type
))),
4341 convert (tree_type
, integer_zero_node
));
4343 /* Make sure SAVE_EXPRs get referenced early enough. */
4345 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4346 convert (void_type_node
, arg1_tree
),
4347 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4348 convert (void_type_node
, arg2_tree
),
4353 case FFEINTRIN_impISHFTC
:
4355 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4356 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4357 ffecom_expr (arg2
)));
4358 tree arg3_tree
= (arg3
== NULL
) ? TYPE_SIZE (tree_type
)
4359 : ffecom_save_tree (convert (integer_type_node
, ffecom_expr (arg3
)));
4365 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4368 = ffecom_2 (LSHIFT_EXPR
, tree_type
,
4369 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4370 convert (tree_type
, integer_zero_node
)),
4372 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4374 = ffecom_3 (COND_EXPR
, tree_type
,
4376 (ffecom_2 (NE_EXPR
, integer_type_node
,
4378 TYPE_SIZE (uns_type
))),
4380 convert (tree_type
, integer_zero_node
));
4382 mask_arg1
= ffecom_save_tree (mask_arg1
);
4384 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4386 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4388 masked_arg1
= ffecom_save_tree (masked_arg1
);
4390 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4392 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4393 convert (uns_type
, masked_arg1
),
4394 ffecom_1 (NEGATE_EXPR
,
4397 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4399 ffecom_2 (PLUS_EXPR
, integer_type_node
,
4403 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4404 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4408 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4409 convert (uns_type
, masked_arg1
),
4410 ffecom_2 (MINUS_EXPR
,
4415 = ffecom_3 (COND_EXPR
, tree_type
,
4417 (ffecom_2 (LT_EXPR
, integer_type_node
,
4419 integer_zero_node
)),
4423 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4424 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4427 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4428 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4432 = ffecom_3 (COND_EXPR
, tree_type
,
4434 (ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
4435 ffecom_2 (EQ_EXPR
, integer_type_node
,
4440 ffecom_2 (EQ_EXPR
, integer_type_node
,
4442 integer_zero_node
))),
4445 /* Make sure SAVE_EXPRs get referenced early enough. */
4447 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4448 convert (void_type_node
, arg1_tree
),
4449 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4450 convert (void_type_node
, arg2_tree
),
4451 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4452 convert (void_type_node
,
4454 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4455 convert (void_type_node
,
4459 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4460 convert (void_type_node
,
4466 case FFEINTRIN_impLOC
:
4468 tree arg1_tree
= ffecom_expr (arg1
);
4471 = convert (tree_type
,
4472 ffecom_1 (ADDR_EXPR
,
4473 build_pointer_type (TREE_TYPE (arg1_tree
)),
4478 case FFEINTRIN_impMVBITS
:
4483 ffebld arg4
= ffebld_head (ffebld_trail (list
));
4486 ffebld arg5
= ffebld_head (ffebld_trail (ffebld_trail (list
)));
4490 tree arg5_plus_arg3
;
4492 ffecom_push_calltemps ();
4494 arg2_tree
= convert (integer_type_node
,
4495 ffecom_expr (arg2
));
4496 arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4497 ffecom_expr (arg3
)));
4498 arg4_tree
= ffecom_expr_rw (arg4
);
4499 arg4_type
= TREE_TYPE (arg4_tree
);
4501 arg1_tree
= ffecom_save_tree (convert (arg4_type
,
4502 ffecom_expr (arg1
)));
4504 arg5_tree
= ffecom_save_tree (convert (integer_type_node
,
4505 ffecom_expr (arg5
)));
4507 ffecom_pop_calltemps ();
4510 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4511 ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4512 ffecom_2 (RSHIFT_EXPR
, arg4_type
,
4515 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4516 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4517 ffecom_1 (BIT_NOT_EXPR
,
4521 integer_zero_node
)),
4525 = ffecom_save_tree (ffecom_2 (PLUS_EXPR
, arg4_type
,
4529 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4530 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4532 integer_zero_node
)),
4534 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4536 = ffecom_3 (COND_EXPR
, arg4_type
,
4538 (ffecom_2 (NE_EXPR
, integer_type_node
,
4540 convert (TREE_TYPE (arg5_plus_arg3
),
4541 TYPE_SIZE (arg4_type
)))),
4543 convert (arg4_type
, integer_zero_node
));
4546 = ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4548 ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4550 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4551 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4552 ffecom_1 (BIT_NOT_EXPR
,
4556 integer_zero_node
)),
4559 = ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4562 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4564 = ffecom_3 (COND_EXPR
, arg4_type
,
4566 (ffecom_2 (NE_EXPR
, integer_type_node
,
4568 convert (TREE_TYPE (arg3_tree
),
4569 integer_zero_node
))),
4573 = ffecom_3 (COND_EXPR
, arg4_type
,
4575 (ffecom_2 (NE_EXPR
, integer_type_node
,
4577 convert (TREE_TYPE (arg3_tree
),
4578 TYPE_SIZE (arg4_type
)))),
4583 = ffecom_2s (MODIFY_EXPR
, void_type_node
,
4586 /* Make sure SAVE_EXPRs get referenced early enough. */
4588 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4590 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4592 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4594 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4598 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4605 case FFEINTRIN_impDERF
:
4606 case FFEINTRIN_impERF
:
4607 case FFEINTRIN_impDERFC
:
4608 case FFEINTRIN_impERFC
:
4611 case FFEINTRIN_impIARGC
:
4612 /* extern int xargc; i__1 = xargc - 1; */
4613 expr_tree
= ffecom_2 (MINUS_EXPR
, TREE_TYPE (ffecom_tree_xargc_
),
4615 convert (TREE_TYPE (ffecom_tree_xargc_
),
4619 case FFEINTRIN_impSIGNAL_func
:
4620 case FFEINTRIN_impSIGNAL_subr
:
4626 ffecom_push_calltemps ();
4628 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4629 ffecom_expr (arg1
));
4630 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4631 build_pointer_type (TREE_TYPE (arg1_tree
)),
4634 /* Pass procedure as a pointer to it, anything else by value. */
4635 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4636 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4638 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4639 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4643 arg3_tree
= ffecom_expr_rw (arg3
);
4645 arg3_tree
= NULL_TREE
;
4647 ffecom_pop_calltemps ();
4649 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4650 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4651 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4654 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4655 ffecom_gfrt_kindtype (gfrt
),
4657 ((codegen_imp
== FFEINTRIN_impSIGNAL_subr
) ?
4661 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4663 if (arg3_tree
!= NULL_TREE
)
4665 = ffecom_modify (NULL_TREE
, arg3_tree
,
4666 convert (TREE_TYPE (arg3_tree
),
4671 case FFEINTRIN_impALARM
:
4677 ffecom_push_calltemps ();
4679 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4680 ffecom_expr (arg1
));
4681 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4682 build_pointer_type (TREE_TYPE (arg1_tree
)),
4685 /* Pass procedure as a pointer to it, anything else by value. */
4686 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4687 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4689 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4690 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4694 arg3_tree
= ffecom_expr_rw (arg3
);
4696 arg3_tree
= NULL_TREE
;
4698 ffecom_pop_calltemps ();
4700 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4701 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4702 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4705 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4706 ffecom_gfrt_kindtype (gfrt
),
4710 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4712 if (arg3_tree
!= NULL_TREE
)
4714 = ffecom_modify (NULL_TREE
, arg3_tree
,
4715 convert (TREE_TYPE (arg3_tree
),
4720 case FFEINTRIN_impCHDIR_subr
:
4721 case FFEINTRIN_impFDATE_subr
:
4722 case FFEINTRIN_impFGET_subr
:
4723 case FFEINTRIN_impFPUT_subr
:
4724 case FFEINTRIN_impGETCWD_subr
:
4725 case FFEINTRIN_impHOSTNM_subr
:
4726 case FFEINTRIN_impSYSTEM_subr
:
4727 case FFEINTRIN_impUNLINK_subr
:
4729 tree arg1_len
= integer_zero_node
;
4733 ffecom_push_calltemps ();
4735 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4738 arg2_tree
= ffecom_expr_rw (arg2
);
4740 arg2_tree
= NULL_TREE
;
4742 ffecom_pop_calltemps ();
4744 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4745 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4746 TREE_CHAIN (arg1_tree
) = arg1_len
;
4749 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4750 ffecom_gfrt_kindtype (gfrt
),
4754 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4756 if (arg2_tree
!= NULL_TREE
)
4758 = ffecom_modify (NULL_TREE
, arg2_tree
,
4759 convert (TREE_TYPE (arg2_tree
),
4764 case FFEINTRIN_impEXIT
:
4768 expr_tree
= build_tree_list (NULL_TREE
,
4769 ffecom_1 (ADDR_EXPR
,
4771 (ffecom_integer_type_node
),
4772 integer_zero_node
));
4775 ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4776 ffecom_gfrt_kindtype (gfrt
),
4780 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4782 case FFEINTRIN_impFLUSH
:
4784 gfrt
= FFECOM_gfrtFLUSH
;
4786 gfrt
= FFECOM_gfrtFLUSH1
;
4789 case FFEINTRIN_impCHMOD_subr
:
4790 case FFEINTRIN_impLINK_subr
:
4791 case FFEINTRIN_impRENAME_subr
:
4792 case FFEINTRIN_impSYMLNK_subr
:
4794 tree arg1_len
= integer_zero_node
;
4796 tree arg2_len
= integer_zero_node
;
4800 ffecom_push_calltemps ();
4802 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4803 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
4805 arg3_tree
= ffecom_expr_rw (arg3
);
4807 arg3_tree
= NULL_TREE
;
4809 ffecom_pop_calltemps ();
4811 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4812 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4813 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4814 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
4815 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4816 TREE_CHAIN (arg2_tree
) = arg1_len
;
4817 TREE_CHAIN (arg1_len
) = arg2_len
;
4818 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4819 ffecom_gfrt_kindtype (gfrt
),
4823 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4824 if (arg3_tree
!= NULL_TREE
)
4825 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4826 convert (TREE_TYPE (arg3_tree
),
4831 case FFEINTRIN_impLSTAT_subr
:
4832 case FFEINTRIN_impSTAT_subr
:
4834 tree arg1_len
= integer_zero_node
;
4839 ffecom_push_calltemps ();
4841 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4843 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4846 arg3_tree
= ffecom_expr_rw (arg3
);
4848 arg3_tree
= NULL_TREE
;
4850 ffecom_pop_calltemps ();
4852 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4853 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4854 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4855 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4856 TREE_CHAIN (arg2_tree
) = arg1_len
;
4857 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4858 ffecom_gfrt_kindtype (gfrt
),
4862 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4863 if (arg3_tree
!= NULL_TREE
)
4864 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4865 convert (TREE_TYPE (arg3_tree
),
4870 case FFEINTRIN_impFGETC_subr
:
4871 case FFEINTRIN_impFPUTC_subr
:
4875 tree arg2_len
= integer_zero_node
;
4878 ffecom_push_calltemps ();
4880 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4881 ffecom_expr (arg1
));
4882 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4883 build_pointer_type (TREE_TYPE (arg1_tree
)),
4886 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
4887 arg3_tree
= ffecom_expr_rw (arg3
);
4889 ffecom_pop_calltemps ();
4891 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4892 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4893 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
4894 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4895 TREE_CHAIN (arg2_tree
) = arg2_len
;
4897 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4898 ffecom_gfrt_kindtype (gfrt
),
4902 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4903 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4904 convert (TREE_TYPE (arg3_tree
),
4909 case FFEINTRIN_impFSTAT_subr
:
4915 ffecom_push_calltemps ();
4917 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4918 ffecom_expr (arg1
));
4919 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4920 build_pointer_type (TREE_TYPE (arg1_tree
)),
4923 arg2_tree
= convert (ffecom_f2c_ptr_to_integer_type_node
,
4924 ffecom_ptr_to_expr (arg2
));
4927 arg3_tree
= NULL_TREE
;
4929 arg3_tree
= ffecom_expr_rw (arg3
);
4931 ffecom_pop_calltemps ();
4933 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4934 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4935 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4936 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4937 ffecom_gfrt_kindtype (gfrt
),
4941 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4942 if (arg3_tree
!= NULL_TREE
) {
4943 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4944 convert (TREE_TYPE (arg3_tree
),
4950 case FFEINTRIN_impKILL_subr
:
4956 ffecom_push_calltemps ();
4958 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4959 ffecom_expr (arg1
));
4960 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4961 build_pointer_type (TREE_TYPE (arg1_tree
)),
4964 arg2_tree
= convert (ffecom_f2c_integer_type_node
,
4965 ffecom_expr (arg2
));
4966 arg2_tree
= ffecom_1 (ADDR_EXPR
,
4967 build_pointer_type (TREE_TYPE (arg2_tree
)),
4971 arg3_tree
= NULL_TREE
;
4973 arg3_tree
= ffecom_expr_rw (arg3
);
4975 ffecom_pop_calltemps ();
4977 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4978 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4979 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4980 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4981 ffecom_gfrt_kindtype (gfrt
),
4985 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4986 if (arg3_tree
!= NULL_TREE
) {
4987 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4988 convert (TREE_TYPE (arg3_tree
),
4994 case FFEINTRIN_impCTIME_subr
:
4995 case FFEINTRIN_impTTYNAM_subr
:
4997 tree arg1_len
= integer_zero_node
;
5001 ffecom_push_calltemps ();
5003 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
5005 arg2_tree
= convert (((gfrt
== FFEINTRIN_impCTIME_subr
) ?
5006 ffecom_f2c_longint_type_node
:
5007 ffecom_f2c_integer_type_node
),
5008 ffecom_expr (arg2
));
5009 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5010 build_pointer_type (TREE_TYPE (arg2_tree
)),
5013 ffecom_pop_calltemps ();
5015 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5016 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5017 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5018 TREE_CHAIN (arg1_len
) = arg2_tree
;
5019 TREE_CHAIN (arg1_tree
) = arg1_len
;
5022 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5023 ffecom_gfrt_kindtype (gfrt
),
5027 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
5031 case FFEINTRIN_impIRAND
:
5032 case FFEINTRIN_impRAND
:
5033 /* Arg defaults to 0 (normal random case) */
5038 arg1_tree
= ffecom_integer_zero_node
;
5040 arg1_tree
= ffecom_expr (arg1
);
5041 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5043 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5044 build_pointer_type (TREE_TYPE (arg1_tree
)),
5046 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5048 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5049 ffecom_gfrt_kindtype (gfrt
),
5051 ((codegen_imp
== FFEINTRIN_impIRAND
) ?
5052 ffecom_f2c_integer_type_node
:
5053 ffecom_f2c_doublereal_type_node
),
5055 dest_tree
, dest
, dest_used
,
5060 case FFEINTRIN_impFTELL_subr
:
5061 case FFEINTRIN_impUMASK_subr
:
5066 ffecom_push_calltemps ();
5068 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5069 ffecom_expr (arg1
));
5070 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5071 build_pointer_type (TREE_TYPE (arg1_tree
)),
5075 arg2_tree
= NULL_TREE
;
5077 arg2_tree
= ffecom_expr_rw (arg2
);
5079 ffecom_pop_calltemps ();
5081 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5082 ffecom_gfrt_kindtype (gfrt
),
5085 build_tree_list (NULL_TREE
, arg1_tree
),
5086 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5088 if (arg2_tree
!= NULL_TREE
) {
5089 expr_tree
= ffecom_modify (NULL_TREE
, arg2_tree
,
5090 convert (TREE_TYPE (arg2_tree
),
5096 case FFEINTRIN_impCPU_TIME
:
5097 case FFEINTRIN_impSECOND_subr
:
5101 ffecom_push_calltemps ();
5103 arg1_tree
= ffecom_expr_rw (arg1
);
5105 ffecom_pop_calltemps ();
5108 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5109 ffecom_gfrt_kindtype (gfrt
),
5113 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
5116 = ffecom_modify (NULL_TREE
, arg1_tree
,
5117 convert (TREE_TYPE (arg1_tree
),
5122 case FFEINTRIN_impDTIME_subr
:
5123 case FFEINTRIN_impETIME_subr
:
5128 ffecom_push_calltemps ();
5130 arg1_tree
= ffecom_expr_rw (arg1
);
5132 arg2_tree
= ffecom_ptr_to_expr (arg2
);
5134 ffecom_pop_calltemps ();
5136 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5137 ffecom_gfrt_kindtype (gfrt
),
5140 build_tree_list (NULL_TREE
, arg2_tree
),
5141 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5143 expr_tree
= ffecom_modify (NULL_TREE
, arg1_tree
,
5144 convert (TREE_TYPE (arg1_tree
),
5149 /* Straightforward calls of libf2c routines: */
5150 case FFEINTRIN_impABORT
:
5151 case FFEINTRIN_impACCESS
:
5152 case FFEINTRIN_impBESJ0
:
5153 case FFEINTRIN_impBESJ1
:
5154 case FFEINTRIN_impBESJN
:
5155 case FFEINTRIN_impBESY0
:
5156 case FFEINTRIN_impBESY1
:
5157 case FFEINTRIN_impBESYN
:
5158 case FFEINTRIN_impCHDIR_func
:
5159 case FFEINTRIN_impCHMOD_func
:
5160 case FFEINTRIN_impDATE
:
5161 case FFEINTRIN_impDBESJ0
:
5162 case FFEINTRIN_impDBESJ1
:
5163 case FFEINTRIN_impDBESJN
:
5164 case FFEINTRIN_impDBESY0
:
5165 case FFEINTRIN_impDBESY1
:
5166 case FFEINTRIN_impDBESYN
:
5167 case FFEINTRIN_impDTIME_func
:
5168 case FFEINTRIN_impETIME_func
:
5169 case FFEINTRIN_impFGETC_func
:
5170 case FFEINTRIN_impFGET_func
:
5171 case FFEINTRIN_impFNUM
:
5172 case FFEINTRIN_impFPUTC_func
:
5173 case FFEINTRIN_impFPUT_func
:
5174 case FFEINTRIN_impFSEEK
:
5175 case FFEINTRIN_impFSTAT_func
:
5176 case FFEINTRIN_impFTELL_func
:
5177 case FFEINTRIN_impGERROR
:
5178 case FFEINTRIN_impGETARG
:
5179 case FFEINTRIN_impGETCWD_func
:
5180 case FFEINTRIN_impGETENV
:
5181 case FFEINTRIN_impGETGID
:
5182 case FFEINTRIN_impGETLOG
:
5183 case FFEINTRIN_impGETPID
:
5184 case FFEINTRIN_impGETUID
:
5185 case FFEINTRIN_impGMTIME
:
5186 case FFEINTRIN_impHOSTNM_func
:
5187 case FFEINTRIN_impIDATE_unix
:
5188 case FFEINTRIN_impIDATE_vxt
:
5189 case FFEINTRIN_impIERRNO
:
5190 case FFEINTRIN_impISATTY
:
5191 case FFEINTRIN_impITIME
:
5192 case FFEINTRIN_impKILL_func
:
5193 case FFEINTRIN_impLINK_func
:
5194 case FFEINTRIN_impLNBLNK
:
5195 case FFEINTRIN_impLSTAT_func
:
5196 case FFEINTRIN_impLTIME
:
5197 case FFEINTRIN_impMCLOCK8
:
5198 case FFEINTRIN_impMCLOCK
:
5199 case FFEINTRIN_impPERROR
:
5200 case FFEINTRIN_impRENAME_func
:
5201 case FFEINTRIN_impSECNDS
:
5202 case FFEINTRIN_impSECOND_func
:
5203 case FFEINTRIN_impSLEEP
:
5204 case FFEINTRIN_impSRAND
:
5205 case FFEINTRIN_impSTAT_func
:
5206 case FFEINTRIN_impSYMLNK_func
:
5207 case FFEINTRIN_impSYSTEM_CLOCK
:
5208 case FFEINTRIN_impSYSTEM_func
:
5209 case FFEINTRIN_impTIME8
:
5210 case FFEINTRIN_impTIME_unix
:
5211 case FFEINTRIN_impTIME_vxt
:
5212 case FFEINTRIN_impUMASK_func
:
5213 case FFEINTRIN_impUNLINK_func
:
5216 case FFEINTRIN_impCTIME_func
: /* CHARACTER functions not handled here. */
5217 case FFEINTRIN_impFDATE_func
: /* CHARACTER functions not handled here. */
5218 case FFEINTRIN_impTTYNAM_func
: /* CHARACTER functions not handled here. */
5219 case FFEINTRIN_impNONE
:
5220 case FFEINTRIN_imp
: /* Hush up gcc warning. */
5221 fprintf (stderr
, "No %s implementation.\n",
5222 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr
))));
5223 assert ("unimplemented intrinsic" == NULL
);
5224 return error_mark_node
;
5227 assert (gfrt
!= FFECOM_gfrt
); /* Must have an implementation! */
5229 ffecom_push_calltemps ();
5230 expr_tree
= ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt
),
5231 ffebld_right (expr
));
5232 ffecom_pop_calltemps ();
5234 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt
), ffecom_gfrt_kindtype (gfrt
),
5235 (ffe_is_f2c_library () && ffecom_gfrt_complex_
[gfrt
]),
5237 expr_tree
, dest_tree
, dest
, dest_used
,
5240 /**INDENT* (Do not reformat this comment even with -fca option.)
5241 Data-gathering files: Given the source file listed below, compiled with
5242 f2c I obtained the output file listed after that, and from the output
5243 file I derived the above code.
5245 -------- (begin input file to f2c)
5251 double precision D1,D2
5253 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
5282 c FFEINTRIN_impAIMAG
5283 call fooR(AIMAG(C1))
5288 c FFEINTRIN_impALOG10
5289 call fooR(ALOG10(R1))
5290 c FFEINTRIN_impAMAX0
5291 call fooR(AMAX0(I1,I2))
5292 c FFEINTRIN_impAMAX1
5293 call fooR(AMAX1(R1,R2))
5294 c FFEINTRIN_impAMIN0
5295 call fooR(AMIN0(I1,I2))
5296 c FFEINTRIN_impAMIN1
5297 call fooR(AMIN1(R1,R2))
5299 call fooR(AMOD(R1,R2))
5300 c FFEINTRIN_impANINT
5301 call fooR(ANINT(R1))
5306 c FFEINTRIN_impATAN2
5307 call fooR(ATAN2(R1,R2))
5318 c FFEINTRIN_impCONJG
5319 call fooC(CONJG(C1))
5326 c FFEINTRIN_impCSQRT
5327 call fooC(CSQRT(C1))
5330 c FFEINTRIN_impDACOS
5331 call fooD(DACOS(D1))
5332 c FFEINTRIN_impDASIN
5333 call fooD(DASIN(D1))
5334 c FFEINTRIN_impDATAN
5335 call fooD(DATAN(D1))
5336 c FFEINTRIN_impDATAN2
5337 call fooD(DATAN2(D1,D2))
5340 c FFEINTRIN_impDCOSH
5341 call fooD(DCOSH(D1))
5343 call fooD(DDIM(D1,D2))
5347 call fooR(DIM(R1,R2))
5352 c FFEINTRIN_impDLOG10
5353 call fooD(DLOG10(D1))
5354 c FFEINTRIN_impDMAX1
5355 call fooD(DMAX1(D1,D2))
5356 c FFEINTRIN_impDMIN1
5357 call fooD(DMIN1(D1,D2))
5359 call fooD(DMOD(D1,D2))
5360 c FFEINTRIN_impDNINT
5361 call fooD(DNINT(D1))
5362 c FFEINTRIN_impDPROD
5363 call fooD(DPROD(R1,R2))
5364 c FFEINTRIN_impDSIGN
5365 call fooD(DSIGN(D1,D2))
5368 c FFEINTRIN_impDSINH
5369 call fooD(DSINH(D1))
5370 c FFEINTRIN_impDSQRT
5371 call fooD(DSQRT(D1))
5374 c FFEINTRIN_impDTANH
5375 call fooD(DTANH(D1))
5380 c FFEINTRIN_impICHAR
5381 call fooI(ICHAR(A1))
5383 call fooI(IDIM(I1,I2))
5384 c FFEINTRIN_impIDNINT
5385 call fooI(IDNINT(D1))
5386 c FFEINTRIN_impINDEX
5387 call fooI(INDEX(A1,A2))
5388 c FFEINTRIN_impISIGN
5389 call fooI(ISIGN(I1,I2))
5393 call fooL(LGE(A1,A2))
5395 call fooL(LGT(A1,A2))
5397 call fooL(LLE(A1,A2))
5399 call fooL(LLT(A1,A2))
5401 call fooI(MAX0(I1,I2))
5403 call fooI(MAX1(R1,R2))
5405 call fooI(MIN0(I1,I2))
5407 call fooI(MIN1(R1,R2))
5409 call fooI(MOD(I1,I2))
5413 call fooR(SIGN(R1,R2))
5424 c FFEINTRIN_imp_CMPLX_C
5425 call fooC(cmplx(C1,C2))
5426 c FFEINTRIN_imp_CMPLX_D
5427 call fooZ(cmplx(D1,D2))
5428 c FFEINTRIN_imp_CMPLX_I
5429 call fooC(cmplx(I1,I2))
5430 c FFEINTRIN_imp_CMPLX_R
5431 call fooC(cmplx(R1,R2))
5432 c FFEINTRIN_imp_DBLE_C
5434 c FFEINTRIN_imp_DBLE_D
5436 c FFEINTRIN_imp_DBLE_I
5438 c FFEINTRIN_imp_DBLE_R
5440 c FFEINTRIN_imp_INT_C
5442 c FFEINTRIN_imp_INT_D
5444 c FFEINTRIN_imp_INT_I
5446 c FFEINTRIN_imp_INT_R
5448 c FFEINTRIN_imp_REAL_C
5450 c FFEINTRIN_imp_REAL_D
5452 c FFEINTRIN_imp_REAL_I
5454 c FFEINTRIN_imp_REAL_R
5457 c FFEINTRIN_imp_INT_D:
5459 c FFEINTRIN_specIDINT
5460 call fooI(IDINT(D1))
5462 c FFEINTRIN_imp_INT_R:
5464 c FFEINTRIN_specIFIX
5469 c FFEINTRIN_imp_REAL_D:
5471 c FFEINTRIN_specSNGL
5474 c FFEINTRIN_imp_REAL_I:
5476 c FFEINTRIN_specFLOAT
5477 call fooR(FLOAT(I1))
5478 c FFEINTRIN_specREAL
5482 -------- (end input file to f2c)
5484 -------- (begin output from providing above input file as input to:
5485 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
5486 -------- -e "s:^#.*$::g"')
5488 // -- translated by f2c (version 19950223).
5489 You must link the resulting object file with the libraries:
5490 -lf2c -lm (in that order)
5494 // f2c.h -- Standard Fortran to C header file //
5496 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
5498 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
5503 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
5504 // we assume short, float are OK //
5505 typedef long int // long int // integer;
5506 typedef char *address;
5507 typedef short int shortint;
5509 typedef double doublereal;
5510 typedef struct { real r, i; } complex;
5511 typedef struct { doublereal r, i; } doublecomplex;
5512 typedef long int // long int // logical;
5513 typedef short int shortlogical;
5514 typedef char logical1;
5515 typedef char integer1;
5516 // typedef long long longint; // // system-dependent //
5521 // Extern is for use with -E //
5535 typedef long int // int or long int // flag;
5536 typedef long int // int or long int // ftnlen;
5537 typedef long int // int or long int // ftnint;
5540 //external read, write//
5549 //internal read, write//
5579 //rewind, backspace, endfile//
5591 ftnint *inex; //parameters in standard's order//
5617 union Multitype { // for multiple entry points //
5628 typedef union Multitype Multitype;
5630 typedef long Long; // No longer used; formerly in Namelist //
5632 struct Vardesc { // for Namelist //
5638 typedef struct Vardesc Vardesc;
5645 typedef struct Namelist Namelist;
5654 // procedure parameter types for -A and -C++ //
5659 typedef int // Unknown procedure type // (*U_fp)();
5660 typedef shortint (*J_fp)();
5661 typedef integer (*I_fp)();
5662 typedef real (*R_fp)();
5663 typedef doublereal (*D_fp)(), (*E_fp)();
5664 typedef // Complex // void (*C_fp)();
5665 typedef // Double Complex // void (*Z_fp)();
5666 typedef logical (*L_fp)();
5667 typedef shortlogical (*K_fp)();
5668 typedef // Character // void (*H_fp)();
5669 typedef // Subroutine // int (*S_fp)();
5671 // E_fp is for real functions when -R is not specified //
5672 typedef void C_f; // complex function //
5673 typedef void H_f; // character function //
5674 typedef void Z_f; // double complex function //
5675 typedef doublereal E_f; // real function with -R not specified //
5677 // undef any lower-case symbols that your C compiler predefines, e.g.: //
5680 // (No such symbols should be defined in a strict ANSI C compiler.
5681 We can avoid trouble with f2c-translated code by using
5682 gcc -ansi [-traditional].) //
5706 // Main program // MAIN__()
5708 // System generated locals //
5711 doublereal d__1, d__2;
5713 doublecomplex z__1, z__2, z__3;
5717 // Builtin functions //
5720 double pow_ri(), pow_di();
5724 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
5725 asin(), atan(), atan2(), c_abs();
5726 void c_cos(), c_exp(), c_log(), r_cnjg();
5727 double cos(), cosh();
5728 void c_sin(), c_sqrt();
5729 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
5730 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
5731 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
5732 logical l_ge(), l_gt(), l_le(), l_lt();
5736 // Local variables //
5737 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
5738 fool_(), fooz_(), getem_();
5739 static char a1[10], a2[10];
5740 static complex c1, c2;
5741 static doublereal d1, d2;
5742 static integer i1, i2;
5746 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
5754 d__1 = (doublereal) i1;
5755 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
5765 c_div(&q__1, &c1, &c2);
5767 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
5769 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
5772 i__1 = pow_ii(&i1, &i2);
5774 r__1 = pow_ri(&r1, &i1);
5776 d__1 = pow_di(&d1, &i1);
5778 pow_ci(&q__1, &c1, &i1);
5780 d__1 = (doublereal) r1;
5781 d__2 = (doublereal) r2;
5782 r__1 = pow_dd(&d__1, &d__2);
5784 d__2 = (doublereal) r1;
5785 d__1 = pow_dd(&d__2, &d1);
5787 d__1 = pow_dd(&d1, &d2);
5789 d__2 = (doublereal) r1;
5790 d__1 = pow_dd(&d1, &d__2);
5792 z__2.r = c1.r, z__2.i = c1.i;
5793 z__3.r = c2.r, z__3.i = c2.i;
5794 pow_zz(&z__1, &z__2, &z__3);
5795 q__1.r = z__1.r, q__1.i = z__1.i;
5797 z__2.r = c1.r, z__2.i = c1.i;
5798 z__3.r = r1, z__3.i = 0.;
5799 pow_zz(&z__1, &z__2, &z__3);
5800 q__1.r = z__1.r, q__1.i = z__1.i;
5802 z__2.r = c1.r, z__2.i = c1.i;
5803 z__3.r = d1, z__3.i = 0.;
5804 pow_zz(&z__1, &z__2, &z__3);
5806 // FFEINTRIN_impABS //
5807 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
5809 // FFEINTRIN_impACOS //
5812 // FFEINTRIN_impAIMAG //
5815 // FFEINTRIN_impAINT //
5818 // FFEINTRIN_impALOG //
5821 // FFEINTRIN_impALOG10 //
5824 // FFEINTRIN_impAMAX0 //
5825 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
5827 // FFEINTRIN_impAMAX1 //
5828 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
5830 // FFEINTRIN_impAMIN0 //
5831 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
5833 // FFEINTRIN_impAMIN1 //
5834 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
5836 // FFEINTRIN_impAMOD //
5837 r__1 = r_mod(&r1, &r2);
5839 // FFEINTRIN_impANINT //
5842 // FFEINTRIN_impASIN //
5845 // FFEINTRIN_impATAN //
5848 // FFEINTRIN_impATAN2 //
5849 r__1 = atan2(r1, r2);
5851 // FFEINTRIN_impCABS //
5854 // FFEINTRIN_impCCOS //
5857 // FFEINTRIN_impCEXP //
5860 // FFEINTRIN_impCHAR //
5861 *(unsigned char *)&ch__1[0] = i1;
5863 // FFEINTRIN_impCLOG //
5866 // FFEINTRIN_impCONJG //
5869 // FFEINTRIN_impCOS //
5872 // FFEINTRIN_impCOSH //
5875 // FFEINTRIN_impCSIN //
5878 // FFEINTRIN_impCSQRT //
5881 // FFEINTRIN_impDABS //
5882 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
5884 // FFEINTRIN_impDACOS //
5887 // FFEINTRIN_impDASIN //
5890 // FFEINTRIN_impDATAN //
5893 // FFEINTRIN_impDATAN2 //
5894 d__1 = atan2(d1, d2);
5896 // FFEINTRIN_impDCOS //
5899 // FFEINTRIN_impDCOSH //
5902 // FFEINTRIN_impDDIM //
5903 d__1 = d_dim(&d1, &d2);
5905 // FFEINTRIN_impDEXP //
5908 // FFEINTRIN_impDIM //
5909 r__1 = r_dim(&r1, &r2);
5911 // FFEINTRIN_impDINT //
5914 // FFEINTRIN_impDLOG //
5917 // FFEINTRIN_impDLOG10 //
5920 // FFEINTRIN_impDMAX1 //
5921 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
5923 // FFEINTRIN_impDMIN1 //
5924 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
5926 // FFEINTRIN_impDMOD //
5927 d__1 = d_mod(&d1, &d2);
5929 // FFEINTRIN_impDNINT //
5932 // FFEINTRIN_impDPROD //
5933 d__1 = (doublereal) r1 * r2;
5935 // FFEINTRIN_impDSIGN //
5936 d__1 = d_sign(&d1, &d2);
5938 // FFEINTRIN_impDSIN //
5941 // FFEINTRIN_impDSINH //
5944 // FFEINTRIN_impDSQRT //
5947 // FFEINTRIN_impDTAN //
5950 // FFEINTRIN_impDTANH //
5953 // FFEINTRIN_impEXP //
5956 // FFEINTRIN_impIABS //
5957 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
5959 // FFEINTRIN_impICHAR //
5960 i__1 = *(unsigned char *)a1;
5962 // FFEINTRIN_impIDIM //
5963 i__1 = i_dim(&i1, &i2);
5965 // FFEINTRIN_impIDNINT //
5968 // FFEINTRIN_impINDEX //
5969 i__1 = i_indx(a1, a2, 10L, 10L);
5971 // FFEINTRIN_impISIGN //
5972 i__1 = i_sign(&i1, &i2);
5974 // FFEINTRIN_impLEN //
5975 i__1 = i_len(a1, 10L);
5977 // FFEINTRIN_impLGE //
5978 L__1 = l_ge(a1, a2, 10L, 10L);
5980 // FFEINTRIN_impLGT //
5981 L__1 = l_gt(a1, a2, 10L, 10L);
5983 // FFEINTRIN_impLLE //
5984 L__1 = l_le(a1, a2, 10L, 10L);
5986 // FFEINTRIN_impLLT //
5987 L__1 = l_lt(a1, a2, 10L, 10L);
5989 // FFEINTRIN_impMAX0 //
5990 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
5992 // FFEINTRIN_impMAX1 //
5993 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
5995 // FFEINTRIN_impMIN0 //
5996 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
5998 // FFEINTRIN_impMIN1 //
5999 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
6001 // FFEINTRIN_impMOD //
6004 // FFEINTRIN_impNINT //
6007 // FFEINTRIN_impSIGN //
6008 r__1 = r_sign(&r1, &r2);
6010 // FFEINTRIN_impSIN //
6013 // FFEINTRIN_impSINH //
6016 // FFEINTRIN_impSQRT //
6019 // FFEINTRIN_impTAN //
6022 // FFEINTRIN_impTANH //
6025 // FFEINTRIN_imp_CMPLX_C //
6028 q__1.r = r__1, q__1.i = r__2;
6030 // FFEINTRIN_imp_CMPLX_D //
6031 z__1.r = d1, z__1.i = d2;
6033 // FFEINTRIN_imp_CMPLX_I //
6036 q__1.r = r__1, q__1.i = r__2;
6038 // FFEINTRIN_imp_CMPLX_R //
6039 q__1.r = r1, q__1.i = r2;
6041 // FFEINTRIN_imp_DBLE_C //
6042 d__1 = (doublereal) c1.r;
6044 // FFEINTRIN_imp_DBLE_D //
6047 // FFEINTRIN_imp_DBLE_I //
6048 d__1 = (doublereal) i1;
6050 // FFEINTRIN_imp_DBLE_R //
6051 d__1 = (doublereal) r1;
6053 // FFEINTRIN_imp_INT_C //
6054 i__1 = (integer) c1.r;
6056 // FFEINTRIN_imp_INT_D //
6057 i__1 = (integer) d1;
6059 // FFEINTRIN_imp_INT_I //
6062 // FFEINTRIN_imp_INT_R //
6063 i__1 = (integer) r1;
6065 // FFEINTRIN_imp_REAL_C //
6068 // FFEINTRIN_imp_REAL_D //
6071 // FFEINTRIN_imp_REAL_I //
6074 // FFEINTRIN_imp_REAL_R //
6078 // FFEINTRIN_imp_INT_D: //
6080 // FFEINTRIN_specIDINT //
6081 i__1 = (integer) d1;
6084 // FFEINTRIN_imp_INT_R: //
6086 // FFEINTRIN_specIFIX //
6087 i__1 = (integer) r1;
6089 // FFEINTRIN_specINT //
6090 i__1 = (integer) r1;
6093 // FFEINTRIN_imp_REAL_D: //
6095 // FFEINTRIN_specSNGL //
6099 // FFEINTRIN_imp_REAL_I: //
6101 // FFEINTRIN_specFLOAT //
6104 // FFEINTRIN_specREAL //
6110 -------- (end output file from f2c)
6116 /* For power (exponentiation) where right-hand operand is type INTEGER,
6117 generate in-line code to do it the fast way (which, if the operand
6118 is a constant, might just mean a series of multiplies). */
6120 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6122 ffecom_expr_power_integer_ (ffebld left
, ffebld right
)
6124 tree l
= ffecom_expr (left
);
6125 tree r
= ffecom_expr (right
);
6126 tree ltype
= TREE_TYPE (l
);
6127 tree rtype
= TREE_TYPE (r
);
6128 tree result
= NULL_TREE
;
6130 if (l
== error_mark_node
6131 || r
== error_mark_node
)
6132 return error_mark_node
;
6134 if (TREE_CODE (r
) == INTEGER_CST
)
6136 int sgn
= tree_int_cst_sgn (r
);
6139 return convert (ltype
, integer_one_node
);
6141 if ((TREE_CODE (ltype
) == INTEGER_TYPE
)
6144 /* Reciprocal of integer is either 0, -1, or 1, so after
6145 calculating that (which we leave to the back end to do
6146 or not do optimally), don't bother with any multiplying. */
6148 result
= ffecom_tree_divide_ (ltype
,
6149 convert (ltype
, integer_one_node
),
6151 NULL_TREE
, NULL
, NULL
);
6152 r
= ffecom_1 (NEGATE_EXPR
,
6155 if ((TREE_INT_CST_LOW (r
) & 1) == 0)
6156 result
= ffecom_1 (ABS_EXPR
, rtype
,
6160 /* Generate appropriate series of multiplies, preceded
6161 by divide if the exponent is negative. */
6167 l
= ffecom_tree_divide_ (ltype
,
6168 convert (ltype
, integer_one_node
),
6170 NULL_TREE
, NULL
, NULL
);
6171 r
= ffecom_1 (NEGATE_EXPR
, rtype
, r
);
6172 assert (TREE_CODE (r
) == INTEGER_CST
);
6174 if (tree_int_cst_sgn (r
) < 0)
6175 { /* The "most negative" number. */
6176 r
= ffecom_1 (NEGATE_EXPR
, rtype
,
6177 ffecom_2 (RSHIFT_EXPR
, rtype
,
6181 l
= ffecom_2 (MULT_EXPR
, ltype
,
6189 if (TREE_INT_CST_LOW (r
) & 1)
6191 if (result
== NULL_TREE
)
6194 result
= ffecom_2 (MULT_EXPR
, ltype
,
6199 r
= ffecom_2 (RSHIFT_EXPR
, rtype
,
6202 if (integer_zerop (r
))
6204 assert (TREE_CODE (r
) == INTEGER_CST
);
6207 l
= ffecom_2 (MULT_EXPR
, ltype
,
6214 /* Though rhs isn't a constant, in-line code cannot be expanded
6215 while transforming dummies
6216 because the back end cannot be easily convinced to generate
6217 stores (MODIFY_EXPR), handle temporaries, and so on before
6218 all the appropriate rtx's have been generated for things like
6219 dummy args referenced in rhs -- which doesn't happen until
6220 store_parm_decls() is called (expand_function_start, I believe,
6221 does the actual rtx-stuffing of PARM_DECLs).
6223 So, in this case, let the caller generate the call to the
6224 run-time-library function to evaluate the power for us. */
6226 if (ffecom_transform_only_dummies_
)
6229 /* Right-hand operand not a constant, expand in-line code to figure
6230 out how to do the multiplies, &c.
6232 The returned expression is expressed this way in GNU C, where l and
6235 ({ typeof (r) rtmp = r;
6236 typeof (l) ltmp = l;
6243 if ((basetypeof (l) == basetypeof (int))
6246 result = ((typeof (l)) 1) / ltmp;
6247 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
6253 if ((basetypeof (l) != basetypeof (int))
6256 ltmp = ((typeof (l)) 1) / ltmp;
6260 rtmp = -(rtmp >> 1);
6268 if ((rtmp >>= 1) == 0)
6277 Note that some of the above is compile-time collapsable, such as
6278 the first part of the if statements that checks the base type of
6279 l against int. The if statements are phrased that way to suggest
6280 an easy way to generate the if/else constructs here, knowing that
6281 the back end should (and probably does) eliminate the resulting
6282 dead code (either the int case or the non-int case), something
6283 it couldn't do without the redundant phrasing, requiring explicit
6284 dead-code elimination here, which would be kind of difficult to
6290 tree basetypeof_l_is_int
;
6294 = build_int_2 ((TREE_CODE (ltype
) == INTEGER_TYPE
), 0);
6296 se
= expand_start_stmt_expr ();
6297 ffecom_push_calltemps ();
6299 rtmp
= ffecom_push_tempvar (rtype
, FFETARGET_charactersizeNONE
, -1,
6301 ltmp
= ffecom_push_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1,
6303 result
= ffecom_push_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1,
6306 expand_expr_stmt (ffecom_modify (void_type_node
,
6309 expand_expr_stmt (ffecom_modify (void_type_node
,
6312 expand_start_cond (ffecom_truth_value
6313 (ffecom_2 (EQ_EXPR
, integer_type_node
,
6315 convert (rtype
, integer_zero_node
))),
6317 expand_expr_stmt (ffecom_modify (void_type_node
,
6319 convert (ltype
, integer_one_node
)));
6320 expand_start_else ();
6321 if (!integer_zerop (basetypeof_l_is_int
))
6323 expand_start_cond (ffecom_2 (LT_EXPR
, integer_type_node
,
6326 integer_zero_node
)),
6328 expand_expr_stmt (ffecom_modify (void_type_node
,
6332 convert (ltype
, integer_one_node
),
6334 NULL_TREE
, NULL
, NULL
)));
6335 expand_start_cond (ffecom_truth_value
6336 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
6337 ffecom_2 (LT_EXPR
, integer_type_node
,
6340 integer_zero_node
)),
6341 ffecom_2 (EQ_EXPR
, integer_type_node
,
6342 ffecom_2 (BIT_AND_EXPR
,
6344 ffecom_1 (NEGATE_EXPR
,
6350 integer_zero_node
)))),
6352 expand_expr_stmt (ffecom_modify (void_type_node
,
6354 ffecom_1 (NEGATE_EXPR
,
6358 expand_start_else ();
6360 expand_expr_stmt (ffecom_modify (void_type_node
,
6362 convert (ltype
, integer_one_node
)));
6363 expand_start_cond (ffecom_truth_value
6364 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
6365 ffecom_truth_value_invert
6366 (basetypeof_l_is_int
),
6367 ffecom_2 (LT_EXPR
, integer_type_node
,
6370 integer_zero_node
)))),
6372 expand_expr_stmt (ffecom_modify (void_type_node
,
6376 convert (ltype
, integer_one_node
),
6378 NULL_TREE
, NULL
, NULL
)));
6379 expand_expr_stmt (ffecom_modify (void_type_node
,
6381 ffecom_1 (NEGATE_EXPR
, rtype
,
6383 expand_start_cond (ffecom_truth_value
6384 (ffecom_2 (LT_EXPR
, integer_type_node
,
6386 convert (rtype
, integer_zero_node
))),
6388 expand_expr_stmt (ffecom_modify (void_type_node
,
6390 ffecom_1 (NEGATE_EXPR
, rtype
,
6391 ffecom_2 (RSHIFT_EXPR
,
6394 integer_one_node
))));
6395 expand_expr_stmt (ffecom_modify (void_type_node
,
6397 ffecom_2 (MULT_EXPR
, ltype
,
6402 expand_start_loop (1);
6403 expand_start_cond (ffecom_truth_value
6404 (ffecom_2 (BIT_AND_EXPR
, rtype
,
6406 convert (rtype
, integer_one_node
))),
6408 expand_expr_stmt (ffecom_modify (void_type_node
,
6410 ffecom_2 (MULT_EXPR
, ltype
,
6414 expand_exit_loop_if_false (NULL
,
6416 (ffecom_modify (rtype
,
6418 ffecom_2 (RSHIFT_EXPR
,
6421 integer_one_node
))));
6422 expand_expr_stmt (ffecom_modify (void_type_node
,
6424 ffecom_2 (MULT_EXPR
, ltype
,
6429 if (!integer_zerop (basetypeof_l_is_int
))
6431 expand_expr_stmt (result
);
6433 ffecom_pop_calltemps ();
6434 result
= expand_end_stmt_expr (se
);
6435 TREE_SIDE_EFFECTS (result
) = 1;
6442 /* ffecom_expr_transform_ -- Transform symbols in expr
6444 ffebld expr; // FFE expression.
6445 ffecom_expr_transform_ (expr);
6447 Recursive descent on expr while transforming any untransformed SYMTERs. */
6449 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6451 ffecom_expr_transform_ (ffebld expr
)
6456 tail_recurse
: /* :::::::::::::::::::: */
6461 switch (ffebld_op (expr
))
6463 case FFEBLD_opSYMTER
:
6464 s
= ffebld_symter (expr
);
6465 t
= ffesymbol_hook (s
).decl_tree
;
6466 if ((t
== NULL_TREE
)
6467 && ((ffesymbol_kind (s
) != FFEINFO_kindNONE
)
6468 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
6469 && (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
))))
6471 s
= ffecom_sym_transform_ (s
);
6472 t
= ffesymbol_hook (s
).decl_tree
; /* Sfunc expr non-dummy,
6475 break; /* Ok if (t == NULL) here. */
6478 ffecom_expr_transform_ (ffebld_head (expr
));
6479 expr
= ffebld_trail (expr
);
6480 goto tail_recurse
; /* :::::::::::::::::::: */
6486 switch (ffebld_arity (expr
))
6489 ffecom_expr_transform_ (ffebld_left (expr
));
6490 expr
= ffebld_right (expr
);
6491 goto tail_recurse
; /* :::::::::::::::::::: */
6494 expr
= ffebld_left (expr
);
6495 goto tail_recurse
; /* :::::::::::::::::::: */
6505 /* Make a type based on info in live f2c.h file. */
6507 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6509 ffecom_f2c_make_type_ (tree
*type
, int tcode
, char *name
)
6513 case FFECOM_f2ccodeCHAR
:
6514 *type
= make_signed_type (CHAR_TYPE_SIZE
);
6517 case FFECOM_f2ccodeSHORT
:
6518 *type
= make_signed_type (SHORT_TYPE_SIZE
);
6521 case FFECOM_f2ccodeINT
:
6522 *type
= make_signed_type (INT_TYPE_SIZE
);
6525 case FFECOM_f2ccodeLONG
:
6526 *type
= make_signed_type (LONG_TYPE_SIZE
);
6529 case FFECOM_f2ccodeLONGLONG
:
6530 *type
= make_signed_type (LONG_LONG_TYPE_SIZE
);
6533 case FFECOM_f2ccodeCHARPTR
:
6534 *type
= build_pointer_type (DEFAULT_SIGNED_CHAR
6535 ? signed_char_type_node
6536 : unsigned_char_type_node
);
6539 case FFECOM_f2ccodeFLOAT
:
6540 *type
= make_node (REAL_TYPE
);
6541 TYPE_PRECISION (*type
) = FLOAT_TYPE_SIZE
;
6542 layout_type (*type
);
6545 case FFECOM_f2ccodeDOUBLE
:
6546 *type
= make_node (REAL_TYPE
);
6547 TYPE_PRECISION (*type
) = DOUBLE_TYPE_SIZE
;
6548 layout_type (*type
);
6551 case FFECOM_f2ccodeLONGDOUBLE
:
6552 *type
= make_node (REAL_TYPE
);
6553 TYPE_PRECISION (*type
) = LONG_DOUBLE_TYPE_SIZE
;
6554 layout_type (*type
);
6557 case FFECOM_f2ccodeTWOREALS
:
6558 *type
= ffecom_make_complex_type_ (ffecom_f2c_real_type_node
);
6561 case FFECOM_f2ccodeTWODOUBLEREALS
:
6562 *type
= ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node
);
6566 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL
);
6567 *type
= error_mark_node
;
6571 pushdecl (build_decl (TYPE_DECL
,
6572 ffecom_get_invented_identifier ("__g77_f2c_%s",
6578 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6579 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6583 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
6589 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
6590 if (((t
= ffecom_tree_type
[bt
][j
]) != NULL_TREE
)
6591 && (TREE_INT_CST_LOW (TYPE_SIZE (t
)) == size
))
6593 assert (code
!= -1);
6594 ffecom_f2c_typecode_
[bt
][j
] = code
;
6600 /* Finish up globals after doing all program units in file
6602 Need to handle only uninitialized COMMON areas. */
6604 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6606 ffecom_finish_global_ (ffeglobal global
)
6612 if (ffeglobal_type (global
) != FFEGLOBAL_typeCOMMON
)
6615 if (ffeglobal_common_init (global
))
6618 cbt
= ffeglobal_hook (global
);
6619 if ((cbt
== NULL_TREE
)
6620 || !ffeglobal_common_have_size (global
))
6621 return global
; /* No need to make common, never ref'd. */
6623 suspend_momentary ();
6625 DECL_EXTERNAL (cbt
) = 0;
6627 /* Give the array a size now. */
6629 size
= build_int_2 (ffeglobal_common_size (global
), 0);
6631 cbtype
= TREE_TYPE (cbt
);
6632 TYPE_DOMAIN (cbtype
) = build_range_type (integer_type_node
,
6635 if (!TREE_TYPE (size
))
6636 TREE_TYPE (size
) = TYPE_DOMAIN (cbtype
);
6637 layout_type (cbtype
);
6639 cbt
= start_decl (cbt
, FALSE
);
6640 assert (cbt
== ffeglobal_hook (global
));
6642 finish_decl (cbt
, NULL_TREE
, FALSE
);
6648 /* Finish up any untransformed symbols. */
6650 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6652 ffecom_finish_symbol_transform_ (ffesymbol s
)
6654 if ((s
== NULL
) || (TREE_CODE (current_function_decl
) == ERROR_MARK
))
6657 /* It's easy to know to transform an untransformed symbol, to make sure
6658 we put out debugging info for it. But COMMON variables, unlike
6659 EQUIVALENCE ones, aren't given declarations in addition to the
6660 tree expressions that specify offsets, because COMMON variables
6661 can be referenced in the outer scope where only dummy arguments
6662 (PARM_DECLs) should really be seen. To be safe, just don't do any
6663 VAR_DECLs for COMMON variables when we transform them for real
6664 use, and therefore we do all the VAR_DECL creating here. */
6666 if ((ffesymbol_hook (s
).decl_tree
== NULL_TREE
)
6667 && ((ffesymbol_kind (s
) != FFEINFO_kindNONE
)
6668 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
6669 && (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
)))
6670 && (ffesymbol_where (s
) != FFEINFO_whereDUMMY
))
6671 /* Not transformed, and not CHARACTER*(*), and not a dummy
6672 argument, which can happen only if the entry point names
6673 it "rides in on" are all invalidated for other reasons. */
6674 s
= ffecom_sym_transform_ (s
);
6676 if ((ffesymbol_where (s
) == FFEINFO_whereCOMMON
)
6677 && (ffesymbol_hook (s
).decl_tree
!= error_mark_node
))
6679 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
6680 int yes
= suspend_momentary ();
6682 /* This isn't working, at least for dbxout. The .s file looks
6683 okay to me (burley), but in gdb 4.9 at least, the variables
6684 appear to reside somewhere outside of the common area, so
6685 it doesn't make sense to mislead anyone by generating the info
6686 on those variables until this is fixed. NOTE: Same problem
6687 with EQUIVALENCE, sadly...see similar #if later. */
6688 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s
)),
6689 ffesymbol_storage (s
));
6691 resume_momentary (yes
);
6699 /* Append underscore(s) to name before calling get_identifier. "us"
6700 is nonzero if the name already contains an underscore and thus
6701 needs two underscores appended. */
6703 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6705 ffecom_get_appended_identifier_ (char us
, char *name
)
6711 newname
= xmalloc ((i
= strlen (name
)) + 1
6712 + ffe_is_underscoring ()
6714 memcpy (newname
, name
, i
);
6716 newname
[i
+ us
] = '_';
6717 newname
[i
+ 1 + us
] = '\0';
6718 id
= get_identifier (newname
);
6726 /* Decide whether to append underscore to name before calling
6729 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6731 ffecom_get_external_identifier_ (ffesymbol s
)
6734 char *name
= ffesymbol_text (s
);
6736 /* If name is a built-in name, just return it as is. */
6738 if (!ffe_is_underscoring ()
6739 || (strcmp (name
, FFETARGET_nameBLANK_COMMON
) == 0)
6740 #if FFETARGET_isENFORCED_MAIN_NAME
6741 || (strcmp (name
, FFETARGET_nameENFORCED_NAME
) == 0)
6743 || (strcmp (name
, FFETARGET_nameUNNAMED_MAIN
) == 0)
6745 || (strcmp (name
, FFETARGET_nameUNNAMED_BLOCK_DATA
) == 0))
6746 return get_identifier (name
);
6748 us
= ffe_is_second_underscore ()
6749 ? (strchr (name
, '_') != NULL
)
6752 return ffecom_get_appended_identifier_ (us
, name
);
6756 /* Decide whether to append underscore to internal name before calling
6759 This is for non-external, top-function-context names only. Transform
6760 identifier so it doesn't conflict with the transformed result
6761 of using a _different_ external name. E.g. if "CALL FOO" is
6762 transformed into "FOO_();", then the variable in "FOO_ = 3"
6763 must be transformed into something that does not conflict, since
6764 these two things should be independent.
6766 The transformation is as follows. If the name does not contain
6767 an underscore, there is no possible conflict, so just return.
6768 If the name does contain an underscore, then transform it just
6769 like we transform an external identifier. */
6771 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6773 ffecom_get_identifier_ (char *name
)
6775 /* If name does not contain an underscore, just return it as is. */
6777 if (!ffe_is_underscoring ()
6778 || (strchr (name
, '_') == NULL
))
6779 return get_identifier (name
);
6781 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6786 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6789 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6790 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6791 ffesymbol_kindtype(s));
6793 Call after setting up containing function and getting trees for all
6796 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6798 ffecom_gen_sfuncdef_ (ffesymbol s
, ffeinfoBasictype bt
, ffeinfoKindtype kt
)
6800 ffebld expr
= ffesymbol_sfexpr (s
);
6804 bool charfunc
= (bt
== FFEINFO_basictypeCHARACTER
);
6805 static bool recurse
= FALSE
;
6807 int old_lineno
= lineno
;
6808 char *old_input_filename
= input_filename
;
6810 ffecom_nested_entry_
= s
;
6812 /* For now, we don't have a handy pointer to where the sfunc is actually
6813 defined, though that should be easy to add to an ffesymbol. (The
6814 token/where info available might well point to the place where the type
6815 of the sfunc is declared, especially if that precedes the place where
6816 the sfunc itself is defined, which is typically the case.) We should
6817 put out a null pointer rather than point somewhere wrong, but I want to
6818 see how it works at this point. */
6820 input_filename
= ffesymbol_where_filename (s
);
6821 lineno
= ffesymbol_where_filelinenum (s
);
6823 /* Pretransform the expression so any newly discovered things belong to the
6824 outer program unit, not to the statement function. */
6826 ffecom_expr_transform_ (expr
);
6828 /* Make sure no recursive invocation of this fn (a specific case of failing
6829 to pretransform an sfunc's expression, i.e. where its expression
6830 references another untransformed sfunc) happens. */
6835 yes
= suspend_momentary ();
6837 push_f_function_context ();
6839 ffecom_push_calltemps ();
6842 type
= void_type_node
;
6845 type
= ffecom_tree_type
[bt
][kt
];
6846 if (type
== NULL_TREE
)
6847 type
= integer_type_node
; /* _sym_exec_transition reports
6851 start_function (ffecom_get_identifier_ (ffesymbol_text (s
)),
6852 build_function_type (type
, NULL_TREE
),
6853 1, /* nested/inline */
6854 0); /* TREE_PUBLIC */
6856 /* We don't worry about COMPLEX return values here, because this is
6857 entirely internal to our code, and gcc has the ability to return COMPLEX
6858 directly as a value. */
6860 yes
= suspend_momentary ();
6863 { /* Prepend arg for where result goes. */
6866 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
6868 result
= ffecom_get_invented_identifier ("__g77_%s",
6871 ffecom_char_enhance_arg_ (&type
, s
); /* Ignore returned length. */
6873 type
= build_pointer_type (type
);
6874 result
= build_decl (PARM_DECL
, result
, type
);
6876 push_parm_decl (result
);
6879 result
= NULL_TREE
; /* Not ref'd if !charfunc. */
6881 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s
), TRUE
);
6883 resume_momentary (yes
);
6885 store_parm_decls (0);
6887 ffecom_start_compstmt_ ();
6893 ffetargetCharacterSize sz
= ffesymbol_size (s
);
6896 result_length
= build_int_2 (sz
, 0);
6897 TREE_TYPE (result_length
) = ffecom_f2c_ftnlen_type_node
;
6899 ffecom_let_char_ (result
, result_length
, sz
, expr
);
6900 expand_null_return ();
6903 expand_return (ffecom_modify (NULL_TREE
,
6904 DECL_RESULT (current_function_decl
),
6905 ffecom_expr (expr
)));
6910 ffecom_end_compstmt_ ();
6912 func
= current_function_decl
;
6913 finish_function (1);
6915 ffecom_pop_calltemps ();
6917 pop_f_function_context ();
6919 resume_momentary (yes
);
6923 lineno
= old_lineno
;
6924 input_filename
= old_input_filename
;
6926 ffecom_nested_entry_
= NULL
;
6933 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6935 ffecom_gfrt_args_ (ffecomGfrt ix
)
6937 return ffecom_gfrt_argstring_
[ix
];
6941 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6943 ffecom_gfrt_tree_ (ffecomGfrt ix
)
6945 if (ffecom_gfrt_
[ix
] == NULL_TREE
)
6946 ffecom_make_gfrt_ (ix
);
6948 return ffecom_1 (ADDR_EXPR
,
6949 build_pointer_type (TREE_TYPE (ffecom_gfrt_
[ix
])),
6954 /* Return initialize-to-zero expression for this VAR_DECL. */
6956 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6958 ffecom_init_zero_ (tree decl
)
6961 int incremental
= TREE_STATIC (decl
);
6962 tree type
= TREE_TYPE (decl
);
6966 int momentary
= suspend_momentary ();
6967 push_obstacks_nochange ();
6968 if (TREE_PERMANENT (decl
))
6969 end_temporary_allocation ();
6970 make_decl_rtl (decl
, NULL
, TREE_PUBLIC (decl
) ? 1 : 0);
6971 assemble_variable (decl
, TREE_PUBLIC (decl
) ? 1 : 0, 0, 1);
6973 resume_momentary (momentary
);
6978 if ((TREE_CODE (type
) != ARRAY_TYPE
)
6979 && (TREE_CODE (type
) != RECORD_TYPE
)
6980 && (TREE_CODE (type
) != UNION_TYPE
)
6982 init
= convert (type
, integer_zero_node
);
6983 else if (!incremental
)
6985 int momentary
= suspend_momentary ();
6987 init
= build (CONSTRUCTOR
, type
, NULL_TREE
, NULL_TREE
);
6988 TREE_CONSTANT (init
) = 1;
6989 TREE_STATIC (init
) = 1;
6991 resume_momentary (momentary
);
6995 int momentary
= suspend_momentary ();
6997 assemble_zeros (int_size_in_bytes (type
));
6998 init
= error_mark_node
;
7000 resume_momentary (momentary
);
7003 pop_momentary_nofree ();
7009 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7011 ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
7017 switch (ffebld_op (arg
))
7019 case FFEBLD_opCONTER
: /* For F90, check 0-length. */
7020 if (ffetarget_length_character1
7021 (ffebld_constant_character1
7022 (ffebld_conter (arg
))) == 0)
7024 *maybe_tree
= integer_zero_node
;
7025 return convert (tree_type
, integer_zero_node
);
7028 *maybe_tree
= integer_one_node
;
7029 expr_tree
= build_int_2 (*ffetarget_text_character1
7030 (ffebld_constant_character1
7031 (ffebld_conter (arg
))),
7033 TREE_TYPE (expr_tree
) = tree_type
;
7036 case FFEBLD_opSYMTER
:
7037 case FFEBLD_opARRAYREF
:
7038 case FFEBLD_opFUNCREF
:
7039 case FFEBLD_opSUBSTR
:
7040 ffecom_push_calltemps ();
7041 ffecom_char_args_ (&expr_tree
, &length_tree
, arg
);
7042 ffecom_pop_calltemps ();
7044 if ((expr_tree
== error_mark_node
)
7045 || (length_tree
== error_mark_node
))
7047 *maybe_tree
= error_mark_node
;
7048 return error_mark_node
;
7051 if (integer_zerop (length_tree
))
7053 *maybe_tree
= integer_zero_node
;
7054 return convert (tree_type
, integer_zero_node
);
7058 = ffecom_1 (INDIRECT_REF
,
7059 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
7062 = ffecom_2 (ARRAY_REF
,
7063 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
7066 expr_tree
= convert (tree_type
, expr_tree
);
7068 if (TREE_CODE (length_tree
) == INTEGER_CST
)
7069 *maybe_tree
= integer_one_node
;
7070 else /* Must check length at run time. */
7072 = ffecom_truth_value
7073 (ffecom_2 (GT_EXPR
, integer_type_node
,
7075 ffecom_f2c_ftnlen_zero_node
));
7078 case FFEBLD_opPAREN
:
7079 case FFEBLD_opCONVERT
:
7080 if (ffeinfo_size (ffebld_info (arg
)) == 0)
7082 *maybe_tree
= integer_zero_node
;
7083 return convert (tree_type
, integer_zero_node
);
7085 return ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
7088 case FFEBLD_opCONCATENATE
:
7095 expr_left
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
7097 expr_right
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_right (arg
),
7099 *maybe_tree
= ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
7102 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
7110 assert ("bad op in ICHAR" == NULL
);
7111 return error_mark_node
;
7116 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
7120 length_arg = ffecom_intrinsic_len_ (expr);
7122 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
7123 subexpressions by constructing the appropriate tree for the
7124 length-of-character-text argument in a calling sequence. */
7126 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7128 ffecom_intrinsic_len_ (ffebld expr
)
7130 ffetargetCharacter1 val
;
7133 switch (ffebld_op (expr
))
7135 case FFEBLD_opCONTER
:
7136 val
= ffebld_constant_character1 (ffebld_conter (expr
));
7137 length
= build_int_2 (ffetarget_length_character1 (val
), 0);
7138 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
7141 case FFEBLD_opSYMTER
:
7143 ffesymbol s
= ffebld_symter (expr
);
7146 item
= ffesymbol_hook (s
).decl_tree
;
7147 if (item
== NULL_TREE
)
7149 s
= ffecom_sym_transform_ (s
);
7150 item
= ffesymbol_hook (s
).decl_tree
;
7152 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
7154 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
7155 length
= ffesymbol_hook (s
).length_tree
;
7158 length
= build_int_2 (ffesymbol_size (s
), 0);
7159 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
7162 else if (item
== error_mark_node
)
7163 length
= error_mark_node
;
7164 else /* FFEINFO_kindFUNCTION: */
7169 case FFEBLD_opARRAYREF
:
7170 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
7173 case FFEBLD_opSUBSTR
:
7177 ffebld thing
= ffebld_right (expr
);
7181 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
7182 start
= ffebld_head (thing
);
7183 thing
= ffebld_trail (thing
);
7184 assert (ffebld_trail (thing
) == NULL
);
7185 end
= ffebld_head (thing
);
7187 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
7189 if (length
== error_mark_node
)
7198 length
= convert (ffecom_f2c_ftnlen_type_node
,
7204 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
7205 ffecom_expr (start
));
7207 if (start_tree
== error_mark_node
)
7209 length
= error_mark_node
;
7215 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
7216 ffecom_f2c_ftnlen_one_node
,
7217 ffecom_2 (MINUS_EXPR
,
7218 ffecom_f2c_ftnlen_type_node
,
7224 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
7227 if (end_tree
== error_mark_node
)
7229 length
= error_mark_node
;
7233 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
7234 ffecom_f2c_ftnlen_one_node
,
7235 ffecom_2 (MINUS_EXPR
,
7236 ffecom_f2c_ftnlen_type_node
,
7237 end_tree
, start_tree
));
7243 case FFEBLD_opCONCATENATE
:
7245 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
7246 ffecom_intrinsic_len_ (ffebld_left (expr
)),
7247 ffecom_intrinsic_len_ (ffebld_right (expr
)));
7250 case FFEBLD_opFUNCREF
:
7251 case FFEBLD_opCONVERT
:
7252 length
= build_int_2 (ffebld_size (expr
), 0);
7253 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
7257 assert ("bad op for single char arg expr" == NULL
);
7258 length
= ffecom_f2c_ftnlen_zero_node
;
7262 assert (length
!= NULL_TREE
);
7268 /* ffecom_let_char_ -- Do assignment stuff for character type
7270 tree dest_tree; // destination (ADDR_EXPR)
7271 tree dest_length; // length (INT_CST/INDIRECT_REF(PARM_DECL))
7272 ffetargetCharacterSize dest_size; // length
7273 ffebld source; // source expression
7274 ffecom_let_char_(dest_tree,dest_length,dest_size,source);
7276 Generates code to do the assignment. Used by ordinary assignment
7277 statement handler ffecom_let_stmt and by statement-function
7278 handler to generate code for a statement function. */
7280 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7282 ffecom_let_char_ (tree dest_tree
, tree dest_length
,
7283 ffetargetCharacterSize dest_size
, ffebld source
)
7285 ffecomConcatList_ catlist
;
7290 if ((dest_tree
== error_mark_node
)
7291 || (dest_length
== error_mark_node
))
7294 assert (dest_tree
!= NULL_TREE
);
7295 assert (dest_length
!= NULL_TREE
);
7297 /* Source might be an opCONVERT, which just means it is a different size
7298 than the destination. Since the underlying implementation here handles
7299 that (directly or via the s_copy or s_cat run-time-library functions),
7300 we don't need the "convenience" of an opCONVERT that tells us to
7301 truncate or blank-pad, particularly since the resulting implementation
7302 would probably be slower than otherwise. */
7304 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
7305 source
= ffebld_left (source
);
7307 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
7308 switch (ffecom_concat_list_count_ (catlist
))
7310 case 0: /* Shouldn't happen, but in case it does... */
7311 ffecom_concat_list_kill_ (catlist
);
7312 source_tree
= null_pointer_node
;
7313 source_length
= ffecom_f2c_ftnlen_zero_node
;
7314 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
7315 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
7316 TREE_CHAIN (TREE_CHAIN (expr_tree
))
7317 = build_tree_list (NULL_TREE
, dest_length
);
7318 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
7319 = build_tree_list (NULL_TREE
, source_length
);
7321 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
);
7322 TREE_SIDE_EFFECTS (expr_tree
) = 1;
7324 expand_expr_stmt (expr_tree
);
7328 case 1: /* The (fairly) easy case. */
7329 ffecom_char_args_ (&source_tree
, &source_length
,
7330 ffecom_concat_list_expr_ (catlist
, 0));
7331 ffecom_concat_list_kill_ (catlist
);
7332 assert (source_tree
!= NULL_TREE
);
7333 assert (source_length
!= NULL_TREE
);
7335 if ((source_tree
== error_mark_node
)
7336 || (source_length
== error_mark_node
))
7342 = ffecom_1 (INDIRECT_REF
,
7343 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7347 = ffecom_2 (ARRAY_REF
,
7348 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7353 = ffecom_1 (INDIRECT_REF
,
7354 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7358 = ffecom_2 (ARRAY_REF
,
7359 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7364 expr_tree
= ffecom_modify (void_type_node
, dest_tree
, source_tree
);
7366 expand_expr_stmt (expr_tree
);
7371 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
7372 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
7373 TREE_CHAIN (TREE_CHAIN (expr_tree
))
7374 = build_tree_list (NULL_TREE
, dest_length
);
7375 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
7376 = build_tree_list (NULL_TREE
, source_length
);
7378 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
);
7379 TREE_SIDE_EFFECTS (expr_tree
) = 1;
7381 expand_expr_stmt (expr_tree
);
7385 default: /* Must actually concatenate things. */
7389 /* Heavy-duty concatenation. */
7392 int count
= ffecom_concat_list_count_ (catlist
);
7403 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
7404 FFETARGET_charactersizeNONE
, count
, TRUE
);
7405 item_array
= items
= ffecom_push_tempvar (ffecom_f2c_address_type_node
,
7406 FFETARGET_charactersizeNONE
,
7409 for (i
= 0; i
< count
; ++i
)
7411 ffecom_char_args_ (&citem
, &clength
,
7412 ffecom_concat_list_expr_ (catlist
, i
));
7413 if ((citem
== error_mark_node
)
7414 || (clength
== error_mark_node
))
7416 ffecom_concat_list_kill_ (catlist
);
7421 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
7422 ffecom_modify (void_type_node
,
7423 ffecom_2 (ARRAY_REF
,
7424 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
7426 build_int_2 (i
, 0)),
7430 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
7431 ffecom_modify (void_type_node
,
7432 ffecom_2 (ARRAY_REF
,
7433 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
7435 build_int_2 (i
, 0)),
7440 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
7441 TREE_CHAIN (expr_tree
)
7442 = build_tree_list (NULL_TREE
,
7443 ffecom_1 (ADDR_EXPR
,
7444 build_pointer_type (TREE_TYPE (items
)),
7446 TREE_CHAIN (TREE_CHAIN (expr_tree
))
7447 = build_tree_list (NULL_TREE
,
7448 ffecom_1 (ADDR_EXPR
,
7449 build_pointer_type (TREE_TYPE (lengths
)),
7451 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
7454 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
7455 convert (ffecom_f2c_ftnlen_type_node
,
7456 build_int_2 (count
, 0))));
7457 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
))))
7458 = build_tree_list (NULL_TREE
, dest_length
);
7460 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCAT
, expr_tree
);
7461 TREE_SIDE_EFFECTS (expr_tree
) = 1;
7463 expand_expr_stmt (expr_tree
);
7466 ffecom_concat_list_kill_ (catlist
);
7470 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
7473 ffecom_make_gfrt_(ix);
7475 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
7476 for the indicated run-time routine (ix). */
7478 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7480 ffecom_make_gfrt_ (ffecomGfrt ix
)
7485 push_obstacks_nochange ();
7486 end_temporary_allocation ();
7488 switch (ffecom_gfrt_type_
[ix
])
7490 case FFECOM_rttypeVOID_
:
7491 ttype
= void_type_node
;
7494 case FFECOM_rttypeVOIDSTAR_
:
7495 ttype
= TREE_TYPE (null_pointer_node
); /* `void *'. */
7498 case FFECOM_rttypeFTNINT_
:
7499 ttype
= ffecom_f2c_ftnint_type_node
;
7502 case FFECOM_rttypeINTEGER_
:
7503 ttype
= ffecom_f2c_integer_type_node
;
7506 case FFECOM_rttypeLONGINT_
:
7507 ttype
= ffecom_f2c_longint_type_node
;
7510 case FFECOM_rttypeLOGICAL_
:
7511 ttype
= ffecom_f2c_logical_type_node
;
7514 case FFECOM_rttypeREAL_F2C_
:
7515 ttype
= double_type_node
;
7518 case FFECOM_rttypeREAL_GNU_
:
7519 ttype
= float_type_node
;
7522 case FFECOM_rttypeCOMPLEX_F2C_
:
7523 ttype
= void_type_node
;
7526 case FFECOM_rttypeCOMPLEX_GNU_
:
7527 ttype
= ffecom_f2c_complex_type_node
;
7530 case FFECOM_rttypeDOUBLE_
:
7531 ttype
= double_type_node
;
7534 case FFECOM_rttypeDOUBLEREAL_
:
7535 ttype
= ffecom_f2c_doublereal_type_node
;
7538 case FFECOM_rttypeDBLCMPLX_F2C_
:
7539 ttype
= void_type_node
;
7542 case FFECOM_rttypeDBLCMPLX_GNU_
:
7543 ttype
= ffecom_f2c_doublecomplex_type_node
;
7546 case FFECOM_rttypeCHARACTER_
:
7547 ttype
= void_type_node
;
7552 assert ("bad rttype" == NULL
);
7556 ttype
= build_function_type (ttype
, NULL_TREE
);
7557 t
= build_decl (FUNCTION_DECL
,
7558 get_identifier (ffecom_gfrt_name_
[ix
]),
7560 DECL_EXTERNAL (t
) = 1;
7561 TREE_PUBLIC (t
) = 1;
7562 TREE_THIS_VOLATILE (t
) = ffecom_gfrt_volatile_
[ix
] ? 1 : 0;
7564 t
= start_decl (t
, TRUE
);
7566 finish_decl (t
, NULL_TREE
, TRUE
);
7568 resume_temporary_allocation ();
7571 ffecom_gfrt_
[ix
] = t
;
7575 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
7577 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7579 ffecom_member_phase1_ (ffestorag mst UNUSED
, ffestorag st
)
7581 ffesymbol s
= ffestorag_symbol (st
);
7583 if (ffesymbol_namelisted (s
))
7584 ffecom_member_namelisted_
= TRUE
;
7588 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
7589 the member so debugger will see it. Otherwise nobody should be
7590 referencing the member. */
7592 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7593 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
7595 ffecom_member_phase2_ (ffestorag mst
, ffestorag st
)
7603 || ((mt
= ffestorag_hook (mst
)) == NULL
)
7604 || (mt
== error_mark_node
))
7608 || ((s
= ffestorag_symbol (st
)) == NULL
))
7611 type
= ffecom_type_localvar_ (s
,
7612 ffesymbol_basictype (s
),
7613 ffesymbol_kindtype (s
));
7614 if (type
== error_mark_node
)
7617 t
= build_decl (VAR_DECL
,
7618 ffecom_get_identifier_ (ffesymbol_text (s
)),
7621 TREE_STATIC (t
) = TREE_STATIC (mt
);
7622 DECL_INITIAL (t
) = NULL_TREE
;
7623 TREE_ASM_WRITTEN (t
) = 1;
7626 = gen_rtx (MEM
, TYPE_MODE (type
),
7627 plus_constant (XEXP (DECL_RTL (mt
), 0),
7628 ffestorag_modulo (mst
)
7629 + ffestorag_offset (st
)
7630 - ffestorag_offset (mst
)));
7632 t
= start_decl (t
, FALSE
);
7634 finish_decl (t
, NULL_TREE
, FALSE
);
7639 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7641 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7642 (which generates their trees) and then their trees get push_parm_decl'd.
7644 The second arg is TRUE if the dummies are for a statement function, in
7645 which case lengths are not pushed for character arguments (since they are
7646 always known by both the caller and the callee, though the code allows
7647 for someday permitting CHAR*(*) stmtfunc dummies). */
7649 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7651 ffecom_push_dummy_decls_ (ffebld dummy_list
, bool stmtfunc
)
7658 ffecom_transform_only_dummies_
= TRUE
;
7660 /* First push the parms corresponding to actual dummy "contents". */
7662 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7664 dummy
= ffebld_head (dumlist
);
7665 switch (ffebld_op (dummy
))
7669 continue; /* Forget alternate returns. */
7674 assert (ffebld_op (dummy
) == FFEBLD_opSYMTER
);
7675 s
= ffebld_symter (dummy
);
7676 parm
= ffesymbol_hook (s
).decl_tree
;
7677 if (parm
== NULL_TREE
)
7679 s
= ffecom_sym_transform_ (s
);
7680 parm
= ffesymbol_hook (s
).decl_tree
;
7681 assert (parm
!= NULL_TREE
);
7683 if (parm
!= error_mark_node
)
7684 push_parm_decl (parm
);
7687 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7689 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7691 dummy
= ffebld_head (dumlist
);
7692 switch (ffebld_op (dummy
))
7696 continue; /* Forget alternate returns, they mean
7702 s
= ffebld_symter (dummy
);
7703 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
7704 continue; /* Only looking for CHARACTER arguments. */
7705 if (stmtfunc
&& (ffesymbol_size (s
) != FFETARGET_charactersizeNONE
))
7706 continue; /* Stmtfunc arg with known size needs no
7708 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
7709 continue; /* Only looking for variables and arrays. */
7710 parm
= ffesymbol_hook (s
).length_tree
;
7711 assert (parm
!= NULL_TREE
);
7712 if (parm
!= error_mark_node
)
7713 push_parm_decl (parm
);
7716 ffecom_transform_only_dummies_
= FALSE
;
7720 /* ffecom_start_progunit_ -- Beginning of program unit
7722 Does GNU back end stuff necessary to teach it about the start of its
7723 equivalent of a Fortran program unit. */
7725 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7727 ffecom_start_progunit_ ()
7729 ffesymbol fn
= ffecom_primary_entry_
;
7731 tree id
; /* Identifier (name) of function. */
7732 tree type
; /* Type of function. */
7733 tree result
; /* Result of function. */
7734 ffeinfoBasictype bt
;
7738 ffeglobalType egt
= FFEGLOBAL_type
;
7741 bool altentries
= (ffecom_num_entrypoints_
!= 0);
7744 && (ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
7745 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
7746 bool main_program
= FALSE
;
7747 int old_lineno
= lineno
;
7748 char *old_input_filename
= input_filename
;
7751 assert (fn
!= NULL
);
7752 assert (ffesymbol_hook (fn
).decl_tree
== NULL_TREE
);
7754 input_filename
= ffesymbol_where_filename (fn
);
7755 lineno
= ffesymbol_where_filelinenum (fn
);
7757 /* c-parse.y indeed does call suspend_momentary and not only ignores the
7758 return value, but also never calls resume_momentary, when starting an
7759 outer function (see "fndef:", "setspecs:", and so on). So g77 does the
7760 same thing. It shouldn't be a problem since start_function calls
7761 temporary_allocation, but it might be necessary. If it causes a problem
7762 here, then maybe there's a bug lurking in gcc. NOTE: This identical
7763 comment appears twice in thist file. */
7765 suspend_momentary ();
7767 switch (ffecom_primary_entry_kind_
)
7769 case FFEINFO_kindPROGRAM
:
7770 main_program
= TRUE
;
7771 gt
= FFEGLOBAL_typeMAIN
;
7772 bt
= FFEINFO_basictypeNONE
;
7773 kt
= FFEINFO_kindtypeNONE
;
7774 type
= ffecom_tree_fun_type_void
;
7779 case FFEINFO_kindBLOCKDATA
:
7780 gt
= FFEGLOBAL_typeBDATA
;
7781 bt
= FFEINFO_basictypeNONE
;
7782 kt
= FFEINFO_kindtypeNONE
;
7783 type
= ffecom_tree_fun_type_void
;
7788 case FFEINFO_kindFUNCTION
:
7789 gt
= FFEGLOBAL_typeFUNC
;
7790 egt
= FFEGLOBAL_typeEXT
;
7791 bt
= ffesymbol_basictype (fn
);
7792 kt
= ffesymbol_kindtype (fn
);
7793 if (bt
== FFEINFO_basictypeNONE
)
7795 ffeimplic_establish_symbol (fn
);
7796 if (ffesymbol_funcresult (fn
) != NULL
)
7797 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
7798 bt
= ffesymbol_basictype (fn
);
7799 kt
= ffesymbol_kindtype (fn
);
7803 charfunc
= cmplxfunc
= FALSE
;
7804 else if (bt
== FFEINFO_basictypeCHARACTER
)
7805 charfunc
= TRUE
, cmplxfunc
= FALSE
;
7806 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
7807 && ffesymbol_is_f2c (fn
)
7809 charfunc
= FALSE
, cmplxfunc
= TRUE
;
7811 charfunc
= cmplxfunc
= FALSE
;
7813 if (multi
|| charfunc
)
7814 type
= ffecom_tree_fun_type_void
;
7815 else if (ffesymbol_is_f2c (fn
) && !altentries
)
7816 type
= ffecom_tree_fun_type
[bt
][kt
];
7818 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
7820 if ((type
== NULL_TREE
)
7821 || (TREE_TYPE (type
) == NULL_TREE
))
7822 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
7825 case FFEINFO_kindSUBROUTINE
:
7826 gt
= FFEGLOBAL_typeSUBR
;
7827 egt
= FFEGLOBAL_typeEXT
;
7828 bt
= FFEINFO_basictypeNONE
;
7829 kt
= FFEINFO_kindtypeNONE
;
7830 if (ffecom_is_altreturning_
)
7831 type
= ffecom_tree_subr_type
;
7833 type
= ffecom_tree_fun_type_void
;
7839 assert ("say what??" == NULL
);
7841 case FFEINFO_kindANY
:
7842 gt
= FFEGLOBAL_typeANY
;
7843 bt
= FFEINFO_basictypeNONE
;
7844 kt
= FFEINFO_kindtypeNONE
;
7845 type
= error_mark_node
;
7853 id
= ffecom_get_invented_identifier ("__g77_masterfun_%s",
7854 ffesymbol_text (fn
),
7856 IDENTIFIER_INVENTED (id
) = 0; /* Allow this to be debugged. */
7858 #if FFETARGET_isENFORCED_MAIN
7859 else if (main_program
)
7860 id
= get_identifier (FFETARGET_nameENFORCED_MAIN_NAME
);
7863 id
= ffecom_get_external_identifier_ (fn
);
7867 0, /* nested/inline */
7868 !altentries
); /* TREE_PUBLIC */
7870 TREE_USED (current_function_decl
) = 1; /* Avoid spurious warning if altentries. */
7873 && ((g
= ffesymbol_global (fn
)) != NULL
)
7874 && ((ffeglobal_type (g
) == gt
)
7875 || (ffeglobal_type (g
) == egt
)))
7877 ffeglobal_set_hook (g
, current_function_decl
);
7880 yes
= suspend_momentary ();
7882 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7883 exec-transitioning needs current_function_decl to be filled in. So we
7884 do these things in two phases. */
7887 { /* 1st arg identifies which entrypoint. */
7888 ffecom_which_entrypoint_decl_
7889 = build_decl (PARM_DECL
,
7890 ffecom_get_invented_identifier ("__g77_%s",
7894 push_parm_decl (ffecom_which_entrypoint_decl_
);
7900 { /* Arg for result (return value). */
7905 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
7907 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
7909 type
= ffecom_multi_type_node_
;
7911 result
= ffecom_get_invented_identifier ("__g77_%s",
7914 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7917 length
= ffecom_char_enhance_arg_ (&type
, fn
);
7919 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
7921 type
= build_pointer_type (type
);
7922 result
= build_decl (PARM_DECL
, result
, type
);
7924 push_parm_decl (result
);
7926 ffecom_multi_retval_
= result
;
7928 ffecom_func_result_
= result
;
7932 push_parm_decl (length
);
7933 ffecom_func_length_
= length
;
7937 if (ffecom_primary_entry_is_proc_
)
7940 arglist
= ffecom_master_arglist_
;
7942 arglist
= ffesymbol_dummyargs (fn
);
7943 ffecom_push_dummy_decls_ (arglist
, FALSE
);
7946 resume_momentary (yes
);
7948 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
7949 store_parm_decls (main_program
? 1 : 0);
7951 ffecom_start_compstmt_ ();
7953 lineno
= old_lineno
;
7954 input_filename
= old_input_filename
;
7956 /* This handles any symbols still untransformed, in case -g specified.
7957 This used to be done in ffecom_finish_progunit, but it turns out to
7958 be necessary to do it here so that statement functions are
7959 expanded before code. But don't bother for BLOCK DATA. */
7961 if (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
7962 ffesymbol_drive (ffecom_finish_symbol_transform_
);
7966 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7969 ffecom_sym_transform_(s);
7971 The ffesymbol_hook info for s is updated with appropriate backend info
7974 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7976 ffecom_sym_transform_ (ffesymbol s
)
7978 tree t
; /* Transformed thingy. */
7979 tree tlen
; /* Length if CHAR*(*). */
7980 bool addr
; /* Is t the address of the thingy? */
7981 ffeinfoBasictype bt
;
7985 int old_lineno
= lineno
;
7986 char *old_input_filename
= input_filename
;
7988 if (ffesymbol_sfdummyparent (s
) == NULL
)
7990 input_filename
= ffesymbol_where_filename (s
);
7991 lineno
= ffesymbol_where_filelinenum (s
);
7995 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
7997 input_filename
= ffesymbol_where_filename (sf
);
7998 lineno
= ffesymbol_where_filelinenum (sf
);
8001 bt
= ffeinfo_basictype (ffebld_info (s
));
8002 kt
= ffeinfo_kindtype (ffebld_info (s
));
8008 switch (ffesymbol_kind (s
))
8010 case FFEINFO_kindNONE
:
8011 switch (ffesymbol_where (s
))
8013 case FFEINFO_whereDUMMY
: /* Subroutine or function. */
8014 assert (ffecom_transform_only_dummies_
);
8016 /* Before 0.4, this could be ENTITY/DUMMY, but see
8017 ffestu_sym_end_transition -- no longer true (in particular, if
8018 it could be an ENTITY, it _will_ be made one, so that
8019 possibility won't come through here). So we never make length
8020 arg for CHARACTER type. */
8022 t
= build_decl (PARM_DECL
,
8023 ffecom_get_identifier_ (ffesymbol_text (s
)),
8024 ffecom_tree_ptr_to_subr_type
);
8026 DECL_ARTIFICIAL (t
) = 1;
8031 case FFEINFO_whereGLOBAL
: /* Subroutine or function. */
8032 assert (!ffecom_transform_only_dummies_
);
8034 if (((g
= ffesymbol_global (s
)) != NULL
)
8035 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8036 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8037 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8038 && (ffeglobal_hook (g
) != NULL_TREE
)
8039 && ffe_is_globals ())
8041 t
= ffeglobal_hook (g
);
8045 push_obstacks_nochange ();
8046 end_temporary_allocation ();
8048 t
= build_decl (FUNCTION_DECL
,
8049 ffecom_get_external_identifier_ (s
),
8050 ffecom_tree_subr_type
); /* Assume subr. */
8051 DECL_EXTERNAL (t
) = 1;
8052 TREE_PUBLIC (t
) = 1;
8054 t
= start_decl (t
, FALSE
);
8055 finish_decl (t
, NULL_TREE
, FALSE
);
8058 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8059 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8060 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8061 ffeglobal_set_hook (g
, t
);
8063 resume_temporary_allocation ();
8069 assert ("NONE where unexpected" == NULL
);
8071 case FFEINFO_whereANY
:
8076 case FFEINFO_kindENTITY
:
8077 switch (ffeinfo_where (ffesymbol_info (s
)))
8080 case FFEINFO_whereCONSTANT
: /* ~~debugging info needed? */
8081 assert (!ffecom_transform_only_dummies_
);
8082 t
= error_mark_node
; /* Shouldn't ever see this in expr. */
8085 case FFEINFO_whereLOCAL
:
8086 assert (!ffecom_transform_only_dummies_
);
8089 ffestorag st
= ffesymbol_storage (s
);
8093 && (ffestorag_size (st
) == 0))
8095 t
= error_mark_node
;
8099 yes
= suspend_momentary ();
8100 type
= ffecom_type_localvar_ (s
, bt
, kt
);
8101 resume_momentary (yes
);
8103 if (type
== error_mark_node
)
8105 t
= error_mark_node
;
8110 && (ffestorag_parent (st
) != NULL
))
8111 { /* Child of EQUIVALENCE parent. */
8115 ffetargetOffset offset
;
8117 est
= ffestorag_parent (st
);
8118 ffecom_transform_equiv_ (est
);
8120 et
= ffestorag_hook (est
);
8121 assert (et
!= NULL_TREE
);
8123 if (! TREE_STATIC (et
))
8124 put_var_into_stack (et
);
8126 yes
= suspend_momentary ();
8128 offset
= ffestorag_modulo (est
)
8129 + ffestorag_offset (ffesymbol_storage (s
))
8130 - ffestorag_offset (est
);
8132 ffecom_debug_kludge_ (et
, "EQUIVALENCE", s
, type
, offset
);
8134 /* (t_type *) (((char *) &et) + offset) */
8136 t
= convert (string_type_node
, /* (char *) */
8137 ffecom_1 (ADDR_EXPR
,
8138 build_pointer_type (TREE_TYPE (et
)),
8140 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
8142 build_int_2 (offset
, 0));
8143 t
= convert (build_pointer_type (type
),
8148 resume_momentary (yes
);
8153 bool init
= ffesymbol_is_init (s
);
8155 yes
= suspend_momentary ();
8157 t
= build_decl (VAR_DECL
,
8158 ffecom_get_identifier_ (ffesymbol_text (s
)),
8162 || ffesymbol_namelisted (s
)
8163 #ifdef FFECOM_sizeMAXSTACKITEM
8165 && (ffestorag_size (st
) > FFECOM_sizeMAXSTACKITEM
))
8167 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8168 && (ffecom_primary_entry_kind_
8169 != FFEINFO_kindBLOCKDATA
)
8170 && (ffesymbol_is_save (s
) || ffe_is_saveall ())))
8171 TREE_STATIC (t
) = !ffesymbol_attr (s
, FFESYMBOL_attrADJUSTABLE
);
8173 TREE_STATIC (t
) = 0; /* No need to make static. */
8175 if (init
|| ffe_is_init_local_zero ())
8176 DECL_INITIAL (t
) = error_mark_node
;
8178 /* Keep -Wunused from complaining about var if it
8179 is used as sfunc arg or DATA implied-DO. */
8180 if (ffesymbol_attrs (s
) & FFESYMBOL_attrsSFARG
)
8181 DECL_IN_SYSTEM_HEADER (t
) = 1;
8183 t
= start_decl (t
, FALSE
);
8187 if (ffesymbol_init (s
) != NULL
)
8188 initexpr
= ffecom_expr (ffesymbol_init (s
));
8190 initexpr
= ffecom_init_zero_ (t
);
8192 else if (ffe_is_init_local_zero ())
8193 initexpr
= ffecom_init_zero_ (t
);
8195 initexpr
= NULL_TREE
; /* Not ref'd if !init. */
8197 finish_decl (t
, initexpr
, FALSE
);
8199 if ((st
!= NULL
) && (DECL_SIZE (t
) != error_mark_node
))
8203 size_tree
= size_binop (CEIL_DIV_EXPR
,
8205 size_int (BITS_PER_UNIT
));
8206 assert (TREE_INT_CST_HIGH (size_tree
) == 0);
8207 assert (TREE_INT_CST_LOW (size_tree
) == ffestorag_size (st
));
8210 resume_momentary (yes
);
8215 case FFEINFO_whereRESULT
:
8216 assert (!ffecom_transform_only_dummies_
);
8218 if (bt
== FFEINFO_basictypeCHARACTER
)
8219 { /* Result is already in list of dummies, use
8221 t
= ffecom_func_result_
;
8222 tlen
= ffecom_func_length_
;
8226 if ((ffecom_num_entrypoints_
== 0)
8227 && (bt
== FFEINFO_basictypeCOMPLEX
)
8228 && (ffesymbol_is_f2c (ffecom_primary_entry_
)))
8229 { /* Result is already in list of dummies, use
8231 t
= ffecom_func_result_
;
8235 if (ffecom_func_result_
!= NULL_TREE
)
8237 t
= ffecom_func_result_
;
8240 if ((ffecom_num_entrypoints_
!= 0)
8241 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
))
8243 yes
= suspend_momentary ();
8245 assert (ffecom_multi_retval_
!= NULL_TREE
);
8246 t
= ffecom_1 (INDIRECT_REF
, ffecom_multi_type_node_
,
8247 ffecom_multi_retval_
);
8248 t
= ffecom_2 (COMPONENT_REF
, ffecom_tree_type
[bt
][kt
],
8249 t
, ffecom_multi_fields_
[bt
][kt
]);
8251 resume_momentary (yes
);
8255 yes
= suspend_momentary ();
8257 t
= build_decl (VAR_DECL
,
8258 ffecom_get_identifier_ (ffesymbol_text (s
)),
8259 ffecom_tree_type
[bt
][kt
]);
8260 TREE_STATIC (t
) = 0; /* Put result on stack. */
8261 t
= start_decl (t
, FALSE
);
8262 finish_decl (t
, NULL_TREE
, FALSE
);
8264 ffecom_func_result_
= t
;
8266 resume_momentary (yes
);
8269 case FFEINFO_whereDUMMY
:
8277 bool adjustable
= FALSE
; /* Conditionally adjustable? */
8279 type
= ffecom_tree_type
[bt
][kt
];
8280 if (ffesymbol_sfdummyparent (s
) != NULL
)
8282 if (current_function_decl
== ffecom_outer_function_decl_
)
8283 { /* Exec transition before sfunc
8284 context; get it later. */
8287 t
= ffecom_get_identifier_ (ffesymbol_text
8288 (ffesymbol_sfdummyparent (s
)));
8291 t
= ffecom_get_identifier_ (ffesymbol_text (s
));
8293 assert (ffecom_transform_only_dummies_
);
8295 old_sizes
= get_pending_sizes ();
8296 put_pending_sizes (old_sizes
);
8298 if (bt
== FFEINFO_basictypeCHARACTER
)
8299 tlen
= ffecom_char_enhance_arg_ (&type
, s
);
8300 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
8302 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
8304 if (type
== error_mark_node
)
8307 dim
= ffebld_head (dl
);
8308 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
8309 if ((ffebld_left (dim
) == NULL
) || ffecom_doing_entry_
)
8310 low
= ffecom_integer_one_node
;
8312 low
= ffecom_expr (ffebld_left (dim
));
8313 assert (ffebld_right (dim
) != NULL
);
8314 if ((ffebld_op (ffebld_right (dim
)) == FFEBLD_opSTAR
)
8315 || ffecom_doing_entry_
)
8317 /* Used to just do high=low. But for ffecom_tree_
8318 canonize_ref_, it probably is important to correctly
8319 assess the size. E.g. given COMPLEX C(*),CFUNC and
8320 C(2)=CFUNC(C), overlap can happen, while it can't
8321 for, say, C(1)=CFUNC(C(2)). */
8322 /* Even more recently used to set to INT_MAX, but that
8323 broke when some overflow checking went into the back
8324 end. Now we just leave the upper bound unspecified. */
8328 high
= ffecom_expr (ffebld_right (dim
));
8330 /* Determine whether array is conditionally adjustable,
8331 to decide whether back-end magic is needed.
8333 Normally the front end uses the back-end function
8334 variable_size to wrap SAVE_EXPR's around expressions
8335 affecting the size/shape of an array so that the
8336 size/shape info doesn't change during execution
8337 of the compiled code even though variables and
8338 functions referenced in those expressions might.
8340 variable_size also makes sure those saved expressions
8341 get evaluated immediately upon entry to the
8342 compiled procedure -- the front end normally doesn't
8343 have to worry about that.
8345 However, there is a problem with this that affects
8346 g77's implementation of entry points, and that is
8347 that it is _not_ true that each invocation of the
8348 compiled procedure is permitted to evaluate
8349 array size/shape info -- because it is possible
8350 that, for some invocations, that info is invalid (in
8351 which case it is "promised" -- i.e. a violation of
8352 the Fortran standard -- that the compiled code
8353 won't reference the array or its size/shape
8354 during that particular invocation).
8356 To phrase this in C terms, consider this gcc function:
8358 void foo (int *n, float (*a)[*n])
8360 // a is "pointer to array ...", fyi.
8363 Suppose that, for some invocations, it is permitted
8364 for a caller of foo to do this:
8368 Now the _written_ code for foo can take such a call
8369 into account by either testing explicitly for whether
8370 (a == NULL) || (n == NULL) -- presumably it is
8371 not permitted to reference *a in various fashions
8372 if (n == NULL) I suppose -- or it can avoid it by
8373 looking at other info (other arguments, static/global
8376 However, this won't work in gcc 2.5.8 because it'll
8377 automatically emit the code to save the "*n"
8378 expression, which'll yield a NULL dereference for
8379 the "foo (NULL, NULL)" call, something the code
8380 for foo cannot prevent.
8382 g77 definitely needs to avoid executing such
8383 code anytime the pointer to the adjustable array
8384 is NULL, because even if its bounds expressions
8385 don't have any references to possible "absent"
8386 variables like "*n" -- say all variable references
8387 are to COMMON variables, i.e. global (though in C,
8388 local static could actually make sense) -- the
8389 expressions could yield other run-time problems
8390 for allowably "dead" values in those variables.
8392 For example, let's consider a more complicated
8398 void foo (float (*a)[i/j])
8403 The above is (essentially) quite valid for Fortran
8404 but, again, for a call like "foo (NULL);", it is
8405 permitted for i and j to be undefined when the
8406 call is made. If j happened to be zero, for
8407 example, emitting the code to evaluate "i/j"
8408 could result in a run-time error.
8410 Offhand, though I don't have my F77 or F90
8411 standards handy, it might even be valid for a
8412 bounds expression to contain a function reference,
8413 in which case I doubt it is permitted for an
8414 implementation to invoke that function in the
8415 Fortran case involved here (invocation of an
8416 alternate ENTRY point that doesn't have the adjustable
8417 array as one of its arguments).
8419 So, the code that the compiler would normally emit
8420 to preevaluate the size/shape info for an
8421 adjustable array _must not_ be executed at run time
8422 in certain cases. Specifically, for Fortran,
8423 the case is when the pointer to the adjustable
8424 array == NULL. (For gnu-ish C, it might be nice
8425 for the source code itself to specify an expression
8426 that, if TRUE, inhibits execution of the code. Or
8427 reverse the sense for elegance.)
8429 (Note that g77 could use a different test than NULL,
8430 actually, since it happens to always pass an
8431 integer to the called function that specifies which
8432 entry point is being invoked. Hmm, this might
8433 solve the next problem.)
8435 One way a user could, I suppose, write "foo" so
8436 it works is to insert COND_EXPR's for the
8437 size/shape info so the dangerous stuff isn't
8438 actually done, as in:
8440 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
8445 The next problem is that the front end needs to
8446 be able to tell the back end about the array's
8447 decl _before_ it tells it about the conditional
8448 expression to inhibit evaluation of size/shape info,
8451 To solve this, the front end needs to be able
8452 to give the back end the expression to inhibit
8453 generation of the preevaluation code _after_
8454 it makes the decl for the adjustable array.
8456 Until then, the above example using the COND_EXPR
8457 doesn't pass muster with gcc because the "(a == NULL)"
8458 part has a reference to "a", which is still
8459 undefined at that point.
8461 g77 will therefore use a different mechanism in the
8465 && ((TREE_CODE (low
) != INTEGER_CST
)
8466 || (high
&& TREE_CODE (high
) != INTEGER_CST
)))
8469 #if 0 /* Old approach -- see below. */
8470 if (TREE_CODE (low
) != INTEGER_CST
)
8471 low
= ffecom_3 (COND_EXPR
, integer_type_node
,
8472 ffecom_adjarray_passed_ (s
),
8474 ffecom_integer_zero_node
);
8476 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
8477 high
= ffecom_3 (COND_EXPR
, integer_type_node
,
8478 ffecom_adjarray_passed_ (s
),
8480 ffecom_integer_zero_node
);
8483 /* ~~~gcc/stor-layout.c/layout_type should do this,
8484 probably. Fixes 950302-1.f. */
8486 if (TREE_CODE (low
) != INTEGER_CST
)
8487 low
= variable_size (low
);
8489 /* ~~~similarly, this fixes dumb0.f. The C front end
8490 does this, which is why dumb0.c would work. */
8492 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
8493 high
= variable_size (high
);
8498 build_range_type (ffecom_integer_type_node
,
8500 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
8503 if (type
== error_mark_node
)
8505 t
= error_mark_node
;
8509 if ((ffesymbol_sfdummyparent (s
) == NULL
)
8510 || (ffesymbol_basictype (s
) == FFEINFO_basictypeCHARACTER
))
8512 type
= build_pointer_type (type
);
8516 t
= build_decl (PARM_DECL
, t
, type
);
8518 DECL_ARTIFICIAL (t
) = 1;
8521 /* If this arg is present in every entry point's list of
8522 dummy args, then we're done. */
8524 if (ffesymbol_numentries (s
)
8525 == (ffecom_num_entrypoints_
+ 1))
8530 /* If variable_size in stor-layout has been called during
8531 the above, then get_pending_sizes should have the
8532 yet-to-be-evaluated saved expressions pending.
8533 Make the whole lot of them get emitted, conditionally
8534 on whether the array decl ("t" above) is not NULL. */
8537 tree sizes
= get_pending_sizes ();
8542 tem
= TREE_CHAIN (tem
))
8544 tree temv
= TREE_VALUE (tem
);
8550 = ffecom_2 (COMPOUND_EXPR
,
8559 = ffecom_3 (COND_EXPR
,
8566 convert (TREE_TYPE (sizes
),
8567 integer_zero_node
));
8568 sizes
= ffecom_save_tree (sizes
);
8571 = tree_cons (NULL_TREE
, sizes
, tem
);
8575 put_pending_sizes (sizes
);
8581 && (ffesymbol_numentries (s
)
8582 != ffecom_num_entrypoints_
+ 1))
8584 = ffecom_2 (NE_EXPR
, integer_type_node
,
8590 && (ffesymbol_numentries (s
)
8591 != ffecom_num_entrypoints_
+ 1))
8593 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED
);
8594 ffebad_here (0, ffesymbol_where_line (s
),
8595 ffesymbol_where_column (s
));
8596 ffebad_string (ffesymbol_text (s
));
8605 case FFEINFO_whereCOMMON
:
8610 ffestorag st
= ffesymbol_storage (s
);
8614 cs
= ffesymbol_common (s
); /* The COMMON area itself. */
8615 if (st
!= NULL
) /* Else not laid out. */
8617 ffecom_transform_common_ (cs
);
8618 st
= ffesymbol_storage (s
);
8621 yes
= suspend_momentary ();
8623 type
= ffecom_type_localvar_ (s
, bt
, kt
);
8625 cg
= ffesymbol_global (cs
); /* The global COMMON info. */
8627 || (ffeglobal_type (cg
) != FFEGLOBAL_typeCOMMON
))
8630 ct
= ffeglobal_hook (cg
); /* The common area's tree. */
8632 if ((ct
== NULL_TREE
)
8634 || (type
== error_mark_node
))
8635 t
= error_mark_node
;
8638 ffetargetOffset offset
;
8641 cst
= ffestorag_parent (st
);
8642 assert (cst
== ffesymbol_storage (cs
));
8644 offset
= ffestorag_modulo (cst
)
8645 + ffestorag_offset (st
)
8646 - ffestorag_offset (cst
);
8648 ffecom_debug_kludge_ (ct
, "COMMON", s
, type
, offset
);
8650 /* (t_type *) (((char *) &ct) + offset) */
8652 t
= convert (string_type_node
, /* (char *) */
8653 ffecom_1 (ADDR_EXPR
,
8654 build_pointer_type (TREE_TYPE (ct
)),
8656 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
8658 build_int_2 (offset
, 0));
8659 t
= convert (build_pointer_type (type
),
8665 resume_momentary (yes
);
8669 case FFEINFO_whereIMMEDIATE
:
8670 case FFEINFO_whereGLOBAL
:
8671 case FFEINFO_whereFLEETING
:
8672 case FFEINFO_whereFLEETING_CADDR
:
8673 case FFEINFO_whereFLEETING_IADDR
:
8674 case FFEINFO_whereINTRINSIC
:
8675 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8677 assert ("ENTITY where unheard of" == NULL
);
8679 case FFEINFO_whereANY
:
8680 t
= error_mark_node
;
8685 case FFEINFO_kindFUNCTION
:
8686 switch (ffeinfo_where (ffesymbol_info (s
)))
8688 case FFEINFO_whereLOCAL
: /* Me. */
8689 assert (!ffecom_transform_only_dummies_
);
8690 t
= current_function_decl
;
8693 case FFEINFO_whereGLOBAL
:
8694 assert (!ffecom_transform_only_dummies_
);
8696 if (((g
= ffesymbol_global (s
)) != NULL
)
8697 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8698 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8699 && (ffeglobal_hook (g
) != NULL_TREE
)
8700 && ffe_is_globals ())
8702 t
= ffeglobal_hook (g
);
8706 push_obstacks_nochange ();
8707 end_temporary_allocation ();
8709 if (ffesymbol_is_f2c (s
)
8710 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8711 t
= ffecom_tree_fun_type
[bt
][kt
];
8713 t
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
8715 t
= build_decl (FUNCTION_DECL
,
8716 ffecom_get_external_identifier_ (s
),
8718 DECL_EXTERNAL (t
) = 1;
8719 TREE_PUBLIC (t
) = 1;
8721 t
= start_decl (t
, FALSE
);
8722 finish_decl (t
, NULL_TREE
, FALSE
);
8725 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8726 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8727 ffeglobal_set_hook (g
, t
);
8729 resume_temporary_allocation ();
8734 case FFEINFO_whereDUMMY
:
8735 assert (ffecom_transform_only_dummies_
);
8737 if (ffesymbol_is_f2c (s
)
8738 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8739 t
= ffecom_tree_ptr_to_fun_type
[bt
][kt
];
8741 t
= build_pointer_type
8742 (build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
));
8744 t
= build_decl (PARM_DECL
,
8745 ffecom_get_identifier_ (ffesymbol_text (s
)),
8748 DECL_ARTIFICIAL (t
) = 1;
8753 case FFEINFO_whereCONSTANT
: /* Statement function. */
8754 assert (!ffecom_transform_only_dummies_
);
8755 t
= ffecom_gen_sfuncdef_ (s
, bt
, kt
);
8758 case FFEINFO_whereINTRINSIC
:
8759 assert (!ffecom_transform_only_dummies_
);
8760 break; /* Let actual references generate their
8764 assert ("FUNCTION where unheard of" == NULL
);
8766 case FFEINFO_whereANY
:
8767 t
= error_mark_node
;
8772 case FFEINFO_kindSUBROUTINE
:
8773 switch (ffeinfo_where (ffesymbol_info (s
)))
8775 case FFEINFO_whereLOCAL
: /* Me. */
8776 assert (!ffecom_transform_only_dummies_
);
8777 t
= current_function_decl
;
8780 case FFEINFO_whereGLOBAL
:
8781 assert (!ffecom_transform_only_dummies_
);
8783 if (((g
= ffesymbol_global (s
)) != NULL
)
8784 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8785 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8786 && (ffeglobal_hook (g
) != NULL_TREE
)
8787 && ffe_is_globals ())
8789 t
= ffeglobal_hook (g
);
8793 push_obstacks_nochange ();
8794 end_temporary_allocation ();
8796 t
= build_decl (FUNCTION_DECL
,
8797 ffecom_get_external_identifier_ (s
),
8798 ffecom_tree_subr_type
);
8799 DECL_EXTERNAL (t
) = 1;
8800 TREE_PUBLIC (t
) = 1;
8802 t
= start_decl (t
, FALSE
);
8803 finish_decl (t
, NULL_TREE
, FALSE
);
8806 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8807 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8808 ffeglobal_set_hook (g
, t
);
8810 resume_temporary_allocation ();
8815 case FFEINFO_whereDUMMY
:
8816 assert (ffecom_transform_only_dummies_
);
8818 t
= build_decl (PARM_DECL
,
8819 ffecom_get_identifier_ (ffesymbol_text (s
)),
8820 ffecom_tree_ptr_to_subr_type
);
8822 DECL_ARTIFICIAL (t
) = 1;
8827 case FFEINFO_whereINTRINSIC
:
8828 assert (!ffecom_transform_only_dummies_
);
8829 break; /* Let actual references generate their
8833 assert ("SUBROUTINE where unheard of" == NULL
);
8835 case FFEINFO_whereANY
:
8836 t
= error_mark_node
;
8841 case FFEINFO_kindPROGRAM
:
8842 switch (ffeinfo_where (ffesymbol_info (s
)))
8844 case FFEINFO_whereLOCAL
: /* Me. */
8845 assert (!ffecom_transform_only_dummies_
);
8846 t
= current_function_decl
;
8849 case FFEINFO_whereCOMMON
:
8850 case FFEINFO_whereDUMMY
:
8851 case FFEINFO_whereGLOBAL
:
8852 case FFEINFO_whereRESULT
:
8853 case FFEINFO_whereFLEETING
:
8854 case FFEINFO_whereFLEETING_CADDR
:
8855 case FFEINFO_whereFLEETING_IADDR
:
8856 case FFEINFO_whereIMMEDIATE
:
8857 case FFEINFO_whereINTRINSIC
:
8858 case FFEINFO_whereCONSTANT
:
8859 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8861 assert ("PROGRAM where unheard of" == NULL
);
8863 case FFEINFO_whereANY
:
8864 t
= error_mark_node
;
8869 case FFEINFO_kindBLOCKDATA
:
8870 switch (ffeinfo_where (ffesymbol_info (s
)))
8872 case FFEINFO_whereLOCAL
: /* Me. */
8873 assert (!ffecom_transform_only_dummies_
);
8874 t
= current_function_decl
;
8877 case FFEINFO_whereGLOBAL
:
8878 assert (!ffecom_transform_only_dummies_
);
8880 push_obstacks_nochange ();
8881 end_temporary_allocation ();
8883 t
= build_decl (FUNCTION_DECL
,
8884 ffecom_get_external_identifier_ (s
),
8885 ffecom_tree_blockdata_type
);
8886 DECL_EXTERNAL (t
) = 1;
8887 TREE_PUBLIC (t
) = 1;
8889 t
= start_decl (t
, FALSE
);
8890 finish_decl (t
, NULL_TREE
, FALSE
);
8892 resume_temporary_allocation ();
8897 case FFEINFO_whereCOMMON
:
8898 case FFEINFO_whereDUMMY
:
8899 case FFEINFO_whereRESULT
:
8900 case FFEINFO_whereFLEETING
:
8901 case FFEINFO_whereFLEETING_CADDR
:
8902 case FFEINFO_whereFLEETING_IADDR
:
8903 case FFEINFO_whereIMMEDIATE
:
8904 case FFEINFO_whereINTRINSIC
:
8905 case FFEINFO_whereCONSTANT
:
8906 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8908 assert ("BLOCKDATA where unheard of" == NULL
);
8910 case FFEINFO_whereANY
:
8911 t
= error_mark_node
;
8916 case FFEINFO_kindCOMMON
:
8917 switch (ffeinfo_where (ffesymbol_info (s
)))
8919 case FFEINFO_whereLOCAL
:
8920 assert (!ffecom_transform_only_dummies_
);
8921 ffecom_transform_common_ (s
);
8924 case FFEINFO_whereNONE
:
8925 case FFEINFO_whereCOMMON
:
8926 case FFEINFO_whereDUMMY
:
8927 case FFEINFO_whereGLOBAL
:
8928 case FFEINFO_whereRESULT
:
8929 case FFEINFO_whereFLEETING
:
8930 case FFEINFO_whereFLEETING_CADDR
:
8931 case FFEINFO_whereFLEETING_IADDR
:
8932 case FFEINFO_whereIMMEDIATE
:
8933 case FFEINFO_whereINTRINSIC
:
8934 case FFEINFO_whereCONSTANT
:
8935 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8937 assert ("COMMON where unheard of" == NULL
);
8939 case FFEINFO_whereANY
:
8940 t
= error_mark_node
;
8945 case FFEINFO_kindCONSTRUCT
:
8946 switch (ffeinfo_where (ffesymbol_info (s
)))
8948 case FFEINFO_whereLOCAL
:
8949 assert (!ffecom_transform_only_dummies_
);
8952 case FFEINFO_whereNONE
:
8953 case FFEINFO_whereCOMMON
:
8954 case FFEINFO_whereDUMMY
:
8955 case FFEINFO_whereGLOBAL
:
8956 case FFEINFO_whereRESULT
:
8957 case FFEINFO_whereFLEETING
:
8958 case FFEINFO_whereFLEETING_CADDR
:
8959 case FFEINFO_whereFLEETING_IADDR
:
8960 case FFEINFO_whereIMMEDIATE
:
8961 case FFEINFO_whereINTRINSIC
:
8962 case FFEINFO_whereCONSTANT
:
8963 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8965 assert ("CONSTRUCT where unheard of" == NULL
);
8967 case FFEINFO_whereANY
:
8968 t
= error_mark_node
;
8973 case FFEINFO_kindNAMELIST
:
8974 switch (ffeinfo_where (ffesymbol_info (s
)))
8976 case FFEINFO_whereLOCAL
:
8977 assert (!ffecom_transform_only_dummies_
);
8978 t
= ffecom_transform_namelist_ (s
);
8981 case FFEINFO_whereNONE
:
8982 case FFEINFO_whereCOMMON
:
8983 case FFEINFO_whereDUMMY
:
8984 case FFEINFO_whereGLOBAL
:
8985 case FFEINFO_whereRESULT
:
8986 case FFEINFO_whereFLEETING
:
8987 case FFEINFO_whereFLEETING_CADDR
:
8988 case FFEINFO_whereFLEETING_IADDR
:
8989 case FFEINFO_whereIMMEDIATE
:
8990 case FFEINFO_whereINTRINSIC
:
8991 case FFEINFO_whereCONSTANT
:
8992 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8994 assert ("NAMELIST where unheard of" == NULL
);
8996 case FFEINFO_whereANY
:
8997 t
= error_mark_node
;
9003 assert ("kind unheard of" == NULL
);
9005 case FFEINFO_kindANY
:
9006 t
= error_mark_node
;
9010 ffesymbol_hook (s
).decl_tree
= t
;
9011 ffesymbol_hook (s
).length_tree
= tlen
;
9012 ffesymbol_hook (s
).addr
= addr
;
9014 lineno
= old_lineno
;
9015 input_filename
= old_input_filename
;
9021 /* Transform into ASSIGNable symbol.
9023 Symbol has already been transformed, but for whatever reason, the
9024 resulting decl_tree has been deemed not usable for an ASSIGN target.
9025 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
9026 another local symbol of type void * and stuff that in the assign_tree
9027 argument. The F77/F90 standards allow this implementation. */
9029 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9031 ffecom_sym_transform_assign_ (ffesymbol s
)
9033 tree t
; /* Transformed thingy. */
9035 int old_lineno
= lineno
;
9036 char *old_input_filename
= input_filename
;
9038 if (ffesymbol_sfdummyparent (s
) == NULL
)
9040 input_filename
= ffesymbol_where_filename (s
);
9041 lineno
= ffesymbol_where_filelinenum (s
);
9045 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
9047 input_filename
= ffesymbol_where_filename (sf
);
9048 lineno
= ffesymbol_where_filelinenum (sf
);
9051 assert (!ffecom_transform_only_dummies_
);
9053 yes
= suspend_momentary ();
9055 t
= build_decl (VAR_DECL
,
9056 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
9059 TREE_TYPE (null_pointer_node
));
9061 switch (ffesymbol_where (s
))
9063 case FFEINFO_whereLOCAL
:
9064 /* Unlike for regular vars, SAVE status is easy to determine for
9065 ASSIGNed vars, since there's no initialization, there's no
9066 effective storage association (so "SAVE J" does not apply to
9067 K even given "EQUIVALENCE (J,K)"), there's no size issue
9068 to worry about, etc. */
9069 if ((ffesymbol_is_save (s
) || ffe_is_saveall ())
9070 && (ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
9071 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
))
9072 TREE_STATIC (t
) = 1; /* SAVEd in proc, make static. */
9074 TREE_STATIC (t
) = 0; /* No need to make static. */
9077 case FFEINFO_whereCOMMON
:
9078 TREE_STATIC (t
) = 1; /* Assume COMMONs always SAVEd. */
9081 case FFEINFO_whereDUMMY
:
9082 /* Note that twinning a DUMMY means the caller won't see
9083 the ASSIGNed value. But both F77 and F90 allow implementations
9084 to do this, i.e. disallow Fortran code that would try and
9085 take advantage of actually putting a label into a variable
9086 via a dummy argument (or any other storage association, for
9088 TREE_STATIC (t
) = 0;
9092 TREE_STATIC (t
) = 0;
9096 t
= start_decl (t
, FALSE
);
9097 finish_decl (t
, NULL_TREE
, FALSE
);
9099 resume_momentary (yes
);
9101 ffesymbol_hook (s
).assign_tree
= t
;
9103 lineno
= old_lineno
;
9104 input_filename
= old_input_filename
;
9110 /* Implement COMMON area in back end.
9112 Because COMMON-based variables can be referenced in the dimension
9113 expressions of dummy (adjustable) arrays, and because dummies
9114 (in the gcc back end) need to be put in the outer binding level
9115 of a function (which has two binding levels, the outer holding
9116 the dummies and the inner holding the other vars), special care
9117 must be taken to handle COMMON areas.
9119 The current strategy is basically to always tell the back end about
9120 the COMMON area as a top-level external reference to just a block
9121 of storage of the master type of that area (e.g. integer, real,
9122 character, whatever -- not a structure). As a distinct action,
9123 if initial values are provided, tell the back end about the area
9124 as a top-level non-external (initialized) area and remember not to
9125 allow further initialization or expansion of the area. Meanwhile,
9126 if no initialization happens at all, tell the back end about
9127 the largest size we've seen declared so the space does get reserved.
9128 (This function doesn't handle all that stuff, but it does some
9129 of the important things.)
9131 Meanwhile, for COMMON variables themselves, just keep creating
9132 references like *((float *) (&common_area + offset)) each time
9133 we reference the variable. In other words, don't make a VAR_DECL
9134 or any kind of component reference (like we used to do before 0.4),
9135 though we might do that as well just for debugging purposes (and
9136 stuff the rtl with the appropriate offset expression). */
9138 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9140 ffecom_transform_common_ (ffesymbol s
)
9142 ffestorag st
= ffesymbol_storage (s
);
9143 ffeglobal g
= ffesymbol_global (s
);
9147 bool is_init
= ffestorag_is_init (st
);
9149 assert (st
!= NULL
);
9152 || (ffeglobal_type (g
) != FFEGLOBAL_typeCOMMON
))
9155 /* First update the size of the area in global terms. */
9157 ffeglobal_size_common (s
, ffestorag_size (st
));
9159 if (!ffeglobal_common_init (g
))
9160 is_init
= FALSE
; /* No explicit init, don't let erroneous joins init. */
9162 cbt
= ffeglobal_hook (g
);
9164 /* If we already have declared this common block for a previous program
9165 unit, and either we already initialized it or we don't have new
9166 initialization for it, just return what we have without changing it. */
9168 if ((cbt
!= NULL_TREE
)
9170 || !DECL_EXTERNAL (cbt
)))
9173 /* Process inits. */
9177 if (ffestorag_init (st
) != NULL
)
9179 init
= ffecom_expr (ffestorag_init (st
));
9180 if (init
== error_mark_node
)
9181 { /* Hopefully the back end complained! */
9183 if (cbt
!= NULL_TREE
)
9188 init
= error_mark_node
;
9193 push_obstacks_nochange ();
9194 end_temporary_allocation ();
9196 /* cbtype must be permanently allocated! */
9199 cbtype
= build_array_type (char_type_node
,
9200 build_range_type (integer_type_node
,
9203 (ffeglobal_common_size (g
),
9206 cbtype
= build_array_type (char_type_node
, NULL_TREE
);
9208 if (cbt
== NULL_TREE
)
9211 = build_decl (VAR_DECL
,
9212 ffecom_get_external_identifier_ (s
),
9214 TREE_STATIC (cbt
) = 1;
9215 TREE_PUBLIC (cbt
) = 1;
9220 TREE_TYPE (cbt
) = cbtype
;
9222 DECL_EXTERNAL (cbt
) = init
? 0 : 1;
9223 DECL_INITIAL (cbt
) = init
? error_mark_node
: NULL_TREE
;
9225 cbt
= start_decl (cbt
, TRUE
);
9226 if (ffeglobal_hook (g
) != NULL
)
9227 assert (cbt
== ffeglobal_hook (g
));
9229 assert (!init
|| !DECL_EXTERNAL (cbt
));
9231 /* Make sure that any type can live in COMMON and be referenced
9232 without getting a bus error. We could pick the most restrictive
9233 alignment of all entities actually placed in the COMMON, but
9234 this seems easy enough. */
9236 DECL_ALIGN (cbt
) = BIGGEST_ALIGNMENT
;
9238 if (is_init
&& (ffestorag_init (st
) == NULL
))
9239 init
= ffecom_init_zero_ (cbt
);
9241 finish_decl (cbt
, init
, TRUE
);
9244 ffestorag_set_init (st
, ffebld_new_any ());
9250 assert (DECL_SIZE (cbt
) != NULL_TREE
);
9251 assert (TREE_CODE (DECL_SIZE (cbt
)) == INTEGER_CST
);
9252 size_tree
= size_binop (CEIL_DIV_EXPR
,
9254 size_int (BITS_PER_UNIT
));
9255 assert (TREE_INT_CST_HIGH (size_tree
) == 0);
9256 assert (TREE_INT_CST_LOW (size_tree
) == ffeglobal_common_size (g
));
9259 ffeglobal_set_hook (g
, cbt
);
9261 ffestorag_set_hook (st
, cbt
);
9263 resume_temporary_allocation ();
9268 /* Make master area for local EQUIVALENCE. */
9270 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9272 ffecom_transform_equiv_ (ffestorag eqst
)
9278 bool is_init
= ffestorag_is_init (eqst
);
9281 assert (eqst
!= NULL
);
9283 eqt
= ffestorag_hook (eqst
);
9285 if (eqt
!= NULL_TREE
)
9288 /* Process inits. */
9292 if (ffestorag_init (eqst
) != NULL
)
9294 init
= ffecom_expr (ffestorag_init (eqst
));
9295 if (init
== error_mark_node
)
9296 init
= NULL_TREE
; /* Hopefully the back end complained! */
9299 init
= error_mark_node
;
9301 else if (ffe_is_init_local_zero ())
9302 init
= error_mark_node
;
9306 ffecom_member_namelisted_
= FALSE
;
9307 ffestorag_drive (ffestorag_list_equivs (eqst
),
9308 &ffecom_member_phase1_
,
9311 yes
= suspend_momentary ();
9313 high
= build_int_2 (ffestorag_size (eqst
), 0);
9314 TREE_TYPE (high
) = ffecom_integer_type_node
;
9316 eqtype
= build_array_type (char_type_node
,
9317 build_range_type (ffecom_integer_type_node
,
9318 ffecom_integer_one_node
,
9321 eqt
= build_decl (VAR_DECL
,
9322 ffecom_get_invented_identifier ("__g77_equiv_%s",
9328 DECL_EXTERNAL (eqt
) = 0;
9330 || ffecom_member_namelisted_
9331 #ifdef FFECOM_sizeMAXSTACKITEM
9332 || (ffestorag_size (eqst
) > FFECOM_sizeMAXSTACKITEM
)
9334 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
9335 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
9336 && (ffestorag_is_save (eqst
) || ffe_is_saveall ())))
9337 TREE_STATIC (eqt
) = 1;
9339 TREE_STATIC (eqt
) = 0;
9340 TREE_PUBLIC (eqt
) = 0;
9341 DECL_CONTEXT (eqt
) = current_function_decl
;
9343 DECL_INITIAL (eqt
) = error_mark_node
;
9345 DECL_INITIAL (eqt
) = NULL_TREE
;
9347 eqt
= start_decl (eqt
, FALSE
);
9349 /* Make sure this shows up as a debug symbol, which is not normally
9350 the case for invented identifiers. */
9352 DECL_IGNORED_P (eqt
) = 0;
9354 /* Make sure that any type can live in EQUIVALENCE and be referenced
9355 without getting a bus error. We could pick the most restrictive
9356 alignment of all entities actually placed in the EQUIVALENCE, but
9357 this seems easy enough. */
9359 DECL_ALIGN (eqt
) = BIGGEST_ALIGNMENT
;
9361 if ((!is_init
&& ffe_is_init_local_zero ())
9362 || (is_init
&& (ffestorag_init (eqst
) == NULL
)))
9363 init
= ffecom_init_zero_ (eqt
);
9365 finish_decl (eqt
, init
, FALSE
);
9368 ffestorag_set_init (eqst
, ffebld_new_any ());
9373 size_tree
= size_binop (CEIL_DIV_EXPR
,
9375 size_int (BITS_PER_UNIT
));
9376 assert (TREE_INT_CST_HIGH (size_tree
) == 0);
9377 assert (TREE_INT_CST_LOW (size_tree
) == ffestorag_size (eqst
));
9380 ffestorag_set_hook (eqst
, eqt
);
9382 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
9383 ffestorag_drive (ffestorag_list_equivs (eqst
),
9384 &ffecom_member_phase2_
,
9388 resume_momentary (yes
);
9392 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
9394 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9396 ffecom_transform_namelist_ (ffesymbol s
)
9399 tree nmltype
= ffecom_type_namelist_ ();
9408 static int mynumber
= 0;
9410 yes
= suspend_momentary ();
9412 nmlt
= build_decl (VAR_DECL
,
9413 ffecom_get_invented_identifier ("__g77_namelist_%d",
9416 TREE_STATIC (nmlt
) = 1;
9417 DECL_INITIAL (nmlt
) = error_mark_node
;
9419 nmlt
= start_decl (nmlt
, FALSE
);
9421 /* Process inits. */
9423 i
= strlen (ffesymbol_text (s
));
9425 high
= build_int_2 (i
, 0);
9426 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
9428 nameinit
= ffecom_build_f2c_string_ (i
+ 1,
9429 ffesymbol_text (s
));
9430 TREE_TYPE (nameinit
)
9431 = build_type_variant
9434 build_range_type (ffecom_f2c_ftnlen_type_node
,
9435 ffecom_f2c_ftnlen_one_node
,
9438 TREE_CONSTANT (nameinit
) = 1;
9439 TREE_STATIC (nameinit
) = 1;
9440 nameinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (nameinit
)),
9443 varsinit
= ffecom_vardesc_array_ (s
);
9444 varsinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (varsinit
)),
9446 TREE_CONSTANT (varsinit
) = 1;
9447 TREE_STATIC (varsinit
) = 1;
9452 for (i
= 0, b
= ffesymbol_namelist (s
); b
!= NULL
; b
= ffebld_trail (b
))
9455 nvarsinit
= build_int_2 (i
, 0);
9456 TREE_TYPE (nvarsinit
) = integer_type_node
;
9457 TREE_CONSTANT (nvarsinit
) = 1;
9458 TREE_STATIC (nvarsinit
) = 1;
9460 nmlinits
= build_tree_list ((field
= TYPE_FIELDS (nmltype
)), nameinit
);
9461 TREE_CHAIN (nmlinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
9463 TREE_CHAIN (TREE_CHAIN (nmlinits
))
9464 = build_tree_list ((field
= TREE_CHAIN (field
)), nvarsinit
);
9466 nmlinits
= build (CONSTRUCTOR
, nmltype
, NULL_TREE
, nmlinits
);
9467 TREE_CONSTANT (nmlinits
) = 1;
9468 TREE_STATIC (nmlinits
) = 1;
9470 finish_decl (nmlt
, nmlinits
, FALSE
);
9472 nmlt
= ffecom_1 (ADDR_EXPR
, build_pointer_type (nmltype
), nmlt
);
9474 resume_momentary (yes
);
9481 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
9482 analyzed on the assumption it is calculating a pointer to be
9483 indirected through. It must return the proper decl and offset,
9484 taking into account different units of measurements for offsets. */
9486 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9488 ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
9491 switch (TREE_CODE (t
))
9495 case NON_LVALUE_EXPR
:
9496 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
9500 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
9501 if ((*decl
== NULL_TREE
)
9502 || (*decl
== error_mark_node
))
9505 if (TREE_CODE (TREE_OPERAND (t
, 1)) == INTEGER_CST
)
9507 /* An offset into COMMON. */
9508 *offset
= size_binop (PLUS_EXPR
,
9510 TREE_OPERAND (t
, 1));
9511 /* Convert offset (presumably in bytes) into canonical units
9512 (presumably bits). */
9513 *offset
= size_binop (MULT_EXPR
,
9514 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t
))),
9518 /* Not a COMMON reference, so an unrecognized pattern. */
9519 *decl
= error_mark_node
;
9524 *offset
= bitsize_int (0L, 0L);
9528 if (TREE_CODE (TREE_OPERAND (t
, 0)) == VAR_DECL
)
9530 /* A reference to COMMON. */
9531 *decl
= TREE_OPERAND (t
, 0);
9532 *offset
= bitsize_int (0L, 0L);
9537 /* Not a COMMON reference, so an unrecognized pattern. */
9538 *decl
= error_mark_node
;
9544 /* Given a tree that is possibly intended for use as an lvalue, return
9545 information representing a canonical view of that tree as a decl, an
9546 offset into that decl, and a size for the lvalue.
9548 If there's no applicable decl, NULL_TREE is returned for the decl,
9549 and the other fields are left undefined.
9551 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9552 is returned for the decl, and the other fields are left undefined.
9554 Otherwise, the decl returned currently is either a VAR_DECL or a
9557 The offset returned is always valid, but of course not necessarily
9558 a constant, and not necessarily converted into the appropriate
9559 type, leaving that up to the caller (so as to avoid that overhead
9560 if the decls being looked at are different anyway).
9562 If the size cannot be determined (e.g. an adjustable array),
9563 an ERROR_MARK node is returned for the size. Otherwise, the
9564 size returned is valid, not necessarily a constant, and not
9565 necessarily converted into the appropriate type as with the
9568 Note that the offset and size expressions are expressed in the
9569 base storage units (usually bits) rather than in the units of
9570 the type of the decl, because two decls with different types
9571 might overlap but with apparently non-overlapping array offsets,
9572 whereas converting the array offsets to consistant offsets will
9573 reveal the overlap. */
9575 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9577 ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
9580 /* The default path is to report a nonexistant decl. */
9586 switch (TREE_CODE (t
))
9589 case IDENTIFIER_NODE
:
9598 case TRUNC_DIV_EXPR
:
9600 case FLOOR_DIV_EXPR
:
9601 case ROUND_DIV_EXPR
:
9602 case TRUNC_MOD_EXPR
:
9604 case FLOOR_MOD_EXPR
:
9605 case ROUND_MOD_EXPR
:
9607 case EXACT_DIV_EXPR
:
9608 case FIX_TRUNC_EXPR
:
9610 case FIX_FLOOR_EXPR
:
9611 case FIX_ROUND_EXPR
:
9626 case BIT_ANDTC_EXPR
:
9628 case TRUTH_ANDIF_EXPR
:
9629 case TRUTH_ORIF_EXPR
:
9630 case TRUTH_AND_EXPR
:
9632 case TRUTH_XOR_EXPR
:
9633 case TRUTH_NOT_EXPR
:
9653 *offset
= bitsize_int (0L, 0L);
9654 *size
= TYPE_SIZE (TREE_TYPE (t
));
9659 tree array
= TREE_OPERAND (t
, 0);
9660 tree element
= TREE_OPERAND (t
, 1);
9663 if ((array
== NULL_TREE
)
9664 || (element
== NULL_TREE
))
9666 *decl
= error_mark_node
;
9670 ffecom_tree_canonize_ref_ (decl
, &init_offset
, size
,
9672 if ((*decl
== NULL_TREE
)
9673 || (*decl
== error_mark_node
))
9676 *offset
= size_binop (MULT_EXPR
,
9677 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array
))),
9678 size_binop (MINUS_EXPR
,
9682 (TREE_TYPE (array
)))));
9684 *offset
= size_binop (PLUS_EXPR
,
9688 *size
= TYPE_SIZE (TREE_TYPE (t
));
9694 /* Most of this code is to handle references to COMMON. And so
9695 far that is useful only for calling library functions, since
9696 external (user) functions might reference common areas. But
9697 even calling an external function, it's worthwhile to decode
9698 COMMON references because if not storing into COMMON, we don't
9699 want COMMON-based arguments to gratuitously force use of a
9702 *size
= TYPE_SIZE (TREE_TYPE (t
));
9704 ffecom_tree_canonize_ptr_ (decl
, offset
,
9705 TREE_OPERAND (t
, 0));
9712 case NON_LVALUE_EXPR
:
9715 case COND_EXPR
: /* More cases than we can handle. */
9717 case REFERENCE_EXPR
:
9718 case PREDECREMENT_EXPR
:
9719 case PREINCREMENT_EXPR
:
9720 case POSTDECREMENT_EXPR
:
9721 case POSTINCREMENT_EXPR
:
9724 *decl
= error_mark_node
;
9730 /* Do divide operation appropriate to type of operands. */
9732 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9734 ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
9735 tree dest_tree
, ffebld dest
, bool *dest_used
)
9737 if ((left
== error_mark_node
)
9738 || (right
== error_mark_node
))
9739 return error_mark_node
;
9741 switch (TREE_CODE (tree_type
))
9744 return ffecom_2 (TRUNC_DIV_EXPR
, tree_type
,
9752 if (TREE_TYPE (tree_type
)
9753 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9754 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9756 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9758 left
= ffecom_1 (ADDR_EXPR
,
9759 build_pointer_type (TREE_TYPE (left
)),
9761 left
= build_tree_list (NULL_TREE
, left
);
9762 right
= ffecom_1 (ADDR_EXPR
,
9763 build_pointer_type (TREE_TYPE (right
)),
9765 right
= build_tree_list (NULL_TREE
, right
);
9766 TREE_CHAIN (left
) = right
;
9768 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9769 ffecom_gfrt_kindtype (ix
),
9770 ffe_is_f2c_library (),
9773 dest_tree
, dest
, dest_used
,
9782 if (TREE_TYPE (TYPE_FIELDS (tree_type
))
9783 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9784 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9786 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9788 left
= ffecom_1 (ADDR_EXPR
,
9789 build_pointer_type (TREE_TYPE (left
)),
9791 left
= build_tree_list (NULL_TREE
, left
);
9792 right
= ffecom_1 (ADDR_EXPR
,
9793 build_pointer_type (TREE_TYPE (right
)),
9795 right
= build_tree_list (NULL_TREE
, right
);
9796 TREE_CHAIN (left
) = right
;
9798 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9799 ffecom_gfrt_kindtype (ix
),
9800 ffe_is_f2c_library (),
9803 dest_tree
, dest
, dest_used
,
9809 return ffecom_2 (RDIV_EXPR
, tree_type
,
9816 /* ffecom_type_localvar_ -- Build type info for non-dummy variable
9819 ffesymbol s; // the variable's symbol
9820 ffeinfoBasictype bt; // it's basictype
9821 ffeinfoKindtype kt; // it's kindtype
9823 type = ffecom_type_localvar_(s,bt,kt);
9825 Handles static arrays, CHARACTER type, etc. */
9827 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9829 ffecom_type_localvar_ (ffesymbol s
, ffeinfoBasictype bt
,
9838 type
= ffecom_tree_type
[bt
][kt
];
9839 if (bt
== FFEINFO_basictypeCHARACTER
)
9841 hight
= build_int_2 (ffesymbol_size (s
), 0);
9842 TREE_TYPE (hight
) = ffecom_f2c_ftnlen_type_node
;
9847 build_range_type (ffecom_f2c_ftnlen_type_node
,
9848 ffecom_f2c_ftnlen_one_node
,
9850 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9853 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
9855 if (type
== error_mark_node
)
9858 dim
= ffebld_head (dl
);
9859 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
9861 if (ffebld_left (dim
) == NULL
)
9862 lowt
= integer_one_node
;
9864 lowt
= ffecom_expr (ffebld_left (dim
));
9866 if (TREE_CODE (lowt
) != INTEGER_CST
)
9867 lowt
= variable_size (lowt
);
9869 assert (ffebld_right (dim
) != NULL
);
9870 hight
= ffecom_expr (ffebld_right (dim
));
9872 if (TREE_CODE (hight
) != INTEGER_CST
)
9873 hight
= variable_size (hight
);
9875 type
= build_array_type (type
,
9876 build_range_type (ffecom_integer_type_node
,
9878 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9885 /* Build Namelist type. */
9887 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9889 ffecom_type_namelist_ ()
9891 static tree type
= NULL_TREE
;
9893 if (type
== NULL_TREE
)
9895 static tree namefield
, varsfield
, nvarsfield
;
9898 vardesctype
= ffecom_type_vardesc_ ();
9900 push_obstacks_nochange ();
9901 end_temporary_allocation ();
9903 type
= make_node (RECORD_TYPE
);
9905 vardesctype
= build_pointer_type (build_pointer_type (vardesctype
));
9907 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9909 varsfield
= ffecom_decl_field (type
, namefield
, "vars", vardesctype
);
9910 nvarsfield
= ffecom_decl_field (type
, varsfield
, "nvars",
9913 TYPE_FIELDS (type
) = namefield
;
9916 resume_temporary_allocation ();
9925 /* Make a copy of a type, assuming caller has switched to the permanent
9926 obstacks and that the type is for an aggregate (array) initializer. */
9928 #if FFECOM_targetCURRENT == FFECOM_targetGCC && 0 /* Not used now. */
9930 ffecom_type_permanent_copy_ (tree t
)
9935 assert (TREE_TYPE (t
) != NULL_TREE
);
9937 domain
= TYPE_DOMAIN (t
);
9939 assert (TREE_CODE (t
) == ARRAY_TYPE
);
9940 assert (TREE_PERMANENT (TREE_TYPE (t
)));
9941 assert (TREE_PERMANENT (TREE_TYPE (domain
)));
9942 assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain
)));
9944 max
= TYPE_MAX_VALUE (domain
);
9945 if (!TREE_PERMANENT (max
))
9947 assert (TREE_CODE (max
) == INTEGER_CST
);
9949 max
= build_int_2 (TREE_INT_CST_LOW (max
), TREE_INT_CST_HIGH (max
));
9950 TREE_TYPE (max
) = TREE_TYPE (TYPE_MIN_VALUE (domain
));
9953 return build_array_type (TREE_TYPE (t
),
9954 build_range_type (TREE_TYPE (domain
),
9955 TYPE_MIN_VALUE (domain
),
9960 /* Build Vardesc type. */
9962 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9964 ffecom_type_vardesc_ ()
9966 static tree type
= NULL_TREE
;
9967 static tree namefield
, addrfield
, dimsfield
, typefield
;
9969 if (type
== NULL_TREE
)
9971 push_obstacks_nochange ();
9972 end_temporary_allocation ();
9974 type
= make_node (RECORD_TYPE
);
9976 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9978 addrfield
= ffecom_decl_field (type
, namefield
, "addr",
9980 dimsfield
= ffecom_decl_field (type
, addrfield
, "dims",
9981 ffecom_f2c_ptr_to_ftnlen_type_node
);
9982 typefield
= ffecom_decl_field (type
, dimsfield
, "type",
9985 TYPE_FIELDS (type
) = namefield
;
9988 resume_temporary_allocation ();
9997 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9999 ffecom_vardesc_ (ffebld expr
)
10003 assert (ffebld_op (expr
) == FFEBLD_opSYMTER
);
10004 s
= ffebld_symter (expr
);
10006 if (ffesymbol_hook (s
).vardesc_tree
== NULL_TREE
)
10009 tree vardesctype
= ffecom_type_vardesc_ ();
10018 static int mynumber
= 0;
10020 yes
= suspend_momentary ();
10022 var
= build_decl (VAR_DECL
,
10023 ffecom_get_invented_identifier ("__g77_vardesc_%d",
10026 TREE_STATIC (var
) = 1;
10027 DECL_INITIAL (var
) = error_mark_node
;
10029 var
= start_decl (var
, FALSE
);
10031 /* Process inits. */
10033 nameinit
= ffecom_build_f2c_string_ ((i
= strlen (ffesymbol_text (s
)))
10035 ffesymbol_text (s
));
10036 TREE_TYPE (nameinit
)
10037 = build_type_variant
10040 build_range_type (integer_type_node
,
10042 build_int_2 (i
, 0))),
10044 TREE_CONSTANT (nameinit
) = 1;
10045 TREE_STATIC (nameinit
) = 1;
10046 nameinit
= ffecom_1 (ADDR_EXPR
,
10047 build_pointer_type (TREE_TYPE (nameinit
)),
10050 addrinit
= ffecom_arg_ptr_to_expr (expr
, &typeinit
);
10052 dimsinit
= ffecom_vardesc_dims_ (s
);
10054 if (typeinit
== NULL_TREE
)
10056 ffeinfoBasictype bt
= ffesymbol_basictype (s
);
10057 ffeinfoKindtype kt
= ffesymbol_kindtype (s
);
10058 int tc
= ffecom_f2c_typecode (bt
, kt
);
10061 typeinit
= build_int_2 (tc
, (tc
< 0) ? -1 : 0);
10064 typeinit
= ffecom_1 (NEGATE_EXPR
, TREE_TYPE (typeinit
), typeinit
);
10066 varinits
= build_tree_list ((field
= TYPE_FIELDS (vardesctype
)),
10068 TREE_CHAIN (varinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
10070 TREE_CHAIN (TREE_CHAIN (varinits
))
10071 = build_tree_list ((field
= TREE_CHAIN (field
)), dimsinit
);
10072 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits
)))
10073 = build_tree_list ((field
= TREE_CHAIN (field
)), typeinit
);
10075 varinits
= build (CONSTRUCTOR
, vardesctype
, NULL_TREE
, varinits
);
10076 TREE_CONSTANT (varinits
) = 1;
10077 TREE_STATIC (varinits
) = 1;
10079 finish_decl (var
, varinits
, FALSE
);
10081 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (vardesctype
), var
);
10083 resume_momentary (yes
);
10085 ffesymbol_hook (s
).vardesc_tree
= var
;
10088 return ffesymbol_hook (s
).vardesc_tree
;
10092 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10094 ffecom_vardesc_array_ (ffesymbol s
)
10098 tree item
= NULL_TREE
;
10102 static int mynumber
= 0;
10104 for (i
= 0, list
= NULL_TREE
, b
= ffesymbol_namelist (s
);
10106 b
= ffebld_trail (b
), ++i
)
10110 t
= ffecom_vardesc_ (ffebld_head (b
));
10112 if (list
== NULL_TREE
)
10113 list
= item
= build_tree_list (NULL_TREE
, t
);
10116 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
10117 item
= TREE_CHAIN (item
);
10121 yes
= suspend_momentary ();
10123 item
= build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
10124 build_range_type (integer_type_node
,
10126 build_int_2 (i
, 0)));
10127 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
10128 TREE_CONSTANT (list
) = 1;
10129 TREE_STATIC (list
) = 1;
10131 var
= ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL
,
10133 var
= build_decl (VAR_DECL
, var
, item
);
10134 TREE_STATIC (var
) = 1;
10135 DECL_INITIAL (var
) = error_mark_node
;
10136 var
= start_decl (var
, FALSE
);
10137 finish_decl (var
, list
, FALSE
);
10139 resume_momentary (yes
);
10145 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10147 ffecom_vardesc_dims_ (ffesymbol s
)
10149 if (ffesymbol_dims (s
) == NULL
)
10150 return convert (ffecom_f2c_ptr_to_ftnlen_type_node
,
10151 integer_zero_node
);
10158 tree item
= NULL_TREE
;
10163 tree baseoff
= NULL_TREE
;
10164 static int mynumber
= 0;
10166 numdim
= build_int_2 ((int) ffesymbol_rank (s
), 0);
10167 TREE_TYPE (numdim
) = ffecom_f2c_ftnlen_type_node
;
10169 numelem
= ffecom_expr (ffesymbol_arraysize (s
));
10170 TREE_TYPE (numelem
) = ffecom_f2c_ftnlen_type_node
;
10173 backlist
= NULL_TREE
;
10174 for (b
= ffesymbol_dims (s
), e
= ffesymbol_extents (s
);
10176 b
= ffebld_trail (b
), e
= ffebld_trail (e
))
10182 if (ffebld_trail (b
) == NULL
)
10186 t
= convert (ffecom_f2c_ftnlen_type_node
,
10187 ffecom_expr (ffebld_head (e
)));
10189 if (list
== NULL_TREE
)
10190 list
= item
= build_tree_list (NULL_TREE
, t
);
10193 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
10194 item
= TREE_CHAIN (item
);
10198 if (ffebld_left (ffebld_head (b
)) == NULL
)
10199 low
= ffecom_integer_one_node
;
10201 low
= ffecom_expr (ffebld_left (ffebld_head (b
)));
10202 low
= convert (ffecom_f2c_ftnlen_type_node
, low
);
10204 back
= build_tree_list (low
, t
);
10205 TREE_CHAIN (back
) = backlist
;
10209 for (item
= backlist
; item
!= NULL_TREE
; item
= TREE_CHAIN (item
))
10211 if (TREE_VALUE (item
) == NULL_TREE
)
10212 baseoff
= TREE_PURPOSE (item
);
10214 baseoff
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
10215 TREE_PURPOSE (item
),
10216 ffecom_2 (MULT_EXPR
,
10217 ffecom_f2c_ftnlen_type_node
,
10222 /* backlist now dead, along with all TREE_PURPOSEs on it. */
10224 baseoff
= build_tree_list (NULL_TREE
, baseoff
);
10225 TREE_CHAIN (baseoff
) = list
;
10227 numelem
= build_tree_list (NULL_TREE
, numelem
);
10228 TREE_CHAIN (numelem
) = baseoff
;
10230 numdim
= build_tree_list (NULL_TREE
, numdim
);
10231 TREE_CHAIN (numdim
) = numelem
;
10233 yes
= suspend_momentary ();
10235 item
= build_array_type (ffecom_f2c_ftnlen_type_node
,
10236 build_range_type (integer_type_node
,
10239 ((int) ffesymbol_rank (s
)
10241 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, numdim
);
10242 TREE_CONSTANT (list
) = 1;
10243 TREE_STATIC (list
) = 1;
10245 var
= ffecom_get_invented_identifier ("__g77_dims_%d", NULL
,
10247 var
= build_decl (VAR_DECL
, var
, item
);
10248 TREE_STATIC (var
) = 1;
10249 DECL_INITIAL (var
) = error_mark_node
;
10250 var
= start_decl (var
, FALSE
);
10251 finish_decl (var
, list
, FALSE
);
10253 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (item
), var
);
10255 resume_momentary (yes
);
10262 /* Essentially does a "fold (build1 (code, type, node))" while checking
10263 for certain housekeeping things.
10265 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
10266 ffecom_1_fn instead. */
10268 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10270 ffecom_1 (enum tree_code code
, tree type
, tree node
)
10274 if ((node
== error_mark_node
)
10275 || (type
== error_mark_node
))
10276 return error_mark_node
;
10278 if (code
== ADDR_EXPR
)
10280 if (!mark_addressable (node
))
10281 assert ("can't mark_addressable this node!" == NULL
);
10284 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
10288 case REALPART_EXPR
:
10289 item
= build (COMPONENT_REF
, type
, node
, TYPE_FIELDS (TREE_TYPE (node
)));
10292 case IMAGPART_EXPR
:
10293 item
= build (COMPONENT_REF
, type
, node
, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node
))));
10298 if (TREE_CODE (type
) != RECORD_TYPE
)
10300 item
= build1 (code
, type
, node
);
10303 node
= ffecom_stabilize_aggregate_ (node
);
10304 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10306 ffecom_2 (COMPLEX_EXPR
, type
,
10307 ffecom_1 (NEGATE_EXPR
, realtype
,
10308 ffecom_1 (REALPART_EXPR
, realtype
,
10310 ffecom_1 (NEGATE_EXPR
, realtype
,
10311 ffecom_1 (IMAGPART_EXPR
, realtype
,
10316 item
= build1 (code
, type
, node
);
10320 if (TREE_SIDE_EFFECTS (node
))
10321 TREE_SIDE_EFFECTS (item
) = 1;
10322 if ((code
== ADDR_EXPR
) && staticp (node
))
10323 TREE_CONSTANT (item
) = 1;
10324 return fold (item
);
10328 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
10329 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
10330 does not set TREE_ADDRESSABLE (because calling an inline
10331 function does not mean the function needs to be separately
10334 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10336 ffecom_1_fn (tree node
)
10341 if (node
== error_mark_node
)
10342 return error_mark_node
;
10344 type
= build_type_variant (TREE_TYPE (node
),
10345 TREE_READONLY (node
),
10346 TREE_THIS_VOLATILE (node
));
10347 item
= build1 (ADDR_EXPR
,
10348 build_pointer_type (type
), node
);
10349 if (TREE_SIDE_EFFECTS (node
))
10350 TREE_SIDE_EFFECTS (item
) = 1;
10351 if (staticp (node
))
10352 TREE_CONSTANT (item
) = 1;
10353 return fold (item
);
10357 /* Essentially does a "fold (build (code, type, node1, node2))" while
10358 checking for certain housekeeping things. */
10360 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10362 ffecom_2 (enum tree_code code
, tree type
, tree node1
,
10367 if ((node1
== error_mark_node
)
10368 || (node2
== error_mark_node
)
10369 || (type
== error_mark_node
))
10370 return error_mark_node
;
10372 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
10374 tree a
, b
, c
, d
, realtype
;
10377 assert ("no CONJ_EXPR support yet" == NULL
);
10378 return error_mark_node
;
10381 item
= build_tree_list (TYPE_FIELDS (type
), node1
);
10382 TREE_CHAIN (item
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), node2
);
10383 item
= build (CONSTRUCTOR
, type
, NULL_TREE
, item
);
10387 if (TREE_CODE (type
) != RECORD_TYPE
)
10389 item
= build (code
, type
, node1
, node2
);
10392 node1
= ffecom_stabilize_aggregate_ (node1
);
10393 node2
= ffecom_stabilize_aggregate_ (node2
);
10394 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10396 ffecom_2 (COMPLEX_EXPR
, type
,
10397 ffecom_2 (PLUS_EXPR
, realtype
,
10398 ffecom_1 (REALPART_EXPR
, realtype
,
10400 ffecom_1 (REALPART_EXPR
, realtype
,
10402 ffecom_2 (PLUS_EXPR
, realtype
,
10403 ffecom_1 (IMAGPART_EXPR
, realtype
,
10405 ffecom_1 (IMAGPART_EXPR
, realtype
,
10410 if (TREE_CODE (type
) != RECORD_TYPE
)
10412 item
= build (code
, type
, node1
, node2
);
10415 node1
= ffecom_stabilize_aggregate_ (node1
);
10416 node2
= ffecom_stabilize_aggregate_ (node2
);
10417 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10419 ffecom_2 (COMPLEX_EXPR
, type
,
10420 ffecom_2 (MINUS_EXPR
, realtype
,
10421 ffecom_1 (REALPART_EXPR
, realtype
,
10423 ffecom_1 (REALPART_EXPR
, realtype
,
10425 ffecom_2 (MINUS_EXPR
, realtype
,
10426 ffecom_1 (IMAGPART_EXPR
, realtype
,
10428 ffecom_1 (IMAGPART_EXPR
, realtype
,
10433 if (TREE_CODE (type
) != RECORD_TYPE
)
10435 item
= build (code
, type
, node1
, node2
);
10438 node1
= ffecom_stabilize_aggregate_ (node1
);
10439 node2
= ffecom_stabilize_aggregate_ (node2
);
10440 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10441 a
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
10443 b
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
10445 c
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
10447 d
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
10450 ffecom_2 (COMPLEX_EXPR
, type
,
10451 ffecom_2 (MINUS_EXPR
, realtype
,
10452 ffecom_2 (MULT_EXPR
, realtype
,
10455 ffecom_2 (MULT_EXPR
, realtype
,
10458 ffecom_2 (PLUS_EXPR
, realtype
,
10459 ffecom_2 (MULT_EXPR
, realtype
,
10462 ffecom_2 (MULT_EXPR
, realtype
,
10468 if ((TREE_CODE (node1
) != RECORD_TYPE
)
10469 && (TREE_CODE (node2
) != RECORD_TYPE
))
10471 item
= build (code
, type
, node1
, node2
);
10474 assert (TREE_CODE (node1
) == RECORD_TYPE
);
10475 assert (TREE_CODE (node2
) == RECORD_TYPE
);
10476 node1
= ffecom_stabilize_aggregate_ (node1
);
10477 node2
= ffecom_stabilize_aggregate_ (node2
);
10478 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10480 ffecom_2 (TRUTH_ANDIF_EXPR
, type
,
10481 ffecom_2 (code
, type
,
10482 ffecom_1 (REALPART_EXPR
, realtype
,
10484 ffecom_1 (REALPART_EXPR
, realtype
,
10486 ffecom_2 (code
, type
,
10487 ffecom_1 (IMAGPART_EXPR
, realtype
,
10489 ffecom_1 (IMAGPART_EXPR
, realtype
,
10494 if ((TREE_CODE (node1
) != RECORD_TYPE
)
10495 && (TREE_CODE (node2
) != RECORD_TYPE
))
10497 item
= build (code
, type
, node1
, node2
);
10500 assert (TREE_CODE (node1
) == RECORD_TYPE
);
10501 assert (TREE_CODE (node2
) == RECORD_TYPE
);
10502 node1
= ffecom_stabilize_aggregate_ (node1
);
10503 node2
= ffecom_stabilize_aggregate_ (node2
);
10504 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10506 ffecom_2 (TRUTH_ORIF_EXPR
, type
,
10507 ffecom_2 (code
, type
,
10508 ffecom_1 (REALPART_EXPR
, realtype
,
10510 ffecom_1 (REALPART_EXPR
, realtype
,
10512 ffecom_2 (code
, type
,
10513 ffecom_1 (IMAGPART_EXPR
, realtype
,
10515 ffecom_1 (IMAGPART_EXPR
, realtype
,
10520 item
= build (code
, type
, node1
, node2
);
10524 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
))
10525 TREE_SIDE_EFFECTS (item
) = 1;
10526 return fold (item
);
10530 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
10532 ffesymbol s; // the ENTRY point itself
10533 if (ffecom_2pass_advise_entrypoint(s))
10534 // the ENTRY point has been accepted
10536 Does whatever compiler needs to do when it learns about the entrypoint,
10537 like determine the return type of the master function, count the
10538 number of entrypoints, etc. Returns FALSE if the return type is
10539 not compatible with the return type(s) of other entrypoint(s).
10541 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
10542 later (after _finish_progunit) be called with the same entrypoint(s)
10543 as passed to this fn for which TRUE was returned.
10546 Return FALSE if the return type conflicts with previous entrypoints. */
10548 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10550 ffecom_2pass_advise_entrypoint (ffesymbol entry
)
10552 ffebld list
; /* opITEM. */
10553 ffebld mlist
; /* opITEM. */
10554 ffebld plist
; /* opITEM. */
10555 ffebld arg
; /* ffebld_head(opITEM). */
10556 ffebld item
; /* opITEM. */
10557 ffesymbol s
; /* ffebld_symter(arg). */
10558 ffeinfoBasictype bt
= ffesymbol_basictype (entry
);
10559 ffeinfoKindtype kt
= ffesymbol_kindtype (entry
);
10560 ffetargetCharacterSize size
= ffesymbol_size (entry
);
10563 if (ffecom_num_entrypoints_
== 0)
10564 { /* First entrypoint, make list of main
10565 arglist's dummies. */
10566 assert (ffecom_primary_entry_
!= NULL
);
10568 ffecom_master_bt_
= ffesymbol_basictype (ffecom_primary_entry_
);
10569 ffecom_master_kt_
= ffesymbol_kindtype (ffecom_primary_entry_
);
10570 ffecom_master_size_
= ffesymbol_size (ffecom_primary_entry_
);
10572 for (plist
= NULL
, list
= ffesymbol_dummyargs (ffecom_primary_entry_
);
10574 list
= ffebld_trail (list
))
10576 arg
= ffebld_head (list
);
10577 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
10578 continue; /* Alternate return or some such thing. */
10579 item
= ffebld_new_item (arg
, NULL
);
10581 ffecom_master_arglist_
= item
;
10583 ffebld_set_trail (plist
, item
);
10588 /* If necessary, scan entry arglist for alternate returns. Do this scan
10589 apparently redundantly (it's done below to UNIONize the arglists) so
10590 that we don't complain about RETURN 1 if an offending ENTRY is the only
10591 one with an alternate return. */
10593 if (!ffecom_is_altreturning_
)
10595 for (list
= ffesymbol_dummyargs (entry
);
10597 list
= ffebld_trail (list
))
10599 arg
= ffebld_head (list
);
10600 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
10602 ffecom_is_altreturning_
= TRUE
;
10608 /* Now check type compatibility. */
10610 switch (ffecom_master_bt_
)
10612 case FFEINFO_basictypeNONE
:
10613 ok
= (bt
!= FFEINFO_basictypeCHARACTER
);
10616 case FFEINFO_basictypeCHARACTER
:
10618 = (bt
== FFEINFO_basictypeCHARACTER
)
10619 && (kt
== ffecom_master_kt_
)
10620 && (size
== ffecom_master_size_
);
10623 case FFEINFO_basictypeANY
:
10624 return FALSE
; /* Just don't bother. */
10627 if (bt
== FFEINFO_basictypeCHARACTER
)
10633 if ((bt
!= ffecom_master_bt_
) || (kt
!= ffecom_master_kt_
))
10635 ffecom_master_bt_
= FFEINFO_basictypeNONE
;
10636 ffecom_master_kt_
= FFEINFO_kindtypeNONE
;
10643 ffebad_start (FFEBAD_ENTRY_CONFLICTS
);
10644 ffest_ffebad_here_current_stmt (0);
10646 return FALSE
; /* Can't handle entrypoint. */
10649 /* Entrypoint type compatible with previous types. */
10651 ++ffecom_num_entrypoints_
;
10653 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10655 for (list
= ffesymbol_dummyargs (entry
);
10657 list
= ffebld_trail (list
))
10659 arg
= ffebld_head (list
);
10660 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
10661 continue; /* Alternate return or some such thing. */
10662 s
= ffebld_symter (arg
);
10663 for (plist
= NULL
, mlist
= ffecom_master_arglist_
;
10665 plist
= mlist
, mlist
= ffebld_trail (mlist
))
10666 { /* plist points to previous item for easy
10667 appending of arg. */
10668 if (ffebld_symter (ffebld_head (mlist
)) == s
)
10669 break; /* Already have this arg in the master list. */
10672 continue; /* Already have this arg in the master list. */
10674 /* Append this arg to the master list. */
10676 item
= ffebld_new_item (arg
, NULL
);
10678 ffecom_master_arglist_
= item
;
10680 ffebld_set_trail (plist
, item
);
10687 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10689 ffesymbol s; // the ENTRY point itself
10690 ffecom_2pass_do_entrypoint(s);
10692 Does whatever compiler needs to do to make the entrypoint actually
10693 happen. Must be called for each entrypoint after
10694 ffecom_finish_progunit is called. */
10696 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10698 ffecom_2pass_do_entrypoint (ffesymbol entry
)
10700 static int mfn_num
= 0;
10701 static int ent_num
;
10703 if (mfn_num
!= ffecom_num_fns_
)
10704 { /* First entrypoint for this program unit. */
10706 mfn_num
= ffecom_num_fns_
;
10707 ffecom_do_entry_ (ffecom_primary_entry_
, 0);
10712 --ffecom_num_entrypoints_
;
10714 ffecom_do_entry_ (entry
, ent_num
);
10719 /* Essentially does a "fold (build (code, type, node1, node2))" while
10720 checking for certain housekeeping things. Always sets
10721 TREE_SIDE_EFFECTS. */
10723 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10725 ffecom_2s (enum tree_code code
, tree type
, tree node1
,
10730 if ((node1
== error_mark_node
)
10731 || (node2
== error_mark_node
)
10732 || (type
== error_mark_node
))
10733 return error_mark_node
;
10735 item
= build (code
, type
, node1
, node2
);
10736 TREE_SIDE_EFFECTS (item
) = 1;
10737 return fold (item
);
10741 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10742 checking for certain housekeeping things. */
10744 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10746 ffecom_3 (enum tree_code code
, tree type
, tree node1
,
10747 tree node2
, tree node3
)
10751 if ((node1
== error_mark_node
)
10752 || (node2
== error_mark_node
)
10753 || (node3
== error_mark_node
)
10754 || (type
== error_mark_node
))
10755 return error_mark_node
;
10757 item
= build (code
, type
, node1
, node2
, node3
);
10758 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
)
10759 || (node3
!= NULL_TREE
&& TREE_SIDE_EFFECTS (node3
)))
10760 TREE_SIDE_EFFECTS (item
) = 1;
10761 return fold (item
);
10765 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10766 checking for certain housekeeping things. Always sets
10767 TREE_SIDE_EFFECTS. */
10769 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10771 ffecom_3s (enum tree_code code
, tree type
, tree node1
,
10772 tree node2
, tree node3
)
10776 if ((node1
== error_mark_node
)
10777 || (node2
== error_mark_node
)
10778 || (node3
== error_mark_node
)
10779 || (type
== error_mark_node
))
10780 return error_mark_node
;
10782 item
= build (code
, type
, node1
, node2
, node3
);
10783 TREE_SIDE_EFFECTS (item
) = 1;
10784 return fold (item
);
10788 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10790 See use by ffecom_list_expr.
10792 If expression is NULL, returns an integer zero tree. If it is not
10793 a CHARACTER expression, returns whatever ffecom_expr
10794 returns and sets the length return value to NULL_TREE. Otherwise
10795 generates code to evaluate the character expression, returns the proper
10796 pointer to the result, but does NOT set the length return value to a tree
10797 that specifies the length of the result. (In other words, the length
10798 variable is always set to NULL_TREE, because a length is never passed.)
10801 Don't set returned length, since nobody needs it (yet; someday if
10802 we allow CHARACTER*(*) dummies to statement functions, we'll need
10805 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10807 ffecom_arg_expr (ffebld expr
, tree
*length
)
10811 *length
= NULL_TREE
;
10814 return integer_zero_node
;
10816 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10817 return ffecom_expr (expr
);
10819 return ffecom_arg_ptr_to_expr (expr
, &ign
);
10823 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10825 See use by ffecom_list_ptr_to_expr.
10827 If expression is NULL, returns an integer zero tree. If it is not
10828 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10829 returns and sets the length return value to NULL_TREE. Otherwise
10830 generates code to evaluate the character expression, returns the proper
10831 pointer to the result, AND sets the length return value to a tree that
10832 specifies the length of the result.
10834 If the length argument is NULL, this is a slightly special
10835 case of building a FORMAT expression, that is, an expression that
10836 will be used at run time without regard to length. For the current
10837 implementation, which uses the libf2c library, this means it is nice
10838 to append a null byte to the end of the expression, where feasible,
10839 to make sure any diagnostic about the FORMAT string terminates at
10842 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10843 length argument. This might even be seen as a feature, if a null
10844 byte can always be appended. */
10846 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10848 ffecom_arg_ptr_to_expr (ffebld expr
, tree
*length
)
10852 ffecomConcatList_ catlist
;
10854 if (length
!= NULL
)
10855 *length
= NULL_TREE
;
10858 return integer_zero_node
;
10860 switch (ffebld_op (expr
))
10862 case FFEBLD_opPERCENT_VAL
:
10863 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10864 return ffecom_expr (ffebld_left (expr
));
10869 temp_exp
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &temp_length
);
10870 return ffecom_1 (INDIRECT_REF
, TREE_TYPE (TREE_TYPE (temp_exp
)),
10874 case FFEBLD_opPERCENT_REF
:
10875 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10876 return ffecom_ptr_to_expr (ffebld_left (expr
));
10877 if (length
!= NULL
)
10879 ign_length
= NULL_TREE
;
10880 length
= &ign_length
;
10882 expr
= ffebld_left (expr
);
10885 case FFEBLD_opPERCENT_DESCR
:
10886 switch (ffeinfo_basictype (ffebld_info (expr
)))
10888 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10889 case FFEINFO_basictypeHOLLERITH
:
10891 case FFEINFO_basictypeCHARACTER
:
10892 break; /* Passed by descriptor anyway. */
10895 item
= ffecom_ptr_to_expr (expr
);
10896 if (item
!= error_mark_node
)
10897 *length
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (item
)));
10906 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10907 if ((ffeinfo_basictype (ffebld_info (expr
)) == FFEINFO_basictypeHOLLERITH
)
10908 && (length
!= NULL
))
10909 { /* Pass Hollerith by descriptor. */
10910 ffetargetHollerith h
;
10912 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
10913 h
= ffebld_cu_val_hollerith (ffebld_constant_union
10914 (ffebld_conter (expr
)));
10916 = build_int_2 (h
.length
, 0);
10917 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10921 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10922 return ffecom_ptr_to_expr (expr
);
10924 assert (ffeinfo_kindtype (ffebld_info (expr
))
10925 == FFEINFO_kindtypeCHARACTER1
);
10927 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
10928 switch (ffecom_concat_list_count_ (catlist
))
10930 case 0: /* Shouldn't happen, but in case it does... */
10931 if (length
!= NULL
)
10933 *length
= ffecom_f2c_ftnlen_zero_node
;
10934 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10936 ffecom_concat_list_kill_ (catlist
);
10937 return null_pointer_node
;
10939 case 1: /* The (fairly) easy case. */
10940 if (length
== NULL
)
10941 ffecom_char_args_with_null_ (&item
, &ign_length
,
10942 ffecom_concat_list_expr_ (catlist
, 0));
10944 ffecom_char_args_ (&item
, length
,
10945 ffecom_concat_list_expr_ (catlist
, 0));
10946 ffecom_concat_list_kill_ (catlist
);
10947 assert (item
!= NULL_TREE
);
10950 default: /* Must actually concatenate things. */
10955 int count
= ffecom_concat_list_count_ (catlist
);
10966 ffetargetCharacterSize sz
;
10970 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
10971 FFETARGET_charactersizeNONE
, count
, TRUE
);
10974 = ffecom_push_tempvar (ffecom_f2c_address_type_node
,
10975 FFETARGET_charactersizeNONE
, count
, TRUE
);
10977 known_length
= ffecom_f2c_ftnlen_zero_node
;
10979 for (i
= 0; i
< count
; ++i
)
10982 && (length
== NULL
))
10983 ffecom_char_args_with_null_ (&citem
, &clength
,
10984 ffecom_concat_list_expr_ (catlist
, i
));
10986 ffecom_char_args_ (&citem
, &clength
,
10987 ffecom_concat_list_expr_ (catlist
, i
));
10988 if ((citem
== error_mark_node
)
10989 || (clength
== error_mark_node
))
10991 ffecom_concat_list_kill_ (catlist
);
10992 *length
= error_mark_node
;
10993 return error_mark_node
;
10997 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
10998 ffecom_modify (void_type_node
,
10999 ffecom_2 (ARRAY_REF
,
11000 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
11002 build_int_2 (i
, 0)),
11005 clength
= ffecom_save_tree (clength
);
11006 if (length
!= NULL
)
11008 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
11012 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
11013 ffecom_modify (void_type_node
,
11014 ffecom_2 (ARRAY_REF
,
11015 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
11017 build_int_2 (i
, 0)),
11022 sz
= ffecom_concat_list_maxlen_ (catlist
);
11023 assert (sz
!= FFETARGET_charactersizeNONE
);
11025 temporary
= ffecom_push_tempvar (char_type_node
,
11027 temporary
= ffecom_1 (ADDR_EXPR
,
11028 build_pointer_type (TREE_TYPE (temporary
)),
11031 item
= build_tree_list (NULL_TREE
, temporary
);
11033 = build_tree_list (NULL_TREE
,
11034 ffecom_1 (ADDR_EXPR
,
11035 build_pointer_type (TREE_TYPE (items
)),
11037 TREE_CHAIN (TREE_CHAIN (item
))
11038 = build_tree_list (NULL_TREE
,
11039 ffecom_1 (ADDR_EXPR
,
11040 build_pointer_type (TREE_TYPE (lengths
)),
11042 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
11045 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
11046 convert (ffecom_f2c_ftnlen_type_node
,
11047 build_int_2 (count
, 0))));
11048 num
= build_int_2 (sz
, 0);
11049 TREE_TYPE (num
) = ffecom_f2c_ftnlen_type_node
;
11050 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
))))
11051 = build_tree_list (NULL_TREE
, num
);
11053 item
= ffecom_call_gfrt (FFECOM_gfrtCAT
, item
);
11054 TREE_SIDE_EFFECTS (item
) = 1;
11055 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (temporary
),
11059 if (length
!= NULL
)
11060 *length
= known_length
;
11063 ffecom_concat_list_kill_ (catlist
);
11064 assert (item
!= NULL_TREE
);
11069 /* ffecom_call_gfrt -- Generate call to run-time function
11072 expr = ffecom_call_gfrt(FFECOM_gfrtSTOPNIL,NULL_TREE);
11074 The first arg is the GNU Fortran Run-Time function index, the second
11075 arg is the list of arguments to pass to it. Returned is the expression
11076 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
11077 result (which may be void). */
11079 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11081 ffecom_call_gfrt (ffecomGfrt ix
, tree args
)
11083 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
11084 ffecom_gfrt_kindtype (ix
),
11085 ffe_is_f2c_library () && ffecom_gfrt_complex_
[ix
],
11086 NULL_TREE
, args
, NULL_TREE
, NULL
,
11087 NULL
, NULL_TREE
, TRUE
);
11091 /* ffecom_constantunion -- Transform constant-union to tree
11093 ffebldConstantUnion cu; // the constant to transform
11094 ffeinfoBasictype bt; // its basic type
11095 ffeinfoKindtype kt; // its kind type
11096 tree tree_type; // ffecom_tree_type[bt][kt]
11097 ffecom_constantunion(&cu,bt,kt,tree_type); */
11099 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11101 ffecom_constantunion (ffebldConstantUnion
*cu
, ffeinfoBasictype bt
,
11102 ffeinfoKindtype kt
, tree tree_type
)
11108 case FFEINFO_basictypeINTEGER
:
11114 #if FFETARGET_okINTEGER1
11115 case FFEINFO_kindtypeINTEGER1
:
11116 val
= ffebld_cu_val_integer1 (*cu
);
11120 #if FFETARGET_okINTEGER2
11121 case FFEINFO_kindtypeINTEGER2
:
11122 val
= ffebld_cu_val_integer2 (*cu
);
11126 #if FFETARGET_okINTEGER3
11127 case FFEINFO_kindtypeINTEGER3
:
11128 val
= ffebld_cu_val_integer3 (*cu
);
11132 #if FFETARGET_okINTEGER4
11133 case FFEINFO_kindtypeINTEGER4
:
11134 val
= ffebld_cu_val_integer4 (*cu
);
11139 assert ("bad INTEGER constant kind type" == NULL
);
11140 /* Fall through. */
11141 case FFEINFO_kindtypeANY
:
11142 return error_mark_node
;
11144 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
11145 TREE_TYPE (item
) = tree_type
;
11149 case FFEINFO_basictypeLOGICAL
:
11155 #if FFETARGET_okLOGICAL1
11156 case FFEINFO_kindtypeLOGICAL1
:
11157 val
= ffebld_cu_val_logical1 (*cu
);
11161 #if FFETARGET_okLOGICAL2
11162 case FFEINFO_kindtypeLOGICAL2
:
11163 val
= ffebld_cu_val_logical2 (*cu
);
11167 #if FFETARGET_okLOGICAL3
11168 case FFEINFO_kindtypeLOGICAL3
:
11169 val
= ffebld_cu_val_logical3 (*cu
);
11173 #if FFETARGET_okLOGICAL4
11174 case FFEINFO_kindtypeLOGICAL4
:
11175 val
= ffebld_cu_val_logical4 (*cu
);
11180 assert ("bad LOGICAL constant kind type" == NULL
);
11181 /* Fall through. */
11182 case FFEINFO_kindtypeANY
:
11183 return error_mark_node
;
11185 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
11186 TREE_TYPE (item
) = tree_type
;
11190 case FFEINFO_basictypeREAL
:
11192 REAL_VALUE_TYPE val
;
11196 #if FFETARGET_okREAL1
11197 case FFEINFO_kindtypeREAL1
:
11198 val
= ffetarget_value_real1 (ffebld_cu_val_real1 (*cu
));
11202 #if FFETARGET_okREAL2
11203 case FFEINFO_kindtypeREAL2
:
11204 val
= ffetarget_value_real2 (ffebld_cu_val_real2 (*cu
));
11208 #if FFETARGET_okREAL3
11209 case FFEINFO_kindtypeREAL3
:
11210 val
= ffetarget_value_real3 (ffebld_cu_val_real3 (*cu
));
11214 #if FFETARGET_okREAL4
11215 case FFEINFO_kindtypeREAL4
:
11216 val
= ffetarget_value_real4 (ffebld_cu_val_real4 (*cu
));
11221 assert ("bad REAL constant kind type" == NULL
);
11222 /* Fall through. */
11223 case FFEINFO_kindtypeANY
:
11224 return error_mark_node
;
11226 item
= build_real (tree_type
, val
);
11230 case FFEINFO_basictypeCOMPLEX
:
11232 REAL_VALUE_TYPE real
;
11233 REAL_VALUE_TYPE imag
;
11234 tree el_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
11238 #if FFETARGET_okCOMPLEX1
11239 case FFEINFO_kindtypeREAL1
:
11240 real
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).real
);
11241 imag
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).imaginary
);
11245 #if FFETARGET_okCOMPLEX2
11246 case FFEINFO_kindtypeREAL2
:
11247 real
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).real
);
11248 imag
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).imaginary
);
11252 #if FFETARGET_okCOMPLEX3
11253 case FFEINFO_kindtypeREAL3
:
11254 real
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).real
);
11255 imag
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).imaginary
);
11259 #if FFETARGET_okCOMPLEX4
11260 case FFEINFO_kindtypeREAL4
:
11261 real
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).real
);
11262 imag
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).imaginary
);
11267 assert ("bad REAL constant kind type" == NULL
);
11268 /* Fall through. */
11269 case FFEINFO_kindtypeANY
:
11270 return error_mark_node
;
11272 item
= ffecom_build_complex_constant_ (tree_type
,
11273 build_real (el_type
, real
),
11274 build_real (el_type
, imag
));
11278 case FFEINFO_basictypeCHARACTER
:
11279 { /* Happens only in DATA and similar contexts. */
11280 ffetargetCharacter1 val
;
11284 #if FFETARGET_okCHARACTER1
11285 case FFEINFO_kindtypeLOGICAL1
:
11286 val
= ffebld_cu_val_character1 (*cu
);
11291 assert ("bad CHARACTER constant kind type" == NULL
);
11292 /* Fall through. */
11293 case FFEINFO_kindtypeANY
:
11294 return error_mark_node
;
11296 item
= build_string (ffetarget_length_character1 (val
),
11297 ffetarget_text_character1 (val
));
11299 = build_type_variant (build_array_type (char_type_node
,
11301 (integer_type_node
,
11304 (ffetarget_length_character1
11310 case FFEINFO_basictypeHOLLERITH
:
11312 ffetargetHollerith h
;
11314 h
= ffebld_cu_val_hollerith (*cu
);
11316 /* If not at least as wide as default INTEGER, widen it. */
11317 if (h
.length
>= FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
)
11318 item
= build_string (h
.length
, h
.text
);
11321 char str
[FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
];
11323 memcpy (str
, h
.text
, h
.length
);
11324 memset (&str
[h
.length
], ' ',
11325 FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
11327 item
= build_string (FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
,
11331 = build_type_variant (build_array_type (char_type_node
,
11333 (integer_type_node
,
11341 case FFEINFO_basictypeTYPELESS
:
11343 ffetargetInteger1 ival
;
11344 ffetargetTypeless tless
;
11347 tless
= ffebld_cu_val_typeless (*cu
);
11348 error
= ffetarget_convert_integer1_typeless (&ival
, tless
);
11349 assert (error
== FFEBAD
);
11351 item
= build_int_2 ((int) ival
, 0);
11356 assert ("not yet on constant type" == NULL
);
11357 /* Fall through. */
11358 case FFEINFO_basictypeANY
:
11359 return error_mark_node
;
11362 TREE_CONSTANT (item
) = 1;
11369 /* Handy way to make a field in a struct/union. */
11371 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11373 ffecom_decl_field (tree context
, tree prevfield
,
11374 char *name
, tree type
)
11378 field
= build_decl (FIELD_DECL
, get_identifier (name
), type
);
11379 DECL_CONTEXT (field
) = context
;
11380 DECL_FRAME_SIZE (field
) = 0;
11381 if (prevfield
!= NULL_TREE
)
11382 TREE_CHAIN (prevfield
) = field
;
11390 ffecom_close_include (FILE *f
)
11392 #if FFECOM_GCC_INCLUDE
11393 ffecom_close_include_ (f
);
11398 ffecom_decode_include_option (char *spec
)
11400 #if FFECOM_GCC_INCLUDE
11401 return ffecom_decode_include_option_ (spec
);
11407 /* ffecom_end_transition -- Perform end transition on all symbols
11409 ffecom_end_transition();
11411 Calls ffecom_sym_end_transition for each global and local symbol. */
11414 ffecom_end_transition ()
11416 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11420 if (ffe_is_ffedebug ())
11421 fprintf (dmpout
, "; end_stmt_transition\n");
11423 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11424 ffecom_list_blockdata_
= NULL
;
11425 ffecom_list_common_
= NULL
;
11428 ffesymbol_drive (ffecom_sym_end_transition
);
11429 if (ffe_is_ffedebug ())
11431 ffestorag_report ();
11432 ffesymbol_report_all ();
11435 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11436 ffecom_start_progunit_ ();
11438 for (item
= ffecom_list_blockdata_
;
11440 item
= ffebld_trail (item
))
11448 static int number
= 0;
11450 callee
= ffebld_head (item
);
11451 s
= ffebld_symter (callee
);
11452 t
= ffesymbol_hook (s
).decl_tree
;
11453 if (t
== NULL_TREE
)
11455 s
= ffecom_sym_transform_ (s
);
11456 t
= ffesymbol_hook (s
).decl_tree
;
11459 yes
= suspend_momentary ();
11461 dt
= build_pointer_type (TREE_TYPE (t
));
11463 var
= build_decl (VAR_DECL
,
11464 ffecom_get_invented_identifier ("__g77_forceload_%d",
11467 DECL_EXTERNAL (var
) = 0;
11468 TREE_STATIC (var
) = 1;
11469 TREE_PUBLIC (var
) = 0;
11470 DECL_INITIAL (var
) = error_mark_node
;
11471 TREE_USED (var
) = 1;
11473 var
= start_decl (var
, FALSE
);
11475 t
= ffecom_1 (ADDR_EXPR
, dt
, t
);
11477 finish_decl (var
, t
, FALSE
);
11479 resume_momentary (yes
);
11482 /* This handles any COMMON areas that weren't referenced but have, for
11483 example, important initial data. */
11485 for (item
= ffecom_list_common_
;
11487 item
= ffebld_trail (item
))
11488 ffecom_transform_common_ (ffebld_symter (ffebld_head (item
)));
11490 ffecom_list_common_
= NULL
;
11494 /* ffecom_exec_transition -- Perform exec transition on all symbols
11496 ffecom_exec_transition();
11498 Calls ffecom_sym_exec_transition for each global and local symbol.
11499 Make sure error updating not inhibited. */
11502 ffecom_exec_transition ()
11506 if (ffe_is_ffedebug ())
11507 fprintf (dmpout
, "; exec_stmt_transition\n");
11509 inhibited
= ffebad_inhibit ();
11510 ffebad_set_inhibit (FALSE
);
11512 ffesymbol_drive (ffecom_sym_exec_transition
); /* Don't retract! */
11513 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
11514 if (ffe_is_ffedebug ())
11516 ffestorag_report ();
11517 ffesymbol_report_all ();
11521 ffebad_set_inhibit (TRUE
);
11524 /* ffecom_expand_let_stmt -- Compile let (assignment) statement
11528 ffecom_expand_let_stmt(dest,source);
11530 Convert dest and source using ffecom_expr, then join them
11531 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
11533 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11535 ffecom_expand_let_stmt (ffebld dest
, ffebld source
)
11542 if (ffeinfo_basictype (ffebld_info (dest
)) != FFEINFO_basictypeCHARACTER
)
11546 dest_tree
= ffecom_expr_rw (dest
);
11547 if (dest_tree
== error_mark_node
)
11550 if ((TREE_CODE (dest_tree
) != VAR_DECL
)
11551 || TREE_ADDRESSABLE (dest_tree
))
11552 source_tree
= ffecom_expr_ (source
, dest_tree
, dest
, &dest_used
,
11556 source_tree
= ffecom_expr (source
);
11559 if (source_tree
== error_mark_node
)
11563 expr_tree
= source_tree
;
11565 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
11569 expand_expr_stmt (expr_tree
);
11573 ffecom_push_calltemps ();
11574 ffecom_char_args_ (&dest_tree
, &dest_length
, dest
);
11575 ffecom_let_char_ (dest_tree
, dest_length
, ffebld_size_known (dest
),
11577 ffecom_pop_calltemps ();
11581 /* ffecom_expr -- Transform expr into gcc tree
11584 ffebld expr; // FFE expression.
11585 tree = ffecom_expr(expr);
11587 Recursive descent on expr while making corresponding tree nodes and
11588 attaching type info and such. */
11590 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11592 ffecom_expr (ffebld expr
)
11594 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, FALSE
, FALSE
);
11598 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
11600 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11602 ffecom_expr_assign (ffebld expr
)
11604 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
11608 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
11610 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11612 ffecom_expr_assign_w (ffebld expr
)
11614 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
11618 /* Transform expr for use as into read/write tree and stabilize the
11619 reference. Not for use on CHARACTER expressions.
11621 Recursive descent on expr while making corresponding tree nodes and
11622 attaching type info and such. */
11624 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11626 ffecom_expr_rw (ffebld expr
)
11628 assert (expr
!= NULL
);
11630 return stabilize_reference (ffecom_expr (expr
));
11634 /* Do global stuff. */
11636 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11638 ffecom_finish_compile ()
11640 assert (ffecom_outer_function_decl_
== NULL_TREE
);
11641 assert (current_function_decl
== NULL_TREE
);
11643 ffeglobal_drive (ffecom_finish_global_
);
11647 /* Public entry point for front end to access finish_decl. */
11649 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11651 ffecom_finish_decl (tree decl
, tree init
, bool is_top_level
)
11653 assert (!is_top_level
);
11654 finish_decl (decl
, init
, FALSE
);
11658 /* Finish a program unit. */
11660 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11662 ffecom_finish_progunit ()
11664 ffecom_end_compstmt_ ();
11666 ffecom_previous_function_decl_
= current_function_decl
;
11667 ffecom_which_entrypoint_decl_
= NULL_TREE
;
11669 finish_function (0);
11673 /* Wrapper for get_identifier. pattern is like "...%s...", text is
11674 inserted into final name in place of "%s", or if text is NULL,
11675 pattern is like "...%d..." and text form of number is inserted
11676 in place of "%d". */
11678 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11680 ffecom_get_invented_identifier (char *pattern
, char *text
, int number
)
11688 lenlen
= strlen (pattern
) + 20;
11690 lenlen
= strlen (pattern
) + strlen (text
) - 1;
11691 if (lenlen
> ARRAY_SIZE (space
))
11692 nam
= malloc_new_ks (malloc_pool_image (), pattern
, lenlen
);
11696 sprintf (&nam
[0], pattern
, number
);
11698 sprintf (&nam
[0], pattern
, text
);
11699 decl
= get_identifier (nam
);
11700 if (lenlen
> ARRAY_SIZE (space
))
11701 malloc_kill_ks (malloc_pool_image (), nam
, lenlen
);
11703 IDENTIFIER_INVENTED (decl
) = 1;
11709 ffecom_gfrt_basictype (ffecomGfrt gfrt
)
11711 assert (gfrt
< FFECOM_gfrt
);
11713 switch (ffecom_gfrt_type_
[gfrt
])
11715 case FFECOM_rttypeVOID_
:
11716 case FFECOM_rttypeVOIDSTAR_
:
11717 return FFEINFO_basictypeNONE
;
11719 case FFECOM_rttypeFTNINT_
:
11720 return FFEINFO_basictypeINTEGER
;
11722 case FFECOM_rttypeINTEGER_
:
11723 return FFEINFO_basictypeINTEGER
;
11725 case FFECOM_rttypeLONGINT_
:
11726 return FFEINFO_basictypeINTEGER
;
11728 case FFECOM_rttypeLOGICAL_
:
11729 return FFEINFO_basictypeLOGICAL
;
11731 case FFECOM_rttypeREAL_F2C_
:
11732 case FFECOM_rttypeREAL_GNU_
:
11733 return FFEINFO_basictypeREAL
;
11735 case FFECOM_rttypeCOMPLEX_F2C_
:
11736 case FFECOM_rttypeCOMPLEX_GNU_
:
11737 return FFEINFO_basictypeCOMPLEX
;
11739 case FFECOM_rttypeDOUBLE_
:
11740 case FFECOM_rttypeDOUBLEREAL_
:
11741 return FFEINFO_basictypeREAL
;
11743 case FFECOM_rttypeDBLCMPLX_F2C_
:
11744 case FFECOM_rttypeDBLCMPLX_GNU_
:
11745 return FFEINFO_basictypeCOMPLEX
;
11747 case FFECOM_rttypeCHARACTER_
:
11748 return FFEINFO_basictypeCHARACTER
;
11751 return FFEINFO_basictypeANY
;
11756 ffecom_gfrt_kindtype (ffecomGfrt gfrt
)
11758 assert (gfrt
< FFECOM_gfrt
);
11760 switch (ffecom_gfrt_type_
[gfrt
])
11762 case FFECOM_rttypeVOID_
:
11763 case FFECOM_rttypeVOIDSTAR_
:
11764 return FFEINFO_kindtypeNONE
;
11766 case FFECOM_rttypeFTNINT_
:
11767 return FFEINFO_kindtypeINTEGER1
;
11769 case FFECOM_rttypeINTEGER_
:
11770 return FFEINFO_kindtypeINTEGER1
;
11772 case FFECOM_rttypeLONGINT_
:
11773 return FFEINFO_kindtypeINTEGER4
;
11775 case FFECOM_rttypeLOGICAL_
:
11776 return FFEINFO_kindtypeLOGICAL1
;
11778 case FFECOM_rttypeREAL_F2C_
:
11779 case FFECOM_rttypeREAL_GNU_
:
11780 return FFEINFO_kindtypeREAL1
;
11782 case FFECOM_rttypeCOMPLEX_F2C_
:
11783 case FFECOM_rttypeCOMPLEX_GNU_
:
11784 return FFEINFO_kindtypeREAL1
;
11786 case FFECOM_rttypeDOUBLE_
:
11787 case FFECOM_rttypeDOUBLEREAL_
:
11788 return FFEINFO_kindtypeREAL2
;
11790 case FFECOM_rttypeDBLCMPLX_F2C_
:
11791 case FFECOM_rttypeDBLCMPLX_GNU_
:
11792 return FFEINFO_kindtypeREAL2
;
11794 case FFECOM_rttypeCHARACTER_
:
11795 return FFEINFO_kindtypeCHARACTER1
;
11798 return FFEINFO_kindtypeANY
;
11813 /* This block of code comes from the now-obsolete cktyps.c. It checks
11814 whether the compiler environment is buggy in known ways, some of which
11815 would, if not explicitly checked here, result in subtle bugs in g77. */
11817 if (ffe_is_do_internal_checks ())
11819 static char names
[][12]
11821 {"bar", "bletch", "foo", "foobar"};
11826 name
= bsearch ("foo", &names
[0], ARRAY_SIZE (names
), sizeof (names
[0]),
11827 (int (*)()) strcmp
);
11828 if (name
!= (char *) &names
[2])
11830 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11835 ul
= strtoul ("123456789", NULL
, 10);
11836 if (ul
!= 123456789L)
11838 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11839 in proj.h" == NULL
);
11843 fl
= atof ("56.789");
11844 if ((fl
< 56.788) || (fl
> 56.79))
11846 assert ("atof not type double, fix your #include <stdio.h>"
11852 /* Set the sizetype before we do anything else. This _should_ be the
11853 first type we create. */
11855 t
= make_unsigned_type (POINTER_SIZE
);
11856 assert (t
== sizetype
);
11858 #if FFECOM_GCC_INCLUDE
11859 ffecom_initialize_char_syntax_ ();
11862 ffecom_outer_function_decl_
= NULL_TREE
;
11863 current_function_decl
= NULL_TREE
;
11864 named_labels
= NULL_TREE
;
11865 current_binding_level
= NULL_BINDING_LEVEL
;
11866 free_binding_level
= NULL_BINDING_LEVEL
;
11867 pushlevel (0); /* make the binding_level structure for
11869 global_binding_level
= current_binding_level
;
11871 /* Define `int' and `char' first so that dbx will output them first. */
11873 integer_type_node
= make_signed_type (INT_TYPE_SIZE
);
11874 pushdecl (build_decl (TYPE_DECL
, get_identifier ("int"),
11875 integer_type_node
));
11877 char_type_node
= make_unsigned_type (CHAR_TYPE_SIZE
);
11878 pushdecl (build_decl (TYPE_DECL
, get_identifier ("char"),
11881 long_integer_type_node
= make_signed_type (LONG_TYPE_SIZE
);
11882 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long int"),
11883 long_integer_type_node
));
11885 unsigned_type_node
= make_unsigned_type (INT_TYPE_SIZE
);
11886 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned int"),
11887 unsigned_type_node
));
11889 long_unsigned_type_node
= make_unsigned_type (LONG_TYPE_SIZE
);
11890 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long unsigned int"),
11891 long_unsigned_type_node
));
11893 long_long_integer_type_node
= make_signed_type (LONG_LONG_TYPE_SIZE
);
11894 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long int"),
11895 long_long_integer_type_node
));
11897 long_long_unsigned_type_node
= make_unsigned_type (LONG_LONG_TYPE_SIZE
);
11898 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long unsigned int"),
11899 long_long_unsigned_type_node
));
11901 error_mark_node
= make_node (ERROR_MARK
);
11902 TREE_TYPE (error_mark_node
) = error_mark_node
;
11904 short_integer_type_node
= make_signed_type (SHORT_TYPE_SIZE
);
11905 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short int"),
11906 short_integer_type_node
));
11908 short_unsigned_type_node
= make_unsigned_type (SHORT_TYPE_SIZE
);
11909 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short unsigned int"),
11910 short_unsigned_type_node
));
11912 /* Define both `signed char' and `unsigned char'. */
11913 signed_char_type_node
= make_signed_type (CHAR_TYPE_SIZE
);
11914 pushdecl (build_decl (TYPE_DECL
, get_identifier ("signed char"),
11915 signed_char_type_node
));
11917 unsigned_char_type_node
= make_unsigned_type (CHAR_TYPE_SIZE
);
11918 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned char"),
11919 unsigned_char_type_node
));
11921 float_type_node
= make_node (REAL_TYPE
);
11922 TYPE_PRECISION (float_type_node
) = FLOAT_TYPE_SIZE
;
11923 layout_type (float_type_node
);
11924 pushdecl (build_decl (TYPE_DECL
, get_identifier ("float"),
11927 double_type_node
= make_node (REAL_TYPE
);
11928 TYPE_PRECISION (double_type_node
) = DOUBLE_TYPE_SIZE
;
11929 layout_type (double_type_node
);
11930 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double"),
11931 double_type_node
));
11933 long_double_type_node
= make_node (REAL_TYPE
);
11934 TYPE_PRECISION (long_double_type_node
) = LONG_DOUBLE_TYPE_SIZE
;
11935 layout_type (long_double_type_node
);
11936 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long double"),
11937 long_double_type_node
));
11939 complex_integer_type_node
= ffecom_make_complex_type_ (integer_type_node
);
11940 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex int"),
11941 complex_integer_type_node
));
11943 complex_float_type_node
= ffecom_make_complex_type_ (float_type_node
);
11944 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex float"),
11945 complex_float_type_node
));
11947 complex_double_type_node
= ffecom_make_complex_type_ (double_type_node
);
11948 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex double"),
11949 complex_double_type_node
));
11951 complex_long_double_type_node
= ffecom_make_complex_type_ (long_double_type_node
);
11952 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex long double"),
11953 complex_long_double_type_node
));
11955 integer_zero_node
= build_int_2 (0, 0);
11956 TREE_TYPE (integer_zero_node
) = integer_type_node
;
11957 integer_one_node
= build_int_2 (1, 0);
11958 TREE_TYPE (integer_one_node
) = integer_type_node
;
11960 size_zero_node
= build_int_2 (0, 0);
11961 TREE_TYPE (size_zero_node
) = sizetype
;
11962 size_one_node
= build_int_2 (1, 0);
11963 TREE_TYPE (size_one_node
) = sizetype
;
11965 void_type_node
= make_node (VOID_TYPE
);
11966 pushdecl (build_decl (TYPE_DECL
, get_identifier ("void"),
11968 layout_type (void_type_node
); /* Uses integer_zero_node */
11969 /* We are not going to have real types in C with less than byte alignment,
11970 so we might as well not have any types that claim to have it. */
11971 TYPE_ALIGN (void_type_node
) = BITS_PER_UNIT
;
11973 null_pointer_node
= build_int_2 (0, 0);
11974 TREE_TYPE (null_pointer_node
) = build_pointer_type (void_type_node
);
11975 layout_type (TREE_TYPE (null_pointer_node
));
11977 string_type_node
= build_pointer_type (char_type_node
);
11979 ffecom_tree_fun_type_void
11980 = build_function_type (void_type_node
, NULL_TREE
);
11982 ffecom_tree_ptr_to_fun_type_void
11983 = build_pointer_type (ffecom_tree_fun_type_void
);
11985 endlink
= tree_cons (NULL_TREE
, void_type_node
, NULL_TREE
);
11988 = build_function_type (float_type_node
,
11989 tree_cons (NULL_TREE
, float_type_node
, endlink
));
11991 double_ftype_double
11992 = build_function_type (double_type_node
,
11993 tree_cons (NULL_TREE
, double_type_node
, endlink
));
11995 ldouble_ftype_ldouble
11996 = build_function_type (long_double_type_node
,
11997 tree_cons (NULL_TREE
, long_double_type_node
,
12000 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
12001 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
12003 ffecom_tree_type
[i
][j
] = NULL_TREE
;
12004 ffecom_tree_fun_type
[i
][j
] = NULL_TREE
;
12005 ffecom_tree_ptr_to_fun_type
[i
][j
] = NULL_TREE
;
12006 ffecom_f2c_typecode_
[i
][j
] = -1;
12009 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
12010 to size FLOAT_TYPE_SIZE because they have to be the same size as
12011 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
12012 Compiler options and other such stuff that change the ways these
12013 types are set should not affect this particular setup. */
12015 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
]
12016 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
12017 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer"),
12019 type
= ffetype_new ();
12021 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER1
,
12023 ffetype_set_ams (type
,
12024 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12025 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12026 ffetype_set_star (base_type
,
12027 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12029 ffetype_set_kind (base_type
, 1, type
);
12030 assert (ffetype_size (type
) == sizeof (ffetargetInteger1
));
12032 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER1
]
12033 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
); /* HOLLERITH means unsigned. */
12034 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned"),
12037 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER2
]
12038 = t
= make_signed_type (CHAR_TYPE_SIZE
);
12039 pushdecl (build_decl (TYPE_DECL
, get_identifier ("byte"),
12041 type
= ffetype_new ();
12042 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER2
,
12044 ffetype_set_ams (type
,
12045 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12046 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12047 ffetype_set_star (base_type
,
12048 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12050 ffetype_set_kind (base_type
, 3, type
);
12051 assert (ffetype_size (type
) == sizeof (ffetargetInteger2
));
12053 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER2
]
12054 = t
= make_unsigned_type (CHAR_TYPE_SIZE
);
12055 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned byte"),
12058 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER3
]
12059 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
12060 pushdecl (build_decl (TYPE_DECL
, get_identifier ("word"),
12062 type
= ffetype_new ();
12063 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER3
,
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
, 6, type
);
12072 assert (ffetype_size (type
) == sizeof (ffetargetInteger3
));
12074 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER3
]
12075 = t
= make_unsigned_type (CHAR_TYPE_SIZE
* 2);
12076 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned word"),
12079 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER4
]
12080 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
12081 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer4"),
12083 type
= ffetype_new ();
12084 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER4
,
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
, 2, type
);
12093 assert (ffetype_size (type
) == sizeof (ffetargetInteger4
));
12095 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER4
]
12096 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
* 2);
12097 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned4"),
12101 if (ffe_is_do_internal_checks ()
12102 && LONG_TYPE_SIZE
!= FLOAT_TYPE_SIZE
12103 && LONG_TYPE_SIZE
!= CHAR_TYPE_SIZE
12104 && LONG_TYPE_SIZE
!= SHORT_TYPE_SIZE
12105 && LONG_TYPE_SIZE
!= LONG_LONG_TYPE_SIZE
)
12107 fprintf (stderr
, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
12112 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL1
]
12113 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
12114 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical"),
12116 type
= ffetype_new ();
12118 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL1
,
12120 ffetype_set_ams (type
,
12121 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12122 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12123 ffetype_set_star (base_type
,
12124 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12126 ffetype_set_kind (base_type
, 1, type
);
12127 assert (ffetype_size (type
) == sizeof (ffetargetLogical1
));
12129 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL2
]
12130 = t
= make_signed_type (CHAR_TYPE_SIZE
);
12131 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical2"),
12133 type
= ffetype_new ();
12134 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL2
,
12136 ffetype_set_ams (type
,
12137 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12138 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12139 ffetype_set_star (base_type
,
12140 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12142 ffetype_set_kind (base_type
, 3, type
);
12143 assert (ffetype_size (type
) == sizeof (ffetargetLogical2
));
12145 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL3
]
12146 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
12147 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical3"),
12149 type
= ffetype_new ();
12150 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL3
,
12152 ffetype_set_ams (type
,
12153 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12154 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12155 ffetype_set_star (base_type
,
12156 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12158 ffetype_set_kind (base_type
, 6, type
);
12159 assert (ffetype_size (type
) == sizeof (ffetargetLogical3
));
12161 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL4
]
12162 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
12163 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical4"),
12165 type
= ffetype_new ();
12166 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL4
,
12168 ffetype_set_ams (type
,
12169 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12170 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12171 ffetype_set_star (base_type
,
12172 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12174 ffetype_set_kind (base_type
, 2, type
);
12175 assert (ffetype_size (type
) == sizeof (ffetargetLogical4
));
12177 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
12178 = t
= make_node (REAL_TYPE
);
12179 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
;
12180 pushdecl (build_decl (TYPE_DECL
, get_identifier ("real"),
12183 type
= ffetype_new ();
12185 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREAL1
,
12187 ffetype_set_ams (type
,
12188 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12189 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12190 ffetype_set_star (base_type
,
12191 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12193 ffetype_set_kind (base_type
, 1, type
);
12194 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
12195 = FFETARGET_f2cTYREAL
;
12196 assert (ffetype_size (type
) == sizeof (ffetargetReal1
));
12198 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREALDOUBLE
]
12199 = t
= make_node (REAL_TYPE
);
12200 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
* 2; /* Always twice REAL. */
12201 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double precision"),
12204 type
= ffetype_new ();
12205 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREALDOUBLE
,
12207 ffetype_set_ams (type
,
12208 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12209 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12210 ffetype_set_star (base_type
,
12211 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12213 ffetype_set_kind (base_type
, 2, type
);
12214 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]
12215 = FFETARGET_f2cTYDREAL
;
12216 assert (ffetype_size (type
) == sizeof (ffetargetReal2
));
12218 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
12219 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]);
12220 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex"),
12222 type
= ffetype_new ();
12224 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREAL1
,
12226 ffetype_set_ams (type
,
12227 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12228 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12229 ffetype_set_star (base_type
,
12230 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12232 ffetype_set_kind (base_type
, 1, type
);
12233 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
12234 = FFETARGET_f2cTYCOMPLEX
;
12235 assert (ffetype_size (type
) == sizeof (ffetargetComplex1
));
12237 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREALDOUBLE
]
12238 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]);
12239 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double complex"),
12241 type
= ffetype_new ();
12242 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREALDOUBLE
,
12244 ffetype_set_ams (type
,
12245 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12246 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12247 ffetype_set_star (base_type
,
12248 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12250 ffetype_set_kind (base_type
, 2,
12252 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL2
]
12253 = FFETARGET_f2cTYDCOMPLEX
;
12254 assert (ffetype_size (type
) == sizeof (ffetargetComplex2
));
12256 /* Make function and ptr-to-function types for non-CHARACTER types. */
12258 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
12259 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
12261 if ((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
12263 if (i
== FFEINFO_basictypeINTEGER
)
12265 /* Figure out the smallest INTEGER type that can hold
12266 a pointer on this machine. */
12267 if (GET_MODE_SIZE (TYPE_MODE (t
))
12268 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
12270 if ((ffecom_pointer_kind_
== FFEINFO_kindtypeNONE
)
12271 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type
[i
][ffecom_pointer_kind_
]))
12272 > GET_MODE_SIZE (TYPE_MODE (t
))))
12273 ffecom_pointer_kind_
= j
;
12276 else if (i
== FFEINFO_basictypeCOMPLEX
)
12277 t
= void_type_node
;
12278 /* For f2c compatibility, REAL functions are really
12279 implemented as DOUBLE PRECISION. */
12280 else if ((i
== FFEINFO_basictypeREAL
)
12281 && (j
== FFEINFO_kindtypeREAL1
))
12282 t
= ffecom_tree_type
12283 [FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
];
12285 t
= ffecom_tree_fun_type
[i
][j
] = build_function_type (t
,
12287 ffecom_tree_ptr_to_fun_type
[i
][j
] = build_pointer_type (t
);
12291 /* Set up pointer types. */
12293 if (ffecom_pointer_kind_
== FFEINFO_basictypeNONE
)
12294 fatal ("no INTEGER type can hold a pointer on this configuration");
12295 else if (0 && ffe_is_do_internal_checks ())
12296 fprintf (stderr
, "Pointer type kt=%d\n", ffecom_pointer_kind_
);
12297 type
= ffetype_new ();
12298 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER
,
12299 FFEINFO_kindtypeINTEGERDEFAULT
),
12302 if (ffe_is_ugly_assign ())
12303 ffecom_label_kind_
= ffecom_pointer_kind_
; /* Require ASSIGN etc to this. */
12305 ffecom_label_kind_
= FFEINFO_kindtypeINTEGERDEFAULT
;
12306 if (0 && ffe_is_do_internal_checks ())
12307 fprintf (stderr
, "Label type kt=%d\n", ffecom_label_kind_
);
12309 ffecom_integer_type_node
12310 = ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
];
12311 ffecom_integer_zero_node
= convert (ffecom_integer_type_node
,
12312 integer_zero_node
);
12313 ffecom_integer_one_node
= convert (ffecom_integer_type_node
,
12316 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
12317 Turns out that by TYLONG, runtime/libI77/lio.h really means
12318 "whatever size an ftnint is". For consistency and sanity,
12319 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
12320 all are INTEGER, which we also make out of whatever back-end
12321 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
12322 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
12323 accommodate machines like the Alpha. Note that this suggests
12324 f2c and libf2c are missing a distinction perhaps needed on
12325 some machines between "int" and "long int". -- burley 0.5.5 950215 */
12327 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, FLOAT_TYPE_SIZE
,
12328 FFETARGET_f2cTYLONG
);
12329 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, SHORT_TYPE_SIZE
,
12330 FFETARGET_f2cTYSHORT
);
12331 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, CHAR_TYPE_SIZE
,
12332 FFETARGET_f2cTYINT1
);
12333 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, LONG_LONG_TYPE_SIZE
,
12334 FFETARGET_f2cTYQUAD
);
12335 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, FLOAT_TYPE_SIZE
,
12336 FFETARGET_f2cTYLOGICAL
);
12337 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, SHORT_TYPE_SIZE
,
12338 FFETARGET_f2cTYLOGICAL2
);
12339 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, CHAR_TYPE_SIZE
,
12340 FFETARGET_f2cTYLOGICAL1
);
12341 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, LONG_LONG_TYPE_SIZE
,
12342 FFETARGET_f2cTYQUAD
/* ~~~ */);
12344 /* CHARACTER stuff is all special-cased, so it is not handled in the above
12345 loop. CHARACTER items are built as arrays of unsigned char. */
12347 ffecom_tree_type
[FFEINFO_basictypeCHARACTER
]
12348 [FFEINFO_kindtypeCHARACTER1
] = t
= char_type_node
;
12349 type
= ffetype_new ();
12351 ffeinfo_set_type (FFEINFO_basictypeCHARACTER
,
12352 FFEINFO_kindtypeCHARACTER1
,
12354 ffetype_set_ams (type
,
12355 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12356 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12357 ffetype_set_kind (base_type
, 1, type
);
12358 assert (ffetype_size (type
)
12359 == sizeof (((ffetargetCharacter1
) { 0, NULL
}).text
[0]));
12361 ffecom_tree_fun_type
[FFEINFO_basictypeCHARACTER
]
12362 [FFEINFO_kindtypeCHARACTER1
] = ffecom_tree_fun_type_void
;
12363 ffecom_tree_ptr_to_fun_type
[FFEINFO_basictypeCHARACTER
]
12364 [FFEINFO_kindtypeCHARACTER1
]
12365 = ffecom_tree_ptr_to_fun_type_void
;
12366 ffecom_f2c_typecode_
[FFEINFO_basictypeCHARACTER
][FFEINFO_kindtypeCHARACTER1
]
12367 = FFETARGET_f2cTYCHAR
;
12369 ffecom_f2c_typecode_
[FFEINFO_basictypeANY
][FFEINFO_kindtypeANY
]
12372 /* Make multi-return-value type and fields. */
12374 ffecom_multi_type_node_
= make_node (UNION_TYPE
);
12378 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
12379 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
12383 if (ffecom_tree_type
[i
][j
] == NULL_TREE
)
12384 continue; /* Not supported. */
12385 sprintf (&name
[0], "bt_%s_kt_%s",
12386 ffeinfo_basictype_string ((ffeinfoBasictype
) i
),
12387 ffeinfo_kindtype_string ((ffeinfoKindtype
) j
));
12388 ffecom_multi_fields_
[i
][j
] = build_decl (FIELD_DECL
,
12389 get_identifier (name
),
12390 ffecom_tree_type
[i
][j
]);
12391 DECL_CONTEXT (ffecom_multi_fields_
[i
][j
])
12392 = ffecom_multi_type_node_
;
12393 DECL_FRAME_SIZE (ffecom_multi_fields_
[i
][j
]) = 0;
12394 TREE_CHAIN (ffecom_multi_fields_
[i
][j
]) = field
;
12395 field
= ffecom_multi_fields_
[i
][j
];
12398 TYPE_FIELDS (ffecom_multi_type_node_
) = field
;
12399 layout_type (ffecom_multi_type_node_
);
12401 /* Subroutines usually return integer because they might have alternate
12404 ffecom_tree_subr_type
12405 = build_function_type (integer_type_node
, NULL_TREE
);
12406 ffecom_tree_ptr_to_subr_type
12407 = build_pointer_type (ffecom_tree_subr_type
);
12408 ffecom_tree_blockdata_type
12409 = build_function_type (void_type_node
, NULL_TREE
);
12411 builtin_function ("__builtin_sqrtf", float_ftype_float
,
12412 BUILT_IN_FSQRT
, "sqrtf");
12413 builtin_function ("__builtin_fsqrt", double_ftype_double
,
12414 BUILT_IN_FSQRT
, "sqrt");
12415 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble
,
12416 BUILT_IN_FSQRT
, "sqrtl");
12417 builtin_function ("__builtin_sinf", float_ftype_float
,
12418 BUILT_IN_SIN
, "sinf");
12419 builtin_function ("__builtin_sin", double_ftype_double
,
12420 BUILT_IN_SIN
, "sin");
12421 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble
,
12422 BUILT_IN_SIN
, "sinl");
12423 builtin_function ("__builtin_cosf", float_ftype_float
,
12424 BUILT_IN_COS
, "cosf");
12425 builtin_function ("__builtin_cos", double_ftype_double
,
12426 BUILT_IN_COS
, "cos");
12427 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble
,
12428 BUILT_IN_COS
, "cosl");
12431 pedantic_lvalues
= FALSE
;
12434 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node
,
12437 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node
,
12440 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node
,
12443 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node
,
12444 FFECOM_f2cDOUBLEREAL
,
12446 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node
,
12449 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node
,
12450 FFECOM_f2cDOUBLECOMPLEX
,
12452 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node
,
12455 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node
,
12458 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node
,
12461 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node
,
12464 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node
,
12468 ffecom_f2c_ftnlen_zero_node
12469 = convert (ffecom_f2c_ftnlen_type_node
, integer_zero_node
);
12471 ffecom_f2c_ftnlen_one_node
12472 = convert (ffecom_f2c_ftnlen_type_node
, integer_one_node
);
12474 ffecom_f2c_ftnlen_two_node
= build_int_2 (2, 0);
12475 TREE_TYPE (ffecom_f2c_ftnlen_two_node
) = ffecom_integer_type_node
;
12477 ffecom_f2c_ptr_to_ftnlen_type_node
12478 = build_pointer_type (ffecom_f2c_ftnlen_type_node
);
12480 ffecom_f2c_ptr_to_ftnint_type_node
12481 = build_pointer_type (ffecom_f2c_ftnint_type_node
);
12483 ffecom_f2c_ptr_to_integer_type_node
12484 = build_pointer_type (ffecom_f2c_integer_type_node
);
12486 ffecom_f2c_ptr_to_real_type_node
12487 = build_pointer_type (ffecom_f2c_real_type_node
);
12489 ffecom_float_zero_
= build_real (float_type_node
, dconst0
);
12490 ffecom_double_zero_
= build_real (double_type_node
, dconst0
);
12492 REAL_VALUE_TYPE point_5
;
12494 #ifdef REAL_ARITHMETIC
12495 REAL_ARITHMETIC (point_5
, RDIV_EXPR
, dconst1
, dconst2
);
12499 ffecom_float_half_
= build_real (float_type_node
, point_5
);
12500 ffecom_double_half_
= build_real (double_type_node
, point_5
);
12503 /* Do "extern int xargc;". */
12505 ffecom_tree_xargc_
= build_decl (VAR_DECL
,
12506 get_identifier ("xargc"),
12507 integer_type_node
);
12508 DECL_EXTERNAL (ffecom_tree_xargc_
) = 1;
12509 TREE_STATIC (ffecom_tree_xargc_
) = 1;
12510 TREE_PUBLIC (ffecom_tree_xargc_
) = 1;
12511 ffecom_tree_xargc_
= start_decl (ffecom_tree_xargc_
, FALSE
);
12512 finish_decl (ffecom_tree_xargc_
, NULL_TREE
, FALSE
);
12514 #if 0 /* This is being fixed, and seems to be working now. */
12515 if ((FLOAT_TYPE_SIZE
!= 32)
12516 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))) != 32))
12518 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12519 (int) FLOAT_TYPE_SIZE
);
12520 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12521 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))));
12522 warning ("properly unless they all are 32 bits wide.");
12523 warning ("Please keep this in mind before you report bugs. g77 should");
12524 warning ("support non-32-bit machines better as of version 0.6.");
12528 #if 0 /* Code in ste.c that would crash has been commented out. */
12529 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
12530 < TYPE_PRECISION (string_type_node
))
12531 /* I/O will probably crash. */
12532 warning ("configuration: char * holds %d bits, but ftnlen only %d",
12533 TYPE_PRECISION (string_type_node
),
12534 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
));
12537 #if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
12538 if (TYPE_PRECISION (ffecom_integer_type_node
)
12539 < TYPE_PRECISION (string_type_node
))
12540 /* ASSIGN 10 TO I will crash. */
12541 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12542 ASSIGN statement might fail",
12543 TYPE_PRECISION (string_type_node
),
12544 TYPE_PRECISION (ffecom_integer_type_node
));
12549 /* ffecom_init_2 -- Initialize
12551 ffecom_init_2(); */
12553 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12557 assert (ffecom_outer_function_decl_
== NULL_TREE
);
12558 assert (current_function_decl
== NULL_TREE
);
12559 assert (ffecom_which_entrypoint_decl_
== NULL_TREE
);
12561 ffecom_master_arglist_
= NULL
;
12563 ffecom_latest_temp_
= NULL
;
12564 ffecom_primary_entry_
= NULL
;
12565 ffecom_is_altreturning_
= FALSE
;
12566 ffecom_func_result_
= NULL_TREE
;
12567 ffecom_multi_retval_
= NULL_TREE
;
12571 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12574 ffebld expr; // FFE opITEM list.
12575 tree = ffecom_list_expr(expr);
12577 List of actual args is transformed into corresponding gcc backend list. */
12579 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12581 ffecom_list_expr (ffebld expr
)
12584 tree
*plist
= &list
;
12585 tree trail
= NULL_TREE
; /* Append char length args here. */
12586 tree
*ptrail
= &trail
;
12589 while (expr
!= NULL
)
12592 = build_tree_list (NULL_TREE
, ffecom_arg_expr (ffebld_head (expr
),
12594 plist
= &TREE_CHAIN (*plist
);
12595 expr
= ffebld_trail (expr
);
12596 if (length
!= NULL_TREE
)
12598 *ptrail
= build_tree_list (NULL_TREE
, length
);
12599 ptrail
= &TREE_CHAIN (*ptrail
);
12609 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12612 ffebld expr; // FFE opITEM list.
12613 tree = ffecom_list_ptr_to_expr(expr);
12615 List of actual args is transformed into corresponding gcc backend list for
12616 use in calling an external procedure (vs. a statement function). */
12618 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12620 ffecom_list_ptr_to_expr (ffebld expr
)
12623 tree
*plist
= &list
;
12624 tree trail
= NULL_TREE
; /* Append char length args here. */
12625 tree
*ptrail
= &trail
;
12628 while (expr
!= NULL
)
12631 = build_tree_list (NULL_TREE
,
12632 ffecom_arg_ptr_to_expr (ffebld_head (expr
),
12634 plist
= &TREE_CHAIN (*plist
);
12635 expr
= ffebld_trail (expr
);
12636 if (length
!= NULL_TREE
)
12638 *ptrail
= build_tree_list (NULL_TREE
, length
);
12639 ptrail
= &TREE_CHAIN (*ptrail
);
12649 /* Obtain gcc's LABEL_DECL tree for label. */
12651 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12653 ffecom_lookup_label (ffelab label
)
12657 if (ffelab_hook (label
) == NULL_TREE
)
12659 char labelname
[16];
12661 switch (ffelab_type (label
))
12663 case FFELAB_typeLOOPEND
:
12664 case FFELAB_typeNOTLOOP
:
12665 case FFELAB_typeENDIF
:
12666 sprintf (labelname
, "%" ffelabValue_f
"u", ffelab_value (label
));
12667 glabel
= build_decl (LABEL_DECL
, get_identifier (labelname
),
12669 DECL_CONTEXT (glabel
) = current_function_decl
;
12670 DECL_MODE (glabel
) = VOIDmode
;
12673 case FFELAB_typeFORMAT
:
12674 push_obstacks_nochange ();
12675 end_temporary_allocation ();
12677 glabel
= build_decl (VAR_DECL
,
12678 ffecom_get_invented_identifier
12679 ("__g77_format_%d", NULL
,
12680 (int) ffelab_value (label
)),
12681 build_type_variant (build_array_type
12685 TREE_CONSTANT (glabel
) = 1;
12686 TREE_STATIC (glabel
) = 1;
12687 DECL_CONTEXT (glabel
) = 0;
12688 DECL_INITIAL (glabel
) = NULL
;
12689 make_decl_rtl (glabel
, NULL
, 0);
12690 expand_decl (glabel
);
12692 resume_temporary_allocation ();
12697 case FFELAB_typeANY
:
12698 glabel
= error_mark_node
;
12702 assert ("bad label type" == NULL
);
12706 ffelab_set_hook (label
, glabel
);
12710 glabel
= ffelab_hook (label
);
12717 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12718 a single source specification (as in the fourth argument of MVBITS).
12719 If the type is NULL_TREE, the type of lhs is used to make the type of
12720 the MODIFY_EXPR. */
12722 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12724 ffecom_modify (tree newtype
, tree lhs
,
12727 if (lhs
== error_mark_node
|| rhs
== error_mark_node
)
12728 return error_mark_node
;
12730 if (newtype
== NULL_TREE
)
12731 newtype
= TREE_TYPE (lhs
);
12733 if (TREE_SIDE_EFFECTS (lhs
))
12734 lhs
= stabilize_reference (lhs
);
12736 return ffecom_2s (MODIFY_EXPR
, newtype
, lhs
, rhs
);
12741 /* Register source file name. */
12744 ffecom_file (char *name
)
12746 #if FFECOM_GCC_INCLUDE
12747 ffecom_file_ (name
);
12751 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12754 ffecom_notify_init_storage(st);
12756 Gets called when all possible units in an aggregate storage area (a LOCAL
12757 with equivalences or a COMMON) have been initialized. The initialization
12758 info either is in ffestorag_init or, if that is NULL,
12759 ffestorag_accretion:
12761 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12762 even for an array if the array is one element in length!
12764 ffestorag_accretion will contain an opACCTER. It is much like an
12765 opARRTER except it has an ffebit object in it instead of just a size.
12766 The back end can use the info in the ffebit object, if it wants, to
12767 reduce the amount of actual initialization, but in any case it should
12768 kill the ffebit object when done. Also, set accretion to NULL but
12769 init to a non-NULL value.
12771 After performing initialization, DO NOT set init to NULL, because that'll
12772 tell the front end it is ok for more initialization to happen. Instead,
12773 set init to an opANY expression or some such thing that you can use to
12774 tell that you've already initialized the object.
12777 Support two-pass FFE. */
12780 ffecom_notify_init_storage (ffestorag st
)
12782 ffebld init
; /* The initialization expression. */
12783 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12784 ffetargetOffset size
; /* The size of the entity. */
12787 if (ffestorag_init (st
) == NULL
)
12789 init
= ffestorag_accretion (st
);
12790 assert (init
!= NULL
);
12791 ffestorag_set_accretion (st
, NULL
);
12792 ffestorag_set_accretes (st
, 0);
12794 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12795 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12796 size
= ffebld_accter_size (init
);
12797 ffebit_kill (ffebld_accter_bits (init
));
12798 ffebld_set_op (init
, FFEBLD_opARRTER
);
12799 ffebld_set_arrter (init
, ffebld_accter (init
));
12800 ffebld_arrter_set_size (init
, size
);
12804 ffestorag_set_init (st
, init
);
12809 init
= ffestorag_init (st
);
12812 #if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
12813 ffestorag_set_init (st
, ffebld_new_any ());
12815 if (ffebld_op (init
) == FFEBLD_opANY
)
12816 return; /* Oh, we already did this! */
12818 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12822 if (ffestorag_symbol (st
) != NULL
)
12823 s
= ffestorag_symbol (st
);
12825 s
= ffestorag_typesymbol (st
);
12827 fprintf (dmpout
, "= initialize_storage \"%s\" ",
12828 (s
!= NULL
) ? ffesymbol_text (s
) : "(unnamed)");
12829 ffebld_dump (init
);
12830 fputc ('\n', dmpout
);
12834 #endif /* if FFECOM_ONEPASS */
12837 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12840 ffecom_notify_init_symbol(s);
12842 Gets called when all possible units in a symbol (not placed in COMMON
12843 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12844 have been initialized. The initialization info either is in
12845 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12847 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12848 even for an array if the array is one element in length!
12850 ffesymbol_accretion will contain an opACCTER. It is much like an
12851 opARRTER except it has an ffebit object in it instead of just a size.
12852 The back end can use the info in the ffebit object, if it wants, to
12853 reduce the amount of actual initialization, but in any case it should
12854 kill the ffebit object when done. Also, set accretion to NULL but
12855 init to a non-NULL value.
12857 After performing initialization, DO NOT set init to NULL, because that'll
12858 tell the front end it is ok for more initialization to happen. Instead,
12859 set init to an opANY expression or some such thing that you can use to
12860 tell that you've already initialized the object.
12863 Support two-pass FFE. */
12866 ffecom_notify_init_symbol (ffesymbol s
)
12868 ffebld init
; /* The initialization expression. */
12869 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12870 ffetargetOffset size
; /* The size of the entity. */
12873 if (ffesymbol_storage (s
) == NULL
)
12874 return; /* Do nothing until COMMON/EQUIVALENCE
12875 possibilities checked. */
12877 if ((ffesymbol_init (s
) == NULL
)
12878 && ((init
= ffesymbol_accretion (s
)) != NULL
))
12880 ffesymbol_set_accretion (s
, NULL
);
12881 ffesymbol_set_accretes (s
, 0);
12883 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12884 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12885 size
= ffebld_accter_size (init
);
12886 ffebit_kill (ffebld_accter_bits (init
));
12887 ffebld_set_op (init
, FFEBLD_opARRTER
);
12888 ffebld_set_arrter (init
, ffebld_accter (init
));
12889 ffebld_arrter_set_size (init
, size
);
12893 ffesymbol_set_init (s
, init
);
12898 init
= ffesymbol_init (s
);
12902 ffesymbol_set_init (s
, ffebld_new_any ());
12904 if (ffebld_op (init
) == FFEBLD_opANY
)
12905 return; /* Oh, we already did this! */
12907 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12908 fprintf (dmpout
, "= initialize_symbol \"%s\" ", ffesymbol_text (s
));
12909 ffebld_dump (init
);
12910 fputc ('\n', dmpout
);
12913 #endif /* if FFECOM_ONEPASS */
12916 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12919 ffecom_notify_primary_entry(s);
12921 Gets called when implicit or explicit PROGRAM statement seen or when
12922 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12923 global symbol that serves as the entry point. */
12926 ffecom_notify_primary_entry (ffesymbol s
)
12928 ffecom_primary_entry_
= s
;
12929 ffecom_primary_entry_kind_
= ffesymbol_kind (s
);
12931 if ((ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
12932 || (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
))
12933 ffecom_primary_entry_is_proc_
= TRUE
;
12935 ffecom_primary_entry_is_proc_
= FALSE
;
12937 if (!ffe_is_silent ())
12939 if (ffecom_primary_entry_kind_
== FFEINFO_kindPROGRAM
)
12940 fprintf (stderr
, "%s:\n", ffesymbol_text (s
));
12942 fprintf (stderr
, " %s:\n", ffesymbol_text (s
));
12945 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12946 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
12951 for (list
= ffesymbol_dummyargs (s
);
12953 list
= ffebld_trail (list
))
12955 arg
= ffebld_head (list
);
12956 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
12958 ffecom_is_altreturning_
= TRUE
;
12967 ffecom_open_include (char *name
, ffewhereLine l
, ffewhereColumn c
)
12969 #if FFECOM_GCC_INCLUDE
12970 return ffecom_open_include_ (name
, l
, c
);
12972 return fopen (name
, "r");
12976 /* Clean up after making automatically popped call-arg temps.
12978 Call this in pairs with push_calltemps around calls to
12979 ffecom_arg_ptr_to_expr if the latter might use temporaries.
12980 Any temporaries made within the outermost sequence of
12981 push_calltemps and pop_calltemps, that are marked as "auto-pop"
12982 meaning they won't be explicitly popped (freed), are popped
12983 at this point so they can be reused later.
12985 NOTE: when called by ffecom_gen_sfuncdef_, ffecom_pending_calls_
12986 should come in == 1, and all of the in-use auto-pop temps
12987 should have DECL_CONTEXT (temp->t) == current_function_decl.
12988 Moreover, these temps should _never_ be re-used in future
12989 calls to ffecom_push_tempvar -- since current_function_decl will
12990 never be the same again.
12992 SO, it could be a minor win in terms of compile time to just
12993 strip these temps off the list. That is, if the above assumptions
12994 are correct, just remove from the list of temps any temp
12995 that is both in-use and has DECL_CONTEXT (temp->t)
12996 == current_function_decl, when called from ffecom_gen_sfuncdef_. */
12998 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13000 ffecom_pop_calltemps ()
13004 assert (ffecom_pending_calls_
> 0);
13006 if (--ffecom_pending_calls_
== 0)
13007 for (temp
= ffecom_latest_temp_
; temp
!= NULL
; temp
= temp
->next
)
13008 if (temp
->auto_pop
)
13009 temp
->in_use
= FALSE
;
13013 /* Mark latest temp with given tree as no longer in use. */
13015 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13017 ffecom_pop_tempvar (tree t
)
13021 for (temp
= ffecom_latest_temp_
; temp
!= NULL
; temp
= temp
->next
)
13022 if (temp
->in_use
&& (temp
->t
== t
))
13024 assert (!temp
->auto_pop
);
13025 temp
->in_use
= FALSE
;
13029 assert (temp
->t
!= t
);
13031 assert ("couldn't ffecom_pop_tempvar!" != NULL
);
13035 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
13038 ffebld expr; // FFE expression.
13039 tree = ffecom_ptr_to_expr(expr);
13041 Like ffecom_expr, but sticks address-of in front of most things. */
13043 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13045 ffecom_ptr_to_expr (ffebld expr
)
13048 ffeinfoBasictype bt
;
13049 ffeinfoKindtype kt
;
13052 assert (expr
!= NULL
);
13054 switch (ffebld_op (expr
))
13056 case FFEBLD_opSYMTER
:
13057 s
= ffebld_symter (expr
);
13058 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
13062 ix
= ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr
));
13063 assert (ix
!= FFECOM_gfrt
);
13064 if ((item
= ffecom_gfrt_
[ix
]) == NULL_TREE
)
13066 ffecom_make_gfrt_ (ix
);
13067 item
= ffecom_gfrt_
[ix
];
13072 item
= ffesymbol_hook (s
).decl_tree
;
13073 if (item
== NULL_TREE
)
13075 s
= ffecom_sym_transform_ (s
);
13076 item
= ffesymbol_hook (s
).decl_tree
;
13079 assert (item
!= NULL
);
13080 if (item
== error_mark_node
)
13082 if (!ffesymbol_hook (s
).addr
)
13083 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
13087 case FFEBLD_opARRAYREF
:
13089 ffebld dims
[FFECOM_dimensionsMAX
];
13093 item
= ffecom_ptr_to_expr (ffebld_left (expr
));
13095 if (item
== error_mark_node
)
13098 if ((ffeinfo_where (ffebld_info (expr
)) == FFEINFO_whereFLEETING
)
13099 && !mark_addressable (item
))
13100 return error_mark_node
; /* Make sure non-const ref is to
13103 /* Build up ARRAY_REFs in reverse order (since we're column major
13104 here in Fortran land). */
13106 for (i
= 0, expr
= ffebld_right (expr
);
13108 expr
= ffebld_trail (expr
))
13109 dims
[i
++] = ffebld_head (expr
);
13111 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
13113 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
13115 /* The initial subtraction should happen in the original type so
13116 that (possible) negative values are handled appropriately. */
13118 = ffecom_2 (PLUS_EXPR
,
13119 build_pointer_type (TREE_TYPE (array
)),
13121 size_binop (MULT_EXPR
,
13122 size_in_bytes (TREE_TYPE (array
)),
13124 fold (build (MINUS_EXPR
,
13125 TREE_TYPE (TYPE_MIN_VALUE (TYPE_DOMAIN (array
))),
13126 ffecom_expr (dims
[i
]),
13127 TYPE_MIN_VALUE (TYPE_DOMAIN (array
)))))));
13132 case FFEBLD_opCONTER
:
13134 bt
= ffeinfo_basictype (ffebld_info (expr
));
13135 kt
= ffeinfo_kindtype (ffebld_info (expr
));
13137 item
= ffecom_constantunion (&ffebld_constant_union
13138 (ffebld_conter (expr
)), bt
, kt
,
13139 ffecom_tree_type
[bt
][kt
]);
13140 if (item
== error_mark_node
)
13141 return error_mark_node
;
13142 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
13147 return error_mark_node
;
13150 assert (ffecom_pending_calls_
> 0);
13152 bt
= ffeinfo_basictype (ffebld_info (expr
));
13153 kt
= ffeinfo_kindtype (ffebld_info (expr
));
13155 item
= ffecom_expr (expr
);
13156 if (item
== error_mark_node
)
13157 return error_mark_node
;
13159 /* The back end currently optimizes a bit too zealously for us, in that
13160 we fail JCB001 if the following block of code is omitted. It checks
13161 to see if the transformed expression is a symbol or array reference,
13162 and encloses it in a SAVE_EXPR if that is the case. */
13165 if ((TREE_CODE (item
) == VAR_DECL
)
13166 || (TREE_CODE (item
) == PARM_DECL
)
13167 || (TREE_CODE (item
) == RESULT_DECL
)
13168 || (TREE_CODE (item
) == INDIRECT_REF
)
13169 || (TREE_CODE (item
) == ARRAY_REF
)
13170 || (TREE_CODE (item
) == COMPONENT_REF
)
13172 || (TREE_CODE (item
) == OFFSET_REF
)
13174 || (TREE_CODE (item
) == BUFFER_REF
)
13175 || (TREE_CODE (item
) == REALPART_EXPR
)
13176 || (TREE_CODE (item
) == IMAGPART_EXPR
))
13178 item
= ffecom_save_tree (item
);
13181 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
13186 assert ("fall-through error" == NULL
);
13187 return error_mark_node
;
13191 /* Prepare to make call-arg temps.
13193 Call this in pairs with pop_calltemps around calls to
13194 ffecom_arg_ptr_to_expr if the latter might use temporaries. */
13196 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13198 ffecom_push_calltemps ()
13200 ffecom_pending_calls_
++;
13204 /* Obtain a temp var with given data type.
13206 Returns a VAR_DECL tree of a currently (that is, at the current
13207 statement being compiled) not in use and having the given data type,
13208 making a new one if necessary. size is FFETARGET_charactersizeNONE
13209 for a non-CHARACTER type or >= 0 for a CHARACTER type. elements is
13210 -1 for a scalar or > 0 for an array of type. auto_pop is TRUE if
13211 ffecom_pop_tempvar won't be called, meaning temp will be freed
13212 when #pending calls goes to zero. */
13214 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13216 ffecom_push_tempvar (tree type
, ffetargetCharacterSize size
, int elements
,
13222 static int mynumber
;
13224 assert (!auto_pop
|| (ffecom_pending_calls_
> 0));
13226 if (type
== error_mark_node
)
13227 return error_mark_node
;
13229 for (temp
= ffecom_latest_temp_
; temp
!= NULL
; temp
= temp
->next
)
13232 || (temp
->type
!= type
)
13233 || (temp
->size
!= size
)
13234 || (temp
->elements
!= elements
)
13235 || (DECL_CONTEXT (temp
->t
) != current_function_decl
))
13238 temp
->in_use
= TRUE
;
13239 temp
->auto_pop
= auto_pop
;
13243 /* Create a new temp. */
13245 yes
= suspend_momentary ();
13247 if (size
!= FFETARGET_charactersizeNONE
)
13248 type
= build_array_type (type
,
13249 build_range_type (ffecom_f2c_ftnlen_type_node
,
13250 ffecom_f2c_ftnlen_one_node
,
13251 build_int_2 (size
, 0)));
13252 if (elements
!= -1)
13253 type
= build_array_type (type
,
13254 build_range_type (integer_type_node
,
13256 build_int_2 (elements
- 1,
13258 t
= build_decl (VAR_DECL
,
13259 ffecom_get_invented_identifier ("__g77_expr_%d", NULL
,
13262 { /* ~~~~ kludge alert here!!! else temp gets reused outside
13263 a compound-statement sequence.... */
13264 extern tree sequence_rtl_expr
;
13265 tree back_end_bug
= sequence_rtl_expr
;
13267 sequence_rtl_expr
= NULL_TREE
;
13269 t
= start_decl (t
, FALSE
);
13270 finish_decl (t
, NULL_TREE
, FALSE
);
13272 sequence_rtl_expr
= back_end_bug
;
13275 resume_momentary (yes
);
13277 temp
= malloc_new_kp (ffe_pool_program_unit (), "ffecomTemp_",
13280 temp
->next
= ffecom_latest_temp_
;
13284 temp
->elements
= elements
;
13285 temp
->in_use
= TRUE
;
13286 temp
->auto_pop
= auto_pop
;
13288 ffecom_latest_temp_
= temp
;
13294 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13296 tree rtn; // NULL_TREE means use expand_null_return()
13297 ffebld expr; // NULL if no alt return expr to RETURN stmt
13298 rtn = ffecom_return_expr(expr);
13300 Based on the program unit type and other info (like return function
13301 type, return master function type when alternate ENTRY points,
13302 whether subroutine has any alternate RETURN points, etc), returns the
13303 appropriate expression to be returned to the caller, or NULL_TREE
13304 meaning no return value or the caller expects it to be returned somewhere
13305 else (which is handled by other parts of this module). */
13307 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13309 ffecom_return_expr (ffebld expr
)
13313 switch (ffecom_primary_entry_kind_
)
13315 case FFEINFO_kindPROGRAM
:
13316 case FFEINFO_kindBLOCKDATA
:
13320 case FFEINFO_kindSUBROUTINE
:
13321 if (!ffecom_is_altreturning_
)
13322 rtn
= NULL_TREE
; /* No alt returns, never an expr. */
13323 else if (expr
== NULL
)
13324 rtn
= integer_zero_node
;
13326 rtn
= ffecom_expr (expr
);
13329 case FFEINFO_kindFUNCTION
:
13330 if ((ffecom_multi_retval_
!= NULL_TREE
)
13331 || (ffesymbol_basictype (ffecom_primary_entry_
)
13332 == FFEINFO_basictypeCHARACTER
)
13333 || ((ffesymbol_basictype (ffecom_primary_entry_
)
13334 == FFEINFO_basictypeCOMPLEX
)
13335 && (ffecom_num_entrypoints_
== 0)
13336 && ffesymbol_is_f2c (ffecom_primary_entry_
)))
13337 { /* Value is returned by direct assignment
13338 into (implicit) dummy. */
13342 rtn
= ffecom_func_result_
;
13344 /* Spurious error if RETURN happens before first reference! So elide
13345 this code. In particular, for debugging registry, rtn should always
13346 be non-null after all, but TREE_USED won't be set until we encounter
13347 a reference in the code. Perfectly okay (but weird) code that,
13348 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13349 this diagnostic for no reason. Have people use -O -Wuninitialized
13350 and leave it to the back end to find obviously weird cases. */
13352 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13353 situation; if the return value has never been referenced, it won't
13354 have a tree under 2pass mode. */
13355 if ((rtn
== NULL_TREE
)
13356 || !TREE_USED (rtn
))
13358 ffebad_start (FFEBAD_RETURN_VALUE_UNSET
);
13359 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_
),
13360 ffesymbol_where_column (ffecom_primary_entry_
));
13361 ffebad_string (ffesymbol_text (ffesymbol_funcresult
13362 (ffecom_primary_entry_
)));
13369 assert ("bad unit kind" == NULL
);
13370 case FFEINFO_kindANY
:
13371 rtn
= error_mark_node
;
13379 /* Do save_expr only if tree is not error_mark_node. */
13381 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13383 ffecom_save_tree (tree t
)
13385 return save_expr (t
);
13389 /* Public entry point for front end to access start_decl. */
13391 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13393 ffecom_start_decl (tree decl
, bool is_initialized
)
13395 DECL_INITIAL (decl
) = is_initialized
? error_mark_node
: NULL_TREE
;
13396 return start_decl (decl
, FALSE
);
13400 /* ffecom_sym_commit -- Symbol's state being committed to reality
13403 ffecom_sym_commit(s);
13405 Does whatever the backend needs when a symbol is committed after having
13406 been backtrackable for a period of time. */
13408 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13410 ffecom_sym_commit (ffesymbol s UNUSED
)
13412 assert (!ffesymbol_retractable ());
13416 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13418 ffecom_sym_end_transition();
13420 Does backend-specific stuff and also calls ffest_sym_end_transition
13421 to do the necessary FFE stuff.
13423 Backtracking is never enabled when this fn is called, so don't worry
13427 ffecom_sym_end_transition (ffesymbol s
)
13431 assert (!ffesymbol_retractable ());
13433 s
= ffest_sym_end_transition (s
);
13435 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13436 if ((ffesymbol_kind (s
) == FFEINFO_kindBLOCKDATA
)
13437 && (ffesymbol_where (s
) == FFEINFO_whereGLOBAL
))
13439 ffecom_list_blockdata_
13440 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
13441 FFEINTRIN_specNONE
,
13442 FFEINTRIN_impNONE
),
13443 ffecom_list_blockdata_
);
13447 /* This is where we finally notice that a symbol has partial initialization
13448 and finalize it. */
13450 if (ffesymbol_accretion (s
) != NULL
)
13452 assert (ffesymbol_init (s
) == NULL
);
13453 ffecom_notify_init_symbol (s
);
13455 else if (((st
= ffesymbol_storage (s
)) != NULL
)
13456 && ((st
= ffestorag_parent (st
)) != NULL
)
13457 && (ffestorag_accretion (st
) != NULL
))
13459 assert (ffestorag_init (st
) == NULL
);
13460 ffecom_notify_init_storage (st
);
13463 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13464 if ((ffesymbol_kind (s
) == FFEINFO_kindCOMMON
)
13465 && (ffesymbol_where (s
) == FFEINFO_whereLOCAL
)
13466 && (ffesymbol_storage (s
) != NULL
))
13468 ffecom_list_common_
13469 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
13470 FFEINTRIN_specNONE
,
13471 FFEINTRIN_impNONE
),
13472 ffecom_list_common_
);
13479 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13481 ffecom_sym_exec_transition();
13483 Does backend-specific stuff and also calls ffest_sym_exec_transition
13484 to do the necessary FFE stuff.
13486 See the long-winded description in ffecom_sym_learned for info
13487 on handling the situation where backtracking is inhibited. */
13490 ffecom_sym_exec_transition (ffesymbol s
)
13492 s
= ffest_sym_exec_transition (s
);
13497 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13500 s = ffecom_sym_learned(s);
13502 Called when a new symbol is seen after the exec transition or when more
13503 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
13504 it arrives here is that all its latest info is updated already, so its
13505 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13506 field filled in if its gone through here or exec_transition first, and
13509 The backend probably wants to check ffesymbol_retractable() to see if
13510 backtracking is in effect. If so, the FFE's changes to the symbol may
13511 be retracted (undone) or committed (ratified), at which time the
13512 appropriate ffecom_sym_retract or _commit function will be called
13515 If the backend has its own backtracking mechanism, great, use it so that
13516 committal is a simple operation. Though it doesn't make much difference,
13517 I suppose: the reason for tentative symbol evolution in the FFE is to
13518 enable error detection in weird incorrect statements early and to disable
13519 incorrect error detection on a correct statement. The backend is not
13520 likely to introduce any information that'll get involved in these
13521 considerations, so it is probably just fine that the implementation
13522 model for this fn and for _exec_transition is to not do anything
13523 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13524 and instead wait until ffecom_sym_commit is called (which it never
13525 will be as long as we're using ambiguity-detecting statement analysis in
13526 the FFE, which we are initially to shake out the code, but don't depend
13527 on this), otherwise go ahead and do whatever is needed.
13529 In essence, then, when this fn and _exec_transition get called while
13530 backtracking is enabled, a general mechanism would be to flag which (or
13531 both) of these were called (and in what order? neat question as to what
13532 might happen that I'm too lame to think through right now) and then when
13533 _commit is called reproduce the original calling sequence, if any, for
13534 the two fns (at which point backtracking will, of course, be disabled). */
13537 ffecom_sym_learned (ffesymbol s
)
13539 ffestorag_exec_layout (s
);
13544 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13547 ffecom_sym_retract(s);
13549 Does whatever the backend needs when a symbol is retracted after having
13550 been backtrackable for a period of time. */
13552 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13554 ffecom_sym_retract (ffesymbol s UNUSED
)
13556 assert (!ffesymbol_retractable ());
13558 #if 0 /* GCC doesn't commit any backtrackable sins,
13559 so nothing needed here. */
13560 switch (ffesymbol_hook (s
).state
)
13562 case 0: /* nothing happened yet. */
13565 case 1: /* exec transition happened. */
13568 case 2: /* learned happened. */
13571 case 3: /* learned then exec. */
13574 case 4: /* exec then learned. */
13578 assert ("bad hook state" == NULL
);
13585 /* Create temporary gcc label. */
13587 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13589 ffecom_temp_label ()
13592 static int mynumber
= 0;
13594 glabel
= build_decl (LABEL_DECL
,
13595 ffecom_get_invented_identifier ("__g77_label_%d",
13599 DECL_CONTEXT (glabel
) = current_function_decl
;
13600 DECL_MODE (glabel
) = VOIDmode
;
13606 /* Return an expression that is usable as an arg in a conditional context
13607 (IF, DO WHILE, .NOT., and so on).
13609 Use the one provided for the back end as of >2.6.0. */
13611 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13613 ffecom_truth_value (tree expr
)
13615 return truthvalue_conversion (expr
);
13619 /* Return the inversion of a truth value (the inversion of what
13620 ffecom_truth_value builds).
13622 Apparently invert_truthvalue, which is properly in the back end, is
13623 enough for now, so just use it. */
13625 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13627 ffecom_truth_value_invert (tree expr
)
13629 return invert_truthvalue (ffecom_truth_value (expr
));
13633 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13635 If the PARM_DECL already exists, return it, else create it. It's an
13636 integer_type_node argument for the master function that implements a
13637 subroutine or function with more than one entrypoint and is bound at
13638 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13639 first ENTRY statement, and so on). */
13641 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13643 ffecom_which_entrypoint_decl ()
13645 assert (ffecom_which_entrypoint_decl_
!= NULL_TREE
);
13647 return ffecom_which_entrypoint_decl_
;
13652 /* The following sections consists of private and public functions
13653 that have the same names and perform roughly the same functions
13654 as counterparts in the C front end. Changes in the C front end
13655 might affect how things should be done here. Only functions
13656 needed by the back end should be public here; the rest should
13657 be private (static in the C sense). Functions needed by other
13658 g77 front-end modules should be accessed by them via public
13659 ffecom_* names, which should themselves call private versions
13660 in this section so the private versions are easy to recognize
13661 when upgrading to a new gcc and finding interesting changes
13664 Functions named after rule "foo:" in c-parse.y are named
13665 "bison_rule_foo_" so they are easy to find. */
13667 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13670 bison_rule_compstmt_ ()
13672 emit_line_note (input_filename
, lineno
);
13673 expand_end_bindings (getdecls (), 1, 1);
13674 poplevel (1, 1, 0);
13679 bison_rule_pushlevel_ ()
13681 emit_line_note (input_filename
, lineno
);
13683 clear_last_expr ();
13685 expand_start_bindings (0);
13688 /* Return a definition for a builtin function named NAME and whose data type
13689 is TYPE. TYPE should be a function type with argument types.
13690 FUNCTION_CODE tells later passes how to compile calls to this function.
13691 See tree.h for its possible values.
13693 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13694 the name to be called if we can't opencode the function. */
13697 builtin_function (char *name
, tree type
,
13698 enum built_in_function function_code
, char *library_name
)
13700 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
13701 DECL_EXTERNAL (decl
) = 1;
13702 TREE_PUBLIC (decl
) = 1;
13704 DECL_ASSEMBLER_NAME (decl
) = get_identifier (library_name
);
13705 make_decl_rtl (decl
, NULL_PTR
, 1);
13707 if (function_code
!= NOT_BUILT_IN
)
13709 DECL_BUILT_IN (decl
) = 1;
13710 DECL_FUNCTION_CODE (decl
) = function_code
;
13716 /* Handle when a new declaration NEWDECL
13717 has the same name as an old one OLDDECL
13718 in the same binding contour.
13719 Prints an error message if appropriate.
13721 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13722 Otherwise, return 0. */
13725 duplicate_decls (tree newdecl
, tree olddecl
)
13727 int types_match
= 1;
13728 int new_is_definition
= (TREE_CODE (newdecl
) == FUNCTION_DECL
13729 && DECL_INITIAL (newdecl
) != 0);
13730 tree oldtype
= TREE_TYPE (olddecl
);
13731 tree newtype
= TREE_TYPE (newdecl
);
13733 if (olddecl
== newdecl
)
13736 if (TREE_CODE (newtype
) == ERROR_MARK
13737 || TREE_CODE (oldtype
) == ERROR_MARK
)
13740 /* New decl is completely inconsistent with the old one =>
13741 tell caller to replace the old one.
13742 This is always an error except in the case of shadowing a builtin. */
13743 if (TREE_CODE (olddecl
) != TREE_CODE (newdecl
))
13746 /* For real parm decl following a forward decl,
13747 return 1 so old decl will be reused. */
13748 if (types_match
&& TREE_CODE (newdecl
) == PARM_DECL
13749 && TREE_ASM_WRITTEN (olddecl
) && ! TREE_ASM_WRITTEN (newdecl
))
13752 /* The new declaration is the same kind of object as the old one.
13753 The declarations may partially match. Print warnings if they don't
13754 match enough. Ultimately, copy most of the information from the new
13755 decl to the old one, and keep using the old one. */
13757 if (TREE_CODE (olddecl
) == FUNCTION_DECL
13758 && DECL_BUILT_IN (olddecl
))
13760 /* A function declaration for a built-in function. */
13761 if (!TREE_PUBLIC (newdecl
))
13763 else if (!types_match
)
13765 /* Accept the return type of the new declaration if same modes. */
13766 tree oldreturntype
= TREE_TYPE (TREE_TYPE (olddecl
));
13767 tree newreturntype
= TREE_TYPE (TREE_TYPE (newdecl
));
13769 /* Make sure we put the new type in the same obstack as the old ones.
13770 If the old types are not both in the same obstack, use the
13772 if (TYPE_OBSTACK (oldtype
) == TYPE_OBSTACK (newtype
))
13773 push_obstacks (TYPE_OBSTACK (oldtype
), TYPE_OBSTACK (oldtype
));
13776 push_obstacks_nochange ();
13777 end_temporary_allocation ();
13780 if (TYPE_MODE (oldreturntype
) == TYPE_MODE (newreturntype
))
13782 /* Function types may be shared, so we can't just modify
13783 the return type of olddecl's function type. */
13785 = build_function_type (newreturntype
,
13786 TYPE_ARG_TYPES (TREE_TYPE (olddecl
)));
13790 TREE_TYPE (olddecl
) = newtype
;
13798 else if (TREE_CODE (olddecl
) == FUNCTION_DECL
13799 && DECL_SOURCE_LINE (olddecl
) == 0)
13801 /* A function declaration for a predeclared function
13802 that isn't actually built in. */
13803 if (!TREE_PUBLIC (newdecl
))
13805 else if (!types_match
)
13807 /* If the types don't match, preserve volatility indication.
13808 Later on, we will discard everything else about the
13809 default declaration. */
13810 TREE_THIS_VOLATILE (newdecl
) |= TREE_THIS_VOLATILE (olddecl
);
13814 /* Copy all the DECL_... slots specified in the new decl
13815 except for any that we copy here from the old type.
13817 Past this point, we don't change OLDTYPE and NEWTYPE
13818 even if we change the types of NEWDECL and OLDDECL. */
13822 /* Make sure we put the new type in the same obstack as the old ones.
13823 If the old types are not both in the same obstack, use the permanent
13825 if (TYPE_OBSTACK (oldtype
) == TYPE_OBSTACK (newtype
))
13826 push_obstacks (TYPE_OBSTACK (oldtype
), TYPE_OBSTACK (oldtype
));
13829 push_obstacks_nochange ();
13830 end_temporary_allocation ();
13833 /* Merge the data types specified in the two decls. */
13834 if (TREE_CODE (newdecl
) != FUNCTION_DECL
|| !DECL_BUILT_IN (olddecl
))
13835 TREE_TYPE (newdecl
)
13836 = TREE_TYPE (olddecl
)
13837 = TREE_TYPE (newdecl
);
13839 /* Lay the type out, unless already done. */
13840 if (oldtype
!= TREE_TYPE (newdecl
))
13842 if (TREE_TYPE (newdecl
) != error_mark_node
)
13843 layout_type (TREE_TYPE (newdecl
));
13844 if (TREE_CODE (newdecl
) != FUNCTION_DECL
13845 && TREE_CODE (newdecl
) != TYPE_DECL
13846 && TREE_CODE (newdecl
) != CONST_DECL
)
13847 layout_decl (newdecl
, 0);
13851 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13852 DECL_SIZE (newdecl
) = DECL_SIZE (olddecl
);
13853 if (TREE_CODE (olddecl
) != FUNCTION_DECL
)
13854 if (DECL_ALIGN (olddecl
) > DECL_ALIGN (newdecl
))
13855 DECL_ALIGN (newdecl
) = DECL_ALIGN (olddecl
);
13858 /* Keep the old rtl since we can safely use it. */
13859 DECL_RTL (newdecl
) = DECL_RTL (olddecl
);
13861 /* Merge the type qualifiers. */
13862 if (DECL_BUILT_IN_NONANSI (olddecl
) && TREE_THIS_VOLATILE (olddecl
)
13863 && !TREE_THIS_VOLATILE (newdecl
))
13864 TREE_THIS_VOLATILE (olddecl
) = 0;
13865 if (TREE_READONLY (newdecl
))
13866 TREE_READONLY (olddecl
) = 1;
13867 if (TREE_THIS_VOLATILE (newdecl
))
13869 TREE_THIS_VOLATILE (olddecl
) = 1;
13870 if (TREE_CODE (newdecl
) == VAR_DECL
)
13871 make_var_volatile (newdecl
);
13874 /* Keep source location of definition rather than declaration.
13875 Likewise, keep decl at outer scope. */
13876 if ((DECL_INITIAL (newdecl
) == 0 && DECL_INITIAL (olddecl
) != 0)
13877 || (DECL_CONTEXT (newdecl
) != 0 && DECL_CONTEXT (olddecl
) == 0))
13879 DECL_SOURCE_LINE (newdecl
) = DECL_SOURCE_LINE (olddecl
);
13880 DECL_SOURCE_FILE (newdecl
) = DECL_SOURCE_FILE (olddecl
);
13882 if (DECL_CONTEXT (olddecl
) == 0
13883 && TREE_CODE (newdecl
) != FUNCTION_DECL
)
13884 DECL_CONTEXT (newdecl
) = 0;
13887 /* Merge the unused-warning information. */
13888 if (DECL_IN_SYSTEM_HEADER (olddecl
))
13889 DECL_IN_SYSTEM_HEADER (newdecl
) = 1;
13890 else if (DECL_IN_SYSTEM_HEADER (newdecl
))
13891 DECL_IN_SYSTEM_HEADER (olddecl
) = 1;
13893 /* Merge the initialization information. */
13894 if (DECL_INITIAL (newdecl
) == 0)
13895 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13897 /* Merge the section attribute.
13898 We want to issue an error if the sections conflict but that must be
13899 done later in decl_attributes since we are called before attributes
13901 if (DECL_SECTION_NAME (newdecl
) == NULL_TREE
)
13902 DECL_SECTION_NAME (newdecl
) = DECL_SECTION_NAME (olddecl
);
13905 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13907 DECL_STATIC_CONSTRUCTOR(newdecl
) |= DECL_STATIC_CONSTRUCTOR(olddecl
);
13908 DECL_STATIC_DESTRUCTOR (newdecl
) |= DECL_STATIC_DESTRUCTOR (olddecl
);
13914 /* If cannot merge, then use the new type and qualifiers,
13915 and don't preserve the old rtl. */
13918 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13919 TREE_READONLY (olddecl
) = TREE_READONLY (newdecl
);
13920 TREE_THIS_VOLATILE (olddecl
) = TREE_THIS_VOLATILE (newdecl
);
13921 TREE_SIDE_EFFECTS (olddecl
) = TREE_SIDE_EFFECTS (newdecl
);
13924 /* Merge the storage class information. */
13925 /* For functions, static overrides non-static. */
13926 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13928 TREE_PUBLIC (newdecl
) &= TREE_PUBLIC (olddecl
);
13929 /* This is since we don't automatically
13930 copy the attributes of NEWDECL into OLDDECL. */
13931 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13932 /* If this clears `static', clear it in the identifier too. */
13933 if (! TREE_PUBLIC (olddecl
))
13934 TREE_PUBLIC (DECL_NAME (olddecl
)) = 0;
13936 if (DECL_EXTERNAL (newdecl
))
13938 TREE_STATIC (newdecl
) = TREE_STATIC (olddecl
);
13939 DECL_EXTERNAL (newdecl
) = DECL_EXTERNAL (olddecl
);
13940 /* An extern decl does not override previous storage class. */
13941 TREE_PUBLIC (newdecl
) = TREE_PUBLIC (olddecl
);
13945 TREE_STATIC (olddecl
) = TREE_STATIC (newdecl
);
13946 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13949 /* If either decl says `inline', this fn is inline,
13950 unless its definition was passed already. */
13951 if (DECL_INLINE (newdecl
) && DECL_INITIAL (olddecl
) == 0)
13952 DECL_INLINE (olddecl
) = 1;
13953 DECL_INLINE (newdecl
) = DECL_INLINE (olddecl
);
13955 /* Get rid of any built-in function if new arg types don't match it
13956 or if we have a function definition. */
13957 if (TREE_CODE (newdecl
) == FUNCTION_DECL
13958 && DECL_BUILT_IN (olddecl
)
13959 && (!types_match
|| new_is_definition
))
13961 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13962 DECL_BUILT_IN (olddecl
) = 0;
13965 /* If redeclaring a builtin function, and not a definition,
13967 Also preserve various other info from the definition. */
13968 if (TREE_CODE (newdecl
) == FUNCTION_DECL
&& !new_is_definition
)
13970 if (DECL_BUILT_IN (olddecl
))
13972 DECL_BUILT_IN (newdecl
) = 1;
13973 DECL_FUNCTION_CODE (newdecl
) = DECL_FUNCTION_CODE (olddecl
);
13976 DECL_FRAME_SIZE (newdecl
) = DECL_FRAME_SIZE (olddecl
);
13978 DECL_RESULT (newdecl
) = DECL_RESULT (olddecl
);
13979 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13980 DECL_SAVED_INSNS (newdecl
) = DECL_SAVED_INSNS (olddecl
);
13981 DECL_ARGUMENTS (newdecl
) = DECL_ARGUMENTS (olddecl
);
13984 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13985 But preserve olddecl's DECL_UID. */
13987 register unsigned olddecl_uid
= DECL_UID (olddecl
);
13989 memcpy ((char *) olddecl
+ sizeof (struct tree_common
),
13990 (char *) newdecl
+ sizeof (struct tree_common
),
13991 sizeof (struct tree_decl
) - sizeof (struct tree_common
));
13992 DECL_UID (olddecl
) = olddecl_uid
;
13998 /* Finish processing of a declaration;
13999 install its initial value.
14000 If the length of an array type is not known before,
14001 it must be determined now, from the initial value, or it is an error. */
14004 finish_decl (tree decl
, tree init
, bool is_top_level
)
14006 register tree type
= TREE_TYPE (decl
);
14007 int was_incomplete
= (DECL_SIZE (decl
) == 0);
14008 int temporary
= allocation_temporary_p ();
14009 bool at_top_level
= (current_binding_level
== global_binding_level
);
14010 bool top_level
= is_top_level
|| at_top_level
;
14012 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14014 assert (!is_top_level
|| !at_top_level
);
14016 if (TREE_CODE (decl
) == PARM_DECL
)
14017 assert (init
== NULL_TREE
);
14018 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
14019 overlaps DECL_ARG_TYPE. */
14020 else if (init
== NULL_TREE
)
14021 assert (DECL_INITIAL (decl
) == NULL_TREE
);
14023 assert (DECL_INITIAL (decl
) == error_mark_node
);
14025 if (init
!= NULL_TREE
)
14027 if (TREE_CODE (decl
) != TYPE_DECL
)
14028 DECL_INITIAL (decl
) = init
;
14031 /* typedef foo = bar; store the type of bar as the type of foo. */
14032 TREE_TYPE (decl
) = TREE_TYPE (init
);
14033 DECL_INITIAL (decl
) = init
= 0;
14037 /* Pop back to the obstack that is current for this binding level. This is
14038 because MAXINDEX, rtl, etc. to be made below must go in the permanent
14039 obstack. But don't discard the temporary data yet. */
14042 /* Deduce size of array from initialization, if not already known */
14044 if (TREE_CODE (type
) == ARRAY_TYPE
14045 && TYPE_DOMAIN (type
) == 0
14046 && TREE_CODE (decl
) != TYPE_DECL
)
14048 assert (top_level
);
14049 assert (was_incomplete
);
14051 layout_decl (decl
, 0);
14054 if (TREE_CODE (decl
) == VAR_DECL
)
14056 if (DECL_SIZE (decl
) == NULL_TREE
14057 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
14058 layout_decl (decl
, 0);
14060 if (DECL_SIZE (decl
) == NULL_TREE
14061 && (TREE_STATIC (decl
)
14063 /* A static variable with an incomplete type is an error if it is
14064 initialized. Also if it is not file scope. Otherwise, let it
14065 through, but if it is not `extern' then it may cause an error
14067 (DECL_INITIAL (decl
) != 0 || DECL_CONTEXT (decl
) != 0)
14069 /* An automatic variable with an incomplete type is an error. */
14070 !DECL_EXTERNAL (decl
)))
14072 assert ("storage size not known" == NULL
);
14076 if ((DECL_EXTERNAL (decl
) || TREE_STATIC (decl
))
14077 && (DECL_SIZE (decl
) != 0)
14078 && (TREE_CODE (DECL_SIZE (decl
)) != INTEGER_CST
))
14080 assert ("storage size not constant" == NULL
);
14085 /* Output the assembler code and/or RTL code for variables and functions,
14086 unless the type is an undefined structure or union. If not, it will get
14087 done when the type is completed. */
14089 if (TREE_CODE (decl
) == VAR_DECL
|| TREE_CODE (decl
) == FUNCTION_DECL
)
14091 rest_of_decl_compilation (decl
, NULL
,
14092 DECL_CONTEXT (decl
) == 0,
14095 if (DECL_CONTEXT (decl
) != 0)
14097 /* Recompute the RTL of a local array now if it used to be an
14098 incomplete type. */
14100 && !TREE_STATIC (decl
) && !DECL_EXTERNAL (decl
))
14102 /* If we used it already as memory, it must stay in memory. */
14103 TREE_ADDRESSABLE (decl
) = TREE_USED (decl
);
14104 /* If it's still incomplete now, no init will save it. */
14105 if (DECL_SIZE (decl
) == 0)
14106 DECL_INITIAL (decl
) = 0;
14107 expand_decl (decl
);
14109 /* Compute and store the initial value. */
14110 if (TREE_CODE (decl
) != FUNCTION_DECL
)
14111 expand_decl_init (decl
);
14114 else if (TREE_CODE (decl
) == TYPE_DECL
)
14116 rest_of_decl_compilation (decl
, NULL_PTR
,
14117 DECL_CONTEXT (decl
) == 0,
14121 /* This test used to include TREE_PERMANENT, however, we have the same
14122 problem with initializers at the function level. Such initializers get
14123 saved until the end of the function on the momentary_obstack. */
14124 if (!(TREE_CODE (decl
) == FUNCTION_DECL
&& DECL_INLINE (decl
))
14126 /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
14128 && TREE_CODE (decl
) != PARM_DECL
)
14130 /* We need to remember that this array HAD an initialization, but
14131 discard the actual temporary nodes, since we can't have a permanent
14132 node keep pointing to them. */
14133 /* We make an exception for inline functions, since it's normal for a
14134 local extern redeclaration of an inline function to have a copy of
14135 the top-level decl's DECL_INLINE. */
14136 if ((DECL_INITIAL (decl
) != 0)
14137 && (DECL_INITIAL (decl
) != error_mark_node
))
14139 /* If this is a const variable, then preserve the
14140 initializer instead of discarding it so that we can optimize
14141 references to it. */
14142 /* This test used to include TREE_STATIC, but this won't be set
14143 for function level initializers. */
14144 if (TREE_READONLY (decl
))
14146 preserve_initializer ();
14147 /* Hack? Set the permanent bit for something that is
14148 permanent, but not on the permenent obstack, so as to
14149 convince output_constant_def to make its rtl on the
14150 permanent obstack. */
14151 TREE_PERMANENT (DECL_INITIAL (decl
)) = 1;
14153 /* The initializer and DECL must have the same (or equivalent
14154 types), but if the initializer is a STRING_CST, its type
14155 might not be on the right obstack, so copy the type
14157 TREE_TYPE (DECL_INITIAL (decl
)) = type
;
14160 DECL_INITIAL (decl
) = error_mark_node
;
14164 /* If requested, warn about definitions of large data objects. */
14166 if (warn_larger_than
14167 && (TREE_CODE (decl
) == VAR_DECL
|| TREE_CODE (decl
) == PARM_DECL
)
14168 && !DECL_EXTERNAL (decl
))
14170 register tree decl_size
= DECL_SIZE (decl
);
14172 if (decl_size
&& TREE_CODE (decl_size
) == INTEGER_CST
)
14174 unsigned units
= TREE_INT_CST_LOW (decl_size
) / BITS_PER_UNIT
;
14176 if (units
> larger_than_size
)
14177 warning_with_decl (decl
, "size of `%s' is %u bytes", units
);
14181 /* If we have gone back from temporary to permanent allocation, actually
14182 free the temporary space that we no longer need. */
14183 if (temporary
&& !allocation_temporary_p ())
14184 permanent_allocation (0);
14186 /* At the end of a declaration, throw away any variable type sizes of types
14187 defined inside that declaration. There is no use computing them in the
14188 following function definition. */
14189 if (current_binding_level
== global_binding_level
)
14190 get_pending_sizes ();
14193 /* Finish up a function declaration and compile that function
14194 all the way to assembler language output. The free the storage
14195 for the function definition.
14197 This is called after parsing the body of the function definition.
14199 NESTED is nonzero if the function being finished is nested in another. */
14202 finish_function (int nested
)
14204 register tree fndecl
= current_function_decl
;
14206 assert (fndecl
!= NULL_TREE
);
14207 if (TREE_CODE (fndecl
) != ERROR_MARK
)
14210 assert (DECL_CONTEXT (fndecl
) != NULL_TREE
);
14212 assert (DECL_CONTEXT (fndecl
) == NULL_TREE
);
14215 /* TREE_READONLY (fndecl) = 1;
14216 This caused &foo to be of type ptr-to-const-function
14217 which then got a warning when stored in a ptr-to-function variable. */
14219 poplevel (1, 0, 1);
14221 if (TREE_CODE (fndecl
) != ERROR_MARK
)
14223 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
14225 /* Must mark the RESULT_DECL as being in this function. */
14227 DECL_CONTEXT (DECL_RESULT (fndecl
)) = fndecl
;
14229 /* Obey `register' declarations if `setjmp' is called in this fn. */
14230 /* Generate rtl for function exit. */
14231 expand_function_end (input_filename
, lineno
, 0);
14233 /* So we can tell if jump_optimize sets it to 1. */
14236 /* Run the optimizers and output the assembler code for this function. */
14237 rest_of_compilation (fndecl
);
14240 /* Free all the tree nodes making up this function. */
14241 /* Switch back to allocating nodes permanently until we start another
14244 permanent_allocation (1);
14246 if (DECL_SAVED_INSNS (fndecl
) == 0 && !nested
&& (TREE_CODE (fndecl
) != ERROR_MARK
))
14248 /* Stop pointing to the local nodes about to be freed. */
14249 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14250 function definition. */
14251 /* For a nested function, this is done in pop_f_function_context. */
14252 /* If rest_of_compilation set this to 0, leave it 0. */
14253 if (DECL_INITIAL (fndecl
) != 0)
14254 DECL_INITIAL (fndecl
) = error_mark_node
;
14255 DECL_ARGUMENTS (fndecl
) = 0;
14260 /* Let the error reporting routines know that we're outside a function.
14261 For a nested function, this value is used in pop_c_function_context
14262 and then reset via pop_function_context. */
14263 ffecom_outer_function_decl_
= current_function_decl
= NULL
;
14267 /* Plug-in replacement for identifying the name of a decl and, for a
14268 function, what we call it in diagnostics. For now, "program unit"
14269 should suffice, since it's a bit of a hassle to figure out which
14270 of several kinds of things it is. Note that it could conceivably
14271 be a statement function, which probably isn't really a program unit
14272 per se, but if that comes up, it should be easy to check (being a
14273 nested function and all). */
14276 lang_printable_name (tree decl
, int v
)
14278 /* Just to keep GCC quiet about the unused variable.
14279 In theory, differing values of V should produce different
14284 if (TREE_CODE (decl
) == ERROR_MARK
)
14285 return "erroneous code";
14286 return IDENTIFIER_POINTER (DECL_NAME (decl
));
14290 /* g77's function to print out name of current function that caused
14295 lang_print_error_function (file
)
14298 static ffeglobal last_g
= NULL
;
14299 static ffesymbol last_s
= NULL
;
14304 if ((ffecom_primary_entry_
== NULL
)
14305 || (ffesymbol_global (ffecom_primary_entry_
) == NULL
))
14313 g
= ffesymbol_global (ffecom_primary_entry_
);
14314 if (ffecom_nested_entry_
== NULL
)
14316 s
= ffecom_primary_entry_
;
14317 switch (ffesymbol_kind (s
))
14319 case FFEINFO_kindFUNCTION
:
14323 case FFEINFO_kindSUBROUTINE
:
14324 kind
= "subroutine";
14327 case FFEINFO_kindPROGRAM
:
14331 case FFEINFO_kindBLOCKDATA
:
14332 kind
= "block-data";
14336 kind
= ffeinfo_kind_message (ffesymbol_kind (s
));
14342 s
= ffecom_nested_entry_
;
14343 kind
= "statement function";
14347 if ((last_g
!= g
) || (last_s
!= s
))
14350 fprintf (stderr
, "%s: ", file
);
14353 fprintf (stderr
, "Outside of any program unit:\n");
14356 char *name
= ffesymbol_text (s
);
14358 fprintf (stderr
, "In %s `%s':\n", kind
, name
);
14367 /* Similar to `lookup_name' but look only at current binding level. */
14370 lookup_name_current_level (tree name
)
14374 if (current_binding_level
== global_binding_level
)
14375 return IDENTIFIER_GLOBAL_VALUE (name
);
14377 if (IDENTIFIER_LOCAL_VALUE (name
) == 0)
14380 for (t
= current_binding_level
->names
; t
; t
= TREE_CHAIN (t
))
14381 if (DECL_NAME (t
) == name
)
14387 /* Create a new `struct binding_level'. */
14389 static struct binding_level
*
14390 make_binding_level ()
14393 return (struct binding_level
*) xmalloc (sizeof (struct binding_level
));
14396 /* Save and restore the variables in this file and elsewhere
14397 that keep track of the progress of compilation of the current function.
14398 Used for nested functions. */
14402 struct f_function
*next
;
14404 tree shadowed_labels
;
14405 struct binding_level
*binding_level
;
14408 struct f_function
*f_function_chain
;
14410 /* Restore the variables used during compilation of a C function. */
14413 pop_f_function_context ()
14415 struct f_function
*p
= f_function_chain
;
14418 /* Bring back all the labels that were shadowed. */
14419 for (link
= shadowed_labels
; link
; link
= TREE_CHAIN (link
))
14420 if (DECL_NAME (TREE_VALUE (link
)) != 0)
14421 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link
)))
14422 = TREE_VALUE (link
);
14424 if (DECL_SAVED_INSNS (current_function_decl
) == 0)
14426 /* Stop pointing to the local nodes about to be freed. */
14427 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14428 function definition. */
14429 DECL_INITIAL (current_function_decl
) = error_mark_node
;
14430 DECL_ARGUMENTS (current_function_decl
) = 0;
14433 pop_function_context ();
14435 f_function_chain
= p
->next
;
14437 named_labels
= p
->named_labels
;
14438 shadowed_labels
= p
->shadowed_labels
;
14439 current_binding_level
= p
->binding_level
;
14444 /* Save and reinitialize the variables
14445 used during compilation of a C function. */
14448 push_f_function_context ()
14450 struct f_function
*p
14451 = (struct f_function
*) xmalloc (sizeof (struct f_function
));
14453 push_function_context ();
14455 p
->next
= f_function_chain
;
14456 f_function_chain
= p
;
14458 p
->named_labels
= named_labels
;
14459 p
->shadowed_labels
= shadowed_labels
;
14460 p
->binding_level
= current_binding_level
;
14464 push_parm_decl (tree parm
)
14466 int old_immediate_size_expand
= immediate_size_expand
;
14468 /* Don't try computing parm sizes now -- wait till fn is called. */
14470 immediate_size_expand
= 0;
14472 push_obstacks_nochange ();
14474 /* Fill in arg stuff. */
14476 DECL_ARG_TYPE (parm
) = TREE_TYPE (parm
);
14477 DECL_ARG_TYPE_AS_WRITTEN (parm
) = TREE_TYPE (parm
);
14478 TREE_READONLY (parm
) = 1; /* All implementation args are read-only. */
14480 parm
= pushdecl (parm
);
14482 immediate_size_expand
= old_immediate_size_expand
;
14484 finish_decl (parm
, NULL_TREE
, FALSE
);
14487 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
14490 pushdecl_top_level (x
)
14494 register struct binding_level
*b
= current_binding_level
;
14495 register tree f
= current_function_decl
;
14497 current_binding_level
= global_binding_level
;
14498 current_function_decl
= NULL_TREE
;
14500 current_binding_level
= b
;
14501 current_function_decl
= f
;
14505 /* Store the list of declarations of the current level.
14506 This is done for the parameter declarations of a function being defined,
14507 after they are modified in the light of any missing parameters. */
14513 return current_binding_level
->names
= decls
;
14516 /* Store the parameter declarations into the current function declaration.
14517 This is called after parsing the parameter declarations, before
14518 digesting the body of the function.
14520 For an old-style definition, modify the function's type
14521 to specify at least the number of arguments. */
14524 store_parm_decls (int is_main_program UNUSED
)
14526 register tree fndecl
= current_function_decl
;
14528 /* This is a chain of PARM_DECLs from old-style parm declarations. */
14529 DECL_ARGUMENTS (fndecl
) = storedecls (nreverse (getdecls ()));
14531 /* Initialize the RTL code for the function. */
14533 init_function_start (fndecl
, input_filename
, lineno
);
14535 /* Set up parameters and prepare for return, for the function. */
14537 expand_function_start (fndecl
, 0);
14541 start_decl (tree decl
, bool is_top_level
)
14544 bool at_top_level
= (current_binding_level
== global_binding_level
);
14545 bool top_level
= is_top_level
|| at_top_level
;
14547 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14549 assert (!is_top_level
|| !at_top_level
);
14551 /* The corresponding pop_obstacks is in finish_decl. */
14552 push_obstacks_nochange ();
14554 if (DECL_INITIAL (decl
) != NULL_TREE
)
14556 assert (DECL_INITIAL (decl
) == error_mark_node
);
14557 assert (!DECL_EXTERNAL (decl
));
14559 else if (top_level
)
14560 assert ((TREE_STATIC (decl
) == 1) || DECL_EXTERNAL (decl
) == 1);
14562 /* For Fortran, we by default put things in .common when possible. */
14563 DECL_COMMON (decl
) = 1;
14565 /* Add this decl to the current binding level. TEM may equal DECL or it may
14566 be a previous decl of the same name. */
14568 tem
= pushdecl_top_level (decl
);
14570 tem
= pushdecl (decl
);
14572 /* For a local variable, define the RTL now. */
14574 /* But not if this is a duplicate decl and we preserved the rtl from the
14575 previous one (which may or may not happen). */
14576 && DECL_RTL (tem
) == 0)
14578 if (TYPE_SIZE (TREE_TYPE (tem
)) != 0)
14580 else if (TREE_CODE (TREE_TYPE (tem
)) == ARRAY_TYPE
14581 && DECL_INITIAL (tem
) != 0)
14585 if (DECL_INITIAL (tem
) != NULL_TREE
)
14587 /* When parsing and digesting the initializer, use temporary storage.
14588 Do this even if we will ignore the value. */
14590 temporary_allocation ();
14596 /* Create the FUNCTION_DECL for a function definition.
14597 DECLSPECS and DECLARATOR are the parts of the declaration;
14598 they describe the function's name and the type it returns,
14599 but twisted together in a fashion that parallels the syntax of C.
14601 This function creates a binding context for the function body
14602 as well as setting up the FUNCTION_DECL in current_function_decl.
14604 Returns 1 on success. If the DECLARATOR is not suitable for a function
14605 (it defines a datum instead), we return 0, which tells
14606 yyparse to report a parse error.
14608 NESTED is nonzero for a function nested within another function. */
14611 start_function (tree name
, tree type
, int nested
, int public)
14615 int old_immediate_size_expand
= immediate_size_expand
;
14618 shadowed_labels
= 0;
14620 /* Don't expand any sizes in the return type of the function. */
14621 immediate_size_expand
= 0;
14626 assert (current_function_decl
!= NULL_TREE
);
14627 assert (DECL_CONTEXT (current_function_decl
) == NULL_TREE
);
14631 assert (current_function_decl
== NULL_TREE
);
14634 if (TREE_CODE (type
) == ERROR_MARK
)
14635 decl1
= current_function_decl
= error_mark_node
;
14638 decl1
= build_decl (FUNCTION_DECL
,
14641 TREE_PUBLIC (decl1
) = public ? 1 : 0;
14643 DECL_INLINE (decl1
) = 1;
14644 TREE_STATIC (decl1
) = 1;
14645 DECL_EXTERNAL (decl1
) = 0;
14647 announce_function (decl1
);
14649 /* Make the init_value nonzero so pushdecl knows this is not tentative.
14650 error_mark_node is replaced below (in poplevel) with the BLOCK. */
14651 DECL_INITIAL (decl1
) = error_mark_node
;
14653 /* Record the decl so that the function name is defined. If we already have
14654 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
14656 current_function_decl
= pushdecl (decl1
);
14660 ffecom_outer_function_decl_
= current_function_decl
;
14664 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
14666 make_function_rtl (current_function_decl
);
14668 restype
= TREE_TYPE (TREE_TYPE (current_function_decl
));
14669 DECL_RESULT (current_function_decl
)
14670 = build_decl (RESULT_DECL
, NULL_TREE
, restype
);
14674 /* Allocate further tree nodes temporarily during compilation of this
14676 temporary_allocation ();
14678 if (!nested
&& (TREE_CODE (current_function_decl
) != ERROR_MARK
))
14679 TREE_ADDRESSABLE (current_function_decl
) = 1;
14681 immediate_size_expand
= old_immediate_size_expand
;
14684 /* Here are the public functions the GNU back end needs. */
14686 /* This is used by the `assert' macro. It is provided in libgcc.a,
14687 which `cc' doesn't know how to link. Note that the C++ front-end
14688 no longer actually uses the `assert' macro (instead, it calls
14689 my_friendly_assert). But all of the back-end files still need this. */
14691 __eprintf (string
, expression
, line
, filename
)
14693 const char *string
;
14694 const char *expression
;
14696 const char *filename
;
14704 fprintf (stderr
, string
, expression
, line
, filename
);
14710 convert (type
, expr
)
14713 register tree e
= expr
;
14714 register enum tree_code code
= TREE_CODE (type
);
14716 if (type
== TREE_TYPE (e
)
14717 || TREE_CODE (e
) == ERROR_MARK
)
14719 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
14720 return fold (build1 (NOP_EXPR
, type
, e
));
14721 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
14722 || code
== ERROR_MARK
)
14723 return error_mark_node
;
14724 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
14726 assert ("void value not ignored as it ought to be" == NULL
);
14727 return error_mark_node
;
14729 if (code
== VOID_TYPE
)
14730 return build1 (CONVERT_EXPR
, type
, e
);
14731 if ((code
!= RECORD_TYPE
)
14732 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
14733 e
= ffecom_1 (REALPART_EXPR
, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
))),
14735 if (code
== INTEGER_TYPE
|| code
== ENUMERAL_TYPE
)
14736 return fold (convert_to_integer (type
, e
));
14737 if (code
== POINTER_TYPE
)
14738 return fold (convert_to_pointer (type
, e
));
14739 if (code
== REAL_TYPE
)
14740 return fold (convert_to_real (type
, e
));
14741 if (code
== COMPLEX_TYPE
)
14742 return fold (convert_to_complex (type
, e
));
14743 if (code
== RECORD_TYPE
)
14744 return fold (ffecom_convert_to_complex_ (type
, e
));
14746 assert ("conversion to non-scalar type requested" == NULL
);
14747 return error_mark_node
;
14750 /* integrate_decl_tree calls this function, but since we don't use the
14751 DECL_LANG_SPECIFIC field, this is a no-op. */
14754 copy_lang_decl (node
)
14759 /* Return the list of declarations of the current level.
14760 Note that this list is in reverse order unless/until
14761 you nreverse it; and when you do nreverse it, you must
14762 store the result back using `storedecls' or you will lose. */
14767 return current_binding_level
->names
;
14770 /* Nonzero if we are currently in the global binding level. */
14773 global_bindings_p ()
14775 return current_binding_level
== global_binding_level
;
14778 /* Insert BLOCK at the end of the list of subblocks of the
14779 current binding level. This is used when a BIND_EXPR is expanded,
14780 to handle the BLOCK node inside the BIND_EXPR. */
14783 incomplete_type_error (value
, type
)
14787 if (TREE_CODE (type
) == ERROR_MARK
)
14790 assert ("incomplete type?!?" == NULL
);
14794 init_decl_processing ()
14801 init_parse (filename
)
14805 extern void (*print_error_function
) (char *);
14808 /* Open input file. */
14809 if (filename
== 0 || !strcmp (filename
, "-"))
14812 filename
= "stdin";
14815 finput
= fopen (filename
, "r");
14817 pfatal_with_name (filename
);
14819 #ifdef IO_BUFFER_SIZE
14820 setvbuf (finput
, (char *) xmalloc (IO_BUFFER_SIZE
), _IOFBF
, IO_BUFFER_SIZE
);
14823 /* Make identifier nodes long enough for the language-specific slots. */
14824 set_identifier_size (sizeof (struct lang_identifier
));
14825 decl_printable_name
= lang_printable_name
;
14827 print_error_function
= lang_print_error_function
;
14840 insert_block (block
)
14843 TREE_USED (block
) = 1;
14844 current_binding_level
->blocks
14845 = chainon (current_binding_level
->blocks
, block
);
14849 lang_decode_option (p
)
14852 return ffe_decode_option (p
);
14855 /* used by print-tree.c */
14858 lang_print_xnode (file
, node
, indent
)
14868 ffe_terminate_0 ();
14870 if (ffe_is_ffedebug ())
14871 malloc_pool_display (malloc_pool_image ());
14883 /* If the file is output from cpp, it should contain a first line
14884 `# 1 "real-filename"', and the current design of gcc (toplev.c
14885 in particular and the way it sets up information relied on by
14886 INCLUDE) requires that we read this now, and store the
14887 "real-filename" info in master_input_filename. Ask the lexer
14888 to try doing this. */
14889 ffelex_hash_kludge (finput
);
14893 mark_addressable (exp
)
14896 register tree x
= exp
;
14898 switch (TREE_CODE (x
))
14901 case COMPONENT_REF
:
14903 x
= TREE_OPERAND (x
, 0);
14907 TREE_ADDRESSABLE (x
) = 1;
14914 if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
)
14915 && DECL_NONLOCAL (x
))
14917 if (TREE_PUBLIC (x
))
14919 assert ("address of global register var requested" == NULL
);
14922 assert ("address of register variable requested" == NULL
);
14924 else if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
))
14926 if (TREE_PUBLIC (x
))
14928 assert ("address of global register var requested" == NULL
);
14931 assert ("address of register var requested" == NULL
);
14933 put_var_into_stack (x
);
14936 case FUNCTION_DECL
:
14937 TREE_ADDRESSABLE (x
) = 1;
14938 #if 0 /* poplevel deals with this now. */
14939 if (DECL_CONTEXT (x
) == 0)
14940 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x
)) = 1;
14948 /* If DECL has a cleanup, build and return that cleanup here.
14949 This is a callback called by expand_expr. */
14952 maybe_build_cleanup (decl
)
14955 /* There are no cleanups in Fortran. */
14959 /* Exit a binding level.
14960 Pop the level off, and restore the state of the identifier-decl mappings
14961 that were in effect when this level was entered.
14963 If KEEP is nonzero, this level had explicit declarations, so
14964 and create a "block" (a BLOCK node) for the level
14965 to record its declarations and subblocks for symbol table output.
14967 If FUNCTIONBODY is nonzero, this level is the body of a function,
14968 so create a block as if KEEP were set and also clear out all
14971 If REVERSE is nonzero, reverse the order of decls before putting
14972 them into the BLOCK. */
14975 poplevel (keep
, reverse
, functionbody
)
14980 register tree link
;
14981 /* The chain of decls was accumulated in reverse order. Put it into forward
14982 order, just for cleanliness. */
14984 tree subblocks
= current_binding_level
->blocks
;
14987 int block_previously_created
;
14989 /* Get the decls in the order they were written. Usually
14990 current_binding_level->names is in reverse order. But parameter decls
14991 were previously put in forward order. */
14994 current_binding_level
->names
14995 = decls
= nreverse (current_binding_level
->names
);
14997 decls
= current_binding_level
->names
;
14999 /* Output any nested inline functions within this block if they weren't
15002 for (decl
= decls
; decl
; decl
= TREE_CHAIN (decl
))
15003 if (TREE_CODE (decl
) == FUNCTION_DECL
15004 && !TREE_ASM_WRITTEN (decl
)
15005 && DECL_INITIAL (decl
) != 0
15006 && TREE_ADDRESSABLE (decl
))
15008 /* If this decl was copied from a file-scope decl on account of a
15009 block-scope extern decl, propagate TREE_ADDRESSABLE to the
15010 file-scope decl. */
15011 if (DECL_ABSTRACT_ORIGIN (decl
) != 0)
15012 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl
)) = 1;
15015 push_function_context ();
15016 output_inline_function (decl
);
15017 pop_function_context ();
15021 /* If there were any declarations or structure tags in that level, or if
15022 this level is a function body, create a BLOCK to record them for the
15023 life of this function. */
15026 block_previously_created
= (current_binding_level
->this_block
!= 0);
15027 if (block_previously_created
)
15028 block
= current_binding_level
->this_block
;
15029 else if (keep
|| functionbody
)
15030 block
= make_node (BLOCK
);
15033 BLOCK_VARS (block
) = decls
;
15034 BLOCK_SUBBLOCKS (block
) = subblocks
;
15035 remember_end_note (block
);
15038 /* In each subblock, record that this is its superior. */
15040 for (link
= subblocks
; link
; link
= TREE_CHAIN (link
))
15041 BLOCK_SUPERCONTEXT (link
) = block
;
15043 /* Clear out the meanings of the local variables of this level. */
15045 for (link
= decls
; link
; link
= TREE_CHAIN (link
))
15047 if (DECL_NAME (link
) != 0)
15049 /* If the ident. was used or addressed via a local extern decl,
15050 don't forget that fact. */
15051 if (DECL_EXTERNAL (link
))
15053 if (TREE_USED (link
))
15054 TREE_USED (DECL_NAME (link
)) = 1;
15055 if (TREE_ADDRESSABLE (link
))
15056 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link
)) = 1;
15058 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link
)) = 0;
15062 /* If the level being exited is the top level of a function, check over all
15063 the labels, and clear out the current (function local) meanings of their
15068 /* If this is the top level block of a function, the vars are the
15069 function's parameters. Don't leave them in the BLOCK because they
15070 are found in the FUNCTION_DECL instead. */
15072 BLOCK_VARS (block
) = 0;
15075 /* Pop the current level, and free the structure for reuse. */
15078 register struct binding_level
*level
= current_binding_level
;
15079 current_binding_level
= current_binding_level
->level_chain
;
15081 level
->level_chain
= free_binding_level
;
15082 free_binding_level
= level
;
15085 /* Dispose of the block that we just made inside some higher level. */
15087 DECL_INITIAL (current_function_decl
) = block
;
15090 if (!block_previously_created
)
15091 current_binding_level
->blocks
15092 = chainon (current_binding_level
->blocks
, block
);
15094 /* If we did not make a block for the level just exited, any blocks made
15095 for inner levels (since they cannot be recorded as subblocks in that
15096 level) must be carried forward so they will later become subblocks of
15098 else if (subblocks
)
15099 current_binding_level
->blocks
15100 = chainon (current_binding_level
->blocks
, subblocks
);
15102 /* Set the TYPE_CONTEXTs for all of the tagged types belonging to this
15103 binding contour so that they point to the appropriate construct, i.e.
15104 either to the current FUNCTION_DECL node, or else to the BLOCK node we
15107 Note that for tagged types whose scope is just the formal parameter list
15108 for some function type specification, we can't properly set their
15109 TYPE_CONTEXTs here, because we don't have a pointer to the appropriate
15110 FUNCTION_TYPE node readily available to us. For those cases, the
15111 TYPE_CONTEXTs of the relevant tagged type nodes get set in
15112 `grokdeclarator' as soon as we have created the FUNCTION_TYPE node which
15113 will represent the "scope" for these "parameter list local" tagged
15117 TREE_USED (block
) = 1;
15122 print_lang_decl (file
, node
, indent
)
15130 print_lang_identifier (file
, node
, indent
)
15135 print_node (file
, "global", IDENTIFIER_GLOBAL_VALUE (node
), indent
+ 4);
15136 print_node (file
, "local", IDENTIFIER_LOCAL_VALUE (node
), indent
+ 4);
15140 print_lang_statistics ()
15145 print_lang_type (file
, node
, indent
)
15152 /* Record a decl-node X as belonging to the current lexical scope.
15153 Check for errors (such as an incompatible declaration for the same
15154 name already seen in the same scope).
15156 Returns either X or an old decl for the same name.
15157 If an old decl is returned, it may have been smashed
15158 to agree with what X says. */
15165 register tree name
= DECL_NAME (x
);
15166 register struct binding_level
*b
= current_binding_level
;
15168 if ((TREE_CODE (x
) == FUNCTION_DECL
)
15169 && (DECL_INITIAL (x
) == 0)
15170 && DECL_EXTERNAL (x
))
15171 DECL_CONTEXT (x
) = NULL_TREE
;
15173 DECL_CONTEXT (x
) = current_function_decl
;
15177 if (IDENTIFIER_INVENTED (name
))
15180 DECL_ARTIFICIAL (x
) = 1;
15182 DECL_IN_SYSTEM_HEADER (x
) = 1;
15183 DECL_IGNORED_P (x
) = 1;
15185 if (TREE_CODE (x
) == TYPE_DECL
)
15186 TYPE_DECL_SUPPRESS_DEBUG (x
) = 1;
15189 t
= lookup_name_current_level (name
);
15191 assert ((t
== NULL_TREE
) || (DECL_CONTEXT (x
) == NULL_TREE
));
15193 /* Don't push non-parms onto list for parms until we understand
15194 why we're doing this and whether it works. */
15196 assert ((b
== global_binding_level
)
15197 || !ffecom_transform_only_dummies_
15198 || TREE_CODE (x
) == PARM_DECL
);
15200 if ((t
!= NULL_TREE
) && duplicate_decls (x
, t
))
15203 /* If we are processing a typedef statement, generate a whole new
15204 ..._TYPE node (which will be just an variant of the existing
15205 ..._TYPE node with identical properties) and then install the
15206 TYPE_DECL node generated to represent the typedef name as the
15207 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15209 The whole point here is to end up with a situation where each and every
15210 ..._TYPE node the compiler creates will be uniquely associated with
15211 AT MOST one node representing a typedef name. This way, even though
15212 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15213 (i.e. "typedef name") nodes very early on, later parts of the
15214 compiler can always do the reverse translation and get back the
15215 corresponding typedef name. For example, given:
15217 typedef struct S MY_TYPE; MY_TYPE object;
15219 Later parts of the compiler might only know that `object' was of type
15220 `struct S' if it were not for code just below. With this code
15221 however, later parts of the compiler see something like:
15223 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15225 And they can then deduce (from the node for type struct S') that the
15226 original object declaration was:
15230 Being able to do this is important for proper support of protoize, and
15231 also for generating precise symbolic debugging information which
15232 takes full account of the programmer's (typedef) vocabulary.
15234 Obviously, we don't want to generate a duplicate ..._TYPE node if the
15235 TYPE_DECL node that we are now processing really represents a
15236 standard built-in type.
15238 Since all standard types are effectively declared at line zero in the
15239 source file, we can easily check to see if we are working on a
15240 standard type by checking the current value of lineno. */
15242 if (TREE_CODE (x
) == TYPE_DECL
)
15244 if (DECL_SOURCE_LINE (x
) == 0)
15246 if (TYPE_NAME (TREE_TYPE (x
)) == 0)
15247 TYPE_NAME (TREE_TYPE (x
)) = x
;
15249 else if (TREE_TYPE (x
) != error_mark_node
)
15251 tree tt
= TREE_TYPE (x
);
15253 tt
= build_type_copy (tt
);
15254 TYPE_NAME (tt
) = x
;
15255 TREE_TYPE (x
) = tt
;
15259 /* This name is new in its binding level. Install the new declaration
15261 if (b
== global_binding_level
)
15262 IDENTIFIER_GLOBAL_VALUE (name
) = x
;
15264 IDENTIFIER_LOCAL_VALUE (name
) = x
;
15267 /* Put decls on list in reverse order. We will reverse them later if
15269 TREE_CHAIN (x
) = b
->names
;
15275 /* Enter a new binding level.
15276 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15277 not for that of tags. */
15280 pushlevel (tag_transparent
)
15281 int tag_transparent
;
15283 register struct binding_level
*newlevel
= NULL_BINDING_LEVEL
;
15285 assert (!tag_transparent
);
15287 /* Reuse or create a struct for this binding level. */
15289 if (free_binding_level
)
15291 newlevel
= free_binding_level
;
15292 free_binding_level
= free_binding_level
->level_chain
;
15296 newlevel
= make_binding_level ();
15299 /* Add this level to the front of the chain (stack) of levels that are
15302 *newlevel
= clear_binding_level
;
15303 newlevel
->level_chain
= current_binding_level
;
15304 current_binding_level
= newlevel
;
15307 /* Set the BLOCK node for the innermost scope
15308 (the one we are currently in). */
15312 register tree block
;
15314 current_binding_level
->this_block
= block
;
15317 /* ~~tree.h SHOULD declare this, because toplev.c references it. */
15319 /* Can't 'yydebug' a front end not generated by yacc/bison! */
15322 set_yydebug (value
)
15326 fprintf (stderr
, "warning: no yacc/bison-generated output to debug!\n");
15330 signed_or_unsigned_type (unsignedp
, type
)
15336 if (! INTEGRAL_TYPE_P (type
))
15338 if (TYPE_PRECISION (type
) == TYPE_PRECISION (signed_char_type_node
))
15339 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15340 if (TYPE_PRECISION (type
) == TYPE_PRECISION (integer_type_node
))
15341 return unsignedp
? unsigned_type_node
: integer_type_node
;
15342 if (TYPE_PRECISION (type
) == TYPE_PRECISION (short_integer_type_node
))
15343 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15344 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_integer_type_node
))
15345 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15346 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_long_integer_type_node
))
15347 return (unsignedp
? long_long_unsigned_type_node
15348 : long_long_integer_type_node
);
15350 type2
= type_for_size (TYPE_PRECISION (type
), unsignedp
);
15351 if (type2
== NULL_TREE
)
15361 tree type1
= TYPE_MAIN_VARIANT (type
);
15362 ffeinfoKindtype kt
;
15365 if (type1
== unsigned_char_type_node
|| type1
== char_type_node
)
15366 return signed_char_type_node
;
15367 if (type1
== unsigned_type_node
)
15368 return integer_type_node
;
15369 if (type1
== short_unsigned_type_node
)
15370 return short_integer_type_node
;
15371 if (type1
== long_unsigned_type_node
)
15372 return long_integer_type_node
;
15373 if (type1
== long_long_unsigned_type_node
)
15374 return long_long_integer_type_node
;
15375 #if 0 /* gcc/c-* files only */
15376 if (type1
== unsigned_intDI_type_node
)
15377 return intDI_type_node
;
15378 if (type1
== unsigned_intSI_type_node
)
15379 return intSI_type_node
;
15380 if (type1
== unsigned_intHI_type_node
)
15381 return intHI_type_node
;
15382 if (type1
== unsigned_intQI_type_node
)
15383 return intQI_type_node
;
15386 type2
= type_for_size (TYPE_PRECISION (type1
), 0);
15387 if (type2
!= NULL_TREE
)
15390 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15392 type2
= ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
15394 if (type1
== type2
)
15395 return ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15401 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15402 or validate its data type for an `if' or `while' statement or ?..: exp.
15404 This preparation consists of taking the ordinary
15405 representation of an expression expr and producing a valid tree
15406 boolean expression describing whether expr is nonzero. We could
15407 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15408 but we optimize comparisons, &&, ||, and !.
15410 The resulting type should always be `integer_type_node'. */
15413 truthvalue_conversion (expr
)
15416 if (TREE_CODE (expr
) == ERROR_MARK
)
15419 #if 0 /* This appears to be wrong for C++. */
15420 /* These really should return error_mark_node after 2.4 is stable.
15421 But not all callers handle ERROR_MARK properly. */
15422 switch (TREE_CODE (TREE_TYPE (expr
)))
15425 error ("struct type value used where scalar is required");
15426 return integer_zero_node
;
15429 error ("union type value used where scalar is required");
15430 return integer_zero_node
;
15433 error ("array type value used where scalar is required");
15434 return integer_zero_node
;
15441 switch (TREE_CODE (expr
))
15443 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15444 or comparison expressions as truth values at this level. */
15446 case COMPONENT_REF
:
15447 /* A one-bit unsigned bit-field is already acceptable. */
15448 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr
, 1)))
15449 && TREE_UNSIGNED (TREE_OPERAND (expr
, 1)))
15455 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15456 or comparison expressions as truth values at this level. */
15458 if (integer_zerop (TREE_OPERAND (expr
, 1)))
15459 return build_unary_op (TRUTH_NOT_EXPR
, TREE_OPERAND (expr
, 0), 0);
15461 case NE_EXPR
: case LE_EXPR
: case GE_EXPR
: case LT_EXPR
: case GT_EXPR
:
15462 case TRUTH_ANDIF_EXPR
:
15463 case TRUTH_ORIF_EXPR
:
15464 case TRUTH_AND_EXPR
:
15465 case TRUTH_OR_EXPR
:
15466 case TRUTH_XOR_EXPR
:
15467 TREE_TYPE (expr
) = integer_type_node
;
15474 return integer_zerop (expr
) ? integer_zero_node
: integer_one_node
;
15477 return real_zerop (expr
) ? integer_zero_node
: integer_one_node
;
15480 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 0)))
15481 return build (COMPOUND_EXPR
, integer_type_node
,
15482 TREE_OPERAND (expr
, 0), integer_one_node
);
15484 return integer_one_node
;
15487 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1))
15488 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
15490 truthvalue_conversion (TREE_OPERAND (expr
, 0)),
15491 truthvalue_conversion (TREE_OPERAND (expr
, 1)));
15497 /* These don't change whether an object is non-zero or zero. */
15498 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15502 /* These don't change whether an object is zero or non-zero, but
15503 we can't ignore them if their second arg has side-effects. */
15504 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1)))
15505 return build (COMPOUND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 1),
15506 truthvalue_conversion (TREE_OPERAND (expr
, 0)));
15508 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15511 /* Distribute the conversion into the arms of a COND_EXPR. */
15512 return fold (build (COND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 0),
15513 truthvalue_conversion (TREE_OPERAND (expr
, 1)),
15514 truthvalue_conversion (TREE_OPERAND (expr
, 2))));
15517 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15518 since that affects how `default_conversion' will behave. */
15519 if (TREE_CODE (TREE_TYPE (expr
)) == REFERENCE_TYPE
15520 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == REFERENCE_TYPE
)
15522 /* fall through... */
15524 /* If this is widening the argument, we can ignore it. */
15525 if (TYPE_PRECISION (TREE_TYPE (expr
))
15526 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr
, 0))))
15527 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15531 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15533 if (TARGET_FLOAT_FORMAT
== IEEE_FLOAT_FORMAT
15534 && TREE_CODE (TREE_TYPE (expr
)) == REAL_TYPE
)
15536 /* fall through... */
15538 /* This and MINUS_EXPR can be changed into a comparison of the
15540 if (TREE_TYPE (TREE_OPERAND (expr
, 0))
15541 == TREE_TYPE (TREE_OPERAND (expr
, 1)))
15542 return ffecom_2 (NE_EXPR
, integer_type_node
,
15543 TREE_OPERAND (expr
, 0),
15544 TREE_OPERAND (expr
, 1));
15545 return ffecom_2 (NE_EXPR
, integer_type_node
,
15546 TREE_OPERAND (expr
, 0),
15547 fold (build1 (NOP_EXPR
,
15548 TREE_TYPE (TREE_OPERAND (expr
, 0)),
15549 TREE_OPERAND (expr
, 1))));
15552 if (integer_onep (TREE_OPERAND (expr
, 1)))
15557 #if 0 /* No such thing in Fortran. */
15558 if (warn_parentheses
&& C_EXP_ORIGINAL_CODE (expr
) == MODIFY_EXPR
)
15559 warning ("suggest parentheses around assignment used as truth value");
15567 if (TREE_CODE (TREE_TYPE (expr
)) == COMPLEX_TYPE
)
15569 ((TREE_SIDE_EFFECTS (expr
)
15570 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
15572 truthvalue_conversion (ffecom_1 (REALPART_EXPR
,
15573 TREE_TYPE (TREE_TYPE (expr
)),
15575 truthvalue_conversion (ffecom_1 (IMAGPART_EXPR
,
15576 TREE_TYPE (TREE_TYPE (expr
)),
15579 return ffecom_2 (NE_EXPR
, integer_type_node
,
15581 convert (TREE_TYPE (expr
), integer_zero_node
));
15585 type_for_mode (mode
, unsignedp
)
15586 enum machine_mode mode
;
15593 if (mode
== TYPE_MODE (integer_type_node
))
15594 return unsignedp
? unsigned_type_node
: integer_type_node
;
15596 if (mode
== TYPE_MODE (signed_char_type_node
))
15597 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15599 if (mode
== TYPE_MODE (short_integer_type_node
))
15600 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15602 if (mode
== TYPE_MODE (long_integer_type_node
))
15603 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15605 if (mode
== TYPE_MODE (long_long_integer_type_node
))
15606 return unsignedp
? long_long_unsigned_type_node
: long_long_integer_type_node
;
15608 if (mode
== TYPE_MODE (float_type_node
))
15609 return float_type_node
;
15611 if (mode
== TYPE_MODE (double_type_node
))
15612 return double_type_node
;
15614 if (mode
== TYPE_MODE (build_pointer_type (char_type_node
)))
15615 return build_pointer_type (char_type_node
);
15617 if (mode
== TYPE_MODE (build_pointer_type (integer_type_node
)))
15618 return build_pointer_type (integer_type_node
);
15620 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
15621 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
15623 if (((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
15624 && (mode
== TYPE_MODE (t
)))
15626 if ((i
== FFEINFO_basictypeINTEGER
) && unsignedp
)
15627 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][j
];
15637 type_for_size (bits
, unsignedp
)
15641 ffeinfoKindtype kt
;
15644 if (bits
== TYPE_PRECISION (integer_type_node
))
15645 return unsignedp
? unsigned_type_node
: integer_type_node
;
15647 if (bits
== TYPE_PRECISION (signed_char_type_node
))
15648 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15650 if (bits
== TYPE_PRECISION (short_integer_type_node
))
15651 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15653 if (bits
== TYPE_PRECISION (long_integer_type_node
))
15654 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15656 if (bits
== TYPE_PRECISION (long_long_integer_type_node
))
15657 return (unsignedp
? long_long_unsigned_type_node
15658 : long_long_integer_type_node
);
15660 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15662 type_node
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15664 if ((type_node
!= NULL_TREE
) && (bits
== TYPE_PRECISION (type_node
)))
15665 return unsignedp
? ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
]
15673 unsigned_type (type
)
15676 tree type1
= TYPE_MAIN_VARIANT (type
);
15677 ffeinfoKindtype kt
;
15680 if (type1
== signed_char_type_node
|| type1
== char_type_node
)
15681 return unsigned_char_type_node
;
15682 if (type1
== integer_type_node
)
15683 return unsigned_type_node
;
15684 if (type1
== short_integer_type_node
)
15685 return short_unsigned_type_node
;
15686 if (type1
== long_integer_type_node
)
15687 return long_unsigned_type_node
;
15688 if (type1
== long_long_integer_type_node
)
15689 return long_long_unsigned_type_node
;
15690 #if 0 /* gcc/c-* files only */
15691 if (type1
== intDI_type_node
)
15692 return unsigned_intDI_type_node
;
15693 if (type1
== intSI_type_node
)
15694 return unsigned_intSI_type_node
;
15695 if (type1
== intHI_type_node
)
15696 return unsigned_intHI_type_node
;
15697 if (type1
== intQI_type_node
)
15698 return unsigned_intQI_type_node
;
15701 type2
= type_for_size (TYPE_PRECISION (type1
), 1);
15702 if (type2
!= NULL_TREE
)
15705 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15707 type2
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15709 if (type1
== type2
)
15710 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
15716 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15718 #if FFECOM_GCC_INCLUDE
15720 /* From gcc/cccp.c, the code to handle -I. */
15722 /* Skip leading "./" from a directory name.
15723 This may yield the empty string, which represents the current directory. */
15726 skip_redundant_dir_prefix (char *dir
)
15728 while (dir
[0] == '.' && dir
[1] == '/')
15729 for (dir
+= 2; *dir
== '/'; dir
++)
15731 if (dir
[0] == '.' && !dir
[1])
15736 /* The file_name_map structure holds a mapping of file names for a
15737 particular directory. This mapping is read from the file named
15738 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15739 map filenames on a file system with severe filename restrictions,
15740 such as DOS. The format of the file name map file is just a series
15741 of lines with two tokens on each line. The first token is the name
15742 to map, and the second token is the actual name to use. */
15744 struct file_name_map
15746 struct file_name_map
*map_next
;
15751 #define FILE_NAME_MAP_FILE "header.gcc"
15753 /* Current maximum length of directory names in the search path
15754 for include files. (Altered as we get more of them.) */
15756 static int max_include_len
= 0;
15758 struct file_name_list
15760 struct file_name_list
*next
;
15762 /* Mapping of file names for this directory. */
15763 struct file_name_map
*name_map
;
15764 /* Non-zero if name_map is valid. */
15768 static struct file_name_list
*include
= NULL
; /* First dir to search */
15769 static struct file_name_list
*last_include
= NULL
; /* Last in chain */
15771 /* I/O buffer structure.
15772 The `fname' field is nonzero for source files and #include files
15773 and for the dummy text used for -D and -U.
15774 It is zero for rescanning results of macro expansion
15775 and for expanding macro arguments. */
15776 #define INPUT_STACK_MAX 400
15777 static struct file_buf
{
15779 /* Filename specified with #line command. */
15780 char *nominal_fname
;
15781 /* Record where in the search path this file was found.
15782 For #include_next. */
15783 struct file_name_list
*dir
;
15785 ffewhereColumn column
;
15786 } instack
[INPUT_STACK_MAX
];
15788 static int last_error_tick
= 0; /* Incremented each time we print it. */
15789 static int input_file_stack_tick
= 0; /* Incremented when status changes. */
15791 /* Current nesting level of input sources.
15792 `instack[indepth]' is the level currently being read. */
15793 static int indepth
= -1;
15795 typedef struct file_buf FILE_BUF
;
15797 typedef unsigned char U_CHAR
;
15799 /* table to tell if char can be part of a C identifier. */
15800 U_CHAR is_idchar
[256];
15801 /* table to tell if char can be first char of a c identifier. */
15802 U_CHAR is_idstart
[256];
15803 /* table to tell if c is horizontal space. */
15804 U_CHAR is_hor_space
[256];
15805 /* table to tell if c is horizontal or vertical space. */
15806 static U_CHAR is_space
[256];
15808 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15809 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15811 /* Nonzero means -I- has been seen,
15812 so don't look for #include "foo" the source-file directory. */
15813 static int ignore_srcdir
;
15815 #ifndef INCLUDE_LEN_FUDGE
15816 #define INCLUDE_LEN_FUDGE 0
15819 static void append_include_chain (struct file_name_list
*first
,
15820 struct file_name_list
*last
);
15821 static FILE *open_include_file (char *filename
,
15822 struct file_name_list
*searchptr
);
15823 static void print_containing_files (ffebadSeverity sev
);
15824 static char *skip_redundant_dir_prefix (char *);
15825 static char *read_filename_string (int ch
, FILE *f
);
15826 static struct file_name_map
*read_name_map (char *dirname
);
15827 static char *savestring (char *input
);
15829 /* Append a chain of `struct file_name_list's
15830 to the end of the main include chain.
15831 FIRST is the beginning of the chain to append, and LAST is the end. */
15834 append_include_chain (first
, last
)
15835 struct file_name_list
*first
, *last
;
15837 struct file_name_list
*dir
;
15839 if (!first
|| !last
)
15845 last_include
->next
= first
;
15847 for (dir
= first
; ; dir
= dir
->next
) {
15848 int len
= strlen (dir
->fname
) + INCLUDE_LEN_FUDGE
;
15849 if (len
> max_include_len
)
15850 max_include_len
= len
;
15856 last_include
= last
;
15859 /* Try to open include file FILENAME. SEARCHPTR is the directory
15860 being tried from the include file search path. This function maps
15861 filenames on file systems based on information read by
15865 open_include_file (filename
, searchptr
)
15867 struct file_name_list
*searchptr
;
15869 register struct file_name_map
*map
;
15870 register char *from
;
15873 if (searchptr
&& ! searchptr
->got_name_map
)
15875 searchptr
->name_map
= read_name_map (searchptr
->fname
15876 ? searchptr
->fname
: ".");
15877 searchptr
->got_name_map
= 1;
15880 /* First check the mapping for the directory we are using. */
15881 if (searchptr
&& searchptr
->name_map
)
15884 if (searchptr
->fname
)
15885 from
+= strlen (searchptr
->fname
) + 1;
15886 for (map
= searchptr
->name_map
; map
; map
= map
->map_next
)
15888 if (! strcmp (map
->map_from
, from
))
15890 /* Found a match. */
15891 return fopen (map
->map_to
, "r");
15896 /* Try to find a mapping file for the particular directory we are
15897 looking in. Thus #include <sys/types.h> will look up sys/types.h
15898 in /usr/include/header.gcc and look up types.h in
15899 /usr/include/sys/header.gcc. */
15900 p
= rindex (filename
, '/');
15901 #ifdef DIR_SEPARATOR
15902 if (! p
) p
= rindex (filename
, DIR_SEPARATOR
);
15904 char *tmp
= rindex (filename
, DIR_SEPARATOR
);
15905 if (tmp
!= NULL
&& tmp
> p
) p
= tmp
;
15911 && searchptr
->fname
15912 && strlen (searchptr
->fname
) == (size_t) (p
- filename
)
15913 && ! strncmp (searchptr
->fname
, filename
, (int) (p
- filename
)))
15915 /* FILENAME is in SEARCHPTR, which we've already checked. */
15916 return fopen (filename
, "r");
15922 map
= read_name_map (".");
15926 dir
= (char *) xmalloc (p
- filename
+ 1);
15927 memcpy (dir
, filename
, p
- filename
);
15928 dir
[p
- filename
] = '\0';
15930 map
= read_name_map (dir
);
15933 for (; map
; map
= map
->map_next
)
15934 if (! strcmp (map
->map_from
, from
))
15935 return fopen (map
->map_to
, "r");
15937 return fopen (filename
, "r");
15940 /* Print the file names and line numbers of the #include
15941 commands which led to the current file. */
15944 print_containing_files (ffebadSeverity sev
)
15946 FILE_BUF
*ip
= NULL
;
15952 /* If stack of files hasn't changed since we last printed
15953 this info, don't repeat it. */
15954 if (last_error_tick
== input_file_stack_tick
)
15957 for (i
= indepth
; i
>= 0; i
--)
15958 if (instack
[i
].fname
!= NULL
) {
15963 /* Give up if we don't find a source file. */
15967 /* Find the other, outer source files. */
15968 for (i
--; i
>= 0; i
--)
15969 if (instack
[i
].fname
!= NULL
)
15975 str1
= "In file included";
15987 ffebad_start_msg ("%A from %B at %0%C", sev
);
15988 ffebad_here (0, ip
->line
, ip
->column
);
15989 ffebad_string (str1
);
15990 ffebad_string (ip
->nominal_fname
);
15991 ffebad_string (str2
);
15995 /* Record we have printed the status as of this time. */
15996 last_error_tick
= input_file_stack_tick
;
15999 /* Read a space delimited string of unlimited length from a stdio
16003 read_filename_string (ch
, f
)
16011 set
= alloc
= xmalloc (len
+ 1);
16012 if (! is_space
[ch
])
16015 while ((ch
= getc (f
)) != EOF
&& ! is_space
[ch
])
16017 if (set
- alloc
== len
)
16020 alloc
= xrealloc (alloc
, len
+ 1);
16021 set
= alloc
+ len
/ 2;
16031 /* Read the file name map file for DIRNAME. */
16033 static struct file_name_map
*
16034 read_name_map (dirname
)
16037 /* This structure holds a linked list of file name maps, one per
16039 struct file_name_map_list
16041 struct file_name_map_list
*map_list_next
;
16042 char *map_list_name
;
16043 struct file_name_map
*map_list_map
;
16045 static struct file_name_map_list
*map_list
;
16046 register struct file_name_map_list
*map_list_ptr
;
16050 int separator_needed
;
16052 dirname
= skip_redundant_dir_prefix (dirname
);
16054 for (map_list_ptr
= map_list
; map_list_ptr
;
16055 map_list_ptr
= map_list_ptr
->map_list_next
)
16056 if (! strcmp (map_list_ptr
->map_list_name
, dirname
))
16057 return map_list_ptr
->map_list_map
;
16059 map_list_ptr
= ((struct file_name_map_list
*)
16060 xmalloc (sizeof (struct file_name_map_list
)));
16061 map_list_ptr
->map_list_name
= savestring (dirname
);
16062 map_list_ptr
->map_list_map
= NULL
;
16064 dirlen
= strlen (dirname
);
16065 separator_needed
= dirlen
!= 0 && dirname
[dirlen
- 1] != '/';
16066 name
= (char *) xmalloc (dirlen
+ strlen (FILE_NAME_MAP_FILE
) + 2);
16067 strcpy (name
, dirname
);
16068 name
[dirlen
] = '/';
16069 strcpy (name
+ dirlen
+ separator_needed
, FILE_NAME_MAP_FILE
);
16070 f
= fopen (name
, "r");
16073 map_list_ptr
->map_list_map
= NULL
;
16078 while ((ch
= getc (f
)) != EOF
)
16081 struct file_name_map
*ptr
;
16085 from
= read_filename_string (ch
, f
);
16086 while ((ch
= getc (f
)) != EOF
&& is_hor_space
[ch
])
16088 to
= read_filename_string (ch
, f
);
16090 ptr
= ((struct file_name_map
*)
16091 xmalloc (sizeof (struct file_name_map
)));
16092 ptr
->map_from
= from
;
16094 /* Make the real filename absolute. */
16099 ptr
->map_to
= xmalloc (dirlen
+ strlen (to
) + 2);
16100 strcpy (ptr
->map_to
, dirname
);
16101 ptr
->map_to
[dirlen
] = '/';
16102 strcpy (ptr
->map_to
+ dirlen
+ separator_needed
, to
);
16106 ptr
->map_next
= map_list_ptr
->map_list_map
;
16107 map_list_ptr
->map_list_map
= ptr
;
16109 while ((ch
= getc (f
)) != '\n')
16116 map_list_ptr
->map_list_next
= map_list
;
16117 map_list
= map_list_ptr
;
16119 return map_list_ptr
->map_list_map
;
16126 unsigned size
= strlen (input
);
16127 char *output
= xmalloc (size
+ 1);
16128 strcpy (output
, input
);
16133 ffecom_file_ (char *name
)
16137 /* Do partial setup of input buffer for the sake of generating
16138 early #line directives (when -g is in effect). */
16140 fp
= &instack
[++indepth
];
16141 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
16144 fp
->nominal_fname
= fp
->fname
= name
;
16147 /* Initialize syntactic classifications of characters. */
16150 ffecom_initialize_char_syntax_ ()
16155 * Set up is_idchar and is_idstart tables. These should be
16156 * faster than saying (is_alpha (c) || c == '_'), etc.
16157 * Set up these things before calling any routines tthat
16160 for (i
= 'a'; i
<= 'z'; i
++) {
16161 is_idchar
[i
- 'a' + 'A'] = 1;
16163 is_idstart
[i
- 'a' + 'A'] = 1;
16166 for (i
= '0'; i
<= '9'; i
++)
16168 is_idchar
['_'] = 1;
16169 is_idstart
['_'] = 1;
16171 /* horizontal space table */
16172 is_hor_space
[' '] = 1;
16173 is_hor_space
['\t'] = 1;
16174 is_hor_space
['\v'] = 1;
16175 is_hor_space
['\f'] = 1;
16176 is_hor_space
['\r'] = 1;
16179 is_space
['\t'] = 1;
16180 is_space
['\v'] = 1;
16181 is_space
['\f'] = 1;
16182 is_space
['\n'] = 1;
16183 is_space
['\r'] = 1;
16187 ffecom_close_include_ (FILE *f
)
16192 input_file_stack_tick
++;
16194 ffewhere_line_kill (instack
[indepth
].line
);
16195 ffewhere_column_kill (instack
[indepth
].column
);
16199 ffecom_decode_include_option_ (char *spec
)
16201 struct file_name_list
*dirtmp
;
16203 if (! ignore_srcdir
&& !strcmp (spec
, "-"))
16207 dirtmp
= (struct file_name_list
*)
16208 xmalloc (sizeof (struct file_name_list
));
16209 dirtmp
->next
= 0; /* New one goes on the end */
16211 dirtmp
->fname
= spec
;
16213 fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16214 dirtmp
->got_name_map
= 0;
16215 append_include_chain (dirtmp
, dirtmp
);
16220 /* Open INCLUDEd file. */
16223 ffecom_open_include_ (char *name
, ffewhereLine l
, ffewhereColumn c
)
16226 size_t flen
= strlen (fbeg
);
16227 struct file_name_list
*search_start
= include
; /* Chain of dirs to search */
16228 struct file_name_list dsp
[1]; /* First in chain, if #include "..." */
16229 struct file_name_list
*searchptr
= 0;
16230 char *fname
; /* Dynamically allocated fname buffer */
16237 dsp
[0].fname
= NULL
;
16239 /* If -I- was specified, don't search current dir, only spec'd ones. */
16240 if (!ignore_srcdir
)
16242 for (fp
= &instack
[indepth
]; fp
>= instack
; fp
--)
16248 if ((nam
= fp
->nominal_fname
) != NULL
)
16250 /* Found a named file. Figure out dir of the file,
16251 and put it in front of the search list. */
16252 dsp
[0].next
= search_start
;
16253 search_start
= dsp
;
16255 ep
= rindex (nam
, '/');
16256 #ifdef DIR_SEPARATOR
16257 if (ep
== NULL
) ep
= rindex (nam
, DIR_SEPARATOR
);
16259 char *tmp
= rindex (nam
, DIR_SEPARATOR
);
16260 if (tmp
!= NULL
&& tmp
> ep
) ep
= tmp
;
16264 ep
= rindex (nam
, ']');
16265 if (ep
== NULL
) ep
= rindex (nam
, '>');
16266 if (ep
== NULL
) ep
= rindex (nam
, ':');
16267 if (ep
!= NULL
) ep
++;
16272 dsp
[0].fname
= (char *) xmalloc (n
+ 1);
16273 strncpy (dsp
[0].fname
, nam
, n
);
16274 dsp
[0].fname
[n
] = '\0';
16275 if (n
+ INCLUDE_LEN_FUDGE
> max_include_len
)
16276 max_include_len
= n
+ INCLUDE_LEN_FUDGE
;
16279 dsp
[0].fname
= NULL
; /* Current directory */
16280 dsp
[0].got_name_map
= 0;
16286 /* Allocate this permanently, because it gets stored in the definitions
16288 fname
= xmalloc (max_include_len
+ flen
+ 4);
16289 /* + 2 above for slash and terminating null. */
16290 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16293 /* If specified file name is absolute, just open it. */
16296 #ifdef DIR_SEPARATOR
16297 || *fbeg
== DIR_SEPARATOR
16301 strncpy (fname
, (char *) fbeg
, flen
);
16303 f
= open_include_file (fname
, NULL_PTR
);
16309 /* Search directory path, trying to open the file.
16310 Copy each filename tried into FNAME. */
16312 for (searchptr
= search_start
; searchptr
; searchptr
= searchptr
->next
)
16314 if (searchptr
->fname
)
16316 /* The empty string in a search path is ignored.
16317 This makes it possible to turn off entirely
16318 a standard piece of the list. */
16319 if (searchptr
->fname
[0] == 0)
16321 strcpy (fname
, skip_redundant_dir_prefix (searchptr
->fname
));
16322 if (fname
[0] && fname
[strlen (fname
) - 1] != '/')
16323 strcat (fname
, "/");
16324 fname
[strlen (fname
) + flen
] = 0;
16329 strncat (fname
, fbeg
, flen
);
16331 /* Change this 1/2 Unix 1/2 VMS file specification into a
16332 full VMS file specification */
16333 if (searchptr
->fname
&& (searchptr
->fname
[0] != 0))
16335 /* Fix up the filename */
16336 hack_vms_include_specification (fname
);
16340 /* This is a normal VMS filespec, so use it unchanged. */
16341 strncpy (fname
, (char *) fbeg
, flen
);
16343 #if 0 /* Not for g77. */
16344 /* if it's '#include filename', add the missing .h */
16345 if (index (fname
, '.') == NULL
)
16346 strcat (fname
, ".h");
16350 f
= open_include_file (fname
, searchptr
);
16352 if (f
== NULL
&& errno
== EACCES
)
16354 print_containing_files (FFEBAD_severityWARNING
);
16355 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16356 FFEBAD_severityWARNING
);
16357 ffebad_string (fname
);
16358 ffebad_here (0, l
, c
);
16369 /* A file that was not found. */
16371 strncpy (fname
, (char *) fbeg
, flen
);
16373 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE
));
16374 ffebad_start (FFEBAD_OPEN_INCLUDE
);
16375 ffebad_here (0, l
, c
);
16376 ffebad_string (fname
);
16380 if (dsp
[0].fname
!= NULL
)
16381 free (dsp
[0].fname
);
16386 if (indepth
>= (INPUT_STACK_MAX
- 1))
16388 print_containing_files (FFEBAD_severityFATAL
);
16389 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16390 FFEBAD_severityFATAL
);
16391 ffebad_string (fname
);
16392 ffebad_here (0, l
, c
);
16397 instack
[indepth
].line
= ffewhere_line_use (l
);
16398 instack
[indepth
].column
= ffewhere_column_use (c
);
16400 fp
= &instack
[indepth
+ 1];
16401 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
16402 fp
->nominal_fname
= fp
->fname
= fname
;
16403 fp
->dir
= searchptr
;
16406 input_file_stack_tick
++;
16410 #endif /* FFECOM_GCC_INCLUDE */