1 /* com.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995-1997 Free Software Foundation, Inc.
3 Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
5 This file is part of GNU Fortran.
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
26 Contains compiler-specific functions.
31 /* Understanding this module means understanding the interface between
32 the g77 front end and the gcc back end (or, perhaps, some other
33 back end). In here are the functions called by the front end proper
34 to notify whatever back end is in place about certain things, and
35 also the back-end-specific functions. It's a bear to deal with, so
36 lately I've been trying to simplify things, especially with regard
37 to the gcc-back-end-specific stuff.
39 Building expressions generally seems quite easy, but building decls
40 has been challenging and is undergoing revision. gcc has several
43 TYPE_DECL -- a type (int, float, struct, function, etc.)
44 CONST_DECL -- a constant of some type other than function
45 LABEL_DECL -- a variable or a constant?
46 PARM_DECL -- an argument to a function (a variable that is a dummy)
47 RESULT_DECL -- the return value of a function (a variable)
48 VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
49 FUNCTION_DECL -- a function (either the actual function or an extern ref)
50 FIELD_DECL -- a field in a struct or union (goes into types)
52 g77 has a set of functions that somewhat parallels the gcc front end
53 when it comes to building decls:
55 Internal Function (one we define, not just declare as extern):
57 yes = suspend_momentary ();
58 if (is_nested) push_f_function_context ();
59 start_function (get_identifier ("function_name"), function_type,
60 is_nested, is_public);
61 // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
62 store_parm_decls (is_main_program);
63 ffecom_start_compstmt_ ();
64 // for stmts and decls inside function, do appropriate things;
65 ffecom_end_compstmt_ ();
66 finish_function (is_nested);
67 if (is_nested) pop_f_function_context ();
68 if (is_nested) resume_momentary (yes);
74 yes = suspend_momentary ();
75 // fill in external, public, static, &c for decl, and
76 // set DECL_INITIAL to error_mark_node if going to initialize
77 // set is_top_level TRUE only if not at top level and decl
78 // must go in top level (i.e. not within current function decl context)
79 d = start_decl (decl, is_top_level);
80 init = ...; // if have initializer
81 finish_decl (d, init, is_top_level);
82 resume_momentary (yes);
88 #if FFECOM_targetCURRENT == FFECOM_targetGCC
94 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
96 #define FFECOM_GCC_INCLUDE 1 /* Enable -I. */
98 /* BEGIN stuff from gcc/cccp.c. */
100 /* The following symbols should be autoconfigured:
107 In the mean time, we'll get by with approximations based
108 on existing GCC configuration symbols. */
111 # ifndef HAVE_STDLIB_H
112 # define HAVE_STDLIB_H 1
114 # ifndef HAVE_UNISTD_H
115 # define HAVE_UNISTD_H 1
117 # ifndef STDC_HEADERS
118 # define STDC_HEADERS 1
120 #endif /* defined (POSIX) */
122 #if defined (POSIX) || (defined (USG) && !defined (VMS))
123 # ifndef HAVE_FCNTL_H
124 # define HAVE_FCNTL_H 1
131 # if TIME_WITH_SYS_TIME
132 # include <sys/time.h>
136 # include <sys/time.h>
141 # include <sys/resource.h>
148 /* This defines "errno" properly for VMS, and gives us EACCES. */
164 /* VMS-specific definitions */
167 #define O_RDONLY 0 /* Open arg for Read/Only */
168 #define O_WRONLY 1 /* Open arg for Write/Only */
169 #define read(fd,buf,size) VMS_read (fd,buf,size)
170 #define write(fd,buf,size) VMS_write (fd,buf,size)
171 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
172 #define fopen(fname,mode) VMS_fopen (fname,mode)
173 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
174 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
175 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
176 static int VMS_fstat (), VMS_stat ();
177 static char * VMS_strncat ();
178 static int VMS_read ();
179 static int VMS_write ();
180 static int VMS_open ();
181 static FILE * VMS_fopen ();
182 static FILE * VMS_freopen ();
183 static void hack_vms_include_specification ();
184 typedef struct { unsigned :16, :16, :16; } vms_ino_t
;
185 #define ino_t vms_ino_t
186 #define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */
188 #define BSTRING /* VMS/GCC supplies the bstring routines */
189 #endif /* __GNUC__ */
196 /* END stuff from gcc/cccp.c. */
199 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
216 /* Externals defined here. */
218 #define FFECOM_FASTER_ARRAY_REFS 0 /* Generates faster code? */
220 #if FFECOM_targetCURRENT == FFECOM_targetGCC
222 /* tree.h declares a bunch of stuff that it expects the front end to
223 define. Here are the definitions, which in the C front end are
224 found in the file c-decl.c. */
226 tree integer_zero_node
;
227 tree integer_one_node
;
228 tree null_pointer_node
;
229 tree error_mark_node
;
231 tree integer_type_node
;
232 tree unsigned_type_node
;
234 tree current_function_decl
;
236 /* ~~tree.h SHOULD declare this, because toplev.c and dwarfout.c reference
239 char *language_string
= "GNU F77";
241 /* These definitions parallel those in c-decl.c so that code from that
242 module can be used pretty much as is. Much of these defs aren't
243 otherwise used, i.e. by g77 code per se, except some of them are used
244 to build some of them that are. The ones that are global (i.e. not
245 "static") are those that ste.c and such might use (directly
246 or by using com macros that reference them in their definitions). */
248 static tree short_integer_type_node
;
249 tree long_integer_type_node
;
250 static tree long_long_integer_type_node
;
252 static tree short_unsigned_type_node
;
253 static tree long_unsigned_type_node
;
254 static tree long_long_unsigned_type_node
;
256 static tree unsigned_char_type_node
;
257 static tree signed_char_type_node
;
259 static tree float_type_node
;
260 static tree double_type_node
;
261 static tree complex_float_type_node
;
262 tree complex_double_type_node
;
263 static tree long_double_type_node
;
264 static tree complex_integer_type_node
;
265 static tree complex_long_double_type_node
;
267 tree string_type_node
;
269 static tree double_ftype_double
;
270 static tree float_ftype_float
;
271 static tree ldouble_ftype_ldouble
;
273 /* The rest of these are inventions for g77, though there might be
274 similar things in the C front end. As they are found, these
275 inventions should be renamed to be canonical. Note that only
276 the ones currently required to be global are so. */
278 static tree ffecom_tree_fun_type_void
;
279 static tree ffecom_tree_ptr_to_fun_type_void
;
281 tree ffecom_integer_type_node
; /* Abbrev for _tree_type[blah][blah]. */
282 tree ffecom_integer_zero_node
; /* Like *_*_* with g77's integer type. */
283 tree ffecom_integer_one_node
; /* " */
284 tree ffecom_tree_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
286 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
287 just use build_function_type and build_pointer_type on the
288 appropriate _tree_type array element. */
290 static tree ffecom_tree_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
291 static tree ffecom_tree_ptr_to_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
292 static tree ffecom_tree_subr_type
;
293 static tree ffecom_tree_ptr_to_subr_type
;
294 static tree ffecom_tree_blockdata_type
;
296 static tree ffecom_tree_xargc_
;
298 ffecomSymbol ffecom_symbol_null_
305 ffeinfoKindtype ffecom_pointer_kind_
= FFEINFO_basictypeNONE
;
306 ffeinfoKindtype ffecom_label_kind_
= FFEINFO_basictypeNONE
;
308 int ffecom_f2c_typecode_
[FFEINFO_basictype
][FFEINFO_kindtype
];
309 tree ffecom_f2c_integer_type_node
;
310 tree ffecom_f2c_ptr_to_integer_type_node
;
311 tree ffecom_f2c_address_type_node
;
312 tree ffecom_f2c_real_type_node
;
313 tree ffecom_f2c_ptr_to_real_type_node
;
314 tree ffecom_f2c_doublereal_type_node
;
315 tree ffecom_f2c_complex_type_node
;
316 tree ffecom_f2c_doublecomplex_type_node
;
317 tree ffecom_f2c_longint_type_node
;
318 tree ffecom_f2c_logical_type_node
;
319 tree ffecom_f2c_flag_type_node
;
320 tree ffecom_f2c_ftnlen_type_node
;
321 tree ffecom_f2c_ftnlen_zero_node
;
322 tree ffecom_f2c_ftnlen_one_node
;
323 tree ffecom_f2c_ftnlen_two_node
;
324 tree ffecom_f2c_ptr_to_ftnlen_type_node
;
325 tree ffecom_f2c_ftnint_type_node
;
326 tree ffecom_f2c_ptr_to_ftnint_type_node
;
327 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
329 /* Simple definitions and enumerations. */
331 #ifndef FFECOM_sizeMAXSTACKITEM
332 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
333 larger than this # bytes
334 off stack if possible. */
337 /* For systems that have large enough stacks, they should define
338 this to 0, and here, for ease of use later on, we just undefine
341 #if FFECOM_sizeMAXSTACKITEM == 0
342 #undef FFECOM_sizeMAXSTACKITEM
348 FFECOM_rttypeVOIDSTAR_
, /* C's `void *' type. */
349 FFECOM_rttypeFTNINT_
, /* f2c's `ftnint' type. */
350 FFECOM_rttypeINTEGER_
, /* f2c's `integer' type. */
351 FFECOM_rttypeLONGINT_
, /* f2c's `longint' type. */
352 FFECOM_rttypeLOGICAL_
, /* f2c's `logical' type. */
353 FFECOM_rttypeREAL_F2C_
, /* f2c's `real' returned as `double'. */
354 FFECOM_rttypeREAL_GNU_
, /* `real' returned as such. */
355 FFECOM_rttypeCOMPLEX_F2C_
, /* f2c's `complex' returned via 1st arg. */
356 FFECOM_rttypeCOMPLEX_GNU_
, /* f2c's `complex' returned directly. */
357 FFECOM_rttypeDOUBLE_
, /* C's `double' type. */
358 FFECOM_rttypeDOUBLEREAL_
, /* f2c's `doublereal' type. */
359 FFECOM_rttypeDBLCMPLX_F2C_
, /* f2c's `doublecomplex' returned via 1st arg. */
360 FFECOM_rttypeDBLCMPLX_GNU_
, /* f2c's `doublecomplex' returned directly. */
361 FFECOM_rttypeCHARACTER_
, /* f2c `char *'/`ftnlen' pair. */
365 /* Internal typedefs. */
367 #if FFECOM_targetCURRENT == FFECOM_targetGCC
368 typedef struct _ffecom_concat_list_ ffecomConcatList_
;
369 typedef struct _ffecom_temp_
*ffecomTemp_
;
370 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
372 /* Private include files. */
375 /* Internal structure definitions. */
377 #if FFECOM_targetCURRENT == FFECOM_targetGCC
378 struct _ffecom_concat_list_
383 ffetargetCharacterSize minlen
;
384 ffetargetCharacterSize maxlen
;
390 tree type
; /* Base type (w/o size/array applied). */
392 ffetargetCharacterSize size
;
398 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
400 /* Static functions (internal). */
402 #if FFECOM_targetCURRENT == FFECOM_targetGCC
403 static tree
ffecom_arglist_expr_ (char *argstring
, ffebld args
);
404 static tree
ffecom_widest_expr_type_ (ffebld list
);
405 static bool ffecom_overlap_ (tree dest_decl
, tree dest_offset
,
406 tree dest_size
, tree source_tree
,
407 ffebld source
, bool scalar_arg
);
408 static bool ffecom_args_overlapping_ (tree dest_tree
, ffebld dest
,
409 tree args
, tree callee_commons
,
411 static tree
ffecom_build_f2c_string_ (int i
, char *s
);
412 static tree
ffecom_call_ (tree fn
, ffeinfoKindtype kt
,
413 bool is_f2c_complex
, tree type
,
414 tree args
, tree dest_tree
,
415 ffebld dest
, bool *dest_used
,
416 tree callee_commons
, bool scalar_args
);
417 static tree
ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
,
418 bool is_f2c_complex
, tree type
,
419 ffebld left
, ffebld right
,
420 tree dest_tree
, ffebld dest
,
421 bool *dest_used
, tree callee_commons
,
423 static void ffecom_char_args_x_ (tree
*xitem
, tree
*length
,
424 ffebld expr
, bool with_null
);
425 static tree
ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
);
426 static tree
ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
);
427 static ffecomConcatList_
428 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
,
430 ffetargetCharacterSize max
);
431 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist
);
432 static ffecomConcatList_
ffecom_concat_list_new_ (ffebld expr
,
433 ffetargetCharacterSize max
);
434 static void ffecom_debug_kludge_ (tree aggr
, char *aggr_type
, ffesymbol member
,
435 tree member_type
, ffetargetOffset offset
);
436 static void ffecom_do_entry_ (ffesymbol fn
, int entrynum
);
437 static tree
ffecom_expr_ (ffebld expr
, tree type_tree
, tree dest_tree
,
438 ffebld dest
, bool *dest_used
,
440 static tree
ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
441 ffebld dest
, bool *dest_used
);
442 static tree
ffecom_expr_power_integer_ (ffebld left
, ffebld right
);
443 static void ffecom_expr_transform_ (ffebld expr
);
444 static void ffecom_f2c_make_type_ (tree
*type
, int tcode
, char *name
);
445 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
447 static ffeglobal
ffecom_finish_global_ (ffeglobal global
);
448 static ffesymbol
ffecom_finish_symbol_transform_ (ffesymbol s
);
449 static tree
ffecom_get_appended_identifier_ (char us
, char *text
);
450 static tree
ffecom_get_external_identifier_ (ffesymbol s
);
451 static tree
ffecom_get_identifier_ (char *text
);
452 static tree
ffecom_gen_sfuncdef_ (ffesymbol s
,
455 static char *ffecom_gfrt_args_ (ffecomGfrt ix
);
456 static tree
ffecom_gfrt_tree_ (ffecomGfrt ix
);
457 static tree
ffecom_init_zero_ (tree decl
);
458 static tree
ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
460 static tree
ffecom_intrinsic_len_ (ffebld expr
);
461 static void ffecom_let_char_ (tree dest_tree
,
463 ffetargetCharacterSize dest_size
,
465 static void ffecom_make_gfrt_ (ffecomGfrt ix
);
466 static void ffecom_member_phase1_ (ffestorag mst
, ffestorag st
);
467 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
468 static void ffecom_member_phase2_ (ffestorag mst
, ffestorag st
);
470 static void ffecom_push_dummy_decls_ (ffebld dumlist
,
472 static void ffecom_start_progunit_ (void);
473 static ffesymbol
ffecom_sym_transform_ (ffesymbol s
);
474 static ffesymbol
ffecom_sym_transform_assign_ (ffesymbol s
);
475 static void ffecom_transform_common_ (ffesymbol s
);
476 static void ffecom_transform_equiv_ (ffestorag st
);
477 static tree
ffecom_transform_namelist_ (ffesymbol s
);
478 static void ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
480 static void ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
481 tree
*size
, tree tree
);
482 static tree
ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
483 tree dest_tree
, ffebld dest
,
485 static tree
ffecom_type_localvar_ (ffesymbol s
,
488 static tree
ffecom_type_namelist_ (void);
490 static tree
ffecom_type_permanent_copy_ (tree t
);
492 static tree
ffecom_type_vardesc_ (void);
493 static tree
ffecom_vardesc_ (ffebld expr
);
494 static tree
ffecom_vardesc_array_ (ffesymbol s
);
495 static tree
ffecom_vardesc_dims_ (ffesymbol s
);
496 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
498 /* These are static functions that parallel those found in the C front
499 end and thus have the same names. */
501 #if FFECOM_targetCURRENT == FFECOM_targetGCC
502 static void bison_rule_compstmt_ (void);
503 static void bison_rule_pushlevel_ (void);
504 static tree
builtin_function (char *name
, tree type
,
505 enum built_in_function function_code
,
507 static int duplicate_decls (tree newdecl
, tree olddecl
);
508 static void finish_decl (tree decl
, tree init
, bool is_top_level
);
509 static void finish_function (int nested
);
510 static char *lang_printable_name (tree decl
, int v
);
511 static tree
lookup_name_current_level (tree name
);
512 static struct binding_level
*make_binding_level (void);
513 static void pop_f_function_context (void);
514 static void push_f_function_context (void);
515 static void push_parm_decl (tree parm
);
516 static tree
pushdecl_top_level (tree decl
);
517 static tree
storedecls (tree decls
);
518 static void store_parm_decls (int is_main_program
);
519 static tree
start_decl (tree decl
, bool is_top_level
);
520 static void start_function (tree name
, tree type
, int nested
, int public);
521 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
522 #if FFECOM_GCC_INCLUDE
523 static void ffecom_file_ (char *name
);
524 static void ffecom_initialize_char_syntax_ (void);
525 static void ffecom_close_include_ (FILE *f
);
526 static int ffecom_decode_include_option_ (char *spec
);
527 static FILE *ffecom_open_include_ (char *name
, ffewhereLine l
,
529 #endif /* FFECOM_GCC_INCLUDE */
531 /* Static objects accessed by functions in this module. */
533 static ffesymbol ffecom_primary_entry_
= NULL
;
534 static ffesymbol ffecom_nested_entry_
= NULL
;
535 static ffeinfoKind ffecom_primary_entry_kind_
;
536 static bool ffecom_primary_entry_is_proc_
;
537 #if FFECOM_targetCURRENT == FFECOM_targetGCC
538 static tree ffecom_outer_function_decl_
;
539 static tree ffecom_previous_function_decl_
;
540 static tree ffecom_which_entrypoint_decl_
;
541 static ffecomTemp_ ffecom_latest_temp_
;
542 static int ffecom_pending_calls_
= 0;
543 static tree ffecom_float_zero_
= NULL_TREE
;
544 static tree ffecom_float_half_
= NULL_TREE
;
545 static tree ffecom_double_zero_
= NULL_TREE
;
546 static tree ffecom_double_half_
= NULL_TREE
;
547 static tree ffecom_func_result_
;/* For functions. */
548 static tree ffecom_func_length_
;/* For CHARACTER fns. */
549 static ffebld ffecom_list_blockdata_
;
550 static ffebld ffecom_list_common_
;
551 static ffebld ffecom_master_arglist_
;
552 static ffeinfoBasictype ffecom_master_bt_
;
553 static ffeinfoKindtype ffecom_master_kt_
;
554 static ffetargetCharacterSize ffecom_master_size_
;
555 static int ffecom_num_fns_
= 0;
556 static int ffecom_num_entrypoints_
= 0;
557 static bool ffecom_is_altreturning_
= FALSE
;
558 static tree ffecom_multi_type_node_
;
559 static tree ffecom_multi_retval_
;
561 ffecom_multi_fields_
[FFEINFO_basictype
][FFEINFO_kindtype
];
562 static bool ffecom_member_namelisted_
; /* _member_phase1_ namelisted? */
563 static bool ffecom_doing_entry_
= FALSE
;
564 static bool ffecom_transform_only_dummies_
= FALSE
;
566 /* Holds pointer-to-function expressions. */
568 static tree ffecom_gfrt_
[FFECOM_gfrt
]
571 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE,
572 #include "com-rt.def"
576 /* Holds the external names of the functions. */
578 static char *ffecom_gfrt_name_
[FFECOM_gfrt
]
581 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME,
582 #include "com-rt.def"
586 /* Whether the function returns. */
588 static bool ffecom_gfrt_volatile_
[FFECOM_gfrt
]
591 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE,
592 #include "com-rt.def"
596 /* Whether the function returns type complex. */
598 static bool ffecom_gfrt_complex_
[FFECOM_gfrt
]
601 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX,
602 #include "com-rt.def"
606 /* Type code for the function return value. */
608 static ffecomRttype_ ffecom_gfrt_type_
[FFECOM_gfrt
]
611 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE,
612 #include "com-rt.def"
616 /* String of codes for the function's arguments. */
618 static char *ffecom_gfrt_argstring_
[FFECOM_gfrt
]
621 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS,
622 #include "com-rt.def"
625 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
627 /* Internal macros. */
629 #if FFECOM_targetCURRENT == FFECOM_targetGCC
631 /* We let tm.h override the types used here, to handle trivial differences
632 such as the choice of unsigned int or long unsigned int for size_t.
633 When machines start needing nontrivial differences in the size type,
634 it would be best to do something here to figure out automatically
635 from other information what type to use. */
637 /* NOTE: g77 currently doesn't use these; see setting of sizetype and
638 change that if you need to. -- jcb 09/01/91. */
641 #define SIZE_TYPE "long unsigned int"
645 #define WCHAR_TYPE "int"
648 #define ffecom_concat_list_count_(catlist) ((catlist).count)
649 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
650 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
651 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
653 #define ffecom_start_compstmt_ bison_rule_pushlevel_
654 #define ffecom_end_compstmt_ bison_rule_compstmt_
656 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
657 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
659 /* For each binding contour we allocate a binding_level structure
660 * which records the names defined in that contour.
663 * 1) one for each function definition,
664 * where internal declarations of the parameters appear.
666 * The current meaning of a name can be found by searching the levels from
667 * the current one out to the global one.
670 /* Note that the information in the `names' component of the global contour
671 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
675 /* A chain of _DECL nodes for all variables, constants, functions, and
676 typedef types. These are in the reverse of the order supplied. */
679 /* For each level (except not the global one), a chain of BLOCK nodes for
680 all the levels that were entered and exited one level down. */
683 /* The BLOCK node for this level, if one has been preallocated. If 0, the
684 BLOCK is allocated (if needed) when the level is popped. */
687 /* The binding level which this one is contained in (inherits from). */
688 struct binding_level
*level_chain
;
691 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
693 /* The binding level currently in effect. */
695 static struct binding_level
*current_binding_level
;
697 /* A chain of binding_level structures awaiting reuse. */
699 static struct binding_level
*free_binding_level
;
701 /* The outermost binding level, for names of file scope.
702 This is created when the compiler is started and exists
703 through the entire run. */
705 static struct binding_level
*global_binding_level
;
707 /* Binding level structures are initialized by copying this one. */
709 static struct binding_level clear_binding_level
711 {NULL
, NULL
, NULL
, NULL_BINDING_LEVEL
};
713 /* Language-dependent contents of an identifier. */
715 struct lang_identifier
717 struct tree_identifier ignore
;
718 tree global_value
, local_value
, label_value
;
722 /* Macros for access to language-specific slots in an identifier. */
723 /* Each of these slots contains a DECL node or null. */
725 /* This represents the value which the identifier has in the
726 file-scope namespace. */
727 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
728 (((struct lang_identifier *)(NODE))->global_value)
729 /* This represents the value which the identifier has in the current
731 #define IDENTIFIER_LOCAL_VALUE(NODE) \
732 (((struct lang_identifier *)(NODE))->local_value)
733 /* This represents the value which the identifier has as a label in
734 the current label scope. */
735 #define IDENTIFIER_LABEL_VALUE(NODE) \
736 (((struct lang_identifier *)(NODE))->label_value)
737 /* This is nonzero if the identifier was "made up" by g77 code. */
738 #define IDENTIFIER_INVENTED(NODE) \
739 (((struct lang_identifier *)(NODE))->invented)
741 /* In identifiers, C uses the following fields in a special way:
742 TREE_PUBLIC to record that there was a previous local extern decl.
743 TREE_USED to record that such a decl was used.
744 TREE_ADDRESSABLE to record that the address of such a decl was used. */
746 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
747 that have names. Here so we can clear out their names' definitions
748 at the end of the function. */
750 static tree named_labels
;
752 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
754 static tree shadowed_labels
;
756 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
759 /* This is like gcc's stabilize_reference -- in fact, most of the code
760 comes from that -- but it handles the situation where the reference
761 is going to have its subparts picked at, and it shouldn't change
762 (or trigger extra invocations of functions in the subtrees) due to
763 this. save_expr is a bit overzealous, because we don't need the
764 entire thing calculated and saved like a temp. So, for DECLs, no
765 change is needed, because these are stable aggregates, and ARRAY_REF
766 and such might well be stable too, but for things like calculations,
767 we do need to calculate a snapshot of a value before picking at it. */
769 #if FFECOM_targetCURRENT == FFECOM_targetGCC
771 ffecom_stabilize_aggregate_ (tree ref
)
774 enum tree_code code
= TREE_CODE (ref
);
781 /* No action is needed in this case. */
791 result
= build_nt (code
, stabilize_reference (TREE_OPERAND (ref
, 0)));
795 result
= build_nt (INDIRECT_REF
,
796 stabilize_reference_1 (TREE_OPERAND (ref
, 0)));
800 result
= build_nt (COMPONENT_REF
,
801 stabilize_reference (TREE_OPERAND (ref
, 0)),
802 TREE_OPERAND (ref
, 1));
806 result
= build_nt (BIT_FIELD_REF
,
807 stabilize_reference (TREE_OPERAND (ref
, 0)),
808 stabilize_reference_1 (TREE_OPERAND (ref
, 1)),
809 stabilize_reference_1 (TREE_OPERAND (ref
, 2)));
813 result
= build_nt (ARRAY_REF
,
814 stabilize_reference (TREE_OPERAND (ref
, 0)),
815 stabilize_reference_1 (TREE_OPERAND (ref
, 1)));
819 result
= build_nt (COMPOUND_EXPR
,
820 stabilize_reference_1 (TREE_OPERAND (ref
, 0)),
821 stabilize_reference (TREE_OPERAND (ref
, 1)));
825 result
= build1 (INDIRECT_REF
, TREE_TYPE (ref
),
826 save_expr (build1 (ADDR_EXPR
,
827 build_pointer_type (TREE_TYPE (ref
)),
833 return save_expr (ref
);
836 return error_mark_node
;
839 TREE_TYPE (result
) = TREE_TYPE (ref
);
840 TREE_READONLY (result
) = TREE_READONLY (ref
);
841 TREE_SIDE_EFFECTS (result
) = TREE_SIDE_EFFECTS (ref
);
842 TREE_THIS_VOLATILE (result
) = TREE_THIS_VOLATILE (ref
);
843 TREE_RAISES (result
) = TREE_RAISES (ref
);
849 /* A rip-off of gcc's convert.c convert_to_complex function,
850 reworked to handle complex implemented as C structures
851 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
853 #if FFECOM_targetCURRENT == FFECOM_targetGCC
855 ffecom_convert_to_complex_ (tree type
, tree expr
)
857 register enum tree_code form
= TREE_CODE (TREE_TYPE (expr
));
860 assert (TREE_CODE (type
) == RECORD_TYPE
);
862 subtype
= TREE_TYPE (TYPE_FIELDS (type
));
864 if (form
== REAL_TYPE
|| form
== INTEGER_TYPE
|| form
== ENUMERAL_TYPE
)
866 expr
= convert (subtype
, expr
);
867 return ffecom_2 (COMPLEX_EXPR
, type
, expr
,
868 convert (subtype
, integer_zero_node
));
871 if (form
== RECORD_TYPE
)
873 tree elt_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
)));
874 if (TYPE_MAIN_VARIANT (elt_type
) == TYPE_MAIN_VARIANT (subtype
))
878 expr
= save_expr (expr
);
879 return ffecom_2 (COMPLEX_EXPR
,
882 ffecom_1 (REALPART_EXPR
,
883 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
886 ffecom_1 (IMAGPART_EXPR
,
887 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
892 if (form
== POINTER_TYPE
|| form
== REFERENCE_TYPE
)
893 error ("pointer value used where a complex was expected");
895 error ("aggregate value used where a complex was expected");
897 return ffecom_2 (COMPLEX_EXPR
, type
,
898 convert (subtype
, integer_zero_node
),
899 convert (subtype
, integer_zero_node
));
903 /* Like gcc's convert(), but crashes if widening might happen. */
905 #if FFECOM_targetCURRENT == FFECOM_targetGCC
907 ffecom_convert_narrow_ (type
, expr
)
910 register tree e
= expr
;
911 register enum tree_code code
= TREE_CODE (type
);
913 if (type
== TREE_TYPE (e
)
914 || TREE_CODE (e
) == ERROR_MARK
)
916 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
917 return fold (build1 (NOP_EXPR
, type
, e
));
918 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
919 || code
== ERROR_MARK
)
920 return error_mark_node
;
921 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
923 assert ("void value not ignored as it ought to be" == NULL
);
924 return error_mark_node
;
926 assert (code
!= VOID_TYPE
);
927 if ((code
!= RECORD_TYPE
)
928 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
929 assert ("converting COMPLEX to REAL" == NULL
);
930 assert (code
!= ENUMERAL_TYPE
);
931 if (code
== INTEGER_TYPE
)
933 assert (TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
);
934 assert (TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)));
935 return fold (convert_to_integer (type
, e
));
937 if (code
== POINTER_TYPE
)
939 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
940 return fold (convert_to_pointer (type
, e
));
942 if (code
== REAL_TYPE
)
944 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
945 assert (TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)));
946 return fold (convert_to_real (type
, e
));
948 if (code
== COMPLEX_TYPE
)
950 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
951 assert (TYPE_PRECISION (TREE_TYPE (type
)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
952 return fold (convert_to_complex (type
, e
));
954 if (code
== RECORD_TYPE
)
956 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
957 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
958 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
959 return fold (ffecom_convert_to_complex_ (type
, e
));
962 assert ("conversion to non-scalar type requested" == NULL
);
963 return error_mark_node
;
967 /* Like gcc's convert(), but crashes if narrowing might happen. */
969 #if FFECOM_targetCURRENT == FFECOM_targetGCC
971 ffecom_convert_widen_ (type
, expr
)
974 register tree e
= expr
;
975 register enum tree_code code
= TREE_CODE (type
);
977 if (type
== TREE_TYPE (e
)
978 || TREE_CODE (e
) == ERROR_MARK
)
980 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
981 return fold (build1 (NOP_EXPR
, type
, e
));
982 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
983 || code
== ERROR_MARK
)
984 return error_mark_node
;
985 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
987 assert ("void value not ignored as it ought to be" == NULL
);
988 return error_mark_node
;
990 assert (code
!= VOID_TYPE
);
991 if ((code
!= RECORD_TYPE
)
992 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
993 assert ("narrowing COMPLEX to REAL" == NULL
);
994 assert (code
!= ENUMERAL_TYPE
);
995 if (code
== INTEGER_TYPE
)
997 assert (TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
);
998 assert (TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)));
999 return fold (convert_to_integer (type
, e
));
1001 if (code
== POINTER_TYPE
)
1003 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1004 return fold (convert_to_pointer (type
, e
));
1006 if (code
== REAL_TYPE
)
1008 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1009 assert (TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)));
1010 return fold (convert_to_real (type
, e
));
1012 if (code
== COMPLEX_TYPE
)
1014 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1015 assert (TYPE_PRECISION (TREE_TYPE (type
)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1016 return fold (convert_to_complex (type
, e
));
1018 if (code
== RECORD_TYPE
)
1020 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1021 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1022 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1023 return fold (ffecom_convert_to_complex_ (type
, e
));
1026 assert ("conversion to non-scalar type requested" == NULL
);
1027 return error_mark_node
;
1031 /* Handles making a COMPLEX type, either the standard
1032 (but buggy?) gbe way, or the safer (but less elegant?)
1035 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1037 ffecom_make_complex_type_ (tree subtype
)
1043 if (ffe_is_emulate_complex ())
1045 type
= make_node (RECORD_TYPE
);
1046 realfield
= ffecom_decl_field (type
, NULL_TREE
, "r", subtype
);
1047 imagfield
= ffecom_decl_field (type
, realfield
, "i", subtype
);
1048 TYPE_FIELDS (type
) = realfield
;
1053 type
= make_node (COMPLEX_TYPE
);
1054 TREE_TYPE (type
) = subtype
;
1062 /* Chooses either the gbe or the f2c way to build a
1063 complex constant. */
1065 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1067 ffecom_build_complex_constant_ (tree type
, tree realpart
, tree imagpart
)
1071 if (ffe_is_emulate_complex ())
1073 bothparts
= build_tree_list (TYPE_FIELDS (type
), realpart
);
1074 TREE_CHAIN (bothparts
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), imagpart
);
1075 bothparts
= build (CONSTRUCTOR
, type
, NULL_TREE
, bothparts
);
1079 bothparts
= build_complex (type
, realpart
, imagpart
);
1086 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1088 ffecom_arglist_expr_ (char *c
, ffebld expr
)
1091 tree
*plist
= &list
;
1092 tree trail
= NULL_TREE
; /* Append char length args here. */
1093 tree
*ptrail
= &trail
;
1098 tree wanted
= NULL_TREE
;
1099 static char zed
[] = "0";
1104 while (expr
!= NULL
)
1127 wanted
= ffecom_f2c_complex_type_node
;
1131 wanted
= ffecom_f2c_doublereal_type_node
;
1135 wanted
= ffecom_f2c_doublecomplex_type_node
;
1139 wanted
= ffecom_f2c_real_type_node
;
1143 wanted
= ffecom_f2c_integer_type_node
;
1147 wanted
= ffecom_f2c_longint_type_node
;
1151 assert ("bad argstring code" == NULL
);
1157 exprh
= ffebld_head (expr
);
1161 if ((wanted
== NULL_TREE
)
1164 (ffecom_tree_type
[ffeinfo_basictype (ffebld_info (exprh
))]
1165 [ffeinfo_kindtype (ffebld_info (exprh
))])
1166 == TYPE_MODE (wanted
))))
1168 = build_tree_list (NULL_TREE
,
1169 ffecom_arg_ptr_to_expr (exprh
,
1173 item
= ffecom_arg_expr (exprh
, &length
);
1174 item
= ffecom_convert_widen_ (wanted
, item
);
1177 item
= ffecom_1 (ADDR_EXPR
,
1178 build_pointer_type (TREE_TYPE (item
)),
1182 = build_tree_list (NULL_TREE
,
1186 plist
= &TREE_CHAIN (*plist
);
1187 expr
= ffebld_trail (expr
);
1188 if (length
!= NULL_TREE
)
1190 *ptrail
= build_tree_list (NULL_TREE
, length
);
1191 ptrail
= &TREE_CHAIN (*ptrail
);
1195 /* We've run out of args in the call; if the implementation expects
1196 more, supply null pointers for them, which the implementation can
1197 check to see if an arg was omitted. */
1199 while (*c
!= '\0' && *c
!= '0')
1204 assert ("missing arg to run-time routine!" == NULL
);
1219 assert ("bad arg string code" == NULL
);
1223 = build_tree_list (NULL_TREE
,
1225 plist
= &TREE_CHAIN (*plist
);
1234 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1236 ffecom_widest_expr_type_ (ffebld list
)
1239 ffebld widest
= NULL
;
1241 ffetype widest_type
= NULL
;
1244 for (; list
!= NULL
; list
= ffebld_trail (list
))
1246 item
= ffebld_head (list
);
1249 if ((widest
!= NULL
)
1250 && (ffeinfo_basictype (ffebld_info (item
))
1251 != ffeinfo_basictype (ffebld_info (widest
))))
1253 type
= ffeinfo_type (ffeinfo_basictype (ffebld_info (item
)),
1254 ffeinfo_kindtype (ffebld_info (item
)));
1255 if ((widest
== FFEINFO_kindtypeNONE
)
1256 || (ffetype_size (type
)
1257 > ffetype_size (widest_type
)))
1264 assert (widest
!= NULL
);
1265 t
= ffecom_tree_type
[ffeinfo_basictype (ffebld_info (widest
))]
1266 [ffeinfo_kindtype (ffebld_info (widest
))];
1267 assert (t
!= NULL_TREE
);
1272 /* Check whether dest and source might overlap. ffebld versions of these
1273 might or might not be passed, will be NULL if not.
1275 The test is really whether source_tree is modifiable and, if modified,
1276 might overlap destination such that the value(s) in the destination might
1277 change before it is finally modified. dest_* are the canonized
1278 destination itself. */
1280 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1282 ffecom_overlap_ (tree dest_decl
, tree dest_offset
, tree dest_size
,
1283 tree source_tree
, ffebld source UNUSED
,
1291 if (source_tree
== NULL_TREE
)
1294 switch (TREE_CODE (source_tree
))
1297 case IDENTIFIER_NODE
:
1308 case TRUNC_DIV_EXPR
:
1310 case FLOOR_DIV_EXPR
:
1311 case ROUND_DIV_EXPR
:
1312 case TRUNC_MOD_EXPR
:
1314 case FLOOR_MOD_EXPR
:
1315 case ROUND_MOD_EXPR
:
1317 case EXACT_DIV_EXPR
:
1318 case FIX_TRUNC_EXPR
:
1320 case FIX_FLOOR_EXPR
:
1321 case FIX_ROUND_EXPR
:
1336 case BIT_ANDTC_EXPR
:
1338 case TRUTH_ANDIF_EXPR
:
1339 case TRUTH_ORIF_EXPR
:
1340 case TRUTH_AND_EXPR
:
1342 case TRUTH_XOR_EXPR
:
1343 case TRUTH_NOT_EXPR
:
1359 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1360 TREE_OPERAND (source_tree
, 1), NULL
,
1364 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1365 TREE_OPERAND (source_tree
, 0), NULL
,
1370 case NON_LVALUE_EXPR
:
1372 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1375 ffecom_tree_canonize_ptr_ (&source_decl
, &source_offset
,
1377 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1382 ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1383 TREE_OPERAND (source_tree
, 1), NULL
,
1385 || ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1386 TREE_OPERAND (source_tree
, 2), NULL
,
1391 ffecom_tree_canonize_ref_ (&source_decl
, &source_offset
,
1393 TREE_OPERAND (source_tree
, 0));
1397 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1400 source_decl
= source_tree
;
1401 source_offset
= size_zero_node
;
1402 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1406 case REFERENCE_EXPR
:
1407 case PREDECREMENT_EXPR
:
1408 case PREINCREMENT_EXPR
:
1409 case POSTDECREMENT_EXPR
:
1410 case POSTINCREMENT_EXPR
:
1418 /* Come here when source_decl, source_offset, and source_size filled
1419 in appropriately. */
1421 if (source_decl
== NULL_TREE
)
1422 return FALSE
; /* No decl involved, so no overlap. */
1424 if (source_decl
!= dest_decl
)
1425 return FALSE
; /* Different decl, no overlap. */
1427 if (TREE_CODE (dest_size
) == ERROR_MARK
)
1428 return TRUE
; /* Assignment into entire assumed-size
1429 array? Shouldn't happen.... */
1431 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1432 ffecom_2 (PLUS_EXPR
, TREE_TYPE (dest_offset
),
1434 convert (TREE_TYPE (dest_offset
),
1436 convert (TREE_TYPE (dest_offset
),
1439 if (integer_onep (t
))
1440 return FALSE
; /* Destination precedes source. */
1443 || (source_size
== NULL_TREE
)
1444 || (TREE_CODE (source_size
) == ERROR_MARK
)
1445 || integer_zerop (source_size
))
1446 return TRUE
; /* No way to tell if dest follows source. */
1448 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1449 ffecom_2 (PLUS_EXPR
, TREE_TYPE (source_offset
),
1451 convert (TREE_TYPE (source_offset
),
1453 convert (TREE_TYPE (source_offset
),
1456 if (integer_onep (t
))
1457 return FALSE
; /* Destination follows source. */
1459 return TRUE
; /* Destination and source overlap. */
1463 /* Check whether dest might overlap any of a list of arguments or is
1464 in a COMMON area the callee might know about (and thus modify). */
1466 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1468 ffecom_args_overlapping_ (tree dest_tree
, ffebld dest UNUSED
,
1469 tree args
, tree callee_commons
,
1477 ffecom_tree_canonize_ref_ (&dest_decl
, &dest_offset
, &dest_size
,
1480 if (dest_decl
== NULL_TREE
)
1481 return FALSE
; /* Seems unlikely! */
1483 /* If the decl cannot be determined reliably, or if its in COMMON
1484 and the callee isn't known to not futz with COMMON via other
1485 means, overlap might happen. */
1487 if ((TREE_CODE (dest_decl
) == ERROR_MARK
)
1488 || ((callee_commons
!= NULL_TREE
)
1489 && TREE_PUBLIC (dest_decl
)))
1492 for (; args
!= NULL_TREE
; args
= TREE_CHAIN (args
))
1494 if (((arg
= TREE_VALUE (args
)) != NULL_TREE
)
1495 && ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1496 arg
, NULL
, scalar_args
))
1504 /* Build a string for a variable name as used by NAMELIST. This means that
1505 if we're using the f2c library, we build an uppercase string, since
1508 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1510 ffecom_build_f2c_string_ (int i
, char *s
)
1512 if (!ffe_is_f2c_library ())
1513 return build_string (i
, s
);
1522 if (((size_t) i
) > ARRAY_SIZE (space
))
1523 tmp
= malloc_new_ks (malloc_pool_image (), "f2c_string", i
);
1527 for (p
= s
, q
= tmp
; *p
!= '\0'; ++p
, ++q
)
1528 *q
= ffesrc_toupper (*p
);
1531 t
= build_string (i
, tmp
);
1533 if (((size_t) i
) > ARRAY_SIZE (space
))
1534 malloc_kill_ks (malloc_pool_image (), tmp
, i
);
1541 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1542 type to just get whatever the function returns), handling the
1543 f2c value-returning convention, if required, by prepending
1544 to the arglist a pointer to a temporary to receive the return value. */
1546 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1548 ffecom_call_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1549 tree type
, tree args
, tree dest_tree
,
1550 ffebld dest
, bool *dest_used
, tree callee_commons
,
1556 if (dest_used
!= NULL
)
1561 if ((dest_used
== NULL
)
1563 || (ffeinfo_basictype (ffebld_info (dest
))
1564 != FFEINFO_basictypeCOMPLEX
)
1565 || (ffeinfo_kindtype (ffebld_info (dest
)) != kt
)
1566 || ((type
!= NULL_TREE
) && (TREE_TYPE (dest_tree
) != type
))
1567 || ffecom_args_overlapping_ (dest_tree
, dest
, args
,
1571 tempvar
= ffecom_push_tempvar (ffecom_tree_type
1572 [FFEINFO_basictypeCOMPLEX
][kt
],
1573 FFETARGET_charactersizeNONE
,
1579 tempvar
= dest_tree
;
1584 = build_tree_list (NULL_TREE
,
1585 ffecom_1 (ADDR_EXPR
,
1586 build_pointer_type (TREE_TYPE (tempvar
)),
1588 TREE_CHAIN (item
) = args
;
1590 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1593 if (tempvar
!= dest_tree
)
1594 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
, tempvar
);
1597 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1600 if ((type
!= NULL_TREE
) && (TREE_TYPE (item
) != type
))
1601 item
= ffecom_convert_narrow_ (type
, item
);
1607 /* Given two arguments, transform them and make a call to the given
1608 function via ffecom_call_. */
1610 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1612 ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1613 tree type
, ffebld left
, ffebld right
,
1614 tree dest_tree
, ffebld dest
, bool *dest_used
,
1615 tree callee_commons
, bool scalar_args
)
1622 ffecom_push_calltemps ();
1623 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
1624 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
1625 ffecom_pop_calltemps ();
1627 left_tree
= build_tree_list (NULL_TREE
, left_tree
);
1628 right_tree
= build_tree_list (NULL_TREE
, right_tree
);
1629 TREE_CHAIN (left_tree
) = right_tree
;
1631 if (left_length
!= NULL_TREE
)
1633 left_length
= build_tree_list (NULL_TREE
, left_length
);
1634 TREE_CHAIN (right_tree
) = left_length
;
1637 if (right_length
!= NULL_TREE
)
1639 right_length
= build_tree_list (NULL_TREE
, right_length
);
1640 if (left_length
!= NULL_TREE
)
1641 TREE_CHAIN (left_length
) = right_length
;
1643 TREE_CHAIN (right_tree
) = right_length
;
1646 return ffecom_call_ (fn
, kt
, is_f2c_complex
, type
, left_tree
,
1647 dest_tree
, dest
, dest_used
, callee_commons
,
1652 /* ffecom_char_args_x_ -- Return ptr/length args for char subexpression
1658 ffecom_char_args_x_(&ptr_arg,&length_arg,expr,with_null);
1660 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1661 subexpressions by constructing the appropriate trees for the ptr-to-
1662 character-text and length-of-character-text arguments in a calling
1665 Note that if with_null is TRUE, and the expression is an opCONTER,
1666 a null byte is appended to the string. */
1668 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1670 ffecom_char_args_x_ (tree
*xitem
, tree
*length
, ffebld expr
, bool with_null
)
1674 ffetargetCharacter1 val
;
1675 ffetargetCharacterSize newlen
;
1677 switch (ffebld_op (expr
))
1679 case FFEBLD_opCONTER
:
1680 val
= ffebld_constant_character1 (ffebld_conter (expr
));
1681 newlen
= ffetarget_length_character1 (val
);
1685 ++newlen
; /* begin FFETARGET-NULL-KLUDGE. */
1687 *length
= build_int_2 (newlen
, 0);
1688 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1689 high
= build_int_2 (newlen
, 0);
1690 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
1691 item
= build_string (newlen
, /* end FFETARGET-NULL-KLUDGE. */
1692 ffetarget_text_character1 (val
));
1694 = build_type_variant
1698 (ffecom_f2c_ftnlen_type_node
,
1699 ffecom_f2c_ftnlen_one_node
,
1702 TREE_CONSTANT (item
) = 1;
1703 TREE_STATIC (item
) = 1;
1704 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
1708 case FFEBLD_opSYMTER
:
1710 ffesymbol s
= ffebld_symter (expr
);
1712 item
= ffesymbol_hook (s
).decl_tree
;
1713 if (item
== NULL_TREE
)
1715 s
= ffecom_sym_transform_ (s
);
1716 item
= ffesymbol_hook (s
).decl_tree
;
1718 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
1720 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
1721 *length
= ffesymbol_hook (s
).length_tree
;
1724 *length
= build_int_2 (ffesymbol_size (s
), 0);
1725 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1728 else if (item
== error_mark_node
)
1729 *length
= error_mark_node
;
1730 else /* FFEINFO_kindFUNCTION: */
1731 *length
= NULL_TREE
;
1732 if (!ffesymbol_hook (s
).addr
1733 && (item
!= error_mark_node
))
1734 item
= ffecom_1 (ADDR_EXPR
,
1735 build_pointer_type (TREE_TYPE (item
)),
1740 case FFEBLD_opARRAYREF
:
1742 ffebld dims
[FFECOM_dimensionsMAX
];
1746 ffecom_push_calltemps ();
1747 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1748 ffecom_pop_calltemps ();
1750 if (item
== error_mark_node
|| *length
== error_mark_node
)
1752 item
= *length
= error_mark_node
;
1756 /* Build up ARRAY_REFs in reverse order (since we're column major
1757 here in Fortran land). */
1759 for (i
= 0, expr
= ffebld_right (expr
);
1761 expr
= ffebld_trail (expr
))
1762 dims
[i
++] = ffebld_head (expr
);
1764 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
1766 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
1768 item
= ffecom_2 (PLUS_EXPR
, build_pointer_type (TREE_TYPE (array
)),
1770 size_binop (MULT_EXPR
,
1771 size_in_bytes (TREE_TYPE (array
)),
1772 size_binop (MINUS_EXPR
,
1773 ffecom_expr (dims
[i
]),
1774 TYPE_MIN_VALUE (TYPE_DOMAIN (array
)))));
1779 case FFEBLD_opSUBSTR
:
1783 ffebld thing
= ffebld_right (expr
);
1787 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
1788 start
= ffebld_head (thing
);
1789 thing
= ffebld_trail (thing
);
1790 assert (ffebld_trail (thing
) == NULL
);
1791 end
= ffebld_head (thing
);
1793 ffecom_push_calltemps ();
1794 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1795 ffecom_pop_calltemps ();
1797 if (item
== error_mark_node
|| *length
== error_mark_node
)
1799 item
= *length
= error_mark_node
;
1809 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
1812 if (end_tree
== error_mark_node
)
1814 item
= *length
= error_mark_node
;
1823 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
1824 ffecom_expr (start
));
1826 if (start_tree
== error_mark_node
)
1828 item
= *length
= error_mark_node
;
1832 start_tree
= ffecom_save_tree (start_tree
);
1834 item
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (item
),
1836 ffecom_2 (MINUS_EXPR
,
1837 TREE_TYPE (start_tree
),
1839 ffecom_f2c_ftnlen_one_node
));
1843 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
1844 ffecom_f2c_ftnlen_one_node
,
1845 ffecom_2 (MINUS_EXPR
,
1846 ffecom_f2c_ftnlen_type_node
,
1852 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
1855 if (end_tree
== error_mark_node
)
1857 item
= *length
= error_mark_node
;
1861 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
1862 ffecom_f2c_ftnlen_one_node
,
1863 ffecom_2 (MINUS_EXPR
,
1864 ffecom_f2c_ftnlen_type_node
,
1865 end_tree
, start_tree
));
1871 case FFEBLD_opFUNCREF
:
1873 ffesymbol s
= ffebld_symter (ffebld_left (expr
));
1876 ffetargetCharacterSize size
= ffeinfo_size (ffebld_info (expr
));
1879 if (size
== FFETARGET_charactersizeNONE
)
1880 size
= 24; /* ~~~~ Kludge alert! This should someday be fixed. */
1882 *length
= build_int_2 (size
, 0);
1883 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1885 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
1886 == FFEINFO_whereINTRINSIC
)
1889 { /* Invocation of an intrinsic returning CHARACTER*1. */
1890 item
= ffecom_expr_intrinsic_ (expr
, NULL_TREE
,
1894 ix
= ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr
)));
1895 assert (ix
!= FFECOM_gfrt
);
1896 item
= ffecom_gfrt_tree_ (ix
);
1901 item
= ffesymbol_hook (s
).decl_tree
;
1902 if (item
== NULL_TREE
)
1904 s
= ffecom_sym_transform_ (s
);
1905 item
= ffesymbol_hook (s
).decl_tree
;
1907 if (item
== error_mark_node
)
1909 item
= *length
= error_mark_node
;
1913 if (!ffesymbol_hook (s
).addr
)
1914 item
= ffecom_1_fn (item
);
1917 assert (ffecom_pending_calls_
!= 0);
1918 tempvar
= ffecom_push_tempvar (char_type_node
, size
, -1, TRUE
);
1919 tempvar
= ffecom_1 (ADDR_EXPR
,
1920 build_pointer_type (TREE_TYPE (tempvar
)),
1923 ffecom_push_calltemps ();
1925 args
= build_tree_list (NULL_TREE
, tempvar
);
1927 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
) /* Sfunc args by value. */
1928 TREE_CHAIN (args
) = ffecom_list_expr (ffebld_right (expr
));
1931 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, *length
);
1932 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
1934 TREE_CHAIN (TREE_CHAIN (args
))
1935 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix
),
1936 ffebld_right (expr
));
1940 TREE_CHAIN (TREE_CHAIN (args
))
1941 = ffecom_list_ptr_to_expr (ffebld_right (expr
));
1945 item
= ffecom_3s (CALL_EXPR
,
1946 TREE_TYPE (TREE_TYPE (TREE_TYPE (item
))),
1947 item
, args
, NULL_TREE
);
1948 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
,
1951 ffecom_pop_calltemps ();
1955 case FFEBLD_opCONVERT
:
1957 ffecom_push_calltemps ();
1958 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1959 ffecom_pop_calltemps ();
1961 if (item
== error_mark_node
|| *length
== error_mark_node
)
1963 item
= *length
= error_mark_node
;
1967 if ((ffebld_size_known (ffebld_left (expr
))
1968 == FFETARGET_charactersizeNONE
)
1969 || (ffebld_size_known (ffebld_left (expr
)) < (ffebld_size (expr
))))
1970 { /* Possible blank-padding needed, copy into
1976 assert (ffecom_pending_calls_
!= 0);
1977 tempvar
= ffecom_push_tempvar (char_type_node
,
1978 ffebld_size (expr
), -1, TRUE
);
1979 tempvar
= ffecom_1 (ADDR_EXPR
,
1980 build_pointer_type (TREE_TYPE (tempvar
)),
1983 newlen
= build_int_2 (ffebld_size (expr
), 0);
1984 TREE_TYPE (newlen
) = ffecom_f2c_ftnlen_type_node
;
1986 args
= build_tree_list (NULL_TREE
, tempvar
);
1987 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, item
);
1988 TREE_CHAIN (TREE_CHAIN (args
)) = build_tree_list (NULL_TREE
, newlen
);
1989 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args
)))
1990 = build_tree_list (NULL_TREE
, *length
);
1992 item
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, args
);
1993 TREE_SIDE_EFFECTS (item
) = 1;
1994 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), fold (item
),
1999 { /* Just truncate the length. */
2000 *length
= build_int_2 (ffebld_size (expr
), 0);
2001 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2006 assert ("bad op for single char arg expr" == NULL
);
2015 /* Check the size of the type to be sure it doesn't overflow the
2016 "portable" capacities of the compiler back end. `dummy' types
2017 can generally overflow the normal sizes as long as the computations
2018 themselves don't overflow. A particular target of the back end
2019 must still enforce its size requirements, though, and the back
2020 end takes care of this in stor-layout.c. */
2022 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2024 ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
)
2026 if (TREE_CODE (type
) == ERROR_MARK
)
2029 if (TYPE_SIZE (type
) == NULL_TREE
)
2032 if (TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
)
2035 if ((tree_int_cst_sgn (TYPE_SIZE (type
)) < 0)
2036 || (!dummy
&& (TREE_INT_CST_HIGH (TYPE_SIZE (type
)) != 0))
2037 || TREE_OVERFLOW (TYPE_SIZE (type
)))
2039 ffebad_start (FFEBAD_ARRAY_LARGE
);
2040 ffebad_string (ffesymbol_text (s
));
2041 ffebad_here (0, ffesymbol_where_line (s
), ffesymbol_where_column (s
));
2044 return error_mark_node
;
2051 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2052 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2053 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2055 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2057 ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
)
2059 ffetargetCharacterSize sz
= ffesymbol_size (s
);
2064 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
2065 tlen
= NULL_TREE
; /* A statement function, no length passed. */
2068 if (ffesymbol_where (s
) == FFEINFO_whereDUMMY
)
2069 tlen
= ffecom_get_invented_identifier ("__g77_length_%s",
2070 ffesymbol_text (s
), 0);
2072 tlen
= ffecom_get_invented_identifier ("__g77_%s",
2074 tlen
= build_decl (PARM_DECL
, tlen
, ffecom_f2c_ftnlen_type_node
);
2076 DECL_ARTIFICIAL (tlen
) = 1;
2080 if (sz
== FFETARGET_charactersizeNONE
)
2082 assert (tlen
!= NULL_TREE
);
2087 highval
= build_int_2 (sz
, 0);
2088 TREE_TYPE (highval
) = ffecom_f2c_ftnlen_type_node
;
2091 type
= build_array_type (type
,
2092 build_range_type (ffecom_f2c_ftnlen_type_node
,
2093 ffecom_f2c_ftnlen_one_node
,
2101 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2103 ffecomConcatList_ catlist;
2104 ffebld expr; // expr of CHARACTER basictype.
2105 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2106 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2108 Scans expr for character subexpressions, updates and returns catlist
2111 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2112 static ffecomConcatList_
2113 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
, ffebld expr
,
2114 ffetargetCharacterSize max
)
2116 ffetargetCharacterSize sz
;
2118 recurse
: /* :::::::::::::::::::: */
2123 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
>= max
))
2124 return catlist
; /* Don't append any more items. */
2126 switch (ffebld_op (expr
))
2128 case FFEBLD_opCONTER
:
2129 case FFEBLD_opSYMTER
:
2130 case FFEBLD_opARRAYREF
:
2131 case FFEBLD_opFUNCREF
:
2132 case FFEBLD_opSUBSTR
:
2133 case FFEBLD_opCONVERT
: /* Callers should strip this off beforehand
2134 if they don't need to preserve it. */
2135 if (catlist
.count
== catlist
.max
)
2136 { /* Make a (larger) list. */
2140 newmax
= (catlist
.max
== 0) ? 8 : catlist
.max
* 2;
2141 newx
= malloc_new_ks (malloc_pool_image (), "catlist",
2142 newmax
* sizeof (newx
[0]));
2143 if (catlist
.max
!= 0)
2145 memcpy (newx
, catlist
.exprs
, catlist
.max
* sizeof (newx
[0]));
2146 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2147 catlist
.max
* sizeof (newx
[0]));
2149 catlist
.max
= newmax
;
2150 catlist
.exprs
= newx
;
2152 if ((sz
= ffebld_size_known (expr
)) != FFETARGET_charactersizeNONE
)
2153 catlist
.minlen
+= sz
;
2155 ++catlist
.minlen
; /* Not true for F90; can be 0 length. */
2156 if ((sz
= ffebld_size_max (expr
)) == FFETARGET_charactersizeNONE
)
2157 catlist
.maxlen
= sz
;
2159 catlist
.maxlen
+= sz
;
2160 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
> max
))
2161 { /* This item overlaps (or is beyond) the end
2162 of the destination. */
2163 switch (ffebld_op (expr
))
2165 case FFEBLD_opCONTER
:
2166 case FFEBLD_opSYMTER
:
2167 case FFEBLD_opARRAYREF
:
2168 case FFEBLD_opFUNCREF
:
2169 case FFEBLD_opSUBSTR
:
2170 break; /* ~~Do useful truncations here. */
2173 assert ("op changed or inconsistent switches!" == NULL
);
2177 catlist
.exprs
[catlist
.count
++] = expr
;
2180 case FFEBLD_opPAREN
:
2181 expr
= ffebld_left (expr
);
2182 goto recurse
; /* :::::::::::::::::::: */
2184 case FFEBLD_opCONCATENATE
:
2185 catlist
= ffecom_concat_list_gather_ (catlist
, ffebld_left (expr
), max
);
2186 expr
= ffebld_right (expr
);
2187 goto recurse
; /* :::::::::::::::::::: */
2189 #if 0 /* Breaks passing small actual arg to larger
2190 dummy arg of sfunc */
2191 case FFEBLD_opCONVERT
:
2192 expr
= ffebld_left (expr
);
2194 ffetargetCharacterSize cmax
;
2196 cmax
= catlist
.len
+ ffebld_size_known (expr
);
2198 if ((max
== FFETARGET_charactersizeNONE
) || (max
> cmax
))
2201 goto recurse
; /* :::::::::::::::::::: */
2208 assert ("bad op in _gather_" == NULL
);
2214 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2216 ffecomConcatList_ catlist;
2217 ffecom_concat_list_kill_(catlist);
2219 Anything allocated within the list info is deallocated. */
2221 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2223 ffecom_concat_list_kill_ (ffecomConcatList_ catlist
)
2225 if (catlist
.max
!= 0)
2226 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2227 catlist
.max
* sizeof (catlist
.exprs
[0]));
2231 /* ffecom_concat_list_new_ -- Make list of concatenated string exprs
2233 ffecomConcatList_ catlist;
2234 ffebld expr; // Root expr of CHARACTER basictype.
2235 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2236 catlist = ffecom_concat_list_new_(expr,max);
2238 Returns a flattened list of concatenated subexpressions given a
2239 tree of such expressions. */
2241 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2242 static ffecomConcatList_
2243 ffecom_concat_list_new_ (ffebld expr
, ffetargetCharacterSize max
)
2245 ffecomConcatList_ catlist
;
2247 catlist
.maxlen
= catlist
.minlen
= catlist
.max
= catlist
.count
= 0;
2248 return ffecom_concat_list_gather_ (catlist
, expr
, max
);
2253 /* Provide some kind of useful info on member of aggregate area,
2254 since current g77/gcc technology does not provide debug info
2255 on these members. */
2257 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2259 ffecom_debug_kludge_ (tree aggr
, char *aggr_type
, ffesymbol member
,
2260 tree member_type UNUSED
, ffetargetOffset offset
)
2270 for (type_id
= member_type
;
2271 TREE_CODE (type_id
) != IDENTIFIER_NODE
;
2274 switch (TREE_CODE (type_id
))
2278 type_id
= TYPE_NAME (type_id
);
2283 type_id
= TREE_TYPE (type_id
);
2287 assert ("no IDENTIFIER_NODE for type!" == NULL
);
2288 type_id
= error_mark_node
;
2294 if (ffecom_transform_only_dummies_
2295 || !ffe_is_debug_kludge ())
2296 return; /* Can't do this yet, maybe later. */
2299 + strlen (aggr_type
)
2300 + IDENTIFIER_LENGTH (DECL_NAME (aggr
));
2302 + IDENTIFIER_LENGTH (type_id
);
2305 if (((size_t) len
) >= ARRAY_SIZE (space
))
2306 buff
= malloc_new_ks (malloc_pool_image (), "debug_kludge", len
+ 1);
2310 sprintf (&buff
[0], "At (%s) `%s' plus %ld bytes",
2312 IDENTIFIER_POINTER (DECL_NAME (aggr
)),
2315 value
= build_string (len
, buff
);
2317 = build_type_variant (build_array_type (char_type_node
,
2321 build_int_2 (strlen (buff
), 0))),
2323 decl
= build_decl (VAR_DECL
,
2324 ffecom_get_identifier_ (ffesymbol_text (member
)),
2326 TREE_CONSTANT (decl
) = 1;
2327 TREE_STATIC (decl
) = 1;
2328 DECL_INITIAL (decl
) = error_mark_node
;
2329 DECL_IN_SYSTEM_HEADER (decl
) = 1; /* Don't let -Wunused complain. */
2330 decl
= start_decl (decl
, FALSE
);
2331 finish_decl (decl
, value
, FALSE
);
2333 if (buff
!= &space
[0])
2334 malloc_kill_ks (malloc_pool_image (), buff
, len
+ 1);
2338 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2340 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2341 int i; // entry# for this entrypoint (used by master fn)
2342 ffecom_do_entrypoint_(s,i);
2344 Makes a public entry point that calls our private master fn (already
2347 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2349 ffecom_do_entry_ (ffesymbol fn
, int entrynum
)
2352 tree type
; /* Type of function. */
2353 tree multi_retval
; /* Var holding return value (union). */
2354 tree result
; /* Var holding result. */
2355 ffeinfoBasictype bt
;
2359 bool charfunc
; /* All entry points return same type
2361 bool cmplxfunc
; /* Use f2c way of returning COMPLEX. */
2362 bool multi
; /* Master fn has multiple return types. */
2363 bool altreturning
= FALSE
; /* This entry point has alternate returns. */
2366 /* c-parse.y indeed does call suspend_momentary and not only ignores the
2367 return value, but also never calls resume_momentary, when starting an
2368 outer function (see "fndef:", "setspecs:", and so on). So g77 does the
2369 same thing. It shouldn't be a problem since start_function calls
2370 temporary_allocation, but it might be necessary. If it causes a problem
2371 here, then maybe there's a bug lurking in gcc. NOTE: This identical
2372 comment appears twice in thist file. */
2374 suspend_momentary ();
2376 ffecom_doing_entry_
= TRUE
; /* Don't bother with array dimensions. */
2378 switch (ffecom_primary_entry_kind_
)
2380 case FFEINFO_kindFUNCTION
:
2382 /* Determine actual return type for function. */
2384 gt
= FFEGLOBAL_typeFUNC
;
2385 bt
= ffesymbol_basictype (fn
);
2386 kt
= ffesymbol_kindtype (fn
);
2387 if (bt
== FFEINFO_basictypeNONE
)
2389 ffeimplic_establish_symbol (fn
);
2390 if (ffesymbol_funcresult (fn
) != NULL
)
2391 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
2392 bt
= ffesymbol_basictype (fn
);
2393 kt
= ffesymbol_kindtype (fn
);
2396 if (bt
== FFEINFO_basictypeCHARACTER
)
2397 charfunc
= TRUE
, cmplxfunc
= FALSE
;
2398 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
2399 && ffesymbol_is_f2c (fn
))
2400 charfunc
= FALSE
, cmplxfunc
= TRUE
;
2402 charfunc
= cmplxfunc
= FALSE
;
2405 type
= ffecom_tree_fun_type_void
;
2406 else if (ffesymbol_is_f2c (fn
))
2407 type
= ffecom_tree_fun_type
[bt
][kt
];
2409 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
2411 if ((type
== NULL_TREE
)
2412 || (TREE_TYPE (type
) == NULL_TREE
))
2413 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
2415 multi
= (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
2418 case FFEINFO_kindSUBROUTINE
:
2419 gt
= FFEGLOBAL_typeSUBR
;
2420 bt
= FFEINFO_basictypeNONE
;
2421 kt
= FFEINFO_kindtypeNONE
;
2422 if (ffecom_is_altreturning_
)
2423 { /* Am _I_ altreturning? */
2424 for (item
= ffesymbol_dummyargs (fn
);
2426 item
= ffebld_trail (item
))
2428 if (ffebld_op (ffebld_head (item
)) == FFEBLD_opSTAR
)
2430 altreturning
= TRUE
;
2435 type
= ffecom_tree_subr_type
;
2437 type
= ffecom_tree_fun_type_void
;
2440 type
= ffecom_tree_fun_type_void
;
2447 assert ("say what??" == NULL
);
2449 case FFEINFO_kindANY
:
2450 gt
= FFEGLOBAL_typeANY
;
2451 bt
= FFEINFO_basictypeNONE
;
2452 kt
= FFEINFO_kindtypeNONE
;
2453 type
= error_mark_node
;
2460 /* build_decl uses the current lineno and input_filename to set the decl
2461 source info. So, I've putzed with ffestd and ffeste code to update that
2462 source info to point to the appropriate statement just before calling
2463 ffecom_do_entrypoint (which calls this fn). */
2465 start_function (ffecom_get_external_identifier_ (fn
),
2467 0, /* nested/inline */
2468 1); /* TREE_PUBLIC */
2470 if (((g
= ffesymbol_global (fn
)) != NULL
)
2471 && ((ffeglobal_type (g
) == gt
)
2472 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
2474 ffeglobal_set_hook (g
, current_function_decl
);
2477 /* Reset args in master arg list so they get retransitioned. */
2479 for (item
= ffecom_master_arglist_
;
2481 item
= ffebld_trail (item
))
2486 arg
= ffebld_head (item
);
2487 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2488 continue; /* Alternate return or some such thing. */
2489 s
= ffebld_symter (arg
);
2490 ffesymbol_hook (s
).decl_tree
= NULL_TREE
;
2491 ffesymbol_hook (s
).length_tree
= NULL_TREE
;
2494 /* Build dummy arg list for this entry point. */
2496 yes
= suspend_momentary ();
2498 if (charfunc
|| cmplxfunc
)
2499 { /* Prepend arg for where result goes. */
2504 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
2506 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
2508 result
= ffecom_get_invented_identifier ("__g77_%s",
2511 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2514 length
= ffecom_char_enhance_arg_ (&type
, fn
);
2516 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
2518 type
= build_pointer_type (type
);
2519 result
= build_decl (PARM_DECL
, result
, type
);
2521 push_parm_decl (result
);
2522 ffecom_func_result_
= result
;
2526 push_parm_decl (length
);
2527 ffecom_func_length_
= length
;
2531 result
= DECL_RESULT (current_function_decl
);
2533 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn
), FALSE
);
2535 resume_momentary (yes
);
2537 store_parm_decls (0);
2539 ffecom_start_compstmt_ ();
2541 /* Make local var to hold return type for multi-type master fn. */
2545 yes
= suspend_momentary ();
2547 multi_retval
= ffecom_get_invented_identifier ("__g77_%s",
2549 multi_retval
= build_decl (VAR_DECL
, multi_retval
,
2550 ffecom_multi_type_node_
);
2551 multi_retval
= start_decl (multi_retval
, FALSE
);
2552 finish_decl (multi_retval
, NULL_TREE
, FALSE
);
2554 resume_momentary (yes
);
2557 multi_retval
= NULL_TREE
; /* Not actually ref'd if !multi. */
2559 /* Here we emit the actual code for the entry point. */
2565 tree arglist
= NULL_TREE
;
2566 tree
*plist
= &arglist
;
2572 /* Prepare actual arg list based on master arg list. */
2574 for (list
= ffecom_master_arglist_
;
2576 list
= ffebld_trail (list
))
2578 arg
= ffebld_head (list
);
2579 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2581 s
= ffebld_symter (arg
);
2582 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
)
2583 actarg
= null_pointer_node
; /* We don't have this arg. */
2585 actarg
= ffesymbol_hook (s
).decl_tree
;
2586 *plist
= build_tree_list (NULL_TREE
, actarg
);
2587 plist
= &TREE_CHAIN (*plist
);
2590 /* This code appends the length arguments for character
2591 variables/arrays. */
2593 for (list
= ffecom_master_arglist_
;
2595 list
= ffebld_trail (list
))
2597 arg
= ffebld_head (list
);
2598 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2600 s
= ffebld_symter (arg
);
2601 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
2602 continue; /* Only looking for CHARACTER arguments. */
2603 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
2604 continue; /* Only looking for variables and arrays. */
2605 if (ffesymbol_hook (s
).length_tree
== NULL_TREE
)
2606 actarg
= ffecom_f2c_ftnlen_zero_node
; /* We don't have this arg. */
2608 actarg
= ffesymbol_hook (s
).length_tree
;
2609 *plist
= build_tree_list (NULL_TREE
, actarg
);
2610 plist
= &TREE_CHAIN (*plist
);
2613 /* Prepend character-value return info to actual arg list. */
2617 prepend
= build_tree_list (NULL_TREE
, ffecom_func_result_
);
2618 TREE_CHAIN (prepend
)
2619 = build_tree_list (NULL_TREE
, ffecom_func_length_
);
2620 TREE_CHAIN (TREE_CHAIN (prepend
)) = arglist
;
2624 /* Prepend multi-type return value to actual arg list. */
2629 = build_tree_list (NULL_TREE
,
2630 ffecom_1 (ADDR_EXPR
,
2631 build_pointer_type (TREE_TYPE (multi_retval
)),
2633 TREE_CHAIN (prepend
) = arglist
;
2637 /* Prepend my entry-point number to the actual arg list. */
2639 prepend
= build_tree_list (NULL_TREE
, build_int_2 (entrynum
, 0));
2640 TREE_CHAIN (prepend
) = arglist
;
2643 /* Build the call to the master function. */
2645 master_fn
= ffecom_1_fn (ffecom_previous_function_decl_
);
2646 call
= ffecom_3s (CALL_EXPR
,
2647 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn
))),
2648 master_fn
, arglist
, NULL_TREE
);
2650 /* Decide whether the master function is a function or subroutine, and
2651 handle the return value for my entry point. */
2653 if (charfunc
|| ((ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
2656 expand_expr_stmt (call
);
2657 expand_null_return ();
2659 else if (multi
&& cmplxfunc
)
2661 expand_expr_stmt (call
);
2663 = ffecom_1 (INDIRECT_REF
,
2664 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2666 result
= ffecom_modify (NULL_TREE
, result
,
2667 ffecom_2 (COMPONENT_REF
, TREE_TYPE (result
),
2669 ffecom_multi_fields_
[bt
][kt
]));
2670 expand_expr_stmt (result
);
2671 expand_null_return ();
2675 expand_expr_stmt (call
);
2677 = ffecom_modify (NULL_TREE
, result
,
2678 convert (TREE_TYPE (result
),
2679 ffecom_2 (COMPONENT_REF
,
2680 ffecom_tree_type
[bt
][kt
],
2682 ffecom_multi_fields_
[bt
][kt
])));
2683 expand_return (result
);
2688 = ffecom_1 (INDIRECT_REF
,
2689 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2691 result
= ffecom_modify (NULL_TREE
, result
, call
);
2692 expand_expr_stmt (result
);
2693 expand_null_return ();
2697 result
= ffecom_modify (NULL_TREE
,
2699 convert (TREE_TYPE (result
),
2701 expand_return (result
);
2707 ffecom_end_compstmt_ ();
2709 finish_function (0);
2711 ffecom_doing_entry_
= FALSE
;
2715 /* Transform expr into gcc tree with possible destination
2717 Recursive descent on expr while making corresponding tree nodes and
2718 attaching type info and such. If destination supplied and compatible
2719 with temporary that would be made in certain cases, temporary isn't
2720 made, destination used instead, and dest_used flag set TRUE.
2722 If TREE_TYPE is non-null, it overrides the type that the expression
2723 would normally be computed in. This is most useful for array indices
2724 which should be done in sizetype for efficiency. */
2726 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2728 ffecom_expr_ (ffebld expr
, tree tree_type_x
, tree dest_tree
,
2729 ffebld dest
, bool *dest_used
,
2735 ffeinfoBasictype bt
;
2738 tree dt
; /* decl_tree for an ffesymbol. */
2742 enum tree_code code
;
2744 assert (expr
!= NULL
);
2746 if (dest_used
!= NULL
)
2749 bt
= ffeinfo_basictype (ffebld_info (expr
));
2750 kt
= ffeinfo_kindtype (ffebld_info (expr
));
2751 tree_type
= ffecom_tree_type
[bt
][kt
];
2753 switch (ffebld_op (expr
))
2755 case FFEBLD_opACCTER
:
2758 ffebit bits
= ffebld_accter_bits (expr
);
2759 ffetargetOffset source_offset
= 0;
2763 size
= ffetype_size (ffeinfo_type (bt
, kt
));
2768 ffebldConstantUnion cu
;
2771 ffebldConstantArray ca
= ffebld_accter (expr
);
2773 ffebit_test (bits
, source_offset
, &value
, &length
);
2779 for (i
= 0; i
< length
; ++i
)
2781 cu
= ffebld_constantarray_get (ca
, bt
, kt
,
2784 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
2787 purpose
= build_int_2 (source_offset
, 0);
2789 purpose
= NULL_TREE
;
2791 if (list
== NULL_TREE
)
2792 list
= item
= build_tree_list (purpose
, t
);
2795 TREE_CHAIN (item
) = build_tree_list (purpose
, t
);
2796 item
= TREE_CHAIN (item
);
2800 source_offset
+= length
;
2804 item
= build_int_2 (ffebld_accter_size (expr
), 0);
2805 ffebit_kill (ffebld_accter_bits (expr
));
2806 TREE_TYPE (item
) = ffecom_integer_type_node
;
2810 build_range_type (ffecom_integer_type_node
,
2811 ffecom_integer_zero_node
,
2813 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
2814 TREE_CONSTANT (list
) = 1;
2815 TREE_STATIC (list
) = 1;
2818 case FFEBLD_opARRTER
:
2822 list
= item
= NULL_TREE
;
2823 for (i
= 0; i
< ffebld_arrter_size (expr
); ++i
)
2825 ffebldConstantUnion cu
2826 = ffebld_constantarray_get (ffebld_arrter (expr
), bt
, kt
, i
);
2828 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
2830 if (list
== NULL_TREE
)
2831 list
= item
= build_tree_list (NULL_TREE
, t
);
2834 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
2835 item
= TREE_CHAIN (item
);
2840 item
= build_int_2 (ffebld_arrter_size (expr
), 0);
2841 TREE_TYPE (item
) = ffecom_integer_type_node
;
2845 build_range_type (ffecom_integer_type_node
,
2846 ffecom_integer_one_node
,
2848 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
2849 TREE_CONSTANT (list
) = 1;
2850 TREE_STATIC (list
) = 1;
2853 case FFEBLD_opCONTER
:
2855 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr
)),
2859 case FFEBLD_opSYMTER
:
2860 if ((ffebld_symter_generic (expr
) != FFEINTRIN_genNONE
)
2861 || (ffebld_symter_specific (expr
) != FFEINTRIN_specNONE
))
2862 return ffecom_ptr_to_expr (expr
); /* Same as %REF(intrinsic). */
2863 s
= ffebld_symter (expr
);
2864 t
= ffesymbol_hook (s
).decl_tree
;
2867 { /* ASSIGN'ed-label expr. */
2868 if (ffe_is_ugly_assign ())
2870 /* User explicitly wants ASSIGN'ed variables to be at the same
2871 memory address as the variables when used in non-ASSIGN
2872 contexts. That can make old, arcane, non-standard code
2873 work, but don't try to do it when a pointer wouldn't fit
2874 in the normal variable (take other approach, and warn,
2879 s
= ffecom_sym_transform_ (s
);
2880 t
= ffesymbol_hook (s
).decl_tree
;
2881 assert (t
!= NULL_TREE
);
2884 if (t
== error_mark_node
)
2887 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t
)))
2888 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
2890 if (ffesymbol_hook (s
).addr
)
2891 t
= ffecom_1 (INDIRECT_REF
,
2892 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
2896 if (ffesymbol_hook (s
).assign_tree
== NULL_TREE
)
2898 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
2899 FFEBAD_severityWARNING
);
2900 ffebad_string (ffesymbol_text (s
));
2901 ffebad_here (0, ffesymbol_where_line (s
),
2902 ffesymbol_where_column (s
));
2907 /* Don't use the normal variable's tree for ASSIGN, though mark
2908 it as in the system header (housekeeping). Use an explicit,
2909 specially created sibling that is known to be wide enough
2910 to hold pointers to labels. */
2913 && TREE_CODE (t
) == VAR_DECL
)
2914 DECL_IN_SYSTEM_HEADER (t
) = 1; /* Don't let -Wunused complain. */
2916 t
= ffesymbol_hook (s
).assign_tree
;
2919 s
= ffecom_sym_transform_assign_ (s
);
2920 t
= ffesymbol_hook (s
).assign_tree
;
2921 assert (t
!= NULL_TREE
);
2928 s
= ffecom_sym_transform_ (s
);
2929 t
= ffesymbol_hook (s
).decl_tree
;
2930 assert (t
!= NULL_TREE
);
2932 if (ffesymbol_hook (s
).addr
)
2933 t
= ffecom_1 (INDIRECT_REF
,
2934 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
2938 case FFEBLD_opARRAYREF
:
2940 ffebld dims
[FFECOM_dimensionsMAX
];
2941 #if FFECOM_FASTER_ARRAY_REFS
2946 #if FFECOM_FASTER_ARRAY_REFS
2947 t
= ffecom_ptr_to_expr (ffebld_left (expr
));
2949 t
= ffecom_expr (ffebld_left (expr
));
2951 if (t
== error_mark_node
)
2954 if ((ffeinfo_where (ffebld_info (expr
)) == FFEINFO_whereFLEETING
)
2955 && !mark_addressable (t
))
2956 return error_mark_node
; /* Make sure non-const ref is to
2959 /* Build up ARRAY_REFs in reverse order (since we're column major
2960 here in Fortran land). */
2962 for (i
= 0, expr
= ffebld_right (expr
);
2964 expr
= ffebld_trail (expr
))
2965 dims
[i
++] = ffebld_head (expr
);
2967 #if FFECOM_FASTER_ARRAY_REFS
2968 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
)));
2970 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
2971 t
= ffecom_2 (PLUS_EXPR
,
2972 build_pointer_type (TREE_TYPE (array
)),
2974 size_binop (MULT_EXPR
,
2975 size_in_bytes (TREE_TYPE (array
)),
2976 size_binop (MINUS_EXPR
,
2977 ffecom_expr (dims
[i
]),
2978 TYPE_MIN_VALUE (TYPE_DOMAIN (array
)))));
2979 t
= ffecom_1 (INDIRECT_REF
,
2980 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))),
2984 t
= ffecom_2 (ARRAY_REF
,
2985 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))),
2987 ffecom_expr_ (dims
[--i
], sizetype
, NULL
, NULL
,
2994 case FFEBLD_opUPLUS
:
2995 left
= ffecom_expr_ (ffebld_left (expr
), tree_type_x
, NULL
, NULL
,
2997 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
2999 case FFEBLD_opPAREN
: /* ~~~Make sure Fortran rules respected here */
3000 left
= ffecom_expr_ (ffebld_left (expr
), tree_type_x
, NULL
, NULL
,
3002 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3004 case FFEBLD_opUMINUS
:
3005 left
= ffecom_expr_ (ffebld_left (expr
), tree_type_x
, NULL
, NULL
,
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
), tree_type_x
, NULL
, NULL
,
3017 right
= ffecom_expr_ (ffebld_right (expr
), tree_type_x
, NULL
, NULL
,
3021 tree_type
= tree_type_x
;
3022 left
= convert (tree_type
, left
);
3023 right
= convert (tree_type
, right
);
3025 return ffecom_2 (PLUS_EXPR
, tree_type
, left
, right
);
3027 case FFEBLD_opSUBTRACT
:
3028 left
= ffecom_expr_ (ffebld_left (expr
), tree_type_x
, NULL
, NULL
,
3030 right
= ffecom_expr_ (ffebld_right (expr
), tree_type_x
, NULL
, NULL
,
3034 tree_type
= tree_type_x
;
3035 left
= convert (tree_type
, left
);
3036 right
= convert (tree_type
, right
);
3038 return ffecom_2 (MINUS_EXPR
, tree_type
, left
, right
);
3040 case FFEBLD_opMULTIPLY
:
3041 left
= ffecom_expr_ (ffebld_left (expr
), tree_type_x
, NULL
, NULL
,
3043 right
= ffecom_expr_ (ffebld_right (expr
), tree_type_x
, NULL
, NULL
,
3047 tree_type
= tree_type_x
;
3048 left
= convert (tree_type
, left
);
3049 right
= convert (tree_type
, right
);
3051 return ffecom_2 (MULT_EXPR
, tree_type
, left
, right
);
3053 case FFEBLD_opDIVIDE
:
3054 left
= ffecom_expr_ (ffebld_left (expr
), tree_type_x
, NULL
, NULL
,
3056 right
= ffecom_expr_ (ffebld_right (expr
), tree_type_x
, NULL
, NULL
,
3060 tree_type
= tree_type_x
;
3061 left
= convert (tree_type
, left
);
3062 right
= convert (tree_type
, right
);
3064 return ffecom_tree_divide_ (tree_type
, left
, right
,
3065 dest_tree
, dest
, dest_used
);
3067 case FFEBLD_opPOWER
:
3069 ffebld left
= ffebld_left (expr
);
3070 ffebld right
= ffebld_right (expr
);
3072 ffeinfoKindtype rtkt
;
3074 switch (ffeinfo_basictype (ffebld_info (right
)))
3076 case FFEINFO_basictypeINTEGER
:
3079 item
= ffecom_expr_power_integer_ (left
, right
);
3080 if (item
!= NULL_TREE
)
3084 rtkt
= FFEINFO_kindtypeINTEGER1
;
3085 switch (ffeinfo_basictype (ffebld_info (left
)))
3087 case FFEINFO_basictypeINTEGER
:
3088 if ((ffeinfo_kindtype (ffebld_info (left
))
3089 == FFEINFO_kindtypeINTEGER4
)
3090 || (ffeinfo_kindtype (ffebld_info (right
))
3091 == FFEINFO_kindtypeINTEGER4
))
3093 code
= FFECOM_gfrtPOW_QQ
;
3094 rtkt
= FFEINFO_kindtypeINTEGER4
;
3097 code
= FFECOM_gfrtPOW_II
;
3100 case FFEINFO_basictypeREAL
:
3101 if (ffeinfo_kindtype (ffebld_info (left
))
3102 == FFEINFO_kindtypeREAL1
)
3103 code
= FFECOM_gfrtPOW_RI
;
3105 code
= FFECOM_gfrtPOW_DI
;
3108 case FFEINFO_basictypeCOMPLEX
:
3109 if (ffeinfo_kindtype (ffebld_info (left
))
3110 == FFEINFO_kindtypeREAL1
)
3111 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3113 code
= FFECOM_gfrtPOW_ZI
; /* Overlapping result okay. */
3117 assert ("bad pow_*i" == NULL
);
3118 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3121 if (ffeinfo_kindtype (ffebld_info (left
)) != rtkt
)
3122 left
= ffeexpr_convert (left
, NULL
, NULL
,
3123 FFEINFO_basictypeINTEGER
,
3125 FFETARGET_charactersizeNONE
,
3126 FFEEXPR_contextLET
);
3127 if (ffeinfo_kindtype (ffebld_info (right
)) != rtkt
)
3128 right
= ffeexpr_convert (right
, NULL
, NULL
,
3129 FFEINFO_basictypeINTEGER
,
3131 FFETARGET_charactersizeNONE
,
3132 FFEEXPR_contextLET
);
3135 case FFEINFO_basictypeREAL
:
3136 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3137 left
= ffeexpr_convert (left
, NULL
, NULL
, FFEINFO_basictypeREAL
,
3138 FFEINFO_kindtypeREALDOUBLE
, 0,
3139 FFETARGET_charactersizeNONE
,
3140 FFEEXPR_contextLET
);
3141 if (ffeinfo_kindtype (ffebld_info (right
))
3142 == FFEINFO_kindtypeREAL1
)
3143 right
= ffeexpr_convert (right
, NULL
, NULL
,
3144 FFEINFO_basictypeREAL
,
3145 FFEINFO_kindtypeREALDOUBLE
, 0,
3146 FFETARGET_charactersizeNONE
,
3147 FFEEXPR_contextLET
);
3148 code
= FFECOM_gfrtPOW_DD
;
3151 case FFEINFO_basictypeCOMPLEX
:
3152 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3153 left
= ffeexpr_convert (left
, NULL
, NULL
,
3154 FFEINFO_basictypeCOMPLEX
,
3155 FFEINFO_kindtypeREALDOUBLE
, 0,
3156 FFETARGET_charactersizeNONE
,
3157 FFEEXPR_contextLET
);
3158 if (ffeinfo_kindtype (ffebld_info (right
))
3159 == FFEINFO_kindtypeREAL1
)
3160 right
= ffeexpr_convert (right
, NULL
, NULL
,
3161 FFEINFO_basictypeCOMPLEX
,
3162 FFEINFO_kindtypeREALDOUBLE
, 0,
3163 FFETARGET_charactersizeNONE
,
3164 FFEEXPR_contextLET
);
3165 code
= FFECOM_gfrtPOW_ZZ
; /* Overlapping result okay. */
3169 assert ("bad pow_x*" == NULL
);
3170 code
= FFECOM_gfrtPOW_II
;
3173 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code
),
3174 ffecom_gfrt_kindtype (code
),
3175 (ffe_is_f2c_library ()
3176 && ffecom_gfrt_complex_
[code
]),
3177 tree_type
, left
, right
,
3178 dest_tree
, dest
, dest_used
,
3185 case FFEINFO_basictypeLOGICAL
:
3186 item
= ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr
)));
3187 return convert (tree_type
, item
);
3189 case FFEINFO_basictypeINTEGER
:
3190 return ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3191 ffecom_expr (ffebld_left (expr
)));
3194 assert ("NOT bad basictype" == NULL
);
3196 case FFEINFO_basictypeANY
:
3197 return error_mark_node
;
3201 case FFEBLD_opFUNCREF
:
3202 assert (ffeinfo_basictype (ffebld_info (expr
))
3203 != FFEINFO_basictypeCHARACTER
);
3205 case FFEBLD_opSUBRREF
:
3206 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
3207 == FFEINFO_whereINTRINSIC
)
3208 { /* Invocation of an intrinsic. */
3209 item
= ffecom_expr_intrinsic_ (expr
, dest_tree
, dest
,
3213 s
= ffebld_symter (ffebld_left (expr
));
3214 dt
= ffesymbol_hook (s
).decl_tree
;
3215 if (dt
== NULL_TREE
)
3217 s
= ffecom_sym_transform_ (s
);
3218 dt
= ffesymbol_hook (s
).decl_tree
;
3220 if (dt
== error_mark_node
)
3223 if (ffesymbol_hook (s
).addr
)
3226 item
= ffecom_1_fn (dt
);
3228 ffecom_push_calltemps ();
3229 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
3230 args
= ffecom_list_expr (ffebld_right (expr
));
3232 args
= ffecom_list_ptr_to_expr (ffebld_right (expr
));
3233 ffecom_pop_calltemps ();
3235 item
= ffecom_call_ (item
, kt
,
3236 ffesymbol_is_f2c (s
)
3237 && (bt
== FFEINFO_basictypeCOMPLEX
)
3238 && (ffesymbol_where (s
)
3239 != FFEINFO_whereCONSTANT
),
3242 dest_tree
, dest
, dest_used
,
3243 error_mark_node
, FALSE
);
3244 TREE_SIDE_EFFECTS (item
) = 1;
3250 case FFEINFO_basictypeLOGICAL
:
3252 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3253 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3254 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3255 return convert (tree_type
, item
);
3257 case FFEINFO_basictypeINTEGER
:
3258 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
3259 ffecom_expr (ffebld_left (expr
)),
3260 ffecom_expr (ffebld_right (expr
)));
3263 assert ("AND bad basictype" == NULL
);
3265 case FFEINFO_basictypeANY
:
3266 return error_mark_node
;
3273 case FFEINFO_basictypeLOGICAL
:
3275 = ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
3276 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3277 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3278 return convert (tree_type
, item
);
3280 case FFEINFO_basictypeINTEGER
:
3281 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
3282 ffecom_expr (ffebld_left (expr
)),
3283 ffecom_expr (ffebld_right (expr
)));
3286 assert ("OR bad basictype" == NULL
);
3288 case FFEINFO_basictypeANY
:
3289 return error_mark_node
;
3297 case FFEINFO_basictypeLOGICAL
:
3299 = ffecom_2 (NE_EXPR
, integer_type_node
,
3300 ffecom_expr (ffebld_left (expr
)),
3301 ffecom_expr (ffebld_right (expr
)));
3302 return convert (tree_type
, ffecom_truth_value (item
));
3304 case FFEINFO_basictypeINTEGER
:
3305 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3306 ffecom_expr (ffebld_left (expr
)),
3307 ffecom_expr (ffebld_right (expr
)));
3310 assert ("XOR/NEQV bad basictype" == NULL
);
3312 case FFEINFO_basictypeANY
:
3313 return error_mark_node
;
3320 case FFEINFO_basictypeLOGICAL
:
3322 = ffecom_2 (EQ_EXPR
, integer_type_node
,
3323 ffecom_expr (ffebld_left (expr
)),
3324 ffecom_expr (ffebld_right (expr
)));
3325 return convert (tree_type
, ffecom_truth_value (item
));
3327 case FFEINFO_basictypeINTEGER
:
3329 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3330 ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3331 ffecom_expr (ffebld_left (expr
)),
3332 ffecom_expr (ffebld_right (expr
))));
3335 assert ("EQV bad basictype" == NULL
);
3337 case FFEINFO_basictypeANY
:
3338 return error_mark_node
;
3342 case FFEBLD_opCONVERT
:
3343 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opANY
)
3344 return error_mark_node
;
3348 case FFEINFO_basictypeLOGICAL
:
3349 case FFEINFO_basictypeINTEGER
:
3350 case FFEINFO_basictypeREAL
:
3351 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3353 case FFEINFO_basictypeCOMPLEX
:
3354 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3356 case FFEINFO_basictypeINTEGER
:
3357 case FFEINFO_basictypeLOGICAL
:
3358 case FFEINFO_basictypeREAL
:
3359 item
= ffecom_expr (ffebld_left (expr
));
3360 if (item
== error_mark_node
)
3361 return error_mark_node
;
3362 /* convert() takes care of converting to the subtype first,
3363 at least in gcc-2.7.2. */
3364 item
= convert (tree_type
, item
);
3367 case FFEINFO_basictypeCOMPLEX
:
3368 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3371 assert ("CONVERT COMPLEX bad basictype" == NULL
);
3373 case FFEINFO_basictypeANY
:
3374 return error_mark_node
;
3379 assert ("CONVERT bad basictype" == NULL
);
3381 case FFEINFO_basictypeANY
:
3382 return error_mark_node
;
3388 goto relational
; /* :::::::::::::::::::: */
3392 goto relational
; /* :::::::::::::::::::: */
3396 goto relational
; /* :::::::::::::::::::: */
3400 goto relational
; /* :::::::::::::::::::: */
3404 goto relational
; /* :::::::::::::::::::: */
3409 relational
: /* :::::::::::::::::::: */
3410 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3412 case FFEINFO_basictypeLOGICAL
:
3413 case FFEINFO_basictypeINTEGER
:
3414 case FFEINFO_basictypeREAL
:
3415 item
= ffecom_2 (code
, integer_type_node
,
3416 ffecom_expr (ffebld_left (expr
)),
3417 ffecom_expr (ffebld_right (expr
)));
3418 return convert (tree_type
, item
);
3420 case FFEINFO_basictypeCOMPLEX
:
3421 assert (code
== EQ_EXPR
|| code
== NE_EXPR
);
3424 tree arg1
= ffecom_expr (ffebld_left (expr
));
3425 tree arg2
= ffecom_expr (ffebld_right (expr
));
3427 if (arg1
== error_mark_node
|| arg2
== error_mark_node
)
3428 return error_mark_node
;
3430 arg1
= ffecom_save_tree (arg1
);
3431 arg2
= ffecom_save_tree (arg2
);
3433 if (TREE_CODE (TREE_TYPE (arg1
)) == COMPLEX_TYPE
)
3435 real_type
= TREE_TYPE (TREE_TYPE (arg1
));
3436 assert (real_type
== TREE_TYPE (TREE_TYPE (arg2
)));
3440 real_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1
)));
3441 assert (real_type
== TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2
))));
3445 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3446 ffecom_2 (EQ_EXPR
, integer_type_node
,
3447 ffecom_1 (REALPART_EXPR
, real_type
, arg1
),
3448 ffecom_1 (REALPART_EXPR
, real_type
, arg2
)),
3449 ffecom_2 (EQ_EXPR
, integer_type_node
,
3450 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1
),
3451 ffecom_1 (IMAGPART_EXPR
, real_type
,
3453 if (code
== EQ_EXPR
)
3454 item
= ffecom_truth_value (item
);
3456 item
= ffecom_truth_value_invert (item
);
3457 return convert (tree_type
, item
);
3460 case FFEINFO_basictypeCHARACTER
:
3461 ffecom_push_calltemps (); /* Even though we might not call. */
3464 ffebld left
= ffebld_left (expr
);
3465 ffebld right
= ffebld_right (expr
);
3471 /* f2c run-time functions do the implicit blank-padding for us,
3472 so we don't usually have to implement blank-padding ourselves.
3473 (The exception is when we pass an argument to a separately
3474 compiled statement function -- if we know the arg is not the
3475 same length as the dummy, we must truncate or extend it. If
3476 we "inline" statement functions, that necessity goes away as
3479 Strip off the CONVERT operators that blank-pad. (Truncation by
3480 CONVERT shouldn't happen here, but it can happen in
3483 while (ffebld_op (left
) == FFEBLD_opCONVERT
)
3484 left
= ffebld_left (left
);
3485 while (ffebld_op (right
) == FFEBLD_opCONVERT
)
3486 right
= ffebld_left (right
);
3488 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
3489 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
3491 if (left_tree
== error_mark_node
|| left_length
== error_mark_node
3492 || right_tree
== error_mark_node
3493 || right_length
== error_mark_node
)
3495 ffecom_pop_calltemps ();
3496 return error_mark_node
;
3499 if ((ffebld_size_known (left
) == 1)
3500 && (ffebld_size_known (right
) == 1))
3503 = ffecom_1 (INDIRECT_REF
,
3504 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3507 = ffecom_1 (INDIRECT_REF
,
3508 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3512 = ffecom_2 (code
, integer_type_node
,
3513 ffecom_2 (ARRAY_REF
,
3514 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3517 ffecom_2 (ARRAY_REF
,
3518 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3524 item
= build_tree_list (NULL_TREE
, left_tree
);
3525 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, right_tree
);
3526 TREE_CHAIN (TREE_CHAIN (item
)) = build_tree_list (NULL_TREE
,
3528 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
3529 = build_tree_list (NULL_TREE
, right_length
);
3530 item
= ffecom_call_gfrt (FFECOM_gfrtCMP
, item
);
3531 item
= ffecom_2 (code
, integer_type_node
,
3533 convert (TREE_TYPE (item
),
3534 integer_zero_node
));
3536 item
= convert (tree_type
, item
);
3539 ffecom_pop_calltemps ();
3543 assert ("relational bad basictype" == NULL
);
3545 case FFEINFO_basictypeANY
:
3546 return error_mark_node
;
3550 case FFEBLD_opPERCENT_LOC
:
3551 item
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &list
);
3552 return convert (tree_type
, item
);
3556 case FFEBLD_opBOUNDS
:
3557 case FFEBLD_opREPEAT
:
3558 case FFEBLD_opLABTER
:
3559 case FFEBLD_opLABTOK
:
3560 case FFEBLD_opIMPDO
:
3561 case FFEBLD_opCONCATENATE
:
3562 case FFEBLD_opSUBSTR
:
3564 assert ("bad op" == NULL
);
3567 return error_mark_node
;
3571 assert ("didn't think anything got here anymore!!" == NULL
);
3573 switch (ffebld_arity (expr
))
3576 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3577 TREE_OPERAND (item
, 1) = ffecom_expr (ffebld_right (expr
));
3578 if (TREE_OPERAND (item
, 0) == error_mark_node
3579 || TREE_OPERAND (item
, 1) == error_mark_node
)
3580 return error_mark_node
;
3584 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3585 if (TREE_OPERAND (item
, 0) == error_mark_node
)
3586 return error_mark_node
;
3598 /* Returns the tree that does the intrinsic invocation.
3600 Note: this function applies only to intrinsics returning
3601 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3604 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3606 ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
3607 ffebld dest
, bool *dest_used
)
3610 tree saved_expr1
; /* For those who need it. */
3611 tree saved_expr2
; /* For those who need it. */
3612 ffeinfoBasictype bt
;
3616 tree real_type
; /* REAL type corresponding to COMPLEX. */
3618 ffebld list
= ffebld_right (expr
); /* List of (some) args. */
3619 ffebld arg1
; /* For handy reference. */
3622 ffeintrinImp codegen_imp
;
3625 assert (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
);
3627 if (dest_used
!= NULL
)
3630 bt
= ffeinfo_basictype (ffebld_info (expr
));
3631 kt
= ffeinfo_kindtype (ffebld_info (expr
));
3632 tree_type
= ffecom_tree_type
[bt
][kt
];
3636 arg1
= ffebld_head (list
);
3637 if (arg1
!= NULL
&& ffebld_op (arg1
) == FFEBLD_opANY
)
3638 return error_mark_node
;
3639 if ((list
= ffebld_trail (list
)) != NULL
)
3641 arg2
= ffebld_head (list
);
3642 if (arg2
!= NULL
&& ffebld_op (arg2
) == FFEBLD_opANY
)
3643 return error_mark_node
;
3644 if ((list
= ffebld_trail (list
)) != NULL
)
3646 arg3
= ffebld_head (list
);
3647 if (arg3
!= NULL
&& ffebld_op (arg3
) == FFEBLD_opANY
)
3648 return error_mark_node
;
3657 arg1
= arg2
= arg3
= NULL
;
3659 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3660 args. This is used by the MAX/MIN expansions. */
3663 arg1_type
= ffecom_tree_type
3664 [ffeinfo_basictype (ffebld_info (arg1
))]
3665 [ffeinfo_kindtype (ffebld_info (arg1
))];
3667 arg1_type
= NULL_TREE
; /* Really not needed, but might catch bugs
3670 /* There are several ways for each of the cases in the following switch
3671 statements to exit (from simplest to use to most complicated):
3673 break; (when expr_tree == NULL)
3675 A standard call is made to the specific intrinsic just as if it had been
3676 passed in as a dummy procedure and called as any old procedure. This
3677 method can produce slower code but in some cases it's the easiest way for
3678 now. However, if a (presumably faster) direct call is available,
3679 that is used, so this is the easiest way in many more cases now.
3681 gfrt = FFECOM_gfrtWHATEVER;
3684 gfrt contains the gfrt index of a library function to call, passing the
3685 argument(s) by value rather than by reference. Used when a more
3686 careful choice of library function is needed than that provided
3687 by the vanilla `break;'.
3691 The expr_tree has been completely set up and is ready to be returned
3692 as is. No further actions are taken. Use this when the tree is not
3693 in the simple form for one of the arity_n labels. */
3695 /* For info on how the switch statement cases were written, see the files
3696 enclosed in comments below the switch statement. */
3698 codegen_imp
= ffebld_symter_implementation (ffebld_left (expr
));
3699 gfrt
= ffeintrin_gfrt_direct (codegen_imp
);
3700 if (gfrt
== FFECOM_gfrt
)
3701 gfrt
= ffeintrin_gfrt_indirect (codegen_imp
);
3703 switch (codegen_imp
)
3705 case FFEINTRIN_impABS
:
3706 case FFEINTRIN_impCABS
:
3707 case FFEINTRIN_impCDABS
:
3708 case FFEINTRIN_impDABS
:
3709 case FFEINTRIN_impIABS
:
3710 if (ffeinfo_basictype (ffebld_info (arg1
))
3711 == FFEINFO_basictypeCOMPLEX
)
3713 if (kt
== FFEINFO_kindtypeREAL1
)
3714 gfrt
= FFECOM_gfrtCABS
;
3715 else if (kt
== FFEINFO_kindtypeREAL2
)
3716 gfrt
= FFECOM_gfrtCDABS
;
3719 return ffecom_1 (ABS_EXPR
, tree_type
,
3720 convert (tree_type
, ffecom_expr (arg1
)));
3722 case FFEINTRIN_impACOS
:
3723 case FFEINTRIN_impDACOS
:
3726 case FFEINTRIN_impAIMAG
:
3727 case FFEINTRIN_impDIMAG
:
3728 case FFEINTRIN_impIMAGPART
:
3729 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
3730 arg1_type
= TREE_TYPE (arg1_type
);
3732 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
3736 ffecom_1 (IMAGPART_EXPR
, arg1_type
,
3737 ffecom_expr (arg1
)));
3739 case FFEINTRIN_impAINT
:
3740 case FFEINTRIN_impDINT
:
3741 #if 0 /* ~~ someday implement FIX_TRUNC_EXPR
3742 yielding same type as arg */
3743 return ffecom_1 (FIX_TRUNC_EXPR
, tree_type
, ffecom_expr (arg1
));
3744 #else /* in the meantime, must use floor to avoid range problems with ints */
3745 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3746 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3749 ffecom_3 (COND_EXPR
, double_type_node
,
3751 (ffecom_2 (GE_EXPR
, integer_type_node
,
3754 ffecom_float_zero_
))),
3755 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3756 build_tree_list (NULL_TREE
,
3757 convert (double_type_node
,
3759 ffecom_1 (NEGATE_EXPR
, double_type_node
,
3760 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3761 build_tree_list (NULL_TREE
,
3762 convert (double_type_node
,
3763 ffecom_1 (NEGATE_EXPR
,
3770 case FFEINTRIN_impANINT
:
3771 case FFEINTRIN_impDNINT
:
3772 #if 0 /* This way of doing it won't handle real
3773 numbers of large magnitudes. */
3774 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3775 expr_tree
= convert (tree_type
,
3776 convert (integer_type_node
,
3777 ffecom_3 (COND_EXPR
, tree_type
,
3782 ffecom_float_zero_
)),
3783 ffecom_2 (PLUS_EXPR
,
3786 ffecom_float_half_
),
3787 ffecom_2 (MINUS_EXPR
,
3790 ffecom_float_half_
))));
3792 #else /* So we instead call floor. */
3793 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3794 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3797 ffecom_3 (COND_EXPR
, double_type_node
,
3799 (ffecom_2 (GE_EXPR
, integer_type_node
,
3802 ffecom_float_zero_
))),
3803 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3804 build_tree_list (NULL_TREE
,
3805 convert (double_type_node
,
3806 ffecom_2 (PLUS_EXPR
,
3810 ffecom_float_half_
))))),
3811 ffecom_1 (NEGATE_EXPR
, double_type_node
,
3812 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3813 build_tree_list (NULL_TREE
,
3814 convert (double_type_node
,
3815 ffecom_2 (MINUS_EXPR
,
3818 ffecom_float_half_
),
3824 case FFEINTRIN_impASIN
:
3825 case FFEINTRIN_impDASIN
:
3826 case FFEINTRIN_impATAN
:
3827 case FFEINTRIN_impDATAN
:
3828 case FFEINTRIN_impATAN2
:
3829 case FFEINTRIN_impDATAN2
:
3832 case FFEINTRIN_impCHAR
:
3833 case FFEINTRIN_impACHAR
:
3834 assert (ffecom_pending_calls_
!= 0);
3835 tempvar
= ffecom_push_tempvar (char_type_node
,
3838 tree tmv
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar
)));
3840 expr_tree
= ffecom_modify (tmv
,
3841 ffecom_2 (ARRAY_REF
, tmv
, tempvar
,
3843 convert (tmv
, ffecom_expr (arg1
)));
3845 expr_tree
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
),
3848 expr_tree
= ffecom_1 (ADDR_EXPR
,
3849 build_pointer_type (TREE_TYPE (expr_tree
)),
3853 case FFEINTRIN_impCMPLX
:
3854 case FFEINTRIN_impDCMPLX
:
3857 convert (tree_type
, ffecom_expr (arg1
));
3859 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
3861 ffecom_2 (COMPLEX_EXPR
, tree_type
,
3862 convert (real_type
, ffecom_expr (arg1
)),
3864 ffecom_expr (arg2
)));
3866 case FFEINTRIN_impCOMPLEX
:
3868 ffecom_2 (COMPLEX_EXPR
, tree_type
,
3870 ffecom_expr (arg2
));
3872 case FFEINTRIN_impCONJG
:
3873 case FFEINTRIN_impDCONJG
:
3877 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
3878 arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
3880 ffecom_2 (COMPLEX_EXPR
, tree_type
,
3881 ffecom_1 (REALPART_EXPR
, real_type
, arg1_tree
),
3882 ffecom_1 (NEGATE_EXPR
, real_type
,
3883 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1_tree
)));
3886 case FFEINTRIN_impCOS
:
3887 case FFEINTRIN_impCCOS
:
3888 case FFEINTRIN_impCDCOS
:
3889 case FFEINTRIN_impDCOS
:
3890 if (bt
== FFEINFO_basictypeCOMPLEX
)
3892 if (kt
== FFEINFO_kindtypeREAL1
)
3893 gfrt
= FFECOM_gfrtCCOS
; /* Overlapping result okay. */
3894 else if (kt
== FFEINFO_kindtypeREAL2
)
3895 gfrt
= FFECOM_gfrtCDCOS
; /* Overlapping result okay. */
3899 case FFEINTRIN_impCOSH
:
3900 case FFEINTRIN_impDCOSH
:
3903 case FFEINTRIN_impDBLE
:
3904 case FFEINTRIN_impDFLOAT
:
3905 case FFEINTRIN_impDREAL
:
3906 case FFEINTRIN_impFLOAT
:
3907 case FFEINTRIN_impIDINT
:
3908 case FFEINTRIN_impIFIX
:
3909 case FFEINTRIN_impINT2
:
3910 case FFEINTRIN_impINT8
:
3911 case FFEINTRIN_impINT
:
3912 case FFEINTRIN_impLONG
:
3913 case FFEINTRIN_impREAL
:
3914 case FFEINTRIN_impSHORT
:
3915 case FFEINTRIN_impSNGL
:
3916 return convert (tree_type
, ffecom_expr (arg1
));
3918 case FFEINTRIN_impDIM
:
3919 case FFEINTRIN_impDDIM
:
3920 case FFEINTRIN_impIDIM
:
3921 saved_expr1
= ffecom_save_tree (convert (tree_type
,
3922 ffecom_expr (arg1
)));
3923 saved_expr2
= ffecom_save_tree (convert (tree_type
,
3924 ffecom_expr (arg2
)));
3926 ffecom_3 (COND_EXPR
, tree_type
,
3928 (ffecom_2 (GT_EXPR
, integer_type_node
,
3931 ffecom_2 (MINUS_EXPR
, tree_type
,
3934 convert (tree_type
, ffecom_float_zero_
));
3936 case FFEINTRIN_impDPROD
:
3938 ffecom_2 (MULT_EXPR
, tree_type
,
3939 convert (tree_type
, ffecom_expr (arg1
)),
3940 convert (tree_type
, ffecom_expr (arg2
)));
3942 case FFEINTRIN_impEXP
:
3943 case FFEINTRIN_impCDEXP
:
3944 case FFEINTRIN_impCEXP
:
3945 case FFEINTRIN_impDEXP
:
3946 if (bt
== FFEINFO_basictypeCOMPLEX
)
3948 if (kt
== FFEINFO_kindtypeREAL1
)
3949 gfrt
= FFECOM_gfrtCEXP
; /* Overlapping result okay. */
3950 else if (kt
== FFEINFO_kindtypeREAL2
)
3951 gfrt
= FFECOM_gfrtCDEXP
; /* Overlapping result okay. */
3955 case FFEINTRIN_impICHAR
:
3956 case FFEINTRIN_impIACHAR
:
3957 #if 0 /* The simple approach. */
3958 ffecom_char_args_ (&expr_tree
, &saved_expr1
/* Ignored */ , arg1
);
3960 = ffecom_1 (INDIRECT_REF
,
3961 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
3964 = ffecom_2 (ARRAY_REF
,
3965 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
3968 return convert (tree_type
, expr_tree
);
3969 #else /* The more interesting (and more optimal) approach. */
3970 expr_tree
= ffecom_intrinsic_ichar_ (tree_type
, arg1
, &saved_expr1
);
3971 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
3974 convert (tree_type
, integer_zero_node
));
3978 case FFEINTRIN_impINDEX
:
3981 case FFEINTRIN_impLEN
:
3983 break; /* The simple approach. */
3985 return ffecom_intrinsic_len_ (arg1
); /* The more optimal approach. */
3988 case FFEINTRIN_impLGE
:
3989 case FFEINTRIN_impLGT
:
3990 case FFEINTRIN_impLLE
:
3991 case FFEINTRIN_impLLT
:
3994 case FFEINTRIN_impLOG
:
3995 case FFEINTRIN_impALOG
:
3996 case FFEINTRIN_impCDLOG
:
3997 case FFEINTRIN_impCLOG
:
3998 case FFEINTRIN_impDLOG
:
3999 if (bt
== FFEINFO_basictypeCOMPLEX
)
4001 if (kt
== FFEINFO_kindtypeREAL1
)
4002 gfrt
= FFECOM_gfrtCLOG
; /* Overlapping result okay. */
4003 else if (kt
== FFEINFO_kindtypeREAL2
)
4004 gfrt
= FFECOM_gfrtCDLOG
; /* Overlapping result okay. */
4008 case FFEINTRIN_impLOG10
:
4009 case FFEINTRIN_impALOG10
:
4010 case FFEINTRIN_impDLOG10
:
4011 if (gfrt
!= FFECOM_gfrt
)
4012 break; /* Already picked one, stick with it. */
4014 if (kt
== FFEINFO_kindtypeREAL1
)
4015 gfrt
= FFECOM_gfrtALOG10
;
4016 else if (kt
== FFEINFO_kindtypeREAL2
)
4017 gfrt
= FFECOM_gfrtDLOG10
;
4020 case FFEINTRIN_impMAX
:
4021 case FFEINTRIN_impAMAX0
:
4022 case FFEINTRIN_impAMAX1
:
4023 case FFEINTRIN_impDMAX1
:
4024 case FFEINTRIN_impMAX0
:
4025 case FFEINTRIN_impMAX1
:
4026 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4027 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4029 arg1_type
= tree_type
;
4030 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4031 convert (arg1_type
, ffecom_expr (arg1
)),
4032 convert (arg1_type
, ffecom_expr (arg2
)));
4033 for (; list
!= NULL
; list
= ffebld_trail (list
))
4035 if ((ffebld_head (list
) == NULL
)
4036 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4038 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4041 ffecom_expr (ffebld_head (list
))));
4043 return convert (tree_type
, expr_tree
);
4045 case FFEINTRIN_impMIN
:
4046 case FFEINTRIN_impAMIN0
:
4047 case FFEINTRIN_impAMIN1
:
4048 case FFEINTRIN_impDMIN1
:
4049 case FFEINTRIN_impMIN0
:
4050 case FFEINTRIN_impMIN1
:
4051 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4052 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4054 arg1_type
= tree_type
;
4055 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4056 convert (arg1_type
, ffecom_expr (arg1
)),
4057 convert (arg1_type
, ffecom_expr (arg2
)));
4058 for (; list
!= NULL
; list
= ffebld_trail (list
))
4060 if ((ffebld_head (list
) == NULL
)
4061 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4063 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4066 ffecom_expr (ffebld_head (list
))));
4068 return convert (tree_type
, expr_tree
);
4070 case FFEINTRIN_impMOD
:
4071 case FFEINTRIN_impAMOD
:
4072 case FFEINTRIN_impDMOD
:
4073 if (bt
!= FFEINFO_basictypeREAL
)
4074 return ffecom_2 (TRUNC_MOD_EXPR
, tree_type
,
4075 convert (tree_type
, ffecom_expr (arg1
)),
4076 convert (tree_type
, ffecom_expr (arg2
)));
4078 if (kt
== FFEINFO_kindtypeREAL1
)
4079 gfrt
= FFECOM_gfrtAMOD
;
4080 else if (kt
== FFEINFO_kindtypeREAL2
)
4081 gfrt
= FFECOM_gfrtDMOD
;
4084 case FFEINTRIN_impNINT
:
4085 case FFEINTRIN_impIDNINT
:
4086 #if 0 /* ~~ ideally FIX_ROUND_EXPR would be
4087 implemented, but it ain't yet */
4088 return ffecom_1 (FIX_ROUND_EXPR
, tree_type
, ffecom_expr (arg1
));
4090 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4091 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4093 convert (ffecom_integer_type_node
,
4094 ffecom_3 (COND_EXPR
, arg1_type
,
4096 (ffecom_2 (GE_EXPR
, integer_type_node
,
4099 ffecom_float_zero_
))),
4100 ffecom_2 (PLUS_EXPR
, arg1_type
,
4103 ffecom_float_half_
)),
4104 ffecom_2 (MINUS_EXPR
, arg1_type
,
4107 ffecom_float_half_
))));
4110 case FFEINTRIN_impSIGN
:
4111 case FFEINTRIN_impDSIGN
:
4112 case FFEINTRIN_impISIGN
:
4114 tree arg2_tree
= ffecom_expr (arg2
);
4118 (ffecom_1 (ABS_EXPR
, tree_type
,
4120 ffecom_expr (arg1
))));
4122 = ffecom_3 (COND_EXPR
, tree_type
,
4124 (ffecom_2 (GE_EXPR
, integer_type_node
,
4126 convert (TREE_TYPE (arg2_tree
),
4127 integer_zero_node
))),
4129 ffecom_1 (NEGATE_EXPR
, tree_type
, saved_expr1
));
4130 /* Make sure SAVE_EXPRs get referenced early enough. */
4132 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4133 convert (void_type_node
, saved_expr1
),
4138 case FFEINTRIN_impSIN
:
4139 case FFEINTRIN_impCDSIN
:
4140 case FFEINTRIN_impCSIN
:
4141 case FFEINTRIN_impDSIN
:
4142 if (bt
== FFEINFO_basictypeCOMPLEX
)
4144 if (kt
== FFEINFO_kindtypeREAL1
)
4145 gfrt
= FFECOM_gfrtCSIN
; /* Overlapping result okay. */
4146 else if (kt
== FFEINFO_kindtypeREAL2
)
4147 gfrt
= FFECOM_gfrtCDSIN
; /* Overlapping result okay. */
4151 case FFEINTRIN_impSINH
:
4152 case FFEINTRIN_impDSINH
:
4155 case FFEINTRIN_impSQRT
:
4156 case FFEINTRIN_impCDSQRT
:
4157 case FFEINTRIN_impCSQRT
:
4158 case FFEINTRIN_impDSQRT
:
4159 if (bt
== FFEINFO_basictypeCOMPLEX
)
4161 if (kt
== FFEINFO_kindtypeREAL1
)
4162 gfrt
= FFECOM_gfrtCSQRT
; /* Overlapping result okay. */
4163 else if (kt
== FFEINFO_kindtypeREAL2
)
4164 gfrt
= FFECOM_gfrtCDSQRT
; /* Overlapping result okay. */
4168 case FFEINTRIN_impTAN
:
4169 case FFEINTRIN_impDTAN
:
4170 case FFEINTRIN_impTANH
:
4171 case FFEINTRIN_impDTANH
:
4174 case FFEINTRIN_impREALPART
:
4175 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
4176 arg1_type
= TREE_TYPE (arg1_type
);
4178 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
4182 ffecom_1 (REALPART_EXPR
, arg1_type
,
4183 ffecom_expr (arg1
)));
4185 case FFEINTRIN_impIAND
:
4186 case FFEINTRIN_impAND
:
4187 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
4189 ffecom_expr (arg1
)),
4191 ffecom_expr (arg2
)));
4193 case FFEINTRIN_impIOR
:
4194 case FFEINTRIN_impOR
:
4195 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4197 ffecom_expr (arg1
)),
4199 ffecom_expr (arg2
)));
4201 case FFEINTRIN_impIEOR
:
4202 case FFEINTRIN_impXOR
:
4203 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
4205 ffecom_expr (arg1
)),
4207 ffecom_expr (arg2
)));
4209 case FFEINTRIN_impLSHIFT
:
4210 return ffecom_2 (LSHIFT_EXPR
, tree_type
,
4212 convert (integer_type_node
,
4213 ffecom_expr (arg2
)));
4215 case FFEINTRIN_impRSHIFT
:
4216 return ffecom_2 (RSHIFT_EXPR
, tree_type
,
4218 convert (integer_type_node
,
4219 ffecom_expr (arg2
)));
4221 case FFEINTRIN_impNOT
:
4222 return ffecom_1 (BIT_NOT_EXPR
, tree_type
, ffecom_expr (arg1
));
4224 case FFEINTRIN_impBIT_SIZE
:
4225 return convert (tree_type
, TYPE_SIZE (arg1_type
));
4227 case FFEINTRIN_impBTEST
:
4229 ffetargetLogical1
true;
4230 ffetargetLogical1
false;
4234 ffetarget_logical1 (&true, TRUE
);
4235 ffetarget_logical1 (&false, FALSE
);
4237 true_tree
= convert (tree_type
, integer_one_node
);
4239 true_tree
= convert (tree_type
, build_int_2 (true, 0));
4241 false_tree
= convert (tree_type
, integer_zero_node
);
4243 false_tree
= convert (tree_type
, build_int_2 (false, 0));
4246 ffecom_3 (COND_EXPR
, tree_type
,
4248 (ffecom_2 (EQ_EXPR
, integer_type_node
,
4249 ffecom_2 (BIT_AND_EXPR
, arg1_type
,
4251 ffecom_2 (LSHIFT_EXPR
, arg1_type
,
4254 convert (integer_type_node
,
4255 ffecom_expr (arg2
)))),
4257 integer_zero_node
))),
4262 case FFEINTRIN_impIBCLR
:
4264 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4266 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4267 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4270 convert (integer_type_node
,
4271 ffecom_expr (arg2
)))));
4273 case FFEINTRIN_impIBITS
:
4275 tree arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4276 ffecom_expr (arg3
)));
4278 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4281 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4282 ffecom_2 (RSHIFT_EXPR
, tree_type
,
4284 convert (integer_type_node
,
4285 ffecom_expr (arg2
))),
4287 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4288 ffecom_1 (BIT_NOT_EXPR
,
4291 integer_zero_node
)),
4292 ffecom_2 (MINUS_EXPR
,
4294 TYPE_SIZE (uns_type
),
4296 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4298 = ffecom_3 (COND_EXPR
, tree_type
,
4300 (ffecom_2 (NE_EXPR
, integer_type_node
,
4302 integer_zero_node
)),
4304 convert (tree_type
, integer_zero_node
));
4309 case FFEINTRIN_impIBSET
:
4311 ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4313 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4314 convert (tree_type
, integer_one_node
),
4315 convert (integer_type_node
,
4316 ffecom_expr (arg2
))));
4318 case FFEINTRIN_impISHFT
:
4320 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4321 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4322 ffecom_expr (arg2
)));
4324 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4327 = ffecom_3 (COND_EXPR
, tree_type
,
4329 (ffecom_2 (GE_EXPR
, integer_type_node
,
4331 integer_zero_node
)),
4332 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4336 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4337 convert (uns_type
, arg1_tree
),
4338 ffecom_1 (NEGATE_EXPR
,
4341 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4343 = ffecom_3 (COND_EXPR
, tree_type
,
4345 (ffecom_2 (NE_EXPR
, integer_type_node
,
4347 TYPE_SIZE (uns_type
))),
4349 convert (tree_type
, integer_zero_node
));
4351 /* Make sure SAVE_EXPRs get referenced early enough. */
4353 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4354 convert (void_type_node
, arg1_tree
),
4355 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4356 convert (void_type_node
, arg2_tree
),
4361 case FFEINTRIN_impISHFTC
:
4363 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4364 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4365 ffecom_expr (arg2
)));
4366 tree arg3_tree
= (arg3
== NULL
) ? TYPE_SIZE (tree_type
)
4367 : ffecom_save_tree (convert (integer_type_node
, ffecom_expr (arg3
)));
4373 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4376 = ffecom_2 (LSHIFT_EXPR
, tree_type
,
4377 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4378 convert (tree_type
, integer_zero_node
)),
4380 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4382 = ffecom_3 (COND_EXPR
, tree_type
,
4384 (ffecom_2 (NE_EXPR
, integer_type_node
,
4386 TYPE_SIZE (uns_type
))),
4388 convert (tree_type
, integer_zero_node
));
4390 mask_arg1
= ffecom_save_tree (mask_arg1
);
4392 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4394 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4396 masked_arg1
= ffecom_save_tree (masked_arg1
);
4398 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4400 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4401 convert (uns_type
, masked_arg1
),
4402 ffecom_1 (NEGATE_EXPR
,
4405 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4407 ffecom_2 (PLUS_EXPR
, integer_type_node
,
4411 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4412 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4416 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4417 convert (uns_type
, masked_arg1
),
4418 ffecom_2 (MINUS_EXPR
,
4423 = ffecom_3 (COND_EXPR
, tree_type
,
4425 (ffecom_2 (LT_EXPR
, integer_type_node
,
4427 integer_zero_node
)),
4431 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4432 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4435 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4436 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4440 = ffecom_3 (COND_EXPR
, tree_type
,
4442 (ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
4443 ffecom_2 (EQ_EXPR
, integer_type_node
,
4448 ffecom_2 (EQ_EXPR
, integer_type_node
,
4450 integer_zero_node
))),
4453 /* Make sure SAVE_EXPRs get referenced early enough. */
4455 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4456 convert (void_type_node
, arg1_tree
),
4457 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4458 convert (void_type_node
, arg2_tree
),
4459 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4460 convert (void_type_node
,
4462 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4463 convert (void_type_node
,
4467 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4468 convert (void_type_node
,
4474 case FFEINTRIN_impLOC
:
4476 tree arg1_tree
= ffecom_expr (arg1
);
4479 = convert (tree_type
,
4480 ffecom_1 (ADDR_EXPR
,
4481 build_pointer_type (TREE_TYPE (arg1_tree
)),
4486 case FFEINTRIN_impMVBITS
:
4491 ffebld arg4
= ffebld_head (ffebld_trail (list
));
4494 ffebld arg5
= ffebld_head (ffebld_trail (ffebld_trail (list
)));
4498 tree arg5_plus_arg3
;
4500 ffecom_push_calltemps ();
4502 arg2_tree
= convert (integer_type_node
,
4503 ffecom_expr (arg2
));
4504 arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4505 ffecom_expr (arg3
)));
4506 arg4_tree
= ffecom_expr_rw (arg4
);
4507 arg4_type
= TREE_TYPE (arg4_tree
);
4509 arg1_tree
= ffecom_save_tree (convert (arg4_type
,
4510 ffecom_expr (arg1
)));
4512 arg5_tree
= ffecom_save_tree (convert (integer_type_node
,
4513 ffecom_expr (arg5
)));
4515 ffecom_pop_calltemps ();
4518 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4519 ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4520 ffecom_2 (RSHIFT_EXPR
, arg4_type
,
4523 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4524 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4525 ffecom_1 (BIT_NOT_EXPR
,
4529 integer_zero_node
)),
4533 = ffecom_save_tree (ffecom_2 (PLUS_EXPR
, arg4_type
,
4537 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4538 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4540 integer_zero_node
)),
4542 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4544 = ffecom_3 (COND_EXPR
, arg4_type
,
4546 (ffecom_2 (NE_EXPR
, integer_type_node
,
4548 convert (TREE_TYPE (arg5_plus_arg3
),
4549 TYPE_SIZE (arg4_type
)))),
4551 convert (arg4_type
, integer_zero_node
));
4554 = ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4556 ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4558 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4559 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4560 ffecom_1 (BIT_NOT_EXPR
,
4564 integer_zero_node
)),
4567 = ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4570 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4572 = ffecom_3 (COND_EXPR
, arg4_type
,
4574 (ffecom_2 (NE_EXPR
, integer_type_node
,
4576 convert (TREE_TYPE (arg3_tree
),
4577 integer_zero_node
))),
4581 = ffecom_3 (COND_EXPR
, arg4_type
,
4583 (ffecom_2 (NE_EXPR
, integer_type_node
,
4585 convert (TREE_TYPE (arg3_tree
),
4586 TYPE_SIZE (arg4_type
)))),
4591 = ffecom_2s (MODIFY_EXPR
, void_type_node
,
4594 /* Make sure SAVE_EXPRs get referenced early enough. */
4596 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4598 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4600 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4602 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4606 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4613 case FFEINTRIN_impDERF
:
4614 case FFEINTRIN_impERF
:
4615 case FFEINTRIN_impDERFC
:
4616 case FFEINTRIN_impERFC
:
4619 case FFEINTRIN_impIARGC
:
4620 /* extern int xargc; i__1 = xargc - 1; */
4621 expr_tree
= ffecom_2 (MINUS_EXPR
, TREE_TYPE (ffecom_tree_xargc_
),
4623 convert (TREE_TYPE (ffecom_tree_xargc_
),
4627 case FFEINTRIN_impSIGNAL_func
:
4628 case FFEINTRIN_impSIGNAL_subr
:
4634 ffecom_push_calltemps ();
4636 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4637 ffecom_expr (arg1
));
4638 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4639 build_pointer_type (TREE_TYPE (arg1_tree
)),
4642 /* Pass procedure as a pointer to it, anything else by value. */
4643 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4644 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4646 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4647 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4651 arg3_tree
= ffecom_expr_rw (arg3
);
4653 arg3_tree
= NULL_TREE
;
4655 ffecom_pop_calltemps ();
4657 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4658 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4659 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4662 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4663 ffecom_gfrt_kindtype (gfrt
),
4665 ((codegen_imp
== FFEINTRIN_impSIGNAL_subr
) ?
4669 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4671 if (arg3_tree
!= NULL_TREE
)
4673 = ffecom_modify (NULL_TREE
, arg3_tree
,
4674 convert (TREE_TYPE (arg3_tree
),
4679 case FFEINTRIN_impALARM
:
4685 ffecom_push_calltemps ();
4687 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4688 ffecom_expr (arg1
));
4689 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4690 build_pointer_type (TREE_TYPE (arg1_tree
)),
4693 /* Pass procedure as a pointer to it, anything else by value. */
4694 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4695 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4697 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4698 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4702 arg3_tree
= ffecom_expr_rw (arg3
);
4704 arg3_tree
= NULL_TREE
;
4706 ffecom_pop_calltemps ();
4708 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4709 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4710 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4713 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4714 ffecom_gfrt_kindtype (gfrt
),
4718 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4720 if (arg3_tree
!= NULL_TREE
)
4722 = ffecom_modify (NULL_TREE
, arg3_tree
,
4723 convert (TREE_TYPE (arg3_tree
),
4728 case FFEINTRIN_impCHDIR_subr
:
4729 case FFEINTRIN_impFDATE_subr
:
4730 case FFEINTRIN_impFGET_subr
:
4731 case FFEINTRIN_impFPUT_subr
:
4732 case FFEINTRIN_impGETCWD_subr
:
4733 case FFEINTRIN_impHOSTNM_subr
:
4734 case FFEINTRIN_impSYSTEM_subr
:
4735 case FFEINTRIN_impUNLINK_subr
:
4737 tree arg1_len
= integer_zero_node
;
4741 ffecom_push_calltemps ();
4743 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4746 arg2_tree
= ffecom_expr_rw (arg2
);
4748 arg2_tree
= NULL_TREE
;
4750 ffecom_pop_calltemps ();
4752 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4753 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4754 TREE_CHAIN (arg1_tree
) = arg1_len
;
4757 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4758 ffecom_gfrt_kindtype (gfrt
),
4762 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4764 if (arg2_tree
!= NULL_TREE
)
4766 = ffecom_modify (NULL_TREE
, arg2_tree
,
4767 convert (TREE_TYPE (arg2_tree
),
4772 case FFEINTRIN_impEXIT
:
4776 expr_tree
= build_tree_list (NULL_TREE
,
4777 ffecom_1 (ADDR_EXPR
,
4779 (ffecom_integer_type_node
),
4780 integer_zero_node
));
4783 ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4784 ffecom_gfrt_kindtype (gfrt
),
4788 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4790 case FFEINTRIN_impFLUSH
:
4792 gfrt
= FFECOM_gfrtFLUSH
;
4794 gfrt
= FFECOM_gfrtFLUSH1
;
4797 case FFEINTRIN_impCHMOD_subr
:
4798 case FFEINTRIN_impLINK_subr
:
4799 case FFEINTRIN_impRENAME_subr
:
4800 case FFEINTRIN_impSYMLNK_subr
:
4802 tree arg1_len
= integer_zero_node
;
4804 tree arg2_len
= integer_zero_node
;
4808 ffecom_push_calltemps ();
4810 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4811 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
4813 arg3_tree
= ffecom_expr_rw (arg3
);
4815 arg3_tree
= NULL_TREE
;
4817 ffecom_pop_calltemps ();
4819 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4820 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4821 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4822 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
4823 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4824 TREE_CHAIN (arg2_tree
) = arg1_len
;
4825 TREE_CHAIN (arg1_len
) = arg2_len
;
4826 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4827 ffecom_gfrt_kindtype (gfrt
),
4831 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4832 if (arg3_tree
!= NULL_TREE
)
4833 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4834 convert (TREE_TYPE (arg3_tree
),
4839 case FFEINTRIN_impLSTAT_subr
:
4840 case FFEINTRIN_impSTAT_subr
:
4842 tree arg1_len
= integer_zero_node
;
4847 ffecom_push_calltemps ();
4849 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4851 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4854 arg3_tree
= ffecom_expr_rw (arg3
);
4856 arg3_tree
= NULL_TREE
;
4858 ffecom_pop_calltemps ();
4860 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4861 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4862 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4863 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4864 TREE_CHAIN (arg2_tree
) = arg1_len
;
4865 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4866 ffecom_gfrt_kindtype (gfrt
),
4870 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4871 if (arg3_tree
!= NULL_TREE
)
4872 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4873 convert (TREE_TYPE (arg3_tree
),
4878 case FFEINTRIN_impFGETC_subr
:
4879 case FFEINTRIN_impFPUTC_subr
:
4883 tree arg2_len
= integer_zero_node
;
4886 ffecom_push_calltemps ();
4888 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4889 ffecom_expr (arg1
));
4890 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4891 build_pointer_type (TREE_TYPE (arg1_tree
)),
4894 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
4895 arg3_tree
= ffecom_expr_rw (arg3
);
4897 ffecom_pop_calltemps ();
4899 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4900 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4901 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
4902 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4903 TREE_CHAIN (arg2_tree
) = arg2_len
;
4905 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4906 ffecom_gfrt_kindtype (gfrt
),
4910 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4911 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4912 convert (TREE_TYPE (arg3_tree
),
4917 case FFEINTRIN_impFSTAT_subr
:
4923 ffecom_push_calltemps ();
4925 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4926 ffecom_expr (arg1
));
4927 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4928 build_pointer_type (TREE_TYPE (arg1_tree
)),
4931 arg2_tree
= convert (ffecom_f2c_ptr_to_integer_type_node
,
4932 ffecom_ptr_to_expr (arg2
));
4935 arg3_tree
= NULL_TREE
;
4937 arg3_tree
= ffecom_expr_rw (arg3
);
4939 ffecom_pop_calltemps ();
4941 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4942 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4943 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4944 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4945 ffecom_gfrt_kindtype (gfrt
),
4949 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4950 if (arg3_tree
!= NULL_TREE
) {
4951 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4952 convert (TREE_TYPE (arg3_tree
),
4958 case FFEINTRIN_impKILL_subr
:
4964 ffecom_push_calltemps ();
4966 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4967 ffecom_expr (arg1
));
4968 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4969 build_pointer_type (TREE_TYPE (arg1_tree
)),
4972 arg2_tree
= convert (ffecom_f2c_integer_type_node
,
4973 ffecom_expr (arg2
));
4974 arg2_tree
= ffecom_1 (ADDR_EXPR
,
4975 build_pointer_type (TREE_TYPE (arg2_tree
)),
4979 arg3_tree
= NULL_TREE
;
4981 arg3_tree
= ffecom_expr_rw (arg3
);
4983 ffecom_pop_calltemps ();
4985 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4986 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4987 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4988 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4989 ffecom_gfrt_kindtype (gfrt
),
4993 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
4994 if (arg3_tree
!= NULL_TREE
) {
4995 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
4996 convert (TREE_TYPE (arg3_tree
),
5002 case FFEINTRIN_impCTIME_subr
:
5003 case FFEINTRIN_impTTYNAM_subr
:
5005 tree arg1_len
= integer_zero_node
;
5009 ffecom_push_calltemps ();
5011 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
5013 arg2_tree
= convert (((gfrt
== FFEINTRIN_impCTIME_subr
) ?
5014 ffecom_f2c_longint_type_node
:
5015 ffecom_f2c_integer_type_node
),
5016 ffecom_expr (arg2
));
5017 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5018 build_pointer_type (TREE_TYPE (arg2_tree
)),
5021 ffecom_pop_calltemps ();
5023 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5024 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5025 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5026 TREE_CHAIN (arg1_len
) = arg2_tree
;
5027 TREE_CHAIN (arg1_tree
) = arg1_len
;
5030 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5031 ffecom_gfrt_kindtype (gfrt
),
5035 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
5039 case FFEINTRIN_impIRAND
:
5040 case FFEINTRIN_impRAND
:
5041 /* Arg defaults to 0 (normal random case) */
5046 arg1_tree
= ffecom_integer_zero_node
;
5048 arg1_tree
= ffecom_expr (arg1
);
5049 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5051 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5052 build_pointer_type (TREE_TYPE (arg1_tree
)),
5054 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5056 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5057 ffecom_gfrt_kindtype (gfrt
),
5059 ((codegen_imp
== FFEINTRIN_impIRAND
) ?
5060 ffecom_f2c_integer_type_node
:
5061 ffecom_f2c_doublereal_type_node
),
5063 dest_tree
, dest
, dest_used
,
5068 case FFEINTRIN_impFTELL_subr
:
5069 case FFEINTRIN_impUMASK_subr
:
5074 ffecom_push_calltemps ();
5076 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5077 ffecom_expr (arg1
));
5078 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5079 build_pointer_type (TREE_TYPE (arg1_tree
)),
5083 arg2_tree
= NULL_TREE
;
5085 arg2_tree
= ffecom_expr_rw (arg2
);
5087 ffecom_pop_calltemps ();
5089 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5090 ffecom_gfrt_kindtype (gfrt
),
5093 build_tree_list (NULL_TREE
, arg1_tree
),
5094 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5096 if (arg2_tree
!= NULL_TREE
) {
5097 expr_tree
= ffecom_modify (NULL_TREE
, arg2_tree
,
5098 convert (TREE_TYPE (arg2_tree
),
5104 case FFEINTRIN_impCPU_TIME
:
5105 case FFEINTRIN_impSECOND_subr
:
5109 ffecom_push_calltemps ();
5111 arg1_tree
= ffecom_expr_rw (arg1
);
5113 ffecom_pop_calltemps ();
5116 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5117 ffecom_gfrt_kindtype (gfrt
),
5121 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
);
5124 = ffecom_modify (NULL_TREE
, arg1_tree
,
5125 convert (TREE_TYPE (arg1_tree
),
5130 case FFEINTRIN_impDTIME_subr
:
5131 case FFEINTRIN_impETIME_subr
:
5136 ffecom_push_calltemps ();
5138 arg1_tree
= ffecom_expr_rw (arg1
);
5140 arg2_tree
= ffecom_ptr_to_expr (arg2
);
5142 ffecom_pop_calltemps ();
5144 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5145 ffecom_gfrt_kindtype (gfrt
),
5148 build_tree_list (NULL_TREE
, arg2_tree
),
5149 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5151 expr_tree
= ffecom_modify (NULL_TREE
, arg1_tree
,
5152 convert (TREE_TYPE (arg1_tree
),
5157 /* Straightforward calls of libf2c routines: */
5158 case FFEINTRIN_impABORT
:
5159 case FFEINTRIN_impACCESS
:
5160 case FFEINTRIN_impBESJ0
:
5161 case FFEINTRIN_impBESJ1
:
5162 case FFEINTRIN_impBESJN
:
5163 case FFEINTRIN_impBESY0
:
5164 case FFEINTRIN_impBESY1
:
5165 case FFEINTRIN_impBESYN
:
5166 case FFEINTRIN_impCHDIR_func
:
5167 case FFEINTRIN_impCHMOD_func
:
5168 case FFEINTRIN_impDATE
:
5169 case FFEINTRIN_impDBESJ0
:
5170 case FFEINTRIN_impDBESJ1
:
5171 case FFEINTRIN_impDBESJN
:
5172 case FFEINTRIN_impDBESY0
:
5173 case FFEINTRIN_impDBESY1
:
5174 case FFEINTRIN_impDBESYN
:
5175 case FFEINTRIN_impDTIME_func
:
5176 case FFEINTRIN_impETIME_func
:
5177 case FFEINTRIN_impFGETC_func
:
5178 case FFEINTRIN_impFGET_func
:
5179 case FFEINTRIN_impFNUM
:
5180 case FFEINTRIN_impFPUTC_func
:
5181 case FFEINTRIN_impFPUT_func
:
5182 case FFEINTRIN_impFSEEK
:
5183 case FFEINTRIN_impFSTAT_func
:
5184 case FFEINTRIN_impFTELL_func
:
5185 case FFEINTRIN_impGERROR
:
5186 case FFEINTRIN_impGETARG
:
5187 case FFEINTRIN_impGETCWD_func
:
5188 case FFEINTRIN_impGETENV
:
5189 case FFEINTRIN_impGETGID
:
5190 case FFEINTRIN_impGETLOG
:
5191 case FFEINTRIN_impGETPID
:
5192 case FFEINTRIN_impGETUID
:
5193 case FFEINTRIN_impGMTIME
:
5194 case FFEINTRIN_impHOSTNM_func
:
5195 case FFEINTRIN_impIDATE_unix
:
5196 case FFEINTRIN_impIDATE_vxt
:
5197 case FFEINTRIN_impIERRNO
:
5198 case FFEINTRIN_impISATTY
:
5199 case FFEINTRIN_impITIME
:
5200 case FFEINTRIN_impKILL_func
:
5201 case FFEINTRIN_impLINK_func
:
5202 case FFEINTRIN_impLNBLNK
:
5203 case FFEINTRIN_impLSTAT_func
:
5204 case FFEINTRIN_impLTIME
:
5205 case FFEINTRIN_impMCLOCK8
:
5206 case FFEINTRIN_impMCLOCK
:
5207 case FFEINTRIN_impPERROR
:
5208 case FFEINTRIN_impRENAME_func
:
5209 case FFEINTRIN_impSECNDS
:
5210 case FFEINTRIN_impSECOND_func
:
5211 case FFEINTRIN_impSLEEP
:
5212 case FFEINTRIN_impSRAND
:
5213 case FFEINTRIN_impSTAT_func
:
5214 case FFEINTRIN_impSYMLNK_func
:
5215 case FFEINTRIN_impSYSTEM_CLOCK
:
5216 case FFEINTRIN_impSYSTEM_func
:
5217 case FFEINTRIN_impTIME8
:
5218 case FFEINTRIN_impTIME_unix
:
5219 case FFEINTRIN_impTIME_vxt
:
5220 case FFEINTRIN_impUMASK_func
:
5221 case FFEINTRIN_impUNLINK_func
:
5224 case FFEINTRIN_impCTIME_func
: /* CHARACTER functions not handled here. */
5225 case FFEINTRIN_impFDATE_func
: /* CHARACTER functions not handled here. */
5226 case FFEINTRIN_impTTYNAM_func
: /* CHARACTER functions not handled here. */
5227 case FFEINTRIN_impNONE
:
5228 case FFEINTRIN_imp
: /* Hush up gcc warning. */
5229 fprintf (stderr
, "No %s implementation.\n",
5230 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr
))));
5231 assert ("unimplemented intrinsic" == NULL
);
5232 return error_mark_node
;
5235 assert (gfrt
!= FFECOM_gfrt
); /* Must have an implementation! */
5237 ffecom_push_calltemps ();
5238 expr_tree
= ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt
),
5239 ffebld_right (expr
));
5240 ffecom_pop_calltemps ();
5242 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt
), ffecom_gfrt_kindtype (gfrt
),
5243 (ffe_is_f2c_library () && ffecom_gfrt_complex_
[gfrt
]),
5245 expr_tree
, dest_tree
, dest
, dest_used
,
5248 /**INDENT* (Do not reformat this comment even with -fca option.)
5249 Data-gathering files: Given the source file listed below, compiled with
5250 f2c I obtained the output file listed after that, and from the output
5251 file I derived the above code.
5253 -------- (begin input file to f2c)
5259 double precision D1,D2
5261 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
5290 c FFEINTRIN_impAIMAG
5291 call fooR(AIMAG(C1))
5296 c FFEINTRIN_impALOG10
5297 call fooR(ALOG10(R1))
5298 c FFEINTRIN_impAMAX0
5299 call fooR(AMAX0(I1,I2))
5300 c FFEINTRIN_impAMAX1
5301 call fooR(AMAX1(R1,R2))
5302 c FFEINTRIN_impAMIN0
5303 call fooR(AMIN0(I1,I2))
5304 c FFEINTRIN_impAMIN1
5305 call fooR(AMIN1(R1,R2))
5307 call fooR(AMOD(R1,R2))
5308 c FFEINTRIN_impANINT
5309 call fooR(ANINT(R1))
5314 c FFEINTRIN_impATAN2
5315 call fooR(ATAN2(R1,R2))
5326 c FFEINTRIN_impCONJG
5327 call fooC(CONJG(C1))
5334 c FFEINTRIN_impCSQRT
5335 call fooC(CSQRT(C1))
5338 c FFEINTRIN_impDACOS
5339 call fooD(DACOS(D1))
5340 c FFEINTRIN_impDASIN
5341 call fooD(DASIN(D1))
5342 c FFEINTRIN_impDATAN
5343 call fooD(DATAN(D1))
5344 c FFEINTRIN_impDATAN2
5345 call fooD(DATAN2(D1,D2))
5348 c FFEINTRIN_impDCOSH
5349 call fooD(DCOSH(D1))
5351 call fooD(DDIM(D1,D2))
5355 call fooR(DIM(R1,R2))
5360 c FFEINTRIN_impDLOG10
5361 call fooD(DLOG10(D1))
5362 c FFEINTRIN_impDMAX1
5363 call fooD(DMAX1(D1,D2))
5364 c FFEINTRIN_impDMIN1
5365 call fooD(DMIN1(D1,D2))
5367 call fooD(DMOD(D1,D2))
5368 c FFEINTRIN_impDNINT
5369 call fooD(DNINT(D1))
5370 c FFEINTRIN_impDPROD
5371 call fooD(DPROD(R1,R2))
5372 c FFEINTRIN_impDSIGN
5373 call fooD(DSIGN(D1,D2))
5376 c FFEINTRIN_impDSINH
5377 call fooD(DSINH(D1))
5378 c FFEINTRIN_impDSQRT
5379 call fooD(DSQRT(D1))
5382 c FFEINTRIN_impDTANH
5383 call fooD(DTANH(D1))
5388 c FFEINTRIN_impICHAR
5389 call fooI(ICHAR(A1))
5391 call fooI(IDIM(I1,I2))
5392 c FFEINTRIN_impIDNINT
5393 call fooI(IDNINT(D1))
5394 c FFEINTRIN_impINDEX
5395 call fooI(INDEX(A1,A2))
5396 c FFEINTRIN_impISIGN
5397 call fooI(ISIGN(I1,I2))
5401 call fooL(LGE(A1,A2))
5403 call fooL(LGT(A1,A2))
5405 call fooL(LLE(A1,A2))
5407 call fooL(LLT(A1,A2))
5409 call fooI(MAX0(I1,I2))
5411 call fooI(MAX1(R1,R2))
5413 call fooI(MIN0(I1,I2))
5415 call fooI(MIN1(R1,R2))
5417 call fooI(MOD(I1,I2))
5421 call fooR(SIGN(R1,R2))
5432 c FFEINTRIN_imp_CMPLX_C
5433 call fooC(cmplx(C1,C2))
5434 c FFEINTRIN_imp_CMPLX_D
5435 call fooZ(cmplx(D1,D2))
5436 c FFEINTRIN_imp_CMPLX_I
5437 call fooC(cmplx(I1,I2))
5438 c FFEINTRIN_imp_CMPLX_R
5439 call fooC(cmplx(R1,R2))
5440 c FFEINTRIN_imp_DBLE_C
5442 c FFEINTRIN_imp_DBLE_D
5444 c FFEINTRIN_imp_DBLE_I
5446 c FFEINTRIN_imp_DBLE_R
5448 c FFEINTRIN_imp_INT_C
5450 c FFEINTRIN_imp_INT_D
5452 c FFEINTRIN_imp_INT_I
5454 c FFEINTRIN_imp_INT_R
5456 c FFEINTRIN_imp_REAL_C
5458 c FFEINTRIN_imp_REAL_D
5460 c FFEINTRIN_imp_REAL_I
5462 c FFEINTRIN_imp_REAL_R
5465 c FFEINTRIN_imp_INT_D:
5467 c FFEINTRIN_specIDINT
5468 call fooI(IDINT(D1))
5470 c FFEINTRIN_imp_INT_R:
5472 c FFEINTRIN_specIFIX
5477 c FFEINTRIN_imp_REAL_D:
5479 c FFEINTRIN_specSNGL
5482 c FFEINTRIN_imp_REAL_I:
5484 c FFEINTRIN_specFLOAT
5485 call fooR(FLOAT(I1))
5486 c FFEINTRIN_specREAL
5490 -------- (end input file to f2c)
5492 -------- (begin output from providing above input file as input to:
5493 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
5494 -------- -e "s:^#.*$::g"')
5496 // -- translated by f2c (version 19950223).
5497 You must link the resulting object file with the libraries:
5498 -lf2c -lm (in that order)
5502 // f2c.h -- Standard Fortran to C header file //
5504 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
5506 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
5511 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
5512 // we assume short, float are OK //
5513 typedef long int // long int // integer;
5514 typedef char *address;
5515 typedef short int shortint;
5517 typedef double doublereal;
5518 typedef struct { real r, i; } complex;
5519 typedef struct { doublereal r, i; } doublecomplex;
5520 typedef long int // long int // logical;
5521 typedef short int shortlogical;
5522 typedef char logical1;
5523 typedef char integer1;
5524 // typedef long long longint; // // system-dependent //
5529 // Extern is for use with -E //
5543 typedef long int // int or long int // flag;
5544 typedef long int // int or long int // ftnlen;
5545 typedef long int // int or long int // ftnint;
5548 //external read, write//
5557 //internal read, write//
5587 //rewind, backspace, endfile//
5599 ftnint *inex; //parameters in standard's order//
5625 union Multitype { // for multiple entry points //
5636 typedef union Multitype Multitype;
5638 typedef long Long; // No longer used; formerly in Namelist //
5640 struct Vardesc { // for Namelist //
5646 typedef struct Vardesc Vardesc;
5653 typedef struct Namelist Namelist;
5662 // procedure parameter types for -A and -C++ //
5667 typedef int // Unknown procedure type // (*U_fp)();
5668 typedef shortint (*J_fp)();
5669 typedef integer (*I_fp)();
5670 typedef real (*R_fp)();
5671 typedef doublereal (*D_fp)(), (*E_fp)();
5672 typedef // Complex // void (*C_fp)();
5673 typedef // Double Complex // void (*Z_fp)();
5674 typedef logical (*L_fp)();
5675 typedef shortlogical (*K_fp)();
5676 typedef // Character // void (*H_fp)();
5677 typedef // Subroutine // int (*S_fp)();
5679 // E_fp is for real functions when -R is not specified //
5680 typedef void C_f; // complex function //
5681 typedef void H_f; // character function //
5682 typedef void Z_f; // double complex function //
5683 typedef doublereal E_f; // real function with -R not specified //
5685 // undef any lower-case symbols that your C compiler predefines, e.g.: //
5688 // (No such symbols should be defined in a strict ANSI C compiler.
5689 We can avoid trouble with f2c-translated code by using
5690 gcc -ansi [-traditional].) //
5714 // Main program // MAIN__()
5716 // System generated locals //
5719 doublereal d__1, d__2;
5721 doublecomplex z__1, z__2, z__3;
5725 // Builtin functions //
5728 double pow_ri(), pow_di();
5732 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
5733 asin(), atan(), atan2(), c_abs();
5734 void c_cos(), c_exp(), c_log(), r_cnjg();
5735 double cos(), cosh();
5736 void c_sin(), c_sqrt();
5737 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
5738 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
5739 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
5740 logical l_ge(), l_gt(), l_le(), l_lt();
5744 // Local variables //
5745 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
5746 fool_(), fooz_(), getem_();
5747 static char a1[10], a2[10];
5748 static complex c1, c2;
5749 static doublereal d1, d2;
5750 static integer i1, i2;
5754 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
5762 d__1 = (doublereal) i1;
5763 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
5773 c_div(&q__1, &c1, &c2);
5775 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
5777 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
5780 i__1 = pow_ii(&i1, &i2);
5782 r__1 = pow_ri(&r1, &i1);
5784 d__1 = pow_di(&d1, &i1);
5786 pow_ci(&q__1, &c1, &i1);
5788 d__1 = (doublereal) r1;
5789 d__2 = (doublereal) r2;
5790 r__1 = pow_dd(&d__1, &d__2);
5792 d__2 = (doublereal) r1;
5793 d__1 = pow_dd(&d__2, &d1);
5795 d__1 = pow_dd(&d1, &d2);
5797 d__2 = (doublereal) r1;
5798 d__1 = pow_dd(&d1, &d__2);
5800 z__2.r = c1.r, z__2.i = c1.i;
5801 z__3.r = c2.r, z__3.i = c2.i;
5802 pow_zz(&z__1, &z__2, &z__3);
5803 q__1.r = z__1.r, q__1.i = z__1.i;
5805 z__2.r = c1.r, z__2.i = c1.i;
5806 z__3.r = r1, z__3.i = 0.;
5807 pow_zz(&z__1, &z__2, &z__3);
5808 q__1.r = z__1.r, q__1.i = z__1.i;
5810 z__2.r = c1.r, z__2.i = c1.i;
5811 z__3.r = d1, z__3.i = 0.;
5812 pow_zz(&z__1, &z__2, &z__3);
5814 // FFEINTRIN_impABS //
5815 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
5817 // FFEINTRIN_impACOS //
5820 // FFEINTRIN_impAIMAG //
5823 // FFEINTRIN_impAINT //
5826 // FFEINTRIN_impALOG //
5829 // FFEINTRIN_impALOG10 //
5832 // FFEINTRIN_impAMAX0 //
5833 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
5835 // FFEINTRIN_impAMAX1 //
5836 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
5838 // FFEINTRIN_impAMIN0 //
5839 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
5841 // FFEINTRIN_impAMIN1 //
5842 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
5844 // FFEINTRIN_impAMOD //
5845 r__1 = r_mod(&r1, &r2);
5847 // FFEINTRIN_impANINT //
5850 // FFEINTRIN_impASIN //
5853 // FFEINTRIN_impATAN //
5856 // FFEINTRIN_impATAN2 //
5857 r__1 = atan2(r1, r2);
5859 // FFEINTRIN_impCABS //
5862 // FFEINTRIN_impCCOS //
5865 // FFEINTRIN_impCEXP //
5868 // FFEINTRIN_impCHAR //
5869 *(unsigned char *)&ch__1[0] = i1;
5871 // FFEINTRIN_impCLOG //
5874 // FFEINTRIN_impCONJG //
5877 // FFEINTRIN_impCOS //
5880 // FFEINTRIN_impCOSH //
5883 // FFEINTRIN_impCSIN //
5886 // FFEINTRIN_impCSQRT //
5889 // FFEINTRIN_impDABS //
5890 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
5892 // FFEINTRIN_impDACOS //
5895 // FFEINTRIN_impDASIN //
5898 // FFEINTRIN_impDATAN //
5901 // FFEINTRIN_impDATAN2 //
5902 d__1 = atan2(d1, d2);
5904 // FFEINTRIN_impDCOS //
5907 // FFEINTRIN_impDCOSH //
5910 // FFEINTRIN_impDDIM //
5911 d__1 = d_dim(&d1, &d2);
5913 // FFEINTRIN_impDEXP //
5916 // FFEINTRIN_impDIM //
5917 r__1 = r_dim(&r1, &r2);
5919 // FFEINTRIN_impDINT //
5922 // FFEINTRIN_impDLOG //
5925 // FFEINTRIN_impDLOG10 //
5928 // FFEINTRIN_impDMAX1 //
5929 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
5931 // FFEINTRIN_impDMIN1 //
5932 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
5934 // FFEINTRIN_impDMOD //
5935 d__1 = d_mod(&d1, &d2);
5937 // FFEINTRIN_impDNINT //
5940 // FFEINTRIN_impDPROD //
5941 d__1 = (doublereal) r1 * r2;
5943 // FFEINTRIN_impDSIGN //
5944 d__1 = d_sign(&d1, &d2);
5946 // FFEINTRIN_impDSIN //
5949 // FFEINTRIN_impDSINH //
5952 // FFEINTRIN_impDSQRT //
5955 // FFEINTRIN_impDTAN //
5958 // FFEINTRIN_impDTANH //
5961 // FFEINTRIN_impEXP //
5964 // FFEINTRIN_impIABS //
5965 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
5967 // FFEINTRIN_impICHAR //
5968 i__1 = *(unsigned char *)a1;
5970 // FFEINTRIN_impIDIM //
5971 i__1 = i_dim(&i1, &i2);
5973 // FFEINTRIN_impIDNINT //
5976 // FFEINTRIN_impINDEX //
5977 i__1 = i_indx(a1, a2, 10L, 10L);
5979 // FFEINTRIN_impISIGN //
5980 i__1 = i_sign(&i1, &i2);
5982 // FFEINTRIN_impLEN //
5983 i__1 = i_len(a1, 10L);
5985 // FFEINTRIN_impLGE //
5986 L__1 = l_ge(a1, a2, 10L, 10L);
5988 // FFEINTRIN_impLGT //
5989 L__1 = l_gt(a1, a2, 10L, 10L);
5991 // FFEINTRIN_impLLE //
5992 L__1 = l_le(a1, a2, 10L, 10L);
5994 // FFEINTRIN_impLLT //
5995 L__1 = l_lt(a1, a2, 10L, 10L);
5997 // FFEINTRIN_impMAX0 //
5998 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
6000 // FFEINTRIN_impMAX1 //
6001 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
6003 // FFEINTRIN_impMIN0 //
6004 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
6006 // FFEINTRIN_impMIN1 //
6007 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
6009 // FFEINTRIN_impMOD //
6012 // FFEINTRIN_impNINT //
6015 // FFEINTRIN_impSIGN //
6016 r__1 = r_sign(&r1, &r2);
6018 // FFEINTRIN_impSIN //
6021 // FFEINTRIN_impSINH //
6024 // FFEINTRIN_impSQRT //
6027 // FFEINTRIN_impTAN //
6030 // FFEINTRIN_impTANH //
6033 // FFEINTRIN_imp_CMPLX_C //
6036 q__1.r = r__1, q__1.i = r__2;
6038 // FFEINTRIN_imp_CMPLX_D //
6039 z__1.r = d1, z__1.i = d2;
6041 // FFEINTRIN_imp_CMPLX_I //
6044 q__1.r = r__1, q__1.i = r__2;
6046 // FFEINTRIN_imp_CMPLX_R //
6047 q__1.r = r1, q__1.i = r2;
6049 // FFEINTRIN_imp_DBLE_C //
6050 d__1 = (doublereal) c1.r;
6052 // FFEINTRIN_imp_DBLE_D //
6055 // FFEINTRIN_imp_DBLE_I //
6056 d__1 = (doublereal) i1;
6058 // FFEINTRIN_imp_DBLE_R //
6059 d__1 = (doublereal) r1;
6061 // FFEINTRIN_imp_INT_C //
6062 i__1 = (integer) c1.r;
6064 // FFEINTRIN_imp_INT_D //
6065 i__1 = (integer) d1;
6067 // FFEINTRIN_imp_INT_I //
6070 // FFEINTRIN_imp_INT_R //
6071 i__1 = (integer) r1;
6073 // FFEINTRIN_imp_REAL_C //
6076 // FFEINTRIN_imp_REAL_D //
6079 // FFEINTRIN_imp_REAL_I //
6082 // FFEINTRIN_imp_REAL_R //
6086 // FFEINTRIN_imp_INT_D: //
6088 // FFEINTRIN_specIDINT //
6089 i__1 = (integer) d1;
6092 // FFEINTRIN_imp_INT_R: //
6094 // FFEINTRIN_specIFIX //
6095 i__1 = (integer) r1;
6097 // FFEINTRIN_specINT //
6098 i__1 = (integer) r1;
6101 // FFEINTRIN_imp_REAL_D: //
6103 // FFEINTRIN_specSNGL //
6107 // FFEINTRIN_imp_REAL_I: //
6109 // FFEINTRIN_specFLOAT //
6112 // FFEINTRIN_specREAL //
6118 -------- (end output file from f2c)
6124 /* For power (exponentiation) where right-hand operand is type INTEGER,
6125 generate in-line code to do it the fast way (which, if the operand
6126 is a constant, might just mean a series of multiplies). */
6128 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6130 ffecom_expr_power_integer_ (ffebld left
, ffebld right
)
6132 tree l
= ffecom_expr (left
);
6133 tree r
= ffecom_expr (right
);
6134 tree ltype
= TREE_TYPE (l
);
6135 tree rtype
= TREE_TYPE (r
);
6136 tree result
= NULL_TREE
;
6138 if (l
== error_mark_node
6139 || r
== error_mark_node
)
6140 return error_mark_node
;
6142 if (TREE_CODE (r
) == INTEGER_CST
)
6144 int sgn
= tree_int_cst_sgn (r
);
6147 return convert (ltype
, integer_one_node
);
6149 if ((TREE_CODE (ltype
) == INTEGER_TYPE
)
6152 /* Reciprocal of integer is either 0, -1, or 1, so after
6153 calculating that (which we leave to the back end to do
6154 or not do optimally), don't bother with any multiplying. */
6156 result
= ffecom_tree_divide_ (ltype
,
6157 convert (ltype
, integer_one_node
),
6159 NULL_TREE
, NULL
, NULL
);
6160 r
= ffecom_1 (NEGATE_EXPR
,
6163 if ((TREE_INT_CST_LOW (r
) & 1) == 0)
6164 result
= ffecom_1 (ABS_EXPR
, rtype
,
6168 /* Generate appropriate series of multiplies, preceded
6169 by divide if the exponent is negative. */
6175 l
= ffecom_tree_divide_ (ltype
,
6176 convert (ltype
, integer_one_node
),
6178 NULL_TREE
, NULL
, NULL
);
6179 r
= ffecom_1 (NEGATE_EXPR
, rtype
, r
);
6180 assert (TREE_CODE (r
) == INTEGER_CST
);
6182 if (tree_int_cst_sgn (r
) < 0)
6183 { /* The "most negative" number. */
6184 r
= ffecom_1 (NEGATE_EXPR
, rtype
,
6185 ffecom_2 (RSHIFT_EXPR
, rtype
,
6189 l
= ffecom_2 (MULT_EXPR
, ltype
,
6197 if (TREE_INT_CST_LOW (r
) & 1)
6199 if (result
== NULL_TREE
)
6202 result
= ffecom_2 (MULT_EXPR
, ltype
,
6207 r
= ffecom_2 (RSHIFT_EXPR
, rtype
,
6210 if (integer_zerop (r
))
6212 assert (TREE_CODE (r
) == INTEGER_CST
);
6215 l
= ffecom_2 (MULT_EXPR
, ltype
,
6222 /* Though rhs isn't a constant, in-line code cannot be expanded
6223 while transforming dummies
6224 because the back end cannot be easily convinced to generate
6225 stores (MODIFY_EXPR), handle temporaries, and so on before
6226 all the appropriate rtx's have been generated for things like
6227 dummy args referenced in rhs -- which doesn't happen until
6228 store_parm_decls() is called (expand_function_start, I believe,
6229 does the actual rtx-stuffing of PARM_DECLs).
6231 So, in this case, let the caller generate the call to the
6232 run-time-library function to evaluate the power for us. */
6234 if (ffecom_transform_only_dummies_
)
6237 /* Right-hand operand not a constant, expand in-line code to figure
6238 out how to do the multiplies, &c.
6240 The returned expression is expressed this way in GNU C, where l and
6243 ({ typeof (r) rtmp = r;
6244 typeof (l) ltmp = l;
6251 if ((basetypeof (l) == basetypeof (int))
6254 result = ((typeof (l)) 1) / ltmp;
6255 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
6261 if ((basetypeof (l) != basetypeof (int))
6264 ltmp = ((typeof (l)) 1) / ltmp;
6268 rtmp = -(rtmp >> 1);
6276 if ((rtmp >>= 1) == 0)
6285 Note that some of the above is compile-time collapsable, such as
6286 the first part of the if statements that checks the base type of
6287 l against int. The if statements are phrased that way to suggest
6288 an easy way to generate the if/else constructs here, knowing that
6289 the back end should (and probably does) eliminate the resulting
6290 dead code (either the int case or the non-int case), something
6291 it couldn't do without the redundant phrasing, requiring explicit
6292 dead-code elimination here, which would be kind of difficult to
6298 tree basetypeof_l_is_int
;
6302 = build_int_2 ((TREE_CODE (ltype
) == INTEGER_TYPE
), 0);
6304 se
= expand_start_stmt_expr ();
6305 ffecom_push_calltemps ();
6307 rtmp
= ffecom_push_tempvar (rtype
, FFETARGET_charactersizeNONE
, -1,
6309 ltmp
= ffecom_push_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1,
6311 result
= ffecom_push_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1,
6314 expand_expr_stmt (ffecom_modify (void_type_node
,
6317 expand_expr_stmt (ffecom_modify (void_type_node
,
6320 expand_start_cond (ffecom_truth_value
6321 (ffecom_2 (EQ_EXPR
, integer_type_node
,
6323 convert (rtype
, integer_zero_node
))),
6325 expand_expr_stmt (ffecom_modify (void_type_node
,
6327 convert (ltype
, integer_one_node
)));
6328 expand_start_else ();
6329 if (!integer_zerop (basetypeof_l_is_int
))
6331 expand_start_cond (ffecom_2 (LT_EXPR
, integer_type_node
,
6334 integer_zero_node
)),
6336 expand_expr_stmt (ffecom_modify (void_type_node
,
6340 convert (ltype
, integer_one_node
),
6342 NULL_TREE
, NULL
, NULL
)));
6343 expand_start_cond (ffecom_truth_value
6344 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
6345 ffecom_2 (LT_EXPR
, integer_type_node
,
6348 integer_zero_node
)),
6349 ffecom_2 (EQ_EXPR
, integer_type_node
,
6350 ffecom_2 (BIT_AND_EXPR
,
6352 ffecom_1 (NEGATE_EXPR
,
6358 integer_zero_node
)))),
6360 expand_expr_stmt (ffecom_modify (void_type_node
,
6362 ffecom_1 (NEGATE_EXPR
,
6366 expand_start_else ();
6368 expand_expr_stmt (ffecom_modify (void_type_node
,
6370 convert (ltype
, integer_one_node
)));
6371 expand_start_cond (ffecom_truth_value
6372 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
6373 ffecom_truth_value_invert
6374 (basetypeof_l_is_int
),
6375 ffecom_2 (LT_EXPR
, integer_type_node
,
6378 integer_zero_node
)))),
6380 expand_expr_stmt (ffecom_modify (void_type_node
,
6384 convert (ltype
, integer_one_node
),
6386 NULL_TREE
, NULL
, NULL
)));
6387 expand_expr_stmt (ffecom_modify (void_type_node
,
6389 ffecom_1 (NEGATE_EXPR
, rtype
,
6391 expand_start_cond (ffecom_truth_value
6392 (ffecom_2 (LT_EXPR
, integer_type_node
,
6394 convert (rtype
, integer_zero_node
))),
6396 expand_expr_stmt (ffecom_modify (void_type_node
,
6398 ffecom_1 (NEGATE_EXPR
, rtype
,
6399 ffecom_2 (RSHIFT_EXPR
,
6402 integer_one_node
))));
6403 expand_expr_stmt (ffecom_modify (void_type_node
,
6405 ffecom_2 (MULT_EXPR
, ltype
,
6410 expand_start_loop (1);
6411 expand_start_cond (ffecom_truth_value
6412 (ffecom_2 (BIT_AND_EXPR
, rtype
,
6414 convert (rtype
, integer_one_node
))),
6416 expand_expr_stmt (ffecom_modify (void_type_node
,
6418 ffecom_2 (MULT_EXPR
, ltype
,
6422 expand_exit_loop_if_false (NULL
,
6424 (ffecom_modify (rtype
,
6426 ffecom_2 (RSHIFT_EXPR
,
6429 integer_one_node
))));
6430 expand_expr_stmt (ffecom_modify (void_type_node
,
6432 ffecom_2 (MULT_EXPR
, ltype
,
6437 if (!integer_zerop (basetypeof_l_is_int
))
6439 expand_expr_stmt (result
);
6441 ffecom_pop_calltemps ();
6442 result
= expand_end_stmt_expr (se
);
6443 TREE_SIDE_EFFECTS (result
) = 1;
6450 /* ffecom_expr_transform_ -- Transform symbols in expr
6452 ffebld expr; // FFE expression.
6453 ffecom_expr_transform_ (expr);
6455 Recursive descent on expr while transforming any untransformed SYMTERs. */
6457 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6459 ffecom_expr_transform_ (ffebld expr
)
6464 tail_recurse
: /* :::::::::::::::::::: */
6469 switch (ffebld_op (expr
))
6471 case FFEBLD_opSYMTER
:
6472 s
= ffebld_symter (expr
);
6473 t
= ffesymbol_hook (s
).decl_tree
;
6474 if ((t
== NULL_TREE
)
6475 && ((ffesymbol_kind (s
) != FFEINFO_kindNONE
)
6476 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
6477 && (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
))))
6479 s
= ffecom_sym_transform_ (s
);
6480 t
= ffesymbol_hook (s
).decl_tree
; /* Sfunc expr non-dummy,
6483 break; /* Ok if (t == NULL) here. */
6486 ffecom_expr_transform_ (ffebld_head (expr
));
6487 expr
= ffebld_trail (expr
);
6488 goto tail_recurse
; /* :::::::::::::::::::: */
6494 switch (ffebld_arity (expr
))
6497 ffecom_expr_transform_ (ffebld_left (expr
));
6498 expr
= ffebld_right (expr
);
6499 goto tail_recurse
; /* :::::::::::::::::::: */
6502 expr
= ffebld_left (expr
);
6503 goto tail_recurse
; /* :::::::::::::::::::: */
6513 /* Make a type based on info in live f2c.h file. */
6515 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6517 ffecom_f2c_make_type_ (tree
*type
, int tcode
, char *name
)
6521 case FFECOM_f2ccodeCHAR
:
6522 *type
= make_signed_type (CHAR_TYPE_SIZE
);
6525 case FFECOM_f2ccodeSHORT
:
6526 *type
= make_signed_type (SHORT_TYPE_SIZE
);
6529 case FFECOM_f2ccodeINT
:
6530 *type
= make_signed_type (INT_TYPE_SIZE
);
6533 case FFECOM_f2ccodeLONG
:
6534 *type
= make_signed_type (LONG_TYPE_SIZE
);
6537 case FFECOM_f2ccodeLONGLONG
:
6538 *type
= make_signed_type (LONG_LONG_TYPE_SIZE
);
6541 case FFECOM_f2ccodeCHARPTR
:
6542 *type
= build_pointer_type (DEFAULT_SIGNED_CHAR
6543 ? signed_char_type_node
6544 : unsigned_char_type_node
);
6547 case FFECOM_f2ccodeFLOAT
:
6548 *type
= make_node (REAL_TYPE
);
6549 TYPE_PRECISION (*type
) = FLOAT_TYPE_SIZE
;
6550 layout_type (*type
);
6553 case FFECOM_f2ccodeDOUBLE
:
6554 *type
= make_node (REAL_TYPE
);
6555 TYPE_PRECISION (*type
) = DOUBLE_TYPE_SIZE
;
6556 layout_type (*type
);
6559 case FFECOM_f2ccodeLONGDOUBLE
:
6560 *type
= make_node (REAL_TYPE
);
6561 TYPE_PRECISION (*type
) = LONG_DOUBLE_TYPE_SIZE
;
6562 layout_type (*type
);
6565 case FFECOM_f2ccodeTWOREALS
:
6566 *type
= ffecom_make_complex_type_ (ffecom_f2c_real_type_node
);
6569 case FFECOM_f2ccodeTWODOUBLEREALS
:
6570 *type
= ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node
);
6574 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL
);
6575 *type
= error_mark_node
;
6579 pushdecl (build_decl (TYPE_DECL
,
6580 ffecom_get_invented_identifier ("__g77_f2c_%s",
6586 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6587 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6591 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
6597 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
6598 if (((t
= ffecom_tree_type
[bt
][j
]) != NULL_TREE
)
6599 && (TREE_INT_CST_LOW (TYPE_SIZE (t
)) == size
))
6601 assert (code
!= -1);
6602 ffecom_f2c_typecode_
[bt
][j
] = code
;
6608 /* Finish up globals after doing all program units in file
6610 Need to handle only uninitialized COMMON areas. */
6612 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6614 ffecom_finish_global_ (ffeglobal global
)
6620 if (ffeglobal_type (global
) != FFEGLOBAL_typeCOMMON
)
6623 if (ffeglobal_common_init (global
))
6626 cbt
= ffeglobal_hook (global
);
6627 if ((cbt
== NULL_TREE
)
6628 || !ffeglobal_common_have_size (global
))
6629 return global
; /* No need to make common, never ref'd. */
6631 suspend_momentary ();
6633 DECL_EXTERNAL (cbt
) = 0;
6635 /* Give the array a size now. */
6637 size
= build_int_2 (ffeglobal_common_size (global
), 0);
6639 cbtype
= TREE_TYPE (cbt
);
6640 TYPE_DOMAIN (cbtype
) = build_range_type (integer_type_node
,
6643 if (!TREE_TYPE (size
))
6644 TREE_TYPE (size
) = TYPE_DOMAIN (cbtype
);
6645 layout_type (cbtype
);
6647 cbt
= start_decl (cbt
, FALSE
);
6648 assert (cbt
== ffeglobal_hook (global
));
6650 finish_decl (cbt
, NULL_TREE
, FALSE
);
6656 /* Finish up any untransformed symbols. */
6658 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6660 ffecom_finish_symbol_transform_ (ffesymbol s
)
6662 if ((s
== NULL
) || (TREE_CODE (current_function_decl
) == ERROR_MARK
))
6665 /* It's easy to know to transform an untransformed symbol, to make sure
6666 we put out debugging info for it. But COMMON variables, unlike
6667 EQUIVALENCE ones, aren't given declarations in addition to the
6668 tree expressions that specify offsets, because COMMON variables
6669 can be referenced in the outer scope where only dummy arguments
6670 (PARM_DECLs) should really be seen. To be safe, just don't do any
6671 VAR_DECLs for COMMON variables when we transform them for real
6672 use, and therefore we do all the VAR_DECL creating here. */
6674 if ((ffesymbol_hook (s
).decl_tree
== NULL_TREE
)
6675 && ((ffesymbol_kind (s
) != FFEINFO_kindNONE
)
6676 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
6677 && (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
)))
6678 && (ffesymbol_where (s
) != FFEINFO_whereDUMMY
))
6679 /* Not transformed, and not CHARACTER*(*), and not a dummy
6680 argument, which can happen only if the entry point names
6681 it "rides in on" are all invalidated for other reasons. */
6682 s
= ffecom_sym_transform_ (s
);
6684 if ((ffesymbol_where (s
) == FFEINFO_whereCOMMON
)
6685 && (ffesymbol_hook (s
).decl_tree
!= error_mark_node
))
6687 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
6688 int yes
= suspend_momentary ();
6690 /* This isn't working, at least for dbxout. The .s file looks
6691 okay to me (burley), but in gdb 4.9 at least, the variables
6692 appear to reside somewhere outside of the common area, so
6693 it doesn't make sense to mislead anyone by generating the info
6694 on those variables until this is fixed. NOTE: Same problem
6695 with EQUIVALENCE, sadly...see similar #if later. */
6696 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s
)),
6697 ffesymbol_storage (s
));
6699 resume_momentary (yes
);
6707 /* Append underscore(s) to name before calling get_identifier. "us"
6708 is nonzero if the name already contains an underscore and thus
6709 needs two underscores appended. */
6711 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6713 ffecom_get_appended_identifier_ (char us
, char *name
)
6719 newname
= xmalloc ((i
= strlen (name
)) + 1
6720 + ffe_is_underscoring ()
6722 memcpy (newname
, name
, i
);
6724 newname
[i
+ us
] = '_';
6725 newname
[i
+ 1 + us
] = '\0';
6726 id
= get_identifier (newname
);
6734 /* Decide whether to append underscore to name before calling
6737 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6739 ffecom_get_external_identifier_ (ffesymbol s
)
6742 char *name
= ffesymbol_text (s
);
6744 /* If name is a built-in name, just return it as is. */
6746 if (!ffe_is_underscoring ()
6747 || (strcmp (name
, FFETARGET_nameBLANK_COMMON
) == 0)
6748 #if FFETARGET_isENFORCED_MAIN_NAME
6749 || (strcmp (name
, FFETARGET_nameENFORCED_NAME
) == 0)
6751 || (strcmp (name
, FFETARGET_nameUNNAMED_MAIN
) == 0)
6753 || (strcmp (name
, FFETARGET_nameUNNAMED_BLOCK_DATA
) == 0))
6754 return get_identifier (name
);
6756 us
= ffe_is_second_underscore ()
6757 ? (strchr (name
, '_') != NULL
)
6760 return ffecom_get_appended_identifier_ (us
, name
);
6764 /* Decide whether to append underscore to internal name before calling
6767 This is for non-external, top-function-context names only. Transform
6768 identifier so it doesn't conflict with the transformed result
6769 of using a _different_ external name. E.g. if "CALL FOO" is
6770 transformed into "FOO_();", then the variable in "FOO_ = 3"
6771 must be transformed into something that does not conflict, since
6772 these two things should be independent.
6774 The transformation is as follows. If the name does not contain
6775 an underscore, there is no possible conflict, so just return.
6776 If the name does contain an underscore, then transform it just
6777 like we transform an external identifier. */
6779 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6781 ffecom_get_identifier_ (char *name
)
6783 /* If name does not contain an underscore, just return it as is. */
6785 if (!ffe_is_underscoring ()
6786 || (strchr (name
, '_') == NULL
))
6787 return get_identifier (name
);
6789 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6794 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6797 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6798 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6799 ffesymbol_kindtype(s));
6801 Call after setting up containing function and getting trees for all
6804 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6806 ffecom_gen_sfuncdef_ (ffesymbol s
, ffeinfoBasictype bt
, ffeinfoKindtype kt
)
6808 ffebld expr
= ffesymbol_sfexpr (s
);
6812 bool charfunc
= (bt
== FFEINFO_basictypeCHARACTER
);
6813 static bool recurse
= FALSE
;
6815 int old_lineno
= lineno
;
6816 char *old_input_filename
= input_filename
;
6818 ffecom_nested_entry_
= s
;
6820 /* For now, we don't have a handy pointer to where the sfunc is actually
6821 defined, though that should be easy to add to an ffesymbol. (The
6822 token/where info available might well point to the place where the type
6823 of the sfunc is declared, especially if that precedes the place where
6824 the sfunc itself is defined, which is typically the case.) We should
6825 put out a null pointer rather than point somewhere wrong, but I want to
6826 see how it works at this point. */
6828 input_filename
= ffesymbol_where_filename (s
);
6829 lineno
= ffesymbol_where_filelinenum (s
);
6831 /* Pretransform the expression so any newly discovered things belong to the
6832 outer program unit, not to the statement function. */
6834 ffecom_expr_transform_ (expr
);
6836 /* Make sure no recursive invocation of this fn (a specific case of failing
6837 to pretransform an sfunc's expression, i.e. where its expression
6838 references another untransformed sfunc) happens. */
6843 yes
= suspend_momentary ();
6845 push_f_function_context ();
6847 ffecom_push_calltemps ();
6850 type
= void_type_node
;
6853 type
= ffecom_tree_type
[bt
][kt
];
6854 if (type
== NULL_TREE
)
6855 type
= integer_type_node
; /* _sym_exec_transition reports
6859 start_function (ffecom_get_identifier_ (ffesymbol_text (s
)),
6860 build_function_type (type
, NULL_TREE
),
6861 1, /* nested/inline */
6862 0); /* TREE_PUBLIC */
6864 /* We don't worry about COMPLEX return values here, because this is
6865 entirely internal to our code, and gcc has the ability to return COMPLEX
6866 directly as a value. */
6868 yes
= suspend_momentary ();
6871 { /* Prepend arg for where result goes. */
6874 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
6876 result
= ffecom_get_invented_identifier ("__g77_%s",
6879 ffecom_char_enhance_arg_ (&type
, s
); /* Ignore returned length. */
6881 type
= build_pointer_type (type
);
6882 result
= build_decl (PARM_DECL
, result
, type
);
6884 push_parm_decl (result
);
6887 result
= NULL_TREE
; /* Not ref'd if !charfunc. */
6889 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s
), TRUE
);
6891 resume_momentary (yes
);
6893 store_parm_decls (0);
6895 ffecom_start_compstmt_ ();
6901 ffetargetCharacterSize sz
= ffesymbol_size (s
);
6904 result_length
= build_int_2 (sz
, 0);
6905 TREE_TYPE (result_length
) = ffecom_f2c_ftnlen_type_node
;
6907 ffecom_let_char_ (result
, result_length
, sz
, expr
);
6908 expand_null_return ();
6911 expand_return (ffecom_modify (NULL_TREE
,
6912 DECL_RESULT (current_function_decl
),
6913 ffecom_expr (expr
)));
6918 ffecom_end_compstmt_ ();
6920 func
= current_function_decl
;
6921 finish_function (1);
6923 ffecom_pop_calltemps ();
6925 pop_f_function_context ();
6927 resume_momentary (yes
);
6931 lineno
= old_lineno
;
6932 input_filename
= old_input_filename
;
6934 ffecom_nested_entry_
= NULL
;
6941 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6943 ffecom_gfrt_args_ (ffecomGfrt ix
)
6945 return ffecom_gfrt_argstring_
[ix
];
6949 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6951 ffecom_gfrt_tree_ (ffecomGfrt ix
)
6953 if (ffecom_gfrt_
[ix
] == NULL_TREE
)
6954 ffecom_make_gfrt_ (ix
);
6956 return ffecom_1 (ADDR_EXPR
,
6957 build_pointer_type (TREE_TYPE (ffecom_gfrt_
[ix
])),
6962 /* Return initialize-to-zero expression for this VAR_DECL. */
6964 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6966 ffecom_init_zero_ (tree decl
)
6969 int incremental
= TREE_STATIC (decl
);
6970 tree type
= TREE_TYPE (decl
);
6974 int momentary
= suspend_momentary ();
6975 push_obstacks_nochange ();
6976 if (TREE_PERMANENT (decl
))
6977 end_temporary_allocation ();
6978 make_decl_rtl (decl
, NULL
, TREE_PUBLIC (decl
) ? 1 : 0);
6979 assemble_variable (decl
, TREE_PUBLIC (decl
) ? 1 : 0, 0, 1);
6981 resume_momentary (momentary
);
6986 if ((TREE_CODE (type
) != ARRAY_TYPE
)
6987 && (TREE_CODE (type
) != RECORD_TYPE
)
6988 && (TREE_CODE (type
) != UNION_TYPE
)
6990 init
= convert (type
, integer_zero_node
);
6991 else if (!incremental
)
6993 int momentary
= suspend_momentary ();
6995 init
= build (CONSTRUCTOR
, type
, NULL_TREE
, NULL_TREE
);
6996 TREE_CONSTANT (init
) = 1;
6997 TREE_STATIC (init
) = 1;
6999 resume_momentary (momentary
);
7003 int momentary
= suspend_momentary ();
7005 assemble_zeros (int_size_in_bytes (type
));
7006 init
= error_mark_node
;
7008 resume_momentary (momentary
);
7011 pop_momentary_nofree ();
7017 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7019 ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
7025 switch (ffebld_op (arg
))
7027 case FFEBLD_opCONTER
: /* For F90, check 0-length. */
7028 if (ffetarget_length_character1
7029 (ffebld_constant_character1
7030 (ffebld_conter (arg
))) == 0)
7032 *maybe_tree
= integer_zero_node
;
7033 return convert (tree_type
, integer_zero_node
);
7036 *maybe_tree
= integer_one_node
;
7037 expr_tree
= build_int_2 (*ffetarget_text_character1
7038 (ffebld_constant_character1
7039 (ffebld_conter (arg
))),
7041 TREE_TYPE (expr_tree
) = tree_type
;
7044 case FFEBLD_opSYMTER
:
7045 case FFEBLD_opARRAYREF
:
7046 case FFEBLD_opFUNCREF
:
7047 case FFEBLD_opSUBSTR
:
7048 ffecom_push_calltemps ();
7049 ffecom_char_args_ (&expr_tree
, &length_tree
, arg
);
7050 ffecom_pop_calltemps ();
7052 if ((expr_tree
== error_mark_node
)
7053 || (length_tree
== error_mark_node
))
7055 *maybe_tree
= error_mark_node
;
7056 return error_mark_node
;
7059 if (integer_zerop (length_tree
))
7061 *maybe_tree
= integer_zero_node
;
7062 return convert (tree_type
, integer_zero_node
);
7066 = ffecom_1 (INDIRECT_REF
,
7067 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
7070 = ffecom_2 (ARRAY_REF
,
7071 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
7074 expr_tree
= convert (tree_type
, expr_tree
);
7076 if (TREE_CODE (length_tree
) == INTEGER_CST
)
7077 *maybe_tree
= integer_one_node
;
7078 else /* Must check length at run time. */
7080 = ffecom_truth_value
7081 (ffecom_2 (GT_EXPR
, integer_type_node
,
7083 ffecom_f2c_ftnlen_zero_node
));
7086 case FFEBLD_opPAREN
:
7087 case FFEBLD_opCONVERT
:
7088 if (ffeinfo_size (ffebld_info (arg
)) == 0)
7090 *maybe_tree
= integer_zero_node
;
7091 return convert (tree_type
, integer_zero_node
);
7093 return ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
7096 case FFEBLD_opCONCATENATE
:
7103 expr_left
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
7105 expr_right
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_right (arg
),
7107 *maybe_tree
= ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
7110 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
7118 assert ("bad op in ICHAR" == NULL
);
7119 return error_mark_node
;
7124 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
7128 length_arg = ffecom_intrinsic_len_ (expr);
7130 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
7131 subexpressions by constructing the appropriate tree for the
7132 length-of-character-text argument in a calling sequence. */
7134 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7136 ffecom_intrinsic_len_ (ffebld expr
)
7138 ffetargetCharacter1 val
;
7141 switch (ffebld_op (expr
))
7143 case FFEBLD_opCONTER
:
7144 val
= ffebld_constant_character1 (ffebld_conter (expr
));
7145 length
= build_int_2 (ffetarget_length_character1 (val
), 0);
7146 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
7149 case FFEBLD_opSYMTER
:
7151 ffesymbol s
= ffebld_symter (expr
);
7154 item
= ffesymbol_hook (s
).decl_tree
;
7155 if (item
== NULL_TREE
)
7157 s
= ffecom_sym_transform_ (s
);
7158 item
= ffesymbol_hook (s
).decl_tree
;
7160 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
7162 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
7163 length
= ffesymbol_hook (s
).length_tree
;
7166 length
= build_int_2 (ffesymbol_size (s
), 0);
7167 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
7170 else if (item
== error_mark_node
)
7171 length
= error_mark_node
;
7172 else /* FFEINFO_kindFUNCTION: */
7177 case FFEBLD_opARRAYREF
:
7178 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
7181 case FFEBLD_opSUBSTR
:
7185 ffebld thing
= ffebld_right (expr
);
7189 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
7190 start
= ffebld_head (thing
);
7191 thing
= ffebld_trail (thing
);
7192 assert (ffebld_trail (thing
) == NULL
);
7193 end
= ffebld_head (thing
);
7195 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
7197 if (length
== error_mark_node
)
7206 length
= convert (ffecom_f2c_ftnlen_type_node
,
7212 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
7213 ffecom_expr (start
));
7215 if (start_tree
== error_mark_node
)
7217 length
= error_mark_node
;
7223 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
7224 ffecom_f2c_ftnlen_one_node
,
7225 ffecom_2 (MINUS_EXPR
,
7226 ffecom_f2c_ftnlen_type_node
,
7232 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
7235 if (end_tree
== error_mark_node
)
7237 length
= error_mark_node
;
7241 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
7242 ffecom_f2c_ftnlen_one_node
,
7243 ffecom_2 (MINUS_EXPR
,
7244 ffecom_f2c_ftnlen_type_node
,
7245 end_tree
, start_tree
));
7251 case FFEBLD_opCONCATENATE
:
7253 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
7254 ffecom_intrinsic_len_ (ffebld_left (expr
)),
7255 ffecom_intrinsic_len_ (ffebld_right (expr
)));
7258 case FFEBLD_opFUNCREF
:
7259 case FFEBLD_opCONVERT
:
7260 length
= build_int_2 (ffebld_size (expr
), 0);
7261 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
7265 assert ("bad op for single char arg expr" == NULL
);
7266 length
= ffecom_f2c_ftnlen_zero_node
;
7270 assert (length
!= NULL_TREE
);
7276 /* ffecom_let_char_ -- Do assignment stuff for character type
7278 tree dest_tree; // destination (ADDR_EXPR)
7279 tree dest_length; // length (INT_CST/INDIRECT_REF(PARM_DECL))
7280 ffetargetCharacterSize dest_size; // length
7281 ffebld source; // source expression
7282 ffecom_let_char_(dest_tree,dest_length,dest_size,source);
7284 Generates code to do the assignment. Used by ordinary assignment
7285 statement handler ffecom_let_stmt and by statement-function
7286 handler to generate code for a statement function. */
7288 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7290 ffecom_let_char_ (tree dest_tree
, tree dest_length
,
7291 ffetargetCharacterSize dest_size
, ffebld source
)
7293 ffecomConcatList_ catlist
;
7298 if ((dest_tree
== error_mark_node
)
7299 || (dest_length
== error_mark_node
))
7302 assert (dest_tree
!= NULL_TREE
);
7303 assert (dest_length
!= NULL_TREE
);
7305 /* Source might be an opCONVERT, which just means it is a different size
7306 than the destination. Since the underlying implementation here handles
7307 that (directly or via the s_copy or s_cat run-time-library functions),
7308 we don't need the "convenience" of an opCONVERT that tells us to
7309 truncate or blank-pad, particularly since the resulting implementation
7310 would probably be slower than otherwise. */
7312 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
7313 source
= ffebld_left (source
);
7315 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
7316 switch (ffecom_concat_list_count_ (catlist
))
7318 case 0: /* Shouldn't happen, but in case it does... */
7319 ffecom_concat_list_kill_ (catlist
);
7320 source_tree
= null_pointer_node
;
7321 source_length
= ffecom_f2c_ftnlen_zero_node
;
7322 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
7323 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
7324 TREE_CHAIN (TREE_CHAIN (expr_tree
))
7325 = build_tree_list (NULL_TREE
, dest_length
);
7326 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
7327 = build_tree_list (NULL_TREE
, source_length
);
7329 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
);
7330 TREE_SIDE_EFFECTS (expr_tree
) = 1;
7332 expand_expr_stmt (expr_tree
);
7336 case 1: /* The (fairly) easy case. */
7337 ffecom_char_args_ (&source_tree
, &source_length
,
7338 ffecom_concat_list_expr_ (catlist
, 0));
7339 ffecom_concat_list_kill_ (catlist
);
7340 assert (source_tree
!= NULL_TREE
);
7341 assert (source_length
!= NULL_TREE
);
7343 if ((source_tree
== error_mark_node
)
7344 || (source_length
== error_mark_node
))
7350 = ffecom_1 (INDIRECT_REF
,
7351 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7355 = ffecom_2 (ARRAY_REF
,
7356 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7361 = ffecom_1 (INDIRECT_REF
,
7362 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7366 = ffecom_2 (ARRAY_REF
,
7367 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
7372 expr_tree
= ffecom_modify (void_type_node
, dest_tree
, source_tree
);
7374 expand_expr_stmt (expr_tree
);
7379 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
7380 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
7381 TREE_CHAIN (TREE_CHAIN (expr_tree
))
7382 = build_tree_list (NULL_TREE
, dest_length
);
7383 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
7384 = build_tree_list (NULL_TREE
, source_length
);
7386 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
);
7387 TREE_SIDE_EFFECTS (expr_tree
) = 1;
7389 expand_expr_stmt (expr_tree
);
7393 default: /* Must actually concatenate things. */
7397 /* Heavy-duty concatenation. */
7400 int count
= ffecom_concat_list_count_ (catlist
);
7411 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
7412 FFETARGET_charactersizeNONE
, count
, TRUE
);
7413 item_array
= items
= ffecom_push_tempvar (ffecom_f2c_address_type_node
,
7414 FFETARGET_charactersizeNONE
,
7417 for (i
= 0; i
< count
; ++i
)
7419 ffecom_char_args_ (&citem
, &clength
,
7420 ffecom_concat_list_expr_ (catlist
, i
));
7421 if ((citem
== error_mark_node
)
7422 || (clength
== error_mark_node
))
7424 ffecom_concat_list_kill_ (catlist
);
7429 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
7430 ffecom_modify (void_type_node
,
7431 ffecom_2 (ARRAY_REF
,
7432 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
7434 build_int_2 (i
, 0)),
7438 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
7439 ffecom_modify (void_type_node
,
7440 ffecom_2 (ARRAY_REF
,
7441 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
7443 build_int_2 (i
, 0)),
7448 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
7449 TREE_CHAIN (expr_tree
)
7450 = build_tree_list (NULL_TREE
,
7451 ffecom_1 (ADDR_EXPR
,
7452 build_pointer_type (TREE_TYPE (items
)),
7454 TREE_CHAIN (TREE_CHAIN (expr_tree
))
7455 = build_tree_list (NULL_TREE
,
7456 ffecom_1 (ADDR_EXPR
,
7457 build_pointer_type (TREE_TYPE (lengths
)),
7459 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
7462 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
7463 convert (ffecom_f2c_ftnlen_type_node
,
7464 build_int_2 (count
, 0))));
7465 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
))))
7466 = build_tree_list (NULL_TREE
, dest_length
);
7468 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCAT
, expr_tree
);
7469 TREE_SIDE_EFFECTS (expr_tree
) = 1;
7471 expand_expr_stmt (expr_tree
);
7474 ffecom_concat_list_kill_ (catlist
);
7478 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
7481 ffecom_make_gfrt_(ix);
7483 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
7484 for the indicated run-time routine (ix). */
7486 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7488 ffecom_make_gfrt_ (ffecomGfrt ix
)
7493 push_obstacks_nochange ();
7494 end_temporary_allocation ();
7496 switch (ffecom_gfrt_type_
[ix
])
7498 case FFECOM_rttypeVOID_
:
7499 ttype
= void_type_node
;
7502 case FFECOM_rttypeVOIDSTAR_
:
7503 ttype
= TREE_TYPE (null_pointer_node
); /* `void *'. */
7506 case FFECOM_rttypeFTNINT_
:
7507 ttype
= ffecom_f2c_ftnint_type_node
;
7510 case FFECOM_rttypeINTEGER_
:
7511 ttype
= ffecom_f2c_integer_type_node
;
7514 case FFECOM_rttypeLONGINT_
:
7515 ttype
= ffecom_f2c_longint_type_node
;
7518 case FFECOM_rttypeLOGICAL_
:
7519 ttype
= ffecom_f2c_logical_type_node
;
7522 case FFECOM_rttypeREAL_F2C_
:
7523 ttype
= double_type_node
;
7526 case FFECOM_rttypeREAL_GNU_
:
7527 ttype
= float_type_node
;
7530 case FFECOM_rttypeCOMPLEX_F2C_
:
7531 ttype
= void_type_node
;
7534 case FFECOM_rttypeCOMPLEX_GNU_
:
7535 ttype
= ffecom_f2c_complex_type_node
;
7538 case FFECOM_rttypeDOUBLE_
:
7539 ttype
= double_type_node
;
7542 case FFECOM_rttypeDOUBLEREAL_
:
7543 ttype
= ffecom_f2c_doublereal_type_node
;
7546 case FFECOM_rttypeDBLCMPLX_F2C_
:
7547 ttype
= void_type_node
;
7550 case FFECOM_rttypeDBLCMPLX_GNU_
:
7551 ttype
= ffecom_f2c_doublecomplex_type_node
;
7554 case FFECOM_rttypeCHARACTER_
:
7555 ttype
= void_type_node
;
7560 assert ("bad rttype" == NULL
);
7564 ttype
= build_function_type (ttype
, NULL_TREE
);
7565 t
= build_decl (FUNCTION_DECL
,
7566 get_identifier (ffecom_gfrt_name_
[ix
]),
7568 DECL_EXTERNAL (t
) = 1;
7569 TREE_PUBLIC (t
) = 1;
7570 TREE_THIS_VOLATILE (t
) = ffecom_gfrt_volatile_
[ix
] ? 1 : 0;
7572 t
= start_decl (t
, TRUE
);
7574 finish_decl (t
, NULL_TREE
, TRUE
);
7576 resume_temporary_allocation ();
7579 ffecom_gfrt_
[ix
] = t
;
7583 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
7585 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7587 ffecom_member_phase1_ (ffestorag mst UNUSED
, ffestorag st
)
7589 ffesymbol s
= ffestorag_symbol (st
);
7591 if (ffesymbol_namelisted (s
))
7592 ffecom_member_namelisted_
= TRUE
;
7596 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
7597 the member so debugger will see it. Otherwise nobody should be
7598 referencing the member. */
7600 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7601 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
7603 ffecom_member_phase2_ (ffestorag mst
, ffestorag st
)
7611 || ((mt
= ffestorag_hook (mst
)) == NULL
)
7612 || (mt
== error_mark_node
))
7616 || ((s
= ffestorag_symbol (st
)) == NULL
))
7619 type
= ffecom_type_localvar_ (s
,
7620 ffesymbol_basictype (s
),
7621 ffesymbol_kindtype (s
));
7622 if (type
== error_mark_node
)
7625 t
= build_decl (VAR_DECL
,
7626 ffecom_get_identifier_ (ffesymbol_text (s
)),
7629 TREE_STATIC (t
) = TREE_STATIC (mt
);
7630 DECL_INITIAL (t
) = NULL_TREE
;
7631 TREE_ASM_WRITTEN (t
) = 1;
7634 = gen_rtx (MEM
, TYPE_MODE (type
),
7635 plus_constant (XEXP (DECL_RTL (mt
), 0),
7636 ffestorag_modulo (mst
)
7637 + ffestorag_offset (st
)
7638 - ffestorag_offset (mst
)));
7640 t
= start_decl (t
, FALSE
);
7642 finish_decl (t
, NULL_TREE
, FALSE
);
7647 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7649 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7650 (which generates their trees) and then their trees get push_parm_decl'd.
7652 The second arg is TRUE if the dummies are for a statement function, in
7653 which case lengths are not pushed for character arguments (since they are
7654 always known by both the caller and the callee, though the code allows
7655 for someday permitting CHAR*(*) stmtfunc dummies). */
7657 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7659 ffecom_push_dummy_decls_ (ffebld dummy_list
, bool stmtfunc
)
7666 ffecom_transform_only_dummies_
= TRUE
;
7668 /* First push the parms corresponding to actual dummy "contents". */
7670 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7672 dummy
= ffebld_head (dumlist
);
7673 switch (ffebld_op (dummy
))
7677 continue; /* Forget alternate returns. */
7682 assert (ffebld_op (dummy
) == FFEBLD_opSYMTER
);
7683 s
= ffebld_symter (dummy
);
7684 parm
= ffesymbol_hook (s
).decl_tree
;
7685 if (parm
== NULL_TREE
)
7687 s
= ffecom_sym_transform_ (s
);
7688 parm
= ffesymbol_hook (s
).decl_tree
;
7689 assert (parm
!= NULL_TREE
);
7691 if (parm
!= error_mark_node
)
7692 push_parm_decl (parm
);
7695 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7697 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7699 dummy
= ffebld_head (dumlist
);
7700 switch (ffebld_op (dummy
))
7704 continue; /* Forget alternate returns, they mean
7710 s
= ffebld_symter (dummy
);
7711 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
7712 continue; /* Only looking for CHARACTER arguments. */
7713 if (stmtfunc
&& (ffesymbol_size (s
) != FFETARGET_charactersizeNONE
))
7714 continue; /* Stmtfunc arg with known size needs no
7716 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
7717 continue; /* Only looking for variables and arrays. */
7718 parm
= ffesymbol_hook (s
).length_tree
;
7719 assert (parm
!= NULL_TREE
);
7720 if (parm
!= error_mark_node
)
7721 push_parm_decl (parm
);
7724 ffecom_transform_only_dummies_
= FALSE
;
7728 /* ffecom_start_progunit_ -- Beginning of program unit
7730 Does GNU back end stuff necessary to teach it about the start of its
7731 equivalent of a Fortran program unit. */
7733 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7735 ffecom_start_progunit_ ()
7737 ffesymbol fn
= ffecom_primary_entry_
;
7739 tree id
; /* Identifier (name) of function. */
7740 tree type
; /* Type of function. */
7741 tree result
; /* Result of function. */
7742 ffeinfoBasictype bt
;
7746 ffeglobalType egt
= FFEGLOBAL_type
;
7749 bool altentries
= (ffecom_num_entrypoints_
!= 0);
7752 && (ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
7753 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
7754 bool main_program
= FALSE
;
7755 int old_lineno
= lineno
;
7756 char *old_input_filename
= input_filename
;
7759 assert (fn
!= NULL
);
7760 assert (ffesymbol_hook (fn
).decl_tree
== NULL_TREE
);
7762 input_filename
= ffesymbol_where_filename (fn
);
7763 lineno
= ffesymbol_where_filelinenum (fn
);
7765 /* c-parse.y indeed does call suspend_momentary and not only ignores the
7766 return value, but also never calls resume_momentary, when starting an
7767 outer function (see "fndef:", "setspecs:", and so on). So g77 does the
7768 same thing. It shouldn't be a problem since start_function calls
7769 temporary_allocation, but it might be necessary. If it causes a problem
7770 here, then maybe there's a bug lurking in gcc. NOTE: This identical
7771 comment appears twice in thist file. */
7773 suspend_momentary ();
7775 switch (ffecom_primary_entry_kind_
)
7777 case FFEINFO_kindPROGRAM
:
7778 main_program
= TRUE
;
7779 gt
= FFEGLOBAL_typeMAIN
;
7780 bt
= FFEINFO_basictypeNONE
;
7781 kt
= FFEINFO_kindtypeNONE
;
7782 type
= ffecom_tree_fun_type_void
;
7787 case FFEINFO_kindBLOCKDATA
:
7788 gt
= FFEGLOBAL_typeBDATA
;
7789 bt
= FFEINFO_basictypeNONE
;
7790 kt
= FFEINFO_kindtypeNONE
;
7791 type
= ffecom_tree_fun_type_void
;
7796 case FFEINFO_kindFUNCTION
:
7797 gt
= FFEGLOBAL_typeFUNC
;
7798 egt
= FFEGLOBAL_typeEXT
;
7799 bt
= ffesymbol_basictype (fn
);
7800 kt
= ffesymbol_kindtype (fn
);
7801 if (bt
== FFEINFO_basictypeNONE
)
7803 ffeimplic_establish_symbol (fn
);
7804 if (ffesymbol_funcresult (fn
) != NULL
)
7805 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
7806 bt
= ffesymbol_basictype (fn
);
7807 kt
= ffesymbol_kindtype (fn
);
7811 charfunc
= cmplxfunc
= FALSE
;
7812 else if (bt
== FFEINFO_basictypeCHARACTER
)
7813 charfunc
= TRUE
, cmplxfunc
= FALSE
;
7814 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
7815 && ffesymbol_is_f2c (fn
)
7817 charfunc
= FALSE
, cmplxfunc
= TRUE
;
7819 charfunc
= cmplxfunc
= FALSE
;
7821 if (multi
|| charfunc
)
7822 type
= ffecom_tree_fun_type_void
;
7823 else if (ffesymbol_is_f2c (fn
) && !altentries
)
7824 type
= ffecom_tree_fun_type
[bt
][kt
];
7826 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
7828 if ((type
== NULL_TREE
)
7829 || (TREE_TYPE (type
) == NULL_TREE
))
7830 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
7833 case FFEINFO_kindSUBROUTINE
:
7834 gt
= FFEGLOBAL_typeSUBR
;
7835 egt
= FFEGLOBAL_typeEXT
;
7836 bt
= FFEINFO_basictypeNONE
;
7837 kt
= FFEINFO_kindtypeNONE
;
7838 if (ffecom_is_altreturning_
)
7839 type
= ffecom_tree_subr_type
;
7841 type
= ffecom_tree_fun_type_void
;
7847 assert ("say what??" == NULL
);
7849 case FFEINFO_kindANY
:
7850 gt
= FFEGLOBAL_typeANY
;
7851 bt
= FFEINFO_basictypeNONE
;
7852 kt
= FFEINFO_kindtypeNONE
;
7853 type
= error_mark_node
;
7860 id
= ffecom_get_invented_identifier ("__g77_masterfun_%s",
7861 ffesymbol_text (fn
),
7863 #if FFETARGET_isENFORCED_MAIN
7864 else if (main_program
)
7865 id
= get_identifier (FFETARGET_nameENFORCED_MAIN_NAME
);
7868 id
= ffecom_get_external_identifier_ (fn
);
7872 0, /* nested/inline */
7873 !altentries
); /* TREE_PUBLIC */
7876 && ((g
= ffesymbol_global (fn
)) != NULL
)
7877 && ((ffeglobal_type (g
) == gt
)
7878 || (ffeglobal_type (g
) == egt
)))
7880 ffeglobal_set_hook (g
, current_function_decl
);
7883 yes
= suspend_momentary ();
7885 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7886 exec-transitioning needs current_function_decl to be filled in. So we
7887 do these things in two phases. */
7890 { /* 1st arg identifies which entrypoint. */
7891 ffecom_which_entrypoint_decl_
7892 = build_decl (PARM_DECL
,
7893 ffecom_get_invented_identifier ("__g77_%s",
7897 push_parm_decl (ffecom_which_entrypoint_decl_
);
7903 { /* Arg for result (return value). */
7908 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
7910 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
7912 type
= ffecom_multi_type_node_
;
7914 result
= ffecom_get_invented_identifier ("__g77_%s",
7917 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7920 length
= ffecom_char_enhance_arg_ (&type
, fn
);
7922 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
7924 type
= build_pointer_type (type
);
7925 result
= build_decl (PARM_DECL
, result
, type
);
7927 push_parm_decl (result
);
7929 ffecom_multi_retval_
= result
;
7931 ffecom_func_result_
= result
;
7935 push_parm_decl (length
);
7936 ffecom_func_length_
= length
;
7940 if (ffecom_primary_entry_is_proc_
)
7943 arglist
= ffecom_master_arglist_
;
7945 arglist
= ffesymbol_dummyargs (fn
);
7946 ffecom_push_dummy_decls_ (arglist
, FALSE
);
7949 resume_momentary (yes
);
7951 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
7952 store_parm_decls (main_program
? 1 : 0);
7954 ffecom_start_compstmt_ ();
7956 lineno
= old_lineno
;
7957 input_filename
= old_input_filename
;
7959 /* This handles any symbols still untransformed, in case -g specified.
7960 This used to be done in ffecom_finish_progunit, but it turns out to
7961 be necessary to do it here so that statement functions are
7962 expanded before code. But don't bother for BLOCK DATA. */
7964 if (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
7965 ffesymbol_drive (ffecom_finish_symbol_transform_
);
7969 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7972 ffecom_sym_transform_(s);
7974 The ffesymbol_hook info for s is updated with appropriate backend info
7977 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7979 ffecom_sym_transform_ (ffesymbol s
)
7981 tree t
; /* Transformed thingy. */
7982 tree tlen
; /* Length if CHAR*(*). */
7983 bool addr
; /* Is t the address of the thingy? */
7984 ffeinfoBasictype bt
;
7988 int old_lineno
= lineno
;
7989 char *old_input_filename
= input_filename
;
7991 if (ffesymbol_sfdummyparent (s
) == NULL
)
7993 input_filename
= ffesymbol_where_filename (s
);
7994 lineno
= ffesymbol_where_filelinenum (s
);
7998 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
8000 input_filename
= ffesymbol_where_filename (sf
);
8001 lineno
= ffesymbol_where_filelinenum (sf
);
8004 bt
= ffeinfo_basictype (ffebld_info (s
));
8005 kt
= ffeinfo_kindtype (ffebld_info (s
));
8011 switch (ffesymbol_kind (s
))
8013 case FFEINFO_kindNONE
:
8014 switch (ffesymbol_where (s
))
8016 case FFEINFO_whereDUMMY
: /* Subroutine or function. */
8017 assert (ffecom_transform_only_dummies_
);
8019 /* Before 0.4, this could be ENTITY/DUMMY, but see
8020 ffestu_sym_end_transition -- no longer true (in particular, if
8021 it could be an ENTITY, it _will_ be made one, so that
8022 possibility won't come through here). So we never make length
8023 arg for CHARACTER type. */
8025 t
= build_decl (PARM_DECL
,
8026 ffecom_get_identifier_ (ffesymbol_text (s
)),
8027 ffecom_tree_ptr_to_subr_type
);
8029 DECL_ARTIFICIAL (t
) = 1;
8034 case FFEINFO_whereGLOBAL
: /* Subroutine or function. */
8035 assert (!ffecom_transform_only_dummies_
);
8037 if (((g
= ffesymbol_global (s
)) != NULL
)
8038 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8039 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8040 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8041 && (ffeglobal_hook (g
) != NULL_TREE
)
8042 && ffe_is_globals ())
8044 t
= ffeglobal_hook (g
);
8048 push_obstacks_nochange ();
8049 end_temporary_allocation ();
8051 t
= build_decl (FUNCTION_DECL
,
8052 ffecom_get_external_identifier_ (s
),
8053 ffecom_tree_subr_type
); /* Assume subr. */
8054 DECL_EXTERNAL (t
) = 1;
8055 TREE_PUBLIC (t
) = 1;
8057 t
= start_decl (t
, FALSE
);
8058 finish_decl (t
, NULL_TREE
, FALSE
);
8061 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8062 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8063 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8064 ffeglobal_set_hook (g
, t
);
8066 resume_temporary_allocation ();
8072 assert ("NONE where unexpected" == NULL
);
8074 case FFEINFO_whereANY
:
8079 case FFEINFO_kindENTITY
:
8080 switch (ffeinfo_where (ffesymbol_info (s
)))
8083 case FFEINFO_whereCONSTANT
: /* ~~debugging info needed? */
8084 assert (!ffecom_transform_only_dummies_
);
8085 t
= error_mark_node
; /* Shouldn't ever see this in expr. */
8088 case FFEINFO_whereLOCAL
:
8089 assert (!ffecom_transform_only_dummies_
);
8092 ffestorag st
= ffesymbol_storage (s
);
8096 && (ffestorag_size (st
) == 0))
8098 t
= error_mark_node
;
8102 yes
= suspend_momentary ();
8103 type
= ffecom_type_localvar_ (s
, bt
, kt
);
8104 resume_momentary (yes
);
8106 if (type
== error_mark_node
)
8108 t
= error_mark_node
;
8113 && (ffestorag_parent (st
) != NULL
))
8114 { /* Child of EQUIVALENCE parent. */
8118 ffetargetOffset offset
;
8120 est
= ffestorag_parent (st
);
8121 ffecom_transform_equiv_ (est
);
8123 et
= ffestorag_hook (est
);
8124 assert (et
!= NULL_TREE
);
8126 if (! TREE_STATIC (et
))
8127 put_var_into_stack (et
);
8129 yes
= suspend_momentary ();
8131 offset
= ffestorag_modulo (est
)
8132 + ffestorag_offset (ffesymbol_storage (s
))
8133 - ffestorag_offset (est
);
8135 ffecom_debug_kludge_ (et
, "EQUIVALENCE", s
, type
, offset
);
8137 /* (t_type *) (((char *) &et) + offset) */
8139 t
= convert (string_type_node
, /* (char *) */
8140 ffecom_1 (ADDR_EXPR
,
8141 build_pointer_type (TREE_TYPE (et
)),
8143 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
8145 build_int_2 (offset
, 0));
8146 t
= convert (build_pointer_type (type
),
8151 resume_momentary (yes
);
8156 bool init
= ffesymbol_is_init (s
);
8158 yes
= suspend_momentary ();
8160 t
= build_decl (VAR_DECL
,
8161 ffecom_get_identifier_ (ffesymbol_text (s
)),
8165 || ffesymbol_namelisted (s
)
8166 #ifdef FFECOM_sizeMAXSTACKITEM
8168 && (ffestorag_size (st
) > FFECOM_sizeMAXSTACKITEM
))
8170 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8171 && (ffecom_primary_entry_kind_
8172 != FFEINFO_kindBLOCKDATA
)
8173 && (ffesymbol_is_save (s
) || ffe_is_saveall ())))
8174 TREE_STATIC (t
) = !ffesymbol_attr (s
, FFESYMBOL_attrADJUSTABLE
);
8176 TREE_STATIC (t
) = 0; /* No need to make static. */
8178 if (init
|| ffe_is_init_local_zero ())
8179 DECL_INITIAL (t
) = error_mark_node
;
8181 /* Keep -Wunused from complaining about var if it
8182 is used as sfunc arg or DATA implied-DO. */
8183 if (ffesymbol_attrs (s
) & FFESYMBOL_attrsSFARG
)
8184 DECL_IN_SYSTEM_HEADER (t
) = 1;
8186 t
= start_decl (t
, FALSE
);
8190 if (ffesymbol_init (s
) != NULL
)
8191 initexpr
= ffecom_expr (ffesymbol_init (s
));
8193 initexpr
= ffecom_init_zero_ (t
);
8195 else if (ffe_is_init_local_zero ())
8196 initexpr
= ffecom_init_zero_ (t
);
8198 initexpr
= NULL_TREE
; /* Not ref'd if !init. */
8200 finish_decl (t
, initexpr
, FALSE
);
8202 if ((st
!= NULL
) && (DECL_SIZE (t
) != error_mark_node
))
8206 size_tree
= size_binop (CEIL_DIV_EXPR
,
8208 size_int (BITS_PER_UNIT
));
8209 assert (TREE_INT_CST_HIGH (size_tree
) == 0);
8210 assert (TREE_INT_CST_LOW (size_tree
) == ffestorag_size (st
));
8213 resume_momentary (yes
);
8218 case FFEINFO_whereRESULT
:
8219 assert (!ffecom_transform_only_dummies_
);
8221 if (bt
== FFEINFO_basictypeCHARACTER
)
8222 { /* Result is already in list of dummies, use
8224 t
= ffecom_func_result_
;
8225 tlen
= ffecom_func_length_
;
8229 if ((ffecom_num_entrypoints_
== 0)
8230 && (bt
== FFEINFO_basictypeCOMPLEX
)
8231 && (ffesymbol_is_f2c (ffecom_primary_entry_
)))
8232 { /* Result is already in list of dummies, use
8234 t
= ffecom_func_result_
;
8238 if (ffecom_func_result_
!= NULL_TREE
)
8240 t
= ffecom_func_result_
;
8243 if ((ffecom_num_entrypoints_
!= 0)
8244 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
))
8246 yes
= suspend_momentary ();
8248 assert (ffecom_multi_retval_
!= NULL_TREE
);
8249 t
= ffecom_1 (INDIRECT_REF
, ffecom_multi_type_node_
,
8250 ffecom_multi_retval_
);
8251 t
= ffecom_2 (COMPONENT_REF
, ffecom_tree_type
[bt
][kt
],
8252 t
, ffecom_multi_fields_
[bt
][kt
]);
8254 resume_momentary (yes
);
8258 yes
= suspend_momentary ();
8260 t
= build_decl (VAR_DECL
,
8261 ffecom_get_identifier_ (ffesymbol_text (s
)),
8262 ffecom_tree_type
[bt
][kt
]);
8263 TREE_STATIC (t
) = 0; /* Put result on stack. */
8264 t
= start_decl (t
, FALSE
);
8265 finish_decl (t
, NULL_TREE
, FALSE
);
8267 ffecom_func_result_
= t
;
8269 resume_momentary (yes
);
8272 case FFEINFO_whereDUMMY
:
8280 bool adjustable
= FALSE
; /* Conditionally adjustable? */
8282 type
= ffecom_tree_type
[bt
][kt
];
8283 if (ffesymbol_sfdummyparent (s
) != NULL
)
8285 if (current_function_decl
== ffecom_outer_function_decl_
)
8286 { /* Exec transition before sfunc
8287 context; get it later. */
8290 t
= ffecom_get_identifier_ (ffesymbol_text
8291 (ffesymbol_sfdummyparent (s
)));
8294 t
= ffecom_get_identifier_ (ffesymbol_text (s
));
8296 assert (ffecom_transform_only_dummies_
);
8298 old_sizes
= get_pending_sizes ();
8299 put_pending_sizes (old_sizes
);
8301 if (bt
== FFEINFO_basictypeCHARACTER
)
8302 tlen
= ffecom_char_enhance_arg_ (&type
, s
);
8303 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
8305 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
8307 if (type
== error_mark_node
)
8310 dim
= ffebld_head (dl
);
8311 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
8312 if ((ffebld_left (dim
) == NULL
) || ffecom_doing_entry_
)
8313 low
= ffecom_integer_one_node
;
8315 low
= ffecom_expr (ffebld_left (dim
));
8316 assert (ffebld_right (dim
) != NULL
);
8317 if ((ffebld_op (ffebld_right (dim
)) == FFEBLD_opSTAR
)
8318 || ffecom_doing_entry_
)
8320 /* Used to just do high=low. But for ffecom_tree_
8321 canonize_ref_, it probably is important to correctly
8322 assess the size. E.g. given COMPLEX C(*),CFUNC and
8323 C(2)=CFUNC(C), overlap can happen, while it can't
8324 for, say, C(1)=CFUNC(C(2)). */
8325 /* Even more recently used to set to INT_MAX, but that
8326 broke when some overflow checking went into the back
8327 end. Now we just leave the upper bound unspecified. */
8331 high
= ffecom_expr (ffebld_right (dim
));
8333 /* Determine whether array is conditionally adjustable,
8334 to decide whether back-end magic is needed.
8336 Normally the front end uses the back-end function
8337 variable_size to wrap SAVE_EXPR's around expressions
8338 affecting the size/shape of an array so that the
8339 size/shape info doesn't change during execution
8340 of the compiled code even though variables and
8341 functions referenced in those expressions might.
8343 variable_size also makes sure those saved expressions
8344 get evaluated immediately upon entry to the
8345 compiled procedure -- the front end normally doesn't
8346 have to worry about that.
8348 However, there is a problem with this that affects
8349 g77's implementation of entry points, and that is
8350 that it is _not_ true that each invocation of the
8351 compiled procedure is permitted to evaluate
8352 array size/shape info -- because it is possible
8353 that, for some invocations, that info is invalid (in
8354 which case it is "promised" -- i.e. a violation of
8355 the Fortran standard -- that the compiled code
8356 won't reference the array or its size/shape
8357 during that particular invocation).
8359 To phrase this in C terms, consider this gcc function:
8361 void foo (int *n, float (*a)[*n])
8363 // a is "pointer to array ...", fyi.
8366 Suppose that, for some invocations, it is permitted
8367 for a caller of foo to do this:
8371 Now the _written_ code for foo can take such a call
8372 into account by either testing explicitly for whether
8373 (a == NULL) || (n == NULL) -- presumably it is
8374 not permitted to reference *a in various fashions
8375 if (n == NULL) I suppose -- or it can avoid it by
8376 looking at other info (other arguments, static/global
8379 However, this won't work in gcc 2.5.8 because it'll
8380 automatically emit the code to save the "*n"
8381 expression, which'll yield a NULL dereference for
8382 the "foo (NULL, NULL)" call, something the code
8383 for foo cannot prevent.
8385 g77 definitely needs to avoid executing such
8386 code anytime the pointer to the adjustable array
8387 is NULL, because even if its bounds expressions
8388 don't have any references to possible "absent"
8389 variables like "*n" -- say all variable references
8390 are to COMMON variables, i.e. global (though in C,
8391 local static could actually make sense) -- the
8392 expressions could yield other run-time problems
8393 for allowably "dead" values in those variables.
8395 For example, let's consider a more complicated
8401 void foo (float (*a)[i/j])
8406 The above is (essentially) quite valid for Fortran
8407 but, again, for a call like "foo (NULL);", it is
8408 permitted for i and j to be undefined when the
8409 call is made. If j happened to be zero, for
8410 example, emitting the code to evaluate "i/j"
8411 could result in a run-time error.
8413 Offhand, though I don't have my F77 or F90
8414 standards handy, it might even be valid for a
8415 bounds expression to contain a function reference,
8416 in which case I doubt it is permitted for an
8417 implementation to invoke that function in the
8418 Fortran case involved here (invocation of an
8419 alternate ENTRY point that doesn't have the adjustable
8420 array as one of its arguments).
8422 So, the code that the compiler would normally emit
8423 to preevaluate the size/shape info for an
8424 adjustable array _must not_ be executed at run time
8425 in certain cases. Specifically, for Fortran,
8426 the case is when the pointer to the adjustable
8427 array == NULL. (For gnu-ish C, it might be nice
8428 for the source code itself to specify an expression
8429 that, if TRUE, inhibits execution of the code. Or
8430 reverse the sense for elegance.)
8432 (Note that g77 could use a different test than NULL,
8433 actually, since it happens to always pass an
8434 integer to the called function that specifies which
8435 entry point is being invoked. Hmm, this might
8436 solve the next problem.)
8438 One way a user could, I suppose, write "foo" so
8439 it works is to insert COND_EXPR's for the
8440 size/shape info so the dangerous stuff isn't
8441 actually done, as in:
8443 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
8448 The next problem is that the front end needs to
8449 be able to tell the back end about the array's
8450 decl _before_ it tells it about the conditional
8451 expression to inhibit evaluation of size/shape info,
8454 To solve this, the front end needs to be able
8455 to give the back end the expression to inhibit
8456 generation of the preevaluation code _after_
8457 it makes the decl for the adjustable array.
8459 Until then, the above example using the COND_EXPR
8460 doesn't pass muster with gcc because the "(a == NULL)"
8461 part has a reference to "a", which is still
8462 undefined at that point.
8464 g77 will therefore use a different mechanism in the
8468 && ((TREE_CODE (low
) != INTEGER_CST
)
8469 || (high
&& TREE_CODE (high
) != INTEGER_CST
)))
8472 #if 0 /* Old approach -- see below. */
8473 if (TREE_CODE (low
) != INTEGER_CST
)
8474 low
= ffecom_3 (COND_EXPR
, integer_type_node
,
8475 ffecom_adjarray_passed_ (s
),
8477 ffecom_integer_zero_node
);
8479 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
8480 high
= ffecom_3 (COND_EXPR
, integer_type_node
,
8481 ffecom_adjarray_passed_ (s
),
8483 ffecom_integer_zero_node
);
8486 /* ~~~gcc/stor-layout.c/layout_type should do this,
8487 probably. Fixes 950302-1.f. */
8489 if (TREE_CODE (low
) != INTEGER_CST
)
8490 low
= variable_size (low
);
8492 /* ~~~similarly, this fixes dumb0.f. The C front end
8493 does this, which is why dumb0.c would work. */
8495 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
8496 high
= variable_size (high
);
8501 build_range_type (ffecom_integer_type_node
,
8503 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
8506 if (type
== error_mark_node
)
8508 t
= error_mark_node
;
8512 if ((ffesymbol_sfdummyparent (s
) == NULL
)
8513 || (ffesymbol_basictype (s
) == FFEINFO_basictypeCHARACTER
))
8515 type
= build_pointer_type (type
);
8519 t
= build_decl (PARM_DECL
, t
, type
);
8521 DECL_ARTIFICIAL (t
) = 1;
8524 /* If this arg is present in every entry point's list of
8525 dummy args, then we're done. */
8527 if (ffesymbol_numentries (s
)
8528 == (ffecom_num_entrypoints_
+ 1))
8533 /* If variable_size in stor-layout has been called during
8534 the above, then get_pending_sizes should have the
8535 yet-to-be-evaluated saved expressions pending.
8536 Make the whole lot of them get emitted, conditionally
8537 on whether the array decl ("t" above) is not NULL. */
8540 tree sizes
= get_pending_sizes ();
8545 tem
= TREE_CHAIN (tem
))
8547 tree temv
= TREE_VALUE (tem
);
8553 = ffecom_2 (COMPOUND_EXPR
,
8562 = ffecom_3 (COND_EXPR
,
8569 convert (TREE_TYPE (sizes
),
8570 integer_zero_node
));
8571 sizes
= ffecom_save_tree (sizes
);
8574 = tree_cons (NULL_TREE
, sizes
, tem
);
8578 put_pending_sizes (sizes
);
8584 && (ffesymbol_numentries (s
)
8585 != ffecom_num_entrypoints_
+ 1))
8587 = ffecom_2 (NE_EXPR
, integer_type_node
,
8593 && (ffesymbol_numentries (s
)
8594 != ffecom_num_entrypoints_
+ 1))
8596 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED
);
8597 ffebad_here (0, ffesymbol_where_line (s
),
8598 ffesymbol_where_column (s
));
8599 ffebad_string (ffesymbol_text (s
));
8608 case FFEINFO_whereCOMMON
:
8613 ffestorag st
= ffesymbol_storage (s
);
8617 cs
= ffesymbol_common (s
); /* The COMMON area itself. */
8618 if (st
!= NULL
) /* Else not laid out. */
8620 ffecom_transform_common_ (cs
);
8621 st
= ffesymbol_storage (s
);
8624 yes
= suspend_momentary ();
8626 type
= ffecom_type_localvar_ (s
, bt
, kt
);
8628 cg
= ffesymbol_global (cs
); /* The global COMMON info. */
8630 || (ffeglobal_type (cg
) != FFEGLOBAL_typeCOMMON
))
8633 ct
= ffeglobal_hook (cg
); /* The common area's tree. */
8635 if ((ct
== NULL_TREE
)
8637 || (type
== error_mark_node
))
8638 t
= error_mark_node
;
8641 ffetargetOffset offset
;
8644 cst
= ffestorag_parent (st
);
8645 assert (cst
== ffesymbol_storage (cs
));
8647 offset
= ffestorag_modulo (cst
)
8648 + ffestorag_offset (st
)
8649 - ffestorag_offset (cst
);
8651 ffecom_debug_kludge_ (ct
, "COMMON", s
, type
, offset
);
8653 /* (t_type *) (((char *) &ct) + offset) */
8655 t
= convert (string_type_node
, /* (char *) */
8656 ffecom_1 (ADDR_EXPR
,
8657 build_pointer_type (TREE_TYPE (ct
)),
8659 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
8661 build_int_2 (offset
, 0));
8662 t
= convert (build_pointer_type (type
),
8668 resume_momentary (yes
);
8672 case FFEINFO_whereIMMEDIATE
:
8673 case FFEINFO_whereGLOBAL
:
8674 case FFEINFO_whereFLEETING
:
8675 case FFEINFO_whereFLEETING_CADDR
:
8676 case FFEINFO_whereFLEETING_IADDR
:
8677 case FFEINFO_whereINTRINSIC
:
8678 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8680 assert ("ENTITY where unheard of" == NULL
);
8682 case FFEINFO_whereANY
:
8683 t
= error_mark_node
;
8688 case FFEINFO_kindFUNCTION
:
8689 switch (ffeinfo_where (ffesymbol_info (s
)))
8691 case FFEINFO_whereLOCAL
: /* Me. */
8692 assert (!ffecom_transform_only_dummies_
);
8693 t
= current_function_decl
;
8696 case FFEINFO_whereGLOBAL
:
8697 assert (!ffecom_transform_only_dummies_
);
8699 if (((g
= ffesymbol_global (s
)) != NULL
)
8700 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8701 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8702 && (ffeglobal_hook (g
) != NULL_TREE
)
8703 && ffe_is_globals ())
8705 t
= ffeglobal_hook (g
);
8709 push_obstacks_nochange ();
8710 end_temporary_allocation ();
8712 if (ffesymbol_is_f2c (s
)
8713 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8714 t
= ffecom_tree_fun_type
[bt
][kt
];
8716 t
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
8718 t
= build_decl (FUNCTION_DECL
,
8719 ffecom_get_external_identifier_ (s
),
8721 DECL_EXTERNAL (t
) = 1;
8722 TREE_PUBLIC (t
) = 1;
8724 t
= start_decl (t
, FALSE
);
8725 finish_decl (t
, NULL_TREE
, FALSE
);
8728 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8729 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8730 ffeglobal_set_hook (g
, t
);
8732 resume_temporary_allocation ();
8737 case FFEINFO_whereDUMMY
:
8738 assert (ffecom_transform_only_dummies_
);
8740 if (ffesymbol_is_f2c (s
)
8741 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8742 t
= ffecom_tree_ptr_to_fun_type
[bt
][kt
];
8744 t
= build_pointer_type
8745 (build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
));
8747 t
= build_decl (PARM_DECL
,
8748 ffecom_get_identifier_ (ffesymbol_text (s
)),
8751 DECL_ARTIFICIAL (t
) = 1;
8756 case FFEINFO_whereCONSTANT
: /* Statement function. */
8757 assert (!ffecom_transform_only_dummies_
);
8758 t
= ffecom_gen_sfuncdef_ (s
, bt
, kt
);
8761 case FFEINFO_whereINTRINSIC
:
8762 assert (!ffecom_transform_only_dummies_
);
8763 break; /* Let actual references generate their
8767 assert ("FUNCTION where unheard of" == NULL
);
8769 case FFEINFO_whereANY
:
8770 t
= error_mark_node
;
8775 case FFEINFO_kindSUBROUTINE
:
8776 switch (ffeinfo_where (ffesymbol_info (s
)))
8778 case FFEINFO_whereLOCAL
: /* Me. */
8779 assert (!ffecom_transform_only_dummies_
);
8780 t
= current_function_decl
;
8783 case FFEINFO_whereGLOBAL
:
8784 assert (!ffecom_transform_only_dummies_
);
8786 if (((g
= ffesymbol_global (s
)) != NULL
)
8787 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8788 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8789 && (ffeglobal_hook (g
) != NULL_TREE
)
8790 && ffe_is_globals ())
8792 t
= ffeglobal_hook (g
);
8796 push_obstacks_nochange ();
8797 end_temporary_allocation ();
8799 t
= build_decl (FUNCTION_DECL
,
8800 ffecom_get_external_identifier_ (s
),
8801 ffecom_tree_subr_type
);
8802 DECL_EXTERNAL (t
) = 1;
8803 TREE_PUBLIC (t
) = 1;
8805 t
= start_decl (t
, FALSE
);
8806 finish_decl (t
, NULL_TREE
, FALSE
);
8809 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8810 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8811 ffeglobal_set_hook (g
, t
);
8813 resume_temporary_allocation ();
8818 case FFEINFO_whereDUMMY
:
8819 assert (ffecom_transform_only_dummies_
);
8821 t
= build_decl (PARM_DECL
,
8822 ffecom_get_identifier_ (ffesymbol_text (s
)),
8823 ffecom_tree_ptr_to_subr_type
);
8825 DECL_ARTIFICIAL (t
) = 1;
8830 case FFEINFO_whereINTRINSIC
:
8831 assert (!ffecom_transform_only_dummies_
);
8832 break; /* Let actual references generate their
8836 assert ("SUBROUTINE where unheard of" == NULL
);
8838 case FFEINFO_whereANY
:
8839 t
= error_mark_node
;
8844 case FFEINFO_kindPROGRAM
:
8845 switch (ffeinfo_where (ffesymbol_info (s
)))
8847 case FFEINFO_whereLOCAL
: /* Me. */
8848 assert (!ffecom_transform_only_dummies_
);
8849 t
= current_function_decl
;
8852 case FFEINFO_whereCOMMON
:
8853 case FFEINFO_whereDUMMY
:
8854 case FFEINFO_whereGLOBAL
:
8855 case FFEINFO_whereRESULT
:
8856 case FFEINFO_whereFLEETING
:
8857 case FFEINFO_whereFLEETING_CADDR
:
8858 case FFEINFO_whereFLEETING_IADDR
:
8859 case FFEINFO_whereIMMEDIATE
:
8860 case FFEINFO_whereINTRINSIC
:
8861 case FFEINFO_whereCONSTANT
:
8862 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8864 assert ("PROGRAM where unheard of" == NULL
);
8866 case FFEINFO_whereANY
:
8867 t
= error_mark_node
;
8872 case FFEINFO_kindBLOCKDATA
:
8873 switch (ffeinfo_where (ffesymbol_info (s
)))
8875 case FFEINFO_whereLOCAL
: /* Me. */
8876 assert (!ffecom_transform_only_dummies_
);
8877 t
= current_function_decl
;
8880 case FFEINFO_whereGLOBAL
:
8881 assert (!ffecom_transform_only_dummies_
);
8883 push_obstacks_nochange ();
8884 end_temporary_allocation ();
8886 t
= build_decl (FUNCTION_DECL
,
8887 ffecom_get_external_identifier_ (s
),
8888 ffecom_tree_blockdata_type
);
8889 DECL_EXTERNAL (t
) = 1;
8890 TREE_PUBLIC (t
) = 1;
8892 t
= start_decl (t
, FALSE
);
8893 finish_decl (t
, NULL_TREE
, FALSE
);
8895 resume_temporary_allocation ();
8900 case FFEINFO_whereCOMMON
:
8901 case FFEINFO_whereDUMMY
:
8902 case FFEINFO_whereRESULT
:
8903 case FFEINFO_whereFLEETING
:
8904 case FFEINFO_whereFLEETING_CADDR
:
8905 case FFEINFO_whereFLEETING_IADDR
:
8906 case FFEINFO_whereIMMEDIATE
:
8907 case FFEINFO_whereINTRINSIC
:
8908 case FFEINFO_whereCONSTANT
:
8909 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8911 assert ("BLOCKDATA where unheard of" == NULL
);
8913 case FFEINFO_whereANY
:
8914 t
= error_mark_node
;
8919 case FFEINFO_kindCOMMON
:
8920 switch (ffeinfo_where (ffesymbol_info (s
)))
8922 case FFEINFO_whereLOCAL
:
8923 assert (!ffecom_transform_only_dummies_
);
8924 ffecom_transform_common_ (s
);
8927 case FFEINFO_whereNONE
:
8928 case FFEINFO_whereCOMMON
:
8929 case FFEINFO_whereDUMMY
:
8930 case FFEINFO_whereGLOBAL
:
8931 case FFEINFO_whereRESULT
:
8932 case FFEINFO_whereFLEETING
:
8933 case FFEINFO_whereFLEETING_CADDR
:
8934 case FFEINFO_whereFLEETING_IADDR
:
8935 case FFEINFO_whereIMMEDIATE
:
8936 case FFEINFO_whereINTRINSIC
:
8937 case FFEINFO_whereCONSTANT
:
8938 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8940 assert ("COMMON where unheard of" == NULL
);
8942 case FFEINFO_whereANY
:
8943 t
= error_mark_node
;
8948 case FFEINFO_kindCONSTRUCT
:
8949 switch (ffeinfo_where (ffesymbol_info (s
)))
8951 case FFEINFO_whereLOCAL
:
8952 assert (!ffecom_transform_only_dummies_
);
8955 case FFEINFO_whereNONE
:
8956 case FFEINFO_whereCOMMON
:
8957 case FFEINFO_whereDUMMY
:
8958 case FFEINFO_whereGLOBAL
:
8959 case FFEINFO_whereRESULT
:
8960 case FFEINFO_whereFLEETING
:
8961 case FFEINFO_whereFLEETING_CADDR
:
8962 case FFEINFO_whereFLEETING_IADDR
:
8963 case FFEINFO_whereIMMEDIATE
:
8964 case FFEINFO_whereINTRINSIC
:
8965 case FFEINFO_whereCONSTANT
:
8966 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8968 assert ("CONSTRUCT where unheard of" == NULL
);
8970 case FFEINFO_whereANY
:
8971 t
= error_mark_node
;
8976 case FFEINFO_kindNAMELIST
:
8977 switch (ffeinfo_where (ffesymbol_info (s
)))
8979 case FFEINFO_whereLOCAL
:
8980 assert (!ffecom_transform_only_dummies_
);
8981 t
= ffecom_transform_namelist_ (s
);
8984 case FFEINFO_whereNONE
:
8985 case FFEINFO_whereCOMMON
:
8986 case FFEINFO_whereDUMMY
:
8987 case FFEINFO_whereGLOBAL
:
8988 case FFEINFO_whereRESULT
:
8989 case FFEINFO_whereFLEETING
:
8990 case FFEINFO_whereFLEETING_CADDR
:
8991 case FFEINFO_whereFLEETING_IADDR
:
8992 case FFEINFO_whereIMMEDIATE
:
8993 case FFEINFO_whereINTRINSIC
:
8994 case FFEINFO_whereCONSTANT
:
8995 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8997 assert ("NAMELIST where unheard of" == NULL
);
8999 case FFEINFO_whereANY
:
9000 t
= error_mark_node
;
9006 assert ("kind unheard of" == NULL
);
9008 case FFEINFO_kindANY
:
9009 t
= error_mark_node
;
9013 ffesymbol_hook (s
).decl_tree
= t
;
9014 ffesymbol_hook (s
).length_tree
= tlen
;
9015 ffesymbol_hook (s
).addr
= addr
;
9017 lineno
= old_lineno
;
9018 input_filename
= old_input_filename
;
9024 /* Transform into ASSIGNable symbol.
9026 Symbol has already been transformed, but for whatever reason, the
9027 resulting decl_tree has been deemed not usable for an ASSIGN target.
9028 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
9029 another local symbol of type void * and stuff that in the assign_tree
9030 argument. The F77/F90 standards allow this implementation. */
9032 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9034 ffecom_sym_transform_assign_ (ffesymbol s
)
9036 tree t
; /* Transformed thingy. */
9038 int old_lineno
= lineno
;
9039 char *old_input_filename
= input_filename
;
9041 if (ffesymbol_sfdummyparent (s
) == NULL
)
9043 input_filename
= ffesymbol_where_filename (s
);
9044 lineno
= ffesymbol_where_filelinenum (s
);
9048 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
9050 input_filename
= ffesymbol_where_filename (sf
);
9051 lineno
= ffesymbol_where_filelinenum (sf
);
9054 assert (!ffecom_transform_only_dummies_
);
9056 yes
= suspend_momentary ();
9058 t
= build_decl (VAR_DECL
,
9059 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
9062 TREE_TYPE (null_pointer_node
));
9064 switch (ffesymbol_where (s
))
9066 case FFEINFO_whereLOCAL
:
9067 /* Unlike for regular vars, SAVE status is easy to determine for
9068 ASSIGNed vars, since there's no initialization, there's no
9069 effective storage association (so "SAVE J" does not apply to
9070 K even given "EQUIVALENCE (J,K)"), there's no size issue
9071 to worry about, etc. */
9072 if ((ffesymbol_is_save (s
) || ffe_is_saveall ())
9073 && (ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
9074 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
))
9075 TREE_STATIC (t
) = 1; /* SAVEd in proc, make static. */
9077 TREE_STATIC (t
) = 0; /* No need to make static. */
9080 case FFEINFO_whereCOMMON
:
9081 TREE_STATIC (t
) = 1; /* Assume COMMONs always SAVEd. */
9084 case FFEINFO_whereDUMMY
:
9085 /* Note that twinning a DUMMY means the caller won't see
9086 the ASSIGNed value. But both F77 and F90 allow implementations
9087 to do this, i.e. disallow Fortran code that would try and
9088 take advantage of actually putting a label into a variable
9089 via a dummy argument (or any other storage association, for
9091 TREE_STATIC (t
) = 0;
9095 TREE_STATIC (t
) = 0;
9099 t
= start_decl (t
, FALSE
);
9100 finish_decl (t
, NULL_TREE
, FALSE
);
9102 resume_momentary (yes
);
9104 ffesymbol_hook (s
).assign_tree
= t
;
9106 lineno
= old_lineno
;
9107 input_filename
= old_input_filename
;
9113 /* Implement COMMON area in back end.
9115 Because COMMON-based variables can be referenced in the dimension
9116 expressions of dummy (adjustable) arrays, and because dummies
9117 (in the gcc back end) need to be put in the outer binding level
9118 of a function (which has two binding levels, the outer holding
9119 the dummies and the inner holding the other vars), special care
9120 must be taken to handle COMMON areas.
9122 The current strategy is basically to always tell the back end about
9123 the COMMON area as a top-level external reference to just a block
9124 of storage of the master type of that area (e.g. integer, real,
9125 character, whatever -- not a structure). As a distinct action,
9126 if initial values are provided, tell the back end about the area
9127 as a top-level non-external (initialized) area and remember not to
9128 allow further initialization or expansion of the area. Meanwhile,
9129 if no initialization happens at all, tell the back end about
9130 the largest size we've seen declared so the space does get reserved.
9131 (This function doesn't handle all that stuff, but it does some
9132 of the important things.)
9134 Meanwhile, for COMMON variables themselves, just keep creating
9135 references like *((float *) (&common_area + offset)) each time
9136 we reference the variable. In other words, don't make a VAR_DECL
9137 or any kind of component reference (like we used to do before 0.4),
9138 though we might do that as well just for debugging purposes (and
9139 stuff the rtl with the appropriate offset expression). */
9141 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9143 ffecom_transform_common_ (ffesymbol s
)
9145 ffestorag st
= ffesymbol_storage (s
);
9146 ffeglobal g
= ffesymbol_global (s
);
9150 bool is_init
= ffestorag_is_init (st
);
9152 assert (st
!= NULL
);
9155 || (ffeglobal_type (g
) != FFEGLOBAL_typeCOMMON
))
9158 /* First update the size of the area in global terms. */
9160 ffeglobal_size_common (s
, ffestorag_size (st
));
9162 if (!ffeglobal_common_init (g
))
9163 is_init
= FALSE
; /* No explicit init, don't let erroneous joins init. */
9165 cbt
= ffeglobal_hook (g
);
9167 /* If we already have declared this common block for a previous program
9168 unit, and either we already initialized it or we don't have new
9169 initialization for it, just return what we have without changing it. */
9171 if ((cbt
!= NULL_TREE
)
9173 || !DECL_EXTERNAL (cbt
)))
9176 /* Process inits. */
9180 if (ffestorag_init (st
) != NULL
)
9182 init
= ffecom_expr (ffestorag_init (st
));
9183 if (init
== error_mark_node
)
9184 { /* Hopefully the back end complained! */
9186 if (cbt
!= NULL_TREE
)
9191 init
= error_mark_node
;
9196 push_obstacks_nochange ();
9197 end_temporary_allocation ();
9199 /* cbtype must be permanently allocated! */
9202 cbtype
= build_array_type (char_type_node
,
9203 build_range_type (integer_type_node
,
9206 (ffeglobal_common_size (g
),
9209 cbtype
= build_array_type (char_type_node
, NULL_TREE
);
9211 if (cbt
== NULL_TREE
)
9214 = build_decl (VAR_DECL
,
9215 ffecom_get_external_identifier_ (s
),
9217 TREE_STATIC (cbt
) = 1;
9218 TREE_PUBLIC (cbt
) = 1;
9223 TREE_TYPE (cbt
) = cbtype
;
9225 DECL_EXTERNAL (cbt
) = init
? 0 : 1;
9226 DECL_INITIAL (cbt
) = init
? error_mark_node
: NULL_TREE
;
9228 cbt
= start_decl (cbt
, TRUE
);
9229 if (ffeglobal_hook (g
) != NULL
)
9230 assert (cbt
== ffeglobal_hook (g
));
9232 assert (!init
|| !DECL_EXTERNAL (cbt
));
9234 /* Make sure that any type can live in COMMON and be referenced
9235 without getting a bus error. We could pick the most restrictive
9236 alignment of all entities actually placed in the COMMON, but
9237 this seems easy enough. */
9239 DECL_ALIGN (cbt
) = BIGGEST_ALIGNMENT
;
9241 if (is_init
&& (ffestorag_init (st
) == NULL
))
9242 init
= ffecom_init_zero_ (cbt
);
9244 finish_decl (cbt
, init
, TRUE
);
9247 ffestorag_set_init (st
, ffebld_new_any ());
9253 assert (DECL_SIZE (cbt
) != NULL_TREE
);
9254 assert (TREE_CODE (DECL_SIZE (cbt
)) == INTEGER_CST
);
9255 size_tree
= size_binop (CEIL_DIV_EXPR
,
9257 size_int (BITS_PER_UNIT
));
9258 assert (TREE_INT_CST_HIGH (size_tree
) == 0);
9259 assert (TREE_INT_CST_LOW (size_tree
) == ffeglobal_common_size (g
));
9262 ffeglobal_set_hook (g
, cbt
);
9264 ffestorag_set_hook (st
, cbt
);
9266 resume_temporary_allocation ();
9271 /* Make master area for local EQUIVALENCE. */
9273 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9275 ffecom_transform_equiv_ (ffestorag eqst
)
9281 bool is_init
= ffestorag_is_init (eqst
);
9284 assert (eqst
!= NULL
);
9286 eqt
= ffestorag_hook (eqst
);
9288 if (eqt
!= NULL_TREE
)
9291 /* Process inits. */
9295 if (ffestorag_init (eqst
) != NULL
)
9297 init
= ffecom_expr (ffestorag_init (eqst
));
9298 if (init
== error_mark_node
)
9299 init
= NULL_TREE
; /* Hopefully the back end complained! */
9302 init
= error_mark_node
;
9304 else if (ffe_is_init_local_zero ())
9305 init
= error_mark_node
;
9309 ffecom_member_namelisted_
= FALSE
;
9310 ffestorag_drive (ffestorag_list_equivs (eqst
),
9311 &ffecom_member_phase1_
,
9314 yes
= suspend_momentary ();
9316 high
= build_int_2 (ffestorag_size (eqst
), 0);
9317 TREE_TYPE (high
) = ffecom_integer_type_node
;
9319 eqtype
= build_array_type (char_type_node
,
9320 build_range_type (ffecom_integer_type_node
,
9321 ffecom_integer_one_node
,
9324 eqt
= build_decl (VAR_DECL
,
9325 ffecom_get_invented_identifier ("__g77_equiv_%s",
9331 DECL_EXTERNAL (eqt
) = 0;
9333 || ffecom_member_namelisted_
9334 #ifdef FFECOM_sizeMAXSTACKITEM
9335 || (ffestorag_size (eqst
) > FFECOM_sizeMAXSTACKITEM
)
9337 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
9338 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
9339 && (ffestorag_is_save (eqst
) || ffe_is_saveall ())))
9340 TREE_STATIC (eqt
) = 1;
9342 TREE_STATIC (eqt
) = 0;
9343 TREE_PUBLIC (eqt
) = 0;
9344 DECL_CONTEXT (eqt
) = current_function_decl
;
9346 DECL_INITIAL (eqt
) = error_mark_node
;
9348 DECL_INITIAL (eqt
) = NULL_TREE
;
9350 eqt
= start_decl (eqt
, FALSE
);
9352 /* Make sure this shows up as a debug symbol, which is not normally
9353 the case for invented identifiers. */
9355 DECL_IGNORED_P (eqt
) = 0;
9357 /* Make sure that any type can live in EQUIVALENCE and be referenced
9358 without getting a bus error. We could pick the most restrictive
9359 alignment of all entities actually placed in the EQUIVALENCE, but
9360 this seems easy enough. */
9362 DECL_ALIGN (eqt
) = BIGGEST_ALIGNMENT
;
9364 if ((!is_init
&& ffe_is_init_local_zero ())
9365 || (is_init
&& (ffestorag_init (eqst
) == NULL
)))
9366 init
= ffecom_init_zero_ (eqt
);
9368 finish_decl (eqt
, init
, FALSE
);
9371 ffestorag_set_init (eqst
, ffebld_new_any ());
9376 size_tree
= size_binop (CEIL_DIV_EXPR
,
9378 size_int (BITS_PER_UNIT
));
9379 assert (TREE_INT_CST_HIGH (size_tree
) == 0);
9380 assert (TREE_INT_CST_LOW (size_tree
) == ffestorag_size (eqst
));
9383 ffestorag_set_hook (eqst
, eqt
);
9385 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
9386 ffestorag_drive (ffestorag_list_equivs (eqst
),
9387 &ffecom_member_phase2_
,
9391 resume_momentary (yes
);
9395 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
9397 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9399 ffecom_transform_namelist_ (ffesymbol s
)
9402 tree nmltype
= ffecom_type_namelist_ ();
9411 static int mynumber
= 0;
9413 yes
= suspend_momentary ();
9415 nmlt
= build_decl (VAR_DECL
,
9416 ffecom_get_invented_identifier ("__g77_namelist_%d",
9419 TREE_STATIC (nmlt
) = 1;
9420 DECL_INITIAL (nmlt
) = error_mark_node
;
9422 nmlt
= start_decl (nmlt
, FALSE
);
9424 /* Process inits. */
9426 i
= strlen (ffesymbol_text (s
));
9428 high
= build_int_2 (i
, 0);
9429 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
9431 nameinit
= ffecom_build_f2c_string_ (i
+ 1,
9432 ffesymbol_text (s
));
9433 TREE_TYPE (nameinit
)
9434 = build_type_variant
9437 build_range_type (ffecom_f2c_ftnlen_type_node
,
9438 ffecom_f2c_ftnlen_one_node
,
9441 TREE_CONSTANT (nameinit
) = 1;
9442 TREE_STATIC (nameinit
) = 1;
9443 nameinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (nameinit
)),
9446 varsinit
= ffecom_vardesc_array_ (s
);
9447 varsinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (varsinit
)),
9449 TREE_CONSTANT (varsinit
) = 1;
9450 TREE_STATIC (varsinit
) = 1;
9455 for (i
= 0, b
= ffesymbol_namelist (s
); b
!= NULL
; b
= ffebld_trail (b
))
9458 nvarsinit
= build_int_2 (i
, 0);
9459 TREE_TYPE (nvarsinit
) = integer_type_node
;
9460 TREE_CONSTANT (nvarsinit
) = 1;
9461 TREE_STATIC (nvarsinit
) = 1;
9463 nmlinits
= build_tree_list ((field
= TYPE_FIELDS (nmltype
)), nameinit
);
9464 TREE_CHAIN (nmlinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
9466 TREE_CHAIN (TREE_CHAIN (nmlinits
))
9467 = build_tree_list ((field
= TREE_CHAIN (field
)), nvarsinit
);
9469 nmlinits
= build (CONSTRUCTOR
, nmltype
, NULL_TREE
, nmlinits
);
9470 TREE_CONSTANT (nmlinits
) = 1;
9471 TREE_STATIC (nmlinits
) = 1;
9473 finish_decl (nmlt
, nmlinits
, FALSE
);
9475 nmlt
= ffecom_1 (ADDR_EXPR
, build_pointer_type (nmltype
), nmlt
);
9477 resume_momentary (yes
);
9484 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
9485 analyzed on the assumption it is calculating a pointer to be
9486 indirected through. It must return the proper decl and offset,
9487 taking into account different units of measurements for offsets. */
9489 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9491 ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
9494 switch (TREE_CODE (t
))
9498 case NON_LVALUE_EXPR
:
9499 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
9503 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
9504 if ((*decl
== NULL_TREE
)
9505 || (*decl
== error_mark_node
))
9508 if (TREE_CODE (TREE_OPERAND (t
, 1)) == INTEGER_CST
)
9510 /* An offset into COMMON. */
9511 *offset
= size_binop (PLUS_EXPR
,
9513 TREE_OPERAND (t
, 1));
9514 /* Convert offset (presumably in bytes) into canonical units
9515 (presumably bits). */
9516 *offset
= size_binop (MULT_EXPR
,
9517 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t
))),
9521 /* Not a COMMON reference, so an unrecognized pattern. */
9522 *decl
= error_mark_node
;
9527 *offset
= bitsize_int (0L, 0L);
9531 if (TREE_CODE (TREE_OPERAND (t
, 0)) == VAR_DECL
)
9533 /* A reference to COMMON. */
9534 *decl
= TREE_OPERAND (t
, 0);
9535 *offset
= bitsize_int (0L, 0L);
9540 /* Not a COMMON reference, so an unrecognized pattern. */
9541 *decl
= error_mark_node
;
9547 /* Given a tree that is possibly intended for use as an lvalue, return
9548 information representing a canonical view of that tree as a decl, an
9549 offset into that decl, and a size for the lvalue.
9551 If there's no applicable decl, NULL_TREE is returned for the decl,
9552 and the other fields are left undefined.
9554 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9555 is returned for the decl, and the other fields are left undefined.
9557 Otherwise, the decl returned currently is either a VAR_DECL or a
9560 The offset returned is always valid, but of course not necessarily
9561 a constant, and not necessarily converted into the appropriate
9562 type, leaving that up to the caller (so as to avoid that overhead
9563 if the decls being looked at are different anyway).
9565 If the size cannot be determined (e.g. an adjustable array),
9566 an ERROR_MARK node is returned for the size. Otherwise, the
9567 size returned is valid, not necessarily a constant, and not
9568 necessarily converted into the appropriate type as with the
9571 Note that the offset and size expressions are expressed in the
9572 base storage units (usually bits) rather than in the units of
9573 the type of the decl, because two decls with different types
9574 might overlap but with apparently non-overlapping array offsets,
9575 whereas converting the array offsets to consistant offsets will
9576 reveal the overlap. */
9578 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9580 ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
9583 /* The default path is to report a nonexistant decl. */
9589 switch (TREE_CODE (t
))
9592 case IDENTIFIER_NODE
:
9601 case TRUNC_DIV_EXPR
:
9603 case FLOOR_DIV_EXPR
:
9604 case ROUND_DIV_EXPR
:
9605 case TRUNC_MOD_EXPR
:
9607 case FLOOR_MOD_EXPR
:
9608 case ROUND_MOD_EXPR
:
9610 case EXACT_DIV_EXPR
:
9611 case FIX_TRUNC_EXPR
:
9613 case FIX_FLOOR_EXPR
:
9614 case FIX_ROUND_EXPR
:
9629 case BIT_ANDTC_EXPR
:
9631 case TRUTH_ANDIF_EXPR
:
9632 case TRUTH_ORIF_EXPR
:
9633 case TRUTH_AND_EXPR
:
9635 case TRUTH_XOR_EXPR
:
9636 case TRUTH_NOT_EXPR
:
9656 *offset
= bitsize_int (0L, 0L);
9657 *size
= TYPE_SIZE (TREE_TYPE (t
));
9662 tree array
= TREE_OPERAND (t
, 0);
9663 tree element
= TREE_OPERAND (t
, 1);
9666 if ((array
== NULL_TREE
)
9667 || (element
== NULL_TREE
))
9669 *decl
= error_mark_node
;
9673 ffecom_tree_canonize_ref_ (decl
, &init_offset
, size
,
9675 if ((*decl
== NULL_TREE
)
9676 || (*decl
== error_mark_node
))
9679 *offset
= size_binop (MULT_EXPR
,
9680 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array
))),
9681 size_binop (MINUS_EXPR
,
9685 (TREE_TYPE (array
)))));
9687 *offset
= size_binop (PLUS_EXPR
,
9691 *size
= TYPE_SIZE (TREE_TYPE (t
));
9697 /* Most of this code is to handle references to COMMON. And so
9698 far that is useful only for calling library functions, since
9699 external (user) functions might reference common areas. But
9700 even calling an external function, it's worthwhile to decode
9701 COMMON references because if not storing into COMMON, we don't
9702 want COMMON-based arguments to gratuitously force use of a
9705 *size
= TYPE_SIZE (TREE_TYPE (t
));
9707 ffecom_tree_canonize_ptr_ (decl
, offset
,
9708 TREE_OPERAND (t
, 0));
9715 case NON_LVALUE_EXPR
:
9718 case COND_EXPR
: /* More cases than we can handle. */
9720 case REFERENCE_EXPR
:
9721 case PREDECREMENT_EXPR
:
9722 case PREINCREMENT_EXPR
:
9723 case POSTDECREMENT_EXPR
:
9724 case POSTINCREMENT_EXPR
:
9727 *decl
= error_mark_node
;
9733 /* Do divide operation appropriate to type of operands. */
9735 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9737 ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
9738 tree dest_tree
, ffebld dest
, bool *dest_used
)
9740 if ((left
== error_mark_node
)
9741 || (right
== error_mark_node
))
9742 return error_mark_node
;
9744 switch (TREE_CODE (tree_type
))
9747 return ffecom_2 (TRUNC_DIV_EXPR
, tree_type
,
9755 if (TREE_TYPE (tree_type
)
9756 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9757 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9759 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9761 left
= ffecom_1 (ADDR_EXPR
,
9762 build_pointer_type (TREE_TYPE (left
)),
9764 left
= build_tree_list (NULL_TREE
, left
);
9765 right
= ffecom_1 (ADDR_EXPR
,
9766 build_pointer_type (TREE_TYPE (right
)),
9768 right
= build_tree_list (NULL_TREE
, right
);
9769 TREE_CHAIN (left
) = right
;
9771 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9772 ffecom_gfrt_kindtype (ix
),
9773 ffe_is_f2c_library (),
9776 dest_tree
, dest
, dest_used
,
9785 if (TREE_TYPE (TYPE_FIELDS (tree_type
))
9786 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9787 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9789 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9791 left
= ffecom_1 (ADDR_EXPR
,
9792 build_pointer_type (TREE_TYPE (left
)),
9794 left
= build_tree_list (NULL_TREE
, left
);
9795 right
= ffecom_1 (ADDR_EXPR
,
9796 build_pointer_type (TREE_TYPE (right
)),
9798 right
= build_tree_list (NULL_TREE
, right
);
9799 TREE_CHAIN (left
) = right
;
9801 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9802 ffecom_gfrt_kindtype (ix
),
9803 ffe_is_f2c_library (),
9806 dest_tree
, dest
, dest_used
,
9812 return ffecom_2 (RDIV_EXPR
, tree_type
,
9819 /* ffecom_type_localvar_ -- Build type info for non-dummy variable
9822 ffesymbol s; // the variable's symbol
9823 ffeinfoBasictype bt; // it's basictype
9824 ffeinfoKindtype kt; // it's kindtype
9826 type = ffecom_type_localvar_(s,bt,kt);
9828 Handles static arrays, CHARACTER type, etc. */
9830 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9832 ffecom_type_localvar_ (ffesymbol s
, ffeinfoBasictype bt
,
9841 type
= ffecom_tree_type
[bt
][kt
];
9842 if (bt
== FFEINFO_basictypeCHARACTER
)
9844 hight
= build_int_2 (ffesymbol_size (s
), 0);
9845 TREE_TYPE (hight
) = ffecom_f2c_ftnlen_type_node
;
9850 build_range_type (ffecom_f2c_ftnlen_type_node
,
9851 ffecom_f2c_ftnlen_one_node
,
9853 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9856 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
9858 if (type
== error_mark_node
)
9861 dim
= ffebld_head (dl
);
9862 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
9864 if (ffebld_left (dim
) == NULL
)
9865 lowt
= integer_one_node
;
9867 lowt
= ffecom_expr (ffebld_left (dim
));
9869 if (TREE_CODE (lowt
) != INTEGER_CST
)
9870 lowt
= variable_size (lowt
);
9872 assert (ffebld_right (dim
) != NULL
);
9873 hight
= ffecom_expr (ffebld_right (dim
));
9875 if (TREE_CODE (hight
) != INTEGER_CST
)
9876 hight
= variable_size (hight
);
9878 type
= build_array_type (type
,
9879 build_range_type (ffecom_integer_type_node
,
9881 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9888 /* Build Namelist type. */
9890 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9892 ffecom_type_namelist_ ()
9894 static tree type
= NULL_TREE
;
9896 if (type
== NULL_TREE
)
9898 static tree namefield
, varsfield
, nvarsfield
;
9901 vardesctype
= ffecom_type_vardesc_ ();
9903 push_obstacks_nochange ();
9904 end_temporary_allocation ();
9906 type
= make_node (RECORD_TYPE
);
9908 vardesctype
= build_pointer_type (build_pointer_type (vardesctype
));
9910 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9912 varsfield
= ffecom_decl_field (type
, namefield
, "vars", vardesctype
);
9913 nvarsfield
= ffecom_decl_field (type
, varsfield
, "nvars",
9916 TYPE_FIELDS (type
) = namefield
;
9919 resume_temporary_allocation ();
9928 /* Make a copy of a type, assuming caller has switched to the permanent
9929 obstacks and that the type is for an aggregate (array) initializer. */
9931 #if FFECOM_targetCURRENT == FFECOM_targetGCC && 0 /* Not used now. */
9933 ffecom_type_permanent_copy_ (tree t
)
9938 assert (TREE_TYPE (t
) != NULL_TREE
);
9940 domain
= TYPE_DOMAIN (t
);
9942 assert (TREE_CODE (t
) == ARRAY_TYPE
);
9943 assert (TREE_PERMANENT (TREE_TYPE (t
)));
9944 assert (TREE_PERMANENT (TREE_TYPE (domain
)));
9945 assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain
)));
9947 max
= TYPE_MAX_VALUE (domain
);
9948 if (!TREE_PERMANENT (max
))
9950 assert (TREE_CODE (max
) == INTEGER_CST
);
9952 max
= build_int_2 (TREE_INT_CST_LOW (max
), TREE_INT_CST_HIGH (max
));
9953 TREE_TYPE (max
) = TREE_TYPE (TYPE_MIN_VALUE (domain
));
9956 return build_array_type (TREE_TYPE (t
),
9957 build_range_type (TREE_TYPE (domain
),
9958 TYPE_MIN_VALUE (domain
),
9963 /* Build Vardesc type. */
9965 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9967 ffecom_type_vardesc_ ()
9969 static tree type
= NULL_TREE
;
9970 static tree namefield
, addrfield
, dimsfield
, typefield
;
9972 if (type
== NULL_TREE
)
9974 push_obstacks_nochange ();
9975 end_temporary_allocation ();
9977 type
= make_node (RECORD_TYPE
);
9979 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9981 addrfield
= ffecom_decl_field (type
, namefield
, "addr",
9983 dimsfield
= ffecom_decl_field (type
, addrfield
, "dims",
9984 ffecom_f2c_ptr_to_ftnlen_type_node
);
9985 typefield
= ffecom_decl_field (type
, dimsfield
, "type",
9988 TYPE_FIELDS (type
) = namefield
;
9991 resume_temporary_allocation ();
10000 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10002 ffecom_vardesc_ (ffebld expr
)
10006 assert (ffebld_op (expr
) == FFEBLD_opSYMTER
);
10007 s
= ffebld_symter (expr
);
10009 if (ffesymbol_hook (s
).vardesc_tree
== NULL_TREE
)
10012 tree vardesctype
= ffecom_type_vardesc_ ();
10021 static int mynumber
= 0;
10023 yes
= suspend_momentary ();
10025 var
= build_decl (VAR_DECL
,
10026 ffecom_get_invented_identifier ("__g77_vardesc_%d",
10029 TREE_STATIC (var
) = 1;
10030 DECL_INITIAL (var
) = error_mark_node
;
10032 var
= start_decl (var
, FALSE
);
10034 /* Process inits. */
10036 nameinit
= ffecom_build_f2c_string_ ((i
= strlen (ffesymbol_text (s
)))
10038 ffesymbol_text (s
));
10039 TREE_TYPE (nameinit
)
10040 = build_type_variant
10043 build_range_type (integer_type_node
,
10045 build_int_2 (i
, 0))),
10047 TREE_CONSTANT (nameinit
) = 1;
10048 TREE_STATIC (nameinit
) = 1;
10049 nameinit
= ffecom_1 (ADDR_EXPR
,
10050 build_pointer_type (TREE_TYPE (nameinit
)),
10053 addrinit
= ffecom_arg_ptr_to_expr (expr
, &typeinit
);
10055 dimsinit
= ffecom_vardesc_dims_ (s
);
10057 if (typeinit
== NULL_TREE
)
10059 ffeinfoBasictype bt
= ffesymbol_basictype (s
);
10060 ffeinfoKindtype kt
= ffesymbol_kindtype (s
);
10061 int tc
= ffecom_f2c_typecode (bt
, kt
);
10064 typeinit
= build_int_2 (tc
, (tc
< 0) ? -1 : 0);
10067 typeinit
= ffecom_1 (NEGATE_EXPR
, TREE_TYPE (typeinit
), typeinit
);
10069 varinits
= build_tree_list ((field
= TYPE_FIELDS (vardesctype
)),
10071 TREE_CHAIN (varinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
10073 TREE_CHAIN (TREE_CHAIN (varinits
))
10074 = build_tree_list ((field
= TREE_CHAIN (field
)), dimsinit
);
10075 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits
)))
10076 = build_tree_list ((field
= TREE_CHAIN (field
)), typeinit
);
10078 varinits
= build (CONSTRUCTOR
, vardesctype
, NULL_TREE
, varinits
);
10079 TREE_CONSTANT (varinits
) = 1;
10080 TREE_STATIC (varinits
) = 1;
10082 finish_decl (var
, varinits
, FALSE
);
10084 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (vardesctype
), var
);
10086 resume_momentary (yes
);
10088 ffesymbol_hook (s
).vardesc_tree
= var
;
10091 return ffesymbol_hook (s
).vardesc_tree
;
10095 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10097 ffecom_vardesc_array_ (ffesymbol s
)
10101 tree item
= NULL_TREE
;
10105 static int mynumber
= 0;
10107 for (i
= 0, list
= NULL_TREE
, b
= ffesymbol_namelist (s
);
10109 b
= ffebld_trail (b
), ++i
)
10113 t
= ffecom_vardesc_ (ffebld_head (b
));
10115 if (list
== NULL_TREE
)
10116 list
= item
= build_tree_list (NULL_TREE
, t
);
10119 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
10120 item
= TREE_CHAIN (item
);
10124 yes
= suspend_momentary ();
10126 item
= build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
10127 build_range_type (integer_type_node
,
10129 build_int_2 (i
, 0)));
10130 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
10131 TREE_CONSTANT (list
) = 1;
10132 TREE_STATIC (list
) = 1;
10134 var
= ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL
,
10136 var
= build_decl (VAR_DECL
, var
, item
);
10137 TREE_STATIC (var
) = 1;
10138 DECL_INITIAL (var
) = error_mark_node
;
10139 var
= start_decl (var
, FALSE
);
10140 finish_decl (var
, list
, FALSE
);
10142 resume_momentary (yes
);
10148 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10150 ffecom_vardesc_dims_ (ffesymbol s
)
10152 if (ffesymbol_dims (s
) == NULL
)
10153 return convert (ffecom_f2c_ptr_to_ftnlen_type_node
,
10154 integer_zero_node
);
10161 tree item
= NULL_TREE
;
10166 tree baseoff
= NULL_TREE
;
10167 static int mynumber
= 0;
10169 numdim
= build_int_2 ((int) ffesymbol_rank (s
), 0);
10170 TREE_TYPE (numdim
) = ffecom_f2c_ftnlen_type_node
;
10172 numelem
= ffecom_expr (ffesymbol_arraysize (s
));
10173 TREE_TYPE (numelem
) = ffecom_f2c_ftnlen_type_node
;
10176 backlist
= NULL_TREE
;
10177 for (b
= ffesymbol_dims (s
), e
= ffesymbol_extents (s
);
10179 b
= ffebld_trail (b
), e
= ffebld_trail (e
))
10185 if (ffebld_trail (b
) == NULL
)
10189 t
= convert (ffecom_f2c_ftnlen_type_node
,
10190 ffecom_expr (ffebld_head (e
)));
10192 if (list
== NULL_TREE
)
10193 list
= item
= build_tree_list (NULL_TREE
, t
);
10196 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
10197 item
= TREE_CHAIN (item
);
10201 if (ffebld_left (ffebld_head (b
)) == NULL
)
10202 low
= ffecom_integer_one_node
;
10204 low
= ffecom_expr (ffebld_left (ffebld_head (b
)));
10205 low
= convert (ffecom_f2c_ftnlen_type_node
, low
);
10207 back
= build_tree_list (low
, t
);
10208 TREE_CHAIN (back
) = backlist
;
10212 for (item
= backlist
; item
!= NULL_TREE
; item
= TREE_CHAIN (item
))
10214 if (TREE_VALUE (item
) == NULL_TREE
)
10215 baseoff
= TREE_PURPOSE (item
);
10217 baseoff
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
10218 TREE_PURPOSE (item
),
10219 ffecom_2 (MULT_EXPR
,
10220 ffecom_f2c_ftnlen_type_node
,
10225 /* backlist now dead, along with all TREE_PURPOSEs on it. */
10227 baseoff
= build_tree_list (NULL_TREE
, baseoff
);
10228 TREE_CHAIN (baseoff
) = list
;
10230 numelem
= build_tree_list (NULL_TREE
, numelem
);
10231 TREE_CHAIN (numelem
) = baseoff
;
10233 numdim
= build_tree_list (NULL_TREE
, numdim
);
10234 TREE_CHAIN (numdim
) = numelem
;
10236 yes
= suspend_momentary ();
10238 item
= build_array_type (ffecom_f2c_ftnlen_type_node
,
10239 build_range_type (integer_type_node
,
10242 ((int) ffesymbol_rank (s
)
10244 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, numdim
);
10245 TREE_CONSTANT (list
) = 1;
10246 TREE_STATIC (list
) = 1;
10248 var
= ffecom_get_invented_identifier ("__g77_dims_%d", NULL
,
10250 var
= build_decl (VAR_DECL
, var
, item
);
10251 TREE_STATIC (var
) = 1;
10252 DECL_INITIAL (var
) = error_mark_node
;
10253 var
= start_decl (var
, FALSE
);
10254 finish_decl (var
, list
, FALSE
);
10256 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (item
), var
);
10258 resume_momentary (yes
);
10265 /* Essentially does a "fold (build1 (code, type, node))" while checking
10266 for certain housekeeping things.
10268 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
10269 ffecom_1_fn instead. */
10271 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10273 ffecom_1 (enum tree_code code
, tree type
, tree node
)
10277 if ((node
== error_mark_node
)
10278 || (type
== error_mark_node
))
10279 return error_mark_node
;
10281 if (code
== ADDR_EXPR
)
10283 if (!mark_addressable (node
))
10284 assert ("can't mark_addressable this node!" == NULL
);
10287 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
10291 case REALPART_EXPR
:
10292 item
= build (COMPONENT_REF
, type
, node
, TYPE_FIELDS (TREE_TYPE (node
)));
10295 case IMAGPART_EXPR
:
10296 item
= build (COMPONENT_REF
, type
, node
, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node
))));
10301 if (TREE_CODE (type
) != RECORD_TYPE
)
10303 item
= build1 (code
, type
, node
);
10306 node
= ffecom_stabilize_aggregate_ (node
);
10307 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10309 ffecom_2 (COMPLEX_EXPR
, type
,
10310 ffecom_1 (NEGATE_EXPR
, realtype
,
10311 ffecom_1 (REALPART_EXPR
, realtype
,
10313 ffecom_1 (NEGATE_EXPR
, realtype
,
10314 ffecom_1 (IMAGPART_EXPR
, realtype
,
10319 item
= build1 (code
, type
, node
);
10323 if (TREE_SIDE_EFFECTS (node
))
10324 TREE_SIDE_EFFECTS (item
) = 1;
10325 if ((code
== ADDR_EXPR
) && staticp (node
))
10326 TREE_CONSTANT (item
) = 1;
10327 return fold (item
);
10331 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
10332 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
10333 does not set TREE_ADDRESSABLE (because calling an inline
10334 function does not mean the function needs to be separately
10337 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10339 ffecom_1_fn (tree node
)
10344 if (node
== error_mark_node
)
10345 return error_mark_node
;
10347 type
= build_type_variant (TREE_TYPE (node
),
10348 TREE_READONLY (node
),
10349 TREE_THIS_VOLATILE (node
));
10350 item
= build1 (ADDR_EXPR
,
10351 build_pointer_type (type
), node
);
10352 if (TREE_SIDE_EFFECTS (node
))
10353 TREE_SIDE_EFFECTS (item
) = 1;
10354 if (staticp (node
))
10355 TREE_CONSTANT (item
) = 1;
10356 return fold (item
);
10360 /* Essentially does a "fold (build (code, type, node1, node2))" while
10361 checking for certain housekeeping things. */
10363 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10365 ffecom_2 (enum tree_code code
, tree type
, tree node1
,
10370 if ((node1
== error_mark_node
)
10371 || (node2
== error_mark_node
)
10372 || (type
== error_mark_node
))
10373 return error_mark_node
;
10375 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
10377 tree a
, b
, c
, d
, realtype
;
10380 assert ("no CONJ_EXPR support yet" == NULL
);
10381 return error_mark_node
;
10384 item
= build_tree_list (TYPE_FIELDS (type
), node1
);
10385 TREE_CHAIN (item
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), node2
);
10386 item
= build (CONSTRUCTOR
, type
, NULL_TREE
, item
);
10390 if (TREE_CODE (type
) != RECORD_TYPE
)
10392 item
= build (code
, type
, node1
, node2
);
10395 node1
= ffecom_stabilize_aggregate_ (node1
);
10396 node2
= ffecom_stabilize_aggregate_ (node2
);
10397 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10399 ffecom_2 (COMPLEX_EXPR
, type
,
10400 ffecom_2 (PLUS_EXPR
, realtype
,
10401 ffecom_1 (REALPART_EXPR
, realtype
,
10403 ffecom_1 (REALPART_EXPR
, realtype
,
10405 ffecom_2 (PLUS_EXPR
, realtype
,
10406 ffecom_1 (IMAGPART_EXPR
, realtype
,
10408 ffecom_1 (IMAGPART_EXPR
, realtype
,
10413 if (TREE_CODE (type
) != RECORD_TYPE
)
10415 item
= build (code
, type
, node1
, node2
);
10418 node1
= ffecom_stabilize_aggregate_ (node1
);
10419 node2
= ffecom_stabilize_aggregate_ (node2
);
10420 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10422 ffecom_2 (COMPLEX_EXPR
, type
,
10423 ffecom_2 (MINUS_EXPR
, realtype
,
10424 ffecom_1 (REALPART_EXPR
, realtype
,
10426 ffecom_1 (REALPART_EXPR
, realtype
,
10428 ffecom_2 (MINUS_EXPR
, realtype
,
10429 ffecom_1 (IMAGPART_EXPR
, realtype
,
10431 ffecom_1 (IMAGPART_EXPR
, realtype
,
10436 if (TREE_CODE (type
) != RECORD_TYPE
)
10438 item
= build (code
, type
, node1
, node2
);
10441 node1
= ffecom_stabilize_aggregate_ (node1
);
10442 node2
= ffecom_stabilize_aggregate_ (node2
);
10443 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10444 a
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
10446 b
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
10448 c
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
10450 d
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
10453 ffecom_2 (COMPLEX_EXPR
, type
,
10454 ffecom_2 (MINUS_EXPR
, realtype
,
10455 ffecom_2 (MULT_EXPR
, realtype
,
10458 ffecom_2 (MULT_EXPR
, realtype
,
10461 ffecom_2 (PLUS_EXPR
, realtype
,
10462 ffecom_2 (MULT_EXPR
, realtype
,
10465 ffecom_2 (MULT_EXPR
, realtype
,
10471 if ((TREE_CODE (node1
) != RECORD_TYPE
)
10472 && (TREE_CODE (node2
) != RECORD_TYPE
))
10474 item
= build (code
, type
, node1
, node2
);
10477 assert (TREE_CODE (node1
) == RECORD_TYPE
);
10478 assert (TREE_CODE (node2
) == RECORD_TYPE
);
10479 node1
= ffecom_stabilize_aggregate_ (node1
);
10480 node2
= ffecom_stabilize_aggregate_ (node2
);
10481 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10483 ffecom_2 (TRUTH_ANDIF_EXPR
, type
,
10484 ffecom_2 (code
, type
,
10485 ffecom_1 (REALPART_EXPR
, realtype
,
10487 ffecom_1 (REALPART_EXPR
, realtype
,
10489 ffecom_2 (code
, type
,
10490 ffecom_1 (IMAGPART_EXPR
, realtype
,
10492 ffecom_1 (IMAGPART_EXPR
, realtype
,
10497 if ((TREE_CODE (node1
) != RECORD_TYPE
)
10498 && (TREE_CODE (node2
) != RECORD_TYPE
))
10500 item
= build (code
, type
, node1
, node2
);
10503 assert (TREE_CODE (node1
) == RECORD_TYPE
);
10504 assert (TREE_CODE (node2
) == RECORD_TYPE
);
10505 node1
= ffecom_stabilize_aggregate_ (node1
);
10506 node2
= ffecom_stabilize_aggregate_ (node2
);
10507 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
10509 ffecom_2 (TRUTH_ORIF_EXPR
, type
,
10510 ffecom_2 (code
, type
,
10511 ffecom_1 (REALPART_EXPR
, realtype
,
10513 ffecom_1 (REALPART_EXPR
, realtype
,
10515 ffecom_2 (code
, type
,
10516 ffecom_1 (IMAGPART_EXPR
, realtype
,
10518 ffecom_1 (IMAGPART_EXPR
, realtype
,
10523 item
= build (code
, type
, node1
, node2
);
10527 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
))
10528 TREE_SIDE_EFFECTS (item
) = 1;
10529 return fold (item
);
10533 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
10535 ffesymbol s; // the ENTRY point itself
10536 if (ffecom_2pass_advise_entrypoint(s))
10537 // the ENTRY point has been accepted
10539 Does whatever compiler needs to do when it learns about the entrypoint,
10540 like determine the return type of the master function, count the
10541 number of entrypoints, etc. Returns FALSE if the return type is
10542 not compatible with the return type(s) of other entrypoint(s).
10544 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
10545 later (after _finish_progunit) be called with the same entrypoint(s)
10546 as passed to this fn for which TRUE was returned.
10549 Return FALSE if the return type conflicts with previous entrypoints. */
10551 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10553 ffecom_2pass_advise_entrypoint (ffesymbol entry
)
10555 ffebld list
; /* opITEM. */
10556 ffebld mlist
; /* opITEM. */
10557 ffebld plist
; /* opITEM. */
10558 ffebld arg
; /* ffebld_head(opITEM). */
10559 ffebld item
; /* opITEM. */
10560 ffesymbol s
; /* ffebld_symter(arg). */
10561 ffeinfoBasictype bt
= ffesymbol_basictype (entry
);
10562 ffeinfoKindtype kt
= ffesymbol_kindtype (entry
);
10563 ffetargetCharacterSize size
= ffesymbol_size (entry
);
10566 if (ffecom_num_entrypoints_
== 0)
10567 { /* First entrypoint, make list of main
10568 arglist's dummies. */
10569 assert (ffecom_primary_entry_
!= NULL
);
10571 ffecom_master_bt_
= ffesymbol_basictype (ffecom_primary_entry_
);
10572 ffecom_master_kt_
= ffesymbol_kindtype (ffecom_primary_entry_
);
10573 ffecom_master_size_
= ffesymbol_size (ffecom_primary_entry_
);
10575 for (plist
= NULL
, list
= ffesymbol_dummyargs (ffecom_primary_entry_
);
10577 list
= ffebld_trail (list
))
10579 arg
= ffebld_head (list
);
10580 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
10581 continue; /* Alternate return or some such thing. */
10582 item
= ffebld_new_item (arg
, NULL
);
10584 ffecom_master_arglist_
= item
;
10586 ffebld_set_trail (plist
, item
);
10591 /* If necessary, scan entry arglist for alternate returns. Do this scan
10592 apparently redundantly (it's done below to UNIONize the arglists) so
10593 that we don't complain about RETURN 1 if an offending ENTRY is the only
10594 one with an alternate return. */
10596 if (!ffecom_is_altreturning_
)
10598 for (list
= ffesymbol_dummyargs (entry
);
10600 list
= ffebld_trail (list
))
10602 arg
= ffebld_head (list
);
10603 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
10605 ffecom_is_altreturning_
= TRUE
;
10611 /* Now check type compatibility. */
10613 switch (ffecom_master_bt_
)
10615 case FFEINFO_basictypeNONE
:
10616 ok
= (bt
!= FFEINFO_basictypeCHARACTER
);
10619 case FFEINFO_basictypeCHARACTER
:
10621 = (bt
== FFEINFO_basictypeCHARACTER
)
10622 && (kt
== ffecom_master_kt_
)
10623 && (size
== ffecom_master_size_
);
10626 case FFEINFO_basictypeANY
:
10627 return FALSE
; /* Just don't bother. */
10630 if (bt
== FFEINFO_basictypeCHARACTER
)
10636 if ((bt
!= ffecom_master_bt_
) || (kt
!= ffecom_master_kt_
))
10638 ffecom_master_bt_
= FFEINFO_basictypeNONE
;
10639 ffecom_master_kt_
= FFEINFO_kindtypeNONE
;
10646 ffebad_start (FFEBAD_ENTRY_CONFLICTS
);
10647 ffest_ffebad_here_current_stmt (0);
10649 return FALSE
; /* Can't handle entrypoint. */
10652 /* Entrypoint type compatible with previous types. */
10654 ++ffecom_num_entrypoints_
;
10656 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10658 for (list
= ffesymbol_dummyargs (entry
);
10660 list
= ffebld_trail (list
))
10662 arg
= ffebld_head (list
);
10663 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
10664 continue; /* Alternate return or some such thing. */
10665 s
= ffebld_symter (arg
);
10666 for (plist
= NULL
, mlist
= ffecom_master_arglist_
;
10668 plist
= mlist
, mlist
= ffebld_trail (mlist
))
10669 { /* plist points to previous item for easy
10670 appending of arg. */
10671 if (ffebld_symter (ffebld_head (mlist
)) == s
)
10672 break; /* Already have this arg in the master list. */
10675 continue; /* Already have this arg in the master list. */
10677 /* Append this arg to the master list. */
10679 item
= ffebld_new_item (arg
, NULL
);
10681 ffecom_master_arglist_
= item
;
10683 ffebld_set_trail (plist
, item
);
10690 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10692 ffesymbol s; // the ENTRY point itself
10693 ffecom_2pass_do_entrypoint(s);
10695 Does whatever compiler needs to do to make the entrypoint actually
10696 happen. Must be called for each entrypoint after
10697 ffecom_finish_progunit is called. */
10699 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10701 ffecom_2pass_do_entrypoint (ffesymbol entry
)
10703 static int mfn_num
= 0;
10704 static int ent_num
;
10706 if (mfn_num
!= ffecom_num_fns_
)
10707 { /* First entrypoint for this program unit. */
10709 mfn_num
= ffecom_num_fns_
;
10710 ffecom_do_entry_ (ffecom_primary_entry_
, 0);
10715 --ffecom_num_entrypoints_
;
10717 ffecom_do_entry_ (entry
, ent_num
);
10722 /* Essentially does a "fold (build (code, type, node1, node2))" while
10723 checking for certain housekeeping things. Always sets
10724 TREE_SIDE_EFFECTS. */
10726 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10728 ffecom_2s (enum tree_code code
, tree type
, tree node1
,
10733 if ((node1
== error_mark_node
)
10734 || (node2
== error_mark_node
)
10735 || (type
== error_mark_node
))
10736 return error_mark_node
;
10738 item
= build (code
, type
, node1
, node2
);
10739 TREE_SIDE_EFFECTS (item
) = 1;
10740 return fold (item
);
10744 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10745 checking for certain housekeeping things. */
10747 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10749 ffecom_3 (enum tree_code code
, tree type
, tree node1
,
10750 tree node2
, tree node3
)
10754 if ((node1
== error_mark_node
)
10755 || (node2
== error_mark_node
)
10756 || (node3
== error_mark_node
)
10757 || (type
== error_mark_node
))
10758 return error_mark_node
;
10760 item
= build (code
, type
, node1
, node2
, node3
);
10761 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
)
10762 || (node3
!= NULL_TREE
&& TREE_SIDE_EFFECTS (node3
)))
10763 TREE_SIDE_EFFECTS (item
) = 1;
10764 return fold (item
);
10768 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10769 checking for certain housekeeping things. Always sets
10770 TREE_SIDE_EFFECTS. */
10772 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10774 ffecom_3s (enum tree_code code
, tree type
, tree node1
,
10775 tree node2
, tree node3
)
10779 if ((node1
== error_mark_node
)
10780 || (node2
== error_mark_node
)
10781 || (node3
== error_mark_node
)
10782 || (type
== error_mark_node
))
10783 return error_mark_node
;
10785 item
= build (code
, type
, node1
, node2
, node3
);
10786 TREE_SIDE_EFFECTS (item
) = 1;
10787 return fold (item
);
10791 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10793 See use by ffecom_list_expr.
10795 If expression is NULL, returns an integer zero tree. If it is not
10796 a CHARACTER expression, returns whatever ffecom_expr
10797 returns and sets the length return value to NULL_TREE. Otherwise
10798 generates code to evaluate the character expression, returns the proper
10799 pointer to the result, but does NOT set the length return value to a tree
10800 that specifies the length of the result. (In other words, the length
10801 variable is always set to NULL_TREE, because a length is never passed.)
10804 Don't set returned length, since nobody needs it (yet; someday if
10805 we allow CHARACTER*(*) dummies to statement functions, we'll need
10808 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10810 ffecom_arg_expr (ffebld expr
, tree
*length
)
10814 *length
= NULL_TREE
;
10817 return integer_zero_node
;
10819 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10820 return ffecom_expr (expr
);
10822 return ffecom_arg_ptr_to_expr (expr
, &ign
);
10826 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10828 See use by ffecom_list_ptr_to_expr.
10830 If expression is NULL, returns an integer zero tree. If it is not
10831 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10832 returns and sets the length return value to NULL_TREE. Otherwise
10833 generates code to evaluate the character expression, returns the proper
10834 pointer to the result, AND sets the length return value to a tree that
10835 specifies the length of the result.
10837 If the length argument is NULL, this is a slightly special
10838 case of building a FORMAT expression, that is, an expression that
10839 will be used at run time without regard to length. For the current
10840 implementation, which uses the libf2c library, this means it is nice
10841 to append a null byte to the end of the expression, where feasible,
10842 to make sure any diagnostic about the FORMAT string terminates at
10845 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10846 length argument. This might even be seen as a feature, if a null
10847 byte can always be appended. */
10849 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10851 ffecom_arg_ptr_to_expr (ffebld expr
, tree
*length
)
10855 ffecomConcatList_ catlist
;
10857 if (length
!= NULL
)
10858 *length
= NULL_TREE
;
10861 return integer_zero_node
;
10863 switch (ffebld_op (expr
))
10865 case FFEBLD_opPERCENT_VAL
:
10866 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10867 return ffecom_expr (ffebld_left (expr
));
10872 temp_exp
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &temp_length
);
10873 return ffecom_1 (INDIRECT_REF
, TREE_TYPE (TREE_TYPE (temp_exp
)),
10877 case FFEBLD_opPERCENT_REF
:
10878 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10879 return ffecom_ptr_to_expr (ffebld_left (expr
));
10880 if (length
!= NULL
)
10882 ign_length
= NULL_TREE
;
10883 length
= &ign_length
;
10885 expr
= ffebld_left (expr
);
10888 case FFEBLD_opPERCENT_DESCR
:
10889 switch (ffeinfo_basictype (ffebld_info (expr
)))
10891 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10892 case FFEINFO_basictypeHOLLERITH
:
10894 case FFEINFO_basictypeCHARACTER
:
10895 break; /* Passed by descriptor anyway. */
10898 item
= ffecom_ptr_to_expr (expr
);
10899 if (item
!= error_mark_node
)
10900 *length
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (item
)));
10909 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10910 if ((ffeinfo_basictype (ffebld_info (expr
)) == FFEINFO_basictypeHOLLERITH
)
10911 && (length
!= NULL
))
10912 { /* Pass Hollerith by descriptor. */
10913 ffetargetHollerith h
;
10915 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
10916 h
= ffebld_cu_val_hollerith (ffebld_constant_union
10917 (ffebld_conter (expr
)));
10919 = build_int_2 (h
.length
, 0);
10920 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10924 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10925 return ffecom_ptr_to_expr (expr
);
10927 assert (ffeinfo_kindtype (ffebld_info (expr
))
10928 == FFEINFO_kindtypeCHARACTER1
);
10930 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
10931 switch (ffecom_concat_list_count_ (catlist
))
10933 case 0: /* Shouldn't happen, but in case it does... */
10934 if (length
!= NULL
)
10936 *length
= ffecom_f2c_ftnlen_zero_node
;
10937 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10939 ffecom_concat_list_kill_ (catlist
);
10940 return null_pointer_node
;
10942 case 1: /* The (fairly) easy case. */
10943 if (length
== NULL
)
10944 ffecom_char_args_with_null_ (&item
, &ign_length
,
10945 ffecom_concat_list_expr_ (catlist
, 0));
10947 ffecom_char_args_ (&item
, length
,
10948 ffecom_concat_list_expr_ (catlist
, 0));
10949 ffecom_concat_list_kill_ (catlist
);
10950 assert (item
!= NULL_TREE
);
10953 default: /* Must actually concatenate things. */
10958 int count
= ffecom_concat_list_count_ (catlist
);
10969 ffetargetCharacterSize sz
;
10973 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
10974 FFETARGET_charactersizeNONE
, count
, TRUE
);
10977 = ffecom_push_tempvar (ffecom_f2c_address_type_node
,
10978 FFETARGET_charactersizeNONE
, count
, TRUE
);
10980 known_length
= ffecom_f2c_ftnlen_zero_node
;
10982 for (i
= 0; i
< count
; ++i
)
10985 && (length
== NULL
))
10986 ffecom_char_args_with_null_ (&citem
, &clength
,
10987 ffecom_concat_list_expr_ (catlist
, i
));
10989 ffecom_char_args_ (&citem
, &clength
,
10990 ffecom_concat_list_expr_ (catlist
, i
));
10991 if ((citem
== error_mark_node
)
10992 || (clength
== error_mark_node
))
10994 ffecom_concat_list_kill_ (catlist
);
10995 *length
= error_mark_node
;
10996 return error_mark_node
;
11000 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
11001 ffecom_modify (void_type_node
,
11002 ffecom_2 (ARRAY_REF
,
11003 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
11005 build_int_2 (i
, 0)),
11008 clength
= ffecom_save_tree (clength
);
11009 if (length
!= NULL
)
11011 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
11015 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
11016 ffecom_modify (void_type_node
,
11017 ffecom_2 (ARRAY_REF
,
11018 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
11020 build_int_2 (i
, 0)),
11025 sz
= ffecom_concat_list_maxlen_ (catlist
);
11026 assert (sz
!= FFETARGET_charactersizeNONE
);
11028 temporary
= ffecom_push_tempvar (char_type_node
,
11030 temporary
= ffecom_1 (ADDR_EXPR
,
11031 build_pointer_type (TREE_TYPE (temporary
)),
11034 item
= build_tree_list (NULL_TREE
, temporary
);
11036 = build_tree_list (NULL_TREE
,
11037 ffecom_1 (ADDR_EXPR
,
11038 build_pointer_type (TREE_TYPE (items
)),
11040 TREE_CHAIN (TREE_CHAIN (item
))
11041 = build_tree_list (NULL_TREE
,
11042 ffecom_1 (ADDR_EXPR
,
11043 build_pointer_type (TREE_TYPE (lengths
)),
11045 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
11048 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
11049 convert (ffecom_f2c_ftnlen_type_node
,
11050 build_int_2 (count
, 0))));
11051 num
= build_int_2 (sz
, 0);
11052 TREE_TYPE (num
) = ffecom_f2c_ftnlen_type_node
;
11053 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
))))
11054 = build_tree_list (NULL_TREE
, num
);
11056 item
= ffecom_call_gfrt (FFECOM_gfrtCAT
, item
);
11057 TREE_SIDE_EFFECTS (item
) = 1;
11058 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (temporary
),
11062 if (length
!= NULL
)
11063 *length
= known_length
;
11066 ffecom_concat_list_kill_ (catlist
);
11067 assert (item
!= NULL_TREE
);
11072 /* ffecom_call_gfrt -- Generate call to run-time function
11075 expr = ffecom_call_gfrt(FFECOM_gfrtSTOPNIL,NULL_TREE);
11077 The first arg is the GNU Fortran Run-Time function index, the second
11078 arg is the list of arguments to pass to it. Returned is the expression
11079 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
11080 result (which may be void). */
11082 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11084 ffecom_call_gfrt (ffecomGfrt ix
, tree args
)
11086 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
11087 ffecom_gfrt_kindtype (ix
),
11088 ffe_is_f2c_library () && ffecom_gfrt_complex_
[ix
],
11089 NULL_TREE
, args
, NULL_TREE
, NULL
,
11090 NULL
, NULL_TREE
, TRUE
);
11094 /* ffecom_constantunion -- Transform constant-union to tree
11096 ffebldConstantUnion cu; // the constant to transform
11097 ffeinfoBasictype bt; // its basic type
11098 ffeinfoKindtype kt; // its kind type
11099 tree tree_type; // ffecom_tree_type[bt][kt]
11100 ffecom_constantunion(&cu,bt,kt,tree_type); */
11102 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11104 ffecom_constantunion (ffebldConstantUnion
*cu
, ffeinfoBasictype bt
,
11105 ffeinfoKindtype kt
, tree tree_type
)
11111 case FFEINFO_basictypeINTEGER
:
11117 #if FFETARGET_okINTEGER1
11118 case FFEINFO_kindtypeINTEGER1
:
11119 val
= ffebld_cu_val_integer1 (*cu
);
11123 #if FFETARGET_okINTEGER2
11124 case FFEINFO_kindtypeINTEGER2
:
11125 val
= ffebld_cu_val_integer2 (*cu
);
11129 #if FFETARGET_okINTEGER3
11130 case FFEINFO_kindtypeINTEGER3
:
11131 val
= ffebld_cu_val_integer3 (*cu
);
11135 #if FFETARGET_okINTEGER4
11136 case FFEINFO_kindtypeINTEGER4
:
11137 val
= ffebld_cu_val_integer4 (*cu
);
11142 assert ("bad INTEGER constant kind type" == NULL
);
11143 /* Fall through. */
11144 case FFEINFO_kindtypeANY
:
11145 return error_mark_node
;
11147 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
11148 TREE_TYPE (item
) = tree_type
;
11152 case FFEINFO_basictypeLOGICAL
:
11158 #if FFETARGET_okLOGICAL1
11159 case FFEINFO_kindtypeLOGICAL1
:
11160 val
= ffebld_cu_val_logical1 (*cu
);
11164 #if FFETARGET_okLOGICAL2
11165 case FFEINFO_kindtypeLOGICAL2
:
11166 val
= ffebld_cu_val_logical2 (*cu
);
11170 #if FFETARGET_okLOGICAL3
11171 case FFEINFO_kindtypeLOGICAL3
:
11172 val
= ffebld_cu_val_logical3 (*cu
);
11176 #if FFETARGET_okLOGICAL4
11177 case FFEINFO_kindtypeLOGICAL4
:
11178 val
= ffebld_cu_val_logical4 (*cu
);
11183 assert ("bad LOGICAL constant kind type" == NULL
);
11184 /* Fall through. */
11185 case FFEINFO_kindtypeANY
:
11186 return error_mark_node
;
11188 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
11189 TREE_TYPE (item
) = tree_type
;
11193 case FFEINFO_basictypeREAL
:
11195 REAL_VALUE_TYPE val
;
11199 #if FFETARGET_okREAL1
11200 case FFEINFO_kindtypeREAL1
:
11201 val
= ffetarget_value_real1 (ffebld_cu_val_real1 (*cu
));
11205 #if FFETARGET_okREAL2
11206 case FFEINFO_kindtypeREAL2
:
11207 val
= ffetarget_value_real2 (ffebld_cu_val_real2 (*cu
));
11211 #if FFETARGET_okREAL3
11212 case FFEINFO_kindtypeREAL3
:
11213 val
= ffetarget_value_real3 (ffebld_cu_val_real3 (*cu
));
11217 #if FFETARGET_okREAL4
11218 case FFEINFO_kindtypeREAL4
:
11219 val
= ffetarget_value_real4 (ffebld_cu_val_real4 (*cu
));
11224 assert ("bad REAL constant kind type" == NULL
);
11225 /* Fall through. */
11226 case FFEINFO_kindtypeANY
:
11227 return error_mark_node
;
11229 item
= build_real (tree_type
, val
);
11233 case FFEINFO_basictypeCOMPLEX
:
11235 REAL_VALUE_TYPE real
;
11236 REAL_VALUE_TYPE imag
;
11237 tree el_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
11241 #if FFETARGET_okCOMPLEX1
11242 case FFEINFO_kindtypeREAL1
:
11243 real
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).real
);
11244 imag
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).imaginary
);
11248 #if FFETARGET_okCOMPLEX2
11249 case FFEINFO_kindtypeREAL2
:
11250 real
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).real
);
11251 imag
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).imaginary
);
11255 #if FFETARGET_okCOMPLEX3
11256 case FFEINFO_kindtypeREAL3
:
11257 real
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).real
);
11258 imag
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).imaginary
);
11262 #if FFETARGET_okCOMPLEX4
11263 case FFEINFO_kindtypeREAL4
:
11264 real
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).real
);
11265 imag
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).imaginary
);
11270 assert ("bad REAL constant kind type" == NULL
);
11271 /* Fall through. */
11272 case FFEINFO_kindtypeANY
:
11273 return error_mark_node
;
11275 item
= ffecom_build_complex_constant_ (tree_type
,
11276 build_real (el_type
, real
),
11277 build_real (el_type
, imag
));
11281 case FFEINFO_basictypeCHARACTER
:
11282 { /* Happens only in DATA and similar contexts. */
11283 ffetargetCharacter1 val
;
11287 #if FFETARGET_okCHARACTER1
11288 case FFEINFO_kindtypeLOGICAL1
:
11289 val
= ffebld_cu_val_character1 (*cu
);
11294 assert ("bad CHARACTER constant kind type" == NULL
);
11295 /* Fall through. */
11296 case FFEINFO_kindtypeANY
:
11297 return error_mark_node
;
11299 item
= build_string (ffetarget_length_character1 (val
),
11300 ffetarget_text_character1 (val
));
11302 = build_type_variant (build_array_type (char_type_node
,
11304 (integer_type_node
,
11307 (ffetarget_length_character1
11313 case FFEINFO_basictypeHOLLERITH
:
11315 ffetargetHollerith h
;
11317 h
= ffebld_cu_val_hollerith (*cu
);
11319 /* If not at least as wide as default INTEGER, widen it. */
11320 if (h
.length
>= FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
)
11321 item
= build_string (h
.length
, h
.text
);
11324 char str
[FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
];
11326 memcpy (str
, h
.text
, h
.length
);
11327 memset (&str
[h
.length
], ' ',
11328 FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
11330 item
= build_string (FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
,
11334 = build_type_variant (build_array_type (char_type_node
,
11336 (integer_type_node
,
11344 case FFEINFO_basictypeTYPELESS
:
11346 ffetargetInteger1 ival
;
11347 ffetargetTypeless tless
;
11350 tless
= ffebld_cu_val_typeless (*cu
);
11351 error
= ffetarget_convert_integer1_typeless (&ival
, tless
);
11352 assert (error
== FFEBAD
);
11354 item
= build_int_2 ((int) ival
, 0);
11359 assert ("not yet on constant type" == NULL
);
11360 /* Fall through. */
11361 case FFEINFO_basictypeANY
:
11362 return error_mark_node
;
11365 TREE_CONSTANT (item
) = 1;
11372 /* Handy way to make a field in a struct/union. */
11374 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11376 ffecom_decl_field (tree context
, tree prevfield
,
11377 char *name
, tree type
)
11381 field
= build_decl (FIELD_DECL
, get_identifier (name
), type
);
11382 DECL_CONTEXT (field
) = context
;
11383 DECL_FRAME_SIZE (field
) = 0;
11384 if (prevfield
!= NULL_TREE
)
11385 TREE_CHAIN (prevfield
) = field
;
11393 ffecom_close_include (FILE *f
)
11395 #if FFECOM_GCC_INCLUDE
11396 ffecom_close_include_ (f
);
11401 ffecom_decode_include_option (char *spec
)
11403 #if FFECOM_GCC_INCLUDE
11404 return ffecom_decode_include_option_ (spec
);
11410 /* ffecom_end_transition -- Perform end transition on all symbols
11412 ffecom_end_transition();
11414 Calls ffecom_sym_end_transition for each global and local symbol. */
11417 ffecom_end_transition ()
11419 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11423 if (ffe_is_ffedebug ())
11424 fprintf (dmpout
, "; end_stmt_transition\n");
11426 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11427 ffecom_list_blockdata_
= NULL
;
11428 ffecom_list_common_
= NULL
;
11431 ffesymbol_drive (ffecom_sym_end_transition
);
11432 if (ffe_is_ffedebug ())
11434 ffestorag_report ();
11435 ffesymbol_report_all ();
11438 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11439 ffecom_start_progunit_ ();
11441 for (item
= ffecom_list_blockdata_
;
11443 item
= ffebld_trail (item
))
11451 static int number
= 0;
11453 callee
= ffebld_head (item
);
11454 s
= ffebld_symter (callee
);
11455 t
= ffesymbol_hook (s
).decl_tree
;
11456 if (t
== NULL_TREE
)
11458 s
= ffecom_sym_transform_ (s
);
11459 t
= ffesymbol_hook (s
).decl_tree
;
11462 yes
= suspend_momentary ();
11464 dt
= build_pointer_type (TREE_TYPE (t
));
11466 var
= build_decl (VAR_DECL
,
11467 ffecom_get_invented_identifier ("__g77_forceload_%d",
11470 DECL_EXTERNAL (var
) = 0;
11471 TREE_STATIC (var
) = 1;
11472 TREE_PUBLIC (var
) = 0;
11473 DECL_INITIAL (var
) = error_mark_node
;
11474 TREE_USED (var
) = 1;
11476 var
= start_decl (var
, FALSE
);
11478 t
= ffecom_1 (ADDR_EXPR
, dt
, t
);
11480 finish_decl (var
, t
, FALSE
);
11482 resume_momentary (yes
);
11485 /* This handles any COMMON areas that weren't referenced but have, for
11486 example, important initial data. */
11488 for (item
= ffecom_list_common_
;
11490 item
= ffebld_trail (item
))
11491 ffecom_transform_common_ (ffebld_symter (ffebld_head (item
)));
11493 ffecom_list_common_
= NULL
;
11497 /* ffecom_exec_transition -- Perform exec transition on all symbols
11499 ffecom_exec_transition();
11501 Calls ffecom_sym_exec_transition for each global and local symbol.
11502 Make sure error updating not inhibited. */
11505 ffecom_exec_transition ()
11509 if (ffe_is_ffedebug ())
11510 fprintf (dmpout
, "; exec_stmt_transition\n");
11512 inhibited
= ffebad_inhibit ();
11513 ffebad_set_inhibit (FALSE
);
11515 ffesymbol_drive (ffecom_sym_exec_transition
); /* Don't retract! */
11516 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
11517 if (ffe_is_ffedebug ())
11519 ffestorag_report ();
11520 ffesymbol_report_all ();
11524 ffebad_set_inhibit (TRUE
);
11527 /* ffecom_expand_let_stmt -- Compile let (assignment) statement
11531 ffecom_expand_let_stmt(dest,source);
11533 Convert dest and source using ffecom_expr, then join them
11534 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
11536 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11538 ffecom_expand_let_stmt (ffebld dest
, ffebld source
)
11545 if (ffeinfo_basictype (ffebld_info (dest
)) != FFEINFO_basictypeCHARACTER
)
11549 dest_tree
= ffecom_expr_rw (dest
);
11550 if (dest_tree
== error_mark_node
)
11553 if ((TREE_CODE (dest_tree
) != VAR_DECL
)
11554 || TREE_ADDRESSABLE (dest_tree
))
11555 source_tree
= ffecom_expr_ (source
, NULL_TREE
, dest_tree
, dest
,
11556 &dest_used
, FALSE
);
11559 source_tree
= ffecom_expr (source
);
11562 if (source_tree
== error_mark_node
)
11566 expr_tree
= source_tree
;
11568 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
11572 expand_expr_stmt (expr_tree
);
11576 ffecom_push_calltemps ();
11577 ffecom_char_args_ (&dest_tree
, &dest_length
, dest
);
11578 ffecom_let_char_ (dest_tree
, dest_length
, ffebld_size_known (dest
),
11580 ffecom_pop_calltemps ();
11584 /* ffecom_expr -- Transform expr into gcc tree
11587 ffebld expr; // FFE expression.
11588 tree = ffecom_expr(expr);
11590 Recursive descent on expr while making corresponding tree nodes and
11591 attaching type info and such. */
11593 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11595 ffecom_expr (ffebld expr
)
11597 return ffecom_expr_ (expr
, NULL_TREE
, NULL_TREE
, NULL
, NULL
,
11602 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
11604 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11606 ffecom_expr_assign (ffebld expr
)
11608 return ffecom_expr_ (expr
, NULL_TREE
, NULL_TREE
, NULL
, NULL
,
11613 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
11615 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11617 ffecom_expr_assign_w (ffebld expr
)
11619 return ffecom_expr_ (expr
, NULL_TREE
, NULL_TREE
, NULL
, NULL
,
11624 /* Transform expr for use as into read/write tree and stabilize the
11625 reference. Not for use on CHARACTER expressions.
11627 Recursive descent on expr while making corresponding tree nodes and
11628 attaching type info and such. */
11630 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11632 ffecom_expr_rw (ffebld expr
)
11634 assert (expr
!= NULL
);
11636 return stabilize_reference (ffecom_expr (expr
));
11640 /* Do global stuff. */
11642 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11644 ffecom_finish_compile ()
11646 assert (ffecom_outer_function_decl_
== NULL_TREE
);
11647 assert (current_function_decl
== NULL_TREE
);
11649 ffeglobal_drive (ffecom_finish_global_
);
11653 /* Public entry point for front end to access finish_decl. */
11655 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11657 ffecom_finish_decl (tree decl
, tree init
, bool is_top_level
)
11659 assert (!is_top_level
);
11660 finish_decl (decl
, init
, FALSE
);
11664 /* Finish a program unit. */
11666 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11668 ffecom_finish_progunit ()
11670 ffecom_end_compstmt_ ();
11672 ffecom_previous_function_decl_
= current_function_decl
;
11673 ffecom_which_entrypoint_decl_
= NULL_TREE
;
11675 finish_function (0);
11679 /* Wrapper for get_identifier. pattern is like "...%s...", text is
11680 inserted into final name in place of "%s", or if text is NULL,
11681 pattern is like "...%d..." and text form of number is inserted
11682 in place of "%d". */
11684 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11686 ffecom_get_invented_identifier (char *pattern
, char *text
, int number
)
11694 lenlen
= strlen (pattern
) + 20;
11696 lenlen
= strlen (pattern
) + strlen (text
) - 1;
11697 if (lenlen
> ARRAY_SIZE (space
))
11698 nam
= malloc_new_ks (malloc_pool_image (), pattern
, lenlen
);
11702 sprintf (&nam
[0], pattern
, number
);
11704 sprintf (&nam
[0], pattern
, text
);
11705 decl
= get_identifier (nam
);
11706 if (lenlen
> ARRAY_SIZE (space
))
11707 malloc_kill_ks (malloc_pool_image (), nam
, lenlen
);
11709 IDENTIFIER_INVENTED (decl
) = 1;
11715 ffecom_gfrt_basictype (ffecomGfrt gfrt
)
11717 assert (gfrt
< FFECOM_gfrt
);
11719 switch (ffecom_gfrt_type_
[gfrt
])
11721 case FFECOM_rttypeVOID_
:
11722 case FFECOM_rttypeVOIDSTAR_
:
11723 return FFEINFO_basictypeNONE
;
11725 case FFECOM_rttypeFTNINT_
:
11726 return FFEINFO_basictypeINTEGER
;
11728 case FFECOM_rttypeINTEGER_
:
11729 return FFEINFO_basictypeINTEGER
;
11731 case FFECOM_rttypeLONGINT_
:
11732 return FFEINFO_basictypeINTEGER
;
11734 case FFECOM_rttypeLOGICAL_
:
11735 return FFEINFO_basictypeLOGICAL
;
11737 case FFECOM_rttypeREAL_F2C_
:
11738 case FFECOM_rttypeREAL_GNU_
:
11739 return FFEINFO_basictypeREAL
;
11741 case FFECOM_rttypeCOMPLEX_F2C_
:
11742 case FFECOM_rttypeCOMPLEX_GNU_
:
11743 return FFEINFO_basictypeCOMPLEX
;
11745 case FFECOM_rttypeDOUBLE_
:
11746 case FFECOM_rttypeDOUBLEREAL_
:
11747 return FFEINFO_basictypeREAL
;
11749 case FFECOM_rttypeDBLCMPLX_F2C_
:
11750 case FFECOM_rttypeDBLCMPLX_GNU_
:
11751 return FFEINFO_basictypeCOMPLEX
;
11753 case FFECOM_rttypeCHARACTER_
:
11754 return FFEINFO_basictypeCHARACTER
;
11757 return FFEINFO_basictypeANY
;
11762 ffecom_gfrt_kindtype (ffecomGfrt gfrt
)
11764 assert (gfrt
< FFECOM_gfrt
);
11766 switch (ffecom_gfrt_type_
[gfrt
])
11768 case FFECOM_rttypeVOID_
:
11769 case FFECOM_rttypeVOIDSTAR_
:
11770 return FFEINFO_kindtypeNONE
;
11772 case FFECOM_rttypeFTNINT_
:
11773 return FFEINFO_kindtypeINTEGER1
;
11775 case FFECOM_rttypeINTEGER_
:
11776 return FFEINFO_kindtypeINTEGER1
;
11778 case FFECOM_rttypeLONGINT_
:
11779 return FFEINFO_kindtypeINTEGER4
;
11781 case FFECOM_rttypeLOGICAL_
:
11782 return FFEINFO_kindtypeLOGICAL1
;
11784 case FFECOM_rttypeREAL_F2C_
:
11785 case FFECOM_rttypeREAL_GNU_
:
11786 return FFEINFO_kindtypeREAL1
;
11788 case FFECOM_rttypeCOMPLEX_F2C_
:
11789 case FFECOM_rttypeCOMPLEX_GNU_
:
11790 return FFEINFO_kindtypeREAL1
;
11792 case FFECOM_rttypeDOUBLE_
:
11793 case FFECOM_rttypeDOUBLEREAL_
:
11794 return FFEINFO_kindtypeREAL2
;
11796 case FFECOM_rttypeDBLCMPLX_F2C_
:
11797 case FFECOM_rttypeDBLCMPLX_GNU_
:
11798 return FFEINFO_kindtypeREAL2
;
11800 case FFECOM_rttypeCHARACTER_
:
11801 return FFEINFO_kindtypeCHARACTER1
;
11804 return FFEINFO_kindtypeANY
;
11819 /* This block of code comes from the now-obsolete cktyps.c. It checks
11820 whether the compiler environment is buggy in known ways, some of which
11821 would, if not explicitly checked here, result in subtle bugs in g77. */
11823 if (ffe_is_do_internal_checks ())
11825 static char names
[][12]
11827 {"bar", "bletch", "foo", "foobar"};
11832 name
= bsearch ("foo", &names
[0], ARRAY_SIZE (names
), sizeof (names
[0]),
11833 (int (*)()) strcmp
);
11834 if (name
!= (char *) &names
[2])
11836 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11841 ul
= strtoul ("123456789", NULL
, 10);
11842 if (ul
!= 123456789L)
11844 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11845 in proj.h" == NULL
);
11849 fl
= atof ("56.789");
11850 if ((fl
< 56.788) || (fl
> 56.79))
11852 assert ("atof not type double, fix your #include <stdio.h>"
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
));
11902 (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE
))));
11904 error_mark_node
= make_node (ERROR_MARK
);
11905 TREE_TYPE (error_mark_node
) = error_mark_node
;
11907 short_integer_type_node
= make_signed_type (SHORT_TYPE_SIZE
);
11908 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short int"),
11909 short_integer_type_node
));
11911 short_unsigned_type_node
= make_unsigned_type (SHORT_TYPE_SIZE
);
11912 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short unsigned int"),
11913 short_unsigned_type_node
));
11915 /* Define both `signed char' and `unsigned char'. */
11916 signed_char_type_node
= make_signed_type (CHAR_TYPE_SIZE
);
11917 pushdecl (build_decl (TYPE_DECL
, get_identifier ("signed char"),
11918 signed_char_type_node
));
11920 unsigned_char_type_node
= make_unsigned_type (CHAR_TYPE_SIZE
);
11921 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned char"),
11922 unsigned_char_type_node
));
11924 float_type_node
= make_node (REAL_TYPE
);
11925 TYPE_PRECISION (float_type_node
) = FLOAT_TYPE_SIZE
;
11926 layout_type (float_type_node
);
11927 pushdecl (build_decl (TYPE_DECL
, get_identifier ("float"),
11930 double_type_node
= make_node (REAL_TYPE
);
11931 TYPE_PRECISION (double_type_node
) = DOUBLE_TYPE_SIZE
;
11932 layout_type (double_type_node
);
11933 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double"),
11934 double_type_node
));
11936 long_double_type_node
= make_node (REAL_TYPE
);
11937 TYPE_PRECISION (long_double_type_node
) = LONG_DOUBLE_TYPE_SIZE
;
11938 layout_type (long_double_type_node
);
11939 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long double"),
11940 long_double_type_node
));
11942 complex_integer_type_node
= ffecom_make_complex_type_ (integer_type_node
);
11943 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex int"),
11944 complex_integer_type_node
));
11946 complex_float_type_node
= ffecom_make_complex_type_ (float_type_node
);
11947 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex float"),
11948 complex_float_type_node
));
11950 complex_double_type_node
= ffecom_make_complex_type_ (double_type_node
);
11951 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex double"),
11952 complex_double_type_node
));
11954 complex_long_double_type_node
= ffecom_make_complex_type_ (long_double_type_node
);
11955 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex long double"),
11956 complex_long_double_type_node
));
11958 integer_zero_node
= build_int_2 (0, 0);
11959 TREE_TYPE (integer_zero_node
) = integer_type_node
;
11960 integer_one_node
= build_int_2 (1, 0);
11961 TREE_TYPE (integer_one_node
) = integer_type_node
;
11963 size_zero_node
= build_int_2 (0, 0);
11964 TREE_TYPE (size_zero_node
) = sizetype
;
11965 size_one_node
= build_int_2 (1, 0);
11966 TREE_TYPE (size_one_node
) = sizetype
;
11968 void_type_node
= make_node (VOID_TYPE
);
11969 pushdecl (build_decl (TYPE_DECL
, get_identifier ("void"),
11971 layout_type (void_type_node
); /* Uses integer_zero_node */
11972 /* We are not going to have real types in C with less than byte alignment,
11973 so we might as well not have any types that claim to have it. */
11974 TYPE_ALIGN (void_type_node
) = BITS_PER_UNIT
;
11976 null_pointer_node
= build_int_2 (0, 0);
11977 TREE_TYPE (null_pointer_node
) = build_pointer_type (void_type_node
);
11978 layout_type (TREE_TYPE (null_pointer_node
));
11980 string_type_node
= build_pointer_type (char_type_node
);
11982 ffecom_tree_fun_type_void
11983 = build_function_type (void_type_node
, NULL_TREE
);
11985 ffecom_tree_ptr_to_fun_type_void
11986 = build_pointer_type (ffecom_tree_fun_type_void
);
11988 endlink
= tree_cons (NULL_TREE
, void_type_node
, NULL_TREE
);
11991 = build_function_type (float_type_node
,
11992 tree_cons (NULL_TREE
, float_type_node
, endlink
));
11994 double_ftype_double
11995 = build_function_type (double_type_node
,
11996 tree_cons (NULL_TREE
, double_type_node
, endlink
));
11998 ldouble_ftype_ldouble
11999 = build_function_type (long_double_type_node
,
12000 tree_cons (NULL_TREE
, long_double_type_node
,
12003 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
12004 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
12006 ffecom_tree_type
[i
][j
] = NULL_TREE
;
12007 ffecom_tree_fun_type
[i
][j
] = NULL_TREE
;
12008 ffecom_tree_ptr_to_fun_type
[i
][j
] = NULL_TREE
;
12009 ffecom_f2c_typecode_
[i
][j
] = -1;
12012 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
12013 to size FLOAT_TYPE_SIZE because they have to be the same size as
12014 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
12015 Compiler options and other such stuff that change the ways these
12016 types are set should not affect this particular setup. */
12018 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
]
12019 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
12020 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer"),
12022 type
= ffetype_new ();
12024 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER1
,
12026 ffetype_set_ams (type
,
12027 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12028 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12029 ffetype_set_star (base_type
,
12030 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12032 ffetype_set_kind (base_type
, 1, type
);
12033 assert (ffetype_size (type
) == sizeof (ffetargetInteger1
));
12035 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER1
]
12036 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
); /* HOLLERITH means unsigned. */
12037 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned"),
12040 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER2
]
12041 = t
= make_signed_type (CHAR_TYPE_SIZE
);
12042 pushdecl (build_decl (TYPE_DECL
, get_identifier ("byte"),
12044 type
= ffetype_new ();
12045 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER2
,
12047 ffetype_set_ams (type
,
12048 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12049 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12050 ffetype_set_star (base_type
,
12051 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12053 ffetype_set_kind (base_type
, 3, type
);
12054 assert (ffetype_size (type
) == sizeof (ffetargetInteger2
));
12056 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER2
]
12057 = t
= make_unsigned_type (CHAR_TYPE_SIZE
);
12058 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned byte"),
12061 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER3
]
12062 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
12063 pushdecl (build_decl (TYPE_DECL
, get_identifier ("word"),
12065 type
= ffetype_new ();
12066 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER3
,
12068 ffetype_set_ams (type
,
12069 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12070 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12071 ffetype_set_star (base_type
,
12072 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12074 ffetype_set_kind (base_type
, 6, type
);
12075 assert (ffetype_size (type
) == sizeof (ffetargetInteger3
));
12077 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER3
]
12078 = t
= make_unsigned_type (CHAR_TYPE_SIZE
* 2);
12079 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned word"),
12082 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER4
]
12083 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
12084 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer4"),
12086 type
= ffetype_new ();
12087 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER4
,
12089 ffetype_set_ams (type
,
12090 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12091 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12092 ffetype_set_star (base_type
,
12093 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12095 ffetype_set_kind (base_type
, 2, type
);
12096 assert (ffetype_size (type
) == sizeof (ffetargetInteger4
));
12098 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER4
]
12099 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
* 2);
12100 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned4"),
12104 if (ffe_is_do_internal_checks ()
12105 && LONG_TYPE_SIZE
!= FLOAT_TYPE_SIZE
12106 && LONG_TYPE_SIZE
!= CHAR_TYPE_SIZE
12107 && LONG_TYPE_SIZE
!= SHORT_TYPE_SIZE
12108 && LONG_TYPE_SIZE
!= LONG_LONG_TYPE_SIZE
)
12110 fprintf (stderr
, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
12115 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL1
]
12116 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
12117 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical"),
12119 type
= ffetype_new ();
12121 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL1
,
12123 ffetype_set_ams (type
,
12124 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12125 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12126 ffetype_set_star (base_type
,
12127 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12129 ffetype_set_kind (base_type
, 1, type
);
12130 assert (ffetype_size (type
) == sizeof (ffetargetLogical1
));
12132 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL2
]
12133 = t
= make_signed_type (CHAR_TYPE_SIZE
);
12134 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical2"),
12136 type
= ffetype_new ();
12137 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL2
,
12139 ffetype_set_ams (type
,
12140 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12141 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12142 ffetype_set_star (base_type
,
12143 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12145 ffetype_set_kind (base_type
, 3, type
);
12146 assert (ffetype_size (type
) == sizeof (ffetargetLogical2
));
12148 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL3
]
12149 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
12150 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical3"),
12152 type
= ffetype_new ();
12153 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL3
,
12155 ffetype_set_ams (type
,
12156 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12157 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12158 ffetype_set_star (base_type
,
12159 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12161 ffetype_set_kind (base_type
, 6, type
);
12162 assert (ffetype_size (type
) == sizeof (ffetargetLogical3
));
12164 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL4
]
12165 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
12166 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical4"),
12168 type
= ffetype_new ();
12169 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL4
,
12171 ffetype_set_ams (type
,
12172 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12173 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12174 ffetype_set_star (base_type
,
12175 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12177 ffetype_set_kind (base_type
, 2, type
);
12178 assert (ffetype_size (type
) == sizeof (ffetargetLogical4
));
12180 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
12181 = t
= make_node (REAL_TYPE
);
12182 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
;
12183 pushdecl (build_decl (TYPE_DECL
, get_identifier ("real"),
12186 type
= ffetype_new ();
12188 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREAL1
,
12190 ffetype_set_ams (type
,
12191 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12192 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12193 ffetype_set_star (base_type
,
12194 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12196 ffetype_set_kind (base_type
, 1, type
);
12197 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
12198 = FFETARGET_f2cTYREAL
;
12199 assert (ffetype_size (type
) == sizeof (ffetargetReal1
));
12201 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREALDOUBLE
]
12202 = t
= make_node (REAL_TYPE
);
12203 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
* 2; /* Always twice REAL. */
12204 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double precision"),
12207 type
= ffetype_new ();
12208 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREALDOUBLE
,
12210 ffetype_set_ams (type
,
12211 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12212 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12213 ffetype_set_star (base_type
,
12214 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12216 ffetype_set_kind (base_type
, 2, type
);
12217 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]
12218 = FFETARGET_f2cTYDREAL
;
12219 assert (ffetype_size (type
) == sizeof (ffetargetReal2
));
12221 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
12222 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]);
12223 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex"),
12225 type
= ffetype_new ();
12227 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREAL1
,
12229 ffetype_set_ams (type
,
12230 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12231 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12232 ffetype_set_star (base_type
,
12233 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12235 ffetype_set_kind (base_type
, 1, type
);
12236 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
12237 = FFETARGET_f2cTYCOMPLEX
;
12238 assert (ffetype_size (type
) == sizeof (ffetargetComplex1
));
12240 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREALDOUBLE
]
12241 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]);
12242 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double complex"),
12244 type
= ffetype_new ();
12245 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREALDOUBLE
,
12247 ffetype_set_ams (type
,
12248 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12249 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12250 ffetype_set_star (base_type
,
12251 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
12253 ffetype_set_kind (base_type
, 2,
12255 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL2
]
12256 = FFETARGET_f2cTYDCOMPLEX
;
12257 assert (ffetype_size (type
) == sizeof (ffetargetComplex2
));
12259 /* Make function and ptr-to-function types for non-CHARACTER types. */
12261 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
12262 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
12264 if ((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
12266 if (i
== FFEINFO_basictypeINTEGER
)
12268 /* Figure out the smallest INTEGER type that can hold
12269 a pointer on this machine. */
12270 if (GET_MODE_SIZE (TYPE_MODE (t
))
12271 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
12273 if ((ffecom_pointer_kind_
== FFEINFO_kindtypeNONE
)
12274 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type
[i
][ffecom_pointer_kind_
]))
12275 > GET_MODE_SIZE (TYPE_MODE (t
))))
12276 ffecom_pointer_kind_
= j
;
12279 else if (i
== FFEINFO_basictypeCOMPLEX
)
12280 t
= void_type_node
;
12281 /* For f2c compatibility, REAL functions are really
12282 implemented as DOUBLE PRECISION. */
12283 else if ((i
== FFEINFO_basictypeREAL
)
12284 && (j
== FFEINFO_kindtypeREAL1
))
12285 t
= ffecom_tree_type
12286 [FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
];
12288 t
= ffecom_tree_fun_type
[i
][j
] = build_function_type (t
,
12290 ffecom_tree_ptr_to_fun_type
[i
][j
] = build_pointer_type (t
);
12294 /* Set up pointer types. */
12296 if (ffecom_pointer_kind_
== FFEINFO_basictypeNONE
)
12297 fatal ("no INTEGER type can hold a pointer on this configuration");
12298 else if (0 && ffe_is_do_internal_checks ())
12299 fprintf (stderr
, "Pointer type kt=%d\n", ffecom_pointer_kind_
);
12300 type
= ffetype_new ();
12301 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER
,
12302 FFEINFO_kindtypeINTEGERDEFAULT
),
12305 if (ffe_is_ugly_assign ())
12306 ffecom_label_kind_
= ffecom_pointer_kind_
; /* Require ASSIGN etc to this. */
12308 ffecom_label_kind_
= FFEINFO_kindtypeINTEGERDEFAULT
;
12309 if (0 && ffe_is_do_internal_checks ())
12310 fprintf (stderr
, "Label type kt=%d\n", ffecom_label_kind_
);
12312 ffecom_integer_type_node
12313 = ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
];
12314 ffecom_integer_zero_node
= convert (ffecom_integer_type_node
,
12315 integer_zero_node
);
12316 ffecom_integer_one_node
= convert (ffecom_integer_type_node
,
12319 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
12320 Turns out that by TYLONG, runtime/libI77/lio.h really means
12321 "whatever size an ftnint is". For consistency and sanity,
12322 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
12323 all are INTEGER, which we also make out of whatever back-end
12324 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
12325 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
12326 accommodate machines like the Alpha. Note that this suggests
12327 f2c and libf2c are missing a distinction perhaps needed on
12328 some machines between "int" and "long int". -- burley 0.5.5 950215 */
12330 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, FLOAT_TYPE_SIZE
,
12331 FFETARGET_f2cTYLONG
);
12332 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, SHORT_TYPE_SIZE
,
12333 FFETARGET_f2cTYSHORT
);
12334 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, CHAR_TYPE_SIZE
,
12335 FFETARGET_f2cTYINT1
);
12336 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, LONG_LONG_TYPE_SIZE
,
12337 FFETARGET_f2cTYQUAD
);
12338 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, FLOAT_TYPE_SIZE
,
12339 FFETARGET_f2cTYLOGICAL
);
12340 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, SHORT_TYPE_SIZE
,
12341 FFETARGET_f2cTYLOGICAL2
);
12342 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, CHAR_TYPE_SIZE
,
12343 FFETARGET_f2cTYLOGICAL1
);
12344 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, LONG_LONG_TYPE_SIZE
,
12345 FFETARGET_f2cTYQUAD
/* ~~~ */);
12347 /* CHARACTER stuff is all special-cased, so it is not handled in the above
12348 loop. CHARACTER items are built as arrays of unsigned char. */
12350 ffecom_tree_type
[FFEINFO_basictypeCHARACTER
]
12351 [FFEINFO_kindtypeCHARACTER1
] = t
= char_type_node
;
12352 type
= ffetype_new ();
12354 ffeinfo_set_type (FFEINFO_basictypeCHARACTER
,
12355 FFEINFO_kindtypeCHARACTER1
,
12357 ffetype_set_ams (type
,
12358 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
12359 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
12360 ffetype_set_kind (base_type
, 1, type
);
12361 assert (ffetype_size (type
)
12362 == sizeof (((ffetargetCharacter1
) { 0, NULL
}).text
[0]));
12364 ffecom_tree_fun_type
[FFEINFO_basictypeCHARACTER
]
12365 [FFEINFO_kindtypeCHARACTER1
] = ffecom_tree_fun_type_void
;
12366 ffecom_tree_ptr_to_fun_type
[FFEINFO_basictypeCHARACTER
]
12367 [FFEINFO_kindtypeCHARACTER1
]
12368 = ffecom_tree_ptr_to_fun_type_void
;
12369 ffecom_f2c_typecode_
[FFEINFO_basictypeCHARACTER
][FFEINFO_kindtypeCHARACTER1
]
12370 = FFETARGET_f2cTYCHAR
;
12372 ffecom_f2c_typecode_
[FFEINFO_basictypeANY
][FFEINFO_kindtypeANY
]
12375 /* Make multi-return-value type and fields. */
12377 ffecom_multi_type_node_
= make_node (UNION_TYPE
);
12381 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
12382 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
12386 if (ffecom_tree_type
[i
][j
] == NULL_TREE
)
12387 continue; /* Not supported. */
12388 sprintf (&name
[0], "bt_%s_kt_%s",
12389 ffeinfo_basictype_string ((ffeinfoBasictype
) i
),
12390 ffeinfo_kindtype_string ((ffeinfoKindtype
) j
));
12391 ffecom_multi_fields_
[i
][j
] = build_decl (FIELD_DECL
,
12392 get_identifier (name
),
12393 ffecom_tree_type
[i
][j
]);
12394 DECL_CONTEXT (ffecom_multi_fields_
[i
][j
])
12395 = ffecom_multi_type_node_
;
12396 DECL_FRAME_SIZE (ffecom_multi_fields_
[i
][j
]) = 0;
12397 TREE_CHAIN (ffecom_multi_fields_
[i
][j
]) = field
;
12398 field
= ffecom_multi_fields_
[i
][j
];
12401 TYPE_FIELDS (ffecom_multi_type_node_
) = field
;
12402 layout_type (ffecom_multi_type_node_
);
12404 /* Subroutines usually return integer because they might have alternate
12407 ffecom_tree_subr_type
12408 = build_function_type (integer_type_node
, NULL_TREE
);
12409 ffecom_tree_ptr_to_subr_type
12410 = build_pointer_type (ffecom_tree_subr_type
);
12411 ffecom_tree_blockdata_type
12412 = build_function_type (void_type_node
, NULL_TREE
);
12414 builtin_function ("__builtin_sqrtf", float_ftype_float
,
12415 BUILT_IN_FSQRT
, "sqrtf");
12416 builtin_function ("__builtin_fsqrt", double_ftype_double
,
12417 BUILT_IN_FSQRT
, "sqrt");
12418 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble
,
12419 BUILT_IN_FSQRT
, "sqrtl");
12420 builtin_function ("__builtin_sinf", float_ftype_float
,
12421 BUILT_IN_SIN
, "sinf");
12422 builtin_function ("__builtin_sin", double_ftype_double
,
12423 BUILT_IN_SIN
, "sin");
12424 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble
,
12425 BUILT_IN_SIN
, "sinl");
12426 builtin_function ("__builtin_cosf", float_ftype_float
,
12427 BUILT_IN_COS
, "cosf");
12428 builtin_function ("__builtin_cos", double_ftype_double
,
12429 BUILT_IN_COS
, "cos");
12430 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble
,
12431 BUILT_IN_COS
, "cosl");
12434 pedantic_lvalues
= FALSE
;
12437 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node
,
12440 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node
,
12443 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node
,
12446 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node
,
12447 FFECOM_f2cDOUBLEREAL
,
12449 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node
,
12452 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node
,
12453 FFECOM_f2cDOUBLECOMPLEX
,
12455 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node
,
12458 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node
,
12461 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node
,
12464 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node
,
12467 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node
,
12471 ffecom_f2c_ftnlen_zero_node
12472 = convert (ffecom_f2c_ftnlen_type_node
, integer_zero_node
);
12474 ffecom_f2c_ftnlen_one_node
12475 = convert (ffecom_f2c_ftnlen_type_node
, integer_one_node
);
12477 ffecom_f2c_ftnlen_two_node
= build_int_2 (2, 0);
12478 TREE_TYPE (ffecom_f2c_ftnlen_two_node
) = ffecom_integer_type_node
;
12480 ffecom_f2c_ptr_to_ftnlen_type_node
12481 = build_pointer_type (ffecom_f2c_ftnlen_type_node
);
12483 ffecom_f2c_ptr_to_ftnint_type_node
12484 = build_pointer_type (ffecom_f2c_ftnint_type_node
);
12486 ffecom_f2c_ptr_to_integer_type_node
12487 = build_pointer_type (ffecom_f2c_integer_type_node
);
12489 ffecom_f2c_ptr_to_real_type_node
12490 = build_pointer_type (ffecom_f2c_real_type_node
);
12492 ffecom_float_zero_
= build_real (float_type_node
, dconst0
);
12493 ffecom_double_zero_
= build_real (double_type_node
, dconst0
);
12495 REAL_VALUE_TYPE point_5
;
12497 #ifdef REAL_ARITHMETIC
12498 REAL_ARITHMETIC (point_5
, RDIV_EXPR
, dconst1
, dconst2
);
12502 ffecom_float_half_
= build_real (float_type_node
, point_5
);
12503 ffecom_double_half_
= build_real (double_type_node
, point_5
);
12506 /* Do "extern int xargc;". */
12508 ffecom_tree_xargc_
= build_decl (VAR_DECL
,
12509 get_identifier ("xargc"),
12510 integer_type_node
);
12511 DECL_EXTERNAL (ffecom_tree_xargc_
) = 1;
12512 TREE_STATIC (ffecom_tree_xargc_
) = 1;
12513 TREE_PUBLIC (ffecom_tree_xargc_
) = 1;
12514 ffecom_tree_xargc_
= start_decl (ffecom_tree_xargc_
, FALSE
);
12515 finish_decl (ffecom_tree_xargc_
, NULL_TREE
, FALSE
);
12517 #if 0 /* This is being fixed, and seems to be working now. */
12518 if ((FLOAT_TYPE_SIZE
!= 32)
12519 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))) != 32))
12521 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12522 (int) FLOAT_TYPE_SIZE
);
12523 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12524 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))));
12525 warning ("properly unless they all are 32 bits wide.");
12526 warning ("Please keep this in mind before you report bugs. g77 should");
12527 warning ("support non-32-bit machines better as of version 0.6.");
12531 #if 0 /* Code in ste.c that would crash has been commented out. */
12532 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
12533 < TYPE_PRECISION (string_type_node
))
12534 /* I/O will probably crash. */
12535 warning ("configuration: char * holds %d bits, but ftnlen only %d",
12536 TYPE_PRECISION (string_type_node
),
12537 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
));
12540 #if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
12541 if (TYPE_PRECISION (ffecom_integer_type_node
)
12542 < TYPE_PRECISION (string_type_node
))
12543 /* ASSIGN 10 TO I will crash. */
12544 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12545 ASSIGN statement might fail",
12546 TYPE_PRECISION (string_type_node
),
12547 TYPE_PRECISION (ffecom_integer_type_node
));
12552 /* ffecom_init_2 -- Initialize
12554 ffecom_init_2(); */
12556 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12560 assert (ffecom_outer_function_decl_
== NULL_TREE
);
12561 assert (current_function_decl
== NULL_TREE
);
12562 assert (ffecom_which_entrypoint_decl_
== NULL_TREE
);
12564 ffecom_master_arglist_
= NULL
;
12566 ffecom_latest_temp_
= NULL
;
12567 ffecom_primary_entry_
= NULL
;
12568 ffecom_is_altreturning_
= FALSE
;
12569 ffecom_func_result_
= NULL_TREE
;
12570 ffecom_multi_retval_
= NULL_TREE
;
12574 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12577 ffebld expr; // FFE opITEM list.
12578 tree = ffecom_list_expr(expr);
12580 List of actual args is transformed into corresponding gcc backend list. */
12582 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12584 ffecom_list_expr (ffebld expr
)
12587 tree
*plist
= &list
;
12588 tree trail
= NULL_TREE
; /* Append char length args here. */
12589 tree
*ptrail
= &trail
;
12592 while (expr
!= NULL
)
12595 = build_tree_list (NULL_TREE
, ffecom_arg_expr (ffebld_head (expr
),
12597 plist
= &TREE_CHAIN (*plist
);
12598 expr
= ffebld_trail (expr
);
12599 if (length
!= NULL_TREE
)
12601 *ptrail
= build_tree_list (NULL_TREE
, length
);
12602 ptrail
= &TREE_CHAIN (*ptrail
);
12612 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12615 ffebld expr; // FFE opITEM list.
12616 tree = ffecom_list_ptr_to_expr(expr);
12618 List of actual args is transformed into corresponding gcc backend list for
12619 use in calling an external procedure (vs. a statement function). */
12621 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12623 ffecom_list_ptr_to_expr (ffebld expr
)
12626 tree
*plist
= &list
;
12627 tree trail
= NULL_TREE
; /* Append char length args here. */
12628 tree
*ptrail
= &trail
;
12631 while (expr
!= NULL
)
12634 = build_tree_list (NULL_TREE
,
12635 ffecom_arg_ptr_to_expr (ffebld_head (expr
),
12637 plist
= &TREE_CHAIN (*plist
);
12638 expr
= ffebld_trail (expr
);
12639 if (length
!= NULL_TREE
)
12641 *ptrail
= build_tree_list (NULL_TREE
, length
);
12642 ptrail
= &TREE_CHAIN (*ptrail
);
12652 /* Obtain gcc's LABEL_DECL tree for label. */
12654 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12656 ffecom_lookup_label (ffelab label
)
12660 if (ffelab_hook (label
) == NULL_TREE
)
12662 char labelname
[16];
12664 switch (ffelab_type (label
))
12666 case FFELAB_typeLOOPEND
:
12667 case FFELAB_typeNOTLOOP
:
12668 case FFELAB_typeENDIF
:
12669 sprintf (labelname
, "%" ffelabValue_f
"u", ffelab_value (label
));
12670 glabel
= build_decl (LABEL_DECL
, get_identifier (labelname
),
12672 DECL_CONTEXT (glabel
) = current_function_decl
;
12673 DECL_MODE (glabel
) = VOIDmode
;
12676 case FFELAB_typeFORMAT
:
12677 push_obstacks_nochange ();
12678 end_temporary_allocation ();
12680 glabel
= build_decl (VAR_DECL
,
12681 ffecom_get_invented_identifier
12682 ("__g77_format_%d", NULL
,
12683 (int) ffelab_value (label
)),
12684 build_type_variant (build_array_type
12688 TREE_CONSTANT (glabel
) = 1;
12689 TREE_STATIC (glabel
) = 1;
12690 DECL_CONTEXT (glabel
) = 0;
12691 DECL_INITIAL (glabel
) = NULL
;
12692 make_decl_rtl (glabel
, NULL
, 0);
12693 expand_decl (glabel
);
12695 resume_temporary_allocation ();
12700 case FFELAB_typeANY
:
12701 glabel
= error_mark_node
;
12705 assert ("bad label type" == NULL
);
12709 ffelab_set_hook (label
, glabel
);
12713 glabel
= ffelab_hook (label
);
12720 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12721 a single source specification (as in the fourth argument of MVBITS).
12722 If the type is NULL_TREE, the type of lhs is used to make the type of
12723 the MODIFY_EXPR. */
12725 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12727 ffecom_modify (tree newtype
, tree lhs
,
12730 if (lhs
== error_mark_node
|| rhs
== error_mark_node
)
12731 return error_mark_node
;
12733 if (newtype
== NULL_TREE
)
12734 newtype
= TREE_TYPE (lhs
);
12736 if (TREE_SIDE_EFFECTS (lhs
))
12737 lhs
= stabilize_reference (lhs
);
12739 return ffecom_2s (MODIFY_EXPR
, newtype
, lhs
, rhs
);
12744 /* Register source file name. */
12747 ffecom_file (char *name
)
12749 #if FFECOM_GCC_INCLUDE
12750 ffecom_file_ (name
);
12754 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12757 ffecom_notify_init_storage(st);
12759 Gets called when all possible units in an aggregate storage area (a LOCAL
12760 with equivalences or a COMMON) have been initialized. The initialization
12761 info either is in ffestorag_init or, if that is NULL,
12762 ffestorag_accretion:
12764 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12765 even for an array if the array is one element in length!
12767 ffestorag_accretion will contain an opACCTER. It is much like an
12768 opARRTER except it has an ffebit object in it instead of just a size.
12769 The back end can use the info in the ffebit object, if it wants, to
12770 reduce the amount of actual initialization, but in any case it should
12771 kill the ffebit object when done. Also, set accretion to NULL but
12772 init to a non-NULL value.
12774 After performing initialization, DO NOT set init to NULL, because that'll
12775 tell the front end it is ok for more initialization to happen. Instead,
12776 set init to an opANY expression or some such thing that you can use to
12777 tell that you've already initialized the object.
12780 Support two-pass FFE. */
12783 ffecom_notify_init_storage (ffestorag st
)
12785 ffebld init
; /* The initialization expression. */
12786 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12787 ffetargetOffset size
; /* The size of the entity. */
12790 if (ffestorag_init (st
) == NULL
)
12792 init
= ffestorag_accretion (st
);
12793 assert (init
!= NULL
);
12794 ffestorag_set_accretion (st
, NULL
);
12795 ffestorag_set_accretes (st
, 0);
12797 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12798 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12799 size
= ffebld_accter_size (init
);
12800 ffebit_kill (ffebld_accter_bits (init
));
12801 ffebld_set_op (init
, FFEBLD_opARRTER
);
12802 ffebld_set_arrter (init
, ffebld_accter (init
));
12803 ffebld_arrter_set_size (init
, size
);
12807 ffestorag_set_init (st
, init
);
12812 init
= ffestorag_init (st
);
12815 #if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
12816 ffestorag_set_init (st
, ffebld_new_any ());
12818 if (ffebld_op (init
) == FFEBLD_opANY
)
12819 return; /* Oh, we already did this! */
12821 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12825 if (ffestorag_symbol (st
) != NULL
)
12826 s
= ffestorag_symbol (st
);
12828 s
= ffestorag_typesymbol (st
);
12830 fprintf (dmpout
, "= initialize_storage \"%s\" ",
12831 (s
!= NULL
) ? ffesymbol_text (s
) : "(unnamed)");
12832 ffebld_dump (init
);
12833 fputc ('\n', dmpout
);
12837 #endif /* if FFECOM_ONEPASS */
12840 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12843 ffecom_notify_init_symbol(s);
12845 Gets called when all possible units in a symbol (not placed in COMMON
12846 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12847 have been initialized. The initialization info either is in
12848 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12850 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12851 even for an array if the array is one element in length!
12853 ffesymbol_accretion will contain an opACCTER. It is much like an
12854 opARRTER except it has an ffebit object in it instead of just a size.
12855 The back end can use the info in the ffebit object, if it wants, to
12856 reduce the amount of actual initialization, but in any case it should
12857 kill the ffebit object when done. Also, set accretion to NULL but
12858 init to a non-NULL value.
12860 After performing initialization, DO NOT set init to NULL, because that'll
12861 tell the front end it is ok for more initialization to happen. Instead,
12862 set init to an opANY expression or some such thing that you can use to
12863 tell that you've already initialized the object.
12866 Support two-pass FFE. */
12869 ffecom_notify_init_symbol (ffesymbol s
)
12871 ffebld init
; /* The initialization expression. */
12872 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12873 ffetargetOffset size
; /* The size of the entity. */
12876 if (ffesymbol_storage (s
) == NULL
)
12877 return; /* Do nothing until COMMON/EQUIVALENCE
12878 possibilities checked. */
12880 if ((ffesymbol_init (s
) == NULL
)
12881 && ((init
= ffesymbol_accretion (s
)) != NULL
))
12883 ffesymbol_set_accretion (s
, NULL
);
12884 ffesymbol_set_accretes (s
, 0);
12886 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12887 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12888 size
= ffebld_accter_size (init
);
12889 ffebit_kill (ffebld_accter_bits (init
));
12890 ffebld_set_op (init
, FFEBLD_opARRTER
);
12891 ffebld_set_arrter (init
, ffebld_accter (init
));
12892 ffebld_arrter_set_size (init
, size
);
12896 ffesymbol_set_init (s
, init
);
12901 init
= ffesymbol_init (s
);
12905 ffesymbol_set_init (s
, ffebld_new_any ());
12907 if (ffebld_op (init
) == FFEBLD_opANY
)
12908 return; /* Oh, we already did this! */
12910 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12911 fprintf (dmpout
, "= initialize_symbol \"%s\" ", ffesymbol_text (s
));
12912 ffebld_dump (init
);
12913 fputc ('\n', dmpout
);
12916 #endif /* if FFECOM_ONEPASS */
12919 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12922 ffecom_notify_primary_entry(s);
12924 Gets called when implicit or explicit PROGRAM statement seen or when
12925 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12926 global symbol that serves as the entry point. */
12929 ffecom_notify_primary_entry (ffesymbol s
)
12931 ffecom_primary_entry_
= s
;
12932 ffecom_primary_entry_kind_
= ffesymbol_kind (s
);
12934 if ((ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
12935 || (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
))
12936 ffecom_primary_entry_is_proc_
= TRUE
;
12938 ffecom_primary_entry_is_proc_
= FALSE
;
12940 if (!ffe_is_silent ())
12942 if (ffecom_primary_entry_kind_
== FFEINFO_kindPROGRAM
)
12943 fprintf (stderr
, "%s:\n", ffesymbol_text (s
));
12945 fprintf (stderr
, " %s:\n", ffesymbol_text (s
));
12948 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12949 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
12954 for (list
= ffesymbol_dummyargs (s
);
12956 list
= ffebld_trail (list
))
12958 arg
= ffebld_head (list
);
12959 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
12961 ffecom_is_altreturning_
= TRUE
;
12970 ffecom_open_include (char *name
, ffewhereLine l
, ffewhereColumn c
)
12972 #if FFECOM_GCC_INCLUDE
12973 return ffecom_open_include_ (name
, l
, c
);
12975 return fopen (name
, "r");
12979 /* Clean up after making automatically popped call-arg temps.
12981 Call this in pairs with push_calltemps around calls to
12982 ffecom_arg_ptr_to_expr if the latter might use temporaries.
12983 Any temporaries made within the outermost sequence of
12984 push_calltemps and pop_calltemps, that are marked as "auto-pop"
12985 meaning they won't be explicitly popped (freed), are popped
12986 at this point so they can be reused later.
12988 NOTE: when called by ffecom_gen_sfuncdef_, ffecom_pending_calls_
12989 should come in == 1, and all of the in-use auto-pop temps
12990 should have DECL_CONTEXT (temp->t) == current_function_decl.
12991 Moreover, these temps should _never_ be re-used in future
12992 calls to ffecom_push_tempvar -- since current_function_decl will
12993 never be the same again.
12995 SO, it could be a minor win in terms of compile time to just
12996 strip these temps off the list. That is, if the above assumptions
12997 are correct, just remove from the list of temps any temp
12998 that is both in-use and has DECL_CONTEXT (temp->t)
12999 == current_function_decl, when called from ffecom_gen_sfuncdef_. */
13001 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13003 ffecom_pop_calltemps ()
13007 assert (ffecom_pending_calls_
> 0);
13009 if (--ffecom_pending_calls_
== 0)
13010 for (temp
= ffecom_latest_temp_
; temp
!= NULL
; temp
= temp
->next
)
13011 if (temp
->auto_pop
)
13012 temp
->in_use
= FALSE
;
13016 /* Mark latest temp with given tree as no longer in use. */
13018 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13020 ffecom_pop_tempvar (tree t
)
13024 for (temp
= ffecom_latest_temp_
; temp
!= NULL
; temp
= temp
->next
)
13025 if (temp
->in_use
&& (temp
->t
== t
))
13027 assert (!temp
->auto_pop
);
13028 temp
->in_use
= FALSE
;
13032 assert (temp
->t
!= t
);
13034 assert ("couldn't ffecom_pop_tempvar!" != NULL
);
13038 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
13041 ffebld expr; // FFE expression.
13042 tree = ffecom_ptr_to_expr(expr);
13044 Like ffecom_expr, but sticks address-of in front of most things. */
13046 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13048 ffecom_ptr_to_expr (ffebld expr
)
13051 ffeinfoBasictype bt
;
13052 ffeinfoKindtype kt
;
13055 assert (expr
!= NULL
);
13057 switch (ffebld_op (expr
))
13059 case FFEBLD_opSYMTER
:
13060 s
= ffebld_symter (expr
);
13061 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
13065 ix
= ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr
));
13066 assert (ix
!= FFECOM_gfrt
);
13067 if ((item
= ffecom_gfrt_
[ix
]) == NULL_TREE
)
13069 ffecom_make_gfrt_ (ix
);
13070 item
= ffecom_gfrt_
[ix
];
13075 item
= ffesymbol_hook (s
).decl_tree
;
13076 if (item
== NULL_TREE
)
13078 s
= ffecom_sym_transform_ (s
);
13079 item
= ffesymbol_hook (s
).decl_tree
;
13082 assert (item
!= NULL
);
13083 if (item
== error_mark_node
)
13085 if (!ffesymbol_hook (s
).addr
)
13086 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
13090 case FFEBLD_opARRAYREF
:
13092 ffebld dims
[FFECOM_dimensionsMAX
];
13096 item
= ffecom_ptr_to_expr (ffebld_left (expr
));
13098 if (item
== error_mark_node
)
13101 if ((ffeinfo_where (ffebld_info (expr
)) == FFEINFO_whereFLEETING
)
13102 && !mark_addressable (item
))
13103 return error_mark_node
; /* Make sure non-const ref is to
13106 /* Build up ARRAY_REFs in reverse order (since we're column major
13107 here in Fortran land). */
13109 for (i
= 0, expr
= ffebld_right (expr
);
13111 expr
= ffebld_trail (expr
))
13112 dims
[i
++] = ffebld_head (expr
);
13114 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
13116 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
13118 /* The initial subtraction should happen in the original type so
13119 that (possible) negative values are handled appropriately. */
13121 = ffecom_2 (PLUS_EXPR
,
13122 build_pointer_type (TREE_TYPE (array
)),
13124 size_binop (MULT_EXPR
,
13125 size_in_bytes (TREE_TYPE (array
)),
13127 fold (build (MINUS_EXPR
,
13128 TREE_TYPE (TYPE_MIN_VALUE (TYPE_DOMAIN (array
))),
13129 ffecom_expr (dims
[i
]),
13130 TYPE_MIN_VALUE (TYPE_DOMAIN (array
)))))));
13135 case FFEBLD_opCONTER
:
13137 bt
= ffeinfo_basictype (ffebld_info (expr
));
13138 kt
= ffeinfo_kindtype (ffebld_info (expr
));
13140 item
= ffecom_constantunion (&ffebld_constant_union
13141 (ffebld_conter (expr
)), bt
, kt
,
13142 ffecom_tree_type
[bt
][kt
]);
13143 if (item
== error_mark_node
)
13144 return error_mark_node
;
13145 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
13150 return error_mark_node
;
13153 assert (ffecom_pending_calls_
> 0);
13155 bt
= ffeinfo_basictype (ffebld_info (expr
));
13156 kt
= ffeinfo_kindtype (ffebld_info (expr
));
13158 item
= ffecom_expr (expr
);
13159 if (item
== error_mark_node
)
13160 return error_mark_node
;
13162 /* The back end currently optimizes a bit too zealously for us, in that
13163 we fail JCB001 if the following block of code is omitted. It checks
13164 to see if the transformed expression is a symbol or array reference,
13165 and encloses it in a SAVE_EXPR if that is the case. */
13168 if ((TREE_CODE (item
) == VAR_DECL
)
13169 || (TREE_CODE (item
) == PARM_DECL
)
13170 || (TREE_CODE (item
) == RESULT_DECL
)
13171 || (TREE_CODE (item
) == INDIRECT_REF
)
13172 || (TREE_CODE (item
) == ARRAY_REF
)
13173 || (TREE_CODE (item
) == COMPONENT_REF
)
13175 || (TREE_CODE (item
) == OFFSET_REF
)
13177 || (TREE_CODE (item
) == BUFFER_REF
)
13178 || (TREE_CODE (item
) == REALPART_EXPR
)
13179 || (TREE_CODE (item
) == IMAGPART_EXPR
))
13181 item
= ffecom_save_tree (item
);
13184 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
13189 assert ("fall-through error" == NULL
);
13190 return error_mark_node
;
13194 /* Prepare to make call-arg temps.
13196 Call this in pairs with pop_calltemps around calls to
13197 ffecom_arg_ptr_to_expr if the latter might use temporaries. */
13199 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13201 ffecom_push_calltemps ()
13203 ffecom_pending_calls_
++;
13207 /* Obtain a temp var with given data type.
13209 Returns a VAR_DECL tree of a currently (that is, at the current
13210 statement being compiled) not in use and having the given data type,
13211 making a new one if necessary. size is FFETARGET_charactersizeNONE
13212 for a non-CHARACTER type or >= 0 for a CHARACTER type. elements is
13213 -1 for a scalar or > 0 for an array of type. auto_pop is TRUE if
13214 ffecom_pop_tempvar won't be called, meaning temp will be freed
13215 when #pending calls goes to zero. */
13217 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13219 ffecom_push_tempvar (tree type
, ffetargetCharacterSize size
, int elements
,
13225 static int mynumber
;
13227 assert (!auto_pop
|| (ffecom_pending_calls_
> 0));
13229 if (type
== error_mark_node
)
13230 return error_mark_node
;
13232 for (temp
= ffecom_latest_temp_
; temp
!= NULL
; temp
= temp
->next
)
13235 || (temp
->type
!= type
)
13236 || (temp
->size
!= size
)
13237 || (temp
->elements
!= elements
)
13238 || (DECL_CONTEXT (temp
->t
) != current_function_decl
))
13241 temp
->in_use
= TRUE
;
13242 temp
->auto_pop
= auto_pop
;
13246 /* Create a new temp. */
13248 yes
= suspend_momentary ();
13250 if (size
!= FFETARGET_charactersizeNONE
)
13251 type
= build_array_type (type
,
13252 build_range_type (ffecom_f2c_ftnlen_type_node
,
13253 ffecom_f2c_ftnlen_one_node
,
13254 build_int_2 (size
, 0)));
13255 if (elements
!= -1)
13256 type
= build_array_type (type
,
13257 build_range_type (integer_type_node
,
13259 build_int_2 (elements
- 1,
13261 t
= build_decl (VAR_DECL
,
13262 ffecom_get_invented_identifier ("__g77_expr_%d", NULL
,
13265 { /* ~~~~ kludge alert here!!! else temp gets reused outside
13266 a compound-statement sequence.... */
13267 extern tree sequence_rtl_expr
;
13268 tree back_end_bug
= sequence_rtl_expr
;
13270 sequence_rtl_expr
= NULL_TREE
;
13272 t
= start_decl (t
, FALSE
);
13273 finish_decl (t
, NULL_TREE
, FALSE
);
13275 sequence_rtl_expr
= back_end_bug
;
13278 resume_momentary (yes
);
13280 temp
= malloc_new_kp (ffe_pool_program_unit (), "ffecomTemp_",
13283 temp
->next
= ffecom_latest_temp_
;
13287 temp
->elements
= elements
;
13288 temp
->in_use
= TRUE
;
13289 temp
->auto_pop
= auto_pop
;
13291 ffecom_latest_temp_
= temp
;
13297 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13299 tree rtn; // NULL_TREE means use expand_null_return()
13300 ffebld expr; // NULL if no alt return expr to RETURN stmt
13301 rtn = ffecom_return_expr(expr);
13303 Based on the program unit type and other info (like return function
13304 type, return master function type when alternate ENTRY points,
13305 whether subroutine has any alternate RETURN points, etc), returns the
13306 appropriate expression to be returned to the caller, or NULL_TREE
13307 meaning no return value or the caller expects it to be returned somewhere
13308 else (which is handled by other parts of this module). */
13310 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13312 ffecom_return_expr (ffebld expr
)
13316 switch (ffecom_primary_entry_kind_
)
13318 case FFEINFO_kindPROGRAM
:
13319 case FFEINFO_kindBLOCKDATA
:
13323 case FFEINFO_kindSUBROUTINE
:
13324 if (!ffecom_is_altreturning_
)
13325 rtn
= NULL_TREE
; /* No alt returns, never an expr. */
13326 else if (expr
== NULL
)
13327 rtn
= integer_zero_node
;
13329 rtn
= ffecom_expr (expr
);
13332 case FFEINFO_kindFUNCTION
:
13333 if ((ffecom_multi_retval_
!= NULL_TREE
)
13334 || (ffesymbol_basictype (ffecom_primary_entry_
)
13335 == FFEINFO_basictypeCHARACTER
)
13336 || ((ffesymbol_basictype (ffecom_primary_entry_
)
13337 == FFEINFO_basictypeCOMPLEX
)
13338 && (ffecom_num_entrypoints_
== 0)
13339 && ffesymbol_is_f2c (ffecom_primary_entry_
)))
13340 { /* Value is returned by direct assignment
13341 into (implicit) dummy. */
13345 rtn
= ffecom_func_result_
;
13347 /* Spurious error if RETURN happens before first reference! So elide
13348 this code. In particular, for debugging registry, rtn should always
13349 be non-null after all, but TREE_USED won't be set until we encounter
13350 a reference in the code. Perfectly okay (but weird) code that,
13351 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13352 this diagnostic for no reason. Have people use -O -Wuninitialized
13353 and leave it to the back end to find obviously weird cases. */
13355 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13356 situation; if the return value has never been referenced, it won't
13357 have a tree under 2pass mode. */
13358 if ((rtn
== NULL_TREE
)
13359 || !TREE_USED (rtn
))
13361 ffebad_start (FFEBAD_RETURN_VALUE_UNSET
);
13362 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_
),
13363 ffesymbol_where_column (ffecom_primary_entry_
));
13364 ffebad_string (ffesymbol_text (ffesymbol_funcresult
13365 (ffecom_primary_entry_
)));
13372 assert ("bad unit kind" == NULL
);
13373 case FFEINFO_kindANY
:
13374 rtn
= error_mark_node
;
13382 /* Do save_expr only if tree is not error_mark_node. */
13384 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13386 ffecom_save_tree (tree t
)
13388 return save_expr (t
);
13392 /* Public entry point for front end to access start_decl. */
13394 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13396 ffecom_start_decl (tree decl
, bool is_initialized
)
13398 DECL_INITIAL (decl
) = is_initialized
? error_mark_node
: NULL_TREE
;
13399 return start_decl (decl
, FALSE
);
13403 /* ffecom_sym_commit -- Symbol's state being committed to reality
13406 ffecom_sym_commit(s);
13408 Does whatever the backend needs when a symbol is committed after having
13409 been backtrackable for a period of time. */
13411 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13413 ffecom_sym_commit (ffesymbol s UNUSED
)
13415 assert (!ffesymbol_retractable ());
13419 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13421 ffecom_sym_end_transition();
13423 Does backend-specific stuff and also calls ffest_sym_end_transition
13424 to do the necessary FFE stuff.
13426 Backtracking is never enabled when this fn is called, so don't worry
13430 ffecom_sym_end_transition (ffesymbol s
)
13434 assert (!ffesymbol_retractable ());
13436 s
= ffest_sym_end_transition (s
);
13438 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13439 if ((ffesymbol_kind (s
) == FFEINFO_kindBLOCKDATA
)
13440 && (ffesymbol_where (s
) == FFEINFO_whereGLOBAL
))
13442 ffecom_list_blockdata_
13443 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
13444 FFEINTRIN_specNONE
,
13445 FFEINTRIN_impNONE
),
13446 ffecom_list_blockdata_
);
13450 /* This is where we finally notice that a symbol has partial initialization
13451 and finalize it. */
13453 if (ffesymbol_accretion (s
) != NULL
)
13455 assert (ffesymbol_init (s
) == NULL
);
13456 ffecom_notify_init_symbol (s
);
13458 else if (((st
= ffesymbol_storage (s
)) != NULL
)
13459 && ((st
= ffestorag_parent (st
)) != NULL
)
13460 && (ffestorag_accretion (st
) != NULL
))
13462 assert (ffestorag_init (st
) == NULL
);
13463 ffecom_notify_init_storage (st
);
13466 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13467 if ((ffesymbol_kind (s
) == FFEINFO_kindCOMMON
)
13468 && (ffesymbol_where (s
) == FFEINFO_whereLOCAL
)
13469 && (ffesymbol_storage (s
) != NULL
))
13471 ffecom_list_common_
13472 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
13473 FFEINTRIN_specNONE
,
13474 FFEINTRIN_impNONE
),
13475 ffecom_list_common_
);
13482 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13484 ffecom_sym_exec_transition();
13486 Does backend-specific stuff and also calls ffest_sym_exec_transition
13487 to do the necessary FFE stuff.
13489 See the long-winded description in ffecom_sym_learned for info
13490 on handling the situation where backtracking is inhibited. */
13493 ffecom_sym_exec_transition (ffesymbol s
)
13495 s
= ffest_sym_exec_transition (s
);
13500 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13503 s = ffecom_sym_learned(s);
13505 Called when a new symbol is seen after the exec transition or when more
13506 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
13507 it arrives here is that all its latest info is updated already, so its
13508 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13509 field filled in if its gone through here or exec_transition first, and
13512 The backend probably wants to check ffesymbol_retractable() to see if
13513 backtracking is in effect. If so, the FFE's changes to the symbol may
13514 be retracted (undone) or committed (ratified), at which time the
13515 appropriate ffecom_sym_retract or _commit function will be called
13518 If the backend has its own backtracking mechanism, great, use it so that
13519 committal is a simple operation. Though it doesn't make much difference,
13520 I suppose: the reason for tentative symbol evolution in the FFE is to
13521 enable error detection in weird incorrect statements early and to disable
13522 incorrect error detection on a correct statement. The backend is not
13523 likely to introduce any information that'll get involved in these
13524 considerations, so it is probably just fine that the implementation
13525 model for this fn and for _exec_transition is to not do anything
13526 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13527 and instead wait until ffecom_sym_commit is called (which it never
13528 will be as long as we're using ambiguity-detecting statement analysis in
13529 the FFE, which we are initially to shake out the code, but don't depend
13530 on this), otherwise go ahead and do whatever is needed.
13532 In essence, then, when this fn and _exec_transition get called while
13533 backtracking is enabled, a general mechanism would be to flag which (or
13534 both) of these were called (and in what order? neat question as to what
13535 might happen that I'm too lame to think through right now) and then when
13536 _commit is called reproduce the original calling sequence, if any, for
13537 the two fns (at which point backtracking will, of course, be disabled). */
13540 ffecom_sym_learned (ffesymbol s
)
13542 ffestorag_exec_layout (s
);
13547 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13550 ffecom_sym_retract(s);
13552 Does whatever the backend needs when a symbol is retracted after having
13553 been backtrackable for a period of time. */
13555 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13557 ffecom_sym_retract (ffesymbol s UNUSED
)
13559 assert (!ffesymbol_retractable ());
13561 #if 0 /* GCC doesn't commit any backtrackable sins,
13562 so nothing needed here. */
13563 switch (ffesymbol_hook (s
).state
)
13565 case 0: /* nothing happened yet. */
13568 case 1: /* exec transition happened. */
13571 case 2: /* learned happened. */
13574 case 3: /* learned then exec. */
13577 case 4: /* exec then learned. */
13581 assert ("bad hook state" == NULL
);
13588 /* Create temporary gcc label. */
13590 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13592 ffecom_temp_label ()
13595 static int mynumber
= 0;
13597 glabel
= build_decl (LABEL_DECL
,
13598 ffecom_get_invented_identifier ("__g77_label_%d",
13602 DECL_CONTEXT (glabel
) = current_function_decl
;
13603 DECL_MODE (glabel
) = VOIDmode
;
13609 /* Return an expression that is usable as an arg in a conditional context
13610 (IF, DO WHILE, .NOT., and so on).
13612 Use the one provided for the back end as of >2.6.0. */
13614 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13616 ffecom_truth_value (tree expr
)
13618 return truthvalue_conversion (expr
);
13622 /* Return the inversion of a truth value (the inversion of what
13623 ffecom_truth_value builds).
13625 Apparently invert_truthvalue, which is properly in the back end, is
13626 enough for now, so just use it. */
13628 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13630 ffecom_truth_value_invert (tree expr
)
13632 return invert_truthvalue (ffecom_truth_value (expr
));
13636 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13638 If the PARM_DECL already exists, return it, else create it. It's an
13639 integer_type_node argument for the master function that implements a
13640 subroutine or function with more than one entrypoint and is bound at
13641 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13642 first ENTRY statement, and so on). */
13644 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13646 ffecom_which_entrypoint_decl ()
13648 assert (ffecom_which_entrypoint_decl_
!= NULL_TREE
);
13650 return ffecom_which_entrypoint_decl_
;
13655 /* The following sections consists of private and public functions
13656 that have the same names and perform roughly the same functions
13657 as counterparts in the C front end. Changes in the C front end
13658 might affect how things should be done here. Only functions
13659 needed by the back end should be public here; the rest should
13660 be private (static in the C sense). Functions needed by other
13661 g77 front-end modules should be accessed by them via public
13662 ffecom_* names, which should themselves call private versions
13663 in this section so the private versions are easy to recognize
13664 when upgrading to a new gcc and finding interesting changes
13667 Functions named after rule "foo:" in c-parse.y are named
13668 "bison_rule_foo_" so they are easy to find. */
13670 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13673 bison_rule_compstmt_ ()
13675 emit_line_note (input_filename
, lineno
);
13676 expand_end_bindings (getdecls (), 1, 1);
13677 poplevel (1, 1, 0);
13682 bison_rule_pushlevel_ ()
13684 emit_line_note (input_filename
, lineno
);
13686 clear_last_expr ();
13688 expand_start_bindings (0);
13691 /* Return a definition for a builtin function named NAME and whose data type
13692 is TYPE. TYPE should be a function type with argument types.
13693 FUNCTION_CODE tells later passes how to compile calls to this function.
13694 See tree.h for its possible values.
13696 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13697 the name to be called if we can't opencode the function. */
13700 builtin_function (char *name
, tree type
,
13701 enum built_in_function function_code
, char *library_name
)
13703 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
13704 DECL_EXTERNAL (decl
) = 1;
13705 TREE_PUBLIC (decl
) = 1;
13707 DECL_ASSEMBLER_NAME (decl
) = get_identifier (library_name
);
13708 make_decl_rtl (decl
, NULL_PTR
, 1);
13710 if (function_code
!= NOT_BUILT_IN
)
13712 DECL_BUILT_IN (decl
) = 1;
13713 DECL_FUNCTION_CODE (decl
) = function_code
;
13719 /* Handle when a new declaration NEWDECL
13720 has the same name as an old one OLDDECL
13721 in the same binding contour.
13722 Prints an error message if appropriate.
13724 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13725 Otherwise, return 0. */
13728 duplicate_decls (tree newdecl
, tree olddecl
)
13730 int types_match
= 1;
13731 int new_is_definition
= (TREE_CODE (newdecl
) == FUNCTION_DECL
13732 && DECL_INITIAL (newdecl
) != 0);
13733 tree oldtype
= TREE_TYPE (olddecl
);
13734 tree newtype
= TREE_TYPE (newdecl
);
13736 if (olddecl
== newdecl
)
13739 if (TREE_CODE (newtype
) == ERROR_MARK
13740 || TREE_CODE (oldtype
) == ERROR_MARK
)
13743 /* New decl is completely inconsistent with the old one =>
13744 tell caller to replace the old one.
13745 This is always an error except in the case of shadowing a builtin. */
13746 if (TREE_CODE (olddecl
) != TREE_CODE (newdecl
))
13749 /* For real parm decl following a forward decl,
13750 return 1 so old decl will be reused. */
13751 if (types_match
&& TREE_CODE (newdecl
) == PARM_DECL
13752 && TREE_ASM_WRITTEN (olddecl
) && ! TREE_ASM_WRITTEN (newdecl
))
13755 /* The new declaration is the same kind of object as the old one.
13756 The declarations may partially match. Print warnings if they don't
13757 match enough. Ultimately, copy most of the information from the new
13758 decl to the old one, and keep using the old one. */
13760 if (TREE_CODE (olddecl
) == FUNCTION_DECL
13761 && DECL_BUILT_IN (olddecl
))
13763 /* A function declaration for a built-in function. */
13764 if (!TREE_PUBLIC (newdecl
))
13766 else if (!types_match
)
13768 /* Accept the return type of the new declaration if same modes. */
13769 tree oldreturntype
= TREE_TYPE (TREE_TYPE (olddecl
));
13770 tree newreturntype
= TREE_TYPE (TREE_TYPE (newdecl
));
13772 /* Make sure we put the new type in the same obstack as the old ones.
13773 If the old types are not both in the same obstack, use the
13775 if (TYPE_OBSTACK (oldtype
) == TYPE_OBSTACK (newtype
))
13776 push_obstacks (TYPE_OBSTACK (oldtype
), TYPE_OBSTACK (oldtype
));
13779 push_obstacks_nochange ();
13780 end_temporary_allocation ();
13783 if (TYPE_MODE (oldreturntype
) == TYPE_MODE (newreturntype
))
13785 /* Function types may be shared, so we can't just modify
13786 the return type of olddecl's function type. */
13788 = build_function_type (newreturntype
,
13789 TYPE_ARG_TYPES (TREE_TYPE (olddecl
)));
13793 TREE_TYPE (olddecl
) = newtype
;
13801 else if (TREE_CODE (olddecl
) == FUNCTION_DECL
13802 && DECL_SOURCE_LINE (olddecl
) == 0)
13804 /* A function declaration for a predeclared function
13805 that isn't actually built in. */
13806 if (!TREE_PUBLIC (newdecl
))
13808 else if (!types_match
)
13810 /* If the types don't match, preserve volatility indication.
13811 Later on, we will discard everything else about the
13812 default declaration. */
13813 TREE_THIS_VOLATILE (newdecl
) |= TREE_THIS_VOLATILE (olddecl
);
13817 /* Copy all the DECL_... slots specified in the new decl
13818 except for any that we copy here from the old type.
13820 Past this point, we don't change OLDTYPE and NEWTYPE
13821 even if we change the types of NEWDECL and OLDDECL. */
13825 /* Make sure we put the new type in the same obstack as the old ones.
13826 If the old types are not both in the same obstack, use the permanent
13828 if (TYPE_OBSTACK (oldtype
) == TYPE_OBSTACK (newtype
))
13829 push_obstacks (TYPE_OBSTACK (oldtype
), TYPE_OBSTACK (oldtype
));
13832 push_obstacks_nochange ();
13833 end_temporary_allocation ();
13836 /* Merge the data types specified in the two decls. */
13837 if (TREE_CODE (newdecl
) != FUNCTION_DECL
|| !DECL_BUILT_IN (olddecl
))
13838 TREE_TYPE (newdecl
)
13839 = TREE_TYPE (olddecl
)
13840 = TREE_TYPE (newdecl
);
13842 /* Lay the type out, unless already done. */
13843 if (oldtype
!= TREE_TYPE (newdecl
))
13845 if (TREE_TYPE (newdecl
) != error_mark_node
)
13846 layout_type (TREE_TYPE (newdecl
));
13847 if (TREE_CODE (newdecl
) != FUNCTION_DECL
13848 && TREE_CODE (newdecl
) != TYPE_DECL
13849 && TREE_CODE (newdecl
) != CONST_DECL
)
13850 layout_decl (newdecl
, 0);
13854 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13855 DECL_SIZE (newdecl
) = DECL_SIZE (olddecl
);
13856 if (TREE_CODE (olddecl
) != FUNCTION_DECL
)
13857 if (DECL_ALIGN (olddecl
) > DECL_ALIGN (newdecl
))
13858 DECL_ALIGN (newdecl
) = DECL_ALIGN (olddecl
);
13861 /* Keep the old rtl since we can safely use it. */
13862 DECL_RTL (newdecl
) = DECL_RTL (olddecl
);
13864 /* Merge the type qualifiers. */
13865 if (DECL_BUILT_IN_NONANSI (olddecl
) && TREE_THIS_VOLATILE (olddecl
)
13866 && !TREE_THIS_VOLATILE (newdecl
))
13867 TREE_THIS_VOLATILE (olddecl
) = 0;
13868 if (TREE_READONLY (newdecl
))
13869 TREE_READONLY (olddecl
) = 1;
13870 if (TREE_THIS_VOLATILE (newdecl
))
13872 TREE_THIS_VOLATILE (olddecl
) = 1;
13873 if (TREE_CODE (newdecl
) == VAR_DECL
)
13874 make_var_volatile (newdecl
);
13877 /* Keep source location of definition rather than declaration.
13878 Likewise, keep decl at outer scope. */
13879 if ((DECL_INITIAL (newdecl
) == 0 && DECL_INITIAL (olddecl
) != 0)
13880 || (DECL_CONTEXT (newdecl
) != 0 && DECL_CONTEXT (olddecl
) == 0))
13882 DECL_SOURCE_LINE (newdecl
) = DECL_SOURCE_LINE (olddecl
);
13883 DECL_SOURCE_FILE (newdecl
) = DECL_SOURCE_FILE (olddecl
);
13885 if (DECL_CONTEXT (olddecl
) == 0
13886 && TREE_CODE (newdecl
) != FUNCTION_DECL
)
13887 DECL_CONTEXT (newdecl
) = 0;
13890 /* Merge the unused-warning information. */
13891 if (DECL_IN_SYSTEM_HEADER (olddecl
))
13892 DECL_IN_SYSTEM_HEADER (newdecl
) = 1;
13893 else if (DECL_IN_SYSTEM_HEADER (newdecl
))
13894 DECL_IN_SYSTEM_HEADER (olddecl
) = 1;
13896 /* Merge the initialization information. */
13897 if (DECL_INITIAL (newdecl
) == 0)
13898 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13900 /* Merge the section attribute.
13901 We want to issue an error if the sections conflict but that must be
13902 done later in decl_attributes since we are called before attributes
13904 if (DECL_SECTION_NAME (newdecl
) == NULL_TREE
)
13905 DECL_SECTION_NAME (newdecl
) = DECL_SECTION_NAME (olddecl
);
13908 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13910 DECL_STATIC_CONSTRUCTOR(newdecl
) |= DECL_STATIC_CONSTRUCTOR(olddecl
);
13911 DECL_STATIC_DESTRUCTOR (newdecl
) |= DECL_STATIC_DESTRUCTOR (olddecl
);
13917 /* If cannot merge, then use the new type and qualifiers,
13918 and don't preserve the old rtl. */
13921 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13922 TREE_READONLY (olddecl
) = TREE_READONLY (newdecl
);
13923 TREE_THIS_VOLATILE (olddecl
) = TREE_THIS_VOLATILE (newdecl
);
13924 TREE_SIDE_EFFECTS (olddecl
) = TREE_SIDE_EFFECTS (newdecl
);
13927 /* Merge the storage class information. */
13928 /* For functions, static overrides non-static. */
13929 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13931 TREE_PUBLIC (newdecl
) &= TREE_PUBLIC (olddecl
);
13932 /* This is since we don't automatically
13933 copy the attributes of NEWDECL into OLDDECL. */
13934 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13935 /* If this clears `static', clear it in the identifier too. */
13936 if (! TREE_PUBLIC (olddecl
))
13937 TREE_PUBLIC (DECL_NAME (olddecl
)) = 0;
13939 if (DECL_EXTERNAL (newdecl
))
13941 TREE_STATIC (newdecl
) = TREE_STATIC (olddecl
);
13942 DECL_EXTERNAL (newdecl
) = DECL_EXTERNAL (olddecl
);
13943 /* An extern decl does not override previous storage class. */
13944 TREE_PUBLIC (newdecl
) = TREE_PUBLIC (olddecl
);
13948 TREE_STATIC (olddecl
) = TREE_STATIC (newdecl
);
13949 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13952 /* If either decl says `inline', this fn is inline,
13953 unless its definition was passed already. */
13954 if (DECL_INLINE (newdecl
) && DECL_INITIAL (olddecl
) == 0)
13955 DECL_INLINE (olddecl
) = 1;
13956 DECL_INLINE (newdecl
) = DECL_INLINE (olddecl
);
13958 /* Get rid of any built-in function if new arg types don't match it
13959 or if we have a function definition. */
13960 if (TREE_CODE (newdecl
) == FUNCTION_DECL
13961 && DECL_BUILT_IN (olddecl
)
13962 && (!types_match
|| new_is_definition
))
13964 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13965 DECL_BUILT_IN (olddecl
) = 0;
13968 /* If redeclaring a builtin function, and not a definition,
13970 Also preserve various other info from the definition. */
13971 if (TREE_CODE (newdecl
) == FUNCTION_DECL
&& !new_is_definition
)
13973 if (DECL_BUILT_IN (olddecl
))
13975 DECL_BUILT_IN (newdecl
) = 1;
13976 DECL_FUNCTION_CODE (newdecl
) = DECL_FUNCTION_CODE (olddecl
);
13979 DECL_FRAME_SIZE (newdecl
) = DECL_FRAME_SIZE (olddecl
);
13981 DECL_RESULT (newdecl
) = DECL_RESULT (olddecl
);
13982 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13983 DECL_SAVED_INSNS (newdecl
) = DECL_SAVED_INSNS (olddecl
);
13984 DECL_ARGUMENTS (newdecl
) = DECL_ARGUMENTS (olddecl
);
13987 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13988 But preserve olddecl's DECL_UID. */
13990 register unsigned olddecl_uid
= DECL_UID (olddecl
);
13992 memcpy ((char *) olddecl
+ sizeof (struct tree_common
),
13993 (char *) newdecl
+ sizeof (struct tree_common
),
13994 sizeof (struct tree_decl
) - sizeof (struct tree_common
));
13995 DECL_UID (olddecl
) = olddecl_uid
;
14001 /* Finish processing of a declaration;
14002 install its initial value.
14003 If the length of an array type is not known before,
14004 it must be determined now, from the initial value, or it is an error. */
14007 finish_decl (tree decl
, tree init
, bool is_top_level
)
14009 register tree type
= TREE_TYPE (decl
);
14010 int was_incomplete
= (DECL_SIZE (decl
) == 0);
14011 int temporary
= allocation_temporary_p ();
14012 bool at_top_level
= (current_binding_level
== global_binding_level
);
14013 bool top_level
= is_top_level
|| at_top_level
;
14015 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14017 assert (!is_top_level
|| !at_top_level
);
14019 if (TREE_CODE (decl
) == PARM_DECL
)
14020 assert (init
== NULL_TREE
);
14021 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
14022 overlaps DECL_ARG_TYPE. */
14023 else if (init
== NULL_TREE
)
14024 assert (DECL_INITIAL (decl
) == NULL_TREE
);
14026 assert (DECL_INITIAL (decl
) == error_mark_node
);
14028 if (init
!= NULL_TREE
)
14030 if (TREE_CODE (decl
) != TYPE_DECL
)
14031 DECL_INITIAL (decl
) = init
;
14034 /* typedef foo = bar; store the type of bar as the type of foo. */
14035 TREE_TYPE (decl
) = TREE_TYPE (init
);
14036 DECL_INITIAL (decl
) = init
= 0;
14040 /* Pop back to the obstack that is current for this binding level. This is
14041 because MAXINDEX, rtl, etc. to be made below must go in the permanent
14042 obstack. But don't discard the temporary data yet. */
14045 /* Deduce size of array from initialization, if not already known */
14047 if (TREE_CODE (type
) == ARRAY_TYPE
14048 && TYPE_DOMAIN (type
) == 0
14049 && TREE_CODE (decl
) != TYPE_DECL
)
14051 assert (top_level
);
14052 assert (was_incomplete
);
14054 layout_decl (decl
, 0);
14057 if (TREE_CODE (decl
) == VAR_DECL
)
14059 if (DECL_SIZE (decl
) == NULL_TREE
14060 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
14061 layout_decl (decl
, 0);
14063 if (DECL_SIZE (decl
) == NULL_TREE
14064 && (TREE_STATIC (decl
)
14066 /* A static variable with an incomplete type is an error if it is
14067 initialized. Also if it is not file scope. Otherwise, let it
14068 through, but if it is not `extern' then it may cause an error
14070 (DECL_INITIAL (decl
) != 0 || DECL_CONTEXT (decl
) != 0)
14072 /* An automatic variable with an incomplete type is an error. */
14073 !DECL_EXTERNAL (decl
)))
14075 assert ("storage size not known" == NULL
);
14079 if ((DECL_EXTERNAL (decl
) || TREE_STATIC (decl
))
14080 && (DECL_SIZE (decl
) != 0)
14081 && (TREE_CODE (DECL_SIZE (decl
)) != INTEGER_CST
))
14083 assert ("storage size not constant" == NULL
);
14088 /* Output the assembler code and/or RTL code for variables and functions,
14089 unless the type is an undefined structure or union. If not, it will get
14090 done when the type is completed. */
14092 if (TREE_CODE (decl
) == VAR_DECL
|| TREE_CODE (decl
) == FUNCTION_DECL
)
14094 rest_of_decl_compilation (decl
, NULL
,
14095 DECL_CONTEXT (decl
) == 0,
14098 if (DECL_CONTEXT (decl
) != 0)
14100 /* Recompute the RTL of a local array now if it used to be an
14101 incomplete type. */
14103 && !TREE_STATIC (decl
) && !DECL_EXTERNAL (decl
))
14105 /* If we used it already as memory, it must stay in memory. */
14106 TREE_ADDRESSABLE (decl
) = TREE_USED (decl
);
14107 /* If it's still incomplete now, no init will save it. */
14108 if (DECL_SIZE (decl
) == 0)
14109 DECL_INITIAL (decl
) = 0;
14110 expand_decl (decl
);
14112 /* Compute and store the initial value. */
14113 if (TREE_CODE (decl
) != FUNCTION_DECL
)
14114 expand_decl_init (decl
);
14117 else if (TREE_CODE (decl
) == TYPE_DECL
)
14119 rest_of_decl_compilation (decl
, NULL_PTR
,
14120 DECL_CONTEXT (decl
) == 0,
14124 /* This test used to include TREE_PERMANENT, however, we have the same
14125 problem with initializers at the function level. Such initializers get
14126 saved until the end of the function on the momentary_obstack. */
14127 if (!(TREE_CODE (decl
) == FUNCTION_DECL
&& DECL_INLINE (decl
))
14129 /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
14131 && TREE_CODE (decl
) != PARM_DECL
)
14133 /* We need to remember that this array HAD an initialization, but
14134 discard the actual temporary nodes, since we can't have a permanent
14135 node keep pointing to them. */
14136 /* We make an exception for inline functions, since it's normal for a
14137 local extern redeclaration of an inline function to have a copy of
14138 the top-level decl's DECL_INLINE. */
14139 if ((DECL_INITIAL (decl
) != 0)
14140 && (DECL_INITIAL (decl
) != error_mark_node
))
14142 /* If this is a const variable, then preserve the
14143 initializer instead of discarding it so that we can optimize
14144 references to it. */
14145 /* This test used to include TREE_STATIC, but this won't be set
14146 for function level initializers. */
14147 if (TREE_READONLY (decl
))
14149 preserve_initializer ();
14150 /* Hack? Set the permanent bit for something that is
14151 permanent, but not on the permenent obstack, so as to
14152 convince output_constant_def to make its rtl on the
14153 permanent obstack. */
14154 TREE_PERMANENT (DECL_INITIAL (decl
)) = 1;
14156 /* The initializer and DECL must have the same (or equivalent
14157 types), but if the initializer is a STRING_CST, its type
14158 might not be on the right obstack, so copy the type
14160 TREE_TYPE (DECL_INITIAL (decl
)) = type
;
14163 DECL_INITIAL (decl
) = error_mark_node
;
14167 /* If requested, warn about definitions of large data objects. */
14169 if (warn_larger_than
14170 && (TREE_CODE (decl
) == VAR_DECL
|| TREE_CODE (decl
) == PARM_DECL
)
14171 && !DECL_EXTERNAL (decl
))
14173 register tree decl_size
= DECL_SIZE (decl
);
14175 if (decl_size
&& TREE_CODE (decl_size
) == INTEGER_CST
)
14177 unsigned units
= TREE_INT_CST_LOW (decl_size
) / BITS_PER_UNIT
;
14179 if (units
> larger_than_size
)
14180 warning_with_decl (decl
, "size of `%s' is %u bytes", units
);
14184 /* If we have gone back from temporary to permanent allocation, actually
14185 free the temporary space that we no longer need. */
14186 if (temporary
&& !allocation_temporary_p ())
14187 permanent_allocation (0);
14189 /* At the end of a declaration, throw away any variable type sizes of types
14190 defined inside that declaration. There is no use computing them in the
14191 following function definition. */
14192 if (current_binding_level
== global_binding_level
)
14193 get_pending_sizes ();
14196 /* Finish up a function declaration and compile that function
14197 all the way to assembler language output. The free the storage
14198 for the function definition.
14200 This is called after parsing the body of the function definition.
14202 NESTED is nonzero if the function being finished is nested in another. */
14205 finish_function (int nested
)
14207 register tree fndecl
= current_function_decl
;
14209 assert (fndecl
!= NULL_TREE
);
14210 if (TREE_CODE (fndecl
) != ERROR_MARK
)
14213 assert (DECL_CONTEXT (fndecl
) != NULL_TREE
);
14215 assert (DECL_CONTEXT (fndecl
) == NULL_TREE
);
14218 /* TREE_READONLY (fndecl) = 1;
14219 This caused &foo to be of type ptr-to-const-function
14220 which then got a warning when stored in a ptr-to-function variable. */
14222 poplevel (1, 0, 1);
14224 if (TREE_CODE (fndecl
) != ERROR_MARK
)
14226 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
14228 /* Must mark the RESULT_DECL as being in this function. */
14230 DECL_CONTEXT (DECL_RESULT (fndecl
)) = fndecl
;
14232 /* Obey `register' declarations if `setjmp' is called in this fn. */
14233 /* Generate rtl for function exit. */
14234 expand_function_end (input_filename
, lineno
, 0);
14236 /* So we can tell if jump_optimize sets it to 1. */
14239 /* Run the optimizers and output the assembler code for this function. */
14240 rest_of_compilation (fndecl
);
14243 /* Free all the tree nodes making up this function. */
14244 /* Switch back to allocating nodes permanently until we start another
14247 permanent_allocation (1);
14249 if (DECL_SAVED_INSNS (fndecl
) == 0 && !nested
&& (TREE_CODE (fndecl
) != ERROR_MARK
))
14251 /* Stop pointing to the local nodes about to be freed. */
14252 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14253 function definition. */
14254 /* For a nested function, this is done in pop_f_function_context. */
14255 /* If rest_of_compilation set this to 0, leave it 0. */
14256 if (DECL_INITIAL (fndecl
) != 0)
14257 DECL_INITIAL (fndecl
) = error_mark_node
;
14258 DECL_ARGUMENTS (fndecl
) = 0;
14263 /* Let the error reporting routines know that we're outside a function.
14264 For a nested function, this value is used in pop_c_function_context
14265 and then reset via pop_function_context. */
14266 ffecom_outer_function_decl_
= current_function_decl
= NULL
;
14270 /* Plug-in replacement for identifying the name of a decl and, for a
14271 function, what we call it in diagnostics. For now, "program unit"
14272 should suffice, since it's a bit of a hassle to figure out which
14273 of several kinds of things it is. Note that it could conceivably
14274 be a statement function, which probably isn't really a program unit
14275 per se, but if that comes up, it should be easy to check (being a
14276 nested function and all). */
14279 lang_printable_name (tree decl
, int v
)
14281 /* Just to keep GCC quiet about the unused variable.
14282 In theory, differing values of V should produce different
14287 if (TREE_CODE (decl
) == ERROR_MARK
)
14288 return "erroneous code";
14289 return IDENTIFIER_POINTER (DECL_NAME (decl
));
14293 /* g77's function to print out name of current function that caused
14298 lang_print_error_function (file
)
14301 static ffeglobal last_g
= NULL
;
14302 static ffesymbol last_s
= NULL
;
14307 if ((ffecom_primary_entry_
== NULL
)
14308 || (ffesymbol_global (ffecom_primary_entry_
) == NULL
))
14316 g
= ffesymbol_global (ffecom_primary_entry_
);
14317 if (ffecom_nested_entry_
== NULL
)
14319 s
= ffecom_primary_entry_
;
14320 switch (ffesymbol_kind (s
))
14322 case FFEINFO_kindFUNCTION
:
14326 case FFEINFO_kindSUBROUTINE
:
14327 kind
= "subroutine";
14330 case FFEINFO_kindPROGRAM
:
14334 case FFEINFO_kindBLOCKDATA
:
14335 kind
= "block-data";
14339 kind
= ffeinfo_kind_message (ffesymbol_kind (s
));
14345 s
= ffecom_nested_entry_
;
14346 kind
= "statement function";
14350 if ((last_g
!= g
) || (last_s
!= s
))
14353 fprintf (stderr
, "%s: ", file
);
14356 fprintf (stderr
, "Outside of any program unit:\n");
14359 char *name
= ffesymbol_text (s
);
14361 fprintf (stderr
, "In %s `%s':\n", kind
, name
);
14370 /* Similar to `lookup_name' but look only at current binding level. */
14373 lookup_name_current_level (tree name
)
14377 if (current_binding_level
== global_binding_level
)
14378 return IDENTIFIER_GLOBAL_VALUE (name
);
14380 if (IDENTIFIER_LOCAL_VALUE (name
) == 0)
14383 for (t
= current_binding_level
->names
; t
; t
= TREE_CHAIN (t
))
14384 if (DECL_NAME (t
) == name
)
14390 /* Create a new `struct binding_level'. */
14392 static struct binding_level
*
14393 make_binding_level ()
14396 return (struct binding_level
*) xmalloc (sizeof (struct binding_level
));
14399 /* Save and restore the variables in this file and elsewhere
14400 that keep track of the progress of compilation of the current function.
14401 Used for nested functions. */
14405 struct f_function
*next
;
14407 tree shadowed_labels
;
14408 struct binding_level
*binding_level
;
14411 struct f_function
*f_function_chain
;
14413 /* Restore the variables used during compilation of a C function. */
14416 pop_f_function_context ()
14418 struct f_function
*p
= f_function_chain
;
14421 /* Bring back all the labels that were shadowed. */
14422 for (link
= shadowed_labels
; link
; link
= TREE_CHAIN (link
))
14423 if (DECL_NAME (TREE_VALUE (link
)) != 0)
14424 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link
)))
14425 = TREE_VALUE (link
);
14427 if (DECL_SAVED_INSNS (current_function_decl
) == 0)
14429 /* Stop pointing to the local nodes about to be freed. */
14430 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14431 function definition. */
14432 DECL_INITIAL (current_function_decl
) = error_mark_node
;
14433 DECL_ARGUMENTS (current_function_decl
) = 0;
14436 pop_function_context ();
14438 f_function_chain
= p
->next
;
14440 named_labels
= p
->named_labels
;
14441 shadowed_labels
= p
->shadowed_labels
;
14442 current_binding_level
= p
->binding_level
;
14447 /* Save and reinitialize the variables
14448 used during compilation of a C function. */
14451 push_f_function_context ()
14453 struct f_function
*p
14454 = (struct f_function
*) xmalloc (sizeof (struct f_function
));
14456 push_function_context ();
14458 p
->next
= f_function_chain
;
14459 f_function_chain
= p
;
14461 p
->named_labels
= named_labels
;
14462 p
->shadowed_labels
= shadowed_labels
;
14463 p
->binding_level
= current_binding_level
;
14467 push_parm_decl (tree parm
)
14469 int old_immediate_size_expand
= immediate_size_expand
;
14471 /* Don't try computing parm sizes now -- wait till fn is called. */
14473 immediate_size_expand
= 0;
14475 push_obstacks_nochange ();
14477 /* Fill in arg stuff. */
14479 DECL_ARG_TYPE (parm
) = TREE_TYPE (parm
);
14480 DECL_ARG_TYPE_AS_WRITTEN (parm
) = TREE_TYPE (parm
);
14481 TREE_READONLY (parm
) = 1; /* All implementation args are read-only. */
14483 parm
= pushdecl (parm
);
14485 immediate_size_expand
= old_immediate_size_expand
;
14487 finish_decl (parm
, NULL_TREE
, FALSE
);
14490 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
14493 pushdecl_top_level (x
)
14497 register struct binding_level
*b
= current_binding_level
;
14498 register tree f
= current_function_decl
;
14500 current_binding_level
= global_binding_level
;
14501 current_function_decl
= NULL_TREE
;
14503 current_binding_level
= b
;
14504 current_function_decl
= f
;
14508 /* Store the list of declarations of the current level.
14509 This is done for the parameter declarations of a function being defined,
14510 after they are modified in the light of any missing parameters. */
14516 return current_binding_level
->names
= decls
;
14519 /* Store the parameter declarations into the current function declaration.
14520 This is called after parsing the parameter declarations, before
14521 digesting the body of the function.
14523 For an old-style definition, modify the function's type
14524 to specify at least the number of arguments. */
14527 store_parm_decls (int is_main_program UNUSED
)
14529 register tree fndecl
= current_function_decl
;
14531 /* This is a chain of PARM_DECLs from old-style parm declarations. */
14532 DECL_ARGUMENTS (fndecl
) = storedecls (nreverse (getdecls ()));
14534 /* Initialize the RTL code for the function. */
14536 init_function_start (fndecl
, input_filename
, lineno
);
14538 /* Set up parameters and prepare for return, for the function. */
14540 expand_function_start (fndecl
, 0);
14544 start_decl (tree decl
, bool is_top_level
)
14547 bool at_top_level
= (current_binding_level
== global_binding_level
);
14548 bool top_level
= is_top_level
|| at_top_level
;
14550 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14552 assert (!is_top_level
|| !at_top_level
);
14554 /* The corresponding pop_obstacks is in finish_decl. */
14555 push_obstacks_nochange ();
14557 if (DECL_INITIAL (decl
) != NULL_TREE
)
14559 assert (DECL_INITIAL (decl
) == error_mark_node
);
14560 assert (!DECL_EXTERNAL (decl
));
14562 else if (top_level
)
14563 assert ((TREE_STATIC (decl
) == 1) || DECL_EXTERNAL (decl
) == 1);
14565 /* For Fortran, we by default put things in .common when possible. */
14566 DECL_COMMON (decl
) = 1;
14568 /* Add this decl to the current binding level. TEM may equal DECL or it may
14569 be a previous decl of the same name. */
14571 tem
= pushdecl_top_level (decl
);
14573 tem
= pushdecl (decl
);
14575 /* For a local variable, define the RTL now. */
14577 /* But not if this is a duplicate decl and we preserved the rtl from the
14578 previous one (which may or may not happen). */
14579 && DECL_RTL (tem
) == 0)
14581 if (TYPE_SIZE (TREE_TYPE (tem
)) != 0)
14583 else if (TREE_CODE (TREE_TYPE (tem
)) == ARRAY_TYPE
14584 && DECL_INITIAL (tem
) != 0)
14588 if (DECL_INITIAL (tem
) != NULL_TREE
)
14590 /* When parsing and digesting the initializer, use temporary storage.
14591 Do this even if we will ignore the value. */
14593 temporary_allocation ();
14599 /* Create the FUNCTION_DECL for a function definition.
14600 DECLSPECS and DECLARATOR are the parts of the declaration;
14601 they describe the function's name and the type it returns,
14602 but twisted together in a fashion that parallels the syntax of C.
14604 This function creates a binding context for the function body
14605 as well as setting up the FUNCTION_DECL in current_function_decl.
14607 Returns 1 on success. If the DECLARATOR is not suitable for a function
14608 (it defines a datum instead), we return 0, which tells
14609 yyparse to report a parse error.
14611 NESTED is nonzero for a function nested within another function. */
14614 start_function (tree name
, tree type
, int nested
, int public)
14618 int old_immediate_size_expand
= immediate_size_expand
;
14621 shadowed_labels
= 0;
14623 /* Don't expand any sizes in the return type of the function. */
14624 immediate_size_expand
= 0;
14629 assert (current_function_decl
!= NULL_TREE
);
14630 assert (DECL_CONTEXT (current_function_decl
) == NULL_TREE
);
14634 assert (current_function_decl
== NULL_TREE
);
14637 if (TREE_CODE (type
) == ERROR_MARK
)
14638 decl1
= current_function_decl
= error_mark_node
;
14641 decl1
= build_decl (FUNCTION_DECL
,
14644 TREE_PUBLIC (decl1
) = public ? 1 : 0;
14646 DECL_INLINE (decl1
) = 1;
14647 TREE_STATIC (decl1
) = 1;
14648 DECL_EXTERNAL (decl1
) = 0;
14650 announce_function (decl1
);
14652 /* Make the init_value nonzero so pushdecl knows this is not tentative.
14653 error_mark_node is replaced below (in poplevel) with the BLOCK. */
14654 DECL_INITIAL (decl1
) = error_mark_node
;
14656 /* Record the decl so that the function name is defined. If we already have
14657 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
14659 current_function_decl
= pushdecl (decl1
);
14663 ffecom_outer_function_decl_
= current_function_decl
;
14667 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
14669 make_function_rtl (current_function_decl
);
14671 restype
= TREE_TYPE (TREE_TYPE (current_function_decl
));
14672 DECL_RESULT (current_function_decl
)
14673 = build_decl (RESULT_DECL
, NULL_TREE
, restype
);
14677 /* Allocate further tree nodes temporarily during compilation of this
14679 temporary_allocation ();
14681 if (!nested
&& (TREE_CODE (current_function_decl
) != ERROR_MARK
))
14682 TREE_ADDRESSABLE (current_function_decl
) = 1;
14684 immediate_size_expand
= old_immediate_size_expand
;
14687 /* Here are the public functions the GNU back end needs. */
14689 /* This is used by the `assert' macro. It is provided in libgcc.a,
14690 which `cc' doesn't know how to link. Note that the C++ front-end
14691 no longer actually uses the `assert' macro (instead, it calls
14692 my_friendly_assert). But all of the back-end files still need this. */
14694 __eprintf (string
, expression
, line
, filename
)
14696 const char *string
;
14697 const char *expression
;
14699 const char *filename
;
14707 fprintf (stderr
, string
, expression
, line
, filename
);
14713 convert (type
, expr
)
14716 register tree e
= expr
;
14717 register enum tree_code code
= TREE_CODE (type
);
14719 if (type
== TREE_TYPE (e
)
14720 || TREE_CODE (e
) == ERROR_MARK
)
14722 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
14723 return fold (build1 (NOP_EXPR
, type
, e
));
14724 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
14725 || code
== ERROR_MARK
)
14726 return error_mark_node
;
14727 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
14729 assert ("void value not ignored as it ought to be" == NULL
);
14730 return error_mark_node
;
14732 if (code
== VOID_TYPE
)
14733 return build1 (CONVERT_EXPR
, type
, e
);
14734 if ((code
!= RECORD_TYPE
)
14735 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
14736 e
= ffecom_1 (REALPART_EXPR
, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
))),
14738 if (code
== INTEGER_TYPE
|| code
== ENUMERAL_TYPE
)
14739 return fold (convert_to_integer (type
, e
));
14740 if (code
== POINTER_TYPE
)
14741 return fold (convert_to_pointer (type
, e
));
14742 if (code
== REAL_TYPE
)
14743 return fold (convert_to_real (type
, e
));
14744 if (code
== COMPLEX_TYPE
)
14745 return fold (convert_to_complex (type
, e
));
14746 if (code
== RECORD_TYPE
)
14747 return fold (ffecom_convert_to_complex_ (type
, e
));
14749 assert ("conversion to non-scalar type requested" == NULL
);
14750 return error_mark_node
;
14753 /* integrate_decl_tree calls this function, but since we don't use the
14754 DECL_LANG_SPECIFIC field, this is a no-op. */
14757 copy_lang_decl (node
)
14762 /* Return the list of declarations of the current level.
14763 Note that this list is in reverse order unless/until
14764 you nreverse it; and when you do nreverse it, you must
14765 store the result back using `storedecls' or you will lose. */
14770 return current_binding_level
->names
;
14773 /* Nonzero if we are currently in the global binding level. */
14776 global_bindings_p ()
14778 return current_binding_level
== global_binding_level
;
14781 /* Insert BLOCK at the end of the list of subblocks of the
14782 current binding level. This is used when a BIND_EXPR is expanded,
14783 to handle the BLOCK node inside the BIND_EXPR. */
14786 incomplete_type_error (value
, type
)
14790 if (TREE_CODE (type
) == ERROR_MARK
)
14793 assert ("incomplete type?!?" == NULL
);
14797 init_decl_processing ()
14807 extern void (*print_error_function
) (char *);
14810 /* Make identifier nodes long enough for the language-specific slots. */
14811 set_identifier_size (sizeof (struct lang_identifier
));
14812 decl_printable_name
= lang_printable_name
;
14814 print_error_function
= lang_print_error_function
;
14819 insert_block (block
)
14822 TREE_USED (block
) = 1;
14823 current_binding_level
->blocks
14824 = chainon (current_binding_level
->blocks
, block
);
14828 lang_decode_option (p
)
14831 return ffe_decode_option (p
);
14837 ffe_terminate_0 ();
14839 if (ffe_is_ffedebug ())
14840 malloc_pool_display (malloc_pool_image ());
14852 extern FILE *finput
; /* Don't pollute com.h with this. */
14854 /* If the file is output from cpp, it should contain a first line
14855 `# 1 "real-filename"', and the current design of gcc (toplev.c
14856 in particular and the way it sets up information relied on by
14857 INCLUDE) requires that we read this now, and store the
14858 "real-filename" info in master_input_filename. Ask the lexer
14859 to try doing this. */
14860 ffelex_hash_kludge (finput
);
14864 mark_addressable (exp
)
14867 register tree x
= exp
;
14869 switch (TREE_CODE (x
))
14872 case COMPONENT_REF
:
14874 x
= TREE_OPERAND (x
, 0);
14878 TREE_ADDRESSABLE (x
) = 1;
14885 if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
)
14886 && DECL_NONLOCAL (x
))
14888 if (TREE_PUBLIC (x
))
14890 assert ("address of global register var requested" == NULL
);
14893 assert ("address of register variable requested" == NULL
);
14895 else if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
))
14897 if (TREE_PUBLIC (x
))
14899 assert ("address of global register var requested" == NULL
);
14902 assert ("address of register var requested" == NULL
);
14904 put_var_into_stack (x
);
14907 case FUNCTION_DECL
:
14908 TREE_ADDRESSABLE (x
) = 1;
14909 #if 0 /* poplevel deals with this now. */
14910 if (DECL_CONTEXT (x
) == 0)
14911 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x
)) = 1;
14919 /* If DECL has a cleanup, build and return that cleanup here.
14920 This is a callback called by expand_expr. */
14923 maybe_build_cleanup (decl
)
14926 /* There are no cleanups in Fortran. */
14930 /* Exit a binding level.
14931 Pop the level off, and restore the state of the identifier-decl mappings
14932 that were in effect when this level was entered.
14934 If KEEP is nonzero, this level had explicit declarations, so
14935 and create a "block" (a BLOCK node) for the level
14936 to record its declarations and subblocks for symbol table output.
14938 If FUNCTIONBODY is nonzero, this level is the body of a function,
14939 so create a block as if KEEP were set and also clear out all
14942 If REVERSE is nonzero, reverse the order of decls before putting
14943 them into the BLOCK. */
14946 poplevel (keep
, reverse
, functionbody
)
14951 register tree link
;
14952 /* The chain of decls was accumulated in reverse order. Put it into forward
14953 order, just for cleanliness. */
14955 tree subblocks
= current_binding_level
->blocks
;
14958 int block_previously_created
;
14960 /* Get the decls in the order they were written. Usually
14961 current_binding_level->names is in reverse order. But parameter decls
14962 were previously put in forward order. */
14965 current_binding_level
->names
14966 = decls
= nreverse (current_binding_level
->names
);
14968 decls
= current_binding_level
->names
;
14970 /* Output any nested inline functions within this block if they weren't
14973 for (decl
= decls
; decl
; decl
= TREE_CHAIN (decl
))
14974 if (TREE_CODE (decl
) == FUNCTION_DECL
14975 && !TREE_ASM_WRITTEN (decl
)
14976 && DECL_INITIAL (decl
) != 0
14977 && TREE_ADDRESSABLE (decl
))
14979 /* If this decl was copied from a file-scope decl on account of a
14980 block-scope extern decl, propagate TREE_ADDRESSABLE to the
14981 file-scope decl. */
14982 if (DECL_ABSTRACT_ORIGIN (decl
) != 0)
14983 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl
)) = 1;
14986 push_function_context ();
14987 output_inline_function (decl
);
14988 pop_function_context ();
14992 /* If there were any declarations or structure tags in that level, or if
14993 this level is a function body, create a BLOCK to record them for the
14994 life of this function. */
14997 block_previously_created
= (current_binding_level
->this_block
!= 0);
14998 if (block_previously_created
)
14999 block
= current_binding_level
->this_block
;
15000 else if (keep
|| functionbody
)
15001 block
= make_node (BLOCK
);
15004 BLOCK_VARS (block
) = decls
;
15005 BLOCK_SUBBLOCKS (block
) = subblocks
;
15006 remember_end_note (block
);
15009 /* In each subblock, record that this is its superior. */
15011 for (link
= subblocks
; link
; link
= TREE_CHAIN (link
))
15012 BLOCK_SUPERCONTEXT (link
) = block
;
15014 /* Clear out the meanings of the local variables of this level. */
15016 for (link
= decls
; link
; link
= TREE_CHAIN (link
))
15018 if (DECL_NAME (link
) != 0)
15020 /* If the ident. was used or addressed via a local extern decl,
15021 don't forget that fact. */
15022 if (DECL_EXTERNAL (link
))
15024 if (TREE_USED (link
))
15025 TREE_USED (DECL_NAME (link
)) = 1;
15026 if (TREE_ADDRESSABLE (link
))
15027 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link
)) = 1;
15029 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link
)) = 0;
15033 /* If the level being exited is the top level of a function, check over all
15034 the labels, and clear out the current (function local) meanings of their
15039 /* If this is the top level block of a function, the vars are the
15040 function's parameters. Don't leave them in the BLOCK because they
15041 are found in the FUNCTION_DECL instead. */
15043 BLOCK_VARS (block
) = 0;
15046 /* Pop the current level, and free the structure for reuse. */
15049 register struct binding_level
*level
= current_binding_level
;
15050 current_binding_level
= current_binding_level
->level_chain
;
15052 level
->level_chain
= free_binding_level
;
15053 free_binding_level
= level
;
15056 /* Dispose of the block that we just made inside some higher level. */
15058 DECL_INITIAL (current_function_decl
) = block
;
15061 if (!block_previously_created
)
15062 current_binding_level
->blocks
15063 = chainon (current_binding_level
->blocks
, block
);
15065 /* If we did not make a block for the level just exited, any blocks made
15066 for inner levels (since they cannot be recorded as subblocks in that
15067 level) must be carried forward so they will later become subblocks of
15069 else if (subblocks
)
15070 current_binding_level
->blocks
15071 = chainon (current_binding_level
->blocks
, subblocks
);
15073 /* Set the TYPE_CONTEXTs for all of the tagged types belonging to this
15074 binding contour so that they point to the appropriate construct, i.e.
15075 either to the current FUNCTION_DECL node, or else to the BLOCK node we
15078 Note that for tagged types whose scope is just the formal parameter list
15079 for some function type specification, we can't properly set their
15080 TYPE_CONTEXTs here, because we don't have a pointer to the appropriate
15081 FUNCTION_TYPE node readily available to us. For those cases, the
15082 TYPE_CONTEXTs of the relevant tagged type nodes get set in
15083 `grokdeclarator' as soon as we have created the FUNCTION_TYPE node which
15084 will represent the "scope" for these "parameter list local" tagged
15088 TREE_USED (block
) = 1;
15093 print_lang_decl (file
, node
, indent
)
15101 print_lang_identifier (file
, node
, indent
)
15106 print_node (file
, "global", IDENTIFIER_GLOBAL_VALUE (node
), indent
+ 4);
15107 print_node (file
, "local", IDENTIFIER_LOCAL_VALUE (node
), indent
+ 4);
15111 print_lang_statistics ()
15116 print_lang_type (file
, node
, indent
)
15123 /* Record a decl-node X as belonging to the current lexical scope.
15124 Check for errors (such as an incompatible declaration for the same
15125 name already seen in the same scope).
15127 Returns either X or an old decl for the same name.
15128 If an old decl is returned, it may have been smashed
15129 to agree with what X says. */
15136 register tree name
= DECL_NAME (x
);
15137 register struct binding_level
*b
= current_binding_level
;
15139 if ((TREE_CODE (x
) == FUNCTION_DECL
)
15140 && (DECL_INITIAL (x
) == 0)
15141 && DECL_EXTERNAL (x
))
15142 DECL_CONTEXT (x
) = NULL_TREE
;
15144 DECL_CONTEXT (x
) = current_function_decl
;
15148 if (IDENTIFIER_INVENTED (name
))
15151 DECL_ARTIFICIAL (x
) = 1;
15153 DECL_IN_SYSTEM_HEADER (x
) = 1;
15154 DECL_IGNORED_P (x
) = 1;
15156 if (TREE_CODE (x
) == TYPE_DECL
)
15157 TYPE_DECL_SUPPRESS_DEBUG (x
) = 1;
15160 t
= lookup_name_current_level (name
);
15162 assert ((t
== NULL_TREE
) || (DECL_CONTEXT (x
) == NULL_TREE
));
15164 /* Don't push non-parms onto list for parms until we understand
15165 why we're doing this and whether it works. */
15167 assert ((b
== global_binding_level
)
15168 || !ffecom_transform_only_dummies_
15169 || TREE_CODE (x
) == PARM_DECL
);
15171 if ((t
!= NULL_TREE
) && duplicate_decls (x
, t
))
15174 /* If we are processing a typedef statement, generate a whole new
15175 ..._TYPE node (which will be just an variant of the existing
15176 ..._TYPE node with identical properties) and then install the
15177 TYPE_DECL node generated to represent the typedef name as the
15178 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15180 The whole point here is to end up with a situation where each and every
15181 ..._TYPE node the compiler creates will be uniquely associated with
15182 AT MOST one node representing a typedef name. This way, even though
15183 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15184 (i.e. "typedef name") nodes very early on, later parts of the
15185 compiler can always do the reverse translation and get back the
15186 corresponding typedef name. For example, given:
15188 typedef struct S MY_TYPE; MY_TYPE object;
15190 Later parts of the compiler might only know that `object' was of type
15191 `struct S' if if were not for code just below. With this code
15192 however, later parts of the compiler see something like:
15194 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15196 And they can then deduce (from the node for type struct S') that the
15197 original object declaration was:
15201 Being able to do this is important for proper support of protoize, and
15202 also for generating precise symbolic debugging information which
15203 takes full account of the programmer's (typedef) vocabulary.
15205 Obviously, we don't want to generate a duplicate ..._TYPE node if the
15206 TYPE_DECL node that we are now processing really represents a
15207 standard built-in type.
15209 Since all standard types are effectively declared at line zero in the
15210 source file, we can easily check to see if we are working on a
15211 standard type by checking the current value of lineno. */
15213 if (TREE_CODE (x
) == TYPE_DECL
)
15215 if (DECL_SOURCE_LINE (x
) == 0)
15217 if (TYPE_NAME (TREE_TYPE (x
)) == 0)
15218 TYPE_NAME (TREE_TYPE (x
)) = x
;
15220 else if (TREE_TYPE (x
) != error_mark_node
)
15222 tree tt
= TREE_TYPE (x
);
15224 tt
= build_type_copy (tt
);
15225 TYPE_NAME (tt
) = x
;
15226 TREE_TYPE (x
) = tt
;
15230 /* This name is new in its binding level. Install the new declaration
15232 if (b
== global_binding_level
)
15233 IDENTIFIER_GLOBAL_VALUE (name
) = x
;
15235 IDENTIFIER_LOCAL_VALUE (name
) = x
;
15238 /* Put decls on list in reverse order. We will reverse them later if
15240 TREE_CHAIN (x
) = b
->names
;
15246 /* Enter a new binding level.
15247 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15248 not for that of tags. */
15251 pushlevel (tag_transparent
)
15252 int tag_transparent
;
15254 register struct binding_level
*newlevel
= NULL_BINDING_LEVEL
;
15256 assert (!tag_transparent
);
15258 /* Reuse or create a struct for this binding level. */
15260 if (free_binding_level
)
15262 newlevel
= free_binding_level
;
15263 free_binding_level
= free_binding_level
->level_chain
;
15267 newlevel
= make_binding_level ();
15270 /* Add this level to the front of the chain (stack) of levels that are
15273 *newlevel
= clear_binding_level
;
15274 newlevel
->level_chain
= current_binding_level
;
15275 current_binding_level
= newlevel
;
15278 /* Set the BLOCK node for the innermost scope
15279 (the one we are currently in). */
15283 register tree block
;
15285 current_binding_level
->this_block
= block
;
15288 /* ~~tree.h SHOULD declare this, because toplev.c references it. */
15290 /* Can't 'yydebug' a front end not generated by yacc/bison! */
15293 set_yydebug (value
)
15297 fprintf (stderr
, "warning: no yacc/bison-generated output to debug!\n");
15301 signed_or_unsigned_type (unsignedp
, type
)
15307 if (! INTEGRAL_TYPE_P (type
))
15309 if (TYPE_PRECISION (type
) == TYPE_PRECISION (signed_char_type_node
))
15310 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15311 if (TYPE_PRECISION (type
) == TYPE_PRECISION (integer_type_node
))
15312 return unsignedp
? unsigned_type_node
: integer_type_node
;
15313 if (TYPE_PRECISION (type
) == TYPE_PRECISION (short_integer_type_node
))
15314 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15315 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_integer_type_node
))
15316 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15317 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_long_integer_type_node
))
15318 return (unsignedp
? long_long_unsigned_type_node
15319 : long_long_integer_type_node
);
15321 type2
= type_for_size (TYPE_PRECISION (type
), unsignedp
);
15322 if (type2
== NULL_TREE
)
15332 tree type1
= TYPE_MAIN_VARIANT (type
);
15333 ffeinfoKindtype kt
;
15336 if (type1
== unsigned_char_type_node
|| type1
== char_type_node
)
15337 return signed_char_type_node
;
15338 if (type1
== unsigned_type_node
)
15339 return integer_type_node
;
15340 if (type1
== short_unsigned_type_node
)
15341 return short_integer_type_node
;
15342 if (type1
== long_unsigned_type_node
)
15343 return long_integer_type_node
;
15344 if (type1
== long_long_unsigned_type_node
)
15345 return long_long_integer_type_node
;
15346 #if 0 /* gcc/c-* files only */
15347 if (type1
== unsigned_intDI_type_node
)
15348 return intDI_type_node
;
15349 if (type1
== unsigned_intSI_type_node
)
15350 return intSI_type_node
;
15351 if (type1
== unsigned_intHI_type_node
)
15352 return intHI_type_node
;
15353 if (type1
== unsigned_intQI_type_node
)
15354 return intQI_type_node
;
15357 type2
= type_for_size (TYPE_PRECISION (type1
), 0);
15358 if (type2
!= NULL_TREE
)
15361 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15363 type2
= ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
15365 if (type1
== type2
)
15366 return ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15372 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15373 or validate its data type for an `if' or `while' statement or ?..: exp.
15375 This preparation consists of taking the ordinary
15376 representation of an expression expr and producing a valid tree
15377 boolean expression describing whether expr is nonzero. We could
15378 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15379 but we optimize comparisons, &&, ||, and !.
15381 The resulting type should always be `integer_type_node'. */
15384 truthvalue_conversion (expr
)
15387 if (TREE_CODE (expr
) == ERROR_MARK
)
15390 #if 0 /* This appears to be wrong for C++. */
15391 /* These really should return error_mark_node after 2.4 is stable.
15392 But not all callers handle ERROR_MARK properly. */
15393 switch (TREE_CODE (TREE_TYPE (expr
)))
15396 error ("struct type value used where scalar is required");
15397 return integer_zero_node
;
15400 error ("union type value used where scalar is required");
15401 return integer_zero_node
;
15404 error ("array type value used where scalar is required");
15405 return integer_zero_node
;
15412 switch (TREE_CODE (expr
))
15414 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15415 or comparison expressions as truth values at this level. */
15417 case COMPONENT_REF
:
15418 /* A one-bit unsigned bit-field is already acceptable. */
15419 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr
, 1)))
15420 && TREE_UNSIGNED (TREE_OPERAND (expr
, 1)))
15426 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15427 or comparison expressions as truth values at this level. */
15429 if (integer_zerop (TREE_OPERAND (expr
, 1)))
15430 return build_unary_op (TRUTH_NOT_EXPR
, TREE_OPERAND (expr
, 0), 0);
15432 case NE_EXPR
: case LE_EXPR
: case GE_EXPR
: case LT_EXPR
: case GT_EXPR
:
15433 case TRUTH_ANDIF_EXPR
:
15434 case TRUTH_ORIF_EXPR
:
15435 case TRUTH_AND_EXPR
:
15436 case TRUTH_OR_EXPR
:
15437 case TRUTH_XOR_EXPR
:
15438 TREE_TYPE (expr
) = integer_type_node
;
15445 return integer_zerop (expr
) ? integer_zero_node
: integer_one_node
;
15448 return real_zerop (expr
) ? integer_zero_node
: integer_one_node
;
15451 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 0)))
15452 return build (COMPOUND_EXPR
, integer_type_node
,
15453 TREE_OPERAND (expr
, 0), integer_one_node
);
15455 return integer_one_node
;
15458 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1))
15459 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
15461 truthvalue_conversion (TREE_OPERAND (expr
, 0)),
15462 truthvalue_conversion (TREE_OPERAND (expr
, 1)));
15468 /* These don't change whether an object is non-zero or zero. */
15469 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15473 /* These don't change whether an object is zero or non-zero, but
15474 we can't ignore them if their second arg has side-effects. */
15475 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1)))
15476 return build (COMPOUND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 1),
15477 truthvalue_conversion (TREE_OPERAND (expr
, 0)));
15479 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15482 /* Distribute the conversion into the arms of a COND_EXPR. */
15483 return fold (build (COND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 0),
15484 truthvalue_conversion (TREE_OPERAND (expr
, 1)),
15485 truthvalue_conversion (TREE_OPERAND (expr
, 2))));
15488 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15489 since that affects how `default_conversion' will behave. */
15490 if (TREE_CODE (TREE_TYPE (expr
)) == REFERENCE_TYPE
15491 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == REFERENCE_TYPE
)
15493 /* fall through... */
15495 /* If this is widening the argument, we can ignore it. */
15496 if (TYPE_PRECISION (TREE_TYPE (expr
))
15497 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr
, 0))))
15498 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15502 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15504 if (TARGET_FLOAT_FORMAT
== IEEE_FLOAT_FORMAT
15505 && TREE_CODE (TREE_TYPE (expr
)) == REAL_TYPE
)
15507 /* fall through... */
15509 /* This and MINUS_EXPR can be changed into a comparison of the
15511 if (TREE_TYPE (TREE_OPERAND (expr
, 0))
15512 == TREE_TYPE (TREE_OPERAND (expr
, 1)))
15513 return ffecom_2 (NE_EXPR
, integer_type_node
,
15514 TREE_OPERAND (expr
, 0),
15515 TREE_OPERAND (expr
, 1));
15516 return ffecom_2 (NE_EXPR
, integer_type_node
,
15517 TREE_OPERAND (expr
, 0),
15518 fold (build1 (NOP_EXPR
,
15519 TREE_TYPE (TREE_OPERAND (expr
, 0)),
15520 TREE_OPERAND (expr
, 1))));
15523 if (integer_onep (TREE_OPERAND (expr
, 1)))
15528 #if 0 /* No such thing in Fortran. */
15529 if (warn_parentheses
&& C_EXP_ORIGINAL_CODE (expr
) == MODIFY_EXPR
)
15530 warning ("suggest parentheses around assignment used as truth value");
15538 if (TREE_CODE (TREE_TYPE (expr
)) == COMPLEX_TYPE
)
15540 ((TREE_SIDE_EFFECTS (expr
)
15541 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
15543 truthvalue_conversion (ffecom_1 (REALPART_EXPR
,
15544 TREE_TYPE (TREE_TYPE (expr
)),
15546 truthvalue_conversion (ffecom_1 (IMAGPART_EXPR
,
15547 TREE_TYPE (TREE_TYPE (expr
)),
15550 return ffecom_2 (NE_EXPR
, integer_type_node
,
15552 convert (TREE_TYPE (expr
), integer_zero_node
));
15556 type_for_mode (mode
, unsignedp
)
15557 enum machine_mode mode
;
15564 if (mode
== TYPE_MODE (integer_type_node
))
15565 return unsignedp
? unsigned_type_node
: integer_type_node
;
15567 if (mode
== TYPE_MODE (signed_char_type_node
))
15568 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15570 if (mode
== TYPE_MODE (short_integer_type_node
))
15571 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15573 if (mode
== TYPE_MODE (long_integer_type_node
))
15574 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15576 if (mode
== TYPE_MODE (long_long_integer_type_node
))
15577 return unsignedp
? long_long_unsigned_type_node
: long_long_integer_type_node
;
15579 if (mode
== TYPE_MODE (float_type_node
))
15580 return float_type_node
;
15582 if (mode
== TYPE_MODE (double_type_node
))
15583 return double_type_node
;
15585 if (mode
== TYPE_MODE (build_pointer_type (char_type_node
)))
15586 return build_pointer_type (char_type_node
);
15588 if (mode
== TYPE_MODE (build_pointer_type (integer_type_node
)))
15589 return build_pointer_type (integer_type_node
);
15591 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
15592 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
15594 if (((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
15595 && (mode
== TYPE_MODE (t
)))
15597 if ((i
== FFEINFO_basictypeINTEGER
) && unsignedp
)
15598 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][j
];
15608 type_for_size (bits
, unsignedp
)
15612 ffeinfoKindtype kt
;
15615 if (bits
== TYPE_PRECISION (integer_type_node
))
15616 return unsignedp
? unsigned_type_node
: integer_type_node
;
15618 if (bits
== TYPE_PRECISION (signed_char_type_node
))
15619 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15621 if (bits
== TYPE_PRECISION (short_integer_type_node
))
15622 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15624 if (bits
== TYPE_PRECISION (long_integer_type_node
))
15625 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15627 if (bits
== TYPE_PRECISION (long_long_integer_type_node
))
15628 return (unsignedp
? long_long_unsigned_type_node
15629 : long_long_integer_type_node
);
15631 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15633 type_node
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15635 if ((type_node
!= NULL_TREE
) && (bits
== TYPE_PRECISION (type_node
)))
15636 return unsignedp
? ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
]
15644 unsigned_type (type
)
15647 tree type1
= TYPE_MAIN_VARIANT (type
);
15648 ffeinfoKindtype kt
;
15651 if (type1
== signed_char_type_node
|| type1
== char_type_node
)
15652 return unsigned_char_type_node
;
15653 if (type1
== integer_type_node
)
15654 return unsigned_type_node
;
15655 if (type1
== short_integer_type_node
)
15656 return short_unsigned_type_node
;
15657 if (type1
== long_integer_type_node
)
15658 return long_unsigned_type_node
;
15659 if (type1
== long_long_integer_type_node
)
15660 return long_long_unsigned_type_node
;
15661 #if 0 /* gcc/c-* files only */
15662 if (type1
== intDI_type_node
)
15663 return unsigned_intDI_type_node
;
15664 if (type1
== intSI_type_node
)
15665 return unsigned_intSI_type_node
;
15666 if (type1
== intHI_type_node
)
15667 return unsigned_intHI_type_node
;
15668 if (type1
== intQI_type_node
)
15669 return unsigned_intQI_type_node
;
15672 type2
= type_for_size (TYPE_PRECISION (type1
), 1);
15673 if (type2
!= NULL_TREE
)
15676 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15678 type2
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15680 if (type1
== type2
)
15681 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
15687 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15689 #if FFECOM_GCC_INCLUDE
15691 /* From gcc/cccp.c, the code to handle -I. */
15693 /* Skip leading "./" from a directory name.
15694 This may yield the empty string, which represents the current directory. */
15697 skip_redundant_dir_prefix (char *dir
)
15699 while (dir
[0] == '.' && dir
[1] == '/')
15700 for (dir
+= 2; *dir
== '/'; dir
++)
15702 if (dir
[0] == '.' && !dir
[1])
15707 /* The file_name_map structure holds a mapping of file names for a
15708 particular directory. This mapping is read from the file named
15709 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15710 map filenames on a file system with severe filename restrictions,
15711 such as DOS. The format of the file name map file is just a series
15712 of lines with two tokens on each line. The first token is the name
15713 to map, and the second token is the actual name to use. */
15715 struct file_name_map
15717 struct file_name_map
*map_next
;
15722 #define FILE_NAME_MAP_FILE "header.gcc"
15724 /* Current maximum length of directory names in the search path
15725 for include files. (Altered as we get more of them.) */
15727 static int max_include_len
= 0;
15729 struct file_name_list
15731 struct file_name_list
*next
;
15733 /* Mapping of file names for this directory. */
15734 struct file_name_map
*name_map
;
15735 /* Non-zero if name_map is valid. */
15739 static struct file_name_list
*include
= NULL
; /* First dir to search */
15740 static struct file_name_list
*last_include
= NULL
; /* Last in chain */
15742 /* I/O buffer structure.
15743 The `fname' field is nonzero for source files and #include files
15744 and for the dummy text used for -D and -U.
15745 It is zero for rescanning results of macro expansion
15746 and for expanding macro arguments. */
15747 #define INPUT_STACK_MAX 400
15748 static struct file_buf
{
15750 /* Filename specified with #line command. */
15751 char *nominal_fname
;
15752 /* Record where in the search path this file was found.
15753 For #include_next. */
15754 struct file_name_list
*dir
;
15756 ffewhereColumn column
;
15757 } instack
[INPUT_STACK_MAX
];
15759 static int last_error_tick
= 0; /* Incremented each time we print it. */
15760 static int input_file_stack_tick
= 0; /* Incremented when status changes. */
15762 /* Current nesting level of input sources.
15763 `instack[indepth]' is the level currently being read. */
15764 static int indepth
= -1;
15766 typedef struct file_buf FILE_BUF
;
15768 typedef unsigned char U_CHAR
;
15770 /* table to tell if char can be part of a C identifier. */
15771 U_CHAR is_idchar
[256];
15772 /* table to tell if char can be first char of a c identifier. */
15773 U_CHAR is_idstart
[256];
15774 /* table to tell if c is horizontal space. */
15775 U_CHAR is_hor_space
[256];
15776 /* table to tell if c is horizontal or vertical space. */
15777 static U_CHAR is_space
[256];
15779 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15780 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15782 /* Nonzero means -I- has been seen,
15783 so don't look for #include "foo" the source-file directory. */
15784 static int ignore_srcdir
;
15786 #ifndef INCLUDE_LEN_FUDGE
15787 #define INCLUDE_LEN_FUDGE 0
15790 static void append_include_chain (struct file_name_list
*first
,
15791 struct file_name_list
*last
);
15792 static FILE *open_include_file (char *filename
,
15793 struct file_name_list
*searchptr
);
15794 static void print_containing_files (ffebadSeverity sev
);
15795 static char *skip_redundant_dir_prefix (char *);
15796 static char *read_filename_string (int ch
, FILE *f
);
15797 static struct file_name_map
*read_name_map (char *dirname
);
15798 static char *savestring (char *input
);
15800 /* Append a chain of `struct file_name_list's
15801 to the end of the main include chain.
15802 FIRST is the beginning of the chain to append, and LAST is the end. */
15805 append_include_chain (first
, last
)
15806 struct file_name_list
*first
, *last
;
15808 struct file_name_list
*dir
;
15810 if (!first
|| !last
)
15816 last_include
->next
= first
;
15818 for (dir
= first
; ; dir
= dir
->next
) {
15819 int len
= strlen (dir
->fname
) + INCLUDE_LEN_FUDGE
;
15820 if (len
> max_include_len
)
15821 max_include_len
= len
;
15827 last_include
= last
;
15830 /* Try to open include file FILENAME. SEARCHPTR is the directory
15831 being tried from the include file search path. This function maps
15832 filenames on file systems based on information read by
15836 open_include_file (filename
, searchptr
)
15838 struct file_name_list
*searchptr
;
15840 register struct file_name_map
*map
;
15841 register char *from
;
15844 if (searchptr
&& ! searchptr
->got_name_map
)
15846 searchptr
->name_map
= read_name_map (searchptr
->fname
15847 ? searchptr
->fname
: ".");
15848 searchptr
->got_name_map
= 1;
15851 /* First check the mapping for the directory we are using. */
15852 if (searchptr
&& searchptr
->name_map
)
15855 if (searchptr
->fname
)
15856 from
+= strlen (searchptr
->fname
) + 1;
15857 for (map
= searchptr
->name_map
; map
; map
= map
->map_next
)
15859 if (! strcmp (map
->map_from
, from
))
15861 /* Found a match. */
15862 return fopen (map
->map_to
, "r");
15867 /* Try to find a mapping file for the particular directory we are
15868 looking in. Thus #include <sys/types.h> will look up sys/types.h
15869 in /usr/include/header.gcc and look up types.h in
15870 /usr/include/sys/header.gcc. */
15871 p
= rindex (filename
, '/');
15872 #ifdef DIR_SEPARATOR
15873 if (! p
) p
= rindex (filename
, DIR_SEPARATOR
);
15875 char *tmp
= rindex (filename
, DIR_SEPARATOR
);
15876 if (tmp
!= NULL
&& tmp
> p
) p
= tmp
;
15882 && searchptr
->fname
15883 && strlen (searchptr
->fname
) == (size_t) (p
- filename
)
15884 && ! strncmp (searchptr
->fname
, filename
, (int) (p
- filename
)))
15886 /* FILENAME is in SEARCHPTR, which we've already checked. */
15887 return fopen (filename
, "r");
15893 map
= read_name_map (".");
15897 dir
= (char *) xmalloc (p
- filename
+ 1);
15898 memcpy (dir
, filename
, p
- filename
);
15899 dir
[p
- filename
] = '\0';
15901 map
= read_name_map (dir
);
15904 for (; map
; map
= map
->map_next
)
15905 if (! strcmp (map
->map_from
, from
))
15906 return fopen (map
->map_to
, "r");
15908 return fopen (filename
, "r");
15911 /* Print the file names and line numbers of the #include
15912 commands which led to the current file. */
15915 print_containing_files (ffebadSeverity sev
)
15917 FILE_BUF
*ip
= NULL
;
15923 /* If stack of files hasn't changed since we last printed
15924 this info, don't repeat it. */
15925 if (last_error_tick
== input_file_stack_tick
)
15928 for (i
= indepth
; i
>= 0; i
--)
15929 if (instack
[i
].fname
!= NULL
) {
15934 /* Give up if we don't find a source file. */
15938 /* Find the other, outer source files. */
15939 for (i
--; i
>= 0; i
--)
15940 if (instack
[i
].fname
!= NULL
)
15946 str1
= "In file included";
15958 ffebad_start_msg ("%A from %B at %0%C", sev
);
15959 ffebad_here (0, ip
->line
, ip
->column
);
15960 ffebad_string (str1
);
15961 ffebad_string (ip
->nominal_fname
);
15962 ffebad_string (str2
);
15966 /* Record we have printed the status as of this time. */
15967 last_error_tick
= input_file_stack_tick
;
15970 /* Read a space delimited string of unlimited length from a stdio
15974 read_filename_string (ch
, f
)
15982 set
= alloc
= xmalloc (len
+ 1);
15983 if (! is_space
[ch
])
15986 while ((ch
= getc (f
)) != EOF
&& ! is_space
[ch
])
15988 if (set
- alloc
== len
)
15991 alloc
= xrealloc (alloc
, len
+ 1);
15992 set
= alloc
+ len
/ 2;
16002 /* Read the file name map file for DIRNAME. */
16004 static struct file_name_map
*
16005 read_name_map (dirname
)
16008 /* This structure holds a linked list of file name maps, one per
16010 struct file_name_map_list
16012 struct file_name_map_list
*map_list_next
;
16013 char *map_list_name
;
16014 struct file_name_map
*map_list_map
;
16016 static struct file_name_map_list
*map_list
;
16017 register struct file_name_map_list
*map_list_ptr
;
16021 int separator_needed
;
16023 dirname
= skip_redundant_dir_prefix (dirname
);
16025 for (map_list_ptr
= map_list
; map_list_ptr
;
16026 map_list_ptr
= map_list_ptr
->map_list_next
)
16027 if (! strcmp (map_list_ptr
->map_list_name
, dirname
))
16028 return map_list_ptr
->map_list_map
;
16030 map_list_ptr
= ((struct file_name_map_list
*)
16031 xmalloc (sizeof (struct file_name_map_list
)));
16032 map_list_ptr
->map_list_name
= savestring (dirname
);
16033 map_list_ptr
->map_list_map
= NULL
;
16035 dirlen
= strlen (dirname
);
16036 separator_needed
= dirlen
!= 0 && dirname
[dirlen
- 1] != '/';
16037 name
= (char *) xmalloc (dirlen
+ strlen (FILE_NAME_MAP_FILE
) + 2);
16038 strcpy (name
, dirname
);
16039 name
[dirlen
] = '/';
16040 strcpy (name
+ dirlen
+ separator_needed
, FILE_NAME_MAP_FILE
);
16041 f
= fopen (name
, "r");
16044 map_list_ptr
->map_list_map
= NULL
;
16049 while ((ch
= getc (f
)) != EOF
)
16052 struct file_name_map
*ptr
;
16056 from
= read_filename_string (ch
, f
);
16057 while ((ch
= getc (f
)) != EOF
&& is_hor_space
[ch
])
16059 to
= read_filename_string (ch
, f
);
16061 ptr
= ((struct file_name_map
*)
16062 xmalloc (sizeof (struct file_name_map
)));
16063 ptr
->map_from
= from
;
16065 /* Make the real filename absolute. */
16070 ptr
->map_to
= xmalloc (dirlen
+ strlen (to
) + 2);
16071 strcpy (ptr
->map_to
, dirname
);
16072 ptr
->map_to
[dirlen
] = '/';
16073 strcpy (ptr
->map_to
+ dirlen
+ separator_needed
, to
);
16077 ptr
->map_next
= map_list_ptr
->map_list_map
;
16078 map_list_ptr
->map_list_map
= ptr
;
16080 while ((ch
= getc (f
)) != '\n')
16087 map_list_ptr
->map_list_next
= map_list
;
16088 map_list
= map_list_ptr
;
16090 return map_list_ptr
->map_list_map
;
16097 unsigned size
= strlen (input
);
16098 char *output
= xmalloc (size
+ 1);
16099 strcpy (output
, input
);
16104 ffecom_file_ (char *name
)
16108 /* Do partial setup of input buffer for the sake of generating
16109 early #line directives (when -g is in effect). */
16111 fp
= &instack
[++indepth
];
16112 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
16115 fp
->nominal_fname
= fp
->fname
= name
;
16118 /* Initialize syntactic classifications of characters. */
16121 ffecom_initialize_char_syntax_ ()
16126 * Set up is_idchar and is_idstart tables. These should be
16127 * faster than saying (is_alpha (c) || c == '_'), etc.
16128 * Set up these things before calling any routines tthat
16131 for (i
= 'a'; i
<= 'z'; i
++) {
16132 is_idchar
[i
- 'a' + 'A'] = 1;
16134 is_idstart
[i
- 'a' + 'A'] = 1;
16137 for (i
= '0'; i
<= '9'; i
++)
16139 is_idchar
['_'] = 1;
16140 is_idstart
['_'] = 1;
16142 /* horizontal space table */
16143 is_hor_space
[' '] = 1;
16144 is_hor_space
['\t'] = 1;
16145 is_hor_space
['\v'] = 1;
16146 is_hor_space
['\f'] = 1;
16147 is_hor_space
['\r'] = 1;
16150 is_space
['\t'] = 1;
16151 is_space
['\v'] = 1;
16152 is_space
['\f'] = 1;
16153 is_space
['\n'] = 1;
16154 is_space
['\r'] = 1;
16158 ffecom_close_include_ (FILE *f
)
16163 input_file_stack_tick
++;
16165 ffewhere_line_kill (instack
[indepth
].line
);
16166 ffewhere_column_kill (instack
[indepth
].column
);
16170 ffecom_decode_include_option_ (char *spec
)
16172 struct file_name_list
*dirtmp
;
16174 if (! ignore_srcdir
&& !strcmp (spec
, "-"))
16178 dirtmp
= (struct file_name_list
*)
16179 xmalloc (sizeof (struct file_name_list
));
16180 dirtmp
->next
= 0; /* New one goes on the end */
16182 dirtmp
->fname
= spec
;
16184 fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16185 dirtmp
->got_name_map
= 0;
16186 append_include_chain (dirtmp
, dirtmp
);
16191 /* Open INCLUDEd file. */
16194 ffecom_open_include_ (char *name
, ffewhereLine l
, ffewhereColumn c
)
16197 size_t flen
= strlen (fbeg
);
16198 struct file_name_list
*search_start
= include
; /* Chain of dirs to search */
16199 struct file_name_list dsp
[1]; /* First in chain, if #include "..." */
16200 struct file_name_list
*searchptr
= 0;
16201 char *fname
; /* Dynamically allocated fname buffer */
16208 dsp
[0].fname
= NULL
;
16210 /* If -I- was specified, don't search current dir, only spec'd ones. */
16211 if (!ignore_srcdir
)
16213 for (fp
= &instack
[indepth
]; fp
>= instack
; fp
--)
16219 if ((nam
= fp
->nominal_fname
) != NULL
)
16221 /* Found a named file. Figure out dir of the file,
16222 and put it in front of the search list. */
16223 dsp
[0].next
= search_start
;
16224 search_start
= dsp
;
16226 ep
= rindex (nam
, '/');
16227 #ifdef DIR_SEPARATOR
16228 if (ep
== NULL
) ep
= rindex (nam
, DIR_SEPARATOR
);
16230 char *tmp
= rindex (nam
, DIR_SEPARATOR
);
16231 if (tmp
!= NULL
&& tmp
> ep
) ep
= tmp
;
16235 ep
= rindex (nam
, ']');
16236 if (ep
== NULL
) ep
= rindex (nam
, '>');
16237 if (ep
== NULL
) ep
= rindex (nam
, ':');
16238 if (ep
!= NULL
) ep
++;
16243 dsp
[0].fname
= (char *) xmalloc (n
+ 1);
16244 strncpy (dsp
[0].fname
, nam
, n
);
16245 dsp
[0].fname
[n
] = '\0';
16246 if (n
+ INCLUDE_LEN_FUDGE
> max_include_len
)
16247 max_include_len
= n
+ INCLUDE_LEN_FUDGE
;
16250 dsp
[0].fname
= NULL
; /* Current directory */
16251 dsp
[0].got_name_map
= 0;
16257 /* Allocate this permanently, because it gets stored in the definitions
16259 fname
= xmalloc (max_include_len
+ flen
+ 4);
16260 /* + 2 above for slash and terminating null. */
16261 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16264 /* If specified file name is absolute, just open it. */
16267 #ifdef DIR_SEPARATOR
16268 || *fbeg
== DIR_SEPARATOR
16272 strncpy (fname
, (char *) fbeg
, flen
);
16274 f
= open_include_file (fname
, NULL_PTR
);
16280 /* Search directory path, trying to open the file.
16281 Copy each filename tried into FNAME. */
16283 for (searchptr
= search_start
; searchptr
; searchptr
= searchptr
->next
)
16285 if (searchptr
->fname
)
16287 /* The empty string in a search path is ignored.
16288 This makes it possible to turn off entirely
16289 a standard piece of the list. */
16290 if (searchptr
->fname
[0] == 0)
16292 strcpy (fname
, skip_redundant_dir_prefix (searchptr
->fname
));
16293 if (fname
[0] && fname
[strlen (fname
) - 1] != '/')
16294 strcat (fname
, "/");
16295 fname
[strlen (fname
) + flen
] = 0;
16300 strncat (fname
, fbeg
, flen
);
16302 /* Change this 1/2 Unix 1/2 VMS file specification into a
16303 full VMS file specification */
16304 if (searchptr
->fname
&& (searchptr
->fname
[0] != 0))
16306 /* Fix up the filename */
16307 hack_vms_include_specification (fname
);
16311 /* This is a normal VMS filespec, so use it unchanged. */
16312 strncpy (fname
, (char *) fbeg
, flen
);
16314 #if 0 /* Not for g77. */
16315 /* if it's '#include filename', add the missing .h */
16316 if (index (fname
, '.') == NULL
)
16317 strcat (fname
, ".h");
16321 f
= open_include_file (fname
, searchptr
);
16323 if (f
== NULL
&& errno
== EACCES
)
16325 print_containing_files (FFEBAD_severityWARNING
);
16326 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16327 FFEBAD_severityWARNING
);
16328 ffebad_string (fname
);
16329 ffebad_here (0, l
, c
);
16340 /* A file that was not found. */
16342 strncpy (fname
, (char *) fbeg
, flen
);
16344 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE
));
16345 ffebad_start (FFEBAD_OPEN_INCLUDE
);
16346 ffebad_here (0, l
, c
);
16347 ffebad_string (fname
);
16351 if (dsp
[0].fname
!= NULL
)
16352 free (dsp
[0].fname
);
16357 if (indepth
>= (INPUT_STACK_MAX
- 1))
16359 print_containing_files (FFEBAD_severityFATAL
);
16360 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16361 FFEBAD_severityFATAL
);
16362 ffebad_string (fname
);
16363 ffebad_here (0, l
, c
);
16368 instack
[indepth
].line
= ffewhere_line_use (l
);
16369 instack
[indepth
].column
= ffewhere_column_use (c
);
16371 fp
= &instack
[indepth
+ 1];
16372 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
16373 fp
->nominal_fname
= fp
->fname
= fname
;
16374 fp
->dir
= searchptr
;
16377 input_file_stack_tick
++;
16381 #endif /* FFECOM_GCC_INCLUDE */