1 /* com.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
3 Free Software Foundation, Inc.
4 Contributed by James Craig Burley.
6 This file is part of GNU Fortran.
8 GNU Fortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU Fortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Fortran; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
27 Contains compiler-specific functions.
32 /* Understanding this module means understanding the interface between
33 the g77 front end and the gcc back end (or, perhaps, some other
34 back end). In here are the functions called by the front end proper
35 to notify whatever back end is in place about certain things, and
36 also the back-end-specific functions. It's a bear to deal with, so
37 lately I've been trying to simplify things, especially with regard
38 to the gcc-back-end-specific stuff.
40 Building expressions generally seems quite easy, but building decls
41 has been challenging and is undergoing revision. gcc has several
44 TYPE_DECL -- a type (int, float, struct, function, etc.)
45 CONST_DECL -- a constant of some type other than function
46 LABEL_DECL -- a variable or a constant?
47 PARM_DECL -- an argument to a function (a variable that is a dummy)
48 RESULT_DECL -- the return value of a function (a variable)
49 VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
50 FUNCTION_DECL -- a function (either the actual function or an extern ref)
51 FIELD_DECL -- a field in a struct or union (goes into types)
53 g77 has a set of functions that somewhat parallels the gcc front end
54 when it comes to building decls:
56 Internal Function (one we define, not just declare as extern):
57 if (is_nested) push_f_function_context ();
58 start_function (get_identifier ("function_name"), function_type,
59 is_nested, is_public);
60 // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
61 store_parm_decls (is_main_program);
62 ffecom_start_compstmt ();
63 // for stmts and decls inside function, do appropriate things;
64 ffecom_end_compstmt ();
65 finish_function (is_nested);
66 if (is_nested) pop_f_function_context ();
71 // fill in external, public, static, &c for decl, and
72 // set DECL_INITIAL to error_mark_node if going to initialize
73 // set is_top_level TRUE only if not at top level and decl
74 // must go in top level (i.e. not within current function decl context)
75 d = start_decl (decl, is_top_level);
76 init = ...; // if have initializer
77 finish_decl (d, init, is_top_level);
84 #if FFECOM_targetCURRENT == FFECOM_targetGCC
89 #include "output.h" /* Must follow tree.h so TREE_CODE is defined! */
92 #include "diagnostic.h"
93 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
95 #define FFECOM_GCC_INCLUDE 1 /* Enable -I. */
97 /* VMS-specific definitions */
100 #define O_RDONLY 0 /* Open arg for Read/Only */
101 #define O_WRONLY 1 /* Open arg for Write/Only */
102 #define read(fd,buf,size) VMS_read (fd,buf,size)
103 #define write(fd,buf,size) VMS_write (fd,buf,size)
104 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
105 #define fopen(fname,mode) VMS_fopen (fname,mode)
106 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
107 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
108 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
109 static int VMS_fstat (), VMS_stat ();
110 static char * VMS_strncat ();
111 static int VMS_read ();
112 static int VMS_write ();
113 static int VMS_open ();
114 static FILE * VMS_fopen ();
115 static FILE * VMS_freopen ();
116 static void hack_vms_include_specification ();
117 typedef struct { unsigned :16, :16, :16; } vms_ino_t
;
118 #define ino_t vms_ino_t
119 #define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */
122 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
139 /* Externals defined here. */
141 #if FFECOM_targetCURRENT == FFECOM_targetGCC
143 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
146 const char * const language_string
= "GNU F77";
148 /* Stream for reading from the input file. */
151 /* These definitions parallel those in c-decl.c so that code from that
152 module can be used pretty much as is. Much of these defs aren't
153 otherwise used, i.e. by g77 code per se, except some of them are used
154 to build some of them that are. The ones that are global (i.e. not
155 "static") are those that ste.c and such might use (directly
156 or by using com macros that reference them in their definitions). */
158 tree string_type_node
;
160 /* The rest of these are inventions for g77, though there might be
161 similar things in the C front end. As they are found, these
162 inventions should be renamed to be canonical. Note that only
163 the ones currently required to be global are so. */
165 static tree ffecom_tree_fun_type_void
;
167 tree ffecom_integer_type_node
; /* Abbrev for _tree_type[blah][blah]. */
168 tree ffecom_integer_zero_node
; /* Like *_*_* with g77's integer type. */
169 tree ffecom_integer_one_node
; /* " */
170 tree ffecom_tree_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
172 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
173 just use build_function_type and build_pointer_type on the
174 appropriate _tree_type array element. */
176 static tree ffecom_tree_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
177 static tree ffecom_tree_ptr_to_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
178 static tree ffecom_tree_subr_type
;
179 static tree ffecom_tree_ptr_to_subr_type
;
180 static tree ffecom_tree_blockdata_type
;
182 static tree ffecom_tree_xargc_
;
184 ffecomSymbol ffecom_symbol_null_
193 ffeinfoKindtype ffecom_pointer_kind_
= FFEINFO_basictypeNONE
;
194 ffeinfoKindtype ffecom_label_kind_
= FFEINFO_basictypeNONE
;
196 int ffecom_f2c_typecode_
[FFEINFO_basictype
][FFEINFO_kindtype
];
197 tree ffecom_f2c_integer_type_node
;
198 tree ffecom_f2c_ptr_to_integer_type_node
;
199 tree ffecom_f2c_address_type_node
;
200 tree ffecom_f2c_real_type_node
;
201 tree ffecom_f2c_ptr_to_real_type_node
;
202 tree ffecom_f2c_doublereal_type_node
;
203 tree ffecom_f2c_complex_type_node
;
204 tree ffecom_f2c_doublecomplex_type_node
;
205 tree ffecom_f2c_longint_type_node
;
206 tree ffecom_f2c_logical_type_node
;
207 tree ffecom_f2c_flag_type_node
;
208 tree ffecom_f2c_ftnlen_type_node
;
209 tree ffecom_f2c_ftnlen_zero_node
;
210 tree ffecom_f2c_ftnlen_one_node
;
211 tree ffecom_f2c_ftnlen_two_node
;
212 tree ffecom_f2c_ptr_to_ftnlen_type_node
;
213 tree ffecom_f2c_ftnint_type_node
;
214 tree ffecom_f2c_ptr_to_ftnint_type_node
;
215 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
217 /* Simple definitions and enumerations. */
219 #ifndef FFECOM_sizeMAXSTACKITEM
220 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
221 larger than this # bytes
222 off stack if possible. */
225 /* For systems that have large enough stacks, they should define
226 this to 0, and here, for ease of use later on, we just undefine
229 #if FFECOM_sizeMAXSTACKITEM == 0
230 #undef FFECOM_sizeMAXSTACKITEM
236 FFECOM_rttypeVOIDSTAR_
, /* C's `void *' type. */
237 FFECOM_rttypeFTNINT_
, /* f2c's `ftnint' type. */
238 FFECOM_rttypeINTEGER_
, /* f2c's `integer' type. */
239 FFECOM_rttypeLONGINT_
, /* f2c's `longint' type. */
240 FFECOM_rttypeLOGICAL_
, /* f2c's `logical' type. */
241 FFECOM_rttypeREAL_F2C_
, /* f2c's `real' returned as `double'. */
242 FFECOM_rttypeREAL_GNU_
, /* `real' returned as such. */
243 FFECOM_rttypeCOMPLEX_F2C_
, /* f2c's `complex' returned via 1st arg. */
244 FFECOM_rttypeCOMPLEX_GNU_
, /* f2c's `complex' returned directly. */
245 FFECOM_rttypeDOUBLE_
, /* C's `double' type. */
246 FFECOM_rttypeDOUBLEREAL_
, /* f2c's `doublereal' type. */
247 FFECOM_rttypeDBLCMPLX_F2C_
, /* f2c's `doublecomplex' returned via 1st arg. */
248 FFECOM_rttypeDBLCMPLX_GNU_
, /* f2c's `doublecomplex' returned directly. */
249 FFECOM_rttypeCHARACTER_
, /* f2c `char *'/`ftnlen' pair. */
253 /* Internal typedefs. */
255 #if FFECOM_targetCURRENT == FFECOM_targetGCC
256 typedef struct _ffecom_concat_list_ ffecomConcatList_
;
257 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
259 /* Private include files. */
262 /* Internal structure definitions. */
264 #if FFECOM_targetCURRENT == FFECOM_targetGCC
265 struct _ffecom_concat_list_
270 ffetargetCharacterSize minlen
;
271 ffetargetCharacterSize maxlen
;
273 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
275 /* Static functions (internal). */
277 #if FFECOM_targetCURRENT == FFECOM_targetGCC
278 static tree
ffecom_arglist_expr_ (const char *argstring
, ffebld args
);
279 static tree
ffecom_widest_expr_type_ (ffebld list
);
280 static bool ffecom_overlap_ (tree dest_decl
, tree dest_offset
,
281 tree dest_size
, tree source_tree
,
282 ffebld source
, bool scalar_arg
);
283 static bool ffecom_args_overlapping_ (tree dest_tree
, ffebld dest
,
284 tree args
, tree callee_commons
,
286 static tree
ffecom_build_f2c_string_ (int i
, const char *s
);
287 static tree
ffecom_call_ (tree fn
, ffeinfoKindtype kt
,
288 bool is_f2c_complex
, tree type
,
289 tree args
, tree dest_tree
,
290 ffebld dest
, bool *dest_used
,
291 tree callee_commons
, bool scalar_args
, tree hook
);
292 static tree
ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
,
293 bool is_f2c_complex
, tree type
,
294 ffebld left
, ffebld right
,
295 tree dest_tree
, ffebld dest
,
296 bool *dest_used
, tree callee_commons
,
297 bool scalar_args
, bool ref
, tree hook
);
298 static void ffecom_char_args_x_ (tree
*xitem
, tree
*length
,
299 ffebld expr
, bool with_null
);
300 static tree
ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
);
301 static tree
ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
);
302 static ffecomConcatList_
303 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
,
305 ffetargetCharacterSize max
);
306 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist
);
307 static ffecomConcatList_
ffecom_concat_list_new_ (ffebld expr
,
308 ffetargetCharacterSize max
);
309 static void ffecom_debug_kludge_ (tree aggr
, const char *aggr_type
,
310 ffesymbol member
, tree member_type
,
311 ffetargetOffset offset
);
312 static void ffecom_do_entry_ (ffesymbol fn
, int entrynum
);
313 static tree
ffecom_expr_ (ffebld expr
, tree dest_tree
, ffebld dest
,
314 bool *dest_used
, bool assignp
, bool widenp
);
315 static tree
ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
316 ffebld dest
, bool *dest_used
);
317 static tree
ffecom_expr_power_integer_ (ffebld expr
);
318 static void ffecom_expr_transform_ (ffebld expr
);
319 static void ffecom_f2c_make_type_ (tree
*type
, int tcode
, const char *name
);
320 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
322 static ffeglobal
ffecom_finish_global_ (ffeglobal global
);
323 static ffesymbol
ffecom_finish_symbol_transform_ (ffesymbol s
);
324 static tree
ffecom_get_appended_identifier_ (char us
, const char *text
);
325 static tree
ffecom_get_external_identifier_ (ffesymbol s
);
326 static tree
ffecom_get_identifier_ (const char *text
);
327 static tree
ffecom_gen_sfuncdef_ (ffesymbol s
,
330 static const char *ffecom_gfrt_args_ (ffecomGfrt ix
);
331 static tree
ffecom_gfrt_tree_ (ffecomGfrt ix
);
332 static tree
ffecom_init_zero_ (tree decl
);
333 static tree
ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
335 static tree
ffecom_intrinsic_len_ (ffebld expr
);
336 static void ffecom_let_char_ (tree dest_tree
,
338 ffetargetCharacterSize dest_size
,
340 static void ffecom_make_gfrt_ (ffecomGfrt ix
);
341 static void ffecom_member_phase1_ (ffestorag mst
, ffestorag st
);
342 static void ffecom_member_phase2_ (ffestorag mst
, ffestorag st
);
343 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size
,
345 static void ffecom_push_dummy_decls_ (ffebld dumlist
,
347 static void ffecom_start_progunit_ (void);
348 static ffesymbol
ffecom_sym_transform_ (ffesymbol s
);
349 static ffesymbol
ffecom_sym_transform_assign_ (ffesymbol s
);
350 static void ffecom_transform_common_ (ffesymbol s
);
351 static void ffecom_transform_equiv_ (ffestorag st
);
352 static tree
ffecom_transform_namelist_ (ffesymbol s
);
353 static void ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
355 static void ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
356 tree
*size
, tree tree
);
357 static tree
ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
358 tree dest_tree
, ffebld dest
,
359 bool *dest_used
, tree hook
);
360 static tree
ffecom_type_localvar_ (ffesymbol s
,
363 static tree
ffecom_type_namelist_ (void);
364 static tree
ffecom_type_vardesc_ (void);
365 static tree
ffecom_vardesc_ (ffebld expr
);
366 static tree
ffecom_vardesc_array_ (ffesymbol s
);
367 static tree
ffecom_vardesc_dims_ (ffesymbol s
);
368 static tree
ffecom_convert_narrow_ (tree type
, tree expr
);
369 static tree
ffecom_convert_widen_ (tree type
, tree expr
);
370 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
372 /* These are static functions that parallel those found in the C front
373 end and thus have the same names. */
375 #if FFECOM_targetCURRENT == FFECOM_targetGCC
376 static tree
bison_rule_compstmt_ (void);
377 static void bison_rule_pushlevel_ (void);
378 static void delete_block (tree block
);
379 static int duplicate_decls (tree newdecl
, tree olddecl
);
380 static void finish_decl (tree decl
, tree init
, bool is_top_level
);
381 static void finish_function (int nested
);
382 static const char *lang_printable_name (tree decl
, int v
);
383 static tree
lookup_name_current_level (tree name
);
384 static struct binding_level
*make_binding_level (void);
385 static void pop_f_function_context (void);
386 static void push_f_function_context (void);
387 static void push_parm_decl (tree parm
);
388 static tree
pushdecl_top_level (tree decl
);
389 static int kept_level_p (void);
390 static tree
storedecls (tree decls
);
391 static void store_parm_decls (int is_main_program
);
392 static tree
start_decl (tree decl
, bool is_top_level
);
393 static void start_function (tree name
, tree type
, int nested
, int public);
394 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
395 #if FFECOM_GCC_INCLUDE
396 static void ffecom_file_ (const char *name
);
397 static void ffecom_initialize_char_syntax_ (void);
398 static void ffecom_close_include_ (FILE *f
);
399 static int ffecom_decode_include_option_ (char *spec
);
400 static FILE *ffecom_open_include_ (char *name
, ffewhereLine l
,
402 #endif /* FFECOM_GCC_INCLUDE */
404 /* Static objects accessed by functions in this module. */
406 static ffesymbol ffecom_primary_entry_
= NULL
;
407 static ffesymbol ffecom_nested_entry_
= NULL
;
408 static ffeinfoKind ffecom_primary_entry_kind_
;
409 static bool ffecom_primary_entry_is_proc_
;
410 #if FFECOM_targetCURRENT == FFECOM_targetGCC
411 static tree ffecom_outer_function_decl_
;
412 static tree ffecom_previous_function_decl_
;
413 static tree ffecom_which_entrypoint_decl_
;
414 static tree ffecom_float_zero_
= NULL_TREE
;
415 static tree ffecom_float_half_
= NULL_TREE
;
416 static tree ffecom_double_zero_
= NULL_TREE
;
417 static tree ffecom_double_half_
= NULL_TREE
;
418 static tree ffecom_func_result_
;/* For functions. */
419 static tree ffecom_func_length_
;/* For CHARACTER fns. */
420 static ffebld ffecom_list_blockdata_
;
421 static ffebld ffecom_list_common_
;
422 static ffebld ffecom_master_arglist_
;
423 static ffeinfoBasictype ffecom_master_bt_
;
424 static ffeinfoKindtype ffecom_master_kt_
;
425 static ffetargetCharacterSize ffecom_master_size_
;
426 static int ffecom_num_fns_
= 0;
427 static int ffecom_num_entrypoints_
= 0;
428 static bool ffecom_is_altreturning_
= FALSE
;
429 static tree ffecom_multi_type_node_
;
430 static tree ffecom_multi_retval_
;
432 ffecom_multi_fields_
[FFEINFO_basictype
][FFEINFO_kindtype
];
433 static bool ffecom_member_namelisted_
; /* _member_phase1_ namelisted? */
434 static bool ffecom_doing_entry_
= FALSE
;
435 static bool ffecom_transform_only_dummies_
= FALSE
;
436 static int ffecom_typesize_pointer_
;
437 static int ffecom_typesize_integer1_
;
439 /* Holds pointer-to-function expressions. */
441 static tree ffecom_gfrt_
[FFECOM_gfrt
]
444 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
445 #include "com-rt.def"
449 /* Holds the external names of the functions. */
451 static const char *const ffecom_gfrt_name_
[FFECOM_gfrt
]
454 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
455 #include "com-rt.def"
459 /* Whether the function returns. */
461 static bool ffecom_gfrt_volatile_
[FFECOM_gfrt
]
464 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
465 #include "com-rt.def"
469 /* Whether the function returns type complex. */
471 static bool ffecom_gfrt_complex_
[FFECOM_gfrt
]
474 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
475 #include "com-rt.def"
479 /* Whether the function is const
480 (i.e., has no side effects and only depends on its arguments). */
482 static bool ffecom_gfrt_const_
[FFECOM_gfrt
]
485 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
486 #include "com-rt.def"
490 /* Type code for the function return value. */
492 static ffecomRttype_ ffecom_gfrt_type_
[FFECOM_gfrt
]
495 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
496 #include "com-rt.def"
500 /* String of codes for the function's arguments. */
502 static const char *const ffecom_gfrt_argstring_
[FFECOM_gfrt
]
505 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
506 #include "com-rt.def"
509 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
511 /* Internal macros. */
513 #if FFECOM_targetCURRENT == FFECOM_targetGCC
515 /* We let tm.h override the types used here, to handle trivial differences
516 such as the choice of unsigned int or long unsigned int for size_t.
517 When machines start needing nontrivial differences in the size type,
518 it would be best to do something here to figure out automatically
519 from other information what type to use. */
522 #define SIZE_TYPE "long unsigned int"
525 #define ffecom_concat_list_count_(catlist) ((catlist).count)
526 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
527 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
528 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
530 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
531 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
533 /* For each binding contour we allocate a binding_level structure
534 * which records the names defined in that contour.
537 * 1) one for each function definition,
538 * where internal declarations of the parameters appear.
540 * The current meaning of a name can be found by searching the levels from
541 * the current one out to the global one.
544 /* Note that the information in the `names' component of the global contour
545 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
549 /* A chain of _DECL nodes for all variables, constants, functions,
550 and typedef types. These are in the reverse of the order supplied.
554 /* For each level (except not the global one),
555 a chain of BLOCK nodes for all the levels
556 that were entered and exited one level down. */
559 /* The BLOCK node for this level, if one has been preallocated.
560 If 0, the BLOCK is allocated (if needed) when the level is popped. */
563 /* The binding level which this one is contained in (inherits from). */
564 struct binding_level
*level_chain
;
566 /* 0: no ffecom_prepare_* functions called at this level yet;
567 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
568 2: ffecom_prepare_end called. */
572 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
574 /* The binding level currently in effect. */
576 static struct binding_level
*current_binding_level
;
578 /* A chain of binding_level structures awaiting reuse. */
580 static struct binding_level
*free_binding_level
;
582 /* The outermost binding level, for names of file scope.
583 This is created when the compiler is started and exists
584 through the entire run. */
586 static struct binding_level
*global_binding_level
;
588 /* Binding level structures are initialized by copying this one. */
590 static struct binding_level clear_binding_level
592 {NULL
, NULL
, NULL
, NULL_BINDING_LEVEL
, 0};
594 /* Language-dependent contents of an identifier. */
596 struct lang_identifier
598 struct tree_identifier ignore
;
599 tree global_value
, local_value
, label_value
;
603 /* Macros for access to language-specific slots in an identifier. */
604 /* Each of these slots contains a DECL node or null. */
606 /* This represents the value which the identifier has in the
607 file-scope namespace. */
608 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
609 (((struct lang_identifier *)(NODE))->global_value)
610 /* This represents the value which the identifier has in the current
612 #define IDENTIFIER_LOCAL_VALUE(NODE) \
613 (((struct lang_identifier *)(NODE))->local_value)
614 /* This represents the value which the identifier has as a label in
615 the current label scope. */
616 #define IDENTIFIER_LABEL_VALUE(NODE) \
617 (((struct lang_identifier *)(NODE))->label_value)
618 /* This is nonzero if the identifier was "made up" by g77 code. */
619 #define IDENTIFIER_INVENTED(NODE) \
620 (((struct lang_identifier *)(NODE))->invented)
622 /* In identifiers, C uses the following fields in a special way:
623 TREE_PUBLIC to record that there was a previous local extern decl.
624 TREE_USED to record that such a decl was used.
625 TREE_ADDRESSABLE to record that the address of such a decl was used. */
627 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
628 that have names. Here so we can clear out their names' definitions
629 at the end of the function. */
631 static tree named_labels
;
633 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
635 static tree shadowed_labels
;
637 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
639 /* Return the subscript expression, modified to do range-checking.
641 `array' is the array to be checked against.
642 `element' is the subscript expression to check.
643 `dim' is the dimension number (starting at 0).
644 `total_dims' is the total number of dimensions (0 for CHARACTER substring).
648 ffecom_subscript_check_ (tree array
, tree element
, int dim
, int total_dims
,
649 const char *array_name
)
651 tree low
= TYPE_MIN_VALUE (TYPE_DOMAIN (array
));
652 tree high
= TYPE_MAX_VALUE (TYPE_DOMAIN (array
));
657 if (element
== error_mark_node
)
660 if (TREE_TYPE (low
) != TREE_TYPE (element
))
662 if (TYPE_PRECISION (TREE_TYPE (low
))
663 > TYPE_PRECISION (TREE_TYPE (element
)))
664 element
= convert (TREE_TYPE (low
), element
);
667 low
= convert (TREE_TYPE (element
), low
);
669 high
= convert (TREE_TYPE (element
), high
);
673 element
= ffecom_save_tree (element
);
676 /* Special handling for substring range checks. Fortran allows the
677 end subscript < begin subscript, which means that expressions like
678 string(1:0) are valid (and yield a null string). In view of this,
679 enforce two simpler conditions:
680 1) element<=high for end-substring;
681 2) element>=low for start-substring.
682 Run-time character movement will enforce remaining conditions.
684 More complicated checks would be better, but present structure only
685 provides one index element at a time, so it is not possible to
686 enforce a check of both i and j in string(i:j). If it were, the
687 complete set of rules would read,
688 if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
689 ((low<=i<=high) && (low<=j<=high)) )
695 cond
= ffecom_2 (LE_EXPR
, integer_type_node
, element
, high
);
697 cond
= ffecom_2 (LE_EXPR
, integer_type_node
, low
, element
);
701 /* Array reference substring range checking. */
703 cond
= ffecom_2 (LE_EXPR
, integer_type_node
,
708 cond
= ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
710 ffecom_2 (LE_EXPR
, integer_type_node
,
728 var
= concat (array_name
, "[", (dim
? "end" : "start"),
729 "-substring]", NULL
);
730 len
= strlen (var
) + 1;
731 arg1
= build_string (len
, var
);
736 len
= strlen (array_name
) + 1;
737 arg1
= build_string (len
, array_name
);
741 var
= xmalloc (strlen (array_name
) + 40);
742 sprintf (var
, "%s[subscript-%d-of-%d]",
744 dim
+ 1, total_dims
);
745 len
= strlen (var
) + 1;
746 arg1
= build_string (len
, var
);
752 = build_type_variant (build_array_type (char_type_node
,
756 build_int_2 (len
, 0))),
758 TREE_CONSTANT (arg1
) = 1;
759 TREE_STATIC (arg1
) = 1;
760 arg1
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (arg1
)),
763 /* s_rnge adds one to the element to print it, so bias against
764 that -- want to print a faithful *subscript* value. */
765 arg2
= convert (ffecom_f2c_ftnint_type_node
,
766 ffecom_2 (MINUS_EXPR
,
769 convert (TREE_TYPE (element
),
772 proc
= concat (input_filename
, "/",
773 IDENTIFIER_POINTER (DECL_NAME (current_function_decl
)),
775 len
= strlen (proc
) + 1;
776 arg3
= build_string (len
, proc
);
781 = build_type_variant (build_array_type (char_type_node
,
785 build_int_2 (len
, 0))),
787 TREE_CONSTANT (arg3
) = 1;
788 TREE_STATIC (arg3
) = 1;
789 arg3
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (arg3
)),
792 arg4
= convert (ffecom_f2c_ftnint_type_node
,
793 build_int_2 (lineno
, 0));
795 arg1
= build_tree_list (NULL_TREE
, arg1
);
796 arg2
= build_tree_list (NULL_TREE
, arg2
);
797 arg3
= build_tree_list (NULL_TREE
, arg3
);
798 arg4
= build_tree_list (NULL_TREE
, arg4
);
799 TREE_CHAIN (arg3
) = arg4
;
800 TREE_CHAIN (arg2
) = arg3
;
801 TREE_CHAIN (arg1
) = arg2
;
805 die
= ffecom_call_gfrt (FFECOM_gfrtRANGE
,
807 TREE_SIDE_EFFECTS (die
) = 1;
809 element
= ffecom_3 (COND_EXPR
,
818 /* Return the computed element of an array reference.
820 `item' is NULL_TREE, or the transformed pointer to the array.
821 `expr' is the original opARRAYREF expression, which is transformed
822 if `item' is NULL_TREE.
823 `want_ptr' is non-zero if a pointer to the element, instead of
824 the element itself, is to be returned. */
827 ffecom_arrayref_ (tree item
, ffebld expr
, int want_ptr
)
829 ffebld dims
[FFECOM_dimensionsMAX
];
832 int flatten
= ffe_is_flatten_arrays ();
838 const char *array_name
;
842 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
)
843 array_name
= ffesymbol_text (ffebld_symter (ffebld_left (expr
)));
845 array_name
= "[expr?]";
847 /* Build up ARRAY_REFs in reverse order (since we're column major
848 here in Fortran land). */
850 for (i
= 0, list
= ffebld_right (expr
);
852 ++i
, list
= ffebld_trail (list
))
854 dims
[i
] = ffebld_head (list
);
855 type
= ffeinfo_type (ffebld_basictype (dims
[i
]),
856 ffebld_kindtype (dims
[i
]));
858 && ffecom_typesize_pointer_
> ffecom_typesize_integer1_
859 && ffetype_size (type
) > ffecom_typesize_integer1_
)
860 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
861 pointers and 32-bit integers. Do the full 64-bit pointer
862 arithmetic, for codes using arrays for nonstandard heap-like
869 need_ptr
= want_ptr
|| flatten
;
874 item
= ffecom_ptr_to_expr (ffebld_left (expr
));
876 item
= ffecom_expr (ffebld_left (expr
));
878 if (item
== error_mark_node
)
881 if (ffeinfo_where (ffebld_info (expr
)) == FFEINFO_whereFLEETING
882 && ! mark_addressable (item
))
883 return error_mark_node
;
886 if (item
== error_mark_node
)
893 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
895 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
897 min
= TYPE_MIN_VALUE (TYPE_DOMAIN (array
));
898 element
= ffecom_expr_ (dims
[i
], NULL
, NULL
, NULL
, FALSE
, TRUE
);
899 if (flag_bounds_check
)
900 element
= ffecom_subscript_check_ (array
, element
, i
, total_dims
,
902 if (element
== error_mark_node
)
905 /* Widen integral arithmetic as desired while preserving
907 tree_type
= TREE_TYPE (element
);
908 tree_type_x
= tree_type
;
910 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
911 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
912 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
914 if (TREE_TYPE (min
) != tree_type_x
)
915 min
= convert (tree_type_x
, min
);
916 if (TREE_TYPE (element
) != tree_type_x
)
917 element
= convert (tree_type_x
, element
);
919 item
= ffecom_2 (PLUS_EXPR
,
920 build_pointer_type (TREE_TYPE (array
)),
922 size_binop (MULT_EXPR
,
923 size_in_bytes (TREE_TYPE (array
)),
925 fold (build (MINUS_EXPR
,
931 item
= ffecom_1 (INDIRECT_REF
,
932 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
))),
942 array
= TYPE_MAIN_VARIANT (TREE_TYPE (item
));
944 element
= ffecom_expr_ (dims
[i
], NULL
, NULL
, NULL
, FALSE
, TRUE
);
945 if (flag_bounds_check
)
946 element
= ffecom_subscript_check_ (array
, element
, i
, total_dims
,
948 if (element
== error_mark_node
)
951 /* Widen integral arithmetic as desired while preserving
953 tree_type
= TREE_TYPE (element
);
954 tree_type_x
= tree_type
;
956 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
957 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
958 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
960 element
= convert (tree_type_x
, element
);
962 item
= ffecom_2 (ARRAY_REF
,
963 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
))),
972 /* This is like gcc's stabilize_reference -- in fact, most of the code
973 comes from that -- but it handles the situation where the reference
974 is going to have its subparts picked at, and it shouldn't change
975 (or trigger extra invocations of functions in the subtrees) due to
976 this. save_expr is a bit overzealous, because we don't need the
977 entire thing calculated and saved like a temp. So, for DECLs, no
978 change is needed, because these are stable aggregates, and ARRAY_REF
979 and such might well be stable too, but for things like calculations,
980 we do need to calculate a snapshot of a value before picking at it. */
982 #if FFECOM_targetCURRENT == FFECOM_targetGCC
984 ffecom_stabilize_aggregate_ (tree ref
)
987 enum tree_code code
= TREE_CODE (ref
);
994 /* No action is needed in this case. */
1000 case FIX_TRUNC_EXPR
:
1001 case FIX_FLOOR_EXPR
:
1002 case FIX_ROUND_EXPR
:
1004 result
= build_nt (code
, stabilize_reference (TREE_OPERAND (ref
, 0)));
1008 result
= build_nt (INDIRECT_REF
,
1009 stabilize_reference_1 (TREE_OPERAND (ref
, 0)));
1013 result
= build_nt (COMPONENT_REF
,
1014 stabilize_reference (TREE_OPERAND (ref
, 0)),
1015 TREE_OPERAND (ref
, 1));
1019 result
= build_nt (BIT_FIELD_REF
,
1020 stabilize_reference (TREE_OPERAND (ref
, 0)),
1021 stabilize_reference_1 (TREE_OPERAND (ref
, 1)),
1022 stabilize_reference_1 (TREE_OPERAND (ref
, 2)));
1026 result
= build_nt (ARRAY_REF
,
1027 stabilize_reference (TREE_OPERAND (ref
, 0)),
1028 stabilize_reference_1 (TREE_OPERAND (ref
, 1)));
1032 result
= build_nt (COMPOUND_EXPR
,
1033 stabilize_reference_1 (TREE_OPERAND (ref
, 0)),
1034 stabilize_reference (TREE_OPERAND (ref
, 1)));
1042 return save_expr (ref
);
1045 return error_mark_node
;
1048 TREE_TYPE (result
) = TREE_TYPE (ref
);
1049 TREE_READONLY (result
) = TREE_READONLY (ref
);
1050 TREE_SIDE_EFFECTS (result
) = TREE_SIDE_EFFECTS (ref
);
1051 TREE_THIS_VOLATILE (result
) = TREE_THIS_VOLATILE (ref
);
1057 /* A rip-off of gcc's convert.c convert_to_complex function,
1058 reworked to handle complex implemented as C structures
1059 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1061 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1063 ffecom_convert_to_complex_ (tree type
, tree expr
)
1065 register enum tree_code form
= TREE_CODE (TREE_TYPE (expr
));
1068 assert (TREE_CODE (type
) == RECORD_TYPE
);
1070 subtype
= TREE_TYPE (TYPE_FIELDS (type
));
1072 if (form
== REAL_TYPE
|| form
== INTEGER_TYPE
|| form
== ENUMERAL_TYPE
)
1074 expr
= convert (subtype
, expr
);
1075 return ffecom_2 (COMPLEX_EXPR
, type
, expr
,
1076 convert (subtype
, integer_zero_node
));
1079 if (form
== RECORD_TYPE
)
1081 tree elt_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
)));
1082 if (TYPE_MAIN_VARIANT (elt_type
) == TYPE_MAIN_VARIANT (subtype
))
1086 expr
= save_expr (expr
);
1087 return ffecom_2 (COMPLEX_EXPR
,
1090 ffecom_1 (REALPART_EXPR
,
1091 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
1094 ffecom_1 (IMAGPART_EXPR
,
1095 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
1100 if (form
== POINTER_TYPE
|| form
== REFERENCE_TYPE
)
1101 error ("pointer value used where a complex was expected");
1103 error ("aggregate value used where a complex was expected");
1105 return ffecom_2 (COMPLEX_EXPR
, type
,
1106 convert (subtype
, integer_zero_node
),
1107 convert (subtype
, integer_zero_node
));
1111 /* Like gcc's convert(), but crashes if widening might happen. */
1113 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1115 ffecom_convert_narrow_ (type
, expr
)
1118 register tree e
= expr
;
1119 register enum tree_code code
= TREE_CODE (type
);
1121 if (type
== TREE_TYPE (e
)
1122 || TREE_CODE (e
) == ERROR_MARK
)
1124 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
1125 return fold (build1 (NOP_EXPR
, type
, e
));
1126 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
1127 || code
== ERROR_MARK
)
1128 return error_mark_node
;
1129 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
1131 assert ("void value not ignored as it ought to be" == NULL
);
1132 return error_mark_node
;
1134 assert (code
!= VOID_TYPE
);
1135 if ((code
!= RECORD_TYPE
)
1136 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
1137 assert ("converting COMPLEX to REAL" == NULL
);
1138 assert (code
!= ENUMERAL_TYPE
);
1139 if (code
== INTEGER_TYPE
)
1141 assert ((TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
1142 && TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)))
1143 || (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
1144 && (TYPE_PRECISION (type
)
1145 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e
))))));
1146 return fold (convert_to_integer (type
, e
));
1148 if (code
== POINTER_TYPE
)
1150 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1151 return fold (convert_to_pointer (type
, e
));
1153 if (code
== REAL_TYPE
)
1155 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1156 assert (TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)));
1157 return fold (convert_to_real (type
, e
));
1159 if (code
== COMPLEX_TYPE
)
1161 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1162 assert (TYPE_PRECISION (TREE_TYPE (type
)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1163 return fold (convert_to_complex (type
, e
));
1165 if (code
== RECORD_TYPE
)
1167 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1168 /* Check that at least the first field name agrees. */
1169 assert (DECL_NAME (TYPE_FIELDS (type
))
1170 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e
))));
1171 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1172 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1173 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1174 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))))
1176 return fold (ffecom_convert_to_complex_ (type
, e
));
1179 assert ("conversion to non-scalar type requested" == NULL
);
1180 return error_mark_node
;
1184 /* Like gcc's convert(), but crashes if narrowing might happen. */
1186 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1188 ffecom_convert_widen_ (type
, expr
)
1191 register tree e
= expr
;
1192 register enum tree_code code
= TREE_CODE (type
);
1194 if (type
== TREE_TYPE (e
)
1195 || TREE_CODE (e
) == ERROR_MARK
)
1197 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
1198 return fold (build1 (NOP_EXPR
, type
, e
));
1199 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
1200 || code
== ERROR_MARK
)
1201 return error_mark_node
;
1202 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
1204 assert ("void value not ignored as it ought to be" == NULL
);
1205 return error_mark_node
;
1207 assert (code
!= VOID_TYPE
);
1208 if ((code
!= RECORD_TYPE
)
1209 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
1210 assert ("narrowing COMPLEX to REAL" == NULL
);
1211 assert (code
!= ENUMERAL_TYPE
);
1212 if (code
== INTEGER_TYPE
)
1214 assert ((TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
1215 && TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)))
1216 || (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
1217 && (TYPE_PRECISION (type
)
1218 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e
))))));
1219 return fold (convert_to_integer (type
, e
));
1221 if (code
== POINTER_TYPE
)
1223 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1224 return fold (convert_to_pointer (type
, e
));
1226 if (code
== REAL_TYPE
)
1228 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1229 assert (TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)));
1230 return fold (convert_to_real (type
, e
));
1232 if (code
== COMPLEX_TYPE
)
1234 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1235 assert (TYPE_PRECISION (TREE_TYPE (type
)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1236 return fold (convert_to_complex (type
, e
));
1238 if (code
== RECORD_TYPE
)
1240 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1241 /* Check that at least the first field name agrees. */
1242 assert (DECL_NAME (TYPE_FIELDS (type
))
1243 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e
))));
1244 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1245 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1246 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1247 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))))
1249 return fold (ffecom_convert_to_complex_ (type
, e
));
1252 assert ("conversion to non-scalar type requested" == NULL
);
1253 return error_mark_node
;
1257 /* Handles making a COMPLEX type, either the standard
1258 (but buggy?) gbe way, or the safer (but less elegant?)
1261 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1263 ffecom_make_complex_type_ (tree subtype
)
1269 if (ffe_is_emulate_complex ())
1271 type
= make_node (RECORD_TYPE
);
1272 realfield
= ffecom_decl_field (type
, NULL_TREE
, "r", subtype
);
1273 imagfield
= ffecom_decl_field (type
, realfield
, "i", subtype
);
1274 TYPE_FIELDS (type
) = realfield
;
1279 type
= make_node (COMPLEX_TYPE
);
1280 TREE_TYPE (type
) = subtype
;
1288 /* Chooses either the gbe or the f2c way to build a
1289 complex constant. */
1291 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1293 ffecom_build_complex_constant_ (tree type
, tree realpart
, tree imagpart
)
1297 if (ffe_is_emulate_complex ())
1299 bothparts
= build_tree_list (TYPE_FIELDS (type
), realpart
);
1300 TREE_CHAIN (bothparts
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), imagpart
);
1301 bothparts
= build (CONSTRUCTOR
, type
, NULL_TREE
, bothparts
);
1305 bothparts
= build_complex (type
, realpart
, imagpart
);
1312 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1314 ffecom_arglist_expr_ (const char *c
, ffebld expr
)
1317 tree
*plist
= &list
;
1318 tree trail
= NULL_TREE
; /* Append char length args here. */
1319 tree
*ptrail
= &trail
;
1324 tree wanted
= NULL_TREE
;
1325 static char zed
[] = "0";
1330 while (expr
!= NULL
)
1353 wanted
= ffecom_f2c_complex_type_node
;
1357 wanted
= ffecom_f2c_doublereal_type_node
;
1361 wanted
= ffecom_f2c_doublecomplex_type_node
;
1365 wanted
= ffecom_f2c_real_type_node
;
1369 wanted
= ffecom_f2c_integer_type_node
;
1373 wanted
= ffecom_f2c_longint_type_node
;
1377 assert ("bad argstring code" == NULL
);
1383 exprh
= ffebld_head (expr
);
1387 if ((wanted
== NULL_TREE
)
1390 (ffecom_tree_type
[ffeinfo_basictype (ffebld_info (exprh
))]
1391 [ffeinfo_kindtype (ffebld_info (exprh
))])
1392 == TYPE_MODE (wanted
))))
1394 = build_tree_list (NULL_TREE
,
1395 ffecom_arg_ptr_to_expr (exprh
,
1399 item
= ffecom_arg_expr (exprh
, &length
);
1400 item
= ffecom_convert_widen_ (wanted
, item
);
1403 item
= ffecom_1 (ADDR_EXPR
,
1404 build_pointer_type (TREE_TYPE (item
)),
1408 = build_tree_list (NULL_TREE
,
1412 plist
= &TREE_CHAIN (*plist
);
1413 expr
= ffebld_trail (expr
);
1414 if (length
!= NULL_TREE
)
1416 *ptrail
= build_tree_list (NULL_TREE
, length
);
1417 ptrail
= &TREE_CHAIN (*ptrail
);
1421 /* We've run out of args in the call; if the implementation expects
1422 more, supply null pointers for them, which the implementation can
1423 check to see if an arg was omitted. */
1425 while (*c
!= '\0' && *c
!= '0')
1430 assert ("missing arg to run-time routine!" == NULL
);
1445 assert ("bad arg string code" == NULL
);
1449 = build_tree_list (NULL_TREE
,
1451 plist
= &TREE_CHAIN (*plist
);
1460 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1462 ffecom_widest_expr_type_ (ffebld list
)
1465 ffebld widest
= NULL
;
1467 ffetype widest_type
= NULL
;
1470 for (; list
!= NULL
; list
= ffebld_trail (list
))
1472 item
= ffebld_head (list
);
1475 if ((widest
!= NULL
)
1476 && (ffeinfo_basictype (ffebld_info (item
))
1477 != ffeinfo_basictype (ffebld_info (widest
))))
1479 type
= ffeinfo_type (ffeinfo_basictype (ffebld_info (item
)),
1480 ffeinfo_kindtype (ffebld_info (item
)));
1481 if ((widest
== FFEINFO_kindtypeNONE
)
1482 || (ffetype_size (type
)
1483 > ffetype_size (widest_type
)))
1490 assert (widest
!= NULL
);
1491 t
= ffecom_tree_type
[ffeinfo_basictype (ffebld_info (widest
))]
1492 [ffeinfo_kindtype (ffebld_info (widest
))];
1493 assert (t
!= NULL_TREE
);
1498 /* Check whether a partial overlap between two expressions is possible.
1500 Can *starting* to write a portion of expr1 change the value
1501 computed (perhaps already, *partially*) by expr2?
1503 Currently, this is a concern only for a COMPLEX expr1. But if it
1504 isn't in COMMON or local EQUIVALENCE, since we don't support
1505 aliasing of arguments, it isn't a concern. */
1508 ffecom_possible_partial_overlap_ (ffebld expr1
, ffebld expr2 ATTRIBUTE_UNUSED
)
1513 switch (ffebld_op (expr1
))
1515 case FFEBLD_opSYMTER
:
1516 sym
= ffebld_symter (expr1
);
1519 case FFEBLD_opARRAYREF
:
1520 if (ffebld_op (ffebld_left (expr1
)) != FFEBLD_opSYMTER
)
1522 sym
= ffebld_symter (ffebld_left (expr1
));
1529 if (ffesymbol_where (sym
) != FFEINFO_whereCOMMON
1530 && (ffesymbol_where (sym
) != FFEINFO_whereLOCAL
1531 || ! (st
= ffesymbol_storage (sym
))
1532 || ! ffestorag_parent (st
)))
1535 /* It's in COMMON or local EQUIVALENCE. */
1540 /* Check whether dest and source might overlap. ffebld versions of these
1541 might or might not be passed, will be NULL if not.
1543 The test is really whether source_tree is modifiable and, if modified,
1544 might overlap destination such that the value(s) in the destination might
1545 change before it is finally modified. dest_* are the canonized
1546 destination itself. */
1548 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1550 ffecom_overlap_ (tree dest_decl
, tree dest_offset
, tree dest_size
,
1551 tree source_tree
, ffebld source UNUSED
,
1559 if (source_tree
== NULL_TREE
)
1562 switch (TREE_CODE (source_tree
))
1565 case IDENTIFIER_NODE
:
1576 case TRUNC_DIV_EXPR
:
1578 case FLOOR_DIV_EXPR
:
1579 case ROUND_DIV_EXPR
:
1580 case TRUNC_MOD_EXPR
:
1582 case FLOOR_MOD_EXPR
:
1583 case ROUND_MOD_EXPR
:
1585 case EXACT_DIV_EXPR
:
1586 case FIX_TRUNC_EXPR
:
1588 case FIX_FLOOR_EXPR
:
1589 case FIX_ROUND_EXPR
:
1603 case BIT_ANDTC_EXPR
:
1605 case TRUTH_ANDIF_EXPR
:
1606 case TRUTH_ORIF_EXPR
:
1607 case TRUTH_AND_EXPR
:
1609 case TRUTH_XOR_EXPR
:
1610 case TRUTH_NOT_EXPR
:
1626 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1627 TREE_OPERAND (source_tree
, 1), NULL
,
1631 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1632 TREE_OPERAND (source_tree
, 0), NULL
,
1637 case NON_LVALUE_EXPR
:
1639 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1642 ffecom_tree_canonize_ptr_ (&source_decl
, &source_offset
,
1644 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1649 ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1650 TREE_OPERAND (source_tree
, 1), NULL
,
1652 || ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1653 TREE_OPERAND (source_tree
, 2), NULL
,
1658 ffecom_tree_canonize_ref_ (&source_decl
, &source_offset
,
1660 TREE_OPERAND (source_tree
, 0));
1664 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1667 source_decl
= source_tree
;
1668 source_offset
= bitsize_zero_node
;
1669 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1673 case REFERENCE_EXPR
:
1674 case PREDECREMENT_EXPR
:
1675 case PREINCREMENT_EXPR
:
1676 case POSTDECREMENT_EXPR
:
1677 case POSTINCREMENT_EXPR
:
1685 /* Come here when source_decl, source_offset, and source_size filled
1686 in appropriately. */
1688 if (source_decl
== NULL_TREE
)
1689 return FALSE
; /* No decl involved, so no overlap. */
1691 if (source_decl
!= dest_decl
)
1692 return FALSE
; /* Different decl, no overlap. */
1694 if (TREE_CODE (dest_size
) == ERROR_MARK
)
1695 return TRUE
; /* Assignment into entire assumed-size
1696 array? Shouldn't happen.... */
1698 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1699 ffecom_2 (PLUS_EXPR
, TREE_TYPE (dest_offset
),
1701 convert (TREE_TYPE (dest_offset
),
1703 convert (TREE_TYPE (dest_offset
),
1706 if (integer_onep (t
))
1707 return FALSE
; /* Destination precedes source. */
1710 || (source_size
== NULL_TREE
)
1711 || (TREE_CODE (source_size
) == ERROR_MARK
)
1712 || integer_zerop (source_size
))
1713 return TRUE
; /* No way to tell if dest follows source. */
1715 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1716 ffecom_2 (PLUS_EXPR
, TREE_TYPE (source_offset
),
1718 convert (TREE_TYPE (source_offset
),
1720 convert (TREE_TYPE (source_offset
),
1723 if (integer_onep (t
))
1724 return FALSE
; /* Destination follows source. */
1726 return TRUE
; /* Destination and source overlap. */
1730 /* Check whether dest might overlap any of a list of arguments or is
1731 in a COMMON area the callee might know about (and thus modify). */
1733 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1735 ffecom_args_overlapping_ (tree dest_tree
, ffebld dest UNUSED
,
1736 tree args
, tree callee_commons
,
1744 ffecom_tree_canonize_ref_ (&dest_decl
, &dest_offset
, &dest_size
,
1747 if (dest_decl
== NULL_TREE
)
1748 return FALSE
; /* Seems unlikely! */
1750 /* If the decl cannot be determined reliably, or if its in COMMON
1751 and the callee isn't known to not futz with COMMON via other
1752 means, overlap might happen. */
1754 if ((TREE_CODE (dest_decl
) == ERROR_MARK
)
1755 || ((callee_commons
!= NULL_TREE
)
1756 && TREE_PUBLIC (dest_decl
)))
1759 for (; args
!= NULL_TREE
; args
= TREE_CHAIN (args
))
1761 if (((arg
= TREE_VALUE (args
)) != NULL_TREE
)
1762 && ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1763 arg
, NULL
, scalar_args
))
1771 /* Build a string for a variable name as used by NAMELIST. This means that
1772 if we're using the f2c library, we build an uppercase string, since
1775 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1777 ffecom_build_f2c_string_ (int i
, const char *s
)
1779 if (!ffe_is_f2c_library ())
1780 return build_string (i
, s
);
1789 if (((size_t) i
) > ARRAY_SIZE (space
))
1790 tmp
= malloc_new_ks (malloc_pool_image (), "f2c_string", i
);
1794 for (p
= s
, q
= tmp
; *p
!= '\0'; ++p
, ++q
)
1798 t
= build_string (i
, tmp
);
1800 if (((size_t) i
) > ARRAY_SIZE (space
))
1801 malloc_kill_ks (malloc_pool_image (), tmp
, i
);
1808 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1809 type to just get whatever the function returns), handling the
1810 f2c value-returning convention, if required, by prepending
1811 to the arglist a pointer to a temporary to receive the return value. */
1813 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1815 ffecom_call_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1816 tree type
, tree args
, tree dest_tree
,
1817 ffebld dest
, bool *dest_used
, tree callee_commons
,
1818 bool scalar_args
, tree hook
)
1823 if (dest_used
!= NULL
)
1828 if ((dest_used
== NULL
)
1830 || (ffeinfo_basictype (ffebld_info (dest
))
1831 != FFEINFO_basictypeCOMPLEX
)
1832 || (ffeinfo_kindtype (ffebld_info (dest
)) != kt
)
1833 || ((type
!= NULL_TREE
) && (TREE_TYPE (dest_tree
) != type
))
1834 || ffecom_args_overlapping_ (dest_tree
, dest
, args
,
1839 tempvar
= ffecom_make_tempvar (ffecom_tree_type
1840 [FFEINFO_basictypeCOMPLEX
][kt
],
1841 FFETARGET_charactersizeNONE
,
1851 tempvar
= dest_tree
;
1856 = build_tree_list (NULL_TREE
,
1857 ffecom_1 (ADDR_EXPR
,
1858 build_pointer_type (TREE_TYPE (tempvar
)),
1860 TREE_CHAIN (item
) = args
;
1862 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1865 if (tempvar
!= dest_tree
)
1866 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
, tempvar
);
1869 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1872 if ((type
!= NULL_TREE
) && (TREE_TYPE (item
) != type
))
1873 item
= ffecom_convert_narrow_ (type
, item
);
1879 /* Given two arguments, transform them and make a call to the given
1880 function via ffecom_call_. */
1882 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1884 ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1885 tree type
, ffebld left
, ffebld right
,
1886 tree dest_tree
, ffebld dest
, bool *dest_used
,
1887 tree callee_commons
, bool scalar_args
, bool ref
, tree hook
)
1896 /* Pass arguments by reference. */
1897 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
1898 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
1902 /* Pass arguments by value. */
1903 left_tree
= ffecom_arg_expr (left
, &left_length
);
1904 right_tree
= ffecom_arg_expr (right
, &right_length
);
1908 left_tree
= build_tree_list (NULL_TREE
, left_tree
);
1909 right_tree
= build_tree_list (NULL_TREE
, right_tree
);
1910 TREE_CHAIN (left_tree
) = right_tree
;
1912 if (left_length
!= NULL_TREE
)
1914 left_length
= build_tree_list (NULL_TREE
, left_length
);
1915 TREE_CHAIN (right_tree
) = left_length
;
1918 if (right_length
!= NULL_TREE
)
1920 right_length
= build_tree_list (NULL_TREE
, right_length
);
1921 if (left_length
!= NULL_TREE
)
1922 TREE_CHAIN (left_length
) = right_length
;
1924 TREE_CHAIN (right_tree
) = right_length
;
1927 return ffecom_call_ (fn
, kt
, is_f2c_complex
, type
, left_tree
,
1928 dest_tree
, dest
, dest_used
, callee_commons
,
1933 /* Return ptr/length args for char subexpression
1935 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1936 subexpressions by constructing the appropriate trees for the ptr-to-
1937 character-text and length-of-character-text arguments in a calling
1940 Note that if with_null is TRUE, and the expression is an opCONTER,
1941 a null byte is appended to the string. */
1943 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1945 ffecom_char_args_x_ (tree
*xitem
, tree
*length
, ffebld expr
, bool with_null
)
1949 ffetargetCharacter1 val
;
1950 ffetargetCharacterSize newlen
;
1952 switch (ffebld_op (expr
))
1954 case FFEBLD_opCONTER
:
1955 val
= ffebld_constant_character1 (ffebld_conter (expr
));
1956 newlen
= ffetarget_length_character1 (val
);
1959 /* Begin FFETARGET-NULL-KLUDGE. */
1963 *length
= build_int_2 (newlen
, 0);
1964 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1965 high
= build_int_2 (newlen
, 0);
1966 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
1967 item
= build_string (newlen
,
1968 ffetarget_text_character1 (val
));
1969 /* End FFETARGET-NULL-KLUDGE. */
1971 = build_type_variant
1975 (ffecom_f2c_ftnlen_type_node
,
1976 ffecom_f2c_ftnlen_one_node
,
1979 TREE_CONSTANT (item
) = 1;
1980 TREE_STATIC (item
) = 1;
1981 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
1985 case FFEBLD_opSYMTER
:
1987 ffesymbol s
= ffebld_symter (expr
);
1989 item
= ffesymbol_hook (s
).decl_tree
;
1990 if (item
== NULL_TREE
)
1992 s
= ffecom_sym_transform_ (s
);
1993 item
= ffesymbol_hook (s
).decl_tree
;
1995 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
1997 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
1998 *length
= ffesymbol_hook (s
).length_tree
;
2001 *length
= build_int_2 (ffesymbol_size (s
), 0);
2002 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2005 else if (item
== error_mark_node
)
2006 *length
= error_mark_node
;
2008 /* FFEINFO_kindFUNCTION. */
2009 *length
= NULL_TREE
;
2010 if (!ffesymbol_hook (s
).addr
2011 && (item
!= error_mark_node
))
2012 item
= ffecom_1 (ADDR_EXPR
,
2013 build_pointer_type (TREE_TYPE (item
)),
2018 case FFEBLD_opARRAYREF
:
2020 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
2022 if (item
== error_mark_node
|| *length
== error_mark_node
)
2024 item
= *length
= error_mark_node
;
2028 item
= ffecom_arrayref_ (item
, expr
, 1);
2032 case FFEBLD_opSUBSTR
:
2036 ffebld thing
= ffebld_right (expr
);
2039 const char *char_name
;
2043 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
2044 start
= ffebld_head (thing
);
2045 thing
= ffebld_trail (thing
);
2046 assert (ffebld_trail (thing
) == NULL
);
2047 end
= ffebld_head (thing
);
2049 /* Determine name for pretty-printing range-check errors. */
2050 for (left_symter
= ffebld_left (expr
);
2051 left_symter
&& ffebld_op (left_symter
) == FFEBLD_opARRAYREF
;
2052 left_symter
= ffebld_left (left_symter
))
2054 if (ffebld_op (left_symter
) == FFEBLD_opSYMTER
)
2055 char_name
= ffesymbol_text (ffebld_symter (left_symter
));
2057 char_name
= "[expr?]";
2059 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
2061 if (item
== error_mark_node
|| *length
== error_mark_node
)
2063 item
= *length
= error_mark_node
;
2067 array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
2069 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2077 end_tree
= ffecom_expr (end
);
2078 if (flag_bounds_check
)
2079 end_tree
= ffecom_subscript_check_ (array
, end_tree
, 1, 0,
2081 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2084 if (end_tree
== error_mark_node
)
2086 item
= *length
= error_mark_node
;
2095 start_tree
= ffecom_expr (start
);
2096 if (flag_bounds_check
)
2097 start_tree
= ffecom_subscript_check_ (array
, start_tree
, 0, 0,
2099 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2102 if (start_tree
== error_mark_node
)
2104 item
= *length
= error_mark_node
;
2108 start_tree
= ffecom_save_tree (start_tree
);
2110 item
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (item
),
2112 ffecom_2 (MINUS_EXPR
,
2113 TREE_TYPE (start_tree
),
2115 ffecom_f2c_ftnlen_one_node
));
2119 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
2120 ffecom_f2c_ftnlen_one_node
,
2121 ffecom_2 (MINUS_EXPR
,
2122 ffecom_f2c_ftnlen_type_node
,
2128 end_tree
= ffecom_expr (end
);
2129 if (flag_bounds_check
)
2130 end_tree
= ffecom_subscript_check_ (array
, end_tree
, 1, 0,
2132 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2135 if (end_tree
== error_mark_node
)
2137 item
= *length
= error_mark_node
;
2141 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
2142 ffecom_f2c_ftnlen_one_node
,
2143 ffecom_2 (MINUS_EXPR
,
2144 ffecom_f2c_ftnlen_type_node
,
2145 end_tree
, start_tree
));
2151 case FFEBLD_opFUNCREF
:
2153 ffesymbol s
= ffebld_symter (ffebld_left (expr
));
2156 ffetargetCharacterSize size
= ffeinfo_size (ffebld_info (expr
));
2159 if (size
== FFETARGET_charactersizeNONE
)
2160 /* ~~Kludge alert! This should someday be fixed. */
2163 *length
= build_int_2 (size
, 0);
2164 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2166 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
2167 == FFEINFO_whereINTRINSIC
)
2171 /* Invocation of an intrinsic returning CHARACTER*1. */
2172 item
= ffecom_expr_intrinsic_ (expr
, NULL_TREE
,
2176 ix
= ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr
)));
2177 assert (ix
!= FFECOM_gfrt
);
2178 item
= ffecom_gfrt_tree_ (ix
);
2183 item
= ffesymbol_hook (s
).decl_tree
;
2184 if (item
== NULL_TREE
)
2186 s
= ffecom_sym_transform_ (s
);
2187 item
= ffesymbol_hook (s
).decl_tree
;
2189 if (item
== error_mark_node
)
2191 item
= *length
= error_mark_node
;
2195 if (!ffesymbol_hook (s
).addr
)
2196 item
= ffecom_1_fn (item
);
2200 tempvar
= ffecom_push_tempvar (char_type_node
, size
, -1, TRUE
);
2202 tempvar
= ffebld_nonter_hook (expr
);
2205 tempvar
= ffecom_1 (ADDR_EXPR
,
2206 build_pointer_type (TREE_TYPE (tempvar
)),
2209 args
= build_tree_list (NULL_TREE
, tempvar
);
2211 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
) /* Sfunc args by value. */
2212 TREE_CHAIN (args
) = ffecom_list_expr (ffebld_right (expr
));
2215 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, *length
);
2216 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
2218 TREE_CHAIN (TREE_CHAIN (args
))
2219 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix
),
2220 ffebld_right (expr
));
2224 TREE_CHAIN (TREE_CHAIN (args
))
2225 = ffecom_list_ptr_to_expr (ffebld_right (expr
));
2229 item
= ffecom_3s (CALL_EXPR
,
2230 TREE_TYPE (TREE_TYPE (TREE_TYPE (item
))),
2231 item
, args
, NULL_TREE
);
2232 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
,
2237 case FFEBLD_opCONVERT
:
2239 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
2241 if (item
== error_mark_node
|| *length
== error_mark_node
)
2243 item
= *length
= error_mark_node
;
2247 if ((ffebld_size_known (ffebld_left (expr
))
2248 == FFETARGET_charactersizeNONE
)
2249 || (ffebld_size_known (ffebld_left (expr
)) < (ffebld_size (expr
))))
2250 { /* Possible blank-padding needed, copy into
2257 tempvar
= ffecom_make_tempvar (char_type_node
,
2258 ffebld_size (expr
), -1);
2260 tempvar
= ffebld_nonter_hook (expr
);
2263 tempvar
= ffecom_1 (ADDR_EXPR
,
2264 build_pointer_type (TREE_TYPE (tempvar
)),
2267 newlen
= build_int_2 (ffebld_size (expr
), 0);
2268 TREE_TYPE (newlen
) = ffecom_f2c_ftnlen_type_node
;
2270 args
= build_tree_list (NULL_TREE
, tempvar
);
2271 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, item
);
2272 TREE_CHAIN (TREE_CHAIN (args
)) = build_tree_list (NULL_TREE
, newlen
);
2273 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args
)))
2274 = build_tree_list (NULL_TREE
, *length
);
2276 item
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, args
, NULL_TREE
);
2277 TREE_SIDE_EFFECTS (item
) = 1;
2278 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), fold (item
),
2283 { /* Just truncate the length. */
2284 *length
= build_int_2 (ffebld_size (expr
), 0);
2285 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2290 assert ("bad op for single char arg expr" == NULL
);
2299 /* Check the size of the type to be sure it doesn't overflow the
2300 "portable" capacities of the compiler back end. `dummy' types
2301 can generally overflow the normal sizes as long as the computations
2302 themselves don't overflow. A particular target of the back end
2303 must still enforce its size requirements, though, and the back
2304 end takes care of this in stor-layout.c. */
2306 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2308 ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
)
2310 if (TREE_CODE (type
) == ERROR_MARK
)
2313 if (TYPE_SIZE (type
) == NULL_TREE
)
2316 if (TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
)
2319 if ((tree_int_cst_sgn (TYPE_SIZE (type
)) < 0)
2320 || (!dummy
&& (((TREE_INT_CST_HIGH (TYPE_SIZE (type
)) != 0))
2321 || TREE_OVERFLOW (TYPE_SIZE (type
)))))
2323 ffebad_start (FFEBAD_ARRAY_LARGE
);
2324 ffebad_string (ffesymbol_text (s
));
2325 ffebad_here (0, ffesymbol_where_line (s
), ffesymbol_where_column (s
));
2328 return error_mark_node
;
2335 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2336 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2337 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2339 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2341 ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
)
2343 ffetargetCharacterSize sz
= ffesymbol_size (s
);
2348 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
2349 tlen
= NULL_TREE
; /* A statement function, no length passed. */
2352 if (ffesymbol_where (s
) == FFEINFO_whereDUMMY
)
2353 tlen
= ffecom_get_invented_identifier ("__g77_length_%s",
2354 ffesymbol_text (s
));
2356 tlen
= ffecom_get_invented_identifier ("__g77_%s", "length");
2357 tlen
= build_decl (PARM_DECL
, tlen
, ffecom_f2c_ftnlen_type_node
);
2359 DECL_ARTIFICIAL (tlen
) = 1;
2363 if (sz
== FFETARGET_charactersizeNONE
)
2365 assert (tlen
!= NULL_TREE
);
2366 highval
= variable_size (tlen
);
2370 highval
= build_int_2 (sz
, 0);
2371 TREE_TYPE (highval
) = ffecom_f2c_ftnlen_type_node
;
2374 type
= build_array_type (type
,
2375 build_range_type (ffecom_f2c_ftnlen_type_node
,
2376 ffecom_f2c_ftnlen_one_node
,
2384 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2386 ffecomConcatList_ catlist;
2387 ffebld expr; // expr of CHARACTER basictype.
2388 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2389 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2391 Scans expr for character subexpressions, updates and returns catlist
2394 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2395 static ffecomConcatList_
2396 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
, ffebld expr
,
2397 ffetargetCharacterSize max
)
2399 ffetargetCharacterSize sz
;
2401 recurse
: /* :::::::::::::::::::: */
2406 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
>= max
))
2407 return catlist
; /* Don't append any more items. */
2409 switch (ffebld_op (expr
))
2411 case FFEBLD_opCONTER
:
2412 case FFEBLD_opSYMTER
:
2413 case FFEBLD_opARRAYREF
:
2414 case FFEBLD_opFUNCREF
:
2415 case FFEBLD_opSUBSTR
:
2416 case FFEBLD_opCONVERT
: /* Callers should strip this off beforehand
2417 if they don't need to preserve it. */
2418 if (catlist
.count
== catlist
.max
)
2419 { /* Make a (larger) list. */
2423 newmax
= (catlist
.max
== 0) ? 8 : catlist
.max
* 2;
2424 newx
= malloc_new_ks (malloc_pool_image (), "catlist",
2425 newmax
* sizeof (newx
[0]));
2426 if (catlist
.max
!= 0)
2428 memcpy (newx
, catlist
.exprs
, catlist
.max
* sizeof (newx
[0]));
2429 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2430 catlist
.max
* sizeof (newx
[0]));
2432 catlist
.max
= newmax
;
2433 catlist
.exprs
= newx
;
2435 if ((sz
= ffebld_size_known (expr
)) != FFETARGET_charactersizeNONE
)
2436 catlist
.minlen
+= sz
;
2438 ++catlist
.minlen
; /* Not true for F90; can be 0 length. */
2439 if ((sz
= ffebld_size_max (expr
)) == FFETARGET_charactersizeNONE
)
2440 catlist
.maxlen
= sz
;
2442 catlist
.maxlen
+= sz
;
2443 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
> max
))
2444 { /* This item overlaps (or is beyond) the end
2445 of the destination. */
2446 switch (ffebld_op (expr
))
2448 case FFEBLD_opCONTER
:
2449 case FFEBLD_opSYMTER
:
2450 case FFEBLD_opARRAYREF
:
2451 case FFEBLD_opFUNCREF
:
2452 case FFEBLD_opSUBSTR
:
2453 /* ~~Do useful truncations here. */
2457 assert ("op changed or inconsistent switches!" == NULL
);
2461 catlist
.exprs
[catlist
.count
++] = expr
;
2464 case FFEBLD_opPAREN
:
2465 expr
= ffebld_left (expr
);
2466 goto recurse
; /* :::::::::::::::::::: */
2468 case FFEBLD_opCONCATENATE
:
2469 catlist
= ffecom_concat_list_gather_ (catlist
, ffebld_left (expr
), max
);
2470 expr
= ffebld_right (expr
);
2471 goto recurse
; /* :::::::::::::::::::: */
2473 #if 0 /* Breaks passing small actual arg to larger
2474 dummy arg of sfunc */
2475 case FFEBLD_opCONVERT
:
2476 expr
= ffebld_left (expr
);
2478 ffetargetCharacterSize cmax
;
2480 cmax
= catlist
.len
+ ffebld_size_known (expr
);
2482 if ((max
== FFETARGET_charactersizeNONE
) || (max
> cmax
))
2485 goto recurse
; /* :::::::::::::::::::: */
2492 assert ("bad op in _gather_" == NULL
);
2498 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2500 ffecomConcatList_ catlist;
2501 ffecom_concat_list_kill_(catlist);
2503 Anything allocated within the list info is deallocated. */
2505 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2507 ffecom_concat_list_kill_ (ffecomConcatList_ catlist
)
2509 if (catlist
.max
!= 0)
2510 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2511 catlist
.max
* sizeof (catlist
.exprs
[0]));
2515 /* Make list of concatenated string exprs.
2517 Returns a flattened list of concatenated subexpressions given a
2518 tree of such expressions. */
2520 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2521 static ffecomConcatList_
2522 ffecom_concat_list_new_ (ffebld expr
, ffetargetCharacterSize max
)
2524 ffecomConcatList_ catlist
;
2526 catlist
.maxlen
= catlist
.minlen
= catlist
.max
= catlist
.count
= 0;
2527 return ffecom_concat_list_gather_ (catlist
, expr
, max
);
2532 /* Provide some kind of useful info on member of aggregate area,
2533 since current g77/gcc technology does not provide debug info
2534 on these members. */
2536 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2538 ffecom_debug_kludge_ (tree aggr
, const char *aggr_type
, ffesymbol member
,
2539 tree member_type UNUSED
, ffetargetOffset offset
)
2549 for (type_id
= member_type
;
2550 TREE_CODE (type_id
) != IDENTIFIER_NODE
;
2553 switch (TREE_CODE (type_id
))
2557 type_id
= TYPE_NAME (type_id
);
2562 type_id
= TREE_TYPE (type_id
);
2566 assert ("no IDENTIFIER_NODE for type!" == NULL
);
2567 type_id
= error_mark_node
;
2573 if (ffecom_transform_only_dummies_
2574 || !ffe_is_debug_kludge ())
2575 return; /* Can't do this yet, maybe later. */
2578 + strlen (aggr_type
)
2579 + IDENTIFIER_LENGTH (DECL_NAME (aggr
));
2581 + IDENTIFIER_LENGTH (type_id
);
2584 if (((size_t) len
) >= ARRAY_SIZE (space
))
2585 buff
= malloc_new_ks (malloc_pool_image (), "debug_kludge", len
+ 1);
2589 sprintf (&buff
[0], "At (%s) `%s' plus %ld bytes",
2591 IDENTIFIER_POINTER (DECL_NAME (aggr
)),
2594 value
= build_string (len
, buff
);
2596 = build_type_variant (build_array_type (char_type_node
,
2600 build_int_2 (strlen (buff
), 0))),
2602 decl
= build_decl (VAR_DECL
,
2603 ffecom_get_identifier_ (ffesymbol_text (member
)),
2605 TREE_CONSTANT (decl
) = 1;
2606 TREE_STATIC (decl
) = 1;
2607 DECL_INITIAL (decl
) = error_mark_node
;
2608 DECL_IN_SYSTEM_HEADER (decl
) = 1; /* Don't let -Wunused complain. */
2609 decl
= start_decl (decl
, FALSE
);
2610 finish_decl (decl
, value
, FALSE
);
2612 if (buff
!= &space
[0])
2613 malloc_kill_ks (malloc_pool_image (), buff
, len
+ 1);
2617 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2619 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2620 int i; // entry# for this entrypoint (used by master fn)
2621 ffecom_do_entrypoint_(s,i);
2623 Makes a public entry point that calls our private master fn (already
2626 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2628 ffecom_do_entry_ (ffesymbol fn
, int entrynum
)
2631 tree type
; /* Type of function. */
2632 tree multi_retval
; /* Var holding return value (union). */
2633 tree result
; /* Var holding result. */
2634 ffeinfoBasictype bt
;
2638 bool charfunc
; /* All entry points return same type
2640 bool cmplxfunc
; /* Use f2c way of returning COMPLEX. */
2641 bool multi
; /* Master fn has multiple return types. */
2642 bool altreturning
= FALSE
; /* This entry point has alternate returns. */
2643 int old_lineno
= lineno
;
2644 const char *old_input_filename
= input_filename
;
2646 input_filename
= ffesymbol_where_filename (fn
);
2647 lineno
= ffesymbol_where_filelinenum (fn
);
2649 ffecom_doing_entry_
= TRUE
; /* Don't bother with array dimensions. */
2651 switch (ffecom_primary_entry_kind_
)
2653 case FFEINFO_kindFUNCTION
:
2655 /* Determine actual return type for function. */
2657 gt
= FFEGLOBAL_typeFUNC
;
2658 bt
= ffesymbol_basictype (fn
);
2659 kt
= ffesymbol_kindtype (fn
);
2660 if (bt
== FFEINFO_basictypeNONE
)
2662 ffeimplic_establish_symbol (fn
);
2663 if (ffesymbol_funcresult (fn
) != NULL
)
2664 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
2665 bt
= ffesymbol_basictype (fn
);
2666 kt
= ffesymbol_kindtype (fn
);
2669 if (bt
== FFEINFO_basictypeCHARACTER
)
2670 charfunc
= TRUE
, cmplxfunc
= FALSE
;
2671 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
2672 && ffesymbol_is_f2c (fn
))
2673 charfunc
= FALSE
, cmplxfunc
= TRUE
;
2675 charfunc
= cmplxfunc
= FALSE
;
2678 type
= ffecom_tree_fun_type_void
;
2679 else if (ffesymbol_is_f2c (fn
))
2680 type
= ffecom_tree_fun_type
[bt
][kt
];
2682 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
2684 if ((type
== NULL_TREE
)
2685 || (TREE_TYPE (type
) == NULL_TREE
))
2686 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
2688 multi
= (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
2691 case FFEINFO_kindSUBROUTINE
:
2692 gt
= FFEGLOBAL_typeSUBR
;
2693 bt
= FFEINFO_basictypeNONE
;
2694 kt
= FFEINFO_kindtypeNONE
;
2695 if (ffecom_is_altreturning_
)
2696 { /* Am _I_ altreturning? */
2697 for (item
= ffesymbol_dummyargs (fn
);
2699 item
= ffebld_trail (item
))
2701 if (ffebld_op (ffebld_head (item
)) == FFEBLD_opSTAR
)
2703 altreturning
= TRUE
;
2708 type
= ffecom_tree_subr_type
;
2710 type
= ffecom_tree_fun_type_void
;
2713 type
= ffecom_tree_fun_type_void
;
2720 assert ("say what??" == NULL
);
2722 case FFEINFO_kindANY
:
2723 gt
= FFEGLOBAL_typeANY
;
2724 bt
= FFEINFO_basictypeNONE
;
2725 kt
= FFEINFO_kindtypeNONE
;
2726 type
= error_mark_node
;
2733 /* build_decl uses the current lineno and input_filename to set the decl
2734 source info. So, I've putzed with ffestd and ffeste code to update that
2735 source info to point to the appropriate statement just before calling
2736 ffecom_do_entrypoint (which calls this fn). */
2738 start_function (ffecom_get_external_identifier_ (fn
),
2740 0, /* nested/inline */
2741 1); /* TREE_PUBLIC */
2743 if (((g
= ffesymbol_global (fn
)) != NULL
)
2744 && ((ffeglobal_type (g
) == gt
)
2745 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
2747 ffeglobal_set_hook (g
, current_function_decl
);
2750 /* Reset args in master arg list so they get retransitioned. */
2752 for (item
= ffecom_master_arglist_
;
2754 item
= ffebld_trail (item
))
2759 arg
= ffebld_head (item
);
2760 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2761 continue; /* Alternate return or some such thing. */
2762 s
= ffebld_symter (arg
);
2763 ffesymbol_hook (s
).decl_tree
= NULL_TREE
;
2764 ffesymbol_hook (s
).length_tree
= NULL_TREE
;
2767 /* Build dummy arg list for this entry point. */
2769 if (charfunc
|| cmplxfunc
)
2770 { /* Prepend arg for where result goes. */
2775 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
2777 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
2779 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
2781 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2784 length
= ffecom_char_enhance_arg_ (&type
, fn
);
2786 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
2788 type
= build_pointer_type (type
);
2789 result
= build_decl (PARM_DECL
, result
, type
);
2791 push_parm_decl (result
);
2792 ffecom_func_result_
= result
;
2796 push_parm_decl (length
);
2797 ffecom_func_length_
= length
;
2801 result
= DECL_RESULT (current_function_decl
);
2803 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn
), FALSE
);
2805 store_parm_decls (0);
2807 ffecom_start_compstmt ();
2808 /* Disallow temp vars at this level. */
2809 current_binding_level
->prep_state
= 2;
2811 /* Make local var to hold return type for multi-type master fn. */
2815 multi_retval
= ffecom_get_invented_identifier ("__g77_%s",
2817 multi_retval
= build_decl (VAR_DECL
, multi_retval
,
2818 ffecom_multi_type_node_
);
2819 multi_retval
= start_decl (multi_retval
, FALSE
);
2820 finish_decl (multi_retval
, NULL_TREE
, FALSE
);
2823 multi_retval
= NULL_TREE
; /* Not actually ref'd if !multi. */
2825 /* Here we emit the actual code for the entry point. */
2831 tree arglist
= NULL_TREE
;
2832 tree
*plist
= &arglist
;
2838 /* Prepare actual arg list based on master arg list. */
2840 for (list
= ffecom_master_arglist_
;
2842 list
= ffebld_trail (list
))
2844 arg
= ffebld_head (list
);
2845 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2847 s
= ffebld_symter (arg
);
2848 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
2849 || ffesymbol_hook (s
).decl_tree
== error_mark_node
)
2850 actarg
= null_pointer_node
; /* We don't have this arg. */
2852 actarg
= ffesymbol_hook (s
).decl_tree
;
2853 *plist
= build_tree_list (NULL_TREE
, actarg
);
2854 plist
= &TREE_CHAIN (*plist
);
2857 /* This code appends the length arguments for character
2858 variables/arrays. */
2860 for (list
= ffecom_master_arglist_
;
2862 list
= ffebld_trail (list
))
2864 arg
= ffebld_head (list
);
2865 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2867 s
= ffebld_symter (arg
);
2868 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
2869 continue; /* Only looking for CHARACTER arguments. */
2870 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
2871 continue; /* Only looking for variables and arrays. */
2872 if (ffesymbol_hook (s
).length_tree
== NULL_TREE
2873 || ffesymbol_hook (s
).length_tree
== error_mark_node
)
2874 actarg
= ffecom_f2c_ftnlen_zero_node
; /* We don't have this arg. */
2876 actarg
= ffesymbol_hook (s
).length_tree
;
2877 *plist
= build_tree_list (NULL_TREE
, actarg
);
2878 plist
= &TREE_CHAIN (*plist
);
2881 /* Prepend character-value return info to actual arg list. */
2885 prepend
= build_tree_list (NULL_TREE
, ffecom_func_result_
);
2886 TREE_CHAIN (prepend
)
2887 = build_tree_list (NULL_TREE
, ffecom_func_length_
);
2888 TREE_CHAIN (TREE_CHAIN (prepend
)) = arglist
;
2892 /* Prepend multi-type return value to actual arg list. */
2897 = build_tree_list (NULL_TREE
,
2898 ffecom_1 (ADDR_EXPR
,
2899 build_pointer_type (TREE_TYPE (multi_retval
)),
2901 TREE_CHAIN (prepend
) = arglist
;
2905 /* Prepend my entry-point number to the actual arg list. */
2907 prepend
= build_tree_list (NULL_TREE
, build_int_2 (entrynum
, 0));
2908 TREE_CHAIN (prepend
) = arglist
;
2911 /* Build the call to the master function. */
2913 master_fn
= ffecom_1_fn (ffecom_previous_function_decl_
);
2914 call
= ffecom_3s (CALL_EXPR
,
2915 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn
))),
2916 master_fn
, arglist
, NULL_TREE
);
2918 /* Decide whether the master function is a function or subroutine, and
2919 handle the return value for my entry point. */
2921 if (charfunc
|| ((ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
2924 expand_expr_stmt (call
);
2925 expand_null_return ();
2927 else if (multi
&& cmplxfunc
)
2929 expand_expr_stmt (call
);
2931 = ffecom_1 (INDIRECT_REF
,
2932 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2934 result
= ffecom_modify (NULL_TREE
, result
,
2935 ffecom_2 (COMPONENT_REF
, TREE_TYPE (result
),
2937 ffecom_multi_fields_
[bt
][kt
]));
2938 expand_expr_stmt (result
);
2939 expand_null_return ();
2943 expand_expr_stmt (call
);
2945 = ffecom_modify (NULL_TREE
, result
,
2946 convert (TREE_TYPE (result
),
2947 ffecom_2 (COMPONENT_REF
,
2948 ffecom_tree_type
[bt
][kt
],
2950 ffecom_multi_fields_
[bt
][kt
])));
2951 expand_return (result
);
2956 = ffecom_1 (INDIRECT_REF
,
2957 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2959 result
= ffecom_modify (NULL_TREE
, result
, call
);
2960 expand_expr_stmt (result
);
2961 expand_null_return ();
2965 result
= ffecom_modify (NULL_TREE
,
2967 convert (TREE_TYPE (result
),
2969 expand_return (result
);
2973 ffecom_end_compstmt ();
2975 finish_function (0);
2977 lineno
= old_lineno
;
2978 input_filename
= old_input_filename
;
2980 ffecom_doing_entry_
= FALSE
;
2984 /* Transform expr into gcc tree with possible destination
2986 Recursive descent on expr while making corresponding tree nodes and
2987 attaching type info and such. If destination supplied and compatible
2988 with temporary that would be made in certain cases, temporary isn't
2989 made, destination used instead, and dest_used flag set TRUE. */
2991 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2993 ffecom_expr_ (ffebld expr
, tree dest_tree
, ffebld dest
,
2994 bool *dest_used
, bool assignp
, bool widenp
)
2999 ffeinfoBasictype bt
;
3002 tree dt
; /* decl_tree for an ffesymbol. */
3003 tree tree_type
, tree_type_x
;
3006 enum tree_code code
;
3008 assert (expr
!= NULL
);
3010 if (dest_used
!= NULL
)
3013 bt
= ffeinfo_basictype (ffebld_info (expr
));
3014 kt
= ffeinfo_kindtype (ffebld_info (expr
));
3015 tree_type
= ffecom_tree_type
[bt
][kt
];
3017 /* Widen integral arithmetic as desired while preserving signedness. */
3018 tree_type_x
= NULL_TREE
;
3019 if (widenp
&& tree_type
3020 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
3021 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
3022 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
3024 switch (ffebld_op (expr
))
3026 case FFEBLD_opACCTER
:
3029 ffebit bits
= ffebld_accter_bits (expr
);
3030 ffetargetOffset source_offset
= 0;
3031 ffetargetOffset dest_offset
= ffebld_accter_pad (expr
);
3034 assert (dest_offset
== 0
3035 || (bt
== FFEINFO_basictypeCHARACTER
3036 && kt
== FFEINFO_kindtypeCHARACTER1
));
3041 ffebldConstantUnion cu
;
3044 ffebldConstantArray ca
= ffebld_accter (expr
);
3046 ffebit_test (bits
, source_offset
, &value
, &length
);
3052 for (i
= 0; i
< length
; ++i
)
3054 cu
= ffebld_constantarray_get (ca
, bt
, kt
,
3057 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
3060 && dest_offset
!= 0)
3061 purpose
= build_int_2 (dest_offset
, 0);
3063 purpose
= NULL_TREE
;
3065 if (list
== NULL_TREE
)
3066 list
= item
= build_tree_list (purpose
, t
);
3069 TREE_CHAIN (item
) = build_tree_list (purpose
, t
);
3070 item
= TREE_CHAIN (item
);
3074 source_offset
+= length
;
3075 dest_offset
+= length
;
3079 item
= build_int_2 ((ffebld_accter_size (expr
)
3080 + ffebld_accter_pad (expr
)) - 1, 0);
3081 ffebit_kill (ffebld_accter_bits (expr
));
3082 TREE_TYPE (item
) = ffecom_integer_type_node
;
3086 build_range_type (ffecom_integer_type_node
,
3087 ffecom_integer_zero_node
,
3089 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
3090 TREE_CONSTANT (list
) = 1;
3091 TREE_STATIC (list
) = 1;
3094 case FFEBLD_opARRTER
:
3099 if (ffebld_arrter_pad (expr
) == 0)
3103 assert (bt
== FFEINFO_basictypeCHARACTER
3104 && kt
== FFEINFO_kindtypeCHARACTER1
);
3106 /* Becomes PURPOSE first time through loop. */
3107 item
= build_int_2 (ffebld_arrter_pad (expr
), 0);
3110 for (i
= 0; i
< ffebld_arrter_size (expr
); ++i
)
3112 ffebldConstantUnion cu
3113 = ffebld_constantarray_get (ffebld_arrter (expr
), bt
, kt
, i
);
3115 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
3117 if (list
== NULL_TREE
)
3118 /* Assume item is PURPOSE first time through loop. */
3119 list
= item
= build_tree_list (item
, t
);
3122 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
3123 item
= TREE_CHAIN (item
);
3128 item
= build_int_2 ((ffebld_arrter_size (expr
)
3129 + ffebld_arrter_pad (expr
)) - 1, 0);
3130 TREE_TYPE (item
) = ffecom_integer_type_node
;
3134 build_range_type (ffecom_integer_type_node
,
3135 ffecom_integer_zero_node
,
3137 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
3138 TREE_CONSTANT (list
) = 1;
3139 TREE_STATIC (list
) = 1;
3142 case FFEBLD_opCONTER
:
3143 assert (ffebld_conter_pad (expr
) == 0);
3145 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr
)),
3149 case FFEBLD_opSYMTER
:
3150 if ((ffebld_symter_generic (expr
) != FFEINTRIN_genNONE
)
3151 || (ffebld_symter_specific (expr
) != FFEINTRIN_specNONE
))
3152 return ffecom_ptr_to_expr (expr
); /* Same as %REF(intrinsic). */
3153 s
= ffebld_symter (expr
);
3154 t
= ffesymbol_hook (s
).decl_tree
;
3157 { /* ASSIGN'ed-label expr. */
3158 if (ffe_is_ugly_assign ())
3160 /* User explicitly wants ASSIGN'ed variables to be at the same
3161 memory address as the variables when used in non-ASSIGN
3162 contexts. That can make old, arcane, non-standard code
3163 work, but don't try to do it when a pointer wouldn't fit
3164 in the normal variable (take other approach, and warn,
3169 s
= ffecom_sym_transform_ (s
);
3170 t
= ffesymbol_hook (s
).decl_tree
;
3171 assert (t
!= NULL_TREE
);
3174 if (t
== error_mark_node
)
3177 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t
)))
3178 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
3180 if (ffesymbol_hook (s
).addr
)
3181 t
= ffecom_1 (INDIRECT_REF
,
3182 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
3186 if (ffesymbol_hook (s
).assign_tree
== NULL_TREE
)
3188 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3189 FFEBAD_severityWARNING
);
3190 ffebad_string (ffesymbol_text (s
));
3191 ffebad_here (0, ffesymbol_where_line (s
),
3192 ffesymbol_where_column (s
));
3197 /* Don't use the normal variable's tree for ASSIGN, though mark
3198 it as in the system header (housekeeping). Use an explicit,
3199 specially created sibling that is known to be wide enough
3200 to hold pointers to labels. */
3203 && TREE_CODE (t
) == VAR_DECL
)
3204 DECL_IN_SYSTEM_HEADER (t
) = 1; /* Don't let -Wunused complain. */
3206 t
= ffesymbol_hook (s
).assign_tree
;
3209 s
= ffecom_sym_transform_assign_ (s
);
3210 t
= ffesymbol_hook (s
).assign_tree
;
3211 assert (t
!= NULL_TREE
);
3218 s
= ffecom_sym_transform_ (s
);
3219 t
= ffesymbol_hook (s
).decl_tree
;
3220 assert (t
!= NULL_TREE
);
3222 if (ffesymbol_hook (s
).addr
)
3223 t
= ffecom_1 (INDIRECT_REF
,
3224 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
3228 case FFEBLD_opARRAYREF
:
3229 return ffecom_arrayref_ (NULL_TREE
, expr
, 0);
3231 case FFEBLD_opUPLUS
:
3232 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3233 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3235 case FFEBLD_opPAREN
:
3236 /* ~~~Make sure Fortran rules respected here */
3237 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3238 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3240 case FFEBLD_opUMINUS
:
3241 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3244 tree_type
= tree_type_x
;
3245 left
= convert (tree_type
, left
);
3247 return ffecom_1 (NEGATE_EXPR
, tree_type
, left
);
3250 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3251 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3254 tree_type
= tree_type_x
;
3255 left
= convert (tree_type
, left
);
3256 right
= convert (tree_type
, right
);
3258 return ffecom_2 (PLUS_EXPR
, tree_type
, left
, right
);
3260 case FFEBLD_opSUBTRACT
:
3261 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3262 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3265 tree_type
= tree_type_x
;
3266 left
= convert (tree_type
, left
);
3267 right
= convert (tree_type
, right
);
3269 return ffecom_2 (MINUS_EXPR
, tree_type
, left
, right
);
3271 case FFEBLD_opMULTIPLY
:
3272 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3273 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3276 tree_type
= tree_type_x
;
3277 left
= convert (tree_type
, left
);
3278 right
= convert (tree_type
, right
);
3280 return ffecom_2 (MULT_EXPR
, tree_type
, left
, right
);
3282 case FFEBLD_opDIVIDE
:
3283 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3284 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3287 tree_type
= tree_type_x
;
3288 left
= convert (tree_type
, left
);
3289 right
= convert (tree_type
, right
);
3291 return ffecom_tree_divide_ (tree_type
, left
, right
,
3292 dest_tree
, dest
, dest_used
,
3293 ffebld_nonter_hook (expr
));
3295 case FFEBLD_opPOWER
:
3297 ffebld left
= ffebld_left (expr
);
3298 ffebld right
= ffebld_right (expr
);
3300 ffeinfoKindtype rtkt
;
3301 ffeinfoKindtype ltkt
;
3304 switch (ffeinfo_basictype (ffebld_info (right
)))
3307 case FFEINFO_basictypeINTEGER
:
3310 item
= ffecom_expr_power_integer_ (expr
);
3311 if (item
!= NULL_TREE
)
3315 rtkt
= FFEINFO_kindtypeINTEGER1
;
3316 switch (ffeinfo_basictype (ffebld_info (left
)))
3318 case FFEINFO_basictypeINTEGER
:
3319 if ((ffeinfo_kindtype (ffebld_info (left
))
3320 == FFEINFO_kindtypeINTEGER4
)
3321 || (ffeinfo_kindtype (ffebld_info (right
))
3322 == FFEINFO_kindtypeINTEGER4
))
3324 code
= FFECOM_gfrtPOW_QQ
;
3325 ltkt
= FFEINFO_kindtypeINTEGER4
;
3326 rtkt
= FFEINFO_kindtypeINTEGER4
;
3330 code
= FFECOM_gfrtPOW_II
;
3331 ltkt
= FFEINFO_kindtypeINTEGER1
;
3335 case FFEINFO_basictypeREAL
:
3336 if (ffeinfo_kindtype (ffebld_info (left
))
3337 == FFEINFO_kindtypeREAL1
)
3339 code
= FFECOM_gfrtPOW_RI
;
3340 ltkt
= FFEINFO_kindtypeREAL1
;
3344 code
= FFECOM_gfrtPOW_DI
;
3345 ltkt
= FFEINFO_kindtypeREAL2
;
3349 case FFEINFO_basictypeCOMPLEX
:
3350 if (ffeinfo_kindtype (ffebld_info (left
))
3351 == FFEINFO_kindtypeREAL1
)
3353 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3354 ltkt
= FFEINFO_kindtypeREAL1
;
3358 code
= FFECOM_gfrtPOW_ZI
; /* Overlapping result okay. */
3359 ltkt
= FFEINFO_kindtypeREAL2
;
3364 assert ("bad pow_*i" == NULL
);
3365 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3366 ltkt
= FFEINFO_kindtypeREAL1
;
3369 if (ffeinfo_kindtype (ffebld_info (left
)) != ltkt
)
3370 left
= ffeexpr_convert (left
, NULL
, NULL
,
3371 ffeinfo_basictype (ffebld_info (left
)),
3373 FFETARGET_charactersizeNONE
,
3374 FFEEXPR_contextLET
);
3375 if (ffeinfo_kindtype (ffebld_info (right
)) != rtkt
)
3376 right
= ffeexpr_convert (right
, NULL
, NULL
,
3377 FFEINFO_basictypeINTEGER
,
3379 FFETARGET_charactersizeNONE
,
3380 FFEEXPR_contextLET
);
3383 case FFEINFO_basictypeREAL
:
3384 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3385 left
= ffeexpr_convert (left
, NULL
, NULL
, FFEINFO_basictypeREAL
,
3386 FFEINFO_kindtypeREALDOUBLE
, 0,
3387 FFETARGET_charactersizeNONE
,
3388 FFEEXPR_contextLET
);
3389 if (ffeinfo_kindtype (ffebld_info (right
))
3390 == FFEINFO_kindtypeREAL1
)
3391 right
= ffeexpr_convert (right
, NULL
, NULL
,
3392 FFEINFO_basictypeREAL
,
3393 FFEINFO_kindtypeREALDOUBLE
, 0,
3394 FFETARGET_charactersizeNONE
,
3395 FFEEXPR_contextLET
);
3396 /* We used to call FFECOM_gfrtPOW_DD here,
3397 which passes arguments by reference. */
3398 code
= FFECOM_gfrtL_POW
;
3399 /* Pass arguments by value. */
3403 case FFEINFO_basictypeCOMPLEX
:
3404 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3405 left
= ffeexpr_convert (left
, NULL
, NULL
,
3406 FFEINFO_basictypeCOMPLEX
,
3407 FFEINFO_kindtypeREALDOUBLE
, 0,
3408 FFETARGET_charactersizeNONE
,
3409 FFEEXPR_contextLET
);
3410 if (ffeinfo_kindtype (ffebld_info (right
))
3411 == FFEINFO_kindtypeREAL1
)
3412 right
= ffeexpr_convert (right
, NULL
, NULL
,
3413 FFEINFO_basictypeCOMPLEX
,
3414 FFEINFO_kindtypeREALDOUBLE
, 0,
3415 FFETARGET_charactersizeNONE
,
3416 FFEEXPR_contextLET
);
3417 code
= FFECOM_gfrtPOW_ZZ
; /* Overlapping result okay. */
3418 ref
= TRUE
; /* Pass arguments by reference. */
3422 assert ("bad pow_x*" == NULL
);
3423 code
= FFECOM_gfrtPOW_II
;
3426 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code
),
3427 ffecom_gfrt_kindtype (code
),
3428 (ffe_is_f2c_library ()
3429 && ffecom_gfrt_complex_
[code
]),
3430 tree_type
, left
, right
,
3431 dest_tree
, dest
, dest_used
,
3432 NULL_TREE
, FALSE
, ref
,
3433 ffebld_nonter_hook (expr
));
3439 case FFEINFO_basictypeLOGICAL
:
3440 item
= ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr
)));
3441 return convert (tree_type
, item
);
3443 case FFEINFO_basictypeINTEGER
:
3444 return ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3445 ffecom_expr (ffebld_left (expr
)));
3448 assert ("NOT bad basictype" == NULL
);
3450 case FFEINFO_basictypeANY
:
3451 return error_mark_node
;
3455 case FFEBLD_opFUNCREF
:
3456 assert (ffeinfo_basictype (ffebld_info (expr
))
3457 != FFEINFO_basictypeCHARACTER
);
3459 case FFEBLD_opSUBRREF
:
3460 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
3461 == FFEINFO_whereINTRINSIC
)
3462 { /* Invocation of an intrinsic. */
3463 item
= ffecom_expr_intrinsic_ (expr
, dest_tree
, dest
,
3467 s
= ffebld_symter (ffebld_left (expr
));
3468 dt
= ffesymbol_hook (s
).decl_tree
;
3469 if (dt
== NULL_TREE
)
3471 s
= ffecom_sym_transform_ (s
);
3472 dt
= ffesymbol_hook (s
).decl_tree
;
3474 if (dt
== error_mark_node
)
3477 if (ffesymbol_hook (s
).addr
)
3480 item
= ffecom_1_fn (dt
);
3482 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
3483 args
= ffecom_list_expr (ffebld_right (expr
));
3485 args
= ffecom_list_ptr_to_expr (ffebld_right (expr
));
3487 if (args
== error_mark_node
)
3488 return error_mark_node
;
3490 item
= ffecom_call_ (item
, kt
,
3491 ffesymbol_is_f2c (s
)
3492 && (bt
== FFEINFO_basictypeCOMPLEX
)
3493 && (ffesymbol_where (s
)
3494 != FFEINFO_whereCONSTANT
),
3497 dest_tree
, dest
, dest_used
,
3498 error_mark_node
, FALSE
,
3499 ffebld_nonter_hook (expr
));
3500 TREE_SIDE_EFFECTS (item
) = 1;
3506 case FFEINFO_basictypeLOGICAL
:
3508 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3509 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3510 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3511 return convert (tree_type
, item
);
3513 case FFEINFO_basictypeINTEGER
:
3514 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
3515 ffecom_expr (ffebld_left (expr
)),
3516 ffecom_expr (ffebld_right (expr
)));
3519 assert ("AND bad basictype" == NULL
);
3521 case FFEINFO_basictypeANY
:
3522 return error_mark_node
;
3529 case FFEINFO_basictypeLOGICAL
:
3531 = ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
3532 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3533 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3534 return convert (tree_type
, item
);
3536 case FFEINFO_basictypeINTEGER
:
3537 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
3538 ffecom_expr (ffebld_left (expr
)),
3539 ffecom_expr (ffebld_right (expr
)));
3542 assert ("OR bad basictype" == NULL
);
3544 case FFEINFO_basictypeANY
:
3545 return error_mark_node
;
3553 case FFEINFO_basictypeLOGICAL
:
3555 = ffecom_2 (NE_EXPR
, integer_type_node
,
3556 ffecom_expr (ffebld_left (expr
)),
3557 ffecom_expr (ffebld_right (expr
)));
3558 return convert (tree_type
, ffecom_truth_value (item
));
3560 case FFEINFO_basictypeINTEGER
:
3561 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3562 ffecom_expr (ffebld_left (expr
)),
3563 ffecom_expr (ffebld_right (expr
)));
3566 assert ("XOR/NEQV bad basictype" == NULL
);
3568 case FFEINFO_basictypeANY
:
3569 return error_mark_node
;
3576 case FFEINFO_basictypeLOGICAL
:
3578 = ffecom_2 (EQ_EXPR
, integer_type_node
,
3579 ffecom_expr (ffebld_left (expr
)),
3580 ffecom_expr (ffebld_right (expr
)));
3581 return convert (tree_type
, ffecom_truth_value (item
));
3583 case FFEINFO_basictypeINTEGER
:
3585 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3586 ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3587 ffecom_expr (ffebld_left (expr
)),
3588 ffecom_expr (ffebld_right (expr
))));
3591 assert ("EQV bad basictype" == NULL
);
3593 case FFEINFO_basictypeANY
:
3594 return error_mark_node
;
3598 case FFEBLD_opCONVERT
:
3599 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opANY
)
3600 return error_mark_node
;
3604 case FFEINFO_basictypeLOGICAL
:
3605 case FFEINFO_basictypeINTEGER
:
3606 case FFEINFO_basictypeREAL
:
3607 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3609 case FFEINFO_basictypeCOMPLEX
:
3610 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3612 case FFEINFO_basictypeINTEGER
:
3613 case FFEINFO_basictypeLOGICAL
:
3614 case FFEINFO_basictypeREAL
:
3615 item
= ffecom_expr (ffebld_left (expr
));
3616 if (item
== error_mark_node
)
3617 return error_mark_node
;
3618 /* convert() takes care of converting to the subtype first,
3619 at least in gcc-2.7.2. */
3620 item
= convert (tree_type
, item
);
3623 case FFEINFO_basictypeCOMPLEX
:
3624 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3627 assert ("CONVERT COMPLEX bad basictype" == NULL
);
3629 case FFEINFO_basictypeANY
:
3630 return error_mark_node
;
3635 assert ("CONVERT bad basictype" == NULL
);
3637 case FFEINFO_basictypeANY
:
3638 return error_mark_node
;
3644 goto relational
; /* :::::::::::::::::::: */
3648 goto relational
; /* :::::::::::::::::::: */
3652 goto relational
; /* :::::::::::::::::::: */
3656 goto relational
; /* :::::::::::::::::::: */
3660 goto relational
; /* :::::::::::::::::::: */
3665 relational
: /* :::::::::::::::::::: */
3666 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3668 case FFEINFO_basictypeLOGICAL
:
3669 case FFEINFO_basictypeINTEGER
:
3670 case FFEINFO_basictypeREAL
:
3671 item
= ffecom_2 (code
, integer_type_node
,
3672 ffecom_expr (ffebld_left (expr
)),
3673 ffecom_expr (ffebld_right (expr
)));
3674 return convert (tree_type
, item
);
3676 case FFEINFO_basictypeCOMPLEX
:
3677 assert (code
== EQ_EXPR
|| code
== NE_EXPR
);
3680 tree arg1
= ffecom_expr (ffebld_left (expr
));
3681 tree arg2
= ffecom_expr (ffebld_right (expr
));
3683 if (arg1
== error_mark_node
|| arg2
== error_mark_node
)
3684 return error_mark_node
;
3686 arg1
= ffecom_save_tree (arg1
);
3687 arg2
= ffecom_save_tree (arg2
);
3689 if (TREE_CODE (TREE_TYPE (arg1
)) == COMPLEX_TYPE
)
3691 real_type
= TREE_TYPE (TREE_TYPE (arg1
));
3692 assert (real_type
== TREE_TYPE (TREE_TYPE (arg2
)));
3696 real_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1
)));
3697 assert (real_type
== TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2
))));
3701 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3702 ffecom_2 (EQ_EXPR
, integer_type_node
,
3703 ffecom_1 (REALPART_EXPR
, real_type
, arg1
),
3704 ffecom_1 (REALPART_EXPR
, real_type
, arg2
)),
3705 ffecom_2 (EQ_EXPR
, integer_type_node
,
3706 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1
),
3707 ffecom_1 (IMAGPART_EXPR
, real_type
,
3709 if (code
== EQ_EXPR
)
3710 item
= ffecom_truth_value (item
);
3712 item
= ffecom_truth_value_invert (item
);
3713 return convert (tree_type
, item
);
3716 case FFEINFO_basictypeCHARACTER
:
3718 ffebld left
= ffebld_left (expr
);
3719 ffebld right
= ffebld_right (expr
);
3725 /* f2c run-time functions do the implicit blank-padding for us,
3726 so we don't usually have to implement blank-padding ourselves.
3727 (The exception is when we pass an argument to a separately
3728 compiled statement function -- if we know the arg is not the
3729 same length as the dummy, we must truncate or extend it. If
3730 we "inline" statement functions, that necessity goes away as
3733 Strip off the CONVERT operators that blank-pad. (Truncation by
3734 CONVERT shouldn't happen here, but it can happen in
3737 while (ffebld_op (left
) == FFEBLD_opCONVERT
)
3738 left
= ffebld_left (left
);
3739 while (ffebld_op (right
) == FFEBLD_opCONVERT
)
3740 right
= ffebld_left (right
);
3742 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
3743 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
3745 if (left_tree
== error_mark_node
|| left_length
== error_mark_node
3746 || right_tree
== error_mark_node
3747 || right_length
== error_mark_node
)
3748 return error_mark_node
;
3750 if ((ffebld_size_known (left
) == 1)
3751 && (ffebld_size_known (right
) == 1))
3754 = ffecom_1 (INDIRECT_REF
,
3755 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3758 = ffecom_1 (INDIRECT_REF
,
3759 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3763 = ffecom_2 (code
, integer_type_node
,
3764 ffecom_2 (ARRAY_REF
,
3765 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3768 ffecom_2 (ARRAY_REF
,
3769 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3775 item
= build_tree_list (NULL_TREE
, left_tree
);
3776 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, right_tree
);
3777 TREE_CHAIN (TREE_CHAIN (item
)) = build_tree_list (NULL_TREE
,
3779 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
3780 = build_tree_list (NULL_TREE
, right_length
);
3781 item
= ffecom_call_gfrt (FFECOM_gfrtCMP
, item
, NULL_TREE
);
3782 item
= ffecom_2 (code
, integer_type_node
,
3784 convert (TREE_TYPE (item
),
3785 integer_zero_node
));
3787 item
= convert (tree_type
, item
);
3793 assert ("relational bad basictype" == NULL
);
3795 case FFEINFO_basictypeANY
:
3796 return error_mark_node
;
3800 case FFEBLD_opPERCENT_LOC
:
3801 item
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &list
);
3802 return convert (tree_type
, item
);
3806 case FFEBLD_opBOUNDS
:
3807 case FFEBLD_opREPEAT
:
3808 case FFEBLD_opLABTER
:
3809 case FFEBLD_opLABTOK
:
3810 case FFEBLD_opIMPDO
:
3811 case FFEBLD_opCONCATENATE
:
3812 case FFEBLD_opSUBSTR
:
3814 assert ("bad op" == NULL
);
3817 return error_mark_node
;
3821 assert ("didn't think anything got here anymore!!" == NULL
);
3823 switch (ffebld_arity (expr
))
3826 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3827 TREE_OPERAND (item
, 1) = ffecom_expr (ffebld_right (expr
));
3828 if (TREE_OPERAND (item
, 0) == error_mark_node
3829 || TREE_OPERAND (item
, 1) == error_mark_node
)
3830 return error_mark_node
;
3834 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3835 if (TREE_OPERAND (item
, 0) == error_mark_node
)
3836 return error_mark_node
;
3848 /* Returns the tree that does the intrinsic invocation.
3850 Note: this function applies only to intrinsics returning
3851 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3854 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3856 ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
3857 ffebld dest
, bool *dest_used
)
3860 tree saved_expr1
; /* For those who need it. */
3861 tree saved_expr2
; /* For those who need it. */
3862 ffeinfoBasictype bt
;
3866 tree real_type
; /* REAL type corresponding to COMPLEX. */
3868 ffebld list
= ffebld_right (expr
); /* List of (some) args. */
3869 ffebld arg1
; /* For handy reference. */
3872 ffeintrinImp codegen_imp
;
3875 assert (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
);
3877 if (dest_used
!= NULL
)
3880 bt
= ffeinfo_basictype (ffebld_info (expr
));
3881 kt
= ffeinfo_kindtype (ffebld_info (expr
));
3882 tree_type
= ffecom_tree_type
[bt
][kt
];
3886 arg1
= ffebld_head (list
);
3887 if (arg1
!= NULL
&& ffebld_op (arg1
) == FFEBLD_opANY
)
3888 return error_mark_node
;
3889 if ((list
= ffebld_trail (list
)) != NULL
)
3891 arg2
= ffebld_head (list
);
3892 if (arg2
!= NULL
&& ffebld_op (arg2
) == FFEBLD_opANY
)
3893 return error_mark_node
;
3894 if ((list
= ffebld_trail (list
)) != NULL
)
3896 arg3
= ffebld_head (list
);
3897 if (arg3
!= NULL
&& ffebld_op (arg3
) == FFEBLD_opANY
)
3898 return error_mark_node
;
3907 arg1
= arg2
= arg3
= NULL
;
3909 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3910 args. This is used by the MAX/MIN expansions. */
3913 arg1_type
= ffecom_tree_type
3914 [ffeinfo_basictype (ffebld_info (arg1
))]
3915 [ffeinfo_kindtype (ffebld_info (arg1
))];
3917 arg1_type
= NULL_TREE
; /* Really not needed, but might catch bugs
3920 /* There are several ways for each of the cases in the following switch
3921 statements to exit (from simplest to use to most complicated):
3923 break; (when expr_tree == NULL)
3925 A standard call is made to the specific intrinsic just as if it had been
3926 passed in as a dummy procedure and called as any old procedure. This
3927 method can produce slower code but in some cases it's the easiest way for
3928 now. However, if a (presumably faster) direct call is available,
3929 that is used, so this is the easiest way in many more cases now.
3931 gfrt = FFECOM_gfrtWHATEVER;
3934 gfrt contains the gfrt index of a library function to call, passing the
3935 argument(s) by value rather than by reference. Used when a more
3936 careful choice of library function is needed than that provided
3937 by the vanilla `break;'.
3941 The expr_tree has been completely set up and is ready to be returned
3942 as is. No further actions are taken. Use this when the tree is not
3943 in the simple form for one of the arity_n labels. */
3945 /* For info on how the switch statement cases were written, see the files
3946 enclosed in comments below the switch statement. */
3948 codegen_imp
= ffebld_symter_implementation (ffebld_left (expr
));
3949 gfrt
= ffeintrin_gfrt_direct (codegen_imp
);
3950 if (gfrt
== FFECOM_gfrt
)
3951 gfrt
= ffeintrin_gfrt_indirect (codegen_imp
);
3953 switch (codegen_imp
)
3955 case FFEINTRIN_impABS
:
3956 case FFEINTRIN_impCABS
:
3957 case FFEINTRIN_impCDABS
:
3958 case FFEINTRIN_impDABS
:
3959 case FFEINTRIN_impIABS
:
3960 if (ffeinfo_basictype (ffebld_info (arg1
))
3961 == FFEINFO_basictypeCOMPLEX
)
3963 if (kt
== FFEINFO_kindtypeREAL1
)
3964 gfrt
= FFECOM_gfrtCABS
;
3965 else if (kt
== FFEINFO_kindtypeREAL2
)
3966 gfrt
= FFECOM_gfrtCDABS
;
3969 return ffecom_1 (ABS_EXPR
, tree_type
,
3970 convert (tree_type
, ffecom_expr (arg1
)));
3972 case FFEINTRIN_impACOS
:
3973 case FFEINTRIN_impDACOS
:
3976 case FFEINTRIN_impAIMAG
:
3977 case FFEINTRIN_impDIMAG
:
3978 case FFEINTRIN_impIMAGPART
:
3979 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
3980 arg1_type
= TREE_TYPE (arg1_type
);
3982 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
3986 ffecom_1 (IMAGPART_EXPR
, arg1_type
,
3987 ffecom_expr (arg1
)));
3989 case FFEINTRIN_impAINT
:
3990 case FFEINTRIN_impDINT
:
3992 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
3993 return ffecom_1 (FIX_TRUNC_EXPR
, tree_type
, ffecom_expr (arg1
));
3994 #else /* in the meantime, must use floor to avoid range problems with ints */
3995 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3996 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3999 ffecom_3 (COND_EXPR
, double_type_node
,
4001 (ffecom_2 (GE_EXPR
, integer_type_node
,
4004 ffecom_float_zero_
))),
4005 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
4006 build_tree_list (NULL_TREE
,
4007 convert (double_type_node
,
4010 ffecom_1 (NEGATE_EXPR
, double_type_node
,
4011 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
4012 build_tree_list (NULL_TREE
,
4013 convert (double_type_node
,
4014 ffecom_1 (NEGATE_EXPR
,
4022 case FFEINTRIN_impANINT
:
4023 case FFEINTRIN_impDNINT
:
4024 #if 0 /* This way of doing it won't handle real
4025 numbers of large magnitudes. */
4026 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4027 expr_tree
= convert (tree_type
,
4028 convert (integer_type_node
,
4029 ffecom_3 (COND_EXPR
, tree_type
,
4034 ffecom_float_zero_
)),
4035 ffecom_2 (PLUS_EXPR
,
4038 ffecom_float_half_
),
4039 ffecom_2 (MINUS_EXPR
,
4042 ffecom_float_half_
))));
4044 #else /* So we instead call floor. */
4045 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4046 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4049 ffecom_3 (COND_EXPR
, double_type_node
,
4051 (ffecom_2 (GE_EXPR
, integer_type_node
,
4054 ffecom_float_zero_
))),
4055 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
4056 build_tree_list (NULL_TREE
,
4057 convert (double_type_node
,
4058 ffecom_2 (PLUS_EXPR
,
4062 ffecom_float_half_
)))),
4064 ffecom_1 (NEGATE_EXPR
, double_type_node
,
4065 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
4066 build_tree_list (NULL_TREE
,
4067 convert (double_type_node
,
4068 ffecom_2 (MINUS_EXPR
,
4071 ffecom_float_half_
),
4078 case FFEINTRIN_impASIN
:
4079 case FFEINTRIN_impDASIN
:
4080 case FFEINTRIN_impATAN
:
4081 case FFEINTRIN_impDATAN
:
4082 case FFEINTRIN_impATAN2
:
4083 case FFEINTRIN_impDATAN2
:
4086 case FFEINTRIN_impCHAR
:
4087 case FFEINTRIN_impACHAR
:
4089 tempvar
= ffecom_make_tempvar (char_type_node
, 1, -1);
4091 tempvar
= ffebld_nonter_hook (expr
);
4095 tree tmv
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar
)));
4097 expr_tree
= ffecom_modify (tmv
,
4098 ffecom_2 (ARRAY_REF
, tmv
, tempvar
,
4100 convert (tmv
, ffecom_expr (arg1
)));
4102 expr_tree
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
),
4105 expr_tree
= ffecom_1 (ADDR_EXPR
,
4106 build_pointer_type (TREE_TYPE (expr_tree
)),
4110 case FFEINTRIN_impCMPLX
:
4111 case FFEINTRIN_impDCMPLX
:
4114 convert (tree_type
, ffecom_expr (arg1
));
4116 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
4118 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4119 convert (real_type
, ffecom_expr (arg1
)),
4121 ffecom_expr (arg2
)));
4123 case FFEINTRIN_impCOMPLEX
:
4125 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4127 ffecom_expr (arg2
));
4129 case FFEINTRIN_impCONJG
:
4130 case FFEINTRIN_impDCONJG
:
4134 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
4135 arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4137 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4138 ffecom_1 (REALPART_EXPR
, real_type
, arg1_tree
),
4139 ffecom_1 (NEGATE_EXPR
, real_type
,
4140 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1_tree
)));
4143 case FFEINTRIN_impCOS
:
4144 case FFEINTRIN_impCCOS
:
4145 case FFEINTRIN_impCDCOS
:
4146 case FFEINTRIN_impDCOS
:
4147 if (bt
== FFEINFO_basictypeCOMPLEX
)
4149 if (kt
== FFEINFO_kindtypeREAL1
)
4150 gfrt
= FFECOM_gfrtCCOS
; /* Overlapping result okay. */
4151 else if (kt
== FFEINFO_kindtypeREAL2
)
4152 gfrt
= FFECOM_gfrtCDCOS
; /* Overlapping result okay. */
4156 case FFEINTRIN_impCOSH
:
4157 case FFEINTRIN_impDCOSH
:
4160 case FFEINTRIN_impDBLE
:
4161 case FFEINTRIN_impDFLOAT
:
4162 case FFEINTRIN_impDREAL
:
4163 case FFEINTRIN_impFLOAT
:
4164 case FFEINTRIN_impIDINT
:
4165 case FFEINTRIN_impIFIX
:
4166 case FFEINTRIN_impINT2
:
4167 case FFEINTRIN_impINT8
:
4168 case FFEINTRIN_impINT
:
4169 case FFEINTRIN_impLONG
:
4170 case FFEINTRIN_impREAL
:
4171 case FFEINTRIN_impSHORT
:
4172 case FFEINTRIN_impSNGL
:
4173 return convert (tree_type
, ffecom_expr (arg1
));
4175 case FFEINTRIN_impDIM
:
4176 case FFEINTRIN_impDDIM
:
4177 case FFEINTRIN_impIDIM
:
4178 saved_expr1
= ffecom_save_tree (convert (tree_type
,
4179 ffecom_expr (arg1
)));
4180 saved_expr2
= ffecom_save_tree (convert (tree_type
,
4181 ffecom_expr (arg2
)));
4183 ffecom_3 (COND_EXPR
, tree_type
,
4185 (ffecom_2 (GT_EXPR
, integer_type_node
,
4188 ffecom_2 (MINUS_EXPR
, tree_type
,
4191 convert (tree_type
, ffecom_float_zero_
));
4193 case FFEINTRIN_impDPROD
:
4195 ffecom_2 (MULT_EXPR
, tree_type
,
4196 convert (tree_type
, ffecom_expr (arg1
)),
4197 convert (tree_type
, ffecom_expr (arg2
)));
4199 case FFEINTRIN_impEXP
:
4200 case FFEINTRIN_impCDEXP
:
4201 case FFEINTRIN_impCEXP
:
4202 case FFEINTRIN_impDEXP
:
4203 if (bt
== FFEINFO_basictypeCOMPLEX
)
4205 if (kt
== FFEINFO_kindtypeREAL1
)
4206 gfrt
= FFECOM_gfrtCEXP
; /* Overlapping result okay. */
4207 else if (kt
== FFEINFO_kindtypeREAL2
)
4208 gfrt
= FFECOM_gfrtCDEXP
; /* Overlapping result okay. */
4212 case FFEINTRIN_impICHAR
:
4213 case FFEINTRIN_impIACHAR
:
4214 #if 0 /* The simple approach. */
4215 ffecom_char_args_ (&expr_tree
, &saved_expr1
/* Ignored */ , arg1
);
4217 = ffecom_1 (INDIRECT_REF
,
4218 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
4221 = ffecom_2 (ARRAY_REF
,
4222 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
4225 return convert (tree_type
, expr_tree
);
4226 #else /* The more interesting (and more optimal) approach. */
4227 expr_tree
= ffecom_intrinsic_ichar_ (tree_type
, arg1
, &saved_expr1
);
4228 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
4231 convert (tree_type
, integer_zero_node
));
4235 case FFEINTRIN_impINDEX
:
4238 case FFEINTRIN_impLEN
:
4240 break; /* The simple approach. */
4242 return ffecom_intrinsic_len_ (arg1
); /* The more optimal approach. */
4245 case FFEINTRIN_impLGE
:
4246 case FFEINTRIN_impLGT
:
4247 case FFEINTRIN_impLLE
:
4248 case FFEINTRIN_impLLT
:
4251 case FFEINTRIN_impLOG
:
4252 case FFEINTRIN_impALOG
:
4253 case FFEINTRIN_impCDLOG
:
4254 case FFEINTRIN_impCLOG
:
4255 case FFEINTRIN_impDLOG
:
4256 if (bt
== FFEINFO_basictypeCOMPLEX
)
4258 if (kt
== FFEINFO_kindtypeREAL1
)
4259 gfrt
= FFECOM_gfrtCLOG
; /* Overlapping result okay. */
4260 else if (kt
== FFEINFO_kindtypeREAL2
)
4261 gfrt
= FFECOM_gfrtCDLOG
; /* Overlapping result okay. */
4265 case FFEINTRIN_impLOG10
:
4266 case FFEINTRIN_impALOG10
:
4267 case FFEINTRIN_impDLOG10
:
4268 if (gfrt
!= FFECOM_gfrt
)
4269 break; /* Already picked one, stick with it. */
4271 if (kt
== FFEINFO_kindtypeREAL1
)
4272 /* We used to call FFECOM_gfrtALOG10 here. */
4273 gfrt
= FFECOM_gfrtL_LOG10
;
4274 else if (kt
== FFEINFO_kindtypeREAL2
)
4275 /* We used to call FFECOM_gfrtDLOG10 here. */
4276 gfrt
= FFECOM_gfrtL_LOG10
;
4279 case FFEINTRIN_impMAX
:
4280 case FFEINTRIN_impAMAX0
:
4281 case FFEINTRIN_impAMAX1
:
4282 case FFEINTRIN_impDMAX1
:
4283 case FFEINTRIN_impMAX0
:
4284 case FFEINTRIN_impMAX1
:
4285 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4286 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4288 arg1_type
= tree_type
;
4289 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4290 convert (arg1_type
, ffecom_expr (arg1
)),
4291 convert (arg1_type
, ffecom_expr (arg2
)));
4292 for (; list
!= NULL
; list
= ffebld_trail (list
))
4294 if ((ffebld_head (list
) == NULL
)
4295 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4297 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4300 ffecom_expr (ffebld_head (list
))));
4302 return convert (tree_type
, expr_tree
);
4304 case FFEINTRIN_impMIN
:
4305 case FFEINTRIN_impAMIN0
:
4306 case FFEINTRIN_impAMIN1
:
4307 case FFEINTRIN_impDMIN1
:
4308 case FFEINTRIN_impMIN0
:
4309 case FFEINTRIN_impMIN1
:
4310 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4311 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4313 arg1_type
= tree_type
;
4314 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4315 convert (arg1_type
, ffecom_expr (arg1
)),
4316 convert (arg1_type
, ffecom_expr (arg2
)));
4317 for (; list
!= NULL
; list
= ffebld_trail (list
))
4319 if ((ffebld_head (list
) == NULL
)
4320 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4322 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4325 ffecom_expr (ffebld_head (list
))));
4327 return convert (tree_type
, expr_tree
);
4329 case FFEINTRIN_impMOD
:
4330 case FFEINTRIN_impAMOD
:
4331 case FFEINTRIN_impDMOD
:
4332 if (bt
!= FFEINFO_basictypeREAL
)
4333 return ffecom_2 (TRUNC_MOD_EXPR
, tree_type
,
4334 convert (tree_type
, ffecom_expr (arg1
)),
4335 convert (tree_type
, ffecom_expr (arg2
)));
4337 if (kt
== FFEINFO_kindtypeREAL1
)
4338 /* We used to call FFECOM_gfrtAMOD here. */
4339 gfrt
= FFECOM_gfrtL_FMOD
;
4340 else if (kt
== FFEINFO_kindtypeREAL2
)
4341 /* We used to call FFECOM_gfrtDMOD here. */
4342 gfrt
= FFECOM_gfrtL_FMOD
;
4345 case FFEINTRIN_impNINT
:
4346 case FFEINTRIN_impIDNINT
:
4348 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4349 return ffecom_1 (FIX_ROUND_EXPR
, tree_type
, ffecom_expr (arg1
));
4351 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4352 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4354 convert (ffecom_integer_type_node
,
4355 ffecom_3 (COND_EXPR
, arg1_type
,
4357 (ffecom_2 (GE_EXPR
, integer_type_node
,
4360 ffecom_float_zero_
))),
4361 ffecom_2 (PLUS_EXPR
, arg1_type
,
4364 ffecom_float_half_
)),
4365 ffecom_2 (MINUS_EXPR
, arg1_type
,
4368 ffecom_float_half_
))));
4371 case FFEINTRIN_impSIGN
:
4372 case FFEINTRIN_impDSIGN
:
4373 case FFEINTRIN_impISIGN
:
4375 tree arg2_tree
= ffecom_expr (arg2
);
4379 (ffecom_1 (ABS_EXPR
, tree_type
,
4381 ffecom_expr (arg1
))));
4383 = ffecom_3 (COND_EXPR
, tree_type
,
4385 (ffecom_2 (GE_EXPR
, integer_type_node
,
4387 convert (TREE_TYPE (arg2_tree
),
4388 integer_zero_node
))),
4390 ffecom_1 (NEGATE_EXPR
, tree_type
, saved_expr1
));
4391 /* Make sure SAVE_EXPRs get referenced early enough. */
4393 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4394 convert (void_type_node
, saved_expr1
),
4399 case FFEINTRIN_impSIN
:
4400 case FFEINTRIN_impCDSIN
:
4401 case FFEINTRIN_impCSIN
:
4402 case FFEINTRIN_impDSIN
:
4403 if (bt
== FFEINFO_basictypeCOMPLEX
)
4405 if (kt
== FFEINFO_kindtypeREAL1
)
4406 gfrt
= FFECOM_gfrtCSIN
; /* Overlapping result okay. */
4407 else if (kt
== FFEINFO_kindtypeREAL2
)
4408 gfrt
= FFECOM_gfrtCDSIN
; /* Overlapping result okay. */
4412 case FFEINTRIN_impSINH
:
4413 case FFEINTRIN_impDSINH
:
4416 case FFEINTRIN_impSQRT
:
4417 case FFEINTRIN_impCDSQRT
:
4418 case FFEINTRIN_impCSQRT
:
4419 case FFEINTRIN_impDSQRT
:
4420 if (bt
== FFEINFO_basictypeCOMPLEX
)
4422 if (kt
== FFEINFO_kindtypeREAL1
)
4423 gfrt
= FFECOM_gfrtCSQRT
; /* Overlapping result okay. */
4424 else if (kt
== FFEINFO_kindtypeREAL2
)
4425 gfrt
= FFECOM_gfrtCDSQRT
; /* Overlapping result okay. */
4429 case FFEINTRIN_impTAN
:
4430 case FFEINTRIN_impDTAN
:
4431 case FFEINTRIN_impTANH
:
4432 case FFEINTRIN_impDTANH
:
4435 case FFEINTRIN_impREALPART
:
4436 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
4437 arg1_type
= TREE_TYPE (arg1_type
);
4439 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
4443 ffecom_1 (REALPART_EXPR
, arg1_type
,
4444 ffecom_expr (arg1
)));
4446 case FFEINTRIN_impIAND
:
4447 case FFEINTRIN_impAND
:
4448 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
4450 ffecom_expr (arg1
)),
4452 ffecom_expr (arg2
)));
4454 case FFEINTRIN_impIOR
:
4455 case FFEINTRIN_impOR
:
4456 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4458 ffecom_expr (arg1
)),
4460 ffecom_expr (arg2
)));
4462 case FFEINTRIN_impIEOR
:
4463 case FFEINTRIN_impXOR
:
4464 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
4466 ffecom_expr (arg1
)),
4468 ffecom_expr (arg2
)));
4470 case FFEINTRIN_impLSHIFT
:
4471 return ffecom_2 (LSHIFT_EXPR
, tree_type
,
4473 convert (integer_type_node
,
4474 ffecom_expr (arg2
)));
4476 case FFEINTRIN_impRSHIFT
:
4477 return ffecom_2 (RSHIFT_EXPR
, tree_type
,
4479 convert (integer_type_node
,
4480 ffecom_expr (arg2
)));
4482 case FFEINTRIN_impNOT
:
4483 return ffecom_1 (BIT_NOT_EXPR
, tree_type
, ffecom_expr (arg1
));
4485 case FFEINTRIN_impBIT_SIZE
:
4486 return convert (tree_type
, TYPE_SIZE (arg1_type
));
4488 case FFEINTRIN_impBTEST
:
4490 ffetargetLogical1 target_true
;
4491 ffetargetLogical1 target_false
;
4495 ffetarget_logical1 (&target_true
, TRUE
);
4496 ffetarget_logical1 (&target_false
, FALSE
);
4497 if (target_true
== 1)
4498 true_tree
= convert (tree_type
, integer_one_node
);
4500 true_tree
= convert (tree_type
, build_int_2 (target_true
, 0));
4501 if (target_false
== 0)
4502 false_tree
= convert (tree_type
, integer_zero_node
);
4504 false_tree
= convert (tree_type
, build_int_2 (target_false
, 0));
4507 ffecom_3 (COND_EXPR
, tree_type
,
4509 (ffecom_2 (EQ_EXPR
, integer_type_node
,
4510 ffecom_2 (BIT_AND_EXPR
, arg1_type
,
4512 ffecom_2 (LSHIFT_EXPR
, arg1_type
,
4515 convert (integer_type_node
,
4516 ffecom_expr (arg2
)))),
4518 integer_zero_node
))),
4523 case FFEINTRIN_impIBCLR
:
4525 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4527 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4528 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4531 convert (integer_type_node
,
4532 ffecom_expr (arg2
)))));
4534 case FFEINTRIN_impIBITS
:
4536 tree arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4537 ffecom_expr (arg3
)));
4539 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4542 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4543 ffecom_2 (RSHIFT_EXPR
, tree_type
,
4545 convert (integer_type_node
,
4546 ffecom_expr (arg2
))),
4548 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4549 ffecom_1 (BIT_NOT_EXPR
,
4552 integer_zero_node
)),
4553 ffecom_2 (MINUS_EXPR
,
4555 TYPE_SIZE (uns_type
),
4557 /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE. */
4559 = ffecom_3 (COND_EXPR
, tree_type
,
4561 (ffecom_2 (NE_EXPR
, integer_type_node
,
4563 integer_zero_node
)),
4565 convert (tree_type
, integer_zero_node
));
4569 case FFEINTRIN_impIBSET
:
4571 ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4573 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4574 convert (tree_type
, integer_one_node
),
4575 convert (integer_type_node
,
4576 ffecom_expr (arg2
))));
4578 case FFEINTRIN_impISHFT
:
4580 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4581 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4582 ffecom_expr (arg2
)));
4584 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4587 = ffecom_3 (COND_EXPR
, tree_type
,
4589 (ffecom_2 (GE_EXPR
, integer_type_node
,
4591 integer_zero_node
)),
4592 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4596 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4597 convert (uns_type
, arg1_tree
),
4598 ffecom_1 (NEGATE_EXPR
,
4601 /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds. */
4603 = ffecom_3 (COND_EXPR
, tree_type
,
4605 (ffecom_2 (NE_EXPR
, integer_type_node
,
4609 TYPE_SIZE (uns_type
))),
4611 convert (tree_type
, integer_zero_node
));
4612 /* Make sure SAVE_EXPRs get referenced early enough. */
4614 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4615 convert (void_type_node
, arg1_tree
),
4616 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4617 convert (void_type_node
, arg2_tree
),
4622 case FFEINTRIN_impISHFTC
:
4624 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4625 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4626 ffecom_expr (arg2
)));
4627 tree arg3_tree
= (arg3
== NULL
) ? TYPE_SIZE (tree_type
)
4628 : ffecom_save_tree (convert (integer_type_node
, ffecom_expr (arg3
)));
4634 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4637 = ffecom_2 (LSHIFT_EXPR
, tree_type
,
4638 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4639 convert (tree_type
, integer_zero_node
)),
4641 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4643 = ffecom_3 (COND_EXPR
, tree_type
,
4645 (ffecom_2 (NE_EXPR
, integer_type_node
,
4647 TYPE_SIZE (uns_type
))),
4649 convert (tree_type
, integer_zero_node
));
4650 mask_arg1
= ffecom_save_tree (mask_arg1
);
4652 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4654 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4656 masked_arg1
= ffecom_save_tree (masked_arg1
);
4658 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4660 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4661 convert (uns_type
, masked_arg1
),
4662 ffecom_1 (NEGATE_EXPR
,
4665 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4667 ffecom_2 (PLUS_EXPR
, integer_type_node
,
4671 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4672 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4676 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4677 convert (uns_type
, masked_arg1
),
4678 ffecom_2 (MINUS_EXPR
,
4683 = ffecom_3 (COND_EXPR
, tree_type
,
4685 (ffecom_2 (LT_EXPR
, integer_type_node
,
4687 integer_zero_node
)),
4691 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4692 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4695 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4696 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4700 = ffecom_3 (COND_EXPR
, tree_type
,
4702 (ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
4703 ffecom_2 (EQ_EXPR
, integer_type_node
,
4708 ffecom_2 (EQ_EXPR
, integer_type_node
,
4710 integer_zero_node
))),
4713 /* Make sure SAVE_EXPRs get referenced early enough. */
4715 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4716 convert (void_type_node
, arg1_tree
),
4717 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4718 convert (void_type_node
, arg2_tree
),
4719 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4720 convert (void_type_node
,
4722 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4723 convert (void_type_node
,
4727 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4728 convert (void_type_node
,
4734 case FFEINTRIN_impLOC
:
4736 tree arg1_tree
= ffecom_expr (arg1
);
4739 = convert (tree_type
,
4740 ffecom_1 (ADDR_EXPR
,
4741 build_pointer_type (TREE_TYPE (arg1_tree
)),
4746 case FFEINTRIN_impMVBITS
:
4751 ffebld arg4
= ffebld_head (ffebld_trail (list
));
4754 ffebld arg5
= ffebld_head (ffebld_trail (ffebld_trail (list
)));
4758 tree arg5_plus_arg3
;
4760 arg2_tree
= convert (integer_type_node
,
4761 ffecom_expr (arg2
));
4762 arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4763 ffecom_expr (arg3
)));
4764 arg4_tree
= ffecom_expr_rw (NULL_TREE
, arg4
);
4765 arg4_type
= TREE_TYPE (arg4_tree
);
4767 arg1_tree
= ffecom_save_tree (convert (arg4_type
,
4768 ffecom_expr (arg1
)));
4770 arg5_tree
= ffecom_save_tree (convert (integer_type_node
,
4771 ffecom_expr (arg5
)));
4774 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4775 ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4776 ffecom_2 (RSHIFT_EXPR
, arg4_type
,
4779 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4780 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4781 ffecom_1 (BIT_NOT_EXPR
,
4785 integer_zero_node
)),
4789 = ffecom_save_tree (ffecom_2 (PLUS_EXPR
, arg4_type
,
4793 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4794 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4796 integer_zero_node
)),
4798 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4800 = ffecom_3 (COND_EXPR
, arg4_type
,
4802 (ffecom_2 (NE_EXPR
, integer_type_node
,
4804 convert (TREE_TYPE (arg5_plus_arg3
),
4805 TYPE_SIZE (arg4_type
)))),
4807 convert (arg4_type
, integer_zero_node
));
4809 = ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4811 ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4813 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4814 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4815 ffecom_1 (BIT_NOT_EXPR
,
4819 integer_zero_node
)),
4822 = ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4825 /* Fix up (twice), because LSHIFT_EXPR above
4826 can't shift over TYPE_SIZE. */
4828 = ffecom_3 (COND_EXPR
, arg4_type
,
4830 (ffecom_2 (NE_EXPR
, integer_type_node
,
4832 convert (TREE_TYPE (arg3_tree
),
4833 integer_zero_node
))),
4837 = ffecom_3 (COND_EXPR
, arg4_type
,
4839 (ffecom_2 (NE_EXPR
, integer_type_node
,
4841 convert (TREE_TYPE (arg3_tree
),
4842 TYPE_SIZE (arg4_type
)))),
4846 = ffecom_2s (MODIFY_EXPR
, void_type_node
,
4849 /* Make sure SAVE_EXPRs get referenced early enough. */
4851 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4853 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4855 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4857 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4861 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4868 case FFEINTRIN_impDERF
:
4869 case FFEINTRIN_impERF
:
4870 case FFEINTRIN_impDERFC
:
4871 case FFEINTRIN_impERFC
:
4874 case FFEINTRIN_impIARGC
:
4875 /* extern int xargc; i__1 = xargc - 1; */
4876 expr_tree
= ffecom_2 (MINUS_EXPR
, TREE_TYPE (ffecom_tree_xargc_
),
4878 convert (TREE_TYPE (ffecom_tree_xargc_
),
4882 case FFEINTRIN_impSIGNAL_func
:
4883 case FFEINTRIN_impSIGNAL_subr
:
4889 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4890 ffecom_expr (arg1
));
4891 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4892 build_pointer_type (TREE_TYPE (arg1_tree
)),
4895 /* Pass procedure as a pointer to it, anything else by value. */
4896 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4897 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4899 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4900 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4904 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
4906 arg3_tree
= NULL_TREE
;
4908 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4909 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4910 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4913 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4914 ffecom_gfrt_kindtype (gfrt
),
4916 ((codegen_imp
== FFEINTRIN_impSIGNAL_subr
) ?
4920 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4921 ffebld_nonter_hook (expr
));
4923 if (arg3_tree
!= NULL_TREE
)
4925 = ffecom_modify (NULL_TREE
, arg3_tree
,
4926 convert (TREE_TYPE (arg3_tree
),
4931 case FFEINTRIN_impALARM
:
4937 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4938 ffecom_expr (arg1
));
4939 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4940 build_pointer_type (TREE_TYPE (arg1_tree
)),
4943 /* Pass procedure as a pointer to it, anything else by value. */
4944 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4945 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4947 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4948 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4952 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
4954 arg3_tree
= NULL_TREE
;
4956 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4957 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4958 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4961 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4962 ffecom_gfrt_kindtype (gfrt
),
4966 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4967 ffebld_nonter_hook (expr
));
4969 if (arg3_tree
!= NULL_TREE
)
4971 = ffecom_modify (NULL_TREE
, arg3_tree
,
4972 convert (TREE_TYPE (arg3_tree
),
4977 case FFEINTRIN_impCHDIR_subr
:
4978 case FFEINTRIN_impFDATE_subr
:
4979 case FFEINTRIN_impFGET_subr
:
4980 case FFEINTRIN_impFPUT_subr
:
4981 case FFEINTRIN_impGETCWD_subr
:
4982 case FFEINTRIN_impHOSTNM_subr
:
4983 case FFEINTRIN_impSYSTEM_subr
:
4984 case FFEINTRIN_impUNLINK_subr
:
4986 tree arg1_len
= integer_zero_node
;
4990 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4993 arg2_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
4995 arg2_tree
= NULL_TREE
;
4997 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4998 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4999 TREE_CHAIN (arg1_tree
) = arg1_len
;
5002 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5003 ffecom_gfrt_kindtype (gfrt
),
5007 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5008 ffebld_nonter_hook (expr
));
5010 if (arg2_tree
!= NULL_TREE
)
5012 = ffecom_modify (NULL_TREE
, arg2_tree
,
5013 convert (TREE_TYPE (arg2_tree
),
5018 case FFEINTRIN_impEXIT
:
5022 expr_tree
= build_tree_list (NULL_TREE
,
5023 ffecom_1 (ADDR_EXPR
,
5025 (ffecom_integer_type_node
),
5026 integer_zero_node
));
5029 ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5030 ffecom_gfrt_kindtype (gfrt
),
5034 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5035 ffebld_nonter_hook (expr
));
5037 case FFEINTRIN_impFLUSH
:
5039 gfrt
= FFECOM_gfrtFLUSH
;
5041 gfrt
= FFECOM_gfrtFLUSH1
;
5044 case FFEINTRIN_impCHMOD_subr
:
5045 case FFEINTRIN_impLINK_subr
:
5046 case FFEINTRIN_impRENAME_subr
:
5047 case FFEINTRIN_impSYMLNK_subr
:
5049 tree arg1_len
= integer_zero_node
;
5051 tree arg2_len
= integer_zero_node
;
5055 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
5056 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
5058 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5060 arg3_tree
= NULL_TREE
;
5062 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5063 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5064 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5065 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
5066 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5067 TREE_CHAIN (arg2_tree
) = arg1_len
;
5068 TREE_CHAIN (arg1_len
) = arg2_len
;
5069 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5070 ffecom_gfrt_kindtype (gfrt
),
5074 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5075 ffebld_nonter_hook (expr
));
5076 if (arg3_tree
!= NULL_TREE
)
5077 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5078 convert (TREE_TYPE (arg3_tree
),
5083 case FFEINTRIN_impLSTAT_subr
:
5084 case FFEINTRIN_impSTAT_subr
:
5086 tree arg1_len
= integer_zero_node
;
5091 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
5093 arg2_tree
= ffecom_ptr_to_expr (arg2
);
5096 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5098 arg3_tree
= NULL_TREE
;
5100 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5101 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5102 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5103 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5104 TREE_CHAIN (arg2_tree
) = arg1_len
;
5105 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5106 ffecom_gfrt_kindtype (gfrt
),
5110 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5111 ffebld_nonter_hook (expr
));
5112 if (arg3_tree
!= NULL_TREE
)
5113 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5114 convert (TREE_TYPE (arg3_tree
),
5119 case FFEINTRIN_impFGETC_subr
:
5120 case FFEINTRIN_impFPUTC_subr
:
5124 tree arg2_len
= integer_zero_node
;
5127 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5128 ffecom_expr (arg1
));
5129 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5130 build_pointer_type (TREE_TYPE (arg1_tree
)),
5133 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
5135 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5137 arg3_tree
= NULL_TREE
;
5139 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5140 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5141 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
5142 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5143 TREE_CHAIN (arg2_tree
) = arg2_len
;
5145 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5146 ffecom_gfrt_kindtype (gfrt
),
5150 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5151 ffebld_nonter_hook (expr
));
5152 if (arg3_tree
!= NULL_TREE
)
5153 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5154 convert (TREE_TYPE (arg3_tree
),
5159 case FFEINTRIN_impFSTAT_subr
:
5165 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5166 ffecom_expr (arg1
));
5167 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5168 build_pointer_type (TREE_TYPE (arg1_tree
)),
5171 arg2_tree
= convert (ffecom_f2c_ptr_to_integer_type_node
,
5172 ffecom_ptr_to_expr (arg2
));
5175 arg3_tree
= NULL_TREE
;
5177 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5179 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5180 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5181 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5182 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5183 ffecom_gfrt_kindtype (gfrt
),
5187 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5188 ffebld_nonter_hook (expr
));
5189 if (arg3_tree
!= NULL_TREE
) {
5190 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5191 convert (TREE_TYPE (arg3_tree
),
5197 case FFEINTRIN_impKILL_subr
:
5203 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5204 ffecom_expr (arg1
));
5205 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5206 build_pointer_type (TREE_TYPE (arg1_tree
)),
5209 arg2_tree
= convert (ffecom_f2c_integer_type_node
,
5210 ffecom_expr (arg2
));
5211 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5212 build_pointer_type (TREE_TYPE (arg2_tree
)),
5216 arg3_tree
= NULL_TREE
;
5218 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5220 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5221 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5222 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5223 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5224 ffecom_gfrt_kindtype (gfrt
),
5228 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5229 ffebld_nonter_hook (expr
));
5230 if (arg3_tree
!= NULL_TREE
) {
5231 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5232 convert (TREE_TYPE (arg3_tree
),
5238 case FFEINTRIN_impCTIME_subr
:
5239 case FFEINTRIN_impTTYNAM_subr
:
5241 tree arg1_len
= integer_zero_node
;
5245 arg1_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg1_len
);
5247 arg2_tree
= convert (((codegen_imp
== FFEINTRIN_impCTIME_subr
) ?
5248 ffecom_f2c_longint_type_node
:
5249 ffecom_f2c_integer_type_node
),
5250 ffecom_expr (arg1
));
5251 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5252 build_pointer_type (TREE_TYPE (arg2_tree
)),
5255 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5256 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5257 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5258 TREE_CHAIN (arg1_len
) = arg2_tree
;
5259 TREE_CHAIN (arg1_tree
) = arg1_len
;
5262 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5263 ffecom_gfrt_kindtype (gfrt
),
5267 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5268 ffebld_nonter_hook (expr
));
5269 TREE_SIDE_EFFECTS (expr_tree
) = 1;
5273 case FFEINTRIN_impIRAND
:
5274 case FFEINTRIN_impRAND
:
5275 /* Arg defaults to 0 (normal random case) */
5280 arg1_tree
= ffecom_integer_zero_node
;
5282 arg1_tree
= ffecom_expr (arg1
);
5283 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5285 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5286 build_pointer_type (TREE_TYPE (arg1_tree
)),
5288 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5290 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5291 ffecom_gfrt_kindtype (gfrt
),
5293 ((codegen_imp
== FFEINTRIN_impIRAND
) ?
5294 ffecom_f2c_integer_type_node
:
5295 ffecom_f2c_real_type_node
),
5297 dest_tree
, dest
, dest_used
,
5299 ffebld_nonter_hook (expr
));
5303 case FFEINTRIN_impFTELL_subr
:
5304 case FFEINTRIN_impUMASK_subr
:
5309 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5310 ffecom_expr (arg1
));
5311 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5312 build_pointer_type (TREE_TYPE (arg1_tree
)),
5316 arg2_tree
= NULL_TREE
;
5318 arg2_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
5320 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5321 ffecom_gfrt_kindtype (gfrt
),
5324 build_tree_list (NULL_TREE
, arg1_tree
),
5325 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5327 ffebld_nonter_hook (expr
));
5328 if (arg2_tree
!= NULL_TREE
) {
5329 expr_tree
= ffecom_modify (NULL_TREE
, arg2_tree
,
5330 convert (TREE_TYPE (arg2_tree
),
5336 case FFEINTRIN_impCPU_TIME
:
5337 case FFEINTRIN_impSECOND_subr
:
5341 arg1_tree
= ffecom_expr_w (NULL_TREE
, arg1
);
5344 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5345 ffecom_gfrt_kindtype (gfrt
),
5349 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5350 ffebld_nonter_hook (expr
));
5353 = ffecom_modify (NULL_TREE
, arg1_tree
,
5354 convert (TREE_TYPE (arg1_tree
),
5359 case FFEINTRIN_impDTIME_subr
:
5360 case FFEINTRIN_impETIME_subr
:
5365 result_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
5367 arg1_tree
= ffecom_ptr_to_expr (arg1
);
5369 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5370 ffecom_gfrt_kindtype (gfrt
),
5373 build_tree_list (NULL_TREE
, arg1_tree
),
5374 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5376 ffebld_nonter_hook (expr
));
5377 expr_tree
= ffecom_modify (NULL_TREE
, result_tree
,
5378 convert (TREE_TYPE (result_tree
),
5383 /* Straightforward calls of libf2c routines: */
5384 case FFEINTRIN_impABORT
:
5385 case FFEINTRIN_impACCESS
:
5386 case FFEINTRIN_impBESJ0
:
5387 case FFEINTRIN_impBESJ1
:
5388 case FFEINTRIN_impBESJN
:
5389 case FFEINTRIN_impBESY0
:
5390 case FFEINTRIN_impBESY1
:
5391 case FFEINTRIN_impBESYN
:
5392 case FFEINTRIN_impCHDIR_func
:
5393 case FFEINTRIN_impCHMOD_func
:
5394 case FFEINTRIN_impDATE
:
5395 case FFEINTRIN_impDATE_AND_TIME
:
5396 case FFEINTRIN_impDBESJ0
:
5397 case FFEINTRIN_impDBESJ1
:
5398 case FFEINTRIN_impDBESJN
:
5399 case FFEINTRIN_impDBESY0
:
5400 case FFEINTRIN_impDBESY1
:
5401 case FFEINTRIN_impDBESYN
:
5402 case FFEINTRIN_impDTIME_func
:
5403 case FFEINTRIN_impETIME_func
:
5404 case FFEINTRIN_impFGETC_func
:
5405 case FFEINTRIN_impFGET_func
:
5406 case FFEINTRIN_impFNUM
:
5407 case FFEINTRIN_impFPUTC_func
:
5408 case FFEINTRIN_impFPUT_func
:
5409 case FFEINTRIN_impFSEEK
:
5410 case FFEINTRIN_impFSTAT_func
:
5411 case FFEINTRIN_impFTELL_func
:
5412 case FFEINTRIN_impGERROR
:
5413 case FFEINTRIN_impGETARG
:
5414 case FFEINTRIN_impGETCWD_func
:
5415 case FFEINTRIN_impGETENV
:
5416 case FFEINTRIN_impGETGID
:
5417 case FFEINTRIN_impGETLOG
:
5418 case FFEINTRIN_impGETPID
:
5419 case FFEINTRIN_impGETUID
:
5420 case FFEINTRIN_impGMTIME
:
5421 case FFEINTRIN_impHOSTNM_func
:
5422 case FFEINTRIN_impIDATE_unix
:
5423 case FFEINTRIN_impIDATE_vxt
:
5424 case FFEINTRIN_impIERRNO
:
5425 case FFEINTRIN_impISATTY
:
5426 case FFEINTRIN_impITIME
:
5427 case FFEINTRIN_impKILL_func
:
5428 case FFEINTRIN_impLINK_func
:
5429 case FFEINTRIN_impLNBLNK
:
5430 case FFEINTRIN_impLSTAT_func
:
5431 case FFEINTRIN_impLTIME
:
5432 case FFEINTRIN_impMCLOCK8
:
5433 case FFEINTRIN_impMCLOCK
:
5434 case FFEINTRIN_impPERROR
:
5435 case FFEINTRIN_impRENAME_func
:
5436 case FFEINTRIN_impSECNDS
:
5437 case FFEINTRIN_impSECOND_func
:
5438 case FFEINTRIN_impSLEEP
:
5439 case FFEINTRIN_impSRAND
:
5440 case FFEINTRIN_impSTAT_func
:
5441 case FFEINTRIN_impSYMLNK_func
:
5442 case FFEINTRIN_impSYSTEM_CLOCK
:
5443 case FFEINTRIN_impSYSTEM_func
:
5444 case FFEINTRIN_impTIME8
:
5445 case FFEINTRIN_impTIME_unix
:
5446 case FFEINTRIN_impTIME_vxt
:
5447 case FFEINTRIN_impUMASK_func
:
5448 case FFEINTRIN_impUNLINK_func
:
5451 case FFEINTRIN_impCTIME_func
: /* CHARACTER functions not handled here. */
5452 case FFEINTRIN_impFDATE_func
: /* CHARACTER functions not handled here. */
5453 case FFEINTRIN_impTTYNAM_func
: /* CHARACTER functions not handled here. */
5454 case FFEINTRIN_impNONE
:
5455 case FFEINTRIN_imp
: /* Hush up gcc warning. */
5456 fprintf (stderr
, "No %s implementation.\n",
5457 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr
))));
5458 assert ("unimplemented intrinsic" == NULL
);
5459 return error_mark_node
;
5462 assert (gfrt
!= FFECOM_gfrt
); /* Must have an implementation! */
5464 expr_tree
= ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt
),
5465 ffebld_right (expr
));
5467 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt
), ffecom_gfrt_kindtype (gfrt
),
5468 (ffe_is_f2c_library () && ffecom_gfrt_complex_
[gfrt
]),
5470 expr_tree
, dest_tree
, dest
, dest_used
,
5472 ffebld_nonter_hook (expr
));
5474 /* See bottom of this file for f2c transforms used to determine
5475 many of the above implementations. The info seems to confuse
5476 Emacs's C mode indentation, which is why it's been moved to
5477 the bottom of this source file. */
5481 /* For power (exponentiation) where right-hand operand is type INTEGER,
5482 generate in-line code to do it the fast way (which, if the operand
5483 is a constant, might just mean a series of multiplies). */
5485 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5487 ffecom_expr_power_integer_ (ffebld expr
)
5489 tree l
= ffecom_expr (ffebld_left (expr
));
5490 tree r
= ffecom_expr (ffebld_right (expr
));
5491 tree ltype
= TREE_TYPE (l
);
5492 tree rtype
= TREE_TYPE (r
);
5493 tree result
= NULL_TREE
;
5495 if (l
== error_mark_node
5496 || r
== error_mark_node
)
5497 return error_mark_node
;
5499 if (TREE_CODE (r
) == INTEGER_CST
)
5501 int sgn
= tree_int_cst_sgn (r
);
5504 return convert (ltype
, integer_one_node
);
5506 if ((TREE_CODE (ltype
) == INTEGER_TYPE
)
5509 /* Reciprocal of integer is either 0, -1, or 1, so after
5510 calculating that (which we leave to the back end to do
5511 or not do optimally), don't bother with any multiplying. */
5513 result
= ffecom_tree_divide_ (ltype
,
5514 convert (ltype
, integer_one_node
),
5516 NULL_TREE
, NULL
, NULL
, NULL_TREE
);
5517 r
= ffecom_1 (NEGATE_EXPR
,
5520 if ((TREE_INT_CST_LOW (r
) & 1) == 0)
5521 result
= ffecom_1 (ABS_EXPR
, rtype
,
5525 /* Generate appropriate series of multiplies, preceded
5526 by divide if the exponent is negative. */
5532 l
= ffecom_tree_divide_ (ltype
,
5533 convert (ltype
, integer_one_node
),
5535 NULL_TREE
, NULL
, NULL
,
5536 ffebld_nonter_hook (expr
));
5537 r
= ffecom_1 (NEGATE_EXPR
, rtype
, r
);
5538 assert (TREE_CODE (r
) == INTEGER_CST
);
5540 if (tree_int_cst_sgn (r
) < 0)
5541 { /* The "most negative" number. */
5542 r
= ffecom_1 (NEGATE_EXPR
, rtype
,
5543 ffecom_2 (RSHIFT_EXPR
, rtype
,
5547 l
= ffecom_2 (MULT_EXPR
, ltype
,
5555 if (TREE_INT_CST_LOW (r
) & 1)
5557 if (result
== NULL_TREE
)
5560 result
= ffecom_2 (MULT_EXPR
, ltype
,
5565 r
= ffecom_2 (RSHIFT_EXPR
, rtype
,
5568 if (integer_zerop (r
))
5570 assert (TREE_CODE (r
) == INTEGER_CST
);
5573 l
= ffecom_2 (MULT_EXPR
, ltype
,
5580 /* Though rhs isn't a constant, in-line code cannot be expanded
5581 while transforming dummies
5582 because the back end cannot be easily convinced to generate
5583 stores (MODIFY_EXPR), handle temporaries, and so on before
5584 all the appropriate rtx's have been generated for things like
5585 dummy args referenced in rhs -- which doesn't happen until
5586 store_parm_decls() is called (expand_function_start, I believe,
5587 does the actual rtx-stuffing of PARM_DECLs).
5589 So, in this case, let the caller generate the call to the
5590 run-time-library function to evaluate the power for us. */
5592 if (ffecom_transform_only_dummies_
)
5595 /* Right-hand operand not a constant, expand in-line code to figure
5596 out how to do the multiplies, &c.
5598 The returned expression is expressed this way in GNU C, where l and
5601 ({ typeof (r) rtmp = r;
5602 typeof (l) ltmp = l;
5609 if ((basetypeof (l) == basetypeof (int))
5612 result = ((typeof (l)) 1) / ltmp;
5613 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5619 if ((basetypeof (l) != basetypeof (int))
5622 ltmp = ((typeof (l)) 1) / ltmp;
5626 rtmp = -(rtmp >> 1);
5634 if ((rtmp >>= 1) == 0)
5643 Note that some of the above is compile-time collapsable, such as
5644 the first part of the if statements that checks the base type of
5645 l against int. The if statements are phrased that way to suggest
5646 an easy way to generate the if/else constructs here, knowing that
5647 the back end should (and probably does) eliminate the resulting
5648 dead code (either the int case or the non-int case), something
5649 it couldn't do without the redundant phrasing, requiring explicit
5650 dead-code elimination here, which would be kind of difficult to
5657 tree basetypeof_l_is_int
;
5662 = build_int_2 ((TREE_CODE (ltype
) == INTEGER_TYPE
), 0);
5664 se
= expand_start_stmt_expr ();
5666 ffecom_start_compstmt ();
5669 rtmp
= ffecom_make_tempvar ("power_r", rtype
,
5670 FFETARGET_charactersizeNONE
, -1);
5671 ltmp
= ffecom_make_tempvar ("power_l", ltype
,
5672 FFETARGET_charactersizeNONE
, -1);
5673 result
= ffecom_make_tempvar ("power_res", ltype
,
5674 FFETARGET_charactersizeNONE
, -1);
5675 if (TREE_CODE (ltype
) == COMPLEX_TYPE
5676 || TREE_CODE (ltype
) == RECORD_TYPE
)
5677 divide
= ffecom_make_tempvar ("power_div", ltype
,
5678 FFETARGET_charactersizeNONE
, -1);
5685 hook
= ffebld_nonter_hook (expr
);
5687 assert (TREE_CODE (hook
) == TREE_VEC
);
5688 assert (TREE_VEC_LENGTH (hook
) == 4);
5689 rtmp
= TREE_VEC_ELT (hook
, 0);
5690 ltmp
= TREE_VEC_ELT (hook
, 1);
5691 result
= TREE_VEC_ELT (hook
, 2);
5692 divide
= TREE_VEC_ELT (hook
, 3);
5693 if (TREE_CODE (ltype
) == COMPLEX_TYPE
5694 || TREE_CODE (ltype
) == RECORD_TYPE
)
5701 expand_expr_stmt (ffecom_modify (void_type_node
,
5704 expand_expr_stmt (ffecom_modify (void_type_node
,
5707 expand_start_cond (ffecom_truth_value
5708 (ffecom_2 (EQ_EXPR
, integer_type_node
,
5710 convert (rtype
, integer_zero_node
))),
5712 expand_expr_stmt (ffecom_modify (void_type_node
,
5714 convert (ltype
, integer_one_node
)));
5715 expand_start_else ();
5716 if (! integer_zerop (basetypeof_l_is_int
))
5718 expand_start_cond (ffecom_2 (LT_EXPR
, integer_type_node
,
5721 integer_zero_node
)),
5723 expand_expr_stmt (ffecom_modify (void_type_node
,
5727 convert (ltype
, integer_one_node
),
5729 NULL_TREE
, NULL
, NULL
,
5731 expand_start_cond (ffecom_truth_value
5732 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
5733 ffecom_2 (LT_EXPR
, integer_type_node
,
5736 integer_zero_node
)),
5737 ffecom_2 (EQ_EXPR
, integer_type_node
,
5738 ffecom_2 (BIT_AND_EXPR
,
5740 ffecom_1 (NEGATE_EXPR
,
5746 integer_zero_node
)))),
5748 expand_expr_stmt (ffecom_modify (void_type_node
,
5750 ffecom_1 (NEGATE_EXPR
,
5754 expand_start_else ();
5756 expand_expr_stmt (ffecom_modify (void_type_node
,
5758 convert (ltype
, integer_one_node
)));
5759 expand_start_cond (ffecom_truth_value
5760 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
5761 ffecom_truth_value_invert
5762 (basetypeof_l_is_int
),
5763 ffecom_2 (LT_EXPR
, integer_type_node
,
5766 integer_zero_node
)))),
5768 expand_expr_stmt (ffecom_modify (void_type_node
,
5772 convert (ltype
, integer_one_node
),
5774 NULL_TREE
, NULL
, NULL
,
5776 expand_expr_stmt (ffecom_modify (void_type_node
,
5778 ffecom_1 (NEGATE_EXPR
, rtype
,
5780 expand_start_cond (ffecom_truth_value
5781 (ffecom_2 (LT_EXPR
, integer_type_node
,
5783 convert (rtype
, integer_zero_node
))),
5785 expand_expr_stmt (ffecom_modify (void_type_node
,
5787 ffecom_1 (NEGATE_EXPR
, rtype
,
5788 ffecom_2 (RSHIFT_EXPR
,
5791 integer_one_node
))));
5792 expand_expr_stmt (ffecom_modify (void_type_node
,
5794 ffecom_2 (MULT_EXPR
, ltype
,
5799 expand_start_loop (1);
5800 expand_start_cond (ffecom_truth_value
5801 (ffecom_2 (BIT_AND_EXPR
, rtype
,
5803 convert (rtype
, integer_one_node
))),
5805 expand_expr_stmt (ffecom_modify (void_type_node
,
5807 ffecom_2 (MULT_EXPR
, ltype
,
5811 expand_exit_loop_if_false (NULL
,
5813 (ffecom_modify (rtype
,
5815 ffecom_2 (RSHIFT_EXPR
,
5818 integer_one_node
))));
5819 expand_expr_stmt (ffecom_modify (void_type_node
,
5821 ffecom_2 (MULT_EXPR
, ltype
,
5826 if (!integer_zerop (basetypeof_l_is_int
))
5828 expand_expr_stmt (result
);
5830 t
= ffecom_end_compstmt ();
5832 result
= expand_end_stmt_expr (se
);
5834 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5836 if (TREE_CODE (t
) == BLOCK
)
5838 /* Make a BIND_EXPR for the BLOCK already made. */
5839 result
= build (BIND_EXPR
, TREE_TYPE (result
),
5840 NULL_TREE
, result
, t
);
5841 /* Remove the block from the tree at this point.
5842 It gets put back at the proper place
5843 when the BIND_EXPR is expanded. */
5854 /* ffecom_expr_transform_ -- Transform symbols in expr
5856 ffebld expr; // FFE expression.
5857 ffecom_expr_transform_ (expr);
5859 Recursive descent on expr while transforming any untransformed SYMTERs. */
5861 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5863 ffecom_expr_transform_ (ffebld expr
)
5868 tail_recurse
: /* :::::::::::::::::::: */
5873 switch (ffebld_op (expr
))
5875 case FFEBLD_opSYMTER
:
5876 s
= ffebld_symter (expr
);
5877 t
= ffesymbol_hook (s
).decl_tree
;
5878 if ((t
== NULL_TREE
)
5879 && ((ffesymbol_kind (s
) != FFEINFO_kindNONE
)
5880 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
5881 && (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
))))
5883 s
= ffecom_sym_transform_ (s
);
5884 t
= ffesymbol_hook (s
).decl_tree
; /* Sfunc expr non-dummy,
5887 break; /* Ok if (t == NULL) here. */
5890 ffecom_expr_transform_ (ffebld_head (expr
));
5891 expr
= ffebld_trail (expr
);
5892 goto tail_recurse
; /* :::::::::::::::::::: */
5898 switch (ffebld_arity (expr
))
5901 ffecom_expr_transform_ (ffebld_left (expr
));
5902 expr
= ffebld_right (expr
);
5903 goto tail_recurse
; /* :::::::::::::::::::: */
5906 expr
= ffebld_left (expr
);
5907 goto tail_recurse
; /* :::::::::::::::::::: */
5917 /* Make a type based on info in live f2c.h file. */
5919 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5921 ffecom_f2c_make_type_ (tree
*type
, int tcode
, const char *name
)
5925 case FFECOM_f2ccodeCHAR
:
5926 *type
= make_signed_type (CHAR_TYPE_SIZE
);
5929 case FFECOM_f2ccodeSHORT
:
5930 *type
= make_signed_type (SHORT_TYPE_SIZE
);
5933 case FFECOM_f2ccodeINT
:
5934 *type
= make_signed_type (INT_TYPE_SIZE
);
5937 case FFECOM_f2ccodeLONG
:
5938 *type
= make_signed_type (LONG_TYPE_SIZE
);
5941 case FFECOM_f2ccodeLONGLONG
:
5942 *type
= make_signed_type (LONG_LONG_TYPE_SIZE
);
5945 case FFECOM_f2ccodeCHARPTR
:
5946 *type
= build_pointer_type (DEFAULT_SIGNED_CHAR
5947 ? signed_char_type_node
5948 : unsigned_char_type_node
);
5951 case FFECOM_f2ccodeFLOAT
:
5952 *type
= make_node (REAL_TYPE
);
5953 TYPE_PRECISION (*type
) = FLOAT_TYPE_SIZE
;
5954 layout_type (*type
);
5957 case FFECOM_f2ccodeDOUBLE
:
5958 *type
= make_node (REAL_TYPE
);
5959 TYPE_PRECISION (*type
) = DOUBLE_TYPE_SIZE
;
5960 layout_type (*type
);
5963 case FFECOM_f2ccodeLONGDOUBLE
:
5964 *type
= make_node (REAL_TYPE
);
5965 TYPE_PRECISION (*type
) = LONG_DOUBLE_TYPE_SIZE
;
5966 layout_type (*type
);
5969 case FFECOM_f2ccodeTWOREALS
:
5970 *type
= ffecom_make_complex_type_ (ffecom_f2c_real_type_node
);
5973 case FFECOM_f2ccodeTWODOUBLEREALS
:
5974 *type
= ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node
);
5978 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL
);
5979 *type
= error_mark_node
;
5983 pushdecl (build_decl (TYPE_DECL
,
5984 ffecom_get_invented_identifier ("__g77_f2c_%s", name
),
5989 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5990 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5994 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
6000 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
6001 if ((t
= ffecom_tree_type
[bt
][j
]) != NULL_TREE
6002 && compare_tree_int (TYPE_SIZE (t
), size
) == 0)
6004 assert (code
!= -1);
6005 ffecom_f2c_typecode_
[bt
][j
] = code
;
6011 /* Finish up globals after doing all program units in file
6013 Need to handle only uninitialized COMMON areas. */
6015 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6017 ffecom_finish_global_ (ffeglobal global
)
6023 if (ffeglobal_type (global
) != FFEGLOBAL_typeCOMMON
)
6026 if (ffeglobal_common_init (global
))
6029 cbt
= ffeglobal_hook (global
);
6030 if ((cbt
== NULL_TREE
)
6031 || !ffeglobal_common_have_size (global
))
6032 return global
; /* No need to make common, never ref'd. */
6034 DECL_EXTERNAL (cbt
) = 0;
6036 /* Give the array a size now. */
6038 size
= build_int_2 ((ffeglobal_common_size (global
)
6039 + ffeglobal_common_pad (global
)) - 1,
6042 cbtype
= TREE_TYPE (cbt
);
6043 TYPE_DOMAIN (cbtype
) = build_range_type (integer_type_node
,
6046 if (!TREE_TYPE (size
))
6047 TREE_TYPE (size
) = TYPE_DOMAIN (cbtype
);
6048 layout_type (cbtype
);
6050 cbt
= start_decl (cbt
, FALSE
);
6051 assert (cbt
== ffeglobal_hook (global
));
6053 finish_decl (cbt
, NULL_TREE
, FALSE
);
6059 /* Finish up any untransformed symbols. */
6061 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6063 ffecom_finish_symbol_transform_ (ffesymbol s
)
6065 if ((s
== NULL
) || (TREE_CODE (current_function_decl
) == ERROR_MARK
))
6068 /* It's easy to know to transform an untransformed symbol, to make sure
6069 we put out debugging info for it. But COMMON variables, unlike
6070 EQUIVALENCE ones, aren't given declarations in addition to the
6071 tree expressions that specify offsets, because COMMON variables
6072 can be referenced in the outer scope where only dummy arguments
6073 (PARM_DECLs) should really be seen. To be safe, just don't do any
6074 VAR_DECLs for COMMON variables when we transform them for real
6075 use, and therefore we do all the VAR_DECL creating here. */
6077 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
)
6079 if (ffesymbol_kind (s
) != FFEINFO_kindNONE
6080 || (ffesymbol_where (s
) != FFEINFO_whereNONE
6081 && ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
6082 && ffesymbol_where (s
) != FFEINFO_whereDUMMY
))
6083 /* Not transformed, and not CHARACTER*(*), and not a dummy
6084 argument, which can happen only if the entry point names
6085 it "rides in on" are all invalidated for other reasons. */
6086 s
= ffecom_sym_transform_ (s
);
6089 if ((ffesymbol_where (s
) == FFEINFO_whereCOMMON
)
6090 && (ffesymbol_hook (s
).decl_tree
!= error_mark_node
))
6092 /* This isn't working, at least for dbxout. The .s file looks
6093 okay to me (burley), but in gdb 4.9 at least, the variables
6094 appear to reside somewhere outside of the common area, so
6095 it doesn't make sense to mislead anyone by generating the info
6096 on those variables until this is fixed. NOTE: Same problem
6097 with EQUIVALENCE, sadly...see similar #if later. */
6098 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s
)),
6099 ffesymbol_storage (s
));
6106 /* Append underscore(s) to name before calling get_identifier. "us"
6107 is nonzero if the name already contains an underscore and thus
6108 needs two underscores appended. */
6110 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6112 ffecom_get_appended_identifier_ (char us
, const char *name
)
6118 newname
= xmalloc ((i
= strlen (name
)) + 1
6119 + ffe_is_underscoring ()
6121 memcpy (newname
, name
, i
);
6123 newname
[i
+ us
] = '_';
6124 newname
[i
+ 1 + us
] = '\0';
6125 id
= get_identifier (newname
);
6133 /* Decide whether to append underscore to name before calling
6136 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6138 ffecom_get_external_identifier_ (ffesymbol s
)
6141 const char *name
= ffesymbol_text (s
);
6143 /* If name is a built-in name, just return it as is. */
6145 if (!ffe_is_underscoring ()
6146 || (strcmp (name
, FFETARGET_nameBLANK_COMMON
) == 0)
6147 #if FFETARGET_isENFORCED_MAIN_NAME
6148 || (strcmp (name
, FFETARGET_nameENFORCED_NAME
) == 0)
6150 || (strcmp (name
, FFETARGET_nameUNNAMED_MAIN
) == 0)
6152 || (strcmp (name
, FFETARGET_nameUNNAMED_BLOCK_DATA
) == 0))
6153 return get_identifier (name
);
6155 us
= ffe_is_second_underscore ()
6156 ? (strchr (name
, '_') != NULL
)
6159 return ffecom_get_appended_identifier_ (us
, name
);
6163 /* Decide whether to append underscore to internal name before calling
6166 This is for non-external, top-function-context names only. Transform
6167 identifier so it doesn't conflict with the transformed result
6168 of using a _different_ external name. E.g. if "CALL FOO" is
6169 transformed into "FOO_();", then the variable in "FOO_ = 3"
6170 must be transformed into something that does not conflict, since
6171 these two things should be independent.
6173 The transformation is as follows. If the name does not contain
6174 an underscore, there is no possible conflict, so just return.
6175 If the name does contain an underscore, then transform it just
6176 like we transform an external identifier. */
6178 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6180 ffecom_get_identifier_ (const char *name
)
6182 /* If name does not contain an underscore, just return it as is. */
6184 if (!ffe_is_underscoring ()
6185 || (strchr (name
, '_') == NULL
))
6186 return get_identifier (name
);
6188 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6193 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6196 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6197 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6198 ffesymbol_kindtype(s));
6200 Call after setting up containing function and getting trees for all
6203 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6205 ffecom_gen_sfuncdef_ (ffesymbol s
, ffeinfoBasictype bt
, ffeinfoKindtype kt
)
6207 ffebld expr
= ffesymbol_sfexpr (s
);
6211 bool charfunc
= (bt
== FFEINFO_basictypeCHARACTER
);
6212 static bool recurse
= FALSE
;
6213 int old_lineno
= lineno
;
6214 const char *old_input_filename
= input_filename
;
6216 ffecom_nested_entry_
= s
;
6218 /* For now, we don't have a handy pointer to where the sfunc is actually
6219 defined, though that should be easy to add to an ffesymbol. (The
6220 token/where info available might well point to the place where the type
6221 of the sfunc is declared, especially if that precedes the place where
6222 the sfunc itself is defined, which is typically the case.) We should
6223 put out a null pointer rather than point somewhere wrong, but I want to
6224 see how it works at this point. */
6226 input_filename
= ffesymbol_where_filename (s
);
6227 lineno
= ffesymbol_where_filelinenum (s
);
6229 /* Pretransform the expression so any newly discovered things belong to the
6230 outer program unit, not to the statement function. */
6232 ffecom_expr_transform_ (expr
);
6234 /* Make sure no recursive invocation of this fn (a specific case of failing
6235 to pretransform an sfunc's expression, i.e. where its expression
6236 references another untransformed sfunc) happens. */
6241 push_f_function_context ();
6244 type
= void_type_node
;
6247 type
= ffecom_tree_type
[bt
][kt
];
6248 if (type
== NULL_TREE
)
6249 type
= integer_type_node
; /* _sym_exec_transition reports
6253 start_function (ffecom_get_identifier_ (ffesymbol_text (s
)),
6254 build_function_type (type
, NULL_TREE
),
6255 1, /* nested/inline */
6256 0); /* TREE_PUBLIC */
6258 /* We don't worry about COMPLEX return values here, because this is
6259 entirely internal to our code, and gcc has the ability to return COMPLEX
6260 directly as a value. */
6263 { /* Prepend arg for where result goes. */
6266 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
6268 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
6270 ffecom_char_enhance_arg_ (&type
, s
); /* Ignore returned length. */
6272 type
= build_pointer_type (type
);
6273 result
= build_decl (PARM_DECL
, result
, type
);
6275 push_parm_decl (result
);
6278 result
= NULL_TREE
; /* Not ref'd if !charfunc. */
6280 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s
), TRUE
);
6282 store_parm_decls (0);
6284 ffecom_start_compstmt ();
6290 ffetargetCharacterSize sz
= ffesymbol_size (s
);
6293 result_length
= build_int_2 (sz
, 0);
6294 TREE_TYPE (result_length
) = ffecom_f2c_ftnlen_type_node
;
6296 ffecom_prepare_let_char_ (sz
, expr
);
6298 ffecom_prepare_end ();
6300 ffecom_let_char_ (result
, result_length
, sz
, expr
);
6301 expand_null_return ();
6305 ffecom_prepare_expr (expr
);
6307 ffecom_prepare_end ();
6309 expand_return (ffecom_modify (NULL_TREE
,
6310 DECL_RESULT (current_function_decl
),
6311 ffecom_expr (expr
)));
6315 ffecom_end_compstmt ();
6317 func
= current_function_decl
;
6318 finish_function (1);
6320 pop_f_function_context ();
6324 lineno
= old_lineno
;
6325 input_filename
= old_input_filename
;
6327 ffecom_nested_entry_
= NULL
;
6334 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6336 ffecom_gfrt_args_ (ffecomGfrt ix
)
6338 return ffecom_gfrt_argstring_
[ix
];
6342 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6344 ffecom_gfrt_tree_ (ffecomGfrt ix
)
6346 if (ffecom_gfrt_
[ix
] == NULL_TREE
)
6347 ffecom_make_gfrt_ (ix
);
6349 return ffecom_1 (ADDR_EXPR
,
6350 build_pointer_type (TREE_TYPE (ffecom_gfrt_
[ix
])),
6355 /* Return initialize-to-zero expression for this VAR_DECL. */
6357 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6358 /* A somewhat evil way to prevent the garbage collector
6359 from collecting 'tree' structures. */
6360 #define NUM_TRACKED_CHUNK 63
6361 static struct tree_ggc_tracker
6363 struct tree_ggc_tracker
*next
;
6364 tree trees
[NUM_TRACKED_CHUNK
];
6365 } *tracker_head
= NULL
;
6368 mark_tracker_head (void *arg
)
6370 struct tree_ggc_tracker
*head
;
6373 for (head
= * (struct tree_ggc_tracker
**) arg
;
6378 for (i
= 0; i
< NUM_TRACKED_CHUNK
; i
++)
6379 ggc_mark_tree (head
->trees
[i
]);
6384 ffecom_save_tree_forever (tree t
)
6387 if (tracker_head
!= NULL
)
6388 for (i
= 0; i
< NUM_TRACKED_CHUNK
; i
++)
6389 if (tracker_head
->trees
[i
] == NULL
)
6391 tracker_head
->trees
[i
] = t
;
6396 /* Need to allocate a new block. */
6397 struct tree_ggc_tracker
*old_head
= tracker_head
;
6399 tracker_head
= ggc_alloc (sizeof (*tracker_head
));
6400 tracker_head
->next
= old_head
;
6401 tracker_head
->trees
[0] = t
;
6402 for (i
= 1; i
< NUM_TRACKED_CHUNK
; i
++)
6403 tracker_head
->trees
[i
] = NULL
;
6408 ffecom_init_zero_ (tree decl
)
6411 int incremental
= TREE_STATIC (decl
);
6412 tree type
= TREE_TYPE (decl
);
6416 make_decl_rtl (decl
, NULL
);
6417 assemble_variable (decl
, TREE_PUBLIC (decl
) ? 1 : 0, 0, 1);
6420 if ((TREE_CODE (type
) != ARRAY_TYPE
)
6421 && (TREE_CODE (type
) != RECORD_TYPE
)
6422 && (TREE_CODE (type
) != UNION_TYPE
)
6424 init
= convert (type
, integer_zero_node
);
6425 else if (!incremental
)
6427 init
= build (CONSTRUCTOR
, type
, NULL_TREE
, NULL_TREE
);
6428 TREE_CONSTANT (init
) = 1;
6429 TREE_STATIC (init
) = 1;
6433 assemble_zeros (int_size_in_bytes (type
));
6434 init
= error_mark_node
;
6441 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6443 ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
6449 switch (ffebld_op (arg
))
6451 case FFEBLD_opCONTER
: /* For F90, check 0-length. */
6452 if (ffetarget_length_character1
6453 (ffebld_constant_character1
6454 (ffebld_conter (arg
))) == 0)
6456 *maybe_tree
= integer_zero_node
;
6457 return convert (tree_type
, integer_zero_node
);
6460 *maybe_tree
= integer_one_node
;
6461 expr_tree
= build_int_2 (*ffetarget_text_character1
6462 (ffebld_constant_character1
6463 (ffebld_conter (arg
))),
6465 TREE_TYPE (expr_tree
) = tree_type
;
6468 case FFEBLD_opSYMTER
:
6469 case FFEBLD_opARRAYREF
:
6470 case FFEBLD_opFUNCREF
:
6471 case FFEBLD_opSUBSTR
:
6472 ffecom_char_args_ (&expr_tree
, &length_tree
, arg
);
6474 if ((expr_tree
== error_mark_node
)
6475 || (length_tree
== error_mark_node
))
6477 *maybe_tree
= error_mark_node
;
6478 return error_mark_node
;
6481 if (integer_zerop (length_tree
))
6483 *maybe_tree
= integer_zero_node
;
6484 return convert (tree_type
, integer_zero_node
);
6488 = ffecom_1 (INDIRECT_REF
,
6489 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
6492 = ffecom_2 (ARRAY_REF
,
6493 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
6496 expr_tree
= convert (tree_type
, expr_tree
);
6498 if (TREE_CODE (length_tree
) == INTEGER_CST
)
6499 *maybe_tree
= integer_one_node
;
6500 else /* Must check length at run time. */
6502 = ffecom_truth_value
6503 (ffecom_2 (GT_EXPR
, integer_type_node
,
6505 ffecom_f2c_ftnlen_zero_node
));
6508 case FFEBLD_opPAREN
:
6509 case FFEBLD_opCONVERT
:
6510 if (ffeinfo_size (ffebld_info (arg
)) == 0)
6512 *maybe_tree
= integer_zero_node
;
6513 return convert (tree_type
, integer_zero_node
);
6515 return ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
6518 case FFEBLD_opCONCATENATE
:
6525 expr_left
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
6527 expr_right
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_right (arg
),
6529 *maybe_tree
= ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
6532 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
6540 assert ("bad op in ICHAR" == NULL
);
6541 return error_mark_node
;
6546 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6550 length_arg = ffecom_intrinsic_len_ (expr);
6552 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6553 subexpressions by constructing the appropriate tree for the
6554 length-of-character-text argument in a calling sequence. */
6556 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6558 ffecom_intrinsic_len_ (ffebld expr
)
6560 ffetargetCharacter1 val
;
6563 switch (ffebld_op (expr
))
6565 case FFEBLD_opCONTER
:
6566 val
= ffebld_constant_character1 (ffebld_conter (expr
));
6567 length
= build_int_2 (ffetarget_length_character1 (val
), 0);
6568 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6571 case FFEBLD_opSYMTER
:
6573 ffesymbol s
= ffebld_symter (expr
);
6576 item
= ffesymbol_hook (s
).decl_tree
;
6577 if (item
== NULL_TREE
)
6579 s
= ffecom_sym_transform_ (s
);
6580 item
= ffesymbol_hook (s
).decl_tree
;
6582 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
6584 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
6585 length
= ffesymbol_hook (s
).length_tree
;
6588 length
= build_int_2 (ffesymbol_size (s
), 0);
6589 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6592 else if (item
== error_mark_node
)
6593 length
= error_mark_node
;
6594 else /* FFEINFO_kindFUNCTION: */
6599 case FFEBLD_opARRAYREF
:
6600 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
6603 case FFEBLD_opSUBSTR
:
6607 ffebld thing
= ffebld_right (expr
);
6611 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
6612 start
= ffebld_head (thing
);
6613 thing
= ffebld_trail (thing
);
6614 assert (ffebld_trail (thing
) == NULL
);
6615 end
= ffebld_head (thing
);
6617 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
6619 if (length
== error_mark_node
)
6628 length
= convert (ffecom_f2c_ftnlen_type_node
,
6634 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
6635 ffecom_expr (start
));
6637 if (start_tree
== error_mark_node
)
6639 length
= error_mark_node
;
6645 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6646 ffecom_f2c_ftnlen_one_node
,
6647 ffecom_2 (MINUS_EXPR
,
6648 ffecom_f2c_ftnlen_type_node
,
6654 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
6657 if (end_tree
== error_mark_node
)
6659 length
= error_mark_node
;
6663 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6664 ffecom_f2c_ftnlen_one_node
,
6665 ffecom_2 (MINUS_EXPR
,
6666 ffecom_f2c_ftnlen_type_node
,
6667 end_tree
, start_tree
));
6673 case FFEBLD_opCONCATENATE
:
6675 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6676 ffecom_intrinsic_len_ (ffebld_left (expr
)),
6677 ffecom_intrinsic_len_ (ffebld_right (expr
)));
6680 case FFEBLD_opFUNCREF
:
6681 case FFEBLD_opCONVERT
:
6682 length
= build_int_2 (ffebld_size (expr
), 0);
6683 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6687 assert ("bad op for single char arg expr" == NULL
);
6688 length
= ffecom_f2c_ftnlen_zero_node
;
6692 assert (length
!= NULL_TREE
);
6698 /* Handle CHARACTER assignments.
6700 Generates code to do the assignment. Used by ordinary assignment
6701 statement handler ffecom_let_stmt and by statement-function
6702 handler to generate code for a statement function. */
6704 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6706 ffecom_let_char_ (tree dest_tree
, tree dest_length
,
6707 ffetargetCharacterSize dest_size
, ffebld source
)
6709 ffecomConcatList_ catlist
;
6714 if ((dest_tree
== error_mark_node
)
6715 || (dest_length
== error_mark_node
))
6718 assert (dest_tree
!= NULL_TREE
);
6719 assert (dest_length
!= NULL_TREE
);
6721 /* Source might be an opCONVERT, which just means it is a different size
6722 than the destination. Since the underlying implementation here handles
6723 that (directly or via the s_copy or s_cat run-time-library functions),
6724 we don't need the "convenience" of an opCONVERT that tells us to
6725 truncate or blank-pad, particularly since the resulting implementation
6726 would probably be slower than otherwise. */
6728 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
6729 source
= ffebld_left (source
);
6731 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
6732 switch (ffecom_concat_list_count_ (catlist
))
6734 case 0: /* Shouldn't happen, but in case it does... */
6735 ffecom_concat_list_kill_ (catlist
);
6736 source_tree
= null_pointer_node
;
6737 source_length
= ffecom_f2c_ftnlen_zero_node
;
6738 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6739 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
6740 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6741 = build_tree_list (NULL_TREE
, dest_length
);
6742 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6743 = build_tree_list (NULL_TREE
, source_length
);
6745 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
, NULL_TREE
);
6746 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6748 expand_expr_stmt (expr_tree
);
6752 case 1: /* The (fairly) easy case. */
6753 ffecom_char_args_ (&source_tree
, &source_length
,
6754 ffecom_concat_list_expr_ (catlist
, 0));
6755 ffecom_concat_list_kill_ (catlist
);
6756 assert (source_tree
!= NULL_TREE
);
6757 assert (source_length
!= NULL_TREE
);
6759 if ((source_tree
== error_mark_node
)
6760 || (source_length
== error_mark_node
))
6766 = ffecom_1 (INDIRECT_REF
,
6767 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6771 = ffecom_2 (ARRAY_REF
,
6772 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6777 = ffecom_1 (INDIRECT_REF
,
6778 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6782 = ffecom_2 (ARRAY_REF
,
6783 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6788 expr_tree
= ffecom_modify (void_type_node
, dest_tree
, source_tree
);
6790 expand_expr_stmt (expr_tree
);
6795 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6796 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
6797 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6798 = build_tree_list (NULL_TREE
, dest_length
);
6799 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6800 = build_tree_list (NULL_TREE
, source_length
);
6802 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
, NULL_TREE
);
6803 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6805 expand_expr_stmt (expr_tree
);
6809 default: /* Must actually concatenate things. */
6813 /* Heavy-duty concatenation. */
6816 int count
= ffecom_concat_list_count_ (catlist
);
6828 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
6829 FFETARGET_charactersizeNONE
, count
, TRUE
);
6830 item_array
= items
= ffecom_push_tempvar (ffecom_f2c_address_type_node
,
6831 FFETARGET_charactersizeNONE
,
6837 hook
= ffebld_nonter_hook (source
);
6839 assert (TREE_CODE (hook
) == TREE_VEC
);
6840 assert (TREE_VEC_LENGTH (hook
) == 2);
6841 length_array
= lengths
= TREE_VEC_ELT (hook
, 0);
6842 item_array
= items
= TREE_VEC_ELT (hook
, 1);
6846 for (i
= 0; i
< count
; ++i
)
6848 ffecom_char_args_ (&citem
, &clength
,
6849 ffecom_concat_list_expr_ (catlist
, i
));
6850 if ((citem
== error_mark_node
)
6851 || (clength
== error_mark_node
))
6853 ffecom_concat_list_kill_ (catlist
);
6858 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
6859 ffecom_modify (void_type_node
,
6860 ffecom_2 (ARRAY_REF
,
6861 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
6863 build_int_2 (i
, 0)),
6867 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
6868 ffecom_modify (void_type_node
,
6869 ffecom_2 (ARRAY_REF
,
6870 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
6872 build_int_2 (i
, 0)),
6877 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6878 TREE_CHAIN (expr_tree
)
6879 = build_tree_list (NULL_TREE
,
6880 ffecom_1 (ADDR_EXPR
,
6881 build_pointer_type (TREE_TYPE (items
)),
6883 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6884 = build_tree_list (NULL_TREE
,
6885 ffecom_1 (ADDR_EXPR
,
6886 build_pointer_type (TREE_TYPE (lengths
)),
6888 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6891 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
6892 convert (ffecom_f2c_ftnlen_type_node
,
6893 build_int_2 (count
, 0))));
6894 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
))))
6895 = build_tree_list (NULL_TREE
, dest_length
);
6897 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCAT
, expr_tree
, NULL_TREE
);
6898 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6900 expand_expr_stmt (expr_tree
);
6903 ffecom_concat_list_kill_ (catlist
);
6907 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6910 ffecom_make_gfrt_(ix);
6912 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6913 for the indicated run-time routine (ix). */
6915 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6917 ffecom_make_gfrt_ (ffecomGfrt ix
)
6922 switch (ffecom_gfrt_type_
[ix
])
6924 case FFECOM_rttypeVOID_
:
6925 ttype
= void_type_node
;
6928 case FFECOM_rttypeVOIDSTAR_
:
6929 ttype
= TREE_TYPE (null_pointer_node
); /* `void *'. */
6932 case FFECOM_rttypeFTNINT_
:
6933 ttype
= ffecom_f2c_ftnint_type_node
;
6936 case FFECOM_rttypeINTEGER_
:
6937 ttype
= ffecom_f2c_integer_type_node
;
6940 case FFECOM_rttypeLONGINT_
:
6941 ttype
= ffecom_f2c_longint_type_node
;
6944 case FFECOM_rttypeLOGICAL_
:
6945 ttype
= ffecom_f2c_logical_type_node
;
6948 case FFECOM_rttypeREAL_F2C_
:
6949 ttype
= double_type_node
;
6952 case FFECOM_rttypeREAL_GNU_
:
6953 ttype
= float_type_node
;
6956 case FFECOM_rttypeCOMPLEX_F2C_
:
6957 ttype
= void_type_node
;
6960 case FFECOM_rttypeCOMPLEX_GNU_
:
6961 ttype
= ffecom_f2c_complex_type_node
;
6964 case FFECOM_rttypeDOUBLE_
:
6965 ttype
= double_type_node
;
6968 case FFECOM_rttypeDOUBLEREAL_
:
6969 ttype
= ffecom_f2c_doublereal_type_node
;
6972 case FFECOM_rttypeDBLCMPLX_F2C_
:
6973 ttype
= void_type_node
;
6976 case FFECOM_rttypeDBLCMPLX_GNU_
:
6977 ttype
= ffecom_f2c_doublecomplex_type_node
;
6980 case FFECOM_rttypeCHARACTER_
:
6981 ttype
= void_type_node
;
6986 assert ("bad rttype" == NULL
);
6990 ttype
= build_function_type (ttype
, NULL_TREE
);
6991 t
= build_decl (FUNCTION_DECL
,
6992 get_identifier (ffecom_gfrt_name_
[ix
]),
6994 DECL_EXTERNAL (t
) = 1;
6995 TREE_READONLY (t
) = ffecom_gfrt_const_
[ix
] ? 1 : 0;
6996 TREE_PUBLIC (t
) = 1;
6997 TREE_THIS_VOLATILE (t
) = ffecom_gfrt_volatile_
[ix
] ? 1 : 0;
6999 /* Sanity check: A function that's const cannot be volatile. */
7001 assert (ffecom_gfrt_const_
[ix
] ? !ffecom_gfrt_volatile_
[ix
] : 1);
7003 /* Sanity check: A function that's const cannot return complex. */
7005 assert (ffecom_gfrt_const_
[ix
] ? !ffecom_gfrt_complex_
[ix
] : 1);
7007 t
= start_decl (t
, TRUE
);
7009 finish_decl (t
, NULL_TREE
, TRUE
);
7011 ffecom_gfrt_
[ix
] = t
;
7015 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
7017 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7019 ffecom_member_phase1_ (ffestorag mst UNUSED
, ffestorag st
)
7021 ffesymbol s
= ffestorag_symbol (st
);
7023 if (ffesymbol_namelisted (s
))
7024 ffecom_member_namelisted_
= TRUE
;
7028 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
7029 the member so debugger will see it. Otherwise nobody should be
7030 referencing the member. */
7032 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7034 ffecom_member_phase2_ (ffestorag mst
, ffestorag st
)
7042 || ((mt
= ffestorag_hook (mst
)) == NULL
)
7043 || (mt
== error_mark_node
))
7047 || ((s
= ffestorag_symbol (st
)) == NULL
))
7050 type
= ffecom_type_localvar_ (s
,
7051 ffesymbol_basictype (s
),
7052 ffesymbol_kindtype (s
));
7053 if (type
== error_mark_node
)
7056 t
= build_decl (VAR_DECL
,
7057 ffecom_get_identifier_ (ffesymbol_text (s
)),
7060 TREE_STATIC (t
) = TREE_STATIC (mt
);
7061 DECL_INITIAL (t
) = NULL_TREE
;
7062 TREE_ASM_WRITTEN (t
) = 1;
7066 gen_rtx (MEM
, TYPE_MODE (type
),
7067 plus_constant (XEXP (DECL_RTL (mt
), 0),
7068 ffestorag_modulo (mst
)
7069 + ffestorag_offset (st
)
7070 - ffestorag_offset (mst
))));
7072 t
= start_decl (t
, FALSE
);
7074 finish_decl (t
, NULL_TREE
, FALSE
);
7078 /* Prepare source expression for assignment into a destination perhaps known
7079 to be of a specific size. */
7082 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size
, ffebld source
)
7084 ffecomConcatList_ catlist
;
7089 tree tempvar
= NULL_TREE
;
7091 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
7092 source
= ffebld_left (source
);
7094 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
7095 count
= ffecom_concat_list_count_ (catlist
);
7100 = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node
,
7101 FFETARGET_charactersizeNONE
, count
);
7103 = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node
,
7104 FFETARGET_charactersizeNONE
, count
);
7106 tempvar
= make_tree_vec (2);
7107 TREE_VEC_ELT (tempvar
, 0) = ltmp
;
7108 TREE_VEC_ELT (tempvar
, 1) = itmp
;
7111 for (i
= 0; i
< count
; ++i
)
7112 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist
, i
));
7114 ffecom_concat_list_kill_ (catlist
);
7118 ffebld_nonter_set_hook (source
, tempvar
);
7119 current_binding_level
->prep_state
= 1;
7123 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7125 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7126 (which generates their trees) and then their trees get push_parm_decl'd.
7128 The second arg is TRUE if the dummies are for a statement function, in
7129 which case lengths are not pushed for character arguments (since they are
7130 always known by both the caller and the callee, though the code allows
7131 for someday permitting CHAR*(*) stmtfunc dummies). */
7133 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7135 ffecom_push_dummy_decls_ (ffebld dummy_list
, bool stmtfunc
)
7142 ffecom_transform_only_dummies_
= TRUE
;
7144 /* First push the parms corresponding to actual dummy "contents". */
7146 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7148 dummy
= ffebld_head (dumlist
);
7149 switch (ffebld_op (dummy
))
7153 continue; /* Forget alternate returns. */
7158 assert (ffebld_op (dummy
) == FFEBLD_opSYMTER
);
7159 s
= ffebld_symter (dummy
);
7160 parm
= ffesymbol_hook (s
).decl_tree
;
7161 if (parm
== NULL_TREE
)
7163 s
= ffecom_sym_transform_ (s
);
7164 parm
= ffesymbol_hook (s
).decl_tree
;
7165 assert (parm
!= NULL_TREE
);
7167 if (parm
!= error_mark_node
)
7168 push_parm_decl (parm
);
7171 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7173 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7175 dummy
= ffebld_head (dumlist
);
7176 switch (ffebld_op (dummy
))
7180 continue; /* Forget alternate returns, they mean
7186 s
= ffebld_symter (dummy
);
7187 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
7188 continue; /* Only looking for CHARACTER arguments. */
7189 if (stmtfunc
&& (ffesymbol_size (s
) != FFETARGET_charactersizeNONE
))
7190 continue; /* Stmtfunc arg with known size needs no
7192 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
7193 continue; /* Only looking for variables and arrays. */
7194 parm
= ffesymbol_hook (s
).length_tree
;
7195 assert (parm
!= NULL_TREE
);
7196 if (parm
!= error_mark_node
)
7197 push_parm_decl (parm
);
7200 ffecom_transform_only_dummies_
= FALSE
;
7204 /* ffecom_start_progunit_ -- Beginning of program unit
7206 Does GNU back end stuff necessary to teach it about the start of its
7207 equivalent of a Fortran program unit. */
7209 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7211 ffecom_start_progunit_ ()
7213 ffesymbol fn
= ffecom_primary_entry_
;
7215 tree id
; /* Identifier (name) of function. */
7216 tree type
; /* Type of function. */
7217 tree result
; /* Result of function. */
7218 ffeinfoBasictype bt
;
7222 ffeglobalType egt
= FFEGLOBAL_type
;
7225 bool altentries
= (ffecom_num_entrypoints_
!= 0);
7228 && (ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
7229 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
7230 bool main_program
= FALSE
;
7231 int old_lineno
= lineno
;
7232 const char *old_input_filename
= input_filename
;
7234 assert (fn
!= NULL
);
7235 assert (ffesymbol_hook (fn
).decl_tree
== NULL_TREE
);
7237 input_filename
= ffesymbol_where_filename (fn
);
7238 lineno
= ffesymbol_where_filelinenum (fn
);
7240 switch (ffecom_primary_entry_kind_
)
7242 case FFEINFO_kindPROGRAM
:
7243 main_program
= TRUE
;
7244 gt
= FFEGLOBAL_typeMAIN
;
7245 bt
= FFEINFO_basictypeNONE
;
7246 kt
= FFEINFO_kindtypeNONE
;
7247 type
= ffecom_tree_fun_type_void
;
7252 case FFEINFO_kindBLOCKDATA
:
7253 gt
= FFEGLOBAL_typeBDATA
;
7254 bt
= FFEINFO_basictypeNONE
;
7255 kt
= FFEINFO_kindtypeNONE
;
7256 type
= ffecom_tree_fun_type_void
;
7261 case FFEINFO_kindFUNCTION
:
7262 gt
= FFEGLOBAL_typeFUNC
;
7263 egt
= FFEGLOBAL_typeEXT
;
7264 bt
= ffesymbol_basictype (fn
);
7265 kt
= ffesymbol_kindtype (fn
);
7266 if (bt
== FFEINFO_basictypeNONE
)
7268 ffeimplic_establish_symbol (fn
);
7269 if (ffesymbol_funcresult (fn
) != NULL
)
7270 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
7271 bt
= ffesymbol_basictype (fn
);
7272 kt
= ffesymbol_kindtype (fn
);
7276 charfunc
= cmplxfunc
= FALSE
;
7277 else if (bt
== FFEINFO_basictypeCHARACTER
)
7278 charfunc
= TRUE
, cmplxfunc
= FALSE
;
7279 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
7280 && ffesymbol_is_f2c (fn
)
7282 charfunc
= FALSE
, cmplxfunc
= TRUE
;
7284 charfunc
= cmplxfunc
= FALSE
;
7286 if (multi
|| charfunc
)
7287 type
= ffecom_tree_fun_type_void
;
7288 else if (ffesymbol_is_f2c (fn
) && !altentries
)
7289 type
= ffecom_tree_fun_type
[bt
][kt
];
7291 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
7293 if ((type
== NULL_TREE
)
7294 || (TREE_TYPE (type
) == NULL_TREE
))
7295 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
7298 case FFEINFO_kindSUBROUTINE
:
7299 gt
= FFEGLOBAL_typeSUBR
;
7300 egt
= FFEGLOBAL_typeEXT
;
7301 bt
= FFEINFO_basictypeNONE
;
7302 kt
= FFEINFO_kindtypeNONE
;
7303 if (ffecom_is_altreturning_
)
7304 type
= ffecom_tree_subr_type
;
7306 type
= ffecom_tree_fun_type_void
;
7312 assert ("say what??" == NULL
);
7314 case FFEINFO_kindANY
:
7315 gt
= FFEGLOBAL_typeANY
;
7316 bt
= FFEINFO_basictypeNONE
;
7317 kt
= FFEINFO_kindtypeNONE
;
7318 type
= error_mark_node
;
7326 id
= ffecom_get_invented_identifier ("__g77_masterfun_%s",
7327 ffesymbol_text (fn
));
7329 #if FFETARGET_isENFORCED_MAIN
7330 else if (main_program
)
7331 id
= get_identifier (FFETARGET_nameENFORCED_MAIN_NAME
);
7334 id
= ffecom_get_external_identifier_ (fn
);
7338 0, /* nested/inline */
7339 !altentries
); /* TREE_PUBLIC */
7341 TREE_USED (current_function_decl
) = 1; /* Avoid spurious warning if altentries. */
7344 && ((g
= ffesymbol_global (fn
)) != NULL
)
7345 && ((ffeglobal_type (g
) == gt
)
7346 || (ffeglobal_type (g
) == egt
)))
7348 ffeglobal_set_hook (g
, current_function_decl
);
7351 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7352 exec-transitioning needs current_function_decl to be filled in. So we
7353 do these things in two phases. */
7356 { /* 1st arg identifies which entrypoint. */
7357 ffecom_which_entrypoint_decl_
7358 = build_decl (PARM_DECL
,
7359 ffecom_get_invented_identifier ("__g77_%s",
7360 "which_entrypoint"),
7362 push_parm_decl (ffecom_which_entrypoint_decl_
);
7368 { /* Arg for result (return value). */
7373 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
7375 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
7377 type
= ffecom_multi_type_node_
;
7379 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
7381 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7384 length
= ffecom_char_enhance_arg_ (&type
, fn
);
7386 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
7388 type
= build_pointer_type (type
);
7389 result
= build_decl (PARM_DECL
, result
, type
);
7391 push_parm_decl (result
);
7393 ffecom_multi_retval_
= result
;
7395 ffecom_func_result_
= result
;
7399 push_parm_decl (length
);
7400 ffecom_func_length_
= length
;
7404 if (ffecom_primary_entry_is_proc_
)
7407 arglist
= ffecom_master_arglist_
;
7409 arglist
= ffesymbol_dummyargs (fn
);
7410 ffecom_push_dummy_decls_ (arglist
, FALSE
);
7413 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
7414 store_parm_decls (main_program
? 1 : 0);
7416 ffecom_start_compstmt ();
7417 /* Disallow temp vars at this level. */
7418 current_binding_level
->prep_state
= 2;
7420 lineno
= old_lineno
;
7421 input_filename
= old_input_filename
;
7423 /* This handles any symbols still untransformed, in case -g specified.
7424 This used to be done in ffecom_finish_progunit, but it turns out to
7425 be necessary to do it here so that statement functions are
7426 expanded before code. But don't bother for BLOCK DATA. */
7428 if (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
7429 ffesymbol_drive (ffecom_finish_symbol_transform_
);
7433 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7436 ffecom_sym_transform_(s);
7438 The ffesymbol_hook info for s is updated with appropriate backend info
7441 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7443 ffecom_sym_transform_ (ffesymbol s
)
7445 tree t
; /* Transformed thingy. */
7446 tree tlen
; /* Length if CHAR*(*). */
7447 bool addr
; /* Is t the address of the thingy? */
7448 ffeinfoBasictype bt
;
7451 int old_lineno
= lineno
;
7452 const char *old_input_filename
= input_filename
;
7454 /* Must ensure special ASSIGN variables are declared at top of outermost
7455 block, else they'll end up in the innermost block when their first
7456 ASSIGN is seen, which leaves them out of scope when they're the
7457 subject of a GOTO or I/O statement.
7459 We make this variable even if -fugly-assign. Just let it go unused,
7460 in case it turns out there are cases where we really want to use this
7461 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7463 if (! ffecom_transform_only_dummies_
7464 && ffesymbol_assigned (s
)
7465 && ! ffesymbol_hook (s
).assign_tree
)
7466 s
= ffecom_sym_transform_assign_ (s
);
7468 if (ffesymbol_sfdummyparent (s
) == NULL
)
7470 input_filename
= ffesymbol_where_filename (s
);
7471 lineno
= ffesymbol_where_filelinenum (s
);
7475 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
7477 input_filename
= ffesymbol_where_filename (sf
);
7478 lineno
= ffesymbol_where_filelinenum (sf
);
7481 bt
= ffeinfo_basictype (ffebld_info (s
));
7482 kt
= ffeinfo_kindtype (ffebld_info (s
));
7488 switch (ffesymbol_kind (s
))
7490 case FFEINFO_kindNONE
:
7491 switch (ffesymbol_where (s
))
7493 case FFEINFO_whereDUMMY
: /* Subroutine or function. */
7494 assert (ffecom_transform_only_dummies_
);
7496 /* Before 0.4, this could be ENTITY/DUMMY, but see
7497 ffestu_sym_end_transition -- no longer true (in particular, if
7498 it could be an ENTITY, it _will_ be made one, so that
7499 possibility won't come through here). So we never make length
7500 arg for CHARACTER type. */
7502 t
= build_decl (PARM_DECL
,
7503 ffecom_get_identifier_ (ffesymbol_text (s
)),
7504 ffecom_tree_ptr_to_subr_type
);
7506 DECL_ARTIFICIAL (t
) = 1;
7511 case FFEINFO_whereGLOBAL
: /* Subroutine or function. */
7512 assert (!ffecom_transform_only_dummies_
);
7514 if (((g
= ffesymbol_global (s
)) != NULL
)
7515 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
7516 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7517 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
7518 && (ffeglobal_hook (g
) != NULL_TREE
)
7519 && ffe_is_globals ())
7521 t
= ffeglobal_hook (g
);
7525 t
= build_decl (FUNCTION_DECL
,
7526 ffecom_get_external_identifier_ (s
),
7527 ffecom_tree_subr_type
); /* Assume subr. */
7528 DECL_EXTERNAL (t
) = 1;
7529 TREE_PUBLIC (t
) = 1;
7531 t
= start_decl (t
, FALSE
);
7532 finish_decl (t
, NULL_TREE
, FALSE
);
7535 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
7536 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7537 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
7538 ffeglobal_set_hook (g
, t
);
7540 ffecom_save_tree_forever (t
);
7545 assert ("NONE where unexpected" == NULL
);
7547 case FFEINFO_whereANY
:
7552 case FFEINFO_kindENTITY
:
7553 switch (ffeinfo_where (ffesymbol_info (s
)))
7556 case FFEINFO_whereCONSTANT
:
7557 /* ~~Debugging info needed? */
7558 assert (!ffecom_transform_only_dummies_
);
7559 t
= error_mark_node
; /* Shouldn't ever see this in expr. */
7562 case FFEINFO_whereLOCAL
:
7563 assert (!ffecom_transform_only_dummies_
);
7566 ffestorag st
= ffesymbol_storage (s
);
7570 && (ffestorag_size (st
) == 0))
7572 t
= error_mark_node
;
7576 type
= ffecom_type_localvar_ (s
, bt
, kt
);
7578 if (type
== error_mark_node
)
7580 t
= error_mark_node
;
7585 && (ffestorag_parent (st
) != NULL
))
7586 { /* Child of EQUIVALENCE parent. */
7589 ffetargetOffset offset
;
7591 est
= ffestorag_parent (st
);
7592 ffecom_transform_equiv_ (est
);
7594 et
= ffestorag_hook (est
);
7595 assert (et
!= NULL_TREE
);
7597 if (! TREE_STATIC (et
))
7598 put_var_into_stack (et
);
7600 offset
= ffestorag_modulo (est
)
7601 + ffestorag_offset (ffesymbol_storage (s
))
7602 - ffestorag_offset (est
);
7604 ffecom_debug_kludge_ (et
, "EQUIVALENCE", s
, type
, offset
);
7606 /* (t_type *) (((char *) &et) + offset) */
7608 t
= convert (string_type_node
, /* (char *) */
7609 ffecom_1 (ADDR_EXPR
,
7610 build_pointer_type (TREE_TYPE (et
)),
7612 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
7614 build_int_2 (offset
, 0));
7615 t
= convert (build_pointer_type (type
),
7617 TREE_CONSTANT (t
) = staticp (et
);
7624 bool init
= ffesymbol_is_init (s
);
7626 t
= build_decl (VAR_DECL
,
7627 ffecom_get_identifier_ (ffesymbol_text (s
)),
7631 || ffesymbol_namelisted (s
)
7632 #ifdef FFECOM_sizeMAXSTACKITEM
7634 && (ffestorag_size (st
) > FFECOM_sizeMAXSTACKITEM
))
7636 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
7637 && (ffecom_primary_entry_kind_
7638 != FFEINFO_kindBLOCKDATA
)
7639 && (ffesymbol_is_save (s
) || ffe_is_saveall ())))
7640 TREE_STATIC (t
) = !ffesymbol_attr (s
, FFESYMBOL_attrADJUSTABLE
);
7642 TREE_STATIC (t
) = 0; /* No need to make static. */
7644 if (init
|| ffe_is_init_local_zero ())
7645 DECL_INITIAL (t
) = error_mark_node
;
7647 /* Keep -Wunused from complaining about var if it
7648 is used as sfunc arg or DATA implied-DO. */
7649 if (ffesymbol_attrs (s
) & FFESYMBOL_attrsSFARG
)
7650 DECL_IN_SYSTEM_HEADER (t
) = 1;
7652 t
= start_decl (t
, FALSE
);
7656 if (ffesymbol_init (s
) != NULL
)
7657 initexpr
= ffecom_expr (ffesymbol_init (s
));
7659 initexpr
= ffecom_init_zero_ (t
);
7661 else if (ffe_is_init_local_zero ())
7662 initexpr
= ffecom_init_zero_ (t
);
7664 initexpr
= NULL_TREE
; /* Not ref'd if !init. */
7666 finish_decl (t
, initexpr
, FALSE
);
7668 if (st
!= NULL
&& DECL_SIZE (t
) != error_mark_node
)
7670 assert (TREE_CODE (DECL_SIZE_UNIT (t
)) == INTEGER_CST
);
7671 assert (0 == compare_tree_int (DECL_SIZE_UNIT (t
),
7672 ffestorag_size (st
)));
7678 case FFEINFO_whereRESULT
:
7679 assert (!ffecom_transform_only_dummies_
);
7681 if (bt
== FFEINFO_basictypeCHARACTER
)
7682 { /* Result is already in list of dummies, use
7684 t
= ffecom_func_result_
;
7685 tlen
= ffecom_func_length_
;
7689 if ((ffecom_num_entrypoints_
== 0)
7690 && (bt
== FFEINFO_basictypeCOMPLEX
)
7691 && (ffesymbol_is_f2c (ffecom_primary_entry_
)))
7692 { /* Result is already in list of dummies, use
7694 t
= ffecom_func_result_
;
7698 if (ffecom_func_result_
!= NULL_TREE
)
7700 t
= ffecom_func_result_
;
7703 if ((ffecom_num_entrypoints_
!= 0)
7704 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
))
7706 assert (ffecom_multi_retval_
!= NULL_TREE
);
7707 t
= ffecom_1 (INDIRECT_REF
, ffecom_multi_type_node_
,
7708 ffecom_multi_retval_
);
7709 t
= ffecom_2 (COMPONENT_REF
, ffecom_tree_type
[bt
][kt
],
7710 t
, ffecom_multi_fields_
[bt
][kt
]);
7715 t
= build_decl (VAR_DECL
,
7716 ffecom_get_identifier_ (ffesymbol_text (s
)),
7717 ffecom_tree_type
[bt
][kt
]);
7718 TREE_STATIC (t
) = 0; /* Put result on stack. */
7719 t
= start_decl (t
, FALSE
);
7720 finish_decl (t
, NULL_TREE
, FALSE
);
7722 ffecom_func_result_
= t
;
7726 case FFEINFO_whereDUMMY
:
7734 bool adjustable
= FALSE
; /* Conditionally adjustable? */
7736 type
= ffecom_tree_type
[bt
][kt
];
7737 if (ffesymbol_sfdummyparent (s
) != NULL
)
7739 if (current_function_decl
== ffecom_outer_function_decl_
)
7740 { /* Exec transition before sfunc
7741 context; get it later. */
7744 t
= ffecom_get_identifier_ (ffesymbol_text
7745 (ffesymbol_sfdummyparent (s
)));
7748 t
= ffecom_get_identifier_ (ffesymbol_text (s
));
7750 assert (ffecom_transform_only_dummies_
);
7752 old_sizes
= get_pending_sizes ();
7753 put_pending_sizes (old_sizes
);
7755 if (bt
== FFEINFO_basictypeCHARACTER
)
7756 tlen
= ffecom_char_enhance_arg_ (&type
, s
);
7757 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
7759 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
7761 if (type
== error_mark_node
)
7764 dim
= ffebld_head (dl
);
7765 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
7766 if ((ffebld_left (dim
) == NULL
) || ffecom_doing_entry_
)
7767 low
= ffecom_integer_one_node
;
7769 low
= ffecom_expr (ffebld_left (dim
));
7770 assert (ffebld_right (dim
) != NULL
);
7771 if ((ffebld_op (ffebld_right (dim
)) == FFEBLD_opSTAR
)
7772 || ffecom_doing_entry_
)
7774 /* Used to just do high=low. But for ffecom_tree_
7775 canonize_ref_, it probably is important to correctly
7776 assess the size. E.g. given COMPLEX C(*),CFUNC and
7777 C(2)=CFUNC(C), overlap can happen, while it can't
7778 for, say, C(1)=CFUNC(C(2)). */
7779 /* Even more recently used to set to INT_MAX, but that
7780 broke when some overflow checking went into the back
7781 end. Now we just leave the upper bound unspecified. */
7785 high
= ffecom_expr (ffebld_right (dim
));
7787 /* Determine whether array is conditionally adjustable,
7788 to decide whether back-end magic is needed.
7790 Normally the front end uses the back-end function
7791 variable_size to wrap SAVE_EXPR's around expressions
7792 affecting the size/shape of an array so that the
7793 size/shape info doesn't change during execution
7794 of the compiled code even though variables and
7795 functions referenced in those expressions might.
7797 variable_size also makes sure those saved expressions
7798 get evaluated immediately upon entry to the
7799 compiled procedure -- the front end normally doesn't
7800 have to worry about that.
7802 However, there is a problem with this that affects
7803 g77's implementation of entry points, and that is
7804 that it is _not_ true that each invocation of the
7805 compiled procedure is permitted to evaluate
7806 array size/shape info -- because it is possible
7807 that, for some invocations, that info is invalid (in
7808 which case it is "promised" -- i.e. a violation of
7809 the Fortran standard -- that the compiled code
7810 won't reference the array or its size/shape
7811 during that particular invocation).
7813 To phrase this in C terms, consider this gcc function:
7815 void foo (int *n, float (*a)[*n])
7817 // a is "pointer to array ...", fyi.
7820 Suppose that, for some invocations, it is permitted
7821 for a caller of foo to do this:
7825 Now the _written_ code for foo can take such a call
7826 into account by either testing explicitly for whether
7827 (a == NULL) || (n == NULL) -- presumably it is
7828 not permitted to reference *a in various fashions
7829 if (n == NULL) I suppose -- or it can avoid it by
7830 looking at other info (other arguments, static/global
7833 However, this won't work in gcc 2.5.8 because it'll
7834 automatically emit the code to save the "*n"
7835 expression, which'll yield a NULL dereference for
7836 the "foo (NULL, NULL)" call, something the code
7837 for foo cannot prevent.
7839 g77 definitely needs to avoid executing such
7840 code anytime the pointer to the adjustable array
7841 is NULL, because even if its bounds expressions
7842 don't have any references to possible "absent"
7843 variables like "*n" -- say all variable references
7844 are to COMMON variables, i.e. global (though in C,
7845 local static could actually make sense) -- the
7846 expressions could yield other run-time problems
7847 for allowably "dead" values in those variables.
7849 For example, let's consider a more complicated
7855 void foo (float (*a)[i/j])
7860 The above is (essentially) quite valid for Fortran
7861 but, again, for a call like "foo (NULL);", it is
7862 permitted for i and j to be undefined when the
7863 call is made. If j happened to be zero, for
7864 example, emitting the code to evaluate "i/j"
7865 could result in a run-time error.
7867 Offhand, though I don't have my F77 or F90
7868 standards handy, it might even be valid for a
7869 bounds expression to contain a function reference,
7870 in which case I doubt it is permitted for an
7871 implementation to invoke that function in the
7872 Fortran case involved here (invocation of an
7873 alternate ENTRY point that doesn't have the adjustable
7874 array as one of its arguments).
7876 So, the code that the compiler would normally emit
7877 to preevaluate the size/shape info for an
7878 adjustable array _must not_ be executed at run time
7879 in certain cases. Specifically, for Fortran,
7880 the case is when the pointer to the adjustable
7881 array == NULL. (For gnu-ish C, it might be nice
7882 for the source code itself to specify an expression
7883 that, if TRUE, inhibits execution of the code. Or
7884 reverse the sense for elegance.)
7886 (Note that g77 could use a different test than NULL,
7887 actually, since it happens to always pass an
7888 integer to the called function that specifies which
7889 entry point is being invoked. Hmm, this might
7890 solve the next problem.)
7892 One way a user could, I suppose, write "foo" so
7893 it works is to insert COND_EXPR's for the
7894 size/shape info so the dangerous stuff isn't
7895 actually done, as in:
7897 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7902 The next problem is that the front end needs to
7903 be able to tell the back end about the array's
7904 decl _before_ it tells it about the conditional
7905 expression to inhibit evaluation of size/shape info,
7908 To solve this, the front end needs to be able
7909 to give the back end the expression to inhibit
7910 generation of the preevaluation code _after_
7911 it makes the decl for the adjustable array.
7913 Until then, the above example using the COND_EXPR
7914 doesn't pass muster with gcc because the "(a == NULL)"
7915 part has a reference to "a", which is still
7916 undefined at that point.
7918 g77 will therefore use a different mechanism in the
7922 && ((TREE_CODE (low
) != INTEGER_CST
)
7923 || (high
&& TREE_CODE (high
) != INTEGER_CST
)))
7926 #if 0 /* Old approach -- see below. */
7927 if (TREE_CODE (low
) != INTEGER_CST
)
7928 low
= ffecom_3 (COND_EXPR
, integer_type_node
,
7929 ffecom_adjarray_passed_ (s
),
7931 ffecom_integer_zero_node
);
7933 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
7934 high
= ffecom_3 (COND_EXPR
, integer_type_node
,
7935 ffecom_adjarray_passed_ (s
),
7937 ffecom_integer_zero_node
);
7940 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7941 probably. Fixes 950302-1.f. */
7943 if (TREE_CODE (low
) != INTEGER_CST
)
7944 low
= variable_size (low
);
7946 /* ~~~Similarly, this fixes dumb0.f. The C front end
7947 does this, which is why dumb0.c would work. */
7949 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
7950 high
= variable_size (high
);
7955 build_range_type (ffecom_integer_type_node
,
7957 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
7960 if (type
== error_mark_node
)
7962 t
= error_mark_node
;
7966 if ((ffesymbol_sfdummyparent (s
) == NULL
)
7967 || (ffesymbol_basictype (s
) == FFEINFO_basictypeCHARACTER
))
7969 type
= build_pointer_type (type
);
7973 t
= build_decl (PARM_DECL
, t
, type
);
7975 DECL_ARTIFICIAL (t
) = 1;
7978 /* If this arg is present in every entry point's list of
7979 dummy args, then we're done. */
7981 if (ffesymbol_numentries (s
)
7982 == (ffecom_num_entrypoints_
+ 1))
7987 /* If variable_size in stor-layout has been called during
7988 the above, then get_pending_sizes should have the
7989 yet-to-be-evaluated saved expressions pending.
7990 Make the whole lot of them get emitted, conditionally
7991 on whether the array decl ("t" above) is not NULL. */
7994 tree sizes
= get_pending_sizes ();
7999 tem
= TREE_CHAIN (tem
))
8001 tree temv
= TREE_VALUE (tem
);
8007 = ffecom_2 (COMPOUND_EXPR
,
8016 = ffecom_3 (COND_EXPR
,
8023 convert (TREE_TYPE (sizes
),
8024 integer_zero_node
));
8025 sizes
= ffecom_save_tree (sizes
);
8028 = tree_cons (NULL_TREE
, sizes
, tem
);
8032 put_pending_sizes (sizes
);
8038 && (ffesymbol_numentries (s
)
8039 != ffecom_num_entrypoints_
+ 1))
8041 = ffecom_2 (NE_EXPR
, integer_type_node
,
8047 && (ffesymbol_numentries (s
)
8048 != ffecom_num_entrypoints_
+ 1))
8050 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED
);
8051 ffebad_here (0, ffesymbol_where_line (s
),
8052 ffesymbol_where_column (s
));
8053 ffebad_string (ffesymbol_text (s
));
8062 case FFEINFO_whereCOMMON
:
8067 ffestorag st
= ffesymbol_storage (s
);
8070 cs
= ffesymbol_common (s
); /* The COMMON area itself. */
8071 if (st
!= NULL
) /* Else not laid out. */
8073 ffecom_transform_common_ (cs
);
8074 st
= ffesymbol_storage (s
);
8077 type
= ffecom_type_localvar_ (s
, bt
, kt
);
8079 cg
= ffesymbol_global (cs
); /* The global COMMON info. */
8081 || (ffeglobal_type (cg
) != FFEGLOBAL_typeCOMMON
))
8084 ct
= ffeglobal_hook (cg
); /* The common area's tree. */
8086 if ((ct
== NULL_TREE
)
8088 || (type
== error_mark_node
))
8089 t
= error_mark_node
;
8092 ffetargetOffset offset
;
8095 cst
= ffestorag_parent (st
);
8096 assert (cst
== ffesymbol_storage (cs
));
8098 offset
= ffestorag_modulo (cst
)
8099 + ffestorag_offset (st
)
8100 - ffestorag_offset (cst
);
8102 ffecom_debug_kludge_ (ct
, "COMMON", s
, type
, offset
);
8104 /* (t_type *) (((char *) &ct) + offset) */
8106 t
= convert (string_type_node
, /* (char *) */
8107 ffecom_1 (ADDR_EXPR
,
8108 build_pointer_type (TREE_TYPE (ct
)),
8110 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
8112 build_int_2 (offset
, 0));
8113 t
= convert (build_pointer_type (type
),
8115 TREE_CONSTANT (t
) = 1;
8122 case FFEINFO_whereIMMEDIATE
:
8123 case FFEINFO_whereGLOBAL
:
8124 case FFEINFO_whereFLEETING
:
8125 case FFEINFO_whereFLEETING_CADDR
:
8126 case FFEINFO_whereFLEETING_IADDR
:
8127 case FFEINFO_whereINTRINSIC
:
8128 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8130 assert ("ENTITY where unheard of" == NULL
);
8132 case FFEINFO_whereANY
:
8133 t
= error_mark_node
;
8138 case FFEINFO_kindFUNCTION
:
8139 switch (ffeinfo_where (ffesymbol_info (s
)))
8141 case FFEINFO_whereLOCAL
: /* Me. */
8142 assert (!ffecom_transform_only_dummies_
);
8143 t
= current_function_decl
;
8146 case FFEINFO_whereGLOBAL
:
8147 assert (!ffecom_transform_only_dummies_
);
8149 if (((g
= ffesymbol_global (s
)) != NULL
)
8150 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8151 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8152 && (ffeglobal_hook (g
) != NULL_TREE
)
8153 && ffe_is_globals ())
8155 t
= ffeglobal_hook (g
);
8159 if (ffesymbol_is_f2c (s
)
8160 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8161 t
= ffecom_tree_fun_type
[bt
][kt
];
8163 t
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
8165 t
= build_decl (FUNCTION_DECL
,
8166 ffecom_get_external_identifier_ (s
),
8168 DECL_EXTERNAL (t
) = 1;
8169 TREE_PUBLIC (t
) = 1;
8171 t
= start_decl (t
, FALSE
);
8172 finish_decl (t
, NULL_TREE
, FALSE
);
8175 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8176 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8177 ffeglobal_set_hook (g
, t
);
8179 ffecom_save_tree_forever (t
);
8183 case FFEINFO_whereDUMMY
:
8184 assert (ffecom_transform_only_dummies_
);
8186 if (ffesymbol_is_f2c (s
)
8187 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8188 t
= ffecom_tree_ptr_to_fun_type
[bt
][kt
];
8190 t
= build_pointer_type
8191 (build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
));
8193 t
= build_decl (PARM_DECL
,
8194 ffecom_get_identifier_ (ffesymbol_text (s
)),
8197 DECL_ARTIFICIAL (t
) = 1;
8202 case FFEINFO_whereCONSTANT
: /* Statement function. */
8203 assert (!ffecom_transform_only_dummies_
);
8204 t
= ffecom_gen_sfuncdef_ (s
, bt
, kt
);
8207 case FFEINFO_whereINTRINSIC
:
8208 assert (!ffecom_transform_only_dummies_
);
8209 break; /* Let actual references generate their
8213 assert ("FUNCTION where unheard of" == NULL
);
8215 case FFEINFO_whereANY
:
8216 t
= error_mark_node
;
8221 case FFEINFO_kindSUBROUTINE
:
8222 switch (ffeinfo_where (ffesymbol_info (s
)))
8224 case FFEINFO_whereLOCAL
: /* Me. */
8225 assert (!ffecom_transform_only_dummies_
);
8226 t
= current_function_decl
;
8229 case FFEINFO_whereGLOBAL
:
8230 assert (!ffecom_transform_only_dummies_
);
8232 if (((g
= ffesymbol_global (s
)) != NULL
)
8233 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8234 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8235 && (ffeglobal_hook (g
) != NULL_TREE
)
8236 && ffe_is_globals ())
8238 t
= ffeglobal_hook (g
);
8242 t
= build_decl (FUNCTION_DECL
,
8243 ffecom_get_external_identifier_ (s
),
8244 ffecom_tree_subr_type
);
8245 DECL_EXTERNAL (t
) = 1;
8246 TREE_PUBLIC (t
) = 1;
8248 t
= start_decl (t
, FALSE
);
8249 finish_decl (t
, NULL_TREE
, FALSE
);
8252 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8253 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8254 ffeglobal_set_hook (g
, t
);
8256 ffecom_save_tree_forever (t
);
8260 case FFEINFO_whereDUMMY
:
8261 assert (ffecom_transform_only_dummies_
);
8263 t
= build_decl (PARM_DECL
,
8264 ffecom_get_identifier_ (ffesymbol_text (s
)),
8265 ffecom_tree_ptr_to_subr_type
);
8267 DECL_ARTIFICIAL (t
) = 1;
8272 case FFEINFO_whereINTRINSIC
:
8273 assert (!ffecom_transform_only_dummies_
);
8274 break; /* Let actual references generate their
8278 assert ("SUBROUTINE where unheard of" == NULL
);
8280 case FFEINFO_whereANY
:
8281 t
= error_mark_node
;
8286 case FFEINFO_kindPROGRAM
:
8287 switch (ffeinfo_where (ffesymbol_info (s
)))
8289 case FFEINFO_whereLOCAL
: /* Me. */
8290 assert (!ffecom_transform_only_dummies_
);
8291 t
= current_function_decl
;
8294 case FFEINFO_whereCOMMON
:
8295 case FFEINFO_whereDUMMY
:
8296 case FFEINFO_whereGLOBAL
:
8297 case FFEINFO_whereRESULT
:
8298 case FFEINFO_whereFLEETING
:
8299 case FFEINFO_whereFLEETING_CADDR
:
8300 case FFEINFO_whereFLEETING_IADDR
:
8301 case FFEINFO_whereIMMEDIATE
:
8302 case FFEINFO_whereINTRINSIC
:
8303 case FFEINFO_whereCONSTANT
:
8304 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8306 assert ("PROGRAM where unheard of" == NULL
);
8308 case FFEINFO_whereANY
:
8309 t
= error_mark_node
;
8314 case FFEINFO_kindBLOCKDATA
:
8315 switch (ffeinfo_where (ffesymbol_info (s
)))
8317 case FFEINFO_whereLOCAL
: /* Me. */
8318 assert (!ffecom_transform_only_dummies_
);
8319 t
= current_function_decl
;
8322 case FFEINFO_whereGLOBAL
:
8323 assert (!ffecom_transform_only_dummies_
);
8325 t
= build_decl (FUNCTION_DECL
,
8326 ffecom_get_external_identifier_ (s
),
8327 ffecom_tree_blockdata_type
);
8328 DECL_EXTERNAL (t
) = 1;
8329 TREE_PUBLIC (t
) = 1;
8331 t
= start_decl (t
, FALSE
);
8332 finish_decl (t
, NULL_TREE
, FALSE
);
8334 ffecom_save_tree_forever (t
);
8338 case FFEINFO_whereCOMMON
:
8339 case FFEINFO_whereDUMMY
:
8340 case FFEINFO_whereRESULT
:
8341 case FFEINFO_whereFLEETING
:
8342 case FFEINFO_whereFLEETING_CADDR
:
8343 case FFEINFO_whereFLEETING_IADDR
:
8344 case FFEINFO_whereIMMEDIATE
:
8345 case FFEINFO_whereINTRINSIC
:
8346 case FFEINFO_whereCONSTANT
:
8347 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8349 assert ("BLOCKDATA where unheard of" == NULL
);
8351 case FFEINFO_whereANY
:
8352 t
= error_mark_node
;
8357 case FFEINFO_kindCOMMON
:
8358 switch (ffeinfo_where (ffesymbol_info (s
)))
8360 case FFEINFO_whereLOCAL
:
8361 assert (!ffecom_transform_only_dummies_
);
8362 ffecom_transform_common_ (s
);
8365 case FFEINFO_whereNONE
:
8366 case FFEINFO_whereCOMMON
:
8367 case FFEINFO_whereDUMMY
:
8368 case FFEINFO_whereGLOBAL
:
8369 case FFEINFO_whereRESULT
:
8370 case FFEINFO_whereFLEETING
:
8371 case FFEINFO_whereFLEETING_CADDR
:
8372 case FFEINFO_whereFLEETING_IADDR
:
8373 case FFEINFO_whereIMMEDIATE
:
8374 case FFEINFO_whereINTRINSIC
:
8375 case FFEINFO_whereCONSTANT
:
8376 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8378 assert ("COMMON where unheard of" == NULL
);
8380 case FFEINFO_whereANY
:
8381 t
= error_mark_node
;
8386 case FFEINFO_kindCONSTRUCT
:
8387 switch (ffeinfo_where (ffesymbol_info (s
)))
8389 case FFEINFO_whereLOCAL
:
8390 assert (!ffecom_transform_only_dummies_
);
8393 case FFEINFO_whereNONE
:
8394 case FFEINFO_whereCOMMON
:
8395 case FFEINFO_whereDUMMY
:
8396 case FFEINFO_whereGLOBAL
:
8397 case FFEINFO_whereRESULT
:
8398 case FFEINFO_whereFLEETING
:
8399 case FFEINFO_whereFLEETING_CADDR
:
8400 case FFEINFO_whereFLEETING_IADDR
:
8401 case FFEINFO_whereIMMEDIATE
:
8402 case FFEINFO_whereINTRINSIC
:
8403 case FFEINFO_whereCONSTANT
:
8404 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8406 assert ("CONSTRUCT where unheard of" == NULL
);
8408 case FFEINFO_whereANY
:
8409 t
= error_mark_node
;
8414 case FFEINFO_kindNAMELIST
:
8415 switch (ffeinfo_where (ffesymbol_info (s
)))
8417 case FFEINFO_whereLOCAL
:
8418 assert (!ffecom_transform_only_dummies_
);
8419 t
= ffecom_transform_namelist_ (s
);
8422 case FFEINFO_whereNONE
:
8423 case FFEINFO_whereCOMMON
:
8424 case FFEINFO_whereDUMMY
:
8425 case FFEINFO_whereGLOBAL
:
8426 case FFEINFO_whereRESULT
:
8427 case FFEINFO_whereFLEETING
:
8428 case FFEINFO_whereFLEETING_CADDR
:
8429 case FFEINFO_whereFLEETING_IADDR
:
8430 case FFEINFO_whereIMMEDIATE
:
8431 case FFEINFO_whereINTRINSIC
:
8432 case FFEINFO_whereCONSTANT
:
8433 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8435 assert ("NAMELIST where unheard of" == NULL
);
8437 case FFEINFO_whereANY
:
8438 t
= error_mark_node
;
8444 assert ("kind unheard of" == NULL
);
8446 case FFEINFO_kindANY
:
8447 t
= error_mark_node
;
8451 ffesymbol_hook (s
).decl_tree
= t
;
8452 ffesymbol_hook (s
).length_tree
= tlen
;
8453 ffesymbol_hook (s
).addr
= addr
;
8455 lineno
= old_lineno
;
8456 input_filename
= old_input_filename
;
8462 /* Transform into ASSIGNable symbol.
8464 Symbol has already been transformed, but for whatever reason, the
8465 resulting decl_tree has been deemed not usable for an ASSIGN target.
8466 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8467 another local symbol of type void * and stuff that in the assign_tree
8468 argument. The F77/F90 standards allow this implementation. */
8470 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8472 ffecom_sym_transform_assign_ (ffesymbol s
)
8474 tree t
; /* Transformed thingy. */
8475 int old_lineno
= lineno
;
8476 const char *old_input_filename
= input_filename
;
8478 if (ffesymbol_sfdummyparent (s
) == NULL
)
8480 input_filename
= ffesymbol_where_filename (s
);
8481 lineno
= ffesymbol_where_filelinenum (s
);
8485 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
8487 input_filename
= ffesymbol_where_filename (sf
);
8488 lineno
= ffesymbol_where_filelinenum (sf
);
8491 assert (!ffecom_transform_only_dummies_
);
8493 t
= build_decl (VAR_DECL
,
8494 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8495 ffesymbol_text (s
)),
8496 TREE_TYPE (null_pointer_node
));
8498 switch (ffesymbol_where (s
))
8500 case FFEINFO_whereLOCAL
:
8501 /* Unlike for regular vars, SAVE status is easy to determine for
8502 ASSIGNed vars, since there's no initialization, there's no
8503 effective storage association (so "SAVE J" does not apply to
8504 K even given "EQUIVALENCE (J,K)"), there's no size issue
8505 to worry about, etc. */
8506 if ((ffesymbol_is_save (s
) || ffe_is_saveall ())
8507 && (ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8508 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
))
8509 TREE_STATIC (t
) = 1; /* SAVEd in proc, make static. */
8511 TREE_STATIC (t
) = 0; /* No need to make static. */
8514 case FFEINFO_whereCOMMON
:
8515 TREE_STATIC (t
) = 1; /* Assume COMMONs always SAVEd. */
8518 case FFEINFO_whereDUMMY
:
8519 /* Note that twinning a DUMMY means the caller won't see
8520 the ASSIGNed value. But both F77 and F90 allow implementations
8521 to do this, i.e. disallow Fortran code that would try and
8522 take advantage of actually putting a label into a variable
8523 via a dummy argument (or any other storage association, for
8525 TREE_STATIC (t
) = 0;
8529 TREE_STATIC (t
) = 0;
8533 t
= start_decl (t
, FALSE
);
8534 finish_decl (t
, NULL_TREE
, FALSE
);
8536 ffesymbol_hook (s
).assign_tree
= t
;
8538 lineno
= old_lineno
;
8539 input_filename
= old_input_filename
;
8545 /* Implement COMMON area in back end.
8547 Because COMMON-based variables can be referenced in the dimension
8548 expressions of dummy (adjustable) arrays, and because dummies
8549 (in the gcc back end) need to be put in the outer binding level
8550 of a function (which has two binding levels, the outer holding
8551 the dummies and the inner holding the other vars), special care
8552 must be taken to handle COMMON areas.
8554 The current strategy is basically to always tell the back end about
8555 the COMMON area as a top-level external reference to just a block
8556 of storage of the master type of that area (e.g. integer, real,
8557 character, whatever -- not a structure). As a distinct action,
8558 if initial values are provided, tell the back end about the area
8559 as a top-level non-external (initialized) area and remember not to
8560 allow further initialization or expansion of the area. Meanwhile,
8561 if no initialization happens at all, tell the back end about
8562 the largest size we've seen declared so the space does get reserved.
8563 (This function doesn't handle all that stuff, but it does some
8564 of the important things.)
8566 Meanwhile, for COMMON variables themselves, just keep creating
8567 references like *((float *) (&common_area + offset)) each time
8568 we reference the variable. In other words, don't make a VAR_DECL
8569 or any kind of component reference (like we used to do before 0.4),
8570 though we might do that as well just for debugging purposes (and
8571 stuff the rtl with the appropriate offset expression). */
8573 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8575 ffecom_transform_common_ (ffesymbol s
)
8577 ffestorag st
= ffesymbol_storage (s
);
8578 ffeglobal g
= ffesymbol_global (s
);
8583 bool is_init
= ffestorag_is_init (st
);
8585 assert (st
!= NULL
);
8588 || (ffeglobal_type (g
) != FFEGLOBAL_typeCOMMON
))
8591 /* First update the size of the area in global terms. */
8593 ffeglobal_size_common (s
, ffestorag_size (st
));
8595 if (!ffeglobal_common_init (g
))
8596 is_init
= FALSE
; /* No explicit init, don't let erroneous joins init. */
8598 cbt
= ffeglobal_hook (g
);
8600 /* If we already have declared this common block for a previous program
8601 unit, and either we already initialized it or we don't have new
8602 initialization for it, just return what we have without changing it. */
8604 if ((cbt
!= NULL_TREE
)
8606 || !DECL_EXTERNAL (cbt
)))
8608 if (st
->hook
== NULL
) ffestorag_set_hook (st
, cbt
);
8612 /* Process inits. */
8616 if (ffestorag_init (st
) != NULL
)
8620 /* Set the padding for the expression, so ffecom_expr
8621 knows to insert that many zeros. */
8622 switch (ffebld_op (sexp
= ffestorag_init (st
)))
8624 case FFEBLD_opCONTER
:
8625 ffebld_conter_set_pad (sexp
, ffestorag_modulo (st
));
8628 case FFEBLD_opARRTER
:
8629 ffebld_arrter_set_pad (sexp
, ffestorag_modulo (st
));
8632 case FFEBLD_opACCTER
:
8633 ffebld_accter_set_pad (sexp
, ffestorag_modulo (st
));
8637 assert ("bad op for cmn init (pad)" == NULL
);
8641 init
= ffecom_expr (sexp
);
8642 if (init
== error_mark_node
)
8643 { /* Hopefully the back end complained! */
8645 if (cbt
!= NULL_TREE
)
8650 init
= error_mark_node
;
8655 /* cbtype must be permanently allocated! */
8657 /* Allocate the MAX of the areas so far, seen filewide. */
8658 high
= build_int_2 ((ffeglobal_common_size (g
)
8659 + ffeglobal_common_pad (g
)) - 1, 0);
8660 TREE_TYPE (high
) = ffecom_integer_type_node
;
8663 cbtype
= build_array_type (char_type_node
,
8664 build_range_type (integer_type_node
,
8668 cbtype
= build_array_type (char_type_node
, NULL_TREE
);
8670 if (cbt
== NULL_TREE
)
8673 = build_decl (VAR_DECL
,
8674 ffecom_get_external_identifier_ (s
),
8676 TREE_STATIC (cbt
) = 1;
8677 TREE_PUBLIC (cbt
) = 1;
8682 TREE_TYPE (cbt
) = cbtype
;
8684 DECL_EXTERNAL (cbt
) = init
? 0 : 1;
8685 DECL_INITIAL (cbt
) = init
? error_mark_node
: NULL_TREE
;
8687 cbt
= start_decl (cbt
, TRUE
);
8688 if (ffeglobal_hook (g
) != NULL
)
8689 assert (cbt
== ffeglobal_hook (g
));
8691 assert (!init
|| !DECL_EXTERNAL (cbt
));
8693 /* Make sure that any type can live in COMMON and be referenced
8694 without getting a bus error. We could pick the most restrictive
8695 alignment of all entities actually placed in the COMMON, but
8696 this seems easy enough. */
8698 DECL_ALIGN (cbt
) = BIGGEST_ALIGNMENT
;
8699 DECL_USER_ALIGN (cbt
) = 0;
8701 if (is_init
&& (ffestorag_init (st
) == NULL
))
8702 init
= ffecom_init_zero_ (cbt
);
8704 finish_decl (cbt
, init
, TRUE
);
8707 ffestorag_set_init (st
, ffebld_new_any ());
8711 assert (DECL_SIZE_UNIT (cbt
) != NULL_TREE
);
8712 assert (TREE_CODE (DECL_SIZE_UNIT (cbt
)) == INTEGER_CST
);
8713 assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt
),
8714 (ffeglobal_common_size (g
)
8715 + ffeglobal_common_pad (g
))));
8718 ffeglobal_set_hook (g
, cbt
);
8720 ffestorag_set_hook (st
, cbt
);
8722 ffecom_save_tree_forever (cbt
);
8726 /* Make master area for local EQUIVALENCE. */
8728 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8730 ffecom_transform_equiv_ (ffestorag eqst
)
8736 bool is_init
= ffestorag_is_init (eqst
);
8738 assert (eqst
!= NULL
);
8740 eqt
= ffestorag_hook (eqst
);
8742 if (eqt
!= NULL_TREE
)
8745 /* Process inits. */
8749 if (ffestorag_init (eqst
) != NULL
)
8753 /* Set the padding for the expression, so ffecom_expr
8754 knows to insert that many zeros. */
8755 switch (ffebld_op (sexp
= ffestorag_init (eqst
)))
8757 case FFEBLD_opCONTER
:
8758 ffebld_conter_set_pad (sexp
, ffestorag_modulo (eqst
));
8761 case FFEBLD_opARRTER
:
8762 ffebld_arrter_set_pad (sexp
, ffestorag_modulo (eqst
));
8765 case FFEBLD_opACCTER
:
8766 ffebld_accter_set_pad (sexp
, ffestorag_modulo (eqst
));
8770 assert ("bad op for eqv init (pad)" == NULL
);
8774 init
= ffecom_expr (sexp
);
8775 if (init
== error_mark_node
)
8776 init
= NULL_TREE
; /* Hopefully the back end complained! */
8779 init
= error_mark_node
;
8781 else if (ffe_is_init_local_zero ())
8782 init
= error_mark_node
;
8786 ffecom_member_namelisted_
= FALSE
;
8787 ffestorag_drive (ffestorag_list_equivs (eqst
),
8788 &ffecom_member_phase1_
,
8791 high
= build_int_2 ((ffestorag_size (eqst
)
8792 + ffestorag_modulo (eqst
)) - 1, 0);
8793 TREE_TYPE (high
) = ffecom_integer_type_node
;
8795 eqtype
= build_array_type (char_type_node
,
8796 build_range_type (ffecom_integer_type_node
,
8797 ffecom_integer_zero_node
,
8800 eqt
= build_decl (VAR_DECL
,
8801 ffecom_get_invented_identifier ("__g77_equiv_%s",
8803 (ffestorag_symbol (eqst
))),
8805 DECL_EXTERNAL (eqt
) = 0;
8807 || ffecom_member_namelisted_
8808 #ifdef FFECOM_sizeMAXSTACKITEM
8809 || (ffestorag_size (eqst
) > FFECOM_sizeMAXSTACKITEM
)
8811 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8812 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
8813 && (ffestorag_is_save (eqst
) || ffe_is_saveall ())))
8814 TREE_STATIC (eqt
) = 1;
8816 TREE_STATIC (eqt
) = 0;
8817 TREE_PUBLIC (eqt
) = 0;
8818 TREE_ADDRESSABLE (eqt
) = 1; /* Ensure non-register allocation */
8819 DECL_CONTEXT (eqt
) = current_function_decl
;
8821 DECL_INITIAL (eqt
) = error_mark_node
;
8823 DECL_INITIAL (eqt
) = NULL_TREE
;
8825 eqt
= start_decl (eqt
, FALSE
);
8827 /* Make sure that any type can live in EQUIVALENCE and be referenced
8828 without getting a bus error. We could pick the most restrictive
8829 alignment of all entities actually placed in the EQUIVALENCE, but
8830 this seems easy enough. */
8832 DECL_ALIGN (eqt
) = BIGGEST_ALIGNMENT
;
8833 DECL_USER_ALIGN (eqt
) = 0;
8835 if ((!is_init
&& ffe_is_init_local_zero ())
8836 || (is_init
&& (ffestorag_init (eqst
) == NULL
)))
8837 init
= ffecom_init_zero_ (eqt
);
8839 finish_decl (eqt
, init
, FALSE
);
8842 ffestorag_set_init (eqst
, ffebld_new_any ());
8845 assert (TREE_CODE (DECL_SIZE_UNIT (eqt
)) == INTEGER_CST
);
8846 assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt
),
8847 (ffestorag_size (eqst
)
8848 + ffestorag_modulo (eqst
))));
8851 ffestorag_set_hook (eqst
, eqt
);
8853 ffestorag_drive (ffestorag_list_equivs (eqst
),
8854 &ffecom_member_phase2_
,
8859 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8861 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8863 ffecom_transform_namelist_ (ffesymbol s
)
8866 tree nmltype
= ffecom_type_namelist_ ();
8874 static int mynumber
= 0;
8876 nmlt
= build_decl (VAR_DECL
,
8877 ffecom_get_invented_identifier ("__g77_namelist_%d",
8880 TREE_STATIC (nmlt
) = 1;
8881 DECL_INITIAL (nmlt
) = error_mark_node
;
8883 nmlt
= start_decl (nmlt
, FALSE
);
8885 /* Process inits. */
8887 i
= strlen (ffesymbol_text (s
));
8889 high
= build_int_2 (i
, 0);
8890 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
8892 nameinit
= ffecom_build_f2c_string_ (i
+ 1,
8893 ffesymbol_text (s
));
8894 TREE_TYPE (nameinit
)
8895 = build_type_variant
8898 build_range_type (ffecom_f2c_ftnlen_type_node
,
8899 ffecom_f2c_ftnlen_one_node
,
8902 TREE_CONSTANT (nameinit
) = 1;
8903 TREE_STATIC (nameinit
) = 1;
8904 nameinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (nameinit
)),
8907 varsinit
= ffecom_vardesc_array_ (s
);
8908 varsinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (varsinit
)),
8910 TREE_CONSTANT (varsinit
) = 1;
8911 TREE_STATIC (varsinit
) = 1;
8916 for (i
= 0, b
= ffesymbol_namelist (s
); b
!= NULL
; b
= ffebld_trail (b
))
8919 nvarsinit
= build_int_2 (i
, 0);
8920 TREE_TYPE (nvarsinit
) = integer_type_node
;
8921 TREE_CONSTANT (nvarsinit
) = 1;
8922 TREE_STATIC (nvarsinit
) = 1;
8924 nmlinits
= build_tree_list ((field
= TYPE_FIELDS (nmltype
)), nameinit
);
8925 TREE_CHAIN (nmlinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
8927 TREE_CHAIN (TREE_CHAIN (nmlinits
))
8928 = build_tree_list ((field
= TREE_CHAIN (field
)), nvarsinit
);
8930 nmlinits
= build (CONSTRUCTOR
, nmltype
, NULL_TREE
, nmlinits
);
8931 TREE_CONSTANT (nmlinits
) = 1;
8932 TREE_STATIC (nmlinits
) = 1;
8934 finish_decl (nmlt
, nmlinits
, FALSE
);
8936 nmlt
= ffecom_1 (ADDR_EXPR
, build_pointer_type (nmltype
), nmlt
);
8943 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8944 analyzed on the assumption it is calculating a pointer to be
8945 indirected through. It must return the proper decl and offset,
8946 taking into account different units of measurements for offsets. */
8948 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8950 ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
8953 switch (TREE_CODE (t
))
8957 case NON_LVALUE_EXPR
:
8958 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
8962 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
8963 if ((*decl
== NULL_TREE
)
8964 || (*decl
== error_mark_node
))
8967 if (TREE_CODE (TREE_OPERAND (t
, 1)) == INTEGER_CST
)
8969 /* An offset into COMMON. */
8970 *offset
= fold (build (PLUS_EXPR
, TREE_TYPE (*offset
),
8971 *offset
, TREE_OPERAND (t
, 1)));
8972 /* Convert offset (presumably in bytes) into canonical units
8973 (presumably bits). */
8974 *offset
= size_binop (MULT_EXPR
,
8975 convert (bitsizetype
, *offset
),
8976 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t
))));
8979 /* Not a COMMON reference, so an unrecognized pattern. */
8980 *decl
= error_mark_node
;
8985 *offset
= bitsize_zero_node
;
8989 if (TREE_CODE (TREE_OPERAND (t
, 0)) == VAR_DECL
)
8991 /* A reference to COMMON. */
8992 *decl
= TREE_OPERAND (t
, 0);
8993 *offset
= bitsize_zero_node
;
8998 /* Not a COMMON reference, so an unrecognized pattern. */
8999 *decl
= error_mark_node
;
9005 /* Given a tree that is possibly intended for use as an lvalue, return
9006 information representing a canonical view of that tree as a decl, an
9007 offset into that decl, and a size for the lvalue.
9009 If there's no applicable decl, NULL_TREE is returned for the decl,
9010 and the other fields are left undefined.
9012 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9013 is returned for the decl, and the other fields are left undefined.
9015 Otherwise, the decl returned currently is either a VAR_DECL or a
9018 The offset returned is always valid, but of course not necessarily
9019 a constant, and not necessarily converted into the appropriate
9020 type, leaving that up to the caller (so as to avoid that overhead
9021 if the decls being looked at are different anyway).
9023 If the size cannot be determined (e.g. an adjustable array),
9024 an ERROR_MARK node is returned for the size. Otherwise, the
9025 size returned is valid, not necessarily a constant, and not
9026 necessarily converted into the appropriate type as with the
9029 Note that the offset and size expressions are expressed in the
9030 base storage units (usually bits) rather than in the units of
9031 the type of the decl, because two decls with different types
9032 might overlap but with apparently non-overlapping array offsets,
9033 whereas converting the array offsets to consistant offsets will
9034 reveal the overlap. */
9036 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9038 ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
9041 /* The default path is to report a nonexistant decl. */
9047 switch (TREE_CODE (t
))
9050 case IDENTIFIER_NODE
:
9059 case TRUNC_DIV_EXPR
:
9061 case FLOOR_DIV_EXPR
:
9062 case ROUND_DIV_EXPR
:
9063 case TRUNC_MOD_EXPR
:
9065 case FLOOR_MOD_EXPR
:
9066 case ROUND_MOD_EXPR
:
9068 case EXACT_DIV_EXPR
:
9069 case FIX_TRUNC_EXPR
:
9071 case FIX_FLOOR_EXPR
:
9072 case FIX_ROUND_EXPR
:
9086 case BIT_ANDTC_EXPR
:
9088 case TRUTH_ANDIF_EXPR
:
9089 case TRUTH_ORIF_EXPR
:
9090 case TRUTH_AND_EXPR
:
9092 case TRUTH_XOR_EXPR
:
9093 case TRUTH_NOT_EXPR
:
9113 *offset
= bitsize_zero_node
;
9114 *size
= TYPE_SIZE (TREE_TYPE (t
));
9119 tree array
= TREE_OPERAND (t
, 0);
9120 tree element
= TREE_OPERAND (t
, 1);
9123 if ((array
== NULL_TREE
)
9124 || (element
== NULL_TREE
))
9126 *decl
= error_mark_node
;
9130 ffecom_tree_canonize_ref_ (decl
, &init_offset
, size
,
9132 if ((*decl
== NULL_TREE
)
9133 || (*decl
== error_mark_node
))
9136 /* Calculate ((element - base) * NBBY) + init_offset. */
9137 *offset
= fold (build (MINUS_EXPR
, TREE_TYPE (element
),
9139 TYPE_MIN_VALUE (TYPE_DOMAIN
9140 (TREE_TYPE (array
)))));
9142 *offset
= size_binop (MULT_EXPR
,
9143 convert (bitsizetype
, *offset
),
9144 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array
))));
9146 *offset
= size_binop (PLUS_EXPR
, init_offset
, *offset
);
9148 *size
= TYPE_SIZE (TREE_TYPE (t
));
9154 /* Most of this code is to handle references to COMMON. And so
9155 far that is useful only for calling library functions, since
9156 external (user) functions might reference common areas. But
9157 even calling an external function, it's worthwhile to decode
9158 COMMON references because if not storing into COMMON, we don't
9159 want COMMON-based arguments to gratuitously force use of a
9162 *size
= TYPE_SIZE (TREE_TYPE (t
));
9164 ffecom_tree_canonize_ptr_ (decl
, offset
,
9165 TREE_OPERAND (t
, 0));
9172 case NON_LVALUE_EXPR
:
9175 case COND_EXPR
: /* More cases than we can handle. */
9177 case REFERENCE_EXPR
:
9178 case PREDECREMENT_EXPR
:
9179 case PREINCREMENT_EXPR
:
9180 case POSTDECREMENT_EXPR
:
9181 case POSTINCREMENT_EXPR
:
9184 *decl
= error_mark_node
;
9190 /* Do divide operation appropriate to type of operands. */
9192 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9194 ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
9195 tree dest_tree
, ffebld dest
, bool *dest_used
,
9198 if ((left
== error_mark_node
)
9199 || (right
== error_mark_node
))
9200 return error_mark_node
;
9202 switch (TREE_CODE (tree_type
))
9205 return ffecom_2 (TRUNC_DIV_EXPR
, tree_type
,
9210 if (! optimize_size
)
9211 return ffecom_2 (RDIV_EXPR
, tree_type
,
9217 if (TREE_TYPE (tree_type
)
9218 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9219 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9221 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9223 left
= ffecom_1 (ADDR_EXPR
,
9224 build_pointer_type (TREE_TYPE (left
)),
9226 left
= build_tree_list (NULL_TREE
, left
);
9227 right
= ffecom_1 (ADDR_EXPR
,
9228 build_pointer_type (TREE_TYPE (right
)),
9230 right
= build_tree_list (NULL_TREE
, right
);
9231 TREE_CHAIN (left
) = right
;
9233 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9234 ffecom_gfrt_kindtype (ix
),
9235 ffe_is_f2c_library (),
9238 dest_tree
, dest
, dest_used
,
9239 NULL_TREE
, TRUE
, hook
);
9247 if (TREE_TYPE (TYPE_FIELDS (tree_type
))
9248 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9249 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9251 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9253 left
= ffecom_1 (ADDR_EXPR
,
9254 build_pointer_type (TREE_TYPE (left
)),
9256 left
= build_tree_list (NULL_TREE
, left
);
9257 right
= ffecom_1 (ADDR_EXPR
,
9258 build_pointer_type (TREE_TYPE (right
)),
9260 right
= build_tree_list (NULL_TREE
, right
);
9261 TREE_CHAIN (left
) = right
;
9263 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9264 ffecom_gfrt_kindtype (ix
),
9265 ffe_is_f2c_library (),
9268 dest_tree
, dest
, dest_used
,
9269 NULL_TREE
, TRUE
, hook
);
9274 return ffecom_2 (RDIV_EXPR
, tree_type
,
9281 /* Build type info for non-dummy variable. */
9283 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9285 ffecom_type_localvar_ (ffesymbol s
, ffeinfoBasictype bt
,
9294 type
= ffecom_tree_type
[bt
][kt
];
9295 if (bt
== FFEINFO_basictypeCHARACTER
)
9297 hight
= build_int_2 (ffesymbol_size (s
), 0);
9298 TREE_TYPE (hight
) = ffecom_f2c_ftnlen_type_node
;
9303 build_range_type (ffecom_f2c_ftnlen_type_node
,
9304 ffecom_f2c_ftnlen_one_node
,
9306 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9309 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
9311 if (type
== error_mark_node
)
9314 dim
= ffebld_head (dl
);
9315 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
9317 if (ffebld_left (dim
) == NULL
)
9318 lowt
= integer_one_node
;
9320 lowt
= ffecom_expr (ffebld_left (dim
));
9322 if (TREE_CODE (lowt
) != INTEGER_CST
)
9323 lowt
= variable_size (lowt
);
9325 assert (ffebld_right (dim
) != NULL
);
9326 hight
= ffecom_expr (ffebld_right (dim
));
9328 if (TREE_CODE (hight
) != INTEGER_CST
)
9329 hight
= variable_size (hight
);
9331 type
= build_array_type (type
,
9332 build_range_type (ffecom_integer_type_node
,
9334 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9341 /* Build Namelist type. */
9343 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9345 ffecom_type_namelist_ ()
9347 static tree type
= NULL_TREE
;
9349 if (type
== NULL_TREE
)
9351 static tree namefield
, varsfield
, nvarsfield
;
9354 vardesctype
= ffecom_type_vardesc_ ();
9356 type
= make_node (RECORD_TYPE
);
9358 vardesctype
= build_pointer_type (build_pointer_type (vardesctype
));
9360 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9362 varsfield
= ffecom_decl_field (type
, namefield
, "vars", vardesctype
);
9363 nvarsfield
= ffecom_decl_field (type
, varsfield
, "nvars",
9366 TYPE_FIELDS (type
) = namefield
;
9369 ggc_add_tree_root (&type
, 1);
9377 /* Build Vardesc type. */
9379 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9381 ffecom_type_vardesc_ ()
9383 static tree type
= NULL_TREE
;
9384 static tree namefield
, addrfield
, dimsfield
, typefield
;
9386 if (type
== NULL_TREE
)
9388 type
= make_node (RECORD_TYPE
);
9390 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9392 addrfield
= ffecom_decl_field (type
, namefield
, "addr",
9394 dimsfield
= ffecom_decl_field (type
, addrfield
, "dims",
9395 ffecom_f2c_ptr_to_ftnlen_type_node
);
9396 typefield
= ffecom_decl_field (type
, dimsfield
, "type",
9399 TYPE_FIELDS (type
) = namefield
;
9402 ggc_add_tree_root (&type
, 1);
9410 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9412 ffecom_vardesc_ (ffebld expr
)
9416 assert (ffebld_op (expr
) == FFEBLD_opSYMTER
);
9417 s
= ffebld_symter (expr
);
9419 if (ffesymbol_hook (s
).vardesc_tree
== NULL_TREE
)
9422 tree vardesctype
= ffecom_type_vardesc_ ();
9430 static int mynumber
= 0;
9432 var
= build_decl (VAR_DECL
,
9433 ffecom_get_invented_identifier ("__g77_vardesc_%d",
9436 TREE_STATIC (var
) = 1;
9437 DECL_INITIAL (var
) = error_mark_node
;
9439 var
= start_decl (var
, FALSE
);
9441 /* Process inits. */
9443 nameinit
= ffecom_build_f2c_string_ ((i
= strlen (ffesymbol_text (s
)))
9445 ffesymbol_text (s
));
9446 TREE_TYPE (nameinit
)
9447 = build_type_variant
9450 build_range_type (integer_type_node
,
9452 build_int_2 (i
, 0))),
9454 TREE_CONSTANT (nameinit
) = 1;
9455 TREE_STATIC (nameinit
) = 1;
9456 nameinit
= ffecom_1 (ADDR_EXPR
,
9457 build_pointer_type (TREE_TYPE (nameinit
)),
9460 addrinit
= ffecom_arg_ptr_to_expr (expr
, &typeinit
);
9462 dimsinit
= ffecom_vardesc_dims_ (s
);
9464 if (typeinit
== NULL_TREE
)
9466 ffeinfoBasictype bt
= ffesymbol_basictype (s
);
9467 ffeinfoKindtype kt
= ffesymbol_kindtype (s
);
9468 int tc
= ffecom_f2c_typecode (bt
, kt
);
9471 typeinit
= build_int_2 (tc
, (tc
< 0) ? -1 : 0);
9474 typeinit
= ffecom_1 (NEGATE_EXPR
, TREE_TYPE (typeinit
), typeinit
);
9476 varinits
= build_tree_list ((field
= TYPE_FIELDS (vardesctype
)),
9478 TREE_CHAIN (varinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
9480 TREE_CHAIN (TREE_CHAIN (varinits
))
9481 = build_tree_list ((field
= TREE_CHAIN (field
)), dimsinit
);
9482 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits
)))
9483 = build_tree_list ((field
= TREE_CHAIN (field
)), typeinit
);
9485 varinits
= build (CONSTRUCTOR
, vardesctype
, NULL_TREE
, varinits
);
9486 TREE_CONSTANT (varinits
) = 1;
9487 TREE_STATIC (varinits
) = 1;
9489 finish_decl (var
, varinits
, FALSE
);
9491 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (vardesctype
), var
);
9493 ffesymbol_hook (s
).vardesc_tree
= var
;
9496 return ffesymbol_hook (s
).vardesc_tree
;
9500 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9502 ffecom_vardesc_array_ (ffesymbol s
)
9506 tree item
= NULL_TREE
;
9509 static int mynumber
= 0;
9511 for (i
= 0, list
= NULL_TREE
, b
= ffesymbol_namelist (s
);
9513 b
= ffebld_trail (b
), ++i
)
9517 t
= ffecom_vardesc_ (ffebld_head (b
));
9519 if (list
== NULL_TREE
)
9520 list
= item
= build_tree_list (NULL_TREE
, t
);
9523 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
9524 item
= TREE_CHAIN (item
);
9528 item
= build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9529 build_range_type (integer_type_node
,
9531 build_int_2 (i
, 0)));
9532 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
9533 TREE_CONSTANT (list
) = 1;
9534 TREE_STATIC (list
) = 1;
9536 var
= ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber
++);
9537 var
= build_decl (VAR_DECL
, var
, item
);
9538 TREE_STATIC (var
) = 1;
9539 DECL_INITIAL (var
) = error_mark_node
;
9540 var
= start_decl (var
, FALSE
);
9541 finish_decl (var
, list
, FALSE
);
9547 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9549 ffecom_vardesc_dims_ (ffesymbol s
)
9551 if (ffesymbol_dims (s
) == NULL
)
9552 return convert (ffecom_f2c_ptr_to_ftnlen_type_node
,
9560 tree item
= NULL_TREE
;
9564 tree baseoff
= NULL_TREE
;
9565 static int mynumber
= 0;
9567 numdim
= build_int_2 ((int) ffesymbol_rank (s
), 0);
9568 TREE_TYPE (numdim
) = ffecom_f2c_ftnlen_type_node
;
9570 numelem
= ffecom_expr (ffesymbol_arraysize (s
));
9571 TREE_TYPE (numelem
) = ffecom_f2c_ftnlen_type_node
;
9574 backlist
= NULL_TREE
;
9575 for (b
= ffesymbol_dims (s
), e
= ffesymbol_extents (s
);
9577 b
= ffebld_trail (b
), e
= ffebld_trail (e
))
9583 if (ffebld_trail (b
) == NULL
)
9587 t
= convert (ffecom_f2c_ftnlen_type_node
,
9588 ffecom_expr (ffebld_head (e
)));
9590 if (list
== NULL_TREE
)
9591 list
= item
= build_tree_list (NULL_TREE
, t
);
9594 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
9595 item
= TREE_CHAIN (item
);
9599 if (ffebld_left (ffebld_head (b
)) == NULL
)
9600 low
= ffecom_integer_one_node
;
9602 low
= ffecom_expr (ffebld_left (ffebld_head (b
)));
9603 low
= convert (ffecom_f2c_ftnlen_type_node
, low
);
9605 back
= build_tree_list (low
, t
);
9606 TREE_CHAIN (back
) = backlist
;
9610 for (item
= backlist
; item
!= NULL_TREE
; item
= TREE_CHAIN (item
))
9612 if (TREE_VALUE (item
) == NULL_TREE
)
9613 baseoff
= TREE_PURPOSE (item
);
9615 baseoff
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
9616 TREE_PURPOSE (item
),
9617 ffecom_2 (MULT_EXPR
,
9618 ffecom_f2c_ftnlen_type_node
,
9623 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9625 baseoff
= build_tree_list (NULL_TREE
, baseoff
);
9626 TREE_CHAIN (baseoff
) = list
;
9628 numelem
= build_tree_list (NULL_TREE
, numelem
);
9629 TREE_CHAIN (numelem
) = baseoff
;
9631 numdim
= build_tree_list (NULL_TREE
, numdim
);
9632 TREE_CHAIN (numdim
) = numelem
;
9634 item
= build_array_type (ffecom_f2c_ftnlen_type_node
,
9635 build_range_type (integer_type_node
,
9638 ((int) ffesymbol_rank (s
)
9640 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, numdim
);
9641 TREE_CONSTANT (list
) = 1;
9642 TREE_STATIC (list
) = 1;
9644 var
= ffecom_get_invented_identifier ("__g77_dims_%d", mynumber
++);
9645 var
= build_decl (VAR_DECL
, var
, item
);
9646 TREE_STATIC (var
) = 1;
9647 DECL_INITIAL (var
) = error_mark_node
;
9648 var
= start_decl (var
, FALSE
);
9649 finish_decl (var
, list
, FALSE
);
9651 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (item
), var
);
9658 /* Essentially does a "fold (build1 (code, type, node))" while checking
9659 for certain housekeeping things.
9661 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9662 ffecom_1_fn instead. */
9664 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9666 ffecom_1 (enum tree_code code
, tree type
, tree node
)
9670 if ((node
== error_mark_node
)
9671 || (type
== error_mark_node
))
9672 return error_mark_node
;
9674 if (code
== ADDR_EXPR
)
9676 if (!mark_addressable (node
))
9677 assert ("can't mark_addressable this node!" == NULL
);
9680 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
9685 item
= build (COMPONENT_REF
, type
, node
, TYPE_FIELDS (TREE_TYPE (node
)));
9689 item
= build (COMPONENT_REF
, type
, node
, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node
))));
9694 if (TREE_CODE (type
) != RECORD_TYPE
)
9696 item
= build1 (code
, type
, node
);
9699 node
= ffecom_stabilize_aggregate_ (node
);
9700 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9702 ffecom_2 (COMPLEX_EXPR
, type
,
9703 ffecom_1 (NEGATE_EXPR
, realtype
,
9704 ffecom_1 (REALPART_EXPR
, realtype
,
9706 ffecom_1 (NEGATE_EXPR
, realtype
,
9707 ffecom_1 (IMAGPART_EXPR
, realtype
,
9712 item
= build1 (code
, type
, node
);
9716 if (TREE_SIDE_EFFECTS (node
))
9717 TREE_SIDE_EFFECTS (item
) = 1;
9718 if ((code
== ADDR_EXPR
) && staticp (node
))
9719 TREE_CONSTANT (item
) = 1;
9724 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9725 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9726 does not set TREE_ADDRESSABLE (because calling an inline
9727 function does not mean the function needs to be separately
9730 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9732 ffecom_1_fn (tree node
)
9737 if (node
== error_mark_node
)
9738 return error_mark_node
;
9740 type
= build_type_variant (TREE_TYPE (node
),
9741 TREE_READONLY (node
),
9742 TREE_THIS_VOLATILE (node
));
9743 item
= build1 (ADDR_EXPR
,
9744 build_pointer_type (type
), node
);
9745 if (TREE_SIDE_EFFECTS (node
))
9746 TREE_SIDE_EFFECTS (item
) = 1;
9748 TREE_CONSTANT (item
) = 1;
9753 /* Essentially does a "fold (build (code, type, node1, node2))" while
9754 checking for certain housekeeping things. */
9756 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9758 ffecom_2 (enum tree_code code
, tree type
, tree node1
,
9763 if ((node1
== error_mark_node
)
9764 || (node2
== error_mark_node
)
9765 || (type
== error_mark_node
))
9766 return error_mark_node
;
9768 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
9770 tree a
, b
, c
, d
, realtype
;
9773 assert ("no CONJ_EXPR support yet" == NULL
);
9774 return error_mark_node
;
9777 item
= build_tree_list (TYPE_FIELDS (type
), node1
);
9778 TREE_CHAIN (item
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), node2
);
9779 item
= build (CONSTRUCTOR
, type
, NULL_TREE
, item
);
9783 if (TREE_CODE (type
) != RECORD_TYPE
)
9785 item
= build (code
, type
, node1
, node2
);
9788 node1
= ffecom_stabilize_aggregate_ (node1
);
9789 node2
= ffecom_stabilize_aggregate_ (node2
);
9790 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9792 ffecom_2 (COMPLEX_EXPR
, type
,
9793 ffecom_2 (PLUS_EXPR
, realtype
,
9794 ffecom_1 (REALPART_EXPR
, realtype
,
9796 ffecom_1 (REALPART_EXPR
, realtype
,
9798 ffecom_2 (PLUS_EXPR
, realtype
,
9799 ffecom_1 (IMAGPART_EXPR
, realtype
,
9801 ffecom_1 (IMAGPART_EXPR
, realtype
,
9806 if (TREE_CODE (type
) != RECORD_TYPE
)
9808 item
= build (code
, type
, node1
, node2
);
9811 node1
= ffecom_stabilize_aggregate_ (node1
);
9812 node2
= ffecom_stabilize_aggregate_ (node2
);
9813 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9815 ffecom_2 (COMPLEX_EXPR
, type
,
9816 ffecom_2 (MINUS_EXPR
, realtype
,
9817 ffecom_1 (REALPART_EXPR
, realtype
,
9819 ffecom_1 (REALPART_EXPR
, realtype
,
9821 ffecom_2 (MINUS_EXPR
, realtype
,
9822 ffecom_1 (IMAGPART_EXPR
, realtype
,
9824 ffecom_1 (IMAGPART_EXPR
, realtype
,
9829 if (TREE_CODE (type
) != RECORD_TYPE
)
9831 item
= build (code
, type
, node1
, node2
);
9834 node1
= ffecom_stabilize_aggregate_ (node1
);
9835 node2
= ffecom_stabilize_aggregate_ (node2
);
9836 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9837 a
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
9839 b
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
9841 c
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
9843 d
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
9846 ffecom_2 (COMPLEX_EXPR
, type
,
9847 ffecom_2 (MINUS_EXPR
, realtype
,
9848 ffecom_2 (MULT_EXPR
, realtype
,
9851 ffecom_2 (MULT_EXPR
, realtype
,
9854 ffecom_2 (PLUS_EXPR
, realtype
,
9855 ffecom_2 (MULT_EXPR
, realtype
,
9858 ffecom_2 (MULT_EXPR
, realtype
,
9864 if ((TREE_CODE (node1
) != RECORD_TYPE
)
9865 && (TREE_CODE (node2
) != RECORD_TYPE
))
9867 item
= build (code
, type
, node1
, node2
);
9870 assert (TREE_CODE (node1
) == RECORD_TYPE
);
9871 assert (TREE_CODE (node2
) == RECORD_TYPE
);
9872 node1
= ffecom_stabilize_aggregate_ (node1
);
9873 node2
= ffecom_stabilize_aggregate_ (node2
);
9874 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9876 ffecom_2 (TRUTH_ANDIF_EXPR
, type
,
9877 ffecom_2 (code
, type
,
9878 ffecom_1 (REALPART_EXPR
, realtype
,
9880 ffecom_1 (REALPART_EXPR
, realtype
,
9882 ffecom_2 (code
, type
,
9883 ffecom_1 (IMAGPART_EXPR
, realtype
,
9885 ffecom_1 (IMAGPART_EXPR
, realtype
,
9890 if ((TREE_CODE (node1
) != RECORD_TYPE
)
9891 && (TREE_CODE (node2
) != RECORD_TYPE
))
9893 item
= build (code
, type
, node1
, node2
);
9896 assert (TREE_CODE (node1
) == RECORD_TYPE
);
9897 assert (TREE_CODE (node2
) == RECORD_TYPE
);
9898 node1
= ffecom_stabilize_aggregate_ (node1
);
9899 node2
= ffecom_stabilize_aggregate_ (node2
);
9900 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9902 ffecom_2 (TRUTH_ORIF_EXPR
, type
,
9903 ffecom_2 (code
, type
,
9904 ffecom_1 (REALPART_EXPR
, realtype
,
9906 ffecom_1 (REALPART_EXPR
, realtype
,
9908 ffecom_2 (code
, type
,
9909 ffecom_1 (IMAGPART_EXPR
, realtype
,
9911 ffecom_1 (IMAGPART_EXPR
, realtype
,
9916 item
= build (code
, type
, node1
, node2
);
9920 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
))
9921 TREE_SIDE_EFFECTS (item
) = 1;
9926 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9928 ffesymbol s; // the ENTRY point itself
9929 if (ffecom_2pass_advise_entrypoint(s))
9930 // the ENTRY point has been accepted
9932 Does whatever compiler needs to do when it learns about the entrypoint,
9933 like determine the return type of the master function, count the
9934 number of entrypoints, etc. Returns FALSE if the return type is
9935 not compatible with the return type(s) of other entrypoint(s).
9937 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9938 later (after _finish_progunit) be called with the same entrypoint(s)
9939 as passed to this fn for which TRUE was returned.
9942 Return FALSE if the return type conflicts with previous entrypoints. */
9944 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9946 ffecom_2pass_advise_entrypoint (ffesymbol entry
)
9948 ffebld list
; /* opITEM. */
9949 ffebld mlist
; /* opITEM. */
9950 ffebld plist
; /* opITEM. */
9951 ffebld arg
; /* ffebld_head(opITEM). */
9952 ffebld item
; /* opITEM. */
9953 ffesymbol s
; /* ffebld_symter(arg). */
9954 ffeinfoBasictype bt
= ffesymbol_basictype (entry
);
9955 ffeinfoKindtype kt
= ffesymbol_kindtype (entry
);
9956 ffetargetCharacterSize size
= ffesymbol_size (entry
);
9959 if (ffecom_num_entrypoints_
== 0)
9960 { /* First entrypoint, make list of main
9961 arglist's dummies. */
9962 assert (ffecom_primary_entry_
!= NULL
);
9964 ffecom_master_bt_
= ffesymbol_basictype (ffecom_primary_entry_
);
9965 ffecom_master_kt_
= ffesymbol_kindtype (ffecom_primary_entry_
);
9966 ffecom_master_size_
= ffesymbol_size (ffecom_primary_entry_
);
9968 for (plist
= NULL
, list
= ffesymbol_dummyargs (ffecom_primary_entry_
);
9970 list
= ffebld_trail (list
))
9972 arg
= ffebld_head (list
);
9973 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
9974 continue; /* Alternate return or some such thing. */
9975 item
= ffebld_new_item (arg
, NULL
);
9977 ffecom_master_arglist_
= item
;
9979 ffebld_set_trail (plist
, item
);
9984 /* If necessary, scan entry arglist for alternate returns. Do this scan
9985 apparently redundantly (it's done below to UNIONize the arglists) so
9986 that we don't complain about RETURN 1 if an offending ENTRY is the only
9987 one with an alternate return. */
9989 if (!ffecom_is_altreturning_
)
9991 for (list
= ffesymbol_dummyargs (entry
);
9993 list
= ffebld_trail (list
))
9995 arg
= ffebld_head (list
);
9996 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
9998 ffecom_is_altreturning_
= TRUE
;
10004 /* Now check type compatibility. */
10006 switch (ffecom_master_bt_
)
10008 case FFEINFO_basictypeNONE
:
10009 ok
= (bt
!= FFEINFO_basictypeCHARACTER
);
10012 case FFEINFO_basictypeCHARACTER
:
10014 = (bt
== FFEINFO_basictypeCHARACTER
)
10015 && (kt
== ffecom_master_kt_
)
10016 && (size
== ffecom_master_size_
);
10019 case FFEINFO_basictypeANY
:
10020 return FALSE
; /* Just don't bother. */
10023 if (bt
== FFEINFO_basictypeCHARACTER
)
10029 if ((bt
!= ffecom_master_bt_
) || (kt
!= ffecom_master_kt_
))
10031 ffecom_master_bt_
= FFEINFO_basictypeNONE
;
10032 ffecom_master_kt_
= FFEINFO_kindtypeNONE
;
10039 ffebad_start (FFEBAD_ENTRY_CONFLICTS
);
10040 ffest_ffebad_here_current_stmt (0);
10042 return FALSE
; /* Can't handle entrypoint. */
10045 /* Entrypoint type compatible with previous types. */
10047 ++ffecom_num_entrypoints_
;
10049 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10051 for (list
= ffesymbol_dummyargs (entry
);
10053 list
= ffebld_trail (list
))
10055 arg
= ffebld_head (list
);
10056 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
10057 continue; /* Alternate return or some such thing. */
10058 s
= ffebld_symter (arg
);
10059 for (plist
= NULL
, mlist
= ffecom_master_arglist_
;
10061 plist
= mlist
, mlist
= ffebld_trail (mlist
))
10062 { /* plist points to previous item for easy
10063 appending of arg. */
10064 if (ffebld_symter (ffebld_head (mlist
)) == s
)
10065 break; /* Already have this arg in the master list. */
10068 continue; /* Already have this arg in the master list. */
10070 /* Append this arg to the master list. */
10072 item
= ffebld_new_item (arg
, NULL
);
10074 ffecom_master_arglist_
= item
;
10076 ffebld_set_trail (plist
, item
);
10083 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10085 ffesymbol s; // the ENTRY point itself
10086 ffecom_2pass_do_entrypoint(s);
10088 Does whatever compiler needs to do to make the entrypoint actually
10089 happen. Must be called for each entrypoint after
10090 ffecom_finish_progunit is called. */
10092 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10094 ffecom_2pass_do_entrypoint (ffesymbol entry
)
10096 static int mfn_num
= 0;
10097 static int ent_num
;
10099 if (mfn_num
!= ffecom_num_fns_
)
10100 { /* First entrypoint for this program unit. */
10102 mfn_num
= ffecom_num_fns_
;
10103 ffecom_do_entry_ (ffecom_primary_entry_
, 0);
10108 --ffecom_num_entrypoints_
;
10110 ffecom_do_entry_ (entry
, ent_num
);
10115 /* Essentially does a "fold (build (code, type, node1, node2))" while
10116 checking for certain housekeeping things. Always sets
10117 TREE_SIDE_EFFECTS. */
10119 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10121 ffecom_2s (enum tree_code code
, tree type
, tree node1
,
10126 if ((node1
== error_mark_node
)
10127 || (node2
== error_mark_node
)
10128 || (type
== error_mark_node
))
10129 return error_mark_node
;
10131 item
= build (code
, type
, node1
, node2
);
10132 TREE_SIDE_EFFECTS (item
) = 1;
10133 return fold (item
);
10137 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10138 checking for certain housekeeping things. */
10140 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10142 ffecom_3 (enum tree_code code
, tree type
, tree node1
,
10143 tree node2
, tree node3
)
10147 if ((node1
== error_mark_node
)
10148 || (node2
== error_mark_node
)
10149 || (node3
== error_mark_node
)
10150 || (type
== error_mark_node
))
10151 return error_mark_node
;
10153 item
= build (code
, type
, node1
, node2
, node3
);
10154 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
)
10155 || (node3
!= NULL_TREE
&& TREE_SIDE_EFFECTS (node3
)))
10156 TREE_SIDE_EFFECTS (item
) = 1;
10157 return fold (item
);
10161 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10162 checking for certain housekeeping things. Always sets
10163 TREE_SIDE_EFFECTS. */
10165 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10167 ffecom_3s (enum tree_code code
, tree type
, tree node1
,
10168 tree node2
, tree node3
)
10172 if ((node1
== error_mark_node
)
10173 || (node2
== error_mark_node
)
10174 || (node3
== error_mark_node
)
10175 || (type
== error_mark_node
))
10176 return error_mark_node
;
10178 item
= build (code
, type
, node1
, node2
, node3
);
10179 TREE_SIDE_EFFECTS (item
) = 1;
10180 return fold (item
);
10185 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10187 See use by ffecom_list_expr.
10189 If expression is NULL, returns an integer zero tree. If it is not
10190 a CHARACTER expression, returns whatever ffecom_expr
10191 returns and sets the length return value to NULL_TREE. Otherwise
10192 generates code to evaluate the character expression, returns the proper
10193 pointer to the result, but does NOT set the length return value to a tree
10194 that specifies the length of the result. (In other words, the length
10195 variable is always set to NULL_TREE, because a length is never passed.)
10198 Don't set returned length, since nobody needs it (yet; someday if
10199 we allow CHARACTER*(*) dummies to statement functions, we'll need
10202 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10204 ffecom_arg_expr (ffebld expr
, tree
*length
)
10208 *length
= NULL_TREE
;
10211 return integer_zero_node
;
10213 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10214 return ffecom_expr (expr
);
10216 return ffecom_arg_ptr_to_expr (expr
, &ign
);
10220 /* Transform expression into constant argument-pointer-to-expression tree.
10222 If the expression can be transformed into a argument-pointer-to-expression
10223 tree that is constant, that is done, and the tree returned. Else
10224 NULL_TREE is returned.
10226 That way, a caller can attempt to provide compile-time initialization
10227 of a variable and, if that fails, *then* choose to start a new block
10228 and resort to using temporaries, as appropriate. */
10231 ffecom_arg_ptr_to_const_expr (ffebld expr
, tree
*length
)
10234 return integer_zero_node
;
10236 if (ffebld_op (expr
) == FFEBLD_opANY
)
10239 *length
= error_mark_node
;
10240 return error_mark_node
;
10243 if (ffebld_arity (expr
) == 0
10244 && (ffebld_op (expr
) != FFEBLD_opSYMTER
10245 || ffebld_where (expr
) == FFEINFO_whereCOMMON
10246 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
10247 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
10251 t
= ffecom_arg_ptr_to_expr (expr
, length
);
10252 assert (TREE_CONSTANT (t
));
10253 assert (! length
|| TREE_CONSTANT (*length
));
10258 && ffebld_size (expr
) != FFETARGET_charactersizeNONE
)
10259 *length
= build_int_2 (ffebld_size (expr
), 0);
10261 *length
= NULL_TREE
;
10265 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10267 See use by ffecom_list_ptr_to_expr.
10269 If expression is NULL, returns an integer zero tree. If it is not
10270 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10271 returns and sets the length return value to NULL_TREE. Otherwise
10272 generates code to evaluate the character expression, returns the proper
10273 pointer to the result, AND sets the length return value to a tree that
10274 specifies the length of the result.
10276 If the length argument is NULL, this is a slightly special
10277 case of building a FORMAT expression, that is, an expression that
10278 will be used at run time without regard to length. For the current
10279 implementation, which uses the libf2c library, this means it is nice
10280 to append a null byte to the end of the expression, where feasible,
10281 to make sure any diagnostic about the FORMAT string terminates at
10284 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10285 length argument. This might even be seen as a feature, if a null
10286 byte can always be appended. */
10288 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10290 ffecom_arg_ptr_to_expr (ffebld expr
, tree
*length
)
10294 ffecomConcatList_ catlist
;
10296 if (length
!= NULL
)
10297 *length
= NULL_TREE
;
10300 return integer_zero_node
;
10302 switch (ffebld_op (expr
))
10304 case FFEBLD_opPERCENT_VAL
:
10305 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10306 return ffecom_expr (ffebld_left (expr
));
10311 temp_exp
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &temp_length
);
10312 if (temp_exp
== error_mark_node
)
10313 return error_mark_node
;
10315 return ffecom_1 (INDIRECT_REF
, TREE_TYPE (TREE_TYPE (temp_exp
)),
10319 case FFEBLD_opPERCENT_REF
:
10320 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10321 return ffecom_ptr_to_expr (ffebld_left (expr
));
10322 if (length
!= NULL
)
10324 ign_length
= NULL_TREE
;
10325 length
= &ign_length
;
10327 expr
= ffebld_left (expr
);
10330 case FFEBLD_opPERCENT_DESCR
:
10331 switch (ffeinfo_basictype (ffebld_info (expr
)))
10333 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10334 case FFEINFO_basictypeHOLLERITH
:
10336 case FFEINFO_basictypeCHARACTER
:
10337 break; /* Passed by descriptor anyway. */
10340 item
= ffecom_ptr_to_expr (expr
);
10341 if (item
!= error_mark_node
)
10342 *length
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (item
)));
10351 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10352 if ((ffeinfo_basictype (ffebld_info (expr
)) == FFEINFO_basictypeHOLLERITH
)
10353 && (length
!= NULL
))
10354 { /* Pass Hollerith by descriptor. */
10355 ffetargetHollerith h
;
10357 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
10358 h
= ffebld_cu_val_hollerith (ffebld_constant_union
10359 (ffebld_conter (expr
)));
10361 = build_int_2 (h
.length
, 0);
10362 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10366 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10367 return ffecom_ptr_to_expr (expr
);
10369 assert (ffeinfo_kindtype (ffebld_info (expr
))
10370 == FFEINFO_kindtypeCHARACTER1
);
10372 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
10373 expr
= ffebld_left (expr
);
10375 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
10376 switch (ffecom_concat_list_count_ (catlist
))
10378 case 0: /* Shouldn't happen, but in case it does... */
10379 if (length
!= NULL
)
10381 *length
= ffecom_f2c_ftnlen_zero_node
;
10382 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10384 ffecom_concat_list_kill_ (catlist
);
10385 return null_pointer_node
;
10387 case 1: /* The (fairly) easy case. */
10388 if (length
== NULL
)
10389 ffecom_char_args_with_null_ (&item
, &ign_length
,
10390 ffecom_concat_list_expr_ (catlist
, 0));
10392 ffecom_char_args_ (&item
, length
,
10393 ffecom_concat_list_expr_ (catlist
, 0));
10394 ffecom_concat_list_kill_ (catlist
);
10395 assert (item
!= NULL_TREE
);
10398 default: /* Must actually concatenate things. */
10403 int count
= ffecom_concat_list_count_ (catlist
);
10414 ffetargetCharacterSize sz
;
10416 sz
= ffecom_concat_list_maxlen_ (catlist
);
10418 assert (sz
!= FFETARGET_charactersizeNONE
);
10423 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
10424 FFETARGET_charactersizeNONE
, count
, TRUE
);
10427 = ffecom_push_tempvar (ffecom_f2c_address_type_node
,
10428 FFETARGET_charactersizeNONE
, count
, TRUE
);
10429 temporary
= ffecom_push_tempvar (char_type_node
,
10435 hook
= ffebld_nonter_hook (expr
);
10437 assert (TREE_CODE (hook
) == TREE_VEC
);
10438 assert (TREE_VEC_LENGTH (hook
) == 3);
10439 length_array
= lengths
= TREE_VEC_ELT (hook
, 0);
10440 item_array
= items
= TREE_VEC_ELT (hook
, 1);
10441 temporary
= TREE_VEC_ELT (hook
, 2);
10445 known_length
= ffecom_f2c_ftnlen_zero_node
;
10447 for (i
= 0; i
< count
; ++i
)
10450 && (length
== NULL
))
10451 ffecom_char_args_with_null_ (&citem
, &clength
,
10452 ffecom_concat_list_expr_ (catlist
, i
));
10454 ffecom_char_args_ (&citem
, &clength
,
10455 ffecom_concat_list_expr_ (catlist
, i
));
10456 if ((citem
== error_mark_node
)
10457 || (clength
== error_mark_node
))
10459 ffecom_concat_list_kill_ (catlist
);
10460 *length
= error_mark_node
;
10461 return error_mark_node
;
10465 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
10466 ffecom_modify (void_type_node
,
10467 ffecom_2 (ARRAY_REF
,
10468 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
10470 build_int_2 (i
, 0)),
10473 clength
= ffecom_save_tree (clength
);
10474 if (length
!= NULL
)
10476 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
10480 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
10481 ffecom_modify (void_type_node
,
10482 ffecom_2 (ARRAY_REF
,
10483 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
10485 build_int_2 (i
, 0)),
10490 temporary
= ffecom_1 (ADDR_EXPR
,
10491 build_pointer_type (TREE_TYPE (temporary
)),
10494 item
= build_tree_list (NULL_TREE
, temporary
);
10496 = build_tree_list (NULL_TREE
,
10497 ffecom_1 (ADDR_EXPR
,
10498 build_pointer_type (TREE_TYPE (items
)),
10500 TREE_CHAIN (TREE_CHAIN (item
))
10501 = build_tree_list (NULL_TREE
,
10502 ffecom_1 (ADDR_EXPR
,
10503 build_pointer_type (TREE_TYPE (lengths
)),
10505 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
10508 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
10509 convert (ffecom_f2c_ftnlen_type_node
,
10510 build_int_2 (count
, 0))));
10511 num
= build_int_2 (sz
, 0);
10512 TREE_TYPE (num
) = ffecom_f2c_ftnlen_type_node
;
10513 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
))))
10514 = build_tree_list (NULL_TREE
, num
);
10516 item
= ffecom_call_gfrt (FFECOM_gfrtCAT
, item
, NULL_TREE
);
10517 TREE_SIDE_EFFECTS (item
) = 1;
10518 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (temporary
),
10522 if (length
!= NULL
)
10523 *length
= known_length
;
10526 ffecom_concat_list_kill_ (catlist
);
10527 assert (item
!= NULL_TREE
);
10532 /* Generate call to run-time function.
10534 The first arg is the GNU Fortran Run-Time function index, the second
10535 arg is the list of arguments to pass to it. Returned is the expression
10536 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10537 result (which may be void). */
10539 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10541 ffecom_call_gfrt (ffecomGfrt ix
, tree args
, tree hook
)
10543 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
10544 ffecom_gfrt_kindtype (ix
),
10545 ffe_is_f2c_library () && ffecom_gfrt_complex_
[ix
],
10546 NULL_TREE
, args
, NULL_TREE
, NULL
,
10547 NULL
, NULL_TREE
, TRUE
, hook
);
10551 /* Transform constant-union to tree. */
10553 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10555 ffecom_constantunion (ffebldConstantUnion
*cu
, ffeinfoBasictype bt
,
10556 ffeinfoKindtype kt
, tree tree_type
)
10562 case FFEINFO_basictypeINTEGER
:
10568 #if FFETARGET_okINTEGER1
10569 case FFEINFO_kindtypeINTEGER1
:
10570 val
= ffebld_cu_val_integer1 (*cu
);
10574 #if FFETARGET_okINTEGER2
10575 case FFEINFO_kindtypeINTEGER2
:
10576 val
= ffebld_cu_val_integer2 (*cu
);
10580 #if FFETARGET_okINTEGER3
10581 case FFEINFO_kindtypeINTEGER3
:
10582 val
= ffebld_cu_val_integer3 (*cu
);
10586 #if FFETARGET_okINTEGER4
10587 case FFEINFO_kindtypeINTEGER4
:
10588 val
= ffebld_cu_val_integer4 (*cu
);
10593 assert ("bad INTEGER constant kind type" == NULL
);
10594 /* Fall through. */
10595 case FFEINFO_kindtypeANY
:
10596 return error_mark_node
;
10598 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
10599 TREE_TYPE (item
) = tree_type
;
10603 case FFEINFO_basictypeLOGICAL
:
10609 #if FFETARGET_okLOGICAL1
10610 case FFEINFO_kindtypeLOGICAL1
:
10611 val
= ffebld_cu_val_logical1 (*cu
);
10615 #if FFETARGET_okLOGICAL2
10616 case FFEINFO_kindtypeLOGICAL2
:
10617 val
= ffebld_cu_val_logical2 (*cu
);
10621 #if FFETARGET_okLOGICAL3
10622 case FFEINFO_kindtypeLOGICAL3
:
10623 val
= ffebld_cu_val_logical3 (*cu
);
10627 #if FFETARGET_okLOGICAL4
10628 case FFEINFO_kindtypeLOGICAL4
:
10629 val
= ffebld_cu_val_logical4 (*cu
);
10634 assert ("bad LOGICAL constant kind type" == NULL
);
10635 /* Fall through. */
10636 case FFEINFO_kindtypeANY
:
10637 return error_mark_node
;
10639 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
10640 TREE_TYPE (item
) = tree_type
;
10644 case FFEINFO_basictypeREAL
:
10646 REAL_VALUE_TYPE val
;
10650 #if FFETARGET_okREAL1
10651 case FFEINFO_kindtypeREAL1
:
10652 val
= ffetarget_value_real1 (ffebld_cu_val_real1 (*cu
));
10656 #if FFETARGET_okREAL2
10657 case FFEINFO_kindtypeREAL2
:
10658 val
= ffetarget_value_real2 (ffebld_cu_val_real2 (*cu
));
10662 #if FFETARGET_okREAL3
10663 case FFEINFO_kindtypeREAL3
:
10664 val
= ffetarget_value_real3 (ffebld_cu_val_real3 (*cu
));
10668 #if FFETARGET_okREAL4
10669 case FFEINFO_kindtypeREAL4
:
10670 val
= ffetarget_value_real4 (ffebld_cu_val_real4 (*cu
));
10675 assert ("bad REAL constant kind type" == NULL
);
10676 /* Fall through. */
10677 case FFEINFO_kindtypeANY
:
10678 return error_mark_node
;
10680 item
= build_real (tree_type
, val
);
10684 case FFEINFO_basictypeCOMPLEX
:
10686 REAL_VALUE_TYPE real
;
10687 REAL_VALUE_TYPE imag
;
10688 tree el_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
10692 #if FFETARGET_okCOMPLEX1
10693 case FFEINFO_kindtypeREAL1
:
10694 real
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).real
);
10695 imag
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).imaginary
);
10699 #if FFETARGET_okCOMPLEX2
10700 case FFEINFO_kindtypeREAL2
:
10701 real
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).real
);
10702 imag
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).imaginary
);
10706 #if FFETARGET_okCOMPLEX3
10707 case FFEINFO_kindtypeREAL3
:
10708 real
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).real
);
10709 imag
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).imaginary
);
10713 #if FFETARGET_okCOMPLEX4
10714 case FFEINFO_kindtypeREAL4
:
10715 real
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).real
);
10716 imag
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).imaginary
);
10721 assert ("bad REAL constant kind type" == NULL
);
10722 /* Fall through. */
10723 case FFEINFO_kindtypeANY
:
10724 return error_mark_node
;
10726 item
= ffecom_build_complex_constant_ (tree_type
,
10727 build_real (el_type
, real
),
10728 build_real (el_type
, imag
));
10732 case FFEINFO_basictypeCHARACTER
:
10733 { /* Happens only in DATA and similar contexts. */
10734 ffetargetCharacter1 val
;
10738 #if FFETARGET_okCHARACTER1
10739 case FFEINFO_kindtypeLOGICAL1
:
10740 val
= ffebld_cu_val_character1 (*cu
);
10745 assert ("bad CHARACTER constant kind type" == NULL
);
10746 /* Fall through. */
10747 case FFEINFO_kindtypeANY
:
10748 return error_mark_node
;
10750 item
= build_string (ffetarget_length_character1 (val
),
10751 ffetarget_text_character1 (val
));
10753 = build_type_variant (build_array_type (char_type_node
,
10755 (integer_type_node
,
10758 (ffetarget_length_character1
10764 case FFEINFO_basictypeHOLLERITH
:
10766 ffetargetHollerith h
;
10768 h
= ffebld_cu_val_hollerith (*cu
);
10770 /* If not at least as wide as default INTEGER, widen it. */
10771 if (h
.length
>= FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
)
10772 item
= build_string (h
.length
, h
.text
);
10775 char str
[FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
];
10777 memcpy (str
, h
.text
, h
.length
);
10778 memset (&str
[h
.length
], ' ',
10779 FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
10781 item
= build_string (FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
,
10785 = build_type_variant (build_array_type (char_type_node
,
10787 (integer_type_node
,
10795 case FFEINFO_basictypeTYPELESS
:
10797 ffetargetInteger1 ival
;
10798 ffetargetTypeless tless
;
10801 tless
= ffebld_cu_val_typeless (*cu
);
10802 error
= ffetarget_convert_integer1_typeless (&ival
, tless
);
10803 assert (error
== FFEBAD
);
10805 item
= build_int_2 ((int) ival
, 0);
10810 assert ("not yet on constant type" == NULL
);
10811 /* Fall through. */
10812 case FFEINFO_basictypeANY
:
10813 return error_mark_node
;
10816 TREE_CONSTANT (item
) = 1;
10823 /* Transform expression into constant tree.
10825 If the expression can be transformed into a tree that is constant,
10826 that is done, and the tree returned. Else NULL_TREE is returned.
10828 That way, a caller can attempt to provide compile-time initialization
10829 of a variable and, if that fails, *then* choose to start a new block
10830 and resort to using temporaries, as appropriate. */
10833 ffecom_const_expr (ffebld expr
)
10836 return integer_zero_node
;
10838 if (ffebld_op (expr
) == FFEBLD_opANY
)
10839 return error_mark_node
;
10841 if (ffebld_arity (expr
) == 0
10842 && (ffebld_op (expr
) != FFEBLD_opSYMTER
10844 /* ~~Enable once common/equivalence is handled properly? */
10845 || ffebld_where (expr
) == FFEINFO_whereCOMMON
10847 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
10848 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
10852 t
= ffecom_expr (expr
);
10853 assert (TREE_CONSTANT (t
));
10860 /* Handy way to make a field in a struct/union. */
10862 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10864 ffecom_decl_field (tree context
, tree prevfield
,
10865 const char *name
, tree type
)
10869 field
= build_decl (FIELD_DECL
, get_identifier (name
), type
);
10870 DECL_CONTEXT (field
) = context
;
10871 DECL_ALIGN (field
) = 0;
10872 DECL_USER_ALIGN (field
) = 0;
10873 if (prevfield
!= NULL_TREE
)
10874 TREE_CHAIN (prevfield
) = field
;
10882 ffecom_close_include (FILE *f
)
10884 #if FFECOM_GCC_INCLUDE
10885 ffecom_close_include_ (f
);
10890 ffecom_decode_include_option (char *spec
)
10892 #if FFECOM_GCC_INCLUDE
10893 return ffecom_decode_include_option_ (spec
);
10899 /* End a compound statement (block). */
10901 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10903 ffecom_end_compstmt (void)
10905 return bison_rule_compstmt_ ();
10907 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
10909 /* ffecom_end_transition -- Perform end transition on all symbols
10911 ffecom_end_transition();
10913 Calls ffecom_sym_end_transition for each global and local symbol. */
10916 ffecom_end_transition ()
10918 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10922 if (ffe_is_ffedebug ())
10923 fprintf (dmpout
, "; end_stmt_transition\n");
10925 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10926 ffecom_list_blockdata_
= NULL
;
10927 ffecom_list_common_
= NULL
;
10930 ffesymbol_drive (ffecom_sym_end_transition
);
10931 if (ffe_is_ffedebug ())
10933 ffestorag_report ();
10934 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10935 ffesymbol_report_all ();
10939 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10940 ffecom_start_progunit_ ();
10942 for (item
= ffecom_list_blockdata_
;
10944 item
= ffebld_trail (item
))
10951 static int number
= 0;
10953 callee
= ffebld_head (item
);
10954 s
= ffebld_symter (callee
);
10955 t
= ffesymbol_hook (s
).decl_tree
;
10956 if (t
== NULL_TREE
)
10958 s
= ffecom_sym_transform_ (s
);
10959 t
= ffesymbol_hook (s
).decl_tree
;
10962 dt
= build_pointer_type (TREE_TYPE (t
));
10964 var
= build_decl (VAR_DECL
,
10965 ffecom_get_invented_identifier ("__g77_forceload_%d",
10968 DECL_EXTERNAL (var
) = 0;
10969 TREE_STATIC (var
) = 1;
10970 TREE_PUBLIC (var
) = 0;
10971 DECL_INITIAL (var
) = error_mark_node
;
10972 TREE_USED (var
) = 1;
10974 var
= start_decl (var
, FALSE
);
10976 t
= ffecom_1 (ADDR_EXPR
, dt
, t
);
10978 finish_decl (var
, t
, FALSE
);
10981 /* This handles any COMMON areas that weren't referenced but have, for
10982 example, important initial data. */
10984 for (item
= ffecom_list_common_
;
10986 item
= ffebld_trail (item
))
10987 ffecom_transform_common_ (ffebld_symter (ffebld_head (item
)));
10989 ffecom_list_common_
= NULL
;
10993 /* ffecom_exec_transition -- Perform exec transition on all symbols
10995 ffecom_exec_transition();
10997 Calls ffecom_sym_exec_transition for each global and local symbol.
10998 Make sure error updating not inhibited. */
11001 ffecom_exec_transition ()
11005 if (ffe_is_ffedebug ())
11006 fprintf (dmpout
, "; exec_stmt_transition\n");
11008 inhibited
= ffebad_inhibit ();
11009 ffebad_set_inhibit (FALSE
);
11011 ffesymbol_drive (ffecom_sym_exec_transition
); /* Don't retract! */
11012 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
11013 if (ffe_is_ffedebug ())
11015 ffestorag_report ();
11016 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11017 ffesymbol_report_all ();
11022 ffebad_set_inhibit (TRUE
);
11025 /* Handle assignment statement.
11027 Convert dest and source using ffecom_expr, then join them
11028 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
11030 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11032 ffecom_expand_let_stmt (ffebld dest
, ffebld source
)
11039 if (ffeinfo_basictype (ffebld_info (dest
)) != FFEINFO_basictypeCHARACTER
)
11044 /* This attempts to replicate the test below, but must not be
11045 true when the test below is false. (Always err on the side
11046 of creating unused temporaries, to avoid ICEs.) */
11047 if (ffebld_op (dest
) != FFEBLD_opSYMTER
11048 || ((dest_tree
= ffesymbol_hook (ffebld_symter (dest
)).decl_tree
)
11049 && (TREE_CODE (dest_tree
) != VAR_DECL
11050 || TREE_ADDRESSABLE (dest_tree
))))
11052 ffecom_prepare_expr_ (source
, dest
);
11057 ffecom_prepare_expr_ (source
, NULL
);
11061 ffecom_prepare_expr_w (NULL_TREE
, dest
);
11063 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11064 create a temporary through which the assignment is to take place,
11065 since MODIFY_EXPR doesn't handle partial overlap properly. */
11066 if (ffebld_basictype (dest
) == FFEINFO_basictypeCOMPLEX
11067 && ffecom_possible_partial_overlap_ (dest
, source
))
11069 assign_temp
= ffecom_make_tempvar ("complex_let",
11071 [ffebld_basictype (dest
)]
11072 [ffebld_kindtype (dest
)],
11073 FFETARGET_charactersizeNONE
,
11077 assign_temp
= NULL_TREE
;
11079 ffecom_prepare_end ();
11081 dest_tree
= ffecom_expr_w (NULL_TREE
, dest
);
11082 if (dest_tree
== error_mark_node
)
11085 if ((TREE_CODE (dest_tree
) != VAR_DECL
)
11086 || TREE_ADDRESSABLE (dest_tree
))
11087 source_tree
= ffecom_expr_ (source
, dest_tree
, dest
, &dest_used
,
11091 assert (! dest_used
);
11093 source_tree
= ffecom_expr (source
);
11095 if (source_tree
== error_mark_node
)
11099 expr_tree
= source_tree
;
11100 else if (assign_temp
)
11103 /* The back end understands a conceptual move (evaluate source;
11104 store into dest), so use that, in case it can determine
11105 that it is going to use, say, two registers as temporaries
11106 anyway. So don't use the temp (and someday avoid generating
11107 it, once this code starts triggering regularly). */
11108 expr_tree
= ffecom_2s (MOVE_EXPR
, void_type_node
,
11112 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
11115 expand_expr_stmt (expr_tree
);
11116 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
11122 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
11126 expand_expr_stmt (expr_tree
);
11130 ffecom_prepare_let_char_ (ffebld_size_known (dest
), source
);
11131 ffecom_prepare_expr_w (NULL_TREE
, dest
);
11133 ffecom_prepare_end ();
11135 ffecom_char_args_ (&dest_tree
, &dest_length
, dest
);
11136 ffecom_let_char_ (dest_tree
, dest_length
, ffebld_size_known (dest
),
11141 /* ffecom_expr -- Transform expr into gcc tree
11144 ffebld expr; // FFE expression.
11145 tree = ffecom_expr(expr);
11147 Recursive descent on expr while making corresponding tree nodes and
11148 attaching type info and such. */
11150 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11152 ffecom_expr (ffebld expr
)
11154 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, FALSE
, FALSE
);
11158 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
11160 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11162 ffecom_expr_assign (ffebld expr
)
11164 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
11168 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
11170 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11172 ffecom_expr_assign_w (ffebld expr
)
11174 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
11178 /* Transform expr for use as into read/write tree and stabilize the
11179 reference. Not for use on CHARACTER expressions.
11181 Recursive descent on expr while making corresponding tree nodes and
11182 attaching type info and such. */
11184 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11186 ffecom_expr_rw (tree type
, ffebld expr
)
11188 assert (expr
!= NULL
);
11189 /* Different target types not yet supported. */
11190 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
11192 return stabilize_reference (ffecom_expr (expr
));
11196 /* Transform expr for use as into write tree and stabilize the
11197 reference. Not for use on CHARACTER expressions.
11199 Recursive descent on expr while making corresponding tree nodes and
11200 attaching type info and such. */
11202 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11204 ffecom_expr_w (tree type
, ffebld expr
)
11206 assert (expr
!= NULL
);
11207 /* Different target types not yet supported. */
11208 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
11210 return stabilize_reference (ffecom_expr (expr
));
11214 /* Do global stuff. */
11216 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11218 ffecom_finish_compile ()
11220 assert (ffecom_outer_function_decl_
== NULL_TREE
);
11221 assert (current_function_decl
== NULL_TREE
);
11223 ffeglobal_drive (ffecom_finish_global_
);
11227 /* Public entry point for front end to access finish_decl. */
11229 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11231 ffecom_finish_decl (tree decl
, tree init
, bool is_top_level
)
11233 assert (!is_top_level
);
11234 finish_decl (decl
, init
, FALSE
);
11238 /* Finish a program unit. */
11240 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11242 ffecom_finish_progunit ()
11244 ffecom_end_compstmt ();
11246 ffecom_previous_function_decl_
= current_function_decl
;
11247 ffecom_which_entrypoint_decl_
= NULL_TREE
;
11249 finish_function (0);
11254 /* Wrapper for get_identifier. pattern is sprintf-like. */
11256 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11258 ffecom_get_invented_identifier (const char *pattern
, ...)
11264 va_start (ap
, pattern
);
11265 if (vasprintf (&nam
, pattern
, ap
) == 0)
11268 decl
= get_identifier (nam
);
11270 IDENTIFIER_INVENTED (decl
) = 1;
11275 ffecom_gfrt_basictype (ffecomGfrt gfrt
)
11277 assert (gfrt
< FFECOM_gfrt
);
11279 switch (ffecom_gfrt_type_
[gfrt
])
11281 case FFECOM_rttypeVOID_
:
11282 case FFECOM_rttypeVOIDSTAR_
:
11283 return FFEINFO_basictypeNONE
;
11285 case FFECOM_rttypeFTNINT_
:
11286 return FFEINFO_basictypeINTEGER
;
11288 case FFECOM_rttypeINTEGER_
:
11289 return FFEINFO_basictypeINTEGER
;
11291 case FFECOM_rttypeLONGINT_
:
11292 return FFEINFO_basictypeINTEGER
;
11294 case FFECOM_rttypeLOGICAL_
:
11295 return FFEINFO_basictypeLOGICAL
;
11297 case FFECOM_rttypeREAL_F2C_
:
11298 case FFECOM_rttypeREAL_GNU_
:
11299 return FFEINFO_basictypeREAL
;
11301 case FFECOM_rttypeCOMPLEX_F2C_
:
11302 case FFECOM_rttypeCOMPLEX_GNU_
:
11303 return FFEINFO_basictypeCOMPLEX
;
11305 case FFECOM_rttypeDOUBLE_
:
11306 case FFECOM_rttypeDOUBLEREAL_
:
11307 return FFEINFO_basictypeREAL
;
11309 case FFECOM_rttypeDBLCMPLX_F2C_
:
11310 case FFECOM_rttypeDBLCMPLX_GNU_
:
11311 return FFEINFO_basictypeCOMPLEX
;
11313 case FFECOM_rttypeCHARACTER_
:
11314 return FFEINFO_basictypeCHARACTER
;
11317 return FFEINFO_basictypeANY
;
11322 ffecom_gfrt_kindtype (ffecomGfrt gfrt
)
11324 assert (gfrt
< FFECOM_gfrt
);
11326 switch (ffecom_gfrt_type_
[gfrt
])
11328 case FFECOM_rttypeVOID_
:
11329 case FFECOM_rttypeVOIDSTAR_
:
11330 return FFEINFO_kindtypeNONE
;
11332 case FFECOM_rttypeFTNINT_
:
11333 return FFEINFO_kindtypeINTEGER1
;
11335 case FFECOM_rttypeINTEGER_
:
11336 return FFEINFO_kindtypeINTEGER1
;
11338 case FFECOM_rttypeLONGINT_
:
11339 return FFEINFO_kindtypeINTEGER4
;
11341 case FFECOM_rttypeLOGICAL_
:
11342 return FFEINFO_kindtypeLOGICAL1
;
11344 case FFECOM_rttypeREAL_F2C_
:
11345 case FFECOM_rttypeREAL_GNU_
:
11346 return FFEINFO_kindtypeREAL1
;
11348 case FFECOM_rttypeCOMPLEX_F2C_
:
11349 case FFECOM_rttypeCOMPLEX_GNU_
:
11350 return FFEINFO_kindtypeREAL1
;
11352 case FFECOM_rttypeDOUBLE_
:
11353 case FFECOM_rttypeDOUBLEREAL_
:
11354 return FFEINFO_kindtypeREAL2
;
11356 case FFECOM_rttypeDBLCMPLX_F2C_
:
11357 case FFECOM_rttypeDBLCMPLX_GNU_
:
11358 return FFEINFO_kindtypeREAL2
;
11360 case FFECOM_rttypeCHARACTER_
:
11361 return FFEINFO_kindtypeCHARACTER1
;
11364 return FFEINFO_kindtypeANY
;
11378 tree double_ftype_double
;
11379 tree float_ftype_float
;
11380 tree ldouble_ftype_ldouble
;
11381 tree ffecom_tree_ptr_to_fun_type_void
;
11383 /* This block of code comes from the now-obsolete cktyps.c. It checks
11384 whether the compiler environment is buggy in known ways, some of which
11385 would, if not explicitly checked here, result in subtle bugs in g77. */
11387 if (ffe_is_do_internal_checks ())
11389 static const char names
[][12]
11391 {"bar", "bletch", "foo", "foobar"};
11396 name
= bsearch ("foo", &names
[0], ARRAY_SIZE (names
), sizeof (names
[0]),
11397 (int (*)(const void *, const void *)) strcmp
);
11398 if (name
!= &names
[0][2])
11400 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11405 ul
= strtoul ("123456789", NULL
, 10);
11406 if (ul
!= 123456789L)
11408 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11409 in proj.h" == NULL
);
11413 fl
= atof ("56.789");
11414 if ((fl
< 56.788) || (fl
> 56.79))
11416 assert ("atof not type double, fix your #include <stdio.h>"
11422 #if FFECOM_GCC_INCLUDE
11423 ffecom_initialize_char_syntax_ ();
11426 ffecom_outer_function_decl_
= NULL_TREE
;
11427 current_function_decl
= NULL_TREE
;
11428 named_labels
= NULL_TREE
;
11429 current_binding_level
= NULL_BINDING_LEVEL
;
11430 free_binding_level
= NULL_BINDING_LEVEL
;
11431 /* Make the binding_level structure for global names. */
11433 global_binding_level
= current_binding_level
;
11434 current_binding_level
->prep_state
= 2;
11436 build_common_tree_nodes (1);
11438 /* Define `int' and `char' first so that dbx will output them first. */
11439 pushdecl (build_decl (TYPE_DECL
, get_identifier ("int"),
11440 integer_type_node
));
11441 /* CHARACTER*1 is unsigned in ICHAR contexts. */
11442 char_type_node
= make_unsigned_type (CHAR_TYPE_SIZE
);
11443 pushdecl (build_decl (TYPE_DECL
, get_identifier ("char"),
11445 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long int"),
11446 long_integer_type_node
));
11447 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned int"),
11448 unsigned_type_node
));
11449 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long unsigned int"),
11450 long_unsigned_type_node
));
11451 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long int"),
11452 long_long_integer_type_node
));
11453 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long unsigned int"),
11454 long_long_unsigned_type_node
));
11455 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short int"),
11456 short_integer_type_node
));
11457 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short unsigned int"),
11458 short_unsigned_type_node
));
11460 /* Set the sizetype before we make other types. This *should* be the
11461 first type we create. */
11464 (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE
))));
11465 ffecom_typesize_pointer_
11466 = TREE_INT_CST_LOW (TYPE_SIZE (sizetype
)) / BITS_PER_UNIT
;
11468 build_common_tree_nodes_2 (0);
11470 /* Define both `signed char' and `unsigned char'. */
11471 pushdecl (build_decl (TYPE_DECL
, get_identifier ("signed char"),
11472 signed_char_type_node
));
11474 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned char"),
11475 unsigned_char_type_node
));
11477 pushdecl (build_decl (TYPE_DECL
, get_identifier ("float"),
11479 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double"),
11480 double_type_node
));
11481 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long double"),
11482 long_double_type_node
));
11484 /* For now, override what build_common_tree_nodes has done. */
11485 complex_integer_type_node
= ffecom_make_complex_type_ (integer_type_node
);
11486 complex_float_type_node
= ffecom_make_complex_type_ (float_type_node
);
11487 complex_double_type_node
= ffecom_make_complex_type_ (double_type_node
);
11488 complex_long_double_type_node
11489 = ffecom_make_complex_type_ (long_double_type_node
);
11491 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex int"),
11492 complex_integer_type_node
));
11493 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex float"),
11494 complex_float_type_node
));
11495 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex double"),
11496 complex_double_type_node
));
11497 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex long double"),
11498 complex_long_double_type_node
));
11500 pushdecl (build_decl (TYPE_DECL
, get_identifier ("void"),
11502 /* We are not going to have real types in C with less than byte alignment,
11503 so we might as well not have any types that claim to have it. */
11504 TYPE_ALIGN (void_type_node
) = BITS_PER_UNIT
;
11505 TYPE_USER_ALIGN (void_type_node
) = 0;
11507 string_type_node
= build_pointer_type (char_type_node
);
11509 ffecom_tree_fun_type_void
11510 = build_function_type (void_type_node
, NULL_TREE
);
11512 ffecom_tree_ptr_to_fun_type_void
11513 = build_pointer_type (ffecom_tree_fun_type_void
);
11515 endlink
= tree_cons (NULL_TREE
, void_type_node
, NULL_TREE
);
11518 = build_function_type (float_type_node
,
11519 tree_cons (NULL_TREE
, float_type_node
, endlink
));
11521 double_ftype_double
11522 = build_function_type (double_type_node
,
11523 tree_cons (NULL_TREE
, double_type_node
, endlink
));
11525 ldouble_ftype_ldouble
11526 = build_function_type (long_double_type_node
,
11527 tree_cons (NULL_TREE
, long_double_type_node
,
11530 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11531 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11533 ffecom_tree_type
[i
][j
] = NULL_TREE
;
11534 ffecom_tree_fun_type
[i
][j
] = NULL_TREE
;
11535 ffecom_tree_ptr_to_fun_type
[i
][j
] = NULL_TREE
;
11536 ffecom_f2c_typecode_
[i
][j
] = -1;
11539 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11540 to size FLOAT_TYPE_SIZE because they have to be the same size as
11541 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11542 Compiler options and other such stuff that change the ways these
11543 types are set should not affect this particular setup. */
11545 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
]
11546 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
11547 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer"),
11549 type
= ffetype_new ();
11551 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER1
,
11553 ffetype_set_ams (type
,
11554 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11555 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11556 ffetype_set_star (base_type
,
11557 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11559 ffetype_set_kind (base_type
, 1, type
);
11560 ffecom_typesize_integer1_
= ffetype_size (type
);
11561 assert (ffetype_size (type
) == sizeof (ffetargetInteger1
));
11563 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER1
]
11564 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
); /* HOLLERITH means unsigned. */
11565 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned"),
11568 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER2
]
11569 = t
= make_signed_type (CHAR_TYPE_SIZE
);
11570 pushdecl (build_decl (TYPE_DECL
, get_identifier ("byte"),
11572 type
= ffetype_new ();
11573 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER2
,
11575 ffetype_set_ams (type
,
11576 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11577 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11578 ffetype_set_star (base_type
,
11579 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11581 ffetype_set_kind (base_type
, 3, type
);
11582 assert (ffetype_size (type
) == sizeof (ffetargetInteger2
));
11584 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER2
]
11585 = t
= make_unsigned_type (CHAR_TYPE_SIZE
);
11586 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned byte"),
11589 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER3
]
11590 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
11591 pushdecl (build_decl (TYPE_DECL
, get_identifier ("word"),
11593 type
= ffetype_new ();
11594 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER3
,
11596 ffetype_set_ams (type
,
11597 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11598 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11599 ffetype_set_star (base_type
,
11600 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11602 ffetype_set_kind (base_type
, 6, type
);
11603 assert (ffetype_size (type
) == sizeof (ffetargetInteger3
));
11605 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER3
]
11606 = t
= make_unsigned_type (CHAR_TYPE_SIZE
* 2);
11607 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned word"),
11610 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER4
]
11611 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
11612 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer4"),
11614 type
= ffetype_new ();
11615 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER4
,
11617 ffetype_set_ams (type
,
11618 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11619 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11620 ffetype_set_star (base_type
,
11621 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11623 ffetype_set_kind (base_type
, 2, type
);
11624 assert (ffetype_size (type
) == sizeof (ffetargetInteger4
));
11626 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER4
]
11627 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
* 2);
11628 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned4"),
11632 if (ffe_is_do_internal_checks ()
11633 && LONG_TYPE_SIZE
!= FLOAT_TYPE_SIZE
11634 && LONG_TYPE_SIZE
!= CHAR_TYPE_SIZE
11635 && LONG_TYPE_SIZE
!= SHORT_TYPE_SIZE
11636 && LONG_TYPE_SIZE
!= LONG_LONG_TYPE_SIZE
)
11638 fprintf (stderr
, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11643 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL1
]
11644 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
11645 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical"),
11647 type
= ffetype_new ();
11649 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL1
,
11651 ffetype_set_ams (type
,
11652 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11653 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11654 ffetype_set_star (base_type
,
11655 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11657 ffetype_set_kind (base_type
, 1, type
);
11658 assert (ffetype_size (type
) == sizeof (ffetargetLogical1
));
11660 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL2
]
11661 = t
= make_signed_type (CHAR_TYPE_SIZE
);
11662 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical2"),
11664 type
= ffetype_new ();
11665 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL2
,
11667 ffetype_set_ams (type
,
11668 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11669 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11670 ffetype_set_star (base_type
,
11671 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11673 ffetype_set_kind (base_type
, 3, type
);
11674 assert (ffetype_size (type
) == sizeof (ffetargetLogical2
));
11676 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL3
]
11677 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
11678 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical3"),
11680 type
= ffetype_new ();
11681 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL3
,
11683 ffetype_set_ams (type
,
11684 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11685 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11686 ffetype_set_star (base_type
,
11687 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11689 ffetype_set_kind (base_type
, 6, type
);
11690 assert (ffetype_size (type
) == sizeof (ffetargetLogical3
));
11692 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL4
]
11693 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
11694 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical4"),
11696 type
= ffetype_new ();
11697 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL4
,
11699 ffetype_set_ams (type
,
11700 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11701 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11702 ffetype_set_star (base_type
,
11703 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11705 ffetype_set_kind (base_type
, 2, type
);
11706 assert (ffetype_size (type
) == sizeof (ffetargetLogical4
));
11708 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
11709 = t
= make_node (REAL_TYPE
);
11710 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
;
11711 pushdecl (build_decl (TYPE_DECL
, get_identifier ("real"),
11714 type
= ffetype_new ();
11716 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREAL1
,
11718 ffetype_set_ams (type
,
11719 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11720 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11721 ffetype_set_star (base_type
,
11722 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11724 ffetype_set_kind (base_type
, 1, type
);
11725 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
11726 = FFETARGET_f2cTYREAL
;
11727 assert (ffetype_size (type
) == sizeof (ffetargetReal1
));
11729 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREALDOUBLE
]
11730 = t
= make_node (REAL_TYPE
);
11731 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
* 2; /* Always twice REAL. */
11732 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double precision"),
11735 type
= ffetype_new ();
11736 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREALDOUBLE
,
11738 ffetype_set_ams (type
,
11739 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11740 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11741 ffetype_set_star (base_type
,
11742 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11744 ffetype_set_kind (base_type
, 2, type
);
11745 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]
11746 = FFETARGET_f2cTYDREAL
;
11747 assert (ffetype_size (type
) == sizeof (ffetargetReal2
));
11749 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
11750 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]);
11751 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex"),
11753 type
= ffetype_new ();
11755 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREAL1
,
11757 ffetype_set_ams (type
,
11758 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11759 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11760 ffetype_set_star (base_type
,
11761 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11763 ffetype_set_kind (base_type
, 1, type
);
11764 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
11765 = FFETARGET_f2cTYCOMPLEX
;
11766 assert (ffetype_size (type
) == sizeof (ffetargetComplex1
));
11768 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREALDOUBLE
]
11769 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]);
11770 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double complex"),
11772 type
= ffetype_new ();
11773 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREALDOUBLE
,
11775 ffetype_set_ams (type
,
11776 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11777 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11778 ffetype_set_star (base_type
,
11779 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11781 ffetype_set_kind (base_type
, 2,
11783 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL2
]
11784 = FFETARGET_f2cTYDCOMPLEX
;
11785 assert (ffetype_size (type
) == sizeof (ffetargetComplex2
));
11787 /* Make function and ptr-to-function types for non-CHARACTER types. */
11789 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11790 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11792 if ((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
11794 if (i
== FFEINFO_basictypeINTEGER
)
11796 /* Figure out the smallest INTEGER type that can hold
11797 a pointer on this machine. */
11798 if (GET_MODE_SIZE (TYPE_MODE (t
))
11799 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
11801 if ((ffecom_pointer_kind_
== FFEINFO_kindtypeNONE
)
11802 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type
[i
][ffecom_pointer_kind_
]))
11803 > GET_MODE_SIZE (TYPE_MODE (t
))))
11804 ffecom_pointer_kind_
= j
;
11807 else if (i
== FFEINFO_basictypeCOMPLEX
)
11808 t
= void_type_node
;
11809 /* For f2c compatibility, REAL functions are really
11810 implemented as DOUBLE PRECISION. */
11811 else if ((i
== FFEINFO_basictypeREAL
)
11812 && (j
== FFEINFO_kindtypeREAL1
))
11813 t
= ffecom_tree_type
11814 [FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
];
11816 t
= ffecom_tree_fun_type
[i
][j
] = build_function_type (t
,
11818 ffecom_tree_ptr_to_fun_type
[i
][j
] = build_pointer_type (t
);
11822 /* Set up pointer types. */
11824 if (ffecom_pointer_kind_
== FFEINFO_basictypeNONE
)
11825 fatal_error ("no INTEGER type can hold a pointer on this configuration");
11826 else if (0 && ffe_is_do_internal_checks ())
11827 fprintf (stderr
, "Pointer type kt=%d\n", ffecom_pointer_kind_
);
11828 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER
,
11829 FFEINFO_kindtypeINTEGERDEFAULT
),
11831 ffeinfo_type (FFEINFO_basictypeINTEGER
,
11832 ffecom_pointer_kind_
));
11834 if (ffe_is_ugly_assign ())
11835 ffecom_label_kind_
= ffecom_pointer_kind_
; /* Require ASSIGN etc to this. */
11837 ffecom_label_kind_
= FFEINFO_kindtypeINTEGERDEFAULT
;
11838 if (0 && ffe_is_do_internal_checks ())
11839 fprintf (stderr
, "Label type kt=%d\n", ffecom_label_kind_
);
11841 ffecom_integer_type_node
11842 = ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
];
11843 ffecom_integer_zero_node
= convert (ffecom_integer_type_node
,
11844 integer_zero_node
);
11845 ffecom_integer_one_node
= convert (ffecom_integer_type_node
,
11848 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11849 Turns out that by TYLONG, runtime/libI77/lio.h really means
11850 "whatever size an ftnint is". For consistency and sanity,
11851 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11852 all are INTEGER, which we also make out of whatever back-end
11853 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11854 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11855 accommodate machines like the Alpha. Note that this suggests
11856 f2c and libf2c are missing a distinction perhaps needed on
11857 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11859 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, FLOAT_TYPE_SIZE
,
11860 FFETARGET_f2cTYLONG
);
11861 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, SHORT_TYPE_SIZE
,
11862 FFETARGET_f2cTYSHORT
);
11863 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, CHAR_TYPE_SIZE
,
11864 FFETARGET_f2cTYINT1
);
11865 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, LONG_LONG_TYPE_SIZE
,
11866 FFETARGET_f2cTYQUAD
);
11867 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, FLOAT_TYPE_SIZE
,
11868 FFETARGET_f2cTYLOGICAL
);
11869 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, SHORT_TYPE_SIZE
,
11870 FFETARGET_f2cTYLOGICAL2
);
11871 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, CHAR_TYPE_SIZE
,
11872 FFETARGET_f2cTYLOGICAL1
);
11873 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11874 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, LONG_LONG_TYPE_SIZE
,
11875 FFETARGET_f2cTYQUAD
);
11877 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11878 loop. CHARACTER items are built as arrays of unsigned char. */
11880 ffecom_tree_type
[FFEINFO_basictypeCHARACTER
]
11881 [FFEINFO_kindtypeCHARACTER1
] = t
= char_type_node
;
11882 type
= ffetype_new ();
11884 ffeinfo_set_type (FFEINFO_basictypeCHARACTER
,
11885 FFEINFO_kindtypeCHARACTER1
,
11887 ffetype_set_ams (type
,
11888 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11889 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11890 ffetype_set_kind (base_type
, 1, type
);
11891 assert (ffetype_size (type
)
11892 == sizeof (((ffetargetCharacter1
) { 0, NULL
}).text
[0]));
11894 ffecom_tree_fun_type
[FFEINFO_basictypeCHARACTER
]
11895 [FFEINFO_kindtypeCHARACTER1
] = ffecom_tree_fun_type_void
;
11896 ffecom_tree_ptr_to_fun_type
[FFEINFO_basictypeCHARACTER
]
11897 [FFEINFO_kindtypeCHARACTER1
]
11898 = ffecom_tree_ptr_to_fun_type_void
;
11899 ffecom_f2c_typecode_
[FFEINFO_basictypeCHARACTER
][FFEINFO_kindtypeCHARACTER1
]
11900 = FFETARGET_f2cTYCHAR
;
11902 ffecom_f2c_typecode_
[FFEINFO_basictypeANY
][FFEINFO_kindtypeANY
]
11905 /* Make multi-return-value type and fields. */
11907 ffecom_multi_type_node_
= make_node (UNION_TYPE
);
11911 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11912 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11916 if (ffecom_tree_type
[i
][j
] == NULL_TREE
)
11917 continue; /* Not supported. */
11918 sprintf (&name
[0], "bt_%s_kt_%s",
11919 ffeinfo_basictype_string ((ffeinfoBasictype
) i
),
11920 ffeinfo_kindtype_string ((ffeinfoKindtype
) j
));
11921 ffecom_multi_fields_
[i
][j
] = build_decl (FIELD_DECL
,
11922 get_identifier (name
),
11923 ffecom_tree_type
[i
][j
]);
11924 DECL_CONTEXT (ffecom_multi_fields_
[i
][j
])
11925 = ffecom_multi_type_node_
;
11926 DECL_ALIGN (ffecom_multi_fields_
[i
][j
]) = 0;
11927 DECL_USER_ALIGN (ffecom_multi_fields_
[i
][j
]) = 0;
11928 TREE_CHAIN (ffecom_multi_fields_
[i
][j
]) = field
;
11929 field
= ffecom_multi_fields_
[i
][j
];
11932 TYPE_FIELDS (ffecom_multi_type_node_
) = field
;
11933 layout_type (ffecom_multi_type_node_
);
11935 /* Subroutines usually return integer because they might have alternate
11938 ffecom_tree_subr_type
11939 = build_function_type (integer_type_node
, NULL_TREE
);
11940 ffecom_tree_ptr_to_subr_type
11941 = build_pointer_type (ffecom_tree_subr_type
);
11942 ffecom_tree_blockdata_type
11943 = build_function_type (void_type_node
, NULL_TREE
);
11945 builtin_function ("__builtin_sqrtf", float_ftype_float
,
11946 BUILT_IN_FSQRT
, BUILT_IN_NORMAL
, "sqrtf");
11947 builtin_function ("__builtin_fsqrt", double_ftype_double
,
11948 BUILT_IN_FSQRT
, BUILT_IN_NORMAL
, "sqrt");
11949 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble
,
11950 BUILT_IN_FSQRT
, BUILT_IN_NORMAL
, "sqrtl");
11951 builtin_function ("__builtin_sinf", float_ftype_float
,
11952 BUILT_IN_SIN
, BUILT_IN_NORMAL
, "sinf");
11953 builtin_function ("__builtin_sin", double_ftype_double
,
11954 BUILT_IN_SIN
, BUILT_IN_NORMAL
, "sin");
11955 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble
,
11956 BUILT_IN_SIN
, BUILT_IN_NORMAL
, "sinl");
11957 builtin_function ("__builtin_cosf", float_ftype_float
,
11958 BUILT_IN_COS
, BUILT_IN_NORMAL
, "cosf");
11959 builtin_function ("__builtin_cos", double_ftype_double
,
11960 BUILT_IN_COS
, BUILT_IN_NORMAL
, "cos");
11961 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble
,
11962 BUILT_IN_COS
, BUILT_IN_NORMAL
, "cosl");
11965 pedantic_lvalues
= FALSE
;
11968 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node
,
11971 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node
,
11974 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node
,
11977 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node
,
11978 FFECOM_f2cDOUBLEREAL
,
11980 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node
,
11983 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node
,
11984 FFECOM_f2cDOUBLECOMPLEX
,
11986 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node
,
11989 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node
,
11992 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node
,
11995 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node
,
11998 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node
,
12002 ffecom_f2c_ftnlen_zero_node
12003 = convert (ffecom_f2c_ftnlen_type_node
, integer_zero_node
);
12005 ffecom_f2c_ftnlen_one_node
12006 = convert (ffecom_f2c_ftnlen_type_node
, integer_one_node
);
12008 ffecom_f2c_ftnlen_two_node
= build_int_2 (2, 0);
12009 TREE_TYPE (ffecom_f2c_ftnlen_two_node
) = ffecom_integer_type_node
;
12011 ffecom_f2c_ptr_to_ftnlen_type_node
12012 = build_pointer_type (ffecom_f2c_ftnlen_type_node
);
12014 ffecom_f2c_ptr_to_ftnint_type_node
12015 = build_pointer_type (ffecom_f2c_ftnint_type_node
);
12017 ffecom_f2c_ptr_to_integer_type_node
12018 = build_pointer_type (ffecom_f2c_integer_type_node
);
12020 ffecom_f2c_ptr_to_real_type_node
12021 = build_pointer_type (ffecom_f2c_real_type_node
);
12023 ffecom_float_zero_
= build_real (float_type_node
, dconst0
);
12024 ffecom_double_zero_
= build_real (double_type_node
, dconst0
);
12026 REAL_VALUE_TYPE point_5
;
12028 #ifdef REAL_ARITHMETIC
12029 REAL_ARITHMETIC (point_5
, RDIV_EXPR
, dconst1
, dconst2
);
12033 ffecom_float_half_
= build_real (float_type_node
, point_5
);
12034 ffecom_double_half_
= build_real (double_type_node
, point_5
);
12037 /* Do "extern int xargc;". */
12039 ffecom_tree_xargc_
= build_decl (VAR_DECL
,
12040 get_identifier ("f__xargc"),
12041 integer_type_node
);
12042 DECL_EXTERNAL (ffecom_tree_xargc_
) = 1;
12043 TREE_STATIC (ffecom_tree_xargc_
) = 1;
12044 TREE_PUBLIC (ffecom_tree_xargc_
) = 1;
12045 ffecom_tree_xargc_
= start_decl (ffecom_tree_xargc_
, FALSE
);
12046 finish_decl (ffecom_tree_xargc_
, NULL_TREE
, FALSE
);
12048 #if 0 /* This is being fixed, and seems to be working now. */
12049 if ((FLOAT_TYPE_SIZE
!= 32)
12050 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))) != 32))
12052 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12053 (int) FLOAT_TYPE_SIZE
);
12054 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12055 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))));
12056 warning ("properly unless they all are 32 bits wide.");
12057 warning ("Please keep this in mind before you report bugs. g77 should");
12058 warning ("support non-32-bit machines better as of version 0.6.");
12062 #if 0 /* Code in ste.c that would crash has been commented out. */
12063 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
12064 < TYPE_PRECISION (string_type_node
))
12065 /* I/O will probably crash. */
12066 warning ("configuration: char * holds %d bits, but ftnlen only %d",
12067 TYPE_PRECISION (string_type_node
),
12068 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
));
12071 #if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
12072 if (TYPE_PRECISION (ffecom_integer_type_node
)
12073 < TYPE_PRECISION (string_type_node
))
12074 /* ASSIGN 10 TO I will crash. */
12075 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12076 ASSIGN statement might fail",
12077 TYPE_PRECISION (string_type_node
),
12078 TYPE_PRECISION (ffecom_integer_type_node
));
12083 /* ffecom_init_2 -- Initialize
12085 ffecom_init_2(); */
12087 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12091 assert (ffecom_outer_function_decl_
== NULL_TREE
);
12092 assert (current_function_decl
== NULL_TREE
);
12093 assert (ffecom_which_entrypoint_decl_
== NULL_TREE
);
12095 ffecom_master_arglist_
= NULL
;
12097 ffecom_primary_entry_
= NULL
;
12098 ffecom_is_altreturning_
= FALSE
;
12099 ffecom_func_result_
= NULL_TREE
;
12100 ffecom_multi_retval_
= NULL_TREE
;
12104 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12107 ffebld expr; // FFE opITEM list.
12108 tree = ffecom_list_expr(expr);
12110 List of actual args is transformed into corresponding gcc backend list. */
12112 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12114 ffecom_list_expr (ffebld expr
)
12117 tree
*plist
= &list
;
12118 tree trail
= NULL_TREE
; /* Append char length args here. */
12119 tree
*ptrail
= &trail
;
12122 while (expr
!= NULL
)
12124 tree texpr
= ffecom_arg_expr (ffebld_head (expr
), &length
);
12126 if (texpr
== error_mark_node
)
12127 return error_mark_node
;
12129 *plist
= build_tree_list (NULL_TREE
, texpr
);
12130 plist
= &TREE_CHAIN (*plist
);
12131 expr
= ffebld_trail (expr
);
12132 if (length
!= NULL_TREE
)
12134 *ptrail
= build_tree_list (NULL_TREE
, length
);
12135 ptrail
= &TREE_CHAIN (*ptrail
);
12145 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12148 ffebld expr; // FFE opITEM list.
12149 tree = ffecom_list_ptr_to_expr(expr);
12151 List of actual args is transformed into corresponding gcc backend list for
12152 use in calling an external procedure (vs. a statement function). */
12154 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12156 ffecom_list_ptr_to_expr (ffebld expr
)
12159 tree
*plist
= &list
;
12160 tree trail
= NULL_TREE
; /* Append char length args here. */
12161 tree
*ptrail
= &trail
;
12164 while (expr
!= NULL
)
12166 tree texpr
= ffecom_arg_ptr_to_expr (ffebld_head (expr
), &length
);
12168 if (texpr
== error_mark_node
)
12169 return error_mark_node
;
12171 *plist
= build_tree_list (NULL_TREE
, texpr
);
12172 plist
= &TREE_CHAIN (*plist
);
12173 expr
= ffebld_trail (expr
);
12174 if (length
!= NULL_TREE
)
12176 *ptrail
= build_tree_list (NULL_TREE
, length
);
12177 ptrail
= &TREE_CHAIN (*ptrail
);
12187 /* Obtain gcc's LABEL_DECL tree for label. */
12189 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12191 ffecom_lookup_label (ffelab label
)
12195 if (ffelab_hook (label
) == NULL_TREE
)
12197 char labelname
[16];
12199 switch (ffelab_type (label
))
12201 case FFELAB_typeLOOPEND
:
12202 case FFELAB_typeNOTLOOP
:
12203 case FFELAB_typeENDIF
:
12204 sprintf (labelname
, "%" ffelabValue_f
"u", ffelab_value (label
));
12205 glabel
= build_decl (LABEL_DECL
, get_identifier (labelname
),
12207 DECL_CONTEXT (glabel
) = current_function_decl
;
12208 DECL_MODE (glabel
) = VOIDmode
;
12211 case FFELAB_typeFORMAT
:
12212 glabel
= build_decl (VAR_DECL
,
12213 ffecom_get_invented_identifier
12214 ("__g77_format_%d", (int) ffelab_value (label
)),
12215 build_type_variant (build_array_type
12219 TREE_CONSTANT (glabel
) = 1;
12220 TREE_STATIC (glabel
) = 1;
12221 DECL_CONTEXT (glabel
) = current_function_decl
;
12222 DECL_INITIAL (glabel
) = NULL
;
12223 make_decl_rtl (glabel
, NULL
);
12224 expand_decl (glabel
);
12226 ffecom_save_tree_forever (glabel
);
12230 case FFELAB_typeANY
:
12231 glabel
= error_mark_node
;
12235 assert ("bad label type" == NULL
);
12239 ffelab_set_hook (label
, glabel
);
12243 glabel
= ffelab_hook (label
);
12250 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12251 a single source specification (as in the fourth argument of MVBITS).
12252 If the type is NULL_TREE, the type of lhs is used to make the type of
12253 the MODIFY_EXPR. */
12255 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12257 ffecom_modify (tree newtype
, tree lhs
,
12260 if (lhs
== error_mark_node
|| rhs
== error_mark_node
)
12261 return error_mark_node
;
12263 if (newtype
== NULL_TREE
)
12264 newtype
= TREE_TYPE (lhs
);
12266 if (TREE_SIDE_EFFECTS (lhs
))
12267 lhs
= stabilize_reference (lhs
);
12269 return ffecom_2s (MODIFY_EXPR
, newtype
, lhs
, rhs
);
12274 /* Register source file name. */
12277 ffecom_file (const char *name
)
12279 #if FFECOM_GCC_INCLUDE
12280 ffecom_file_ (name
);
12284 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12287 ffecom_notify_init_storage(st);
12289 Gets called when all possible units in an aggregate storage area (a LOCAL
12290 with equivalences or a COMMON) have been initialized. The initialization
12291 info either is in ffestorag_init or, if that is NULL,
12292 ffestorag_accretion:
12294 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12295 even for an array if the array is one element in length!
12297 ffestorag_accretion will contain an opACCTER. It is much like an
12298 opARRTER except it has an ffebit object in it instead of just a size.
12299 The back end can use the info in the ffebit object, if it wants, to
12300 reduce the amount of actual initialization, but in any case it should
12301 kill the ffebit object when done. Also, set accretion to NULL but
12302 init to a non-NULL value.
12304 After performing initialization, DO NOT set init to NULL, because that'll
12305 tell the front end it is ok for more initialization to happen. Instead,
12306 set init to an opANY expression or some such thing that you can use to
12307 tell that you've already initialized the object.
12310 Support two-pass FFE. */
12313 ffecom_notify_init_storage (ffestorag st
)
12315 ffebld init
; /* The initialization expression. */
12316 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12317 ffetargetOffset size
; /* The size of the entity. */
12318 ffetargetAlign pad
; /* Its initial padding. */
12321 if (ffestorag_init (st
) == NULL
)
12323 init
= ffestorag_accretion (st
);
12324 assert (init
!= NULL
);
12325 ffestorag_set_accretion (st
, NULL
);
12326 ffestorag_set_accretes (st
, 0);
12328 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12329 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12330 size
= ffebld_accter_size (init
);
12331 pad
= ffebld_accter_pad (init
);
12332 ffebit_kill (ffebld_accter_bits (init
));
12333 ffebld_set_op (init
, FFEBLD_opARRTER
);
12334 ffebld_set_arrter (init
, ffebld_accter (init
));
12335 ffebld_arrter_set_size (init
, size
);
12336 ffebld_arrter_set_pad (init
, size
);
12340 ffestorag_set_init (st
, init
);
12345 init
= ffestorag_init (st
);
12348 #if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
12349 ffestorag_set_init (st
, ffebld_new_any ());
12351 if (ffebld_op (init
) == FFEBLD_opANY
)
12352 return; /* Oh, we already did this! */
12354 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12358 if (ffestorag_symbol (st
) != NULL
)
12359 s
= ffestorag_symbol (st
);
12361 s
= ffestorag_typesymbol (st
);
12363 fprintf (dmpout
, "= initialize_storage \"%s\" ",
12364 (s
!= NULL
) ? ffesymbol_text (s
) : "(unnamed)");
12365 ffebld_dump (init
);
12366 fputc ('\n', dmpout
);
12370 #endif /* if FFECOM_ONEPASS */
12373 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12376 ffecom_notify_init_symbol(s);
12378 Gets called when all possible units in a symbol (not placed in COMMON
12379 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12380 have been initialized. The initialization info either is in
12381 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12383 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12384 even for an array if the array is one element in length!
12386 ffesymbol_accretion will contain an opACCTER. It is much like an
12387 opARRTER except it has an ffebit object in it instead of just a size.
12388 The back end can use the info in the ffebit object, if it wants, to
12389 reduce the amount of actual initialization, but in any case it should
12390 kill the ffebit object when done. Also, set accretion to NULL but
12391 init to a non-NULL value.
12393 After performing initialization, DO NOT set init to NULL, because that'll
12394 tell the front end it is ok for more initialization to happen. Instead,
12395 set init to an opANY expression or some such thing that you can use to
12396 tell that you've already initialized the object.
12399 Support two-pass FFE. */
12402 ffecom_notify_init_symbol (ffesymbol s
)
12404 ffebld init
; /* The initialization expression. */
12405 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12406 ffetargetOffset size
; /* The size of the entity. */
12407 ffetargetAlign pad
; /* Its initial padding. */
12410 if (ffesymbol_storage (s
) == NULL
)
12411 return; /* Do nothing until COMMON/EQUIVALENCE
12412 possibilities checked. */
12414 if ((ffesymbol_init (s
) == NULL
)
12415 && ((init
= ffesymbol_accretion (s
)) != NULL
))
12417 ffesymbol_set_accretion (s
, NULL
);
12418 ffesymbol_set_accretes (s
, 0);
12420 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12421 /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12422 size
= ffebld_accter_size (init
);
12423 pad
= ffebld_accter_pad (init
);
12424 ffebit_kill (ffebld_accter_bits (init
));
12425 ffebld_set_op (init
, FFEBLD_opARRTER
);
12426 ffebld_set_arrter (init
, ffebld_accter (init
));
12427 ffebld_arrter_set_size (init
, size
);
12428 ffebld_arrter_set_pad (init
, size
);
12432 ffesymbol_set_init (s
, init
);
12437 init
= ffesymbol_init (s
);
12441 ffesymbol_set_init (s
, ffebld_new_any ());
12443 if (ffebld_op (init
) == FFEBLD_opANY
)
12444 return; /* Oh, we already did this! */
12446 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12447 fprintf (dmpout
, "= initialize_symbol \"%s\" ", ffesymbol_text (s
));
12448 ffebld_dump (init
);
12449 fputc ('\n', dmpout
);
12452 #endif /* if FFECOM_ONEPASS */
12455 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12458 ffecom_notify_primary_entry(s);
12460 Gets called when implicit or explicit PROGRAM statement seen or when
12461 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12462 global symbol that serves as the entry point. */
12465 ffecom_notify_primary_entry (ffesymbol s
)
12467 ffecom_primary_entry_
= s
;
12468 ffecom_primary_entry_kind_
= ffesymbol_kind (s
);
12470 if ((ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
12471 || (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
))
12472 ffecom_primary_entry_is_proc_
= TRUE
;
12474 ffecom_primary_entry_is_proc_
= FALSE
;
12476 if (!ffe_is_silent ())
12478 if (ffecom_primary_entry_kind_
== FFEINFO_kindPROGRAM
)
12479 fprintf (stderr
, "%s:\n", ffesymbol_text (s
));
12481 fprintf (stderr
, " %s:\n", ffesymbol_text (s
));
12484 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12485 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
12490 for (list
= ffesymbol_dummyargs (s
);
12492 list
= ffebld_trail (list
))
12494 arg
= ffebld_head (list
);
12495 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
12497 ffecom_is_altreturning_
= TRUE
;
12506 ffecom_open_include (char *name
, ffewhereLine l
, ffewhereColumn c
)
12508 #if FFECOM_GCC_INCLUDE
12509 return ffecom_open_include_ (name
, l
, c
);
12511 return fopen (name
, "r");
12515 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12518 ffebld expr; // FFE expression.
12519 tree = ffecom_ptr_to_expr(expr);
12521 Like ffecom_expr, but sticks address-of in front of most things. */
12523 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12525 ffecom_ptr_to_expr (ffebld expr
)
12528 ffeinfoBasictype bt
;
12529 ffeinfoKindtype kt
;
12532 assert (expr
!= NULL
);
12534 switch (ffebld_op (expr
))
12536 case FFEBLD_opSYMTER
:
12537 s
= ffebld_symter (expr
);
12538 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
12542 ix
= ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr
));
12543 assert (ix
!= FFECOM_gfrt
);
12544 if ((item
= ffecom_gfrt_
[ix
]) == NULL_TREE
)
12546 ffecom_make_gfrt_ (ix
);
12547 item
= ffecom_gfrt_
[ix
];
12552 item
= ffesymbol_hook (s
).decl_tree
;
12553 if (item
== NULL_TREE
)
12555 s
= ffecom_sym_transform_ (s
);
12556 item
= ffesymbol_hook (s
).decl_tree
;
12559 assert (item
!= NULL
);
12560 if (item
== error_mark_node
)
12562 if (!ffesymbol_hook (s
).addr
)
12563 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12567 case FFEBLD_opARRAYREF
:
12568 return ffecom_arrayref_ (NULL_TREE
, expr
, 1);
12570 case FFEBLD_opCONTER
:
12572 bt
= ffeinfo_basictype (ffebld_info (expr
));
12573 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12575 item
= ffecom_constantunion (&ffebld_constant_union
12576 (ffebld_conter (expr
)), bt
, kt
,
12577 ffecom_tree_type
[bt
][kt
]);
12578 if (item
== error_mark_node
)
12579 return error_mark_node
;
12580 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12585 return error_mark_node
;
12588 bt
= ffeinfo_basictype (ffebld_info (expr
));
12589 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12591 item
= ffecom_expr (expr
);
12592 if (item
== error_mark_node
)
12593 return error_mark_node
;
12595 /* The back end currently optimizes a bit too zealously for us, in that
12596 we fail JCB001 if the following block of code is omitted. It checks
12597 to see if the transformed expression is a symbol or array reference,
12598 and encloses it in a SAVE_EXPR if that is the case. */
12601 if ((TREE_CODE (item
) == VAR_DECL
)
12602 || (TREE_CODE (item
) == PARM_DECL
)
12603 || (TREE_CODE (item
) == RESULT_DECL
)
12604 || (TREE_CODE (item
) == INDIRECT_REF
)
12605 || (TREE_CODE (item
) == ARRAY_REF
)
12606 || (TREE_CODE (item
) == COMPONENT_REF
)
12608 || (TREE_CODE (item
) == OFFSET_REF
)
12610 || (TREE_CODE (item
) == BUFFER_REF
)
12611 || (TREE_CODE (item
) == REALPART_EXPR
)
12612 || (TREE_CODE (item
) == IMAGPART_EXPR
))
12614 item
= ffecom_save_tree (item
);
12617 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12622 assert ("fall-through error" == NULL
);
12623 return error_mark_node
;
12627 /* Obtain a temp var with given data type.
12629 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12630 or >= 0 for a CHARACTER type.
12632 elements is -1 for a scalar or > 0 for an array of type. */
12634 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12636 ffecom_make_tempvar (const char *commentary
, tree type
,
12637 ffetargetCharacterSize size
, int elements
)
12640 static int mynumber
;
12642 assert (current_binding_level
->prep_state
< 2);
12644 if (type
== error_mark_node
)
12645 return error_mark_node
;
12647 if (size
!= FFETARGET_charactersizeNONE
)
12648 type
= build_array_type (type
,
12649 build_range_type (ffecom_f2c_ftnlen_type_node
,
12650 ffecom_f2c_ftnlen_one_node
,
12651 build_int_2 (size
, 0)));
12652 if (elements
!= -1)
12653 type
= build_array_type (type
,
12654 build_range_type (integer_type_node
,
12656 build_int_2 (elements
- 1,
12658 t
= build_decl (VAR_DECL
,
12659 ffecom_get_invented_identifier ("__g77_%s_%d",
12664 t
= start_decl (t
, FALSE
);
12665 finish_decl (t
, NULL_TREE
, FALSE
);
12671 /* Prepare argument pointer to expression.
12673 Like ffecom_prepare_expr, except for expressions to be evaluated
12674 via ffecom_arg_ptr_to_expr. */
12677 ffecom_prepare_arg_ptr_to_expr (ffebld expr
)
12679 /* ~~For now, it seems to be the same thing. */
12680 ffecom_prepare_expr (expr
);
12684 /* End of preparations. */
12687 ffecom_prepare_end (void)
12689 int prep_state
= current_binding_level
->prep_state
;
12691 assert (prep_state
< 2);
12692 current_binding_level
->prep_state
= 2;
12694 return (prep_state
== 1) ? TRUE
: FALSE
;
12697 /* Prepare expression.
12699 This is called before any code is generated for the current block.
12700 It scans the expression, declares any temporaries that might be needed
12701 during evaluation of the expression, and stores those temporaries in
12702 the appropriate "hook" fields of the expression. `dest', if not NULL,
12703 specifies the destination that ffecom_expr_ will see, in case that
12704 helps avoid generating unused temporaries.
12706 ~~Improve to avoid allocating unused temporaries by taking `dest'
12707 into account vis-a-vis aliasing requirements of complex/character
12711 ffecom_prepare_expr_ (ffebld expr
, ffebld dest UNUSED
)
12713 ffeinfoBasictype bt
;
12714 ffeinfoKindtype kt
;
12715 ffetargetCharacterSize sz
;
12716 tree tempvar
= NULL_TREE
;
12718 assert (current_binding_level
->prep_state
< 2);
12723 bt
= ffeinfo_basictype (ffebld_info (expr
));
12724 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12725 sz
= ffeinfo_size (ffebld_info (expr
));
12727 /* Generate whatever temporaries are needed to represent the result
12728 of the expression. */
12730 if (bt
== FFEINFO_basictypeCHARACTER
)
12732 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
12733 expr
= ffebld_left (expr
);
12736 switch (ffebld_op (expr
))
12739 /* Don't make temps for SYMTER, CONTER, etc. */
12740 if (ffebld_arity (expr
) == 0)
12745 case FFEINFO_basictypeCOMPLEX
:
12746 if (ffebld_op (expr
) == FFEBLD_opFUNCREF
)
12750 if (ffebld_op (ffebld_left (expr
)) != FFEBLD_opSYMTER
)
12753 s
= ffebld_symter (ffebld_left (expr
));
12754 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
12755 || (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
12756 && ! ffesymbol_is_f2c (s
))
12757 || (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
12758 && ! ffe_is_f2c_library ()))
12761 else if (ffebld_op (expr
) == FFEBLD_opPOWER
)
12763 /* Requires special treatment. There's no POW_CC function
12764 in libg2c, so POW_ZZ is used, which means we always
12765 need a double-complex temp, not a single-complex. */
12766 kt
= FFEINFO_kindtypeREAL2
;
12768 else if (ffebld_op (expr
) != FFEBLD_opDIVIDE
)
12769 /* The other ops don't need temps for complex operands. */
12772 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12773 REAL(C). See 19990325-0.f, routine `check', for cases. */
12774 tempvar
= ffecom_make_tempvar ("complex",
12776 [FFEINFO_basictypeCOMPLEX
][kt
],
12777 FFETARGET_charactersizeNONE
,
12781 case FFEINFO_basictypeCHARACTER
:
12782 if (ffebld_op (expr
) != FFEBLD_opFUNCREF
)
12785 if (sz
== FFETARGET_charactersizeNONE
)
12786 /* ~~Kludge alert! This should someday be fixed. */
12789 tempvar
= ffecom_make_tempvar ("char", char_type_node
, sz
, -1);
12798 case FFEBLD_opPOWER
:
12801 tree rtmp
, ltmp
, result
;
12803 ltype
= ffecom_type_expr (ffebld_left (expr
));
12804 rtype
= ffecom_type_expr (ffebld_right (expr
));
12806 rtmp
= ffecom_make_tempvar (rtype
, FFETARGET_charactersizeNONE
, -1);
12807 ltmp
= ffecom_make_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1);
12808 result
= ffecom_make_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1);
12810 tempvar
= make_tree_vec (3);
12811 TREE_VEC_ELT (tempvar
, 0) = rtmp
;
12812 TREE_VEC_ELT (tempvar
, 1) = ltmp
;
12813 TREE_VEC_ELT (tempvar
, 2) = result
;
12818 case FFEBLD_opCONCATENATE
:
12820 /* This gets special handling, because only one set of temps
12821 is needed for a tree of these -- the tree is treated as
12822 a flattened list of concatenations when generating code. */
12824 ffecomConcatList_ catlist
;
12825 tree ltmp
, itmp
, result
;
12829 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
12830 count
= ffecom_concat_list_count_ (catlist
);
12835 = ffecom_make_tempvar ("concat_len",
12836 ffecom_f2c_ftnlen_type_node
,
12837 FFETARGET_charactersizeNONE
, count
);
12839 = ffecom_make_tempvar ("concat_item",
12840 ffecom_f2c_address_type_node
,
12841 FFETARGET_charactersizeNONE
, count
);
12843 = ffecom_make_tempvar ("concat_res",
12845 ffecom_concat_list_maxlen_ (catlist
),
12848 tempvar
= make_tree_vec (3);
12849 TREE_VEC_ELT (tempvar
, 0) = ltmp
;
12850 TREE_VEC_ELT (tempvar
, 1) = itmp
;
12851 TREE_VEC_ELT (tempvar
, 2) = result
;
12854 for (i
= 0; i
< count
; ++i
)
12855 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist
,
12858 ffecom_concat_list_kill_ (catlist
);
12862 ffebld_nonter_set_hook (expr
, tempvar
);
12863 current_binding_level
->prep_state
= 1;
12868 case FFEBLD_opCONVERT
:
12869 if (bt
== FFEINFO_basictypeCHARACTER
12870 && ((ffebld_size_known (ffebld_left (expr
))
12871 == FFETARGET_charactersizeNONE
)
12872 || (ffebld_size_known (ffebld_left (expr
)) >= sz
)))
12873 tempvar
= ffecom_make_tempvar ("convert", char_type_node
, sz
, -1);
12879 ffebld_nonter_set_hook (expr
, tempvar
);
12880 current_binding_level
->prep_state
= 1;
12883 /* Prepare subexpressions for this expr. */
12885 switch (ffebld_op (expr
))
12887 case FFEBLD_opPERCENT_LOC
:
12888 ffecom_prepare_ptr_to_expr (ffebld_left (expr
));
12891 case FFEBLD_opPERCENT_VAL
:
12892 case FFEBLD_opPERCENT_REF
:
12893 ffecom_prepare_expr (ffebld_left (expr
));
12896 case FFEBLD_opPERCENT_DESCR
:
12897 ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr
));
12900 case FFEBLD_opITEM
:
12906 item
= ffebld_trail (item
))
12907 if (ffebld_head (item
) != NULL
)
12908 ffecom_prepare_expr (ffebld_head (item
));
12913 /* Need to handle character conversion specially. */
12914 switch (ffebld_arity (expr
))
12917 ffecom_prepare_expr (ffebld_left (expr
));
12918 ffecom_prepare_expr (ffebld_right (expr
));
12922 ffecom_prepare_expr (ffebld_left (expr
));
12933 /* Prepare expression for reading and writing.
12935 Like ffecom_prepare_expr, except for expressions to be evaluated
12936 via ffecom_expr_rw. */
12939 ffecom_prepare_expr_rw (tree type
, ffebld expr
)
12941 /* This is all we support for now. */
12942 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
12944 /* ~~For now, it seems to be the same thing. */
12945 ffecom_prepare_expr (expr
);
12949 /* Prepare expression for writing.
12951 Like ffecom_prepare_expr, except for expressions to be evaluated
12952 via ffecom_expr_w. */
12955 ffecom_prepare_expr_w (tree type
, ffebld expr
)
12957 /* This is all we support for now. */
12958 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
12960 /* ~~For now, it seems to be the same thing. */
12961 ffecom_prepare_expr (expr
);
12965 /* Prepare expression for returning.
12967 Like ffecom_prepare_expr, except for expressions to be evaluated
12968 via ffecom_return_expr. */
12971 ffecom_prepare_return_expr (ffebld expr
)
12973 assert (current_binding_level
->prep_state
< 2);
12975 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
12976 && ffecom_is_altreturning_
12978 ffecom_prepare_expr (expr
);
12981 /* Prepare pointer to expression.
12983 Like ffecom_prepare_expr, except for expressions to be evaluated
12984 via ffecom_ptr_to_expr. */
12987 ffecom_prepare_ptr_to_expr (ffebld expr
)
12989 /* ~~For now, it seems to be the same thing. */
12990 ffecom_prepare_expr (expr
);
12994 /* Transform expression into constant pointer-to-expression tree.
12996 If the expression can be transformed into a pointer-to-expression tree
12997 that is constant, that is done, and the tree returned. Else NULL_TREE
13000 That way, a caller can attempt to provide compile-time initialization
13001 of a variable and, if that fails, *then* choose to start a new block
13002 and resort to using temporaries, as appropriate. */
13005 ffecom_ptr_to_const_expr (ffebld expr
)
13008 return integer_zero_node
;
13010 if (ffebld_op (expr
) == FFEBLD_opANY
)
13011 return error_mark_node
;
13013 if (ffebld_arity (expr
) == 0
13014 && (ffebld_op (expr
) != FFEBLD_opSYMTER
13015 || ffebld_where (expr
) == FFEINFO_whereCOMMON
13016 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
13017 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
13021 t
= ffecom_ptr_to_expr (expr
);
13022 assert (TREE_CONSTANT (t
));
13029 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13031 tree rtn; // NULL_TREE means use expand_null_return()
13032 ffebld expr; // NULL if no alt return expr to RETURN stmt
13033 rtn = ffecom_return_expr(expr);
13035 Based on the program unit type and other info (like return function
13036 type, return master function type when alternate ENTRY points,
13037 whether subroutine has any alternate RETURN points, etc), returns the
13038 appropriate expression to be returned to the caller, or NULL_TREE
13039 meaning no return value or the caller expects it to be returned somewhere
13040 else (which is handled by other parts of this module). */
13042 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13044 ffecom_return_expr (ffebld expr
)
13048 switch (ffecom_primary_entry_kind_
)
13050 case FFEINFO_kindPROGRAM
:
13051 case FFEINFO_kindBLOCKDATA
:
13055 case FFEINFO_kindSUBROUTINE
:
13056 if (!ffecom_is_altreturning_
)
13057 rtn
= NULL_TREE
; /* No alt returns, never an expr. */
13058 else if (expr
== NULL
)
13059 rtn
= integer_zero_node
;
13061 rtn
= ffecom_expr (expr
);
13064 case FFEINFO_kindFUNCTION
:
13065 if ((ffecom_multi_retval_
!= NULL_TREE
)
13066 || (ffesymbol_basictype (ffecom_primary_entry_
)
13067 == FFEINFO_basictypeCHARACTER
)
13068 || ((ffesymbol_basictype (ffecom_primary_entry_
)
13069 == FFEINFO_basictypeCOMPLEX
)
13070 && (ffecom_num_entrypoints_
== 0)
13071 && ffesymbol_is_f2c (ffecom_primary_entry_
)))
13072 { /* Value is returned by direct assignment
13073 into (implicit) dummy. */
13077 rtn
= ffecom_func_result_
;
13079 /* Spurious error if RETURN happens before first reference! So elide
13080 this code. In particular, for debugging registry, rtn should always
13081 be non-null after all, but TREE_USED won't be set until we encounter
13082 a reference in the code. Perfectly okay (but weird) code that,
13083 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13084 this diagnostic for no reason. Have people use -O -Wuninitialized
13085 and leave it to the back end to find obviously weird cases. */
13087 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13088 situation; if the return value has never been referenced, it won't
13089 have a tree under 2pass mode. */
13090 if ((rtn
== NULL_TREE
)
13091 || !TREE_USED (rtn
))
13093 ffebad_start (FFEBAD_RETURN_VALUE_UNSET
);
13094 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_
),
13095 ffesymbol_where_column (ffecom_primary_entry_
));
13096 ffebad_string (ffesymbol_text (ffesymbol_funcresult
13097 (ffecom_primary_entry_
)));
13104 assert ("bad unit kind" == NULL
);
13105 case FFEINFO_kindANY
:
13106 rtn
= error_mark_node
;
13114 /* Do save_expr only if tree is not error_mark_node. */
13116 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13118 ffecom_save_tree (tree t
)
13120 return save_expr (t
);
13124 /* Start a compound statement (block). */
13126 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13128 ffecom_start_compstmt (void)
13130 bison_rule_pushlevel_ ();
13132 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13134 /* Public entry point for front end to access start_decl. */
13136 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13138 ffecom_start_decl (tree decl
, bool is_initialized
)
13140 DECL_INITIAL (decl
) = is_initialized
? error_mark_node
: NULL_TREE
;
13141 return start_decl (decl
, FALSE
);
13145 /* ffecom_sym_commit -- Symbol's state being committed to reality
13148 ffecom_sym_commit(s);
13150 Does whatever the backend needs when a symbol is committed after having
13151 been backtrackable for a period of time. */
13153 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13155 ffecom_sym_commit (ffesymbol s UNUSED
)
13157 assert (!ffesymbol_retractable ());
13161 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13163 ffecom_sym_end_transition();
13165 Does backend-specific stuff and also calls ffest_sym_end_transition
13166 to do the necessary FFE stuff.
13168 Backtracking is never enabled when this fn is called, so don't worry
13172 ffecom_sym_end_transition (ffesymbol s
)
13176 assert (!ffesymbol_retractable ());
13178 s
= ffest_sym_end_transition (s
);
13180 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13181 if ((ffesymbol_kind (s
) == FFEINFO_kindBLOCKDATA
)
13182 && (ffesymbol_where (s
) == FFEINFO_whereGLOBAL
))
13184 ffecom_list_blockdata_
13185 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
13186 FFEINTRIN_specNONE
,
13187 FFEINTRIN_impNONE
),
13188 ffecom_list_blockdata_
);
13192 /* This is where we finally notice that a symbol has partial initialization
13193 and finalize it. */
13195 if (ffesymbol_accretion (s
) != NULL
)
13197 assert (ffesymbol_init (s
) == NULL
);
13198 ffecom_notify_init_symbol (s
);
13200 else if (((st
= ffesymbol_storage (s
)) != NULL
)
13201 && ((st
= ffestorag_parent (st
)) != NULL
)
13202 && (ffestorag_accretion (st
) != NULL
))
13204 assert (ffestorag_init (st
) == NULL
);
13205 ffecom_notify_init_storage (st
);
13208 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13209 if ((ffesymbol_kind (s
) == FFEINFO_kindCOMMON
)
13210 && (ffesymbol_where (s
) == FFEINFO_whereLOCAL
)
13211 && (ffesymbol_storage (s
) != NULL
))
13213 ffecom_list_common_
13214 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
13215 FFEINTRIN_specNONE
,
13216 FFEINTRIN_impNONE
),
13217 ffecom_list_common_
);
13224 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13226 ffecom_sym_exec_transition();
13228 Does backend-specific stuff and also calls ffest_sym_exec_transition
13229 to do the necessary FFE stuff.
13231 See the long-winded description in ffecom_sym_learned for info
13232 on handling the situation where backtracking is inhibited. */
13235 ffecom_sym_exec_transition (ffesymbol s
)
13237 s
= ffest_sym_exec_transition (s
);
13242 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13245 s = ffecom_sym_learned(s);
13247 Called when a new symbol is seen after the exec transition or when more
13248 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
13249 it arrives here is that all its latest info is updated already, so its
13250 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13251 field filled in if its gone through here or exec_transition first, and
13254 The backend probably wants to check ffesymbol_retractable() to see if
13255 backtracking is in effect. If so, the FFE's changes to the symbol may
13256 be retracted (undone) or committed (ratified), at which time the
13257 appropriate ffecom_sym_retract or _commit function will be called
13260 If the backend has its own backtracking mechanism, great, use it so that
13261 committal is a simple operation. Though it doesn't make much difference,
13262 I suppose: the reason for tentative symbol evolution in the FFE is to
13263 enable error detection in weird incorrect statements early and to disable
13264 incorrect error detection on a correct statement. The backend is not
13265 likely to introduce any information that'll get involved in these
13266 considerations, so it is probably just fine that the implementation
13267 model for this fn and for _exec_transition is to not do anything
13268 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13269 and instead wait until ffecom_sym_commit is called (which it never
13270 will be as long as we're using ambiguity-detecting statement analysis in
13271 the FFE, which we are initially to shake out the code, but don't depend
13272 on this), otherwise go ahead and do whatever is needed.
13274 In essence, then, when this fn and _exec_transition get called while
13275 backtracking is enabled, a general mechanism would be to flag which (or
13276 both) of these were called (and in what order? neat question as to what
13277 might happen that I'm too lame to think through right now) and then when
13278 _commit is called reproduce the original calling sequence, if any, for
13279 the two fns (at which point backtracking will, of course, be disabled). */
13282 ffecom_sym_learned (ffesymbol s
)
13284 ffestorag_exec_layout (s
);
13289 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13292 ffecom_sym_retract(s);
13294 Does whatever the backend needs when a symbol is retracted after having
13295 been backtrackable for a period of time. */
13297 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13299 ffecom_sym_retract (ffesymbol s UNUSED
)
13301 assert (!ffesymbol_retractable ());
13303 #if 0 /* GCC doesn't commit any backtrackable sins,
13304 so nothing needed here. */
13305 switch (ffesymbol_hook (s
).state
)
13307 case 0: /* nothing happened yet. */
13310 case 1: /* exec transition happened. */
13313 case 2: /* learned happened. */
13316 case 3: /* learned then exec. */
13319 case 4: /* exec then learned. */
13323 assert ("bad hook state" == NULL
);
13330 /* Create temporary gcc label. */
13332 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13334 ffecom_temp_label ()
13337 static int mynumber
= 0;
13339 glabel
= build_decl (LABEL_DECL
,
13340 ffecom_get_invented_identifier ("__g77_label_%d",
13343 DECL_CONTEXT (glabel
) = current_function_decl
;
13344 DECL_MODE (glabel
) = VOIDmode
;
13350 /* Return an expression that is usable as an arg in a conditional context
13351 (IF, DO WHILE, .NOT., and so on).
13353 Use the one provided for the back end as of >2.6.0. */
13355 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13357 ffecom_truth_value (tree expr
)
13359 return truthvalue_conversion (expr
);
13363 /* Return the inversion of a truth value (the inversion of what
13364 ffecom_truth_value builds).
13366 Apparently invert_truthvalue, which is properly in the back end, is
13367 enough for now, so just use it. */
13369 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13371 ffecom_truth_value_invert (tree expr
)
13373 return invert_truthvalue (ffecom_truth_value (expr
));
13378 /* Return the tree that is the type of the expression, as would be
13379 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13380 transforming the expression, generating temporaries, etc. */
13383 ffecom_type_expr (ffebld expr
)
13385 ffeinfoBasictype bt
;
13386 ffeinfoKindtype kt
;
13389 assert (expr
!= NULL
);
13391 bt
= ffeinfo_basictype (ffebld_info (expr
));
13392 kt
= ffeinfo_kindtype (ffebld_info (expr
));
13393 tree_type
= ffecom_tree_type
[bt
][kt
];
13395 switch (ffebld_op (expr
))
13397 case FFEBLD_opCONTER
:
13398 case FFEBLD_opSYMTER
:
13399 case FFEBLD_opARRAYREF
:
13400 case FFEBLD_opUPLUS
:
13401 case FFEBLD_opPAREN
:
13402 case FFEBLD_opUMINUS
:
13404 case FFEBLD_opSUBTRACT
:
13405 case FFEBLD_opMULTIPLY
:
13406 case FFEBLD_opDIVIDE
:
13407 case FFEBLD_opPOWER
:
13409 case FFEBLD_opFUNCREF
:
13410 case FFEBLD_opSUBRREF
:
13414 case FFEBLD_opNEQV
:
13416 case FFEBLD_opCONVERT
:
13423 case FFEBLD_opPERCENT_LOC
:
13426 case FFEBLD_opACCTER
:
13427 case FFEBLD_opARRTER
:
13428 case FFEBLD_opITEM
:
13429 case FFEBLD_opSTAR
:
13430 case FFEBLD_opBOUNDS
:
13431 case FFEBLD_opREPEAT
:
13432 case FFEBLD_opLABTER
:
13433 case FFEBLD_opLABTOK
:
13434 case FFEBLD_opIMPDO
:
13435 case FFEBLD_opCONCATENATE
:
13436 case FFEBLD_opSUBSTR
:
13438 assert ("bad op for ffecom_type_expr" == NULL
);
13439 /* Fall through. */
13441 return error_mark_node
;
13445 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13447 If the PARM_DECL already exists, return it, else create it. It's an
13448 integer_type_node argument for the master function that implements a
13449 subroutine or function with more than one entrypoint and is bound at
13450 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13451 first ENTRY statement, and so on). */
13453 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13455 ffecom_which_entrypoint_decl ()
13457 assert (ffecom_which_entrypoint_decl_
!= NULL_TREE
);
13459 return ffecom_which_entrypoint_decl_
;
13464 /* The following sections consists of private and public functions
13465 that have the same names and perform roughly the same functions
13466 as counterparts in the C front end. Changes in the C front end
13467 might affect how things should be done here. Only functions
13468 needed by the back end should be public here; the rest should
13469 be private (static in the C sense). Functions needed by other
13470 g77 front-end modules should be accessed by them via public
13471 ffecom_* names, which should themselves call private versions
13472 in this section so the private versions are easy to recognize
13473 when upgrading to a new gcc and finding interesting changes
13476 Functions named after rule "foo:" in c-parse.y are named
13477 "bison_rule_foo_" so they are easy to find. */
13479 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13482 bison_rule_pushlevel_ ()
13484 emit_line_note (input_filename
, lineno
);
13486 clear_last_expr ();
13487 expand_start_bindings (0);
13491 bison_rule_compstmt_ ()
13494 int keep
= kept_level_p ();
13496 /* Make the temps go away. */
13498 current_binding_level
->names
= NULL_TREE
;
13500 emit_line_note (input_filename
, lineno
);
13501 expand_end_bindings (getdecls (), keep
, 0);
13502 t
= poplevel (keep
, 1, 0);
13507 /* Return a definition for a builtin function named NAME and whose data type
13508 is TYPE. TYPE should be a function type with argument types.
13509 FUNCTION_CODE tells later passes how to compile calls to this function.
13510 See tree.h for its possible values.
13512 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13513 the name to be called if we can't opencode the function. */
13516 builtin_function (const char *name
, tree type
, int function_code
,
13517 enum built_in_class
class,
13518 const char *library_name
)
13520 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
13521 DECL_EXTERNAL (decl
) = 1;
13522 TREE_PUBLIC (decl
) = 1;
13524 SET_DECL_ASSEMBLER_NAME (decl
, get_identifier (library_name
));
13525 make_decl_rtl (decl
, NULL
);
13527 DECL_BUILT_IN_CLASS (decl
) = class;
13528 DECL_FUNCTION_CODE (decl
) = function_code
;
13533 /* Handle when a new declaration NEWDECL
13534 has the same name as an old one OLDDECL
13535 in the same binding contour.
13536 Prints an error message if appropriate.
13538 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13539 Otherwise, return 0. */
13542 duplicate_decls (tree newdecl
, tree olddecl
)
13544 int types_match
= 1;
13545 int new_is_definition
= (TREE_CODE (newdecl
) == FUNCTION_DECL
13546 && DECL_INITIAL (newdecl
) != 0);
13547 tree oldtype
= TREE_TYPE (olddecl
);
13548 tree newtype
= TREE_TYPE (newdecl
);
13550 if (olddecl
== newdecl
)
13553 if (TREE_CODE (newtype
) == ERROR_MARK
13554 || TREE_CODE (oldtype
) == ERROR_MARK
)
13557 /* New decl is completely inconsistent with the old one =>
13558 tell caller to replace the old one.
13559 This is always an error except in the case of shadowing a builtin. */
13560 if (TREE_CODE (olddecl
) != TREE_CODE (newdecl
))
13563 /* For real parm decl following a forward decl,
13564 return 1 so old decl will be reused. */
13565 if (types_match
&& TREE_CODE (newdecl
) == PARM_DECL
13566 && TREE_ASM_WRITTEN (olddecl
) && ! TREE_ASM_WRITTEN (newdecl
))
13569 /* The new declaration is the same kind of object as the old one.
13570 The declarations may partially match. Print warnings if they don't
13571 match enough. Ultimately, copy most of the information from the new
13572 decl to the old one, and keep using the old one. */
13574 if (TREE_CODE (olddecl
) == FUNCTION_DECL
13575 && DECL_BUILT_IN (olddecl
))
13577 /* A function declaration for a built-in function. */
13578 if (!TREE_PUBLIC (newdecl
))
13580 else if (!types_match
)
13582 /* Accept the return type of the new declaration if same modes. */
13583 tree oldreturntype
= TREE_TYPE (TREE_TYPE (olddecl
));
13584 tree newreturntype
= TREE_TYPE (TREE_TYPE (newdecl
));
13586 if (TYPE_MODE (oldreturntype
) == TYPE_MODE (newreturntype
))
13588 /* Function types may be shared, so we can't just modify
13589 the return type of olddecl's function type. */
13591 = build_function_type (newreturntype
,
13592 TYPE_ARG_TYPES (TREE_TYPE (olddecl
)));
13596 TREE_TYPE (olddecl
) = newtype
;
13602 else if (TREE_CODE (olddecl
) == FUNCTION_DECL
13603 && DECL_SOURCE_LINE (olddecl
) == 0)
13605 /* A function declaration for a predeclared function
13606 that isn't actually built in. */
13607 if (!TREE_PUBLIC (newdecl
))
13609 else if (!types_match
)
13611 /* If the types don't match, preserve volatility indication.
13612 Later on, we will discard everything else about the
13613 default declaration. */
13614 TREE_THIS_VOLATILE (newdecl
) |= TREE_THIS_VOLATILE (olddecl
);
13618 /* Copy all the DECL_... slots specified in the new decl
13619 except for any that we copy here from the old type.
13621 Past this point, we don't change OLDTYPE and NEWTYPE
13622 even if we change the types of NEWDECL and OLDDECL. */
13626 /* Merge the data types specified in the two decls. */
13627 if (TREE_CODE (newdecl
) != FUNCTION_DECL
|| !DECL_BUILT_IN (olddecl
))
13628 TREE_TYPE (newdecl
)
13629 = TREE_TYPE (olddecl
)
13630 = TREE_TYPE (newdecl
);
13632 /* Lay the type out, unless already done. */
13633 if (oldtype
!= TREE_TYPE (newdecl
))
13635 if (TREE_TYPE (newdecl
) != error_mark_node
)
13636 layout_type (TREE_TYPE (newdecl
));
13637 if (TREE_CODE (newdecl
) != FUNCTION_DECL
13638 && TREE_CODE (newdecl
) != TYPE_DECL
13639 && TREE_CODE (newdecl
) != CONST_DECL
)
13640 layout_decl (newdecl
, 0);
13644 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13645 DECL_SIZE (newdecl
) = DECL_SIZE (olddecl
);
13646 DECL_SIZE_UNIT (newdecl
) = DECL_SIZE_UNIT (olddecl
);
13647 if (TREE_CODE (olddecl
) != FUNCTION_DECL
)
13648 if (DECL_ALIGN (olddecl
) > DECL_ALIGN (newdecl
))
13650 DECL_ALIGN (newdecl
) = DECL_ALIGN (olddecl
);
13651 DECL_USER_ALIGN (newdecl
) |= DECL_USER_ALIGN (olddecl
);
13655 /* Keep the old rtl since we can safely use it. */
13656 COPY_DECL_RTL (olddecl
, newdecl
);
13658 /* Merge the type qualifiers. */
13659 if (DECL_BUILT_IN_NONANSI (olddecl
) && TREE_THIS_VOLATILE (olddecl
)
13660 && !TREE_THIS_VOLATILE (newdecl
))
13661 TREE_THIS_VOLATILE (olddecl
) = 0;
13662 if (TREE_READONLY (newdecl
))
13663 TREE_READONLY (olddecl
) = 1;
13664 if (TREE_THIS_VOLATILE (newdecl
))
13666 TREE_THIS_VOLATILE (olddecl
) = 1;
13667 if (TREE_CODE (newdecl
) == VAR_DECL
)
13668 make_var_volatile (newdecl
);
13671 /* Keep source location of definition rather than declaration.
13672 Likewise, keep decl at outer scope. */
13673 if ((DECL_INITIAL (newdecl
) == 0 && DECL_INITIAL (olddecl
) != 0)
13674 || (DECL_CONTEXT (newdecl
) != 0 && DECL_CONTEXT (olddecl
) == 0))
13676 DECL_SOURCE_LINE (newdecl
) = DECL_SOURCE_LINE (olddecl
);
13677 DECL_SOURCE_FILE (newdecl
) = DECL_SOURCE_FILE (olddecl
);
13679 if (DECL_CONTEXT (olddecl
) == 0
13680 && TREE_CODE (newdecl
) != FUNCTION_DECL
)
13681 DECL_CONTEXT (newdecl
) = 0;
13684 /* Merge the unused-warning information. */
13685 if (DECL_IN_SYSTEM_HEADER (olddecl
))
13686 DECL_IN_SYSTEM_HEADER (newdecl
) = 1;
13687 else if (DECL_IN_SYSTEM_HEADER (newdecl
))
13688 DECL_IN_SYSTEM_HEADER (olddecl
) = 1;
13690 /* Merge the initialization information. */
13691 if (DECL_INITIAL (newdecl
) == 0)
13692 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13694 /* Merge the section attribute.
13695 We want to issue an error if the sections conflict but that must be
13696 done later in decl_attributes since we are called before attributes
13698 if (DECL_SECTION_NAME (newdecl
) == NULL_TREE
)
13699 DECL_SECTION_NAME (newdecl
) = DECL_SECTION_NAME (olddecl
);
13702 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13704 DECL_STATIC_CONSTRUCTOR(newdecl
) |= DECL_STATIC_CONSTRUCTOR(olddecl
);
13705 DECL_STATIC_DESTRUCTOR (newdecl
) |= DECL_STATIC_DESTRUCTOR (olddecl
);
13709 /* If cannot merge, then use the new type and qualifiers,
13710 and don't preserve the old rtl. */
13713 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13714 TREE_READONLY (olddecl
) = TREE_READONLY (newdecl
);
13715 TREE_THIS_VOLATILE (olddecl
) = TREE_THIS_VOLATILE (newdecl
);
13716 TREE_SIDE_EFFECTS (olddecl
) = TREE_SIDE_EFFECTS (newdecl
);
13719 /* Merge the storage class information. */
13720 /* For functions, static overrides non-static. */
13721 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13723 TREE_PUBLIC (newdecl
) &= TREE_PUBLIC (olddecl
);
13724 /* This is since we don't automatically
13725 copy the attributes of NEWDECL into OLDDECL. */
13726 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13727 /* If this clears `static', clear it in the identifier too. */
13728 if (! TREE_PUBLIC (olddecl
))
13729 TREE_PUBLIC (DECL_NAME (olddecl
)) = 0;
13731 if (DECL_EXTERNAL (newdecl
))
13733 TREE_STATIC (newdecl
) = TREE_STATIC (olddecl
);
13734 DECL_EXTERNAL (newdecl
) = DECL_EXTERNAL (olddecl
);
13735 /* An extern decl does not override previous storage class. */
13736 TREE_PUBLIC (newdecl
) = TREE_PUBLIC (olddecl
);
13740 TREE_STATIC (olddecl
) = TREE_STATIC (newdecl
);
13741 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13744 /* If either decl says `inline', this fn is inline,
13745 unless its definition was passed already. */
13746 if (DECL_INLINE (newdecl
) && DECL_INITIAL (olddecl
) == 0)
13747 DECL_INLINE (olddecl
) = 1;
13748 DECL_INLINE (newdecl
) = DECL_INLINE (olddecl
);
13750 /* Get rid of any built-in function if new arg types don't match it
13751 or if we have a function definition. */
13752 if (TREE_CODE (newdecl
) == FUNCTION_DECL
13753 && DECL_BUILT_IN (olddecl
)
13754 && (!types_match
|| new_is_definition
))
13756 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13757 DECL_BUILT_IN_CLASS (olddecl
) = NOT_BUILT_IN
;
13760 /* If redeclaring a builtin function, and not a definition,
13762 Also preserve various other info from the definition. */
13763 if (TREE_CODE (newdecl
) == FUNCTION_DECL
&& !new_is_definition
)
13765 if (DECL_BUILT_IN (olddecl
))
13767 DECL_BUILT_IN_CLASS (newdecl
) = DECL_BUILT_IN_CLASS (olddecl
);
13768 DECL_FUNCTION_CODE (newdecl
) = DECL_FUNCTION_CODE (olddecl
);
13771 DECL_RESULT (newdecl
) = DECL_RESULT (olddecl
);
13772 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13773 DECL_SAVED_INSNS (newdecl
) = DECL_SAVED_INSNS (olddecl
);
13774 DECL_ARGUMENTS (newdecl
) = DECL_ARGUMENTS (olddecl
);
13777 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13778 But preserve olddecl's DECL_UID. */
13780 register unsigned olddecl_uid
= DECL_UID (olddecl
);
13782 memcpy ((char *) olddecl
+ sizeof (struct tree_common
),
13783 (char *) newdecl
+ sizeof (struct tree_common
),
13784 sizeof (struct tree_decl
) - sizeof (struct tree_common
));
13785 DECL_UID (olddecl
) = olddecl_uid
;
13791 /* Finish processing of a declaration;
13792 install its initial value.
13793 If the length of an array type is not known before,
13794 it must be determined now, from the initial value, or it is an error. */
13797 finish_decl (tree decl
, tree init
, bool is_top_level
)
13799 register tree type
= TREE_TYPE (decl
);
13800 int was_incomplete
= (DECL_SIZE (decl
) == 0);
13801 bool at_top_level
= (current_binding_level
== global_binding_level
);
13802 bool top_level
= is_top_level
|| at_top_level
;
13804 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13806 assert (!is_top_level
|| !at_top_level
);
13808 if (TREE_CODE (decl
) == PARM_DECL
)
13809 assert (init
== NULL_TREE
);
13810 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13811 overlaps DECL_ARG_TYPE. */
13812 else if (init
== NULL_TREE
)
13813 assert (DECL_INITIAL (decl
) == NULL_TREE
);
13815 assert (DECL_INITIAL (decl
) == error_mark_node
);
13817 if (init
!= NULL_TREE
)
13819 if (TREE_CODE (decl
) != TYPE_DECL
)
13820 DECL_INITIAL (decl
) = init
;
13823 /* typedef foo = bar; store the type of bar as the type of foo. */
13824 TREE_TYPE (decl
) = TREE_TYPE (init
);
13825 DECL_INITIAL (decl
) = init
= 0;
13829 /* Deduce size of array from initialization, if not already known */
13831 if (TREE_CODE (type
) == ARRAY_TYPE
13832 && TYPE_DOMAIN (type
) == 0
13833 && TREE_CODE (decl
) != TYPE_DECL
)
13835 assert (top_level
);
13836 assert (was_incomplete
);
13838 layout_decl (decl
, 0);
13841 if (TREE_CODE (decl
) == VAR_DECL
)
13843 if (DECL_SIZE (decl
) == NULL_TREE
13844 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
13845 layout_decl (decl
, 0);
13847 if (DECL_SIZE (decl
) == NULL_TREE
13848 && (TREE_STATIC (decl
)
13850 /* A static variable with an incomplete type is an error if it is
13851 initialized. Also if it is not file scope. Otherwise, let it
13852 through, but if it is not `extern' then it may cause an error
13854 (DECL_INITIAL (decl
) != 0 || DECL_CONTEXT (decl
) != 0)
13856 /* An automatic variable with an incomplete type is an error. */
13857 !DECL_EXTERNAL (decl
)))
13859 assert ("storage size not known" == NULL
);
13863 if ((DECL_EXTERNAL (decl
) || TREE_STATIC (decl
))
13864 && (DECL_SIZE (decl
) != 0)
13865 && (TREE_CODE (DECL_SIZE (decl
)) != INTEGER_CST
))
13867 assert ("storage size not constant" == NULL
);
13872 /* Output the assembler code and/or RTL code for variables and functions,
13873 unless the type is an undefined structure or union. If not, it will get
13874 done when the type is completed. */
13876 if (TREE_CODE (decl
) == VAR_DECL
|| TREE_CODE (decl
) == FUNCTION_DECL
)
13878 rest_of_decl_compilation (decl
, NULL
,
13879 DECL_CONTEXT (decl
) == 0,
13882 if (DECL_CONTEXT (decl
) != 0)
13884 /* Recompute the RTL of a local array now if it used to be an
13885 incomplete type. */
13887 && !TREE_STATIC (decl
) && !DECL_EXTERNAL (decl
))
13889 /* If we used it already as memory, it must stay in memory. */
13890 TREE_ADDRESSABLE (decl
) = TREE_USED (decl
);
13891 /* If it's still incomplete now, no init will save it. */
13892 if (DECL_SIZE (decl
) == 0)
13893 DECL_INITIAL (decl
) = 0;
13894 expand_decl (decl
);
13896 /* Compute and store the initial value. */
13897 if (TREE_CODE (decl
) != FUNCTION_DECL
)
13898 expand_decl_init (decl
);
13901 else if (TREE_CODE (decl
) == TYPE_DECL
)
13903 rest_of_decl_compilation (decl
, NULL
,
13904 DECL_CONTEXT (decl
) == 0,
13908 /* At the end of a declaration, throw away any variable type sizes of types
13909 defined inside that declaration. There is no use computing them in the
13910 following function definition. */
13911 if (current_binding_level
== global_binding_level
)
13912 get_pending_sizes ();
13915 /* Finish up a function declaration and compile that function
13916 all the way to assembler language output. The free the storage
13917 for the function definition.
13919 This is called after parsing the body of the function definition.
13921 NESTED is nonzero if the function being finished is nested in another. */
13924 finish_function (int nested
)
13926 register tree fndecl
= current_function_decl
;
13928 assert (fndecl
!= NULL_TREE
);
13929 if (TREE_CODE (fndecl
) != ERROR_MARK
)
13932 assert (DECL_CONTEXT (fndecl
) != NULL_TREE
);
13934 assert (DECL_CONTEXT (fndecl
) == NULL_TREE
);
13937 /* TREE_READONLY (fndecl) = 1;
13938 This caused &foo to be of type ptr-to-const-function
13939 which then got a warning when stored in a ptr-to-function variable. */
13941 poplevel (1, 0, 1);
13943 if (TREE_CODE (fndecl
) != ERROR_MARK
)
13945 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
13947 /* Must mark the RESULT_DECL as being in this function. */
13949 DECL_CONTEXT (DECL_RESULT (fndecl
)) = fndecl
;
13951 /* Obey `register' declarations if `setjmp' is called in this fn. */
13952 /* Generate rtl for function exit. */
13953 expand_function_end (input_filename
, lineno
, 0);
13955 /* If this is a nested function, protect the local variables in the stack
13956 above us from being collected while we're compiling this function. */
13958 ggc_push_context ();
13960 /* Run the optimizers and output the assembler code for this function. */
13961 rest_of_compilation (fndecl
);
13963 /* Undo the GC context switch. */
13965 ggc_pop_context ();
13968 if (TREE_CODE (fndecl
) != ERROR_MARK
13970 && DECL_SAVED_INSNS (fndecl
) == 0)
13972 /* Stop pointing to the local nodes about to be freed. */
13973 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13974 function definition. */
13975 /* For a nested function, this is done in pop_f_function_context. */
13976 /* If rest_of_compilation set this to 0, leave it 0. */
13977 if (DECL_INITIAL (fndecl
) != 0)
13978 DECL_INITIAL (fndecl
) = error_mark_node
;
13979 DECL_ARGUMENTS (fndecl
) = 0;
13984 /* Let the error reporting routines know that we're outside a function.
13985 For a nested function, this value is used in pop_c_function_context
13986 and then reset via pop_function_context. */
13987 ffecom_outer_function_decl_
= current_function_decl
= NULL
;
13991 /* Plug-in replacement for identifying the name of a decl and, for a
13992 function, what we call it in diagnostics. For now, "program unit"
13993 should suffice, since it's a bit of a hassle to figure out which
13994 of several kinds of things it is. Note that it could conceivably
13995 be a statement function, which probably isn't really a program unit
13996 per se, but if that comes up, it should be easy to check (being a
13997 nested function and all). */
13999 static const char *
14000 lang_printable_name (tree decl
, int v
)
14002 /* Just to keep GCC quiet about the unused variable.
14003 In theory, differing values of V should produce different
14008 if (TREE_CODE (decl
) == ERROR_MARK
)
14009 return "erroneous code";
14010 return IDENTIFIER_POINTER (DECL_NAME (decl
));
14014 /* g77's function to print out name of current function that caused
14019 lang_print_error_function (diagnostic_context
*context
__attribute__((unused
)),
14022 static ffeglobal last_g
= NULL
;
14023 static ffesymbol last_s
= NULL
;
14028 if ((ffecom_primary_entry_
== NULL
)
14029 || (ffesymbol_global (ffecom_primary_entry_
) == NULL
))
14037 g
= ffesymbol_global (ffecom_primary_entry_
);
14038 if (ffecom_nested_entry_
== NULL
)
14040 s
= ffecom_primary_entry_
;
14041 switch (ffesymbol_kind (s
))
14043 case FFEINFO_kindFUNCTION
:
14047 case FFEINFO_kindSUBROUTINE
:
14048 kind
= "subroutine";
14051 case FFEINFO_kindPROGRAM
:
14055 case FFEINFO_kindBLOCKDATA
:
14056 kind
= "block-data";
14060 kind
= ffeinfo_kind_message (ffesymbol_kind (s
));
14066 s
= ffecom_nested_entry_
;
14067 kind
= "statement function";
14071 if ((last_g
!= g
) || (last_s
!= s
))
14074 fprintf (stderr
, "%s: ", file
);
14077 fprintf (stderr
, "Outside of any program unit:\n");
14080 const char *name
= ffesymbol_text (s
);
14082 fprintf (stderr
, "In %s `%s':\n", kind
, name
);
14091 /* Similar to `lookup_name' but look only at current binding level. */
14094 lookup_name_current_level (tree name
)
14098 if (current_binding_level
== global_binding_level
)
14099 return IDENTIFIER_GLOBAL_VALUE (name
);
14101 if (IDENTIFIER_LOCAL_VALUE (name
) == 0)
14104 for (t
= current_binding_level
->names
; t
; t
= TREE_CHAIN (t
))
14105 if (DECL_NAME (t
) == name
)
14111 /* Create a new `struct binding_level'. */
14113 static struct binding_level
*
14114 make_binding_level ()
14117 return (struct binding_level
*) xmalloc (sizeof (struct binding_level
));
14120 /* Save and restore the variables in this file and elsewhere
14121 that keep track of the progress of compilation of the current function.
14122 Used for nested functions. */
14126 struct f_function
*next
;
14128 tree shadowed_labels
;
14129 struct binding_level
*binding_level
;
14132 struct f_function
*f_function_chain
;
14134 /* Restore the variables used during compilation of a C function. */
14137 pop_f_function_context ()
14139 struct f_function
*p
= f_function_chain
;
14142 /* Bring back all the labels that were shadowed. */
14143 for (link
= shadowed_labels
; link
; link
= TREE_CHAIN (link
))
14144 if (DECL_NAME (TREE_VALUE (link
)) != 0)
14145 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link
)))
14146 = TREE_VALUE (link
);
14148 if (current_function_decl
!= error_mark_node
14149 && DECL_SAVED_INSNS (current_function_decl
) == 0)
14151 /* Stop pointing to the local nodes about to be freed. */
14152 /* But DECL_INITIAL must remain nonzero so we know this was an actual
14153 function definition. */
14154 DECL_INITIAL (current_function_decl
) = error_mark_node
;
14155 DECL_ARGUMENTS (current_function_decl
) = 0;
14158 pop_function_context ();
14160 f_function_chain
= p
->next
;
14162 named_labels
= p
->named_labels
;
14163 shadowed_labels
= p
->shadowed_labels
;
14164 current_binding_level
= p
->binding_level
;
14169 /* Save and reinitialize the variables
14170 used during compilation of a C function. */
14173 push_f_function_context ()
14175 struct f_function
*p
14176 = (struct f_function
*) xmalloc (sizeof (struct f_function
));
14178 push_function_context ();
14180 p
->next
= f_function_chain
;
14181 f_function_chain
= p
;
14183 p
->named_labels
= named_labels
;
14184 p
->shadowed_labels
= shadowed_labels
;
14185 p
->binding_level
= current_binding_level
;
14189 push_parm_decl (tree parm
)
14191 int old_immediate_size_expand
= immediate_size_expand
;
14193 /* Don't try computing parm sizes now -- wait till fn is called. */
14195 immediate_size_expand
= 0;
14197 /* Fill in arg stuff. */
14199 DECL_ARG_TYPE (parm
) = TREE_TYPE (parm
);
14200 DECL_ARG_TYPE_AS_WRITTEN (parm
) = TREE_TYPE (parm
);
14201 TREE_READONLY (parm
) = 1; /* All implementation args are read-only. */
14203 parm
= pushdecl (parm
);
14205 immediate_size_expand
= old_immediate_size_expand
;
14207 finish_decl (parm
, NULL_TREE
, FALSE
);
14210 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
14213 pushdecl_top_level (x
)
14217 register struct binding_level
*b
= current_binding_level
;
14218 register tree f
= current_function_decl
;
14220 current_binding_level
= global_binding_level
;
14221 current_function_decl
= NULL_TREE
;
14223 current_binding_level
= b
;
14224 current_function_decl
= f
;
14228 /* Store the list of declarations of the current level.
14229 This is done for the parameter declarations of a function being defined,
14230 after they are modified in the light of any missing parameters. */
14236 return current_binding_level
->names
= decls
;
14239 /* Store the parameter declarations into the current function declaration.
14240 This is called after parsing the parameter declarations, before
14241 digesting the body of the function.
14243 For an old-style definition, modify the function's type
14244 to specify at least the number of arguments. */
14247 store_parm_decls (int is_main_program UNUSED
)
14249 register tree fndecl
= current_function_decl
;
14251 if (fndecl
== error_mark_node
)
14254 /* This is a chain of PARM_DECLs from old-style parm declarations. */
14255 DECL_ARGUMENTS (fndecl
) = storedecls (nreverse (getdecls ()));
14257 /* Initialize the RTL code for the function. */
14259 init_function_start (fndecl
, input_filename
, lineno
);
14261 /* Set up parameters and prepare for return, for the function. */
14263 expand_function_start (fndecl
, 0);
14267 start_decl (tree decl
, bool is_top_level
)
14270 bool at_top_level
= (current_binding_level
== global_binding_level
);
14271 bool top_level
= is_top_level
|| at_top_level
;
14273 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14275 assert (!is_top_level
|| !at_top_level
);
14277 if (DECL_INITIAL (decl
) != NULL_TREE
)
14279 assert (DECL_INITIAL (decl
) == error_mark_node
);
14280 assert (!DECL_EXTERNAL (decl
));
14282 else if (top_level
)
14283 assert ((TREE_STATIC (decl
) == 1) || DECL_EXTERNAL (decl
) == 1);
14285 /* For Fortran, we by default put things in .common when possible. */
14286 DECL_COMMON (decl
) = 1;
14288 /* Add this decl to the current binding level. TEM may equal DECL or it may
14289 be a previous decl of the same name. */
14291 tem
= pushdecl_top_level (decl
);
14293 tem
= pushdecl (decl
);
14295 /* For a local variable, define the RTL now. */
14297 /* But not if this is a duplicate decl and we preserved the rtl from the
14298 previous one (which may or may not happen). */
14299 && !DECL_RTL_SET_P (tem
))
14301 if (TYPE_SIZE (TREE_TYPE (tem
)) != 0)
14303 else if (TREE_CODE (TREE_TYPE (tem
)) == ARRAY_TYPE
14304 && DECL_INITIAL (tem
) != 0)
14311 /* Create the FUNCTION_DECL for a function definition.
14312 DECLSPECS and DECLARATOR are the parts of the declaration;
14313 they describe the function's name and the type it returns,
14314 but twisted together in a fashion that parallels the syntax of C.
14316 This function creates a binding context for the function body
14317 as well as setting up the FUNCTION_DECL in current_function_decl.
14319 Returns 1 on success. If the DECLARATOR is not suitable for a function
14320 (it defines a datum instead), we return 0, which tells
14321 yyparse to report a parse error.
14323 NESTED is nonzero for a function nested within another function. */
14326 start_function (tree name
, tree type
, int nested
, int public)
14330 int old_immediate_size_expand
= immediate_size_expand
;
14333 shadowed_labels
= 0;
14335 /* Don't expand any sizes in the return type of the function. */
14336 immediate_size_expand
= 0;
14341 assert (current_function_decl
!= NULL_TREE
);
14342 assert (DECL_CONTEXT (current_function_decl
) == NULL_TREE
);
14346 assert (current_function_decl
== NULL_TREE
);
14349 if (TREE_CODE (type
) == ERROR_MARK
)
14350 decl1
= current_function_decl
= error_mark_node
;
14353 decl1
= build_decl (FUNCTION_DECL
,
14356 TREE_PUBLIC (decl1
) = public ? 1 : 0;
14358 DECL_INLINE (decl1
) = 1;
14359 TREE_STATIC (decl1
) = 1;
14360 DECL_EXTERNAL (decl1
) = 0;
14362 announce_function (decl1
);
14364 /* Make the init_value nonzero so pushdecl knows this is not tentative.
14365 error_mark_node is replaced below (in poplevel) with the BLOCK. */
14366 DECL_INITIAL (decl1
) = error_mark_node
;
14368 /* Record the decl so that the function name is defined. If we already have
14369 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
14371 current_function_decl
= pushdecl (decl1
);
14375 ffecom_outer_function_decl_
= current_function_decl
;
14378 current_binding_level
->prep_state
= 2;
14380 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
14382 make_decl_rtl (current_function_decl
, NULL
);
14384 restype
= TREE_TYPE (TREE_TYPE (current_function_decl
));
14385 DECL_RESULT (current_function_decl
)
14386 = build_decl (RESULT_DECL
, NULL_TREE
, restype
);
14389 if (!nested
&& (TREE_CODE (current_function_decl
) != ERROR_MARK
))
14390 TREE_ADDRESSABLE (current_function_decl
) = 1;
14392 immediate_size_expand
= old_immediate_size_expand
;
14395 /* Here are the public functions the GNU back end needs. */
14398 convert (type
, expr
)
14401 register tree e
= expr
;
14402 register enum tree_code code
= TREE_CODE (type
);
14404 if (type
== TREE_TYPE (e
)
14405 || TREE_CODE (e
) == ERROR_MARK
)
14407 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
14408 return fold (build1 (NOP_EXPR
, type
, e
));
14409 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
14410 || code
== ERROR_MARK
)
14411 return error_mark_node
;
14412 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
14414 assert ("void value not ignored as it ought to be" == NULL
);
14415 return error_mark_node
;
14417 if (code
== VOID_TYPE
)
14418 return build1 (CONVERT_EXPR
, type
, e
);
14419 if ((code
!= RECORD_TYPE
)
14420 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
14421 e
= ffecom_1 (REALPART_EXPR
, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
))),
14423 if (code
== INTEGER_TYPE
|| code
== ENUMERAL_TYPE
)
14424 return fold (convert_to_integer (type
, e
));
14425 if (code
== POINTER_TYPE
)
14426 return fold (convert_to_pointer (type
, e
));
14427 if (code
== REAL_TYPE
)
14428 return fold (convert_to_real (type
, e
));
14429 if (code
== COMPLEX_TYPE
)
14430 return fold (convert_to_complex (type
, e
));
14431 if (code
== RECORD_TYPE
)
14432 return fold (ffecom_convert_to_complex_ (type
, e
));
14434 assert ("conversion to non-scalar type requested" == NULL
);
14435 return error_mark_node
;
14438 /* integrate_decl_tree calls this function, but since we don't use the
14439 DECL_LANG_SPECIFIC field, this is a no-op. */
14442 copy_lang_decl (node
)
14447 /* Return the list of declarations of the current level.
14448 Note that this list is in reverse order unless/until
14449 you nreverse it; and when you do nreverse it, you must
14450 store the result back using `storedecls' or you will lose. */
14455 return current_binding_level
->names
;
14458 /* Nonzero if we are currently in the global binding level. */
14461 global_bindings_p ()
14463 return current_binding_level
== global_binding_level
;
14466 /* Print an error message for invalid use of an incomplete type.
14467 VALUE is the expression that was used (or 0 if that isn't known)
14468 and TYPE is the type that was invalid. */
14471 incomplete_type_error (value
, type
)
14475 if (TREE_CODE (type
) == ERROR_MARK
)
14478 assert ("incomplete type?!?" == NULL
);
14481 /* Mark ARG for GC. */
14483 mark_binding_level (void *arg
)
14485 struct binding_level
*level
= *(struct binding_level
**) arg
;
14489 ggc_mark_tree (level
->names
);
14490 ggc_mark_tree (level
->blocks
);
14491 ggc_mark_tree (level
->this_block
);
14492 level
= level
->level_chain
;
14497 init_decl_processing ()
14499 static tree
*const tree_roots
[] = {
14500 ¤t_function_decl
,
14502 &ffecom_tree_fun_type_void
,
14503 &ffecom_integer_zero_node
,
14504 &ffecom_integer_one_node
,
14505 &ffecom_tree_subr_type
,
14506 &ffecom_tree_ptr_to_subr_type
,
14507 &ffecom_tree_blockdata_type
,
14508 &ffecom_tree_xargc_
,
14509 &ffecom_f2c_integer_type_node
,
14510 &ffecom_f2c_ptr_to_integer_type_node
,
14511 &ffecom_f2c_address_type_node
,
14512 &ffecom_f2c_real_type_node
,
14513 &ffecom_f2c_ptr_to_real_type_node
,
14514 &ffecom_f2c_doublereal_type_node
,
14515 &ffecom_f2c_complex_type_node
,
14516 &ffecom_f2c_doublecomplex_type_node
,
14517 &ffecom_f2c_longint_type_node
,
14518 &ffecom_f2c_logical_type_node
,
14519 &ffecom_f2c_flag_type_node
,
14520 &ffecom_f2c_ftnlen_type_node
,
14521 &ffecom_f2c_ftnlen_zero_node
,
14522 &ffecom_f2c_ftnlen_one_node
,
14523 &ffecom_f2c_ftnlen_two_node
,
14524 &ffecom_f2c_ptr_to_ftnlen_type_node
,
14525 &ffecom_f2c_ftnint_type_node
,
14526 &ffecom_f2c_ptr_to_ftnint_type_node
,
14527 &ffecom_outer_function_decl_
,
14528 &ffecom_previous_function_decl_
,
14529 &ffecom_which_entrypoint_decl_
,
14530 &ffecom_float_zero_
,
14531 &ffecom_float_half_
,
14532 &ffecom_double_zero_
,
14533 &ffecom_double_half_
,
14534 &ffecom_func_result_
,
14535 &ffecom_func_length_
,
14536 &ffecom_multi_type_node_
,
14537 &ffecom_multi_retval_
,
14545 /* Record our roots. */
14546 for (i
= 0; i
< ARRAY_SIZE (tree_roots
); i
++)
14547 ggc_add_tree_root (tree_roots
[i
], 1);
14548 ggc_add_tree_root (&ffecom_tree_type
[0][0],
14549 FFEINFO_basictype
*FFEINFO_kindtype
);
14550 ggc_add_tree_root (&ffecom_tree_fun_type
[0][0],
14551 FFEINFO_basictype
*FFEINFO_kindtype
);
14552 ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type
[0][0],
14553 FFEINFO_basictype
*FFEINFO_kindtype
);
14554 ggc_add_tree_root (ffecom_gfrt_
, FFECOM_gfrt
);
14555 ggc_add_root (¤t_binding_level
, 1, sizeof current_binding_level
,
14556 mark_binding_level
);
14557 ggc_add_root (&free_binding_level
, 1, sizeof current_binding_level
,
14558 mark_binding_level
);
14559 ggc_add_root (&tracker_head
, 1, sizeof tracker_head
, mark_tracker_head
);
14565 init_parse (filename
)
14566 const char *filename
;
14568 /* Open input file. */
14569 if (filename
== 0 || !strcmp (filename
, "-"))
14572 filename
= "stdin";
14575 finput
= fopen (filename
, "r");
14577 fatal_io_error ("can't open %s", filename
);
14579 #ifdef IO_BUFFER_SIZE
14580 setvbuf (finput
, (char *) xmalloc (IO_BUFFER_SIZE
), _IOFBF
, IO_BUFFER_SIZE
);
14583 /* Make identifier nodes long enough for the language-specific slots. */
14584 set_identifier_size (sizeof (struct lang_identifier
));
14585 decl_printable_name
= lang_printable_name
;
14587 print_error_function
= lang_print_error_function
;
14599 /* Delete the node BLOCK from the current binding level.
14600 This is used for the block inside a stmt expr ({...})
14601 so that the block can be reinserted where appropriate. */
14604 delete_block (block
)
14608 if (current_binding_level
->blocks
== block
)
14609 current_binding_level
->blocks
= TREE_CHAIN (block
);
14610 for (t
= current_binding_level
->blocks
; t
;)
14612 if (TREE_CHAIN (t
) == block
)
14613 TREE_CHAIN (t
) = TREE_CHAIN (block
);
14615 t
= TREE_CHAIN (t
);
14617 TREE_CHAIN (block
) = NULL
;
14618 /* Clear TREE_USED which is always set by poplevel.
14619 The flag is set again if insert_block is called. */
14620 TREE_USED (block
) = 0;
14624 insert_block (block
)
14627 TREE_USED (block
) = 1;
14628 current_binding_level
->blocks
14629 = chainon (current_binding_level
->blocks
, block
);
14632 /* Each front end provides its own. */
14633 static void ffe_init
PARAMS ((void));
14634 static void ffe_finish
PARAMS ((void));
14635 static void ffe_init_options
PARAMS ((void));
14637 struct lang_hooks lang_hooks
= {ffe_init
,
14641 NULL
/* post_options */};
14643 /* used by print-tree.c */
14646 lang_print_xnode (file
, node
, indent
)
14656 ffe_terminate_0 ();
14658 if (ffe_is_ffedebug ())
14659 malloc_pool_display (malloc_pool_image ());
14668 /* Return the typed-based alias set for T, which may be an expression
14669 or a type. Return -1 if we don't do anything special. */
14672 lang_get_alias_set (t
)
14673 tree t ATTRIBUTE_UNUSED
;
14675 /* We do not wish to use alias-set based aliasing at all. Used in the
14676 extreme (every object with its own set, with equivalences recorded)
14677 it might be helpful, but there are problems when it comes to inlining.
14678 We get on ok with flag_argument_noalias, and alias-set aliasing does
14679 currently limit how stack slots can be reused, which is a lose. */
14684 ffe_init_options ()
14686 /* Set default options for Fortran. */
14687 flag_move_all_movables
= 1;
14688 flag_reduce_all_givs
= 1;
14689 flag_argument_noalias
= 2;
14690 flag_merge_constants
= 2;
14691 flag_errno_math
= 0;
14692 flag_complex_divide_method
= 1;
14698 /* If the file is output from cpp, it should contain a first line
14699 `# 1 "real-filename"', and the current design of gcc (toplev.c
14700 in particular and the way it sets up information relied on by
14701 INCLUDE) requires that we read this now, and store the
14702 "real-filename" info in master_input_filename. Ask the lexer
14703 to try doing this. */
14704 ffelex_hash_kludge (finput
);
14708 mark_addressable (exp
)
14711 register tree x
= exp
;
14713 switch (TREE_CODE (x
))
14716 case COMPONENT_REF
:
14718 x
= TREE_OPERAND (x
, 0);
14722 TREE_ADDRESSABLE (x
) = 1;
14729 if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
)
14730 && DECL_NONLOCAL (x
))
14732 if (TREE_PUBLIC (x
))
14734 assert ("address of global register var requested" == NULL
);
14737 assert ("address of register variable requested" == NULL
);
14739 else if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
))
14741 if (TREE_PUBLIC (x
))
14743 assert ("address of global register var requested" == NULL
);
14746 assert ("address of register var requested" == NULL
);
14748 put_var_into_stack (x
);
14751 case FUNCTION_DECL
:
14752 TREE_ADDRESSABLE (x
) = 1;
14753 #if 0 /* poplevel deals with this now. */
14754 if (DECL_CONTEXT (x
) == 0)
14755 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x
)) = 1;
14763 /* If DECL has a cleanup, build and return that cleanup here.
14764 This is a callback called by expand_expr. */
14767 maybe_build_cleanup (decl
)
14770 /* There are no cleanups in Fortran. */
14774 /* Exit a binding level.
14775 Pop the level off, and restore the state of the identifier-decl mappings
14776 that were in effect when this level was entered.
14778 If KEEP is nonzero, this level had explicit declarations, so
14779 and create a "block" (a BLOCK node) for the level
14780 to record its declarations and subblocks for symbol table output.
14782 If FUNCTIONBODY is nonzero, this level is the body of a function,
14783 so create a block as if KEEP were set and also clear out all
14786 If REVERSE is nonzero, reverse the order of decls before putting
14787 them into the BLOCK. */
14790 poplevel (keep
, reverse
, functionbody
)
14795 register tree link
;
14796 /* The chain of decls was accumulated in reverse order.
14797 Put it into forward order, just for cleanliness. */
14799 tree subblocks
= current_binding_level
->blocks
;
14802 int block_previously_created
;
14804 /* Get the decls in the order they were written.
14805 Usually current_binding_level->names is in reverse order.
14806 But parameter decls were previously put in forward order. */
14809 current_binding_level
->names
14810 = decls
= nreverse (current_binding_level
->names
);
14812 decls
= current_binding_level
->names
;
14814 /* Output any nested inline functions within this block
14815 if they weren't already output. */
14817 for (decl
= decls
; decl
; decl
= TREE_CHAIN (decl
))
14818 if (TREE_CODE (decl
) == FUNCTION_DECL
14819 && ! TREE_ASM_WRITTEN (decl
)
14820 && DECL_INITIAL (decl
) != 0
14821 && TREE_ADDRESSABLE (decl
))
14823 /* If this decl was copied from a file-scope decl
14824 on account of a block-scope extern decl,
14825 propagate TREE_ADDRESSABLE to the file-scope decl.
14827 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14828 true, since then the decl goes through save_for_inline_copying. */
14829 if (DECL_ABSTRACT_ORIGIN (decl
) != 0
14830 && DECL_ABSTRACT_ORIGIN (decl
) != decl
)
14831 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl
)) = 1;
14832 else if (DECL_SAVED_INSNS (decl
) != 0)
14834 push_function_context ();
14835 output_inline_function (decl
);
14836 pop_function_context ();
14840 /* If there were any declarations or structure tags in that level,
14841 or if this level is a function body,
14842 create a BLOCK to record them for the life of this function. */
14845 block_previously_created
= (current_binding_level
->this_block
!= 0);
14846 if (block_previously_created
)
14847 block
= current_binding_level
->this_block
;
14848 else if (keep
|| functionbody
)
14849 block
= make_node (BLOCK
);
14852 BLOCK_VARS (block
) = decls
;
14853 BLOCK_SUBBLOCKS (block
) = subblocks
;
14856 /* In each subblock, record that this is its superior. */
14858 for (link
= subblocks
; link
; link
= TREE_CHAIN (link
))
14859 BLOCK_SUPERCONTEXT (link
) = block
;
14861 /* Clear out the meanings of the local variables of this level. */
14863 for (link
= decls
; link
; link
= TREE_CHAIN (link
))
14865 if (DECL_NAME (link
) != 0)
14867 /* If the ident. was used or addressed via a local extern decl,
14868 don't forget that fact. */
14869 if (DECL_EXTERNAL (link
))
14871 if (TREE_USED (link
))
14872 TREE_USED (DECL_NAME (link
)) = 1;
14873 if (TREE_ADDRESSABLE (link
))
14874 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link
)) = 1;
14876 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link
)) = 0;
14880 /* If the level being exited is the top level of a function,
14881 check over all the labels, and clear out the current
14882 (function local) meanings of their names. */
14886 /* If this is the top level block of a function,
14887 the vars are the function's parameters.
14888 Don't leave them in the BLOCK because they are
14889 found in the FUNCTION_DECL instead. */
14891 BLOCK_VARS (block
) = 0;
14894 /* Pop the current level, and free the structure for reuse. */
14897 register struct binding_level
*level
= current_binding_level
;
14898 current_binding_level
= current_binding_level
->level_chain
;
14900 level
->level_chain
= free_binding_level
;
14901 free_binding_level
= level
;
14904 /* Dispose of the block that we just made inside some higher level. */
14906 && current_function_decl
!= error_mark_node
)
14907 DECL_INITIAL (current_function_decl
) = block
;
14910 if (!block_previously_created
)
14911 current_binding_level
->blocks
14912 = chainon (current_binding_level
->blocks
, block
);
14914 /* If we did not make a block for the level just exited,
14915 any blocks made for inner levels
14916 (since they cannot be recorded as subblocks in that level)
14917 must be carried forward so they will later become subblocks
14918 of something else. */
14919 else if (subblocks
)
14920 current_binding_level
->blocks
14921 = chainon (current_binding_level
->blocks
, subblocks
);
14924 TREE_USED (block
) = 1;
14929 print_lang_decl (file
, node
, indent
)
14937 print_lang_identifier (file
, node
, indent
)
14942 print_node (file
, "global", IDENTIFIER_GLOBAL_VALUE (node
), indent
+ 4);
14943 print_node (file
, "local", IDENTIFIER_LOCAL_VALUE (node
), indent
+ 4);
14947 print_lang_statistics ()
14952 print_lang_type (file
, node
, indent
)
14959 /* Record a decl-node X as belonging to the current lexical scope.
14960 Check for errors (such as an incompatible declaration for the same
14961 name already seen in the same scope).
14963 Returns either X or an old decl for the same name.
14964 If an old decl is returned, it may have been smashed
14965 to agree with what X says. */
14972 register tree name
= DECL_NAME (x
);
14973 register struct binding_level
*b
= current_binding_level
;
14975 if ((TREE_CODE (x
) == FUNCTION_DECL
)
14976 && (DECL_INITIAL (x
) == 0)
14977 && DECL_EXTERNAL (x
))
14978 DECL_CONTEXT (x
) = NULL_TREE
;
14980 DECL_CONTEXT (x
) = current_function_decl
;
14984 if (IDENTIFIER_INVENTED (name
))
14987 DECL_ARTIFICIAL (x
) = 1;
14989 DECL_IN_SYSTEM_HEADER (x
) = 1;
14992 t
= lookup_name_current_level (name
);
14994 assert ((t
== NULL_TREE
) || (DECL_CONTEXT (x
) == NULL_TREE
));
14996 /* Don't push non-parms onto list for parms until we understand
14997 why we're doing this and whether it works. */
14999 assert ((b
== global_binding_level
)
15000 || !ffecom_transform_only_dummies_
15001 || TREE_CODE (x
) == PARM_DECL
);
15003 if ((t
!= NULL_TREE
) && duplicate_decls (x
, t
))
15006 /* If we are processing a typedef statement, generate a whole new
15007 ..._TYPE node (which will be just an variant of the existing
15008 ..._TYPE node with identical properties) and then install the
15009 TYPE_DECL node generated to represent the typedef name as the
15010 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15012 The whole point here is to end up with a situation where each and every
15013 ..._TYPE node the compiler creates will be uniquely associated with
15014 AT MOST one node representing a typedef name. This way, even though
15015 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15016 (i.e. "typedef name") nodes very early on, later parts of the
15017 compiler can always do the reverse translation and get back the
15018 corresponding typedef name. For example, given:
15020 typedef struct S MY_TYPE; MY_TYPE object;
15022 Later parts of the compiler might only know that `object' was of type
15023 `struct S' if it were not for code just below. With this code
15024 however, later parts of the compiler see something like:
15026 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15028 And they can then deduce (from the node for type struct S') that the
15029 original object declaration was:
15033 Being able to do this is important for proper support of protoize, and
15034 also for generating precise symbolic debugging information which
15035 takes full account of the programmer's (typedef) vocabulary.
15037 Obviously, we don't want to generate a duplicate ..._TYPE node if the
15038 TYPE_DECL node that we are now processing really represents a
15039 standard built-in type.
15041 Since all standard types are effectively declared at line zero in the
15042 source file, we can easily check to see if we are working on a
15043 standard type by checking the current value of lineno. */
15045 if (TREE_CODE (x
) == TYPE_DECL
)
15047 if (DECL_SOURCE_LINE (x
) == 0)
15049 if (TYPE_NAME (TREE_TYPE (x
)) == 0)
15050 TYPE_NAME (TREE_TYPE (x
)) = x
;
15052 else if (TREE_TYPE (x
) != error_mark_node
)
15054 tree tt
= TREE_TYPE (x
);
15056 tt
= build_type_copy (tt
);
15057 TYPE_NAME (tt
) = x
;
15058 TREE_TYPE (x
) = tt
;
15062 /* This name is new in its binding level. Install the new declaration
15064 if (b
== global_binding_level
)
15065 IDENTIFIER_GLOBAL_VALUE (name
) = x
;
15067 IDENTIFIER_LOCAL_VALUE (name
) = x
;
15070 /* Put decls on list in reverse order. We will reverse them later if
15072 TREE_CHAIN (x
) = b
->names
;
15078 /* Nonzero if the current level needs to have a BLOCK made. */
15085 for (decl
= current_binding_level
->names
;
15087 decl
= TREE_CHAIN (decl
))
15089 if (TREE_USED (decl
) || TREE_CODE (decl
) != VAR_DECL
15090 || (DECL_NAME (decl
) && ! DECL_ARTIFICIAL (decl
)))
15091 /* Currently, there aren't supposed to be non-artificial names
15092 at other than the top block for a function -- they're
15093 believed to always be temps. But it's wise to check anyway. */
15099 /* Enter a new binding level.
15100 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15101 not for that of tags. */
15104 pushlevel (tag_transparent
)
15105 int tag_transparent
;
15107 register struct binding_level
*newlevel
= NULL_BINDING_LEVEL
;
15109 assert (! tag_transparent
);
15111 if (current_binding_level
== global_binding_level
)
15116 /* Reuse or create a struct for this binding level. */
15118 if (free_binding_level
)
15120 newlevel
= free_binding_level
;
15121 free_binding_level
= free_binding_level
->level_chain
;
15125 newlevel
= make_binding_level ();
15128 /* Add this level to the front of the chain (stack) of levels that
15131 *newlevel
= clear_binding_level
;
15132 newlevel
->level_chain
= current_binding_level
;
15133 current_binding_level
= newlevel
;
15136 /* Set the BLOCK node for the innermost scope
15137 (the one we are currently in). */
15141 register tree block
;
15143 current_binding_level
->this_block
= block
;
15144 current_binding_level
->names
= chainon (current_binding_level
->names
,
15145 BLOCK_VARS (block
));
15146 current_binding_level
->blocks
= chainon (current_binding_level
->blocks
,
15147 BLOCK_SUBBLOCKS (block
));
15150 /* ~~gcc/tree.h *should* declare this, because toplev.c references it. */
15152 /* Can't 'yydebug' a front end not generated by yacc/bison! */
15155 set_yydebug (value
)
15159 fprintf (stderr
, "warning: no yacc/bison-generated output to debug!\n");
15163 signed_or_unsigned_type (unsignedp
, type
)
15169 if (! INTEGRAL_TYPE_P (type
))
15171 if (TYPE_PRECISION (type
) == TYPE_PRECISION (signed_char_type_node
))
15172 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15173 if (TYPE_PRECISION (type
) == TYPE_PRECISION (integer_type_node
))
15174 return unsignedp
? unsigned_type_node
: integer_type_node
;
15175 if (TYPE_PRECISION (type
) == TYPE_PRECISION (short_integer_type_node
))
15176 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15177 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_integer_type_node
))
15178 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15179 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_long_integer_type_node
))
15180 return (unsignedp
? long_long_unsigned_type_node
15181 : long_long_integer_type_node
);
15183 type2
= type_for_size (TYPE_PRECISION (type
), unsignedp
);
15184 if (type2
== NULL_TREE
)
15194 tree type1
= TYPE_MAIN_VARIANT (type
);
15195 ffeinfoKindtype kt
;
15198 if (type1
== unsigned_char_type_node
|| type1
== char_type_node
)
15199 return signed_char_type_node
;
15200 if (type1
== unsigned_type_node
)
15201 return integer_type_node
;
15202 if (type1
== short_unsigned_type_node
)
15203 return short_integer_type_node
;
15204 if (type1
== long_unsigned_type_node
)
15205 return long_integer_type_node
;
15206 if (type1
== long_long_unsigned_type_node
)
15207 return long_long_integer_type_node
;
15208 #if 0 /* gcc/c-* files only */
15209 if (type1
== unsigned_intDI_type_node
)
15210 return intDI_type_node
;
15211 if (type1
== unsigned_intSI_type_node
)
15212 return intSI_type_node
;
15213 if (type1
== unsigned_intHI_type_node
)
15214 return intHI_type_node
;
15215 if (type1
== unsigned_intQI_type_node
)
15216 return intQI_type_node
;
15219 type2
= type_for_size (TYPE_PRECISION (type1
), 0);
15220 if (type2
!= NULL_TREE
)
15223 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15225 type2
= ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
15227 if (type1
== type2
)
15228 return ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15234 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15235 or validate its data type for an `if' or `while' statement or ?..: exp.
15237 This preparation consists of taking the ordinary
15238 representation of an expression expr and producing a valid tree
15239 boolean expression describing whether expr is nonzero. We could
15240 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15241 but we optimize comparisons, &&, ||, and !.
15243 The resulting type should always be `integer_type_node'. */
15246 truthvalue_conversion (expr
)
15249 if (TREE_CODE (expr
) == ERROR_MARK
)
15252 #if 0 /* This appears to be wrong for C++. */
15253 /* These really should return error_mark_node after 2.4 is stable.
15254 But not all callers handle ERROR_MARK properly. */
15255 switch (TREE_CODE (TREE_TYPE (expr
)))
15258 error ("struct type value used where scalar is required");
15259 return integer_zero_node
;
15262 error ("union type value used where scalar is required");
15263 return integer_zero_node
;
15266 error ("array type value used where scalar is required");
15267 return integer_zero_node
;
15274 switch (TREE_CODE (expr
))
15276 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15277 or comparison expressions as truth values at this level. */
15279 case COMPONENT_REF
:
15280 /* A one-bit unsigned bit-field is already acceptable. */
15281 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr
, 1)))
15282 && TREE_UNSIGNED (TREE_OPERAND (expr
, 1)))
15288 /* It is simpler and generates better code to have only TRUTH_*_EXPR
15289 or comparison expressions as truth values at this level. */
15291 if (integer_zerop (TREE_OPERAND (expr
, 1)))
15292 return build_unary_op (TRUTH_NOT_EXPR
, TREE_OPERAND (expr
, 0), 0);
15294 case NE_EXPR
: case LE_EXPR
: case GE_EXPR
: case LT_EXPR
: case GT_EXPR
:
15295 case TRUTH_ANDIF_EXPR
:
15296 case TRUTH_ORIF_EXPR
:
15297 case TRUTH_AND_EXPR
:
15298 case TRUTH_OR_EXPR
:
15299 case TRUTH_XOR_EXPR
:
15300 TREE_TYPE (expr
) = integer_type_node
;
15307 return integer_zerop (expr
) ? integer_zero_node
: integer_one_node
;
15310 return real_zerop (expr
) ? integer_zero_node
: integer_one_node
;
15313 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 0)))
15314 return build (COMPOUND_EXPR
, integer_type_node
,
15315 TREE_OPERAND (expr
, 0), integer_one_node
);
15317 return integer_one_node
;
15320 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1))
15321 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
15323 truthvalue_conversion (TREE_OPERAND (expr
, 0)),
15324 truthvalue_conversion (TREE_OPERAND (expr
, 1)));
15330 /* These don't change whether an object is non-zero or zero. */
15331 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15335 /* These don't change whether an object is zero or non-zero, but
15336 we can't ignore them if their second arg has side-effects. */
15337 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1)))
15338 return build (COMPOUND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 1),
15339 truthvalue_conversion (TREE_OPERAND (expr
, 0)));
15341 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15344 /* Distribute the conversion into the arms of a COND_EXPR. */
15345 return fold (build (COND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 0),
15346 truthvalue_conversion (TREE_OPERAND (expr
, 1)),
15347 truthvalue_conversion (TREE_OPERAND (expr
, 2))));
15350 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15351 since that affects how `default_conversion' will behave. */
15352 if (TREE_CODE (TREE_TYPE (expr
)) == REFERENCE_TYPE
15353 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == REFERENCE_TYPE
)
15355 /* fall through... */
15357 /* If this is widening the argument, we can ignore it. */
15358 if (TYPE_PRECISION (TREE_TYPE (expr
))
15359 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr
, 0))))
15360 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
15364 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15366 if (TARGET_FLOAT_FORMAT
== IEEE_FLOAT_FORMAT
15367 && TREE_CODE (TREE_TYPE (expr
)) == REAL_TYPE
)
15369 /* fall through... */
15371 /* This and MINUS_EXPR can be changed into a comparison of the
15373 if (TREE_TYPE (TREE_OPERAND (expr
, 0))
15374 == TREE_TYPE (TREE_OPERAND (expr
, 1)))
15375 return ffecom_2 (NE_EXPR
, integer_type_node
,
15376 TREE_OPERAND (expr
, 0),
15377 TREE_OPERAND (expr
, 1));
15378 return ffecom_2 (NE_EXPR
, integer_type_node
,
15379 TREE_OPERAND (expr
, 0),
15380 fold (build1 (NOP_EXPR
,
15381 TREE_TYPE (TREE_OPERAND (expr
, 0)),
15382 TREE_OPERAND (expr
, 1))));
15385 if (integer_onep (TREE_OPERAND (expr
, 1)))
15390 #if 0 /* No such thing in Fortran. */
15391 if (warn_parentheses
&& C_EXP_ORIGINAL_CODE (expr
) == MODIFY_EXPR
)
15392 warning ("suggest parentheses around assignment used as truth value");
15400 if (TREE_CODE (TREE_TYPE (expr
)) == COMPLEX_TYPE
)
15402 ((TREE_SIDE_EFFECTS (expr
)
15403 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
15405 truthvalue_conversion (ffecom_1 (REALPART_EXPR
,
15406 TREE_TYPE (TREE_TYPE (expr
)),
15408 truthvalue_conversion (ffecom_1 (IMAGPART_EXPR
,
15409 TREE_TYPE (TREE_TYPE (expr
)),
15412 return ffecom_2 (NE_EXPR
, integer_type_node
,
15414 convert (TREE_TYPE (expr
), integer_zero_node
));
15418 type_for_mode (mode
, unsignedp
)
15419 enum machine_mode mode
;
15426 if (mode
== TYPE_MODE (integer_type_node
))
15427 return unsignedp
? unsigned_type_node
: integer_type_node
;
15429 if (mode
== TYPE_MODE (signed_char_type_node
))
15430 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15432 if (mode
== TYPE_MODE (short_integer_type_node
))
15433 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15435 if (mode
== TYPE_MODE (long_integer_type_node
))
15436 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15438 if (mode
== TYPE_MODE (long_long_integer_type_node
))
15439 return unsignedp
? long_long_unsigned_type_node
: long_long_integer_type_node
;
15441 #if HOST_BITS_PER_WIDE_INT >= 64
15442 if (mode
== TYPE_MODE (intTI_type_node
))
15443 return unsignedp
? unsigned_intTI_type_node
: intTI_type_node
;
15446 if (mode
== TYPE_MODE (float_type_node
))
15447 return float_type_node
;
15449 if (mode
== TYPE_MODE (double_type_node
))
15450 return double_type_node
;
15452 if (mode
== TYPE_MODE (build_pointer_type (char_type_node
)))
15453 return build_pointer_type (char_type_node
);
15455 if (mode
== TYPE_MODE (build_pointer_type (integer_type_node
)))
15456 return build_pointer_type (integer_type_node
);
15458 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
15459 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
15461 if (((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
15462 && (mode
== TYPE_MODE (t
)))
15464 if ((i
== FFEINFO_basictypeINTEGER
) && unsignedp
)
15465 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][j
];
15475 type_for_size (bits
, unsignedp
)
15479 ffeinfoKindtype kt
;
15482 if (bits
== TYPE_PRECISION (integer_type_node
))
15483 return unsignedp
? unsigned_type_node
: integer_type_node
;
15485 if (bits
== TYPE_PRECISION (signed_char_type_node
))
15486 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15488 if (bits
== TYPE_PRECISION (short_integer_type_node
))
15489 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15491 if (bits
== TYPE_PRECISION (long_integer_type_node
))
15492 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15494 if (bits
== TYPE_PRECISION (long_long_integer_type_node
))
15495 return (unsignedp
? long_long_unsigned_type_node
15496 : long_long_integer_type_node
);
15498 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15500 type_node
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15502 if ((type_node
!= NULL_TREE
) && (bits
== TYPE_PRECISION (type_node
)))
15503 return unsignedp
? ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
]
15511 unsigned_type (type
)
15514 tree type1
= TYPE_MAIN_VARIANT (type
);
15515 ffeinfoKindtype kt
;
15518 if (type1
== signed_char_type_node
|| type1
== char_type_node
)
15519 return unsigned_char_type_node
;
15520 if (type1
== integer_type_node
)
15521 return unsigned_type_node
;
15522 if (type1
== short_integer_type_node
)
15523 return short_unsigned_type_node
;
15524 if (type1
== long_integer_type_node
)
15525 return long_unsigned_type_node
;
15526 if (type1
== long_long_integer_type_node
)
15527 return long_long_unsigned_type_node
;
15528 #if 0 /* gcc/c-* files only */
15529 if (type1
== intDI_type_node
)
15530 return unsigned_intDI_type_node
;
15531 if (type1
== intSI_type_node
)
15532 return unsigned_intSI_type_node
;
15533 if (type1
== intHI_type_node
)
15534 return unsigned_intHI_type_node
;
15535 if (type1
== intQI_type_node
)
15536 return unsigned_intQI_type_node
;
15539 type2
= type_for_size (TYPE_PRECISION (type1
), 1);
15540 if (type2
!= NULL_TREE
)
15543 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15545 type2
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15547 if (type1
== type2
)
15548 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
15556 union tree_node
*t ATTRIBUTE_UNUSED
;
15558 if (TREE_CODE (t
) == IDENTIFIER_NODE
)
15560 struct lang_identifier
*i
= (struct lang_identifier
*) t
;
15561 ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i
));
15562 ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i
));
15563 ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i
));
15565 else if (TYPE_P (t
) && TYPE_LANG_SPECIFIC (t
))
15566 ggc_mark (TYPE_LANG_SPECIFIC (t
));
15569 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15571 #if FFECOM_GCC_INCLUDE
15573 /* From gcc/cccp.c, the code to handle -I. */
15575 /* Skip leading "./" from a directory name.
15576 This may yield the empty string, which represents the current directory. */
15578 static const char *
15579 skip_redundant_dir_prefix (const char *dir
)
15581 while (dir
[0] == '.' && dir
[1] == '/')
15582 for (dir
+= 2; *dir
== '/'; dir
++)
15584 if (dir
[0] == '.' && !dir
[1])
15589 /* The file_name_map structure holds a mapping of file names for a
15590 particular directory. This mapping is read from the file named
15591 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15592 map filenames on a file system with severe filename restrictions,
15593 such as DOS. The format of the file name map file is just a series
15594 of lines with two tokens on each line. The first token is the name
15595 to map, and the second token is the actual name to use. */
15597 struct file_name_map
15599 struct file_name_map
*map_next
;
15604 #define FILE_NAME_MAP_FILE "header.gcc"
15606 /* Current maximum length of directory names in the search path
15607 for include files. (Altered as we get more of them.) */
15609 static int max_include_len
= 0;
15611 struct file_name_list
15613 struct file_name_list
*next
;
15615 /* Mapping of file names for this directory. */
15616 struct file_name_map
*name_map
;
15617 /* Non-zero if name_map is valid. */
15621 static struct file_name_list
*include
= NULL
; /* First dir to search */
15622 static struct file_name_list
*last_include
= NULL
; /* Last in chain */
15624 /* I/O buffer structure.
15625 The `fname' field is nonzero for source files and #include files
15626 and for the dummy text used for -D and -U.
15627 It is zero for rescanning results of macro expansion
15628 and for expanding macro arguments. */
15629 #define INPUT_STACK_MAX 400
15630 static struct file_buf
{
15632 /* Filename specified with #line command. */
15633 const char *nominal_fname
;
15634 /* Record where in the search path this file was found.
15635 For #include_next. */
15636 struct file_name_list
*dir
;
15638 ffewhereColumn column
;
15639 } instack
[INPUT_STACK_MAX
];
15641 static int last_error_tick
= 0; /* Incremented each time we print it. */
15642 static int input_file_stack_tick
= 0; /* Incremented when status changes. */
15644 /* Current nesting level of input sources.
15645 `instack[indepth]' is the level currently being read. */
15646 static int indepth
= -1;
15648 typedef struct file_buf FILE_BUF
;
15650 typedef unsigned char U_CHAR
;
15652 /* table to tell if char can be part of a C identifier. */
15653 U_CHAR is_idchar
[256];
15654 /* table to tell if char can be first char of a c identifier. */
15655 U_CHAR is_idstart
[256];
15656 /* table to tell if c is horizontal space. */
15657 U_CHAR is_hor_space
[256];
15658 /* table to tell if c is horizontal or vertical space. */
15659 static U_CHAR is_space
[256];
15661 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15662 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15664 /* Nonzero means -I- has been seen,
15665 so don't look for #include "foo" the source-file directory. */
15666 static int ignore_srcdir
;
15668 #ifndef INCLUDE_LEN_FUDGE
15669 #define INCLUDE_LEN_FUDGE 0
15672 static void append_include_chain (struct file_name_list
*first
,
15673 struct file_name_list
*last
);
15674 static FILE *open_include_file (char *filename
,
15675 struct file_name_list
*searchptr
);
15676 static void print_containing_files (ffebadSeverity sev
);
15677 static char *read_filename_string (int ch
, FILE *f
);
15678 static struct file_name_map
*read_name_map (const char *dirname
);
15680 /* Append a chain of `struct file_name_list's
15681 to the end of the main include chain.
15682 FIRST is the beginning of the chain to append, and LAST is the end. */
15685 append_include_chain (first
, last
)
15686 struct file_name_list
*first
, *last
;
15688 struct file_name_list
*dir
;
15690 if (!first
|| !last
)
15696 last_include
->next
= first
;
15698 for (dir
= first
; ; dir
= dir
->next
) {
15699 int len
= strlen (dir
->fname
) + INCLUDE_LEN_FUDGE
;
15700 if (len
> max_include_len
)
15701 max_include_len
= len
;
15707 last_include
= last
;
15710 /* Try to open include file FILENAME. SEARCHPTR is the directory
15711 being tried from the include file search path. This function maps
15712 filenames on file systems based on information read by
15716 open_include_file (filename
, searchptr
)
15718 struct file_name_list
*searchptr
;
15720 register struct file_name_map
*map
;
15721 register char *from
;
15724 if (searchptr
&& ! searchptr
->got_name_map
)
15726 searchptr
->name_map
= read_name_map (searchptr
->fname
15727 ? searchptr
->fname
: ".");
15728 searchptr
->got_name_map
= 1;
15731 /* First check the mapping for the directory we are using. */
15732 if (searchptr
&& searchptr
->name_map
)
15735 if (searchptr
->fname
)
15736 from
+= strlen (searchptr
->fname
) + 1;
15737 for (map
= searchptr
->name_map
; map
; map
= map
->map_next
)
15739 if (! strcmp (map
->map_from
, from
))
15741 /* Found a match. */
15742 return fopen (map
->map_to
, "r");
15747 /* Try to find a mapping file for the particular directory we are
15748 looking in. Thus #include <sys/types.h> will look up sys/types.h
15749 in /usr/include/header.gcc and look up types.h in
15750 /usr/include/sys/header.gcc. */
15751 p
= strrchr (filename
, '/');
15752 #ifdef DIR_SEPARATOR
15753 if (! p
) p
= strrchr (filename
, DIR_SEPARATOR
);
15755 char *tmp
= strrchr (filename
, DIR_SEPARATOR
);
15756 if (tmp
!= NULL
&& tmp
> p
) p
= tmp
;
15762 && searchptr
->fname
15763 && strlen (searchptr
->fname
) == (size_t) (p
- filename
)
15764 && ! strncmp (searchptr
->fname
, filename
, (int) (p
- filename
)))
15766 /* FILENAME is in SEARCHPTR, which we've already checked. */
15767 return fopen (filename
, "r");
15773 map
= read_name_map (".");
15777 dir
= (char *) xmalloc (p
- filename
+ 1);
15778 memcpy (dir
, filename
, p
- filename
);
15779 dir
[p
- filename
] = '\0';
15781 map
= read_name_map (dir
);
15784 for (; map
; map
= map
->map_next
)
15785 if (! strcmp (map
->map_from
, from
))
15786 return fopen (map
->map_to
, "r");
15788 return fopen (filename
, "r");
15791 /* Print the file names and line numbers of the #include
15792 commands which led to the current file. */
15795 print_containing_files (ffebadSeverity sev
)
15797 FILE_BUF
*ip
= NULL
;
15803 /* If stack of files hasn't changed since we last printed
15804 this info, don't repeat it. */
15805 if (last_error_tick
== input_file_stack_tick
)
15808 for (i
= indepth
; i
>= 0; i
--)
15809 if (instack
[i
].fname
!= NULL
) {
15814 /* Give up if we don't find a source file. */
15818 /* Find the other, outer source files. */
15819 for (i
--; i
>= 0; i
--)
15820 if (instack
[i
].fname
!= NULL
)
15826 str1
= "In file included";
15838 ffebad_start_msg ("%A from %B at %0%C", sev
);
15839 ffebad_here (0, ip
->line
, ip
->column
);
15840 ffebad_string (str1
);
15841 ffebad_string (ip
->nominal_fname
);
15842 ffebad_string (str2
);
15846 /* Record we have printed the status as of this time. */
15847 last_error_tick
= input_file_stack_tick
;
15850 /* Read a space delimited string of unlimited length from a stdio
15854 read_filename_string (ch
, f
)
15862 set
= alloc
= xmalloc (len
+ 1);
15863 if (! is_space
[ch
])
15866 while ((ch
= getc (f
)) != EOF
&& ! is_space
[ch
])
15868 if (set
- alloc
== len
)
15871 alloc
= xrealloc (alloc
, len
+ 1);
15872 set
= alloc
+ len
/ 2;
15882 /* Read the file name map file for DIRNAME. */
15884 static struct file_name_map
*
15885 read_name_map (dirname
)
15886 const char *dirname
;
15888 /* This structure holds a linked list of file name maps, one per
15890 struct file_name_map_list
15892 struct file_name_map_list
*map_list_next
;
15893 char *map_list_name
;
15894 struct file_name_map
*map_list_map
;
15896 static struct file_name_map_list
*map_list
;
15897 register struct file_name_map_list
*map_list_ptr
;
15901 int separator_needed
;
15903 dirname
= skip_redundant_dir_prefix (dirname
);
15905 for (map_list_ptr
= map_list
; map_list_ptr
;
15906 map_list_ptr
= map_list_ptr
->map_list_next
)
15907 if (! strcmp (map_list_ptr
->map_list_name
, dirname
))
15908 return map_list_ptr
->map_list_map
;
15910 map_list_ptr
= ((struct file_name_map_list
*)
15911 xmalloc (sizeof (struct file_name_map_list
)));
15912 map_list_ptr
->map_list_name
= xstrdup (dirname
);
15913 map_list_ptr
->map_list_map
= NULL
;
15915 dirlen
= strlen (dirname
);
15916 separator_needed
= dirlen
!= 0 && dirname
[dirlen
- 1] != '/';
15917 name
= (char *) xmalloc (dirlen
+ strlen (FILE_NAME_MAP_FILE
) + 2);
15918 strcpy (name
, dirname
);
15919 name
[dirlen
] = '/';
15920 strcpy (name
+ dirlen
+ separator_needed
, FILE_NAME_MAP_FILE
);
15921 f
= fopen (name
, "r");
15924 map_list_ptr
->map_list_map
= NULL
;
15929 while ((ch
= getc (f
)) != EOF
)
15932 struct file_name_map
*ptr
;
15936 from
= read_filename_string (ch
, f
);
15937 while ((ch
= getc (f
)) != EOF
&& is_hor_space
[ch
])
15939 to
= read_filename_string (ch
, f
);
15941 ptr
= ((struct file_name_map
*)
15942 xmalloc (sizeof (struct file_name_map
)));
15943 ptr
->map_from
= from
;
15945 /* Make the real filename absolute. */
15950 ptr
->map_to
= xmalloc (dirlen
+ strlen (to
) + 2);
15951 strcpy (ptr
->map_to
, dirname
);
15952 ptr
->map_to
[dirlen
] = '/';
15953 strcpy (ptr
->map_to
+ dirlen
+ separator_needed
, to
);
15957 ptr
->map_next
= map_list_ptr
->map_list_map
;
15958 map_list_ptr
->map_list_map
= ptr
;
15960 while ((ch
= getc (f
)) != '\n')
15967 map_list_ptr
->map_list_next
= map_list
;
15968 map_list
= map_list_ptr
;
15970 return map_list_ptr
->map_list_map
;
15974 ffecom_file_ (const char *name
)
15978 /* Do partial setup of input buffer for the sake of generating
15979 early #line directives (when -g is in effect). */
15981 fp
= &instack
[++indepth
];
15982 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
15985 fp
->nominal_fname
= fp
->fname
= name
;
15988 /* Initialize syntactic classifications of characters. */
15991 ffecom_initialize_char_syntax_ ()
15996 * Set up is_idchar and is_idstart tables. These should be
15997 * faster than saying (is_alpha (c) || c == '_'), etc.
15998 * Set up these things before calling any routines tthat
16001 for (i
= 'a'; i
<= 'z'; i
++) {
16002 is_idchar
[i
- 'a' + 'A'] = 1;
16004 is_idstart
[i
- 'a' + 'A'] = 1;
16007 for (i
= '0'; i
<= '9'; i
++)
16009 is_idchar
['_'] = 1;
16010 is_idstart
['_'] = 1;
16012 /* horizontal space table */
16013 is_hor_space
[' '] = 1;
16014 is_hor_space
['\t'] = 1;
16015 is_hor_space
['\v'] = 1;
16016 is_hor_space
['\f'] = 1;
16017 is_hor_space
['\r'] = 1;
16020 is_space
['\t'] = 1;
16021 is_space
['\v'] = 1;
16022 is_space
['\f'] = 1;
16023 is_space
['\n'] = 1;
16024 is_space
['\r'] = 1;
16028 ffecom_close_include_ (FILE *f
)
16033 input_file_stack_tick
++;
16035 ffewhere_line_kill (instack
[indepth
].line
);
16036 ffewhere_column_kill (instack
[indepth
].column
);
16040 ffecom_decode_include_option_ (char *spec
)
16042 struct file_name_list
*dirtmp
;
16044 if (! ignore_srcdir
&& !strcmp (spec
, "-"))
16048 dirtmp
= (struct file_name_list
*)
16049 xmalloc (sizeof (struct file_name_list
));
16050 dirtmp
->next
= 0; /* New one goes on the end */
16051 dirtmp
->fname
= spec
;
16052 dirtmp
->got_name_map
= 0;
16054 error ("Directory name must immediately follow -I");
16056 append_include_chain (dirtmp
, dirtmp
);
16061 /* Open INCLUDEd file. */
16064 ffecom_open_include_ (char *name
, ffewhereLine l
, ffewhereColumn c
)
16067 size_t flen
= strlen (fbeg
);
16068 struct file_name_list
*search_start
= include
; /* Chain of dirs to search */
16069 struct file_name_list dsp
[1]; /* First in chain, if #include "..." */
16070 struct file_name_list
*searchptr
= 0;
16071 char *fname
; /* Dynamically allocated fname buffer */
16078 dsp
[0].fname
= NULL
;
16080 /* If -I- was specified, don't search current dir, only spec'd ones. */
16081 if (!ignore_srcdir
)
16083 for (fp
= &instack
[indepth
]; fp
>= instack
; fp
--)
16089 if ((nam
= fp
->nominal_fname
) != NULL
)
16091 /* Found a named file. Figure out dir of the file,
16092 and put it in front of the search list. */
16093 dsp
[0].next
= search_start
;
16094 search_start
= dsp
;
16096 ep
= strrchr (nam
, '/');
16097 #ifdef DIR_SEPARATOR
16098 if (ep
== NULL
) ep
= strrchr (nam
, DIR_SEPARATOR
);
16100 char *tmp
= strrchr (nam
, DIR_SEPARATOR
);
16101 if (tmp
!= NULL
&& tmp
> ep
) ep
= tmp
;
16105 ep
= strrchr (nam
, ']');
16106 if (ep
== NULL
) ep
= strrchr (nam
, '>');
16107 if (ep
== NULL
) ep
= strrchr (nam
, ':');
16108 if (ep
!= NULL
) ep
++;
16113 dsp
[0].fname
= (char *) xmalloc (n
+ 1);
16114 strncpy (dsp
[0].fname
, nam
, n
);
16115 dsp
[0].fname
[n
] = '\0';
16116 if (n
+ INCLUDE_LEN_FUDGE
> max_include_len
)
16117 max_include_len
= n
+ INCLUDE_LEN_FUDGE
;
16120 dsp
[0].fname
= NULL
; /* Current directory */
16121 dsp
[0].got_name_map
= 0;
16127 /* Allocate this permanently, because it gets stored in the definitions
16129 fname
= xmalloc (max_include_len
+ flen
+ 4);
16130 /* + 2 above for slash and terminating null. */
16131 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16134 /* If specified file name is absolute, just open it. */
16137 #ifdef DIR_SEPARATOR
16138 || *fbeg
== DIR_SEPARATOR
16142 strncpy (fname
, (char *) fbeg
, flen
);
16144 f
= open_include_file (fname
, NULL
);
16150 /* Search directory path, trying to open the file.
16151 Copy each filename tried into FNAME. */
16153 for (searchptr
= search_start
; searchptr
; searchptr
= searchptr
->next
)
16155 if (searchptr
->fname
)
16157 /* The empty string in a search path is ignored.
16158 This makes it possible to turn off entirely
16159 a standard piece of the list. */
16160 if (searchptr
->fname
[0] == 0)
16162 strcpy (fname
, skip_redundant_dir_prefix (searchptr
->fname
));
16163 if (fname
[0] && fname
[strlen (fname
) - 1] != '/')
16164 strcat (fname
, "/");
16165 fname
[strlen (fname
) + flen
] = 0;
16170 strncat (fname
, fbeg
, flen
);
16172 /* Change this 1/2 Unix 1/2 VMS file specification into a
16173 full VMS file specification */
16174 if (searchptr
->fname
&& (searchptr
->fname
[0] != 0))
16176 /* Fix up the filename */
16177 hack_vms_include_specification (fname
);
16181 /* This is a normal VMS filespec, so use it unchanged. */
16182 strncpy (fname
, (char *) fbeg
, flen
);
16184 #if 0 /* Not for g77. */
16185 /* if it's '#include filename', add the missing .h */
16186 if (strchr (fname
, '.') == NULL
)
16187 strcat (fname
, ".h");
16191 f
= open_include_file (fname
, searchptr
);
16193 if (f
== NULL
&& errno
== EACCES
)
16195 print_containing_files (FFEBAD_severityWARNING
);
16196 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16197 FFEBAD_severityWARNING
);
16198 ffebad_string (fname
);
16199 ffebad_here (0, l
, c
);
16210 /* A file that was not found. */
16212 strncpy (fname
, (char *) fbeg
, flen
);
16214 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE
));
16215 ffebad_start (FFEBAD_OPEN_INCLUDE
);
16216 ffebad_here (0, l
, c
);
16217 ffebad_string (fname
);
16221 if (dsp
[0].fname
!= NULL
)
16222 free (dsp
[0].fname
);
16227 if (indepth
>= (INPUT_STACK_MAX
- 1))
16229 print_containing_files (FFEBAD_severityFATAL
);
16230 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16231 FFEBAD_severityFATAL
);
16232 ffebad_string (fname
);
16233 ffebad_here (0, l
, c
);
16238 instack
[indepth
].line
= ffewhere_line_use (l
);
16239 instack
[indepth
].column
= ffewhere_column_use (c
);
16241 fp
= &instack
[indepth
+ 1];
16242 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
16243 fp
->nominal_fname
= fp
->fname
= fname
;
16244 fp
->dir
= searchptr
;
16247 input_file_stack_tick
++;
16251 #endif /* FFECOM_GCC_INCLUDE */
16253 /**INDENT* (Do not reformat this comment even with -fca option.)
16254 Data-gathering files: Given the source file listed below, compiled with
16255 f2c I obtained the output file listed after that, and from the output
16256 file I derived the above code.
16258 -------- (begin input file to f2c)
16264 double precision D1,D2
16266 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16293 c FFEINTRIN_impACOS
16294 call fooR(ACOS(R1))
16295 c FFEINTRIN_impAIMAG
16296 call fooR(AIMAG(C1))
16297 c FFEINTRIN_impAINT
16298 call fooR(AINT(R1))
16299 c FFEINTRIN_impALOG
16300 call fooR(ALOG(R1))
16301 c FFEINTRIN_impALOG10
16302 call fooR(ALOG10(R1))
16303 c FFEINTRIN_impAMAX0
16304 call fooR(AMAX0(I1,I2))
16305 c FFEINTRIN_impAMAX1
16306 call fooR(AMAX1(R1,R2))
16307 c FFEINTRIN_impAMIN0
16308 call fooR(AMIN0(I1,I2))
16309 c FFEINTRIN_impAMIN1
16310 call fooR(AMIN1(R1,R2))
16311 c FFEINTRIN_impAMOD
16312 call fooR(AMOD(R1,R2))
16313 c FFEINTRIN_impANINT
16314 call fooR(ANINT(R1))
16315 c FFEINTRIN_impASIN
16316 call fooR(ASIN(R1))
16317 c FFEINTRIN_impATAN
16318 call fooR(ATAN(R1))
16319 c FFEINTRIN_impATAN2
16320 call fooR(ATAN2(R1,R2))
16321 c FFEINTRIN_impCABS
16322 call fooR(CABS(C1))
16323 c FFEINTRIN_impCCOS
16324 call fooC(CCOS(C1))
16325 c FFEINTRIN_impCEXP
16326 call fooC(CEXP(C1))
16327 c FFEINTRIN_impCHAR
16328 call fooA(CHAR(I1))
16329 c FFEINTRIN_impCLOG
16330 call fooC(CLOG(C1))
16331 c FFEINTRIN_impCONJG
16332 call fooC(CONJG(C1))
16335 c FFEINTRIN_impCOSH
16336 call fooR(COSH(R1))
16337 c FFEINTRIN_impCSIN
16338 call fooC(CSIN(C1))
16339 c FFEINTRIN_impCSQRT
16340 call fooC(CSQRT(C1))
16341 c FFEINTRIN_impDABS
16342 call fooD(DABS(D1))
16343 c FFEINTRIN_impDACOS
16344 call fooD(DACOS(D1))
16345 c FFEINTRIN_impDASIN
16346 call fooD(DASIN(D1))
16347 c FFEINTRIN_impDATAN
16348 call fooD(DATAN(D1))
16349 c FFEINTRIN_impDATAN2
16350 call fooD(DATAN2(D1,D2))
16351 c FFEINTRIN_impDCOS
16352 call fooD(DCOS(D1))
16353 c FFEINTRIN_impDCOSH
16354 call fooD(DCOSH(D1))
16355 c FFEINTRIN_impDDIM
16356 call fooD(DDIM(D1,D2))
16357 c FFEINTRIN_impDEXP
16358 call fooD(DEXP(D1))
16360 call fooR(DIM(R1,R2))
16361 c FFEINTRIN_impDINT
16362 call fooD(DINT(D1))
16363 c FFEINTRIN_impDLOG
16364 call fooD(DLOG(D1))
16365 c FFEINTRIN_impDLOG10
16366 call fooD(DLOG10(D1))
16367 c FFEINTRIN_impDMAX1
16368 call fooD(DMAX1(D1,D2))
16369 c FFEINTRIN_impDMIN1
16370 call fooD(DMIN1(D1,D2))
16371 c FFEINTRIN_impDMOD
16372 call fooD(DMOD(D1,D2))
16373 c FFEINTRIN_impDNINT
16374 call fooD(DNINT(D1))
16375 c FFEINTRIN_impDPROD
16376 call fooD(DPROD(R1,R2))
16377 c FFEINTRIN_impDSIGN
16378 call fooD(DSIGN(D1,D2))
16379 c FFEINTRIN_impDSIN
16380 call fooD(DSIN(D1))
16381 c FFEINTRIN_impDSINH
16382 call fooD(DSINH(D1))
16383 c FFEINTRIN_impDSQRT
16384 call fooD(DSQRT(D1))
16385 c FFEINTRIN_impDTAN
16386 call fooD(DTAN(D1))
16387 c FFEINTRIN_impDTANH
16388 call fooD(DTANH(D1))
16391 c FFEINTRIN_impIABS
16392 call fooI(IABS(I1))
16393 c FFEINTRIN_impICHAR
16394 call fooI(ICHAR(A1))
16395 c FFEINTRIN_impIDIM
16396 call fooI(IDIM(I1,I2))
16397 c FFEINTRIN_impIDNINT
16398 call fooI(IDNINT(D1))
16399 c FFEINTRIN_impINDEX
16400 call fooI(INDEX(A1,A2))
16401 c FFEINTRIN_impISIGN
16402 call fooI(ISIGN(I1,I2))
16406 call fooL(LGE(A1,A2))
16408 call fooL(LGT(A1,A2))
16410 call fooL(LLE(A1,A2))
16412 call fooL(LLT(A1,A2))
16413 c FFEINTRIN_impMAX0
16414 call fooI(MAX0(I1,I2))
16415 c FFEINTRIN_impMAX1
16416 call fooI(MAX1(R1,R2))
16417 c FFEINTRIN_impMIN0
16418 call fooI(MIN0(I1,I2))
16419 c FFEINTRIN_impMIN1
16420 call fooI(MIN1(R1,R2))
16422 call fooI(MOD(I1,I2))
16423 c FFEINTRIN_impNINT
16424 call fooI(NINT(R1))
16425 c FFEINTRIN_impSIGN
16426 call fooR(SIGN(R1,R2))
16429 c FFEINTRIN_impSINH
16430 call fooR(SINH(R1))
16431 c FFEINTRIN_impSQRT
16432 call fooR(SQRT(R1))
16435 c FFEINTRIN_impTANH
16436 call fooR(TANH(R1))
16437 c FFEINTRIN_imp_CMPLX_C
16438 call fooC(cmplx(C1,C2))
16439 c FFEINTRIN_imp_CMPLX_D
16440 call fooZ(cmplx(D1,D2))
16441 c FFEINTRIN_imp_CMPLX_I
16442 call fooC(cmplx(I1,I2))
16443 c FFEINTRIN_imp_CMPLX_R
16444 call fooC(cmplx(R1,R2))
16445 c FFEINTRIN_imp_DBLE_C
16446 call fooD(dble(C1))
16447 c FFEINTRIN_imp_DBLE_D
16448 call fooD(dble(D1))
16449 c FFEINTRIN_imp_DBLE_I
16450 call fooD(dble(I1))
16451 c FFEINTRIN_imp_DBLE_R
16452 call fooD(dble(R1))
16453 c FFEINTRIN_imp_INT_C
16455 c FFEINTRIN_imp_INT_D
16457 c FFEINTRIN_imp_INT_I
16459 c FFEINTRIN_imp_INT_R
16461 c FFEINTRIN_imp_REAL_C
16462 call fooR(real(C1))
16463 c FFEINTRIN_imp_REAL_D
16464 call fooR(real(D1))
16465 c FFEINTRIN_imp_REAL_I
16466 call fooR(real(I1))
16467 c FFEINTRIN_imp_REAL_R
16468 call fooR(real(R1))
16470 c FFEINTRIN_imp_INT_D:
16472 c FFEINTRIN_specIDINT
16473 call fooI(IDINT(D1))
16475 c FFEINTRIN_imp_INT_R:
16477 c FFEINTRIN_specIFIX
16478 call fooI(IFIX(R1))
16479 c FFEINTRIN_specINT
16482 c FFEINTRIN_imp_REAL_D:
16484 c FFEINTRIN_specSNGL
16485 call fooR(SNGL(D1))
16487 c FFEINTRIN_imp_REAL_I:
16489 c FFEINTRIN_specFLOAT
16490 call fooR(FLOAT(I1))
16491 c FFEINTRIN_specREAL
16492 call fooR(REAL(I1))
16495 -------- (end input file to f2c)
16497 -------- (begin output from providing above input file as input to:
16498 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16499 -------- -e "s:^#.*$::g"')
16501 // -- translated by f2c (version 19950223).
16502 You must link the resulting object file with the libraries:
16503 -lf2c -lm (in that order)
16507 // f2c.h -- Standard Fortran to C header file //
16509 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
16511 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16516 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16517 // we assume short, float are OK //
16518 typedef long int // long int // integer;
16519 typedef char *address;
16520 typedef short int shortint;
16521 typedef float real;
16522 typedef double doublereal;
16523 typedef struct { real r, i; } complex;
16524 typedef struct { doublereal r, i; } doublecomplex;
16525 typedef long int // long int // logical;
16526 typedef short int shortlogical;
16527 typedef char logical1;
16528 typedef char integer1;
16529 // typedef long long longint; // // system-dependent //
16534 // Extern is for use with -E //
16548 typedef long int // int or long int // flag;
16549 typedef long int // int or long int // ftnlen;
16550 typedef long int // int or long int // ftnint;
16553 //external read, write//
16562 //internal read, write//
16592 //rewind, backspace, endfile//
16604 ftnint *inex; //parameters in standard's order//
16630 union Multitype { // for multiple entry points //
16641 typedef union Multitype Multitype;
16643 typedef long Long; // No longer used; formerly in Namelist //
16645 struct Vardesc { // for Namelist //
16651 typedef struct Vardesc Vardesc;
16658 typedef struct Namelist Namelist;
16667 // procedure parameter types for -A and -C++ //
16672 typedef int // Unknown procedure type // (*U_fp)();
16673 typedef shortint (*J_fp)();
16674 typedef integer (*I_fp)();
16675 typedef real (*R_fp)();
16676 typedef doublereal (*D_fp)(), (*E_fp)();
16677 typedef // Complex // void (*C_fp)();
16678 typedef // Double Complex // void (*Z_fp)();
16679 typedef logical (*L_fp)();
16680 typedef shortlogical (*K_fp)();
16681 typedef // Character // void (*H_fp)();
16682 typedef // Subroutine // int (*S_fp)();
16684 // E_fp is for real functions when -R is not specified //
16685 typedef void C_f; // complex function //
16686 typedef void H_f; // character function //
16687 typedef void Z_f; // double complex function //
16688 typedef doublereal E_f; // real function with -R not specified //
16690 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16693 // (No such symbols should be defined in a strict ANSI C compiler.
16694 We can avoid trouble with f2c-translated code by using
16695 gcc -ansi [-traditional].) //
16719 // Main program // MAIN__()
16721 // System generated locals //
16724 doublereal d__1, d__2;
16726 doublecomplex z__1, z__2, z__3;
16730 // Builtin functions //
16733 double pow_ri(), pow_di();
16737 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16738 asin(), atan(), atan2(), c_abs();
16739 void c_cos(), c_exp(), c_log(), r_cnjg();
16740 double cos(), cosh();
16741 void c_sin(), c_sqrt();
16742 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16743 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16744 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16745 logical l_ge(), l_gt(), l_le(), l_lt();
16749 // Local variables //
16750 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16751 fool_(), fooz_(), getem_();
16752 static char a1[10], a2[10];
16753 static complex c1, c2;
16754 static doublereal d1, d2;
16755 static integer i1, i2;
16756 static real r1, r2;
16759 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16767 d__1 = (doublereal) i1;
16768 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16778 c_div(&q__1, &c1, &c2);
16780 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16782 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16785 i__1 = pow_ii(&i1, &i2);
16787 r__1 = pow_ri(&r1, &i1);
16789 d__1 = pow_di(&d1, &i1);
16791 pow_ci(&q__1, &c1, &i1);
16793 d__1 = (doublereal) r1;
16794 d__2 = (doublereal) r2;
16795 r__1 = pow_dd(&d__1, &d__2);
16797 d__2 = (doublereal) r1;
16798 d__1 = pow_dd(&d__2, &d1);
16800 d__1 = pow_dd(&d1, &d2);
16802 d__2 = (doublereal) r1;
16803 d__1 = pow_dd(&d1, &d__2);
16805 z__2.r = c1.r, z__2.i = c1.i;
16806 z__3.r = c2.r, z__3.i = c2.i;
16807 pow_zz(&z__1, &z__2, &z__3);
16808 q__1.r = z__1.r, q__1.i = z__1.i;
16810 z__2.r = c1.r, z__2.i = c1.i;
16811 z__3.r = r1, z__3.i = 0.;
16812 pow_zz(&z__1, &z__2, &z__3);
16813 q__1.r = z__1.r, q__1.i = z__1.i;
16815 z__2.r = c1.r, z__2.i = c1.i;
16816 z__3.r = d1, z__3.i = 0.;
16817 pow_zz(&z__1, &z__2, &z__3);
16819 // FFEINTRIN_impABS //
16820 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16822 // FFEINTRIN_impACOS //
16825 // FFEINTRIN_impAIMAG //
16826 r__1 = r_imag(&c1);
16828 // FFEINTRIN_impAINT //
16831 // FFEINTRIN_impALOG //
16834 // FFEINTRIN_impALOG10 //
16835 r__1 = r_lg10(&r1);
16837 // FFEINTRIN_impAMAX0 //
16838 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16840 // FFEINTRIN_impAMAX1 //
16841 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16843 // FFEINTRIN_impAMIN0 //
16844 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16846 // FFEINTRIN_impAMIN1 //
16847 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16849 // FFEINTRIN_impAMOD //
16850 r__1 = r_mod(&r1, &r2);
16852 // FFEINTRIN_impANINT //
16853 r__1 = r_nint(&r1);
16855 // FFEINTRIN_impASIN //
16858 // FFEINTRIN_impATAN //
16861 // FFEINTRIN_impATAN2 //
16862 r__1 = atan2(r1, r2);
16864 // FFEINTRIN_impCABS //
16867 // FFEINTRIN_impCCOS //
16870 // FFEINTRIN_impCEXP //
16873 // FFEINTRIN_impCHAR //
16874 *(unsigned char *)&ch__1[0] = i1;
16876 // FFEINTRIN_impCLOG //
16879 // FFEINTRIN_impCONJG //
16880 r_cnjg(&q__1, &c1);
16882 // FFEINTRIN_impCOS //
16885 // FFEINTRIN_impCOSH //
16888 // FFEINTRIN_impCSIN //
16891 // FFEINTRIN_impCSQRT //
16892 c_sqrt(&q__1, &c1);
16894 // FFEINTRIN_impDABS //
16895 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16897 // FFEINTRIN_impDACOS //
16900 // FFEINTRIN_impDASIN //
16903 // FFEINTRIN_impDATAN //
16906 // FFEINTRIN_impDATAN2 //
16907 d__1 = atan2(d1, d2);
16909 // FFEINTRIN_impDCOS //
16912 // FFEINTRIN_impDCOSH //
16915 // FFEINTRIN_impDDIM //
16916 d__1 = d_dim(&d1, &d2);
16918 // FFEINTRIN_impDEXP //
16921 // FFEINTRIN_impDIM //
16922 r__1 = r_dim(&r1, &r2);
16924 // FFEINTRIN_impDINT //
16927 // FFEINTRIN_impDLOG //
16930 // FFEINTRIN_impDLOG10 //
16931 d__1 = d_lg10(&d1);
16933 // FFEINTRIN_impDMAX1 //
16934 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16936 // FFEINTRIN_impDMIN1 //
16937 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16939 // FFEINTRIN_impDMOD //
16940 d__1 = d_mod(&d1, &d2);
16942 // FFEINTRIN_impDNINT //
16943 d__1 = d_nint(&d1);
16945 // FFEINTRIN_impDPROD //
16946 d__1 = (doublereal) r1 * r2;
16948 // FFEINTRIN_impDSIGN //
16949 d__1 = d_sign(&d1, &d2);
16951 // FFEINTRIN_impDSIN //
16954 // FFEINTRIN_impDSINH //
16957 // FFEINTRIN_impDSQRT //
16960 // FFEINTRIN_impDTAN //
16963 // FFEINTRIN_impDTANH //
16966 // FFEINTRIN_impEXP //
16969 // FFEINTRIN_impIABS //
16970 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16972 // FFEINTRIN_impICHAR //
16973 i__1 = *(unsigned char *)a1;
16975 // FFEINTRIN_impIDIM //
16976 i__1 = i_dim(&i1, &i2);
16978 // FFEINTRIN_impIDNINT //
16979 i__1 = i_dnnt(&d1);
16981 // FFEINTRIN_impINDEX //
16982 i__1 = i_indx(a1, a2, 10L, 10L);
16984 // FFEINTRIN_impISIGN //
16985 i__1 = i_sign(&i1, &i2);
16987 // FFEINTRIN_impLEN //
16988 i__1 = i_len(a1, 10L);
16990 // FFEINTRIN_impLGE //
16991 L__1 = l_ge(a1, a2, 10L, 10L);
16993 // FFEINTRIN_impLGT //
16994 L__1 = l_gt(a1, a2, 10L, 10L);
16996 // FFEINTRIN_impLLE //
16997 L__1 = l_le(a1, a2, 10L, 10L);
16999 // FFEINTRIN_impLLT //
17000 L__1 = l_lt(a1, a2, 10L, 10L);
17002 // FFEINTRIN_impMAX0 //
17003 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17005 // FFEINTRIN_impMAX1 //
17006 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
17008 // FFEINTRIN_impMIN0 //
17009 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17011 // FFEINTRIN_impMIN1 //
17012 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
17014 // FFEINTRIN_impMOD //
17017 // FFEINTRIN_impNINT //
17018 i__1 = i_nint(&r1);
17020 // FFEINTRIN_impSIGN //
17021 r__1 = r_sign(&r1, &r2);
17023 // FFEINTRIN_impSIN //
17026 // FFEINTRIN_impSINH //
17029 // FFEINTRIN_impSQRT //
17032 // FFEINTRIN_impTAN //
17035 // FFEINTRIN_impTANH //
17038 // FFEINTRIN_imp_CMPLX_C //
17041 q__1.r = r__1, q__1.i = r__2;
17043 // FFEINTRIN_imp_CMPLX_D //
17044 z__1.r = d1, z__1.i = d2;
17046 // FFEINTRIN_imp_CMPLX_I //
17049 q__1.r = r__1, q__1.i = r__2;
17051 // FFEINTRIN_imp_CMPLX_R //
17052 q__1.r = r1, q__1.i = r2;
17054 // FFEINTRIN_imp_DBLE_C //
17055 d__1 = (doublereal) c1.r;
17057 // FFEINTRIN_imp_DBLE_D //
17060 // FFEINTRIN_imp_DBLE_I //
17061 d__1 = (doublereal) i1;
17063 // FFEINTRIN_imp_DBLE_R //
17064 d__1 = (doublereal) r1;
17066 // FFEINTRIN_imp_INT_C //
17067 i__1 = (integer) c1.r;
17069 // FFEINTRIN_imp_INT_D //
17070 i__1 = (integer) d1;
17072 // FFEINTRIN_imp_INT_I //
17075 // FFEINTRIN_imp_INT_R //
17076 i__1 = (integer) r1;
17078 // FFEINTRIN_imp_REAL_C //
17081 // FFEINTRIN_imp_REAL_D //
17084 // FFEINTRIN_imp_REAL_I //
17087 // FFEINTRIN_imp_REAL_R //
17091 // FFEINTRIN_imp_INT_D: //
17093 // FFEINTRIN_specIDINT //
17094 i__1 = (integer) d1;
17097 // FFEINTRIN_imp_INT_R: //
17099 // FFEINTRIN_specIFIX //
17100 i__1 = (integer) r1;
17102 // FFEINTRIN_specINT //
17103 i__1 = (integer) r1;
17106 // FFEINTRIN_imp_REAL_D: //
17108 // FFEINTRIN_specSNGL //
17112 // FFEINTRIN_imp_REAL_I: //
17114 // FFEINTRIN_specFLOAT //
17117 // FFEINTRIN_specREAL //
17123 -------- (end output file from f2c)