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);
88 #include "output.h" /* Must follow tree.h so TREE_CODE is defined! */
91 #include "diagnostic.h"
92 #include "langhooks.h"
93 #include "langhooks-def.h"
95 /* VMS-specific definitions */
98 #define O_RDONLY 0 /* Open arg for Read/Only */
99 #define O_WRONLY 1 /* Open arg for Write/Only */
100 #define read(fd,buf,size) VMS_read (fd,buf,size)
101 #define write(fd,buf,size) VMS_write (fd,buf,size)
102 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
103 #define fopen(fname,mode) VMS_fopen (fname,mode)
104 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
105 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
106 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
107 static int VMS_fstat (), VMS_stat ();
108 static char * VMS_strncat ();
109 static int VMS_read ();
110 static int VMS_write ();
111 static int VMS_open ();
112 static FILE * VMS_fopen ();
113 static FILE * VMS_freopen ();
114 static void hack_vms_include_specification ();
115 typedef struct { unsigned :16, :16, :16; } vms_ino_t
;
116 #define ino_t vms_ino_t
117 #define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */
120 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
137 /* Externals defined here. */
139 /* Stream for reading from the input file. */
142 /* These definitions parallel those in c-decl.c so that code from that
143 module can be used pretty much as is. Much of these defs aren't
144 otherwise used, i.e. by g77 code per se, except some of them are used
145 to build some of them that are. The ones that are global (i.e. not
146 "static") are those that ste.c and such might use (directly
147 or by using com macros that reference them in their definitions). */
149 tree string_type_node
;
151 /* The rest of these are inventions for g77, though there might be
152 similar things in the C front end. As they are found, these
153 inventions should be renamed to be canonical. Note that only
154 the ones currently required to be global are so. */
156 static tree ffecom_tree_fun_type_void
;
158 tree ffecom_integer_type_node
; /* Abbrev for _tree_type[blah][blah]. */
159 tree ffecom_integer_zero_node
; /* Like *_*_* with g77's integer type. */
160 tree ffecom_integer_one_node
; /* " */
161 tree ffecom_tree_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
163 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
164 just use build_function_type and build_pointer_type on the
165 appropriate _tree_type array element. */
167 static tree ffecom_tree_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
168 static tree ffecom_tree_ptr_to_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
169 static tree ffecom_tree_subr_type
;
170 static tree ffecom_tree_ptr_to_subr_type
;
171 static tree ffecom_tree_blockdata_type
;
173 static tree ffecom_tree_xargc_
;
175 ffecomSymbol ffecom_symbol_null_
184 ffeinfoKindtype ffecom_pointer_kind_
= FFEINFO_basictypeNONE
;
185 ffeinfoKindtype ffecom_label_kind_
= FFEINFO_basictypeNONE
;
187 int ffecom_f2c_typecode_
[FFEINFO_basictype
][FFEINFO_kindtype
];
188 tree ffecom_f2c_integer_type_node
;
189 tree ffecom_f2c_ptr_to_integer_type_node
;
190 tree ffecom_f2c_address_type_node
;
191 tree ffecom_f2c_real_type_node
;
192 tree ffecom_f2c_ptr_to_real_type_node
;
193 tree ffecom_f2c_doublereal_type_node
;
194 tree ffecom_f2c_complex_type_node
;
195 tree ffecom_f2c_doublecomplex_type_node
;
196 tree ffecom_f2c_longint_type_node
;
197 tree ffecom_f2c_logical_type_node
;
198 tree ffecom_f2c_flag_type_node
;
199 tree ffecom_f2c_ftnlen_type_node
;
200 tree ffecom_f2c_ftnlen_zero_node
;
201 tree ffecom_f2c_ftnlen_one_node
;
202 tree ffecom_f2c_ftnlen_two_node
;
203 tree ffecom_f2c_ptr_to_ftnlen_type_node
;
204 tree ffecom_f2c_ftnint_type_node
;
205 tree ffecom_f2c_ptr_to_ftnint_type_node
;
207 /* Simple definitions and enumerations. */
209 #ifndef FFECOM_sizeMAXSTACKITEM
210 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
211 larger than this # bytes
212 off stack if possible. */
215 /* For systems that have large enough stacks, they should define
216 this to 0, and here, for ease of use later on, we just undefine
219 #if FFECOM_sizeMAXSTACKITEM == 0
220 #undef FFECOM_sizeMAXSTACKITEM
226 FFECOM_rttypeVOIDSTAR_
, /* C's `void *' type. */
227 FFECOM_rttypeFTNINT_
, /* f2c's `ftnint' type. */
228 FFECOM_rttypeINTEGER_
, /* f2c's `integer' type. */
229 FFECOM_rttypeLONGINT_
, /* f2c's `longint' type. */
230 FFECOM_rttypeLOGICAL_
, /* f2c's `logical' type. */
231 FFECOM_rttypeREAL_F2C_
, /* f2c's `real' returned as `double'. */
232 FFECOM_rttypeREAL_GNU_
, /* `real' returned as such. */
233 FFECOM_rttypeCOMPLEX_F2C_
, /* f2c's `complex' returned via 1st arg. */
234 FFECOM_rttypeCOMPLEX_GNU_
, /* f2c's `complex' returned directly. */
235 FFECOM_rttypeDOUBLE_
, /* C's `double' type. */
236 FFECOM_rttypeDOUBLEREAL_
, /* f2c's `doublereal' type. */
237 FFECOM_rttypeDBLCMPLX_F2C_
, /* f2c's `doublecomplex' returned via 1st arg. */
238 FFECOM_rttypeDBLCMPLX_GNU_
, /* f2c's `doublecomplex' returned directly. */
239 FFECOM_rttypeCHARACTER_
, /* f2c `char *'/`ftnlen' pair. */
243 /* Internal typedefs. */
245 typedef struct _ffecom_concat_list_ ffecomConcatList_
;
247 /* Private include files. */
250 /* Internal structure definitions. */
252 struct _ffecom_concat_list_
257 ffetargetCharacterSize minlen
;
258 ffetargetCharacterSize maxlen
;
261 /* Static functions (internal). */
263 static void ffecom_init_decl_processing
PARAMS ((void));
264 static tree
ffecom_arglist_expr_ (const char *argstring
, ffebld args
);
265 static tree
ffecom_widest_expr_type_ (ffebld list
);
266 static bool ffecom_overlap_ (tree dest_decl
, tree dest_offset
,
267 tree dest_size
, tree source_tree
,
268 ffebld source
, bool scalar_arg
);
269 static bool ffecom_args_overlapping_ (tree dest_tree
, ffebld dest
,
270 tree args
, tree callee_commons
,
272 static tree
ffecom_build_f2c_string_ (int i
, const char *s
);
273 static tree
ffecom_call_ (tree fn
, ffeinfoKindtype kt
,
274 bool is_f2c_complex
, tree type
,
275 tree args
, tree dest_tree
,
276 ffebld dest
, bool *dest_used
,
277 tree callee_commons
, bool scalar_args
, tree hook
);
278 static tree
ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
,
279 bool is_f2c_complex
, tree type
,
280 ffebld left
, ffebld right
,
281 tree dest_tree
, ffebld dest
,
282 bool *dest_used
, tree callee_commons
,
283 bool scalar_args
, bool ref
, tree hook
);
284 static void ffecom_char_args_x_ (tree
*xitem
, tree
*length
,
285 ffebld expr
, bool with_null
);
286 static tree
ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
);
287 static tree
ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
);
288 static ffecomConcatList_
289 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
,
291 ffetargetCharacterSize max
);
292 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist
);
293 static ffecomConcatList_
ffecom_concat_list_new_ (ffebld expr
,
294 ffetargetCharacterSize max
);
295 static void ffecom_debug_kludge_ (tree aggr
, const char *aggr_type
,
296 ffesymbol member
, tree member_type
,
297 ffetargetOffset offset
);
298 static void ffecom_do_entry_ (ffesymbol fn
, int entrynum
);
299 static tree
ffecom_expr_ (ffebld expr
, tree dest_tree
, ffebld dest
,
300 bool *dest_used
, bool assignp
, bool widenp
);
301 static tree
ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
302 ffebld dest
, bool *dest_used
);
303 static tree
ffecom_expr_power_integer_ (ffebld expr
);
304 static void ffecom_expr_transform_ (ffebld expr
);
305 static void ffecom_f2c_make_type_ (tree
*type
, int tcode
, const char *name
);
306 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
308 static ffeglobal
ffecom_finish_global_ (ffeglobal global
);
309 static ffesymbol
ffecom_finish_symbol_transform_ (ffesymbol s
);
310 static tree
ffecom_get_appended_identifier_ (char us
, const char *text
);
311 static tree
ffecom_get_external_identifier_ (ffesymbol s
);
312 static tree
ffecom_get_identifier_ (const char *text
);
313 static tree
ffecom_gen_sfuncdef_ (ffesymbol s
,
316 static const char *ffecom_gfrt_args_ (ffecomGfrt ix
);
317 static tree
ffecom_gfrt_tree_ (ffecomGfrt ix
);
318 static tree
ffecom_init_zero_ (tree decl
);
319 static tree
ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
321 static tree
ffecom_intrinsic_len_ (ffebld expr
);
322 static void ffecom_let_char_ (tree dest_tree
,
324 ffetargetCharacterSize dest_size
,
326 static void ffecom_make_gfrt_ (ffecomGfrt ix
);
327 static void ffecom_member_phase1_ (ffestorag mst
, ffestorag st
);
328 static void ffecom_member_phase2_ (ffestorag mst
, ffestorag st
);
329 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size
,
331 static void ffecom_push_dummy_decls_ (ffebld dumlist
,
333 static void ffecom_start_progunit_ (void);
334 static ffesymbol
ffecom_sym_transform_ (ffesymbol s
);
335 static ffesymbol
ffecom_sym_transform_assign_ (ffesymbol s
);
336 static void ffecom_transform_common_ (ffesymbol s
);
337 static void ffecom_transform_equiv_ (ffestorag st
);
338 static tree
ffecom_transform_namelist_ (ffesymbol s
);
339 static void ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
341 static void ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
342 tree
*size
, tree tree
);
343 static tree
ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
344 tree dest_tree
, ffebld dest
,
345 bool *dest_used
, tree hook
);
346 static tree
ffecom_type_localvar_ (ffesymbol s
,
349 static tree
ffecom_type_namelist_ (void);
350 static tree
ffecom_type_vardesc_ (void);
351 static tree
ffecom_vardesc_ (ffebld expr
);
352 static tree
ffecom_vardesc_array_ (ffesymbol s
);
353 static tree
ffecom_vardesc_dims_ (ffesymbol s
);
354 static tree
ffecom_convert_narrow_ (tree type
, tree expr
);
355 static tree
ffecom_convert_widen_ (tree type
, tree expr
);
357 /* These are static functions that parallel those found in the C front
358 end and thus have the same names. */
360 static tree
bison_rule_compstmt_ (void);
361 static void bison_rule_pushlevel_ (void);
362 static void delete_block (tree block
);
363 static int duplicate_decls (tree newdecl
, tree olddecl
);
364 static void finish_decl (tree decl
, tree init
, bool is_top_level
);
365 static void finish_function (int nested
);
366 static const char *lang_printable_name (tree decl
, int v
);
367 static tree
lookup_name_current_level (tree name
);
368 static struct binding_level
*make_binding_level (void);
369 static void pop_f_function_context (void);
370 static void push_f_function_context (void);
371 static void push_parm_decl (tree parm
);
372 static tree
pushdecl_top_level (tree decl
);
373 static int kept_level_p (void);
374 static tree
storedecls (tree decls
);
375 static void store_parm_decls (int is_main_program
);
376 static tree
start_decl (tree decl
, bool is_top_level
);
377 static void start_function (tree name
, tree type
, int nested
, int public);
378 static void ffecom_file_ (const char *name
);
379 static void ffecom_close_include_ (FILE *f
);
380 static int ffecom_decode_include_option_ (char *spec
);
381 static FILE *ffecom_open_include_ (char *name
, ffewhereLine l
,
384 /* Static objects accessed by functions in this module. */
386 static ffesymbol ffecom_primary_entry_
= NULL
;
387 static ffesymbol ffecom_nested_entry_
= NULL
;
388 static ffeinfoKind ffecom_primary_entry_kind_
;
389 static bool ffecom_primary_entry_is_proc_
;
390 static tree ffecom_outer_function_decl_
;
391 static tree ffecom_previous_function_decl_
;
392 static tree ffecom_which_entrypoint_decl_
;
393 static tree ffecom_float_zero_
= NULL_TREE
;
394 static tree ffecom_float_half_
= NULL_TREE
;
395 static tree ffecom_double_zero_
= NULL_TREE
;
396 static tree ffecom_double_half_
= NULL_TREE
;
397 static tree ffecom_func_result_
;/* For functions. */
398 static tree ffecom_func_length_
;/* For CHARACTER fns. */
399 static ffebld ffecom_list_blockdata_
;
400 static ffebld ffecom_list_common_
;
401 static ffebld ffecom_master_arglist_
;
402 static ffeinfoBasictype ffecom_master_bt_
;
403 static ffeinfoKindtype ffecom_master_kt_
;
404 static ffetargetCharacterSize ffecom_master_size_
;
405 static int ffecom_num_fns_
= 0;
406 static int ffecom_num_entrypoints_
= 0;
407 static bool ffecom_is_altreturning_
= FALSE
;
408 static tree ffecom_multi_type_node_
;
409 static tree ffecom_multi_retval_
;
411 ffecom_multi_fields_
[FFEINFO_basictype
][FFEINFO_kindtype
];
412 static bool ffecom_member_namelisted_
; /* _member_phase1_ namelisted? */
413 static bool ffecom_doing_entry_
= FALSE
;
414 static bool ffecom_transform_only_dummies_
= FALSE
;
415 static int ffecom_typesize_pointer_
;
416 static int ffecom_typesize_integer1_
;
418 /* Holds pointer-to-function expressions. */
420 static tree ffecom_gfrt_
[FFECOM_gfrt
]
423 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
424 #include "com-rt.def"
428 /* Holds the external names of the functions. */
430 static const char *const ffecom_gfrt_name_
[FFECOM_gfrt
]
433 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
434 #include "com-rt.def"
438 /* Whether the function returns. */
440 static const bool ffecom_gfrt_volatile_
[FFECOM_gfrt
]
443 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
444 #include "com-rt.def"
448 /* Whether the function returns type complex. */
450 static const bool ffecom_gfrt_complex_
[FFECOM_gfrt
]
453 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
454 #include "com-rt.def"
458 /* Whether the function is const
459 (i.e., has no side effects and only depends on its arguments). */
461 static const bool ffecom_gfrt_const_
[FFECOM_gfrt
]
464 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
465 #include "com-rt.def"
469 /* Type code for the function return value. */
471 static const ffecomRttype_ ffecom_gfrt_type_
[FFECOM_gfrt
]
474 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
475 #include "com-rt.def"
479 /* String of codes for the function's arguments. */
481 static const char *const ffecom_gfrt_argstring_
[FFECOM_gfrt
]
484 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
485 #include "com-rt.def"
489 /* Internal macros. */
491 /* We let tm.h override the types used here, to handle trivial differences
492 such as the choice of unsigned int or long unsigned int for size_t.
493 When machines start needing nontrivial differences in the size type,
494 it would be best to do something here to figure out automatically
495 from other information what type to use. */
498 #define SIZE_TYPE "long unsigned int"
501 #define ffecom_concat_list_count_(catlist) ((catlist).count)
502 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
503 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
504 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
506 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
507 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
509 /* For each binding contour we allocate a binding_level structure
510 * which records the names defined in that contour.
513 * 1) one for each function definition,
514 * where internal declarations of the parameters appear.
516 * The current meaning of a name can be found by searching the levels from
517 * the current one out to the global one.
520 /* Note that the information in the `names' component of the global contour
521 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
525 /* A chain of _DECL nodes for all variables, constants, functions,
526 and typedef types. These are in the reverse of the order supplied.
530 /* For each level (except not the global one),
531 a chain of BLOCK nodes for all the levels
532 that were entered and exited one level down. */
535 /* The BLOCK node for this level, if one has been preallocated.
536 If 0, the BLOCK is allocated (if needed) when the level is popped. */
539 /* The binding level which this one is contained in (inherits from). */
540 struct binding_level
*level_chain
;
542 /* 0: no ffecom_prepare_* functions called at this level yet;
543 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
544 2: ffecom_prepare_end called. */
548 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
550 /* The binding level currently in effect. */
552 static struct binding_level
*current_binding_level
;
554 /* A chain of binding_level structures awaiting reuse. */
556 static struct binding_level
*free_binding_level
;
558 /* The outermost binding level, for names of file scope.
559 This is created when the compiler is started and exists
560 through the entire run. */
562 static struct binding_level
*global_binding_level
;
564 /* Binding level structures are initialized by copying this one. */
566 static const struct binding_level clear_binding_level
568 {NULL
, NULL
, NULL
, NULL_BINDING_LEVEL
, 0};
570 /* Language-dependent contents of an identifier. */
572 struct lang_identifier
574 struct tree_identifier ignore
;
575 tree global_value
, local_value
, label_value
;
579 /* Macros for access to language-specific slots in an identifier. */
580 /* Each of these slots contains a DECL node or null. */
582 /* This represents the value which the identifier has in the
583 file-scope namespace. */
584 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
585 (((struct lang_identifier *)(NODE))->global_value)
586 /* This represents the value which the identifier has in the current
588 #define IDENTIFIER_LOCAL_VALUE(NODE) \
589 (((struct lang_identifier *)(NODE))->local_value)
590 /* This represents the value which the identifier has as a label in
591 the current label scope. */
592 #define IDENTIFIER_LABEL_VALUE(NODE) \
593 (((struct lang_identifier *)(NODE))->label_value)
594 /* This is nonzero if the identifier was "made up" by g77 code. */
595 #define IDENTIFIER_INVENTED(NODE) \
596 (((struct lang_identifier *)(NODE))->invented)
598 /* In identifiers, C uses the following fields in a special way:
599 TREE_PUBLIC to record that there was a previous local extern decl.
600 TREE_USED to record that such a decl was used.
601 TREE_ADDRESSABLE to record that the address of such a decl was used. */
603 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
604 that have names. Here so we can clear out their names' definitions
605 at the end of the function. */
607 static tree named_labels
;
609 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
611 static tree shadowed_labels
;
613 /* Return the subscript expression, modified to do range-checking.
615 `array' is the array to be checked against.
616 `element' is the subscript expression to check.
617 `dim' is the dimension number (starting at 0).
618 `total_dims' is the total number of dimensions (0 for CHARACTER substring).
622 ffecom_subscript_check_ (tree array
, tree element
, int dim
, int total_dims
,
623 const char *array_name
)
625 tree low
= TYPE_MIN_VALUE (TYPE_DOMAIN (array
));
626 tree high
= TYPE_MAX_VALUE (TYPE_DOMAIN (array
));
631 if (element
== error_mark_node
)
634 if (TREE_TYPE (low
) != TREE_TYPE (element
))
636 if (TYPE_PRECISION (TREE_TYPE (low
))
637 > TYPE_PRECISION (TREE_TYPE (element
)))
638 element
= convert (TREE_TYPE (low
), element
);
641 low
= convert (TREE_TYPE (element
), low
);
643 high
= convert (TREE_TYPE (element
), high
);
647 element
= ffecom_save_tree (element
);
650 /* Special handling for substring range checks. Fortran allows the
651 end subscript < begin subscript, which means that expressions like
652 string(1:0) are valid (and yield a null string). In view of this,
653 enforce two simpler conditions:
654 1) element<=high for end-substring;
655 2) element>=low for start-substring.
656 Run-time character movement will enforce remaining conditions.
658 More complicated checks would be better, but present structure only
659 provides one index element at a time, so it is not possible to
660 enforce a check of both i and j in string(i:j). If it were, the
661 complete set of rules would read,
662 if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
663 ((low<=i<=high) && (low<=j<=high)) )
669 cond
= ffecom_2 (LE_EXPR
, integer_type_node
, element
, high
);
671 cond
= ffecom_2 (LE_EXPR
, integer_type_node
, low
, element
);
675 /* Array reference substring range checking. */
677 cond
= ffecom_2 (LE_EXPR
, integer_type_node
,
682 cond
= ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
684 ffecom_2 (LE_EXPR
, integer_type_node
,
702 var
= concat (array_name
, "[", (dim
? "end" : "start"),
703 "-substring]", NULL
);
704 len
= strlen (var
) + 1;
705 arg1
= build_string (len
, var
);
710 len
= strlen (array_name
) + 1;
711 arg1
= build_string (len
, array_name
);
715 var
= xmalloc (strlen (array_name
) + 40);
716 sprintf (var
, "%s[subscript-%d-of-%d]",
718 dim
+ 1, total_dims
);
719 len
= strlen (var
) + 1;
720 arg1
= build_string (len
, var
);
726 = build_type_variant (build_array_type (char_type_node
,
730 build_int_2 (len
, 0))),
732 TREE_CONSTANT (arg1
) = 1;
733 TREE_STATIC (arg1
) = 1;
734 arg1
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (arg1
)),
737 /* s_rnge adds one to the element to print it, so bias against
738 that -- want to print a faithful *subscript* value. */
739 arg2
= convert (ffecom_f2c_ftnint_type_node
,
740 ffecom_2 (MINUS_EXPR
,
743 convert (TREE_TYPE (element
),
746 proc
= concat (input_filename
, "/",
747 IDENTIFIER_POINTER (DECL_NAME (current_function_decl
)),
749 len
= strlen (proc
) + 1;
750 arg3
= build_string (len
, proc
);
755 = build_type_variant (build_array_type (char_type_node
,
759 build_int_2 (len
, 0))),
761 TREE_CONSTANT (arg3
) = 1;
762 TREE_STATIC (arg3
) = 1;
763 arg3
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (arg3
)),
766 arg4
= convert (ffecom_f2c_ftnint_type_node
,
767 build_int_2 (lineno
, 0));
769 arg1
= build_tree_list (NULL_TREE
, arg1
);
770 arg2
= build_tree_list (NULL_TREE
, arg2
);
771 arg3
= build_tree_list (NULL_TREE
, arg3
);
772 arg4
= build_tree_list (NULL_TREE
, arg4
);
773 TREE_CHAIN (arg3
) = arg4
;
774 TREE_CHAIN (arg2
) = arg3
;
775 TREE_CHAIN (arg1
) = arg2
;
779 die
= ffecom_call_gfrt (FFECOM_gfrtRANGE
,
781 TREE_SIDE_EFFECTS (die
) = 1;
783 element
= ffecom_3 (COND_EXPR
,
792 /* Return the computed element of an array reference.
794 `item' is NULL_TREE, or the transformed pointer to the array.
795 `expr' is the original opARRAYREF expression, which is transformed
796 if `item' is NULL_TREE.
797 `want_ptr' is non-zero if a pointer to the element, instead of
798 the element itself, is to be returned. */
801 ffecom_arrayref_ (tree item
, ffebld expr
, int want_ptr
)
803 ffebld dims
[FFECOM_dimensionsMAX
];
806 int flatten
= ffe_is_flatten_arrays ();
812 const char *array_name
;
816 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
)
817 array_name
= ffesymbol_text (ffebld_symter (ffebld_left (expr
)));
819 array_name
= "[expr?]";
821 /* Build up ARRAY_REFs in reverse order (since we're column major
822 here in Fortran land). */
824 for (i
= 0, list
= ffebld_right (expr
);
826 ++i
, list
= ffebld_trail (list
))
828 dims
[i
] = ffebld_head (list
);
829 type
= ffeinfo_type (ffebld_basictype (dims
[i
]),
830 ffebld_kindtype (dims
[i
]));
832 && ffecom_typesize_pointer_
> ffecom_typesize_integer1_
833 && ffetype_size (type
) > ffecom_typesize_integer1_
)
834 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
835 pointers and 32-bit integers. Do the full 64-bit pointer
836 arithmetic, for codes using arrays for nonstandard heap-like
843 need_ptr
= want_ptr
|| flatten
;
848 item
= ffecom_ptr_to_expr (ffebld_left (expr
));
850 item
= ffecom_expr (ffebld_left (expr
));
852 if (item
== error_mark_node
)
855 if (ffeinfo_where (ffebld_info (expr
)) == FFEINFO_whereFLEETING
856 && ! mark_addressable (item
))
857 return error_mark_node
;
860 if (item
== error_mark_node
)
867 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
869 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
871 min
= TYPE_MIN_VALUE (TYPE_DOMAIN (array
));
872 element
= ffecom_expr_ (dims
[i
], NULL
, NULL
, NULL
, FALSE
, TRUE
);
873 if (flag_bounds_check
)
874 element
= ffecom_subscript_check_ (array
, element
, i
, total_dims
,
876 if (element
== error_mark_node
)
879 /* Widen integral arithmetic as desired while preserving
881 tree_type
= TREE_TYPE (element
);
882 tree_type_x
= tree_type
;
884 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
885 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
886 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
888 if (TREE_TYPE (min
) != tree_type_x
)
889 min
= convert (tree_type_x
, min
);
890 if (TREE_TYPE (element
) != tree_type_x
)
891 element
= convert (tree_type_x
, element
);
893 item
= ffecom_2 (PLUS_EXPR
,
894 build_pointer_type (TREE_TYPE (array
)),
896 size_binop (MULT_EXPR
,
897 size_in_bytes (TREE_TYPE (array
)),
899 fold (build (MINUS_EXPR
,
905 item
= ffecom_1 (INDIRECT_REF
,
906 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
))),
916 array
= TYPE_MAIN_VARIANT (TREE_TYPE (item
));
918 element
= ffecom_expr_ (dims
[i
], NULL
, NULL
, NULL
, FALSE
, TRUE
);
919 if (flag_bounds_check
)
920 element
= ffecom_subscript_check_ (array
, element
, i
, total_dims
,
922 if (element
== error_mark_node
)
925 /* Widen integral arithmetic as desired while preserving
927 tree_type
= TREE_TYPE (element
);
928 tree_type_x
= tree_type
;
930 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
931 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
932 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
934 element
= convert (tree_type_x
, element
);
936 item
= ffecom_2 (ARRAY_REF
,
937 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
))),
946 /* This is like gcc's stabilize_reference -- in fact, most of the code
947 comes from that -- but it handles the situation where the reference
948 is going to have its subparts picked at, and it shouldn't change
949 (or trigger extra invocations of functions in the subtrees) due to
950 this. save_expr is a bit overzealous, because we don't need the
951 entire thing calculated and saved like a temp. So, for DECLs, no
952 change is needed, because these are stable aggregates, and ARRAY_REF
953 and such might well be stable too, but for things like calculations,
954 we do need to calculate a snapshot of a value before picking at it. */
957 ffecom_stabilize_aggregate_ (tree ref
)
960 enum tree_code code
= TREE_CODE (ref
);
967 /* No action is needed in this case. */
977 result
= build_nt (code
, stabilize_reference (TREE_OPERAND (ref
, 0)));
981 result
= build_nt (INDIRECT_REF
,
982 stabilize_reference_1 (TREE_OPERAND (ref
, 0)));
986 result
= build_nt (COMPONENT_REF
,
987 stabilize_reference (TREE_OPERAND (ref
, 0)),
988 TREE_OPERAND (ref
, 1));
992 result
= build_nt (BIT_FIELD_REF
,
993 stabilize_reference (TREE_OPERAND (ref
, 0)),
994 stabilize_reference_1 (TREE_OPERAND (ref
, 1)),
995 stabilize_reference_1 (TREE_OPERAND (ref
, 2)));
999 result
= build_nt (ARRAY_REF
,
1000 stabilize_reference (TREE_OPERAND (ref
, 0)),
1001 stabilize_reference_1 (TREE_OPERAND (ref
, 1)));
1005 result
= build_nt (COMPOUND_EXPR
,
1006 stabilize_reference_1 (TREE_OPERAND (ref
, 0)),
1007 stabilize_reference (TREE_OPERAND (ref
, 1)));
1015 return save_expr (ref
);
1018 return error_mark_node
;
1021 TREE_TYPE (result
) = TREE_TYPE (ref
);
1022 TREE_READONLY (result
) = TREE_READONLY (ref
);
1023 TREE_SIDE_EFFECTS (result
) = TREE_SIDE_EFFECTS (ref
);
1024 TREE_THIS_VOLATILE (result
) = TREE_THIS_VOLATILE (ref
);
1029 /* A rip-off of gcc's convert.c convert_to_complex function,
1030 reworked to handle complex implemented as C structures
1031 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1034 ffecom_convert_to_complex_ (tree type
, tree expr
)
1036 register enum tree_code form
= TREE_CODE (TREE_TYPE (expr
));
1039 assert (TREE_CODE (type
) == RECORD_TYPE
);
1041 subtype
= TREE_TYPE (TYPE_FIELDS (type
));
1043 if (form
== REAL_TYPE
|| form
== INTEGER_TYPE
|| form
== ENUMERAL_TYPE
)
1045 expr
= convert (subtype
, expr
);
1046 return ffecom_2 (COMPLEX_EXPR
, type
, expr
,
1047 convert (subtype
, integer_zero_node
));
1050 if (form
== RECORD_TYPE
)
1052 tree elt_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
)));
1053 if (TYPE_MAIN_VARIANT (elt_type
) == TYPE_MAIN_VARIANT (subtype
))
1057 expr
= save_expr (expr
);
1058 return ffecom_2 (COMPLEX_EXPR
,
1061 ffecom_1 (REALPART_EXPR
,
1062 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
1065 ffecom_1 (IMAGPART_EXPR
,
1066 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
1071 if (form
== POINTER_TYPE
|| form
== REFERENCE_TYPE
)
1072 error ("pointer value used where a complex was expected");
1074 error ("aggregate value used where a complex was expected");
1076 return ffecom_2 (COMPLEX_EXPR
, type
,
1077 convert (subtype
, integer_zero_node
),
1078 convert (subtype
, integer_zero_node
));
1081 /* Like gcc's convert(), but crashes if widening might happen. */
1084 ffecom_convert_narrow_ (type
, expr
)
1087 register tree e
= expr
;
1088 register enum tree_code code
= TREE_CODE (type
);
1090 if (type
== TREE_TYPE (e
)
1091 || TREE_CODE (e
) == ERROR_MARK
)
1093 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
1094 return fold (build1 (NOP_EXPR
, type
, e
));
1095 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
1096 || code
== ERROR_MARK
)
1097 return error_mark_node
;
1098 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
1100 assert ("void value not ignored as it ought to be" == NULL
);
1101 return error_mark_node
;
1103 assert (code
!= VOID_TYPE
);
1104 if ((code
!= RECORD_TYPE
)
1105 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
1106 assert ("converting COMPLEX to REAL" == NULL
);
1107 assert (code
!= ENUMERAL_TYPE
);
1108 if (code
== INTEGER_TYPE
)
1110 assert ((TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
1111 && TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)))
1112 || (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
1113 && (TYPE_PRECISION (type
)
1114 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e
))))));
1115 return fold (convert_to_integer (type
, e
));
1117 if (code
== POINTER_TYPE
)
1119 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1120 return fold (convert_to_pointer (type
, e
));
1122 if (code
== REAL_TYPE
)
1124 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1125 assert (TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)));
1126 return fold (convert_to_real (type
, e
));
1128 if (code
== COMPLEX_TYPE
)
1130 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1131 assert (TYPE_PRECISION (TREE_TYPE (type
)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1132 return fold (convert_to_complex (type
, e
));
1134 if (code
== RECORD_TYPE
)
1136 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1137 /* Check that at least the first field name agrees. */
1138 assert (DECL_NAME (TYPE_FIELDS (type
))
1139 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e
))));
1140 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1141 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1142 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1143 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))))
1145 return fold (ffecom_convert_to_complex_ (type
, e
));
1148 assert ("conversion to non-scalar type requested" == NULL
);
1149 return error_mark_node
;
1152 /* Like gcc's convert(), but crashes if narrowing might happen. */
1155 ffecom_convert_widen_ (type
, expr
)
1158 register tree e
= expr
;
1159 register enum tree_code code
= TREE_CODE (type
);
1161 if (type
== TREE_TYPE (e
)
1162 || TREE_CODE (e
) == ERROR_MARK
)
1164 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
1165 return fold (build1 (NOP_EXPR
, type
, e
));
1166 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
1167 || code
== ERROR_MARK
)
1168 return error_mark_node
;
1169 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
1171 assert ("void value not ignored as it ought to be" == NULL
);
1172 return error_mark_node
;
1174 assert (code
!= VOID_TYPE
);
1175 if ((code
!= RECORD_TYPE
)
1176 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
1177 assert ("narrowing COMPLEX to REAL" == NULL
);
1178 assert (code
!= ENUMERAL_TYPE
);
1179 if (code
== INTEGER_TYPE
)
1181 assert ((TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
1182 && TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)))
1183 || (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
1184 && (TYPE_PRECISION (type
)
1185 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e
))))));
1186 return fold (convert_to_integer (type
, e
));
1188 if (code
== POINTER_TYPE
)
1190 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1191 return fold (convert_to_pointer (type
, e
));
1193 if (code
== REAL_TYPE
)
1195 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1196 assert (TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)));
1197 return fold (convert_to_real (type
, e
));
1199 if (code
== COMPLEX_TYPE
)
1201 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1202 assert (TYPE_PRECISION (TREE_TYPE (type
)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1203 return fold (convert_to_complex (type
, e
));
1205 if (code
== RECORD_TYPE
)
1207 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1208 /* Check that at least the first field name agrees. */
1209 assert (DECL_NAME (TYPE_FIELDS (type
))
1210 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e
))));
1211 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1212 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1213 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1214 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))))
1216 return fold (ffecom_convert_to_complex_ (type
, e
));
1219 assert ("conversion to non-scalar type requested" == NULL
);
1220 return error_mark_node
;
1223 /* Handles making a COMPLEX type, either the standard
1224 (but buggy?) gbe way, or the safer (but less elegant?)
1228 ffecom_make_complex_type_ (tree subtype
)
1234 if (ffe_is_emulate_complex ())
1236 type
= make_node (RECORD_TYPE
);
1237 realfield
= ffecom_decl_field (type
, NULL_TREE
, "r", subtype
);
1238 imagfield
= ffecom_decl_field (type
, realfield
, "i", subtype
);
1239 TYPE_FIELDS (type
) = realfield
;
1244 type
= make_node (COMPLEX_TYPE
);
1245 TREE_TYPE (type
) = subtype
;
1252 /* Chooses either the gbe or the f2c way to build a
1253 complex constant. */
1256 ffecom_build_complex_constant_ (tree type
, tree realpart
, tree imagpart
)
1260 if (ffe_is_emulate_complex ())
1262 bothparts
= build_tree_list (TYPE_FIELDS (type
), realpart
);
1263 TREE_CHAIN (bothparts
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), imagpart
);
1264 bothparts
= build (CONSTRUCTOR
, type
, NULL_TREE
, bothparts
);
1268 bothparts
= build_complex (type
, realpart
, imagpart
);
1275 ffecom_arglist_expr_ (const char *c
, ffebld expr
)
1278 tree
*plist
= &list
;
1279 tree trail
= NULL_TREE
; /* Append char length args here. */
1280 tree
*ptrail
= &trail
;
1285 tree wanted
= NULL_TREE
;
1286 static const char zed
[] = "0";
1291 while (expr
!= NULL
)
1314 wanted
= ffecom_f2c_complex_type_node
;
1318 wanted
= ffecom_f2c_doublereal_type_node
;
1322 wanted
= ffecom_f2c_doublecomplex_type_node
;
1326 wanted
= ffecom_f2c_real_type_node
;
1330 wanted
= ffecom_f2c_integer_type_node
;
1334 wanted
= ffecom_f2c_longint_type_node
;
1338 assert ("bad argstring code" == NULL
);
1344 exprh
= ffebld_head (expr
);
1348 if ((wanted
== NULL_TREE
)
1351 (ffecom_tree_type
[ffeinfo_basictype (ffebld_info (exprh
))]
1352 [ffeinfo_kindtype (ffebld_info (exprh
))])
1353 == TYPE_MODE (wanted
))))
1355 = build_tree_list (NULL_TREE
,
1356 ffecom_arg_ptr_to_expr (exprh
,
1360 item
= ffecom_arg_expr (exprh
, &length
);
1361 item
= ffecom_convert_widen_ (wanted
, item
);
1364 item
= ffecom_1 (ADDR_EXPR
,
1365 build_pointer_type (TREE_TYPE (item
)),
1369 = build_tree_list (NULL_TREE
,
1373 plist
= &TREE_CHAIN (*plist
);
1374 expr
= ffebld_trail (expr
);
1375 if (length
!= NULL_TREE
)
1377 *ptrail
= build_tree_list (NULL_TREE
, length
);
1378 ptrail
= &TREE_CHAIN (*ptrail
);
1382 /* We've run out of args in the call; if the implementation expects
1383 more, supply null pointers for them, which the implementation can
1384 check to see if an arg was omitted. */
1386 while (*c
!= '\0' && *c
!= '0')
1391 assert ("missing arg to run-time routine!" == NULL
);
1406 assert ("bad arg string code" == NULL
);
1410 = build_tree_list (NULL_TREE
,
1412 plist
= &TREE_CHAIN (*plist
);
1421 ffecom_widest_expr_type_ (ffebld list
)
1424 ffebld widest
= NULL
;
1426 ffetype widest_type
= NULL
;
1429 for (; list
!= NULL
; list
= ffebld_trail (list
))
1431 item
= ffebld_head (list
);
1434 if ((widest
!= NULL
)
1435 && (ffeinfo_basictype (ffebld_info (item
))
1436 != ffeinfo_basictype (ffebld_info (widest
))))
1438 type
= ffeinfo_type (ffeinfo_basictype (ffebld_info (item
)),
1439 ffeinfo_kindtype (ffebld_info (item
)));
1440 if ((widest
== FFEINFO_kindtypeNONE
)
1441 || (ffetype_size (type
)
1442 > ffetype_size (widest_type
)))
1449 assert (widest
!= NULL
);
1450 t
= ffecom_tree_type
[ffeinfo_basictype (ffebld_info (widest
))]
1451 [ffeinfo_kindtype (ffebld_info (widest
))];
1452 assert (t
!= NULL_TREE
);
1456 /* Check whether a partial overlap between two expressions is possible.
1458 Can *starting* to write a portion of expr1 change the value
1459 computed (perhaps already, *partially*) by expr2?
1461 Currently, this is a concern only for a COMPLEX expr1. But if it
1462 isn't in COMMON or local EQUIVALENCE, since we don't support
1463 aliasing of arguments, it isn't a concern. */
1466 ffecom_possible_partial_overlap_ (ffebld expr1
, ffebld expr2 ATTRIBUTE_UNUSED
)
1471 switch (ffebld_op (expr1
))
1473 case FFEBLD_opSYMTER
:
1474 sym
= ffebld_symter (expr1
);
1477 case FFEBLD_opARRAYREF
:
1478 if (ffebld_op (ffebld_left (expr1
)) != FFEBLD_opSYMTER
)
1480 sym
= ffebld_symter (ffebld_left (expr1
));
1487 if (ffesymbol_where (sym
) != FFEINFO_whereCOMMON
1488 && (ffesymbol_where (sym
) != FFEINFO_whereLOCAL
1489 || ! (st
= ffesymbol_storage (sym
))
1490 || ! ffestorag_parent (st
)))
1493 /* It's in COMMON or local EQUIVALENCE. */
1498 /* Check whether dest and source might overlap. ffebld versions of these
1499 might or might not be passed, will be NULL if not.
1501 The test is really whether source_tree is modifiable and, if modified,
1502 might overlap destination such that the value(s) in the destination might
1503 change before it is finally modified. dest_* are the canonized
1504 destination itself. */
1507 ffecom_overlap_ (tree dest_decl
, tree dest_offset
, tree dest_size
,
1508 tree source_tree
, ffebld source UNUSED
,
1516 if (source_tree
== NULL_TREE
)
1519 switch (TREE_CODE (source_tree
))
1522 case IDENTIFIER_NODE
:
1533 case TRUNC_DIV_EXPR
:
1535 case FLOOR_DIV_EXPR
:
1536 case ROUND_DIV_EXPR
:
1537 case TRUNC_MOD_EXPR
:
1539 case FLOOR_MOD_EXPR
:
1540 case ROUND_MOD_EXPR
:
1542 case EXACT_DIV_EXPR
:
1543 case FIX_TRUNC_EXPR
:
1545 case FIX_FLOOR_EXPR
:
1546 case FIX_ROUND_EXPR
:
1560 case BIT_ANDTC_EXPR
:
1562 case TRUTH_ANDIF_EXPR
:
1563 case TRUTH_ORIF_EXPR
:
1564 case TRUTH_AND_EXPR
:
1566 case TRUTH_XOR_EXPR
:
1567 case TRUTH_NOT_EXPR
:
1583 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1584 TREE_OPERAND (source_tree
, 1), NULL
,
1588 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1589 TREE_OPERAND (source_tree
, 0), NULL
,
1594 case NON_LVALUE_EXPR
:
1596 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1599 ffecom_tree_canonize_ptr_ (&source_decl
, &source_offset
,
1601 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1606 ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1607 TREE_OPERAND (source_tree
, 1), NULL
,
1609 || ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1610 TREE_OPERAND (source_tree
, 2), NULL
,
1615 ffecom_tree_canonize_ref_ (&source_decl
, &source_offset
,
1617 TREE_OPERAND (source_tree
, 0));
1621 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1624 source_decl
= source_tree
;
1625 source_offset
= bitsize_zero_node
;
1626 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1630 case REFERENCE_EXPR
:
1631 case PREDECREMENT_EXPR
:
1632 case PREINCREMENT_EXPR
:
1633 case POSTDECREMENT_EXPR
:
1634 case POSTINCREMENT_EXPR
:
1642 /* Come here when source_decl, source_offset, and source_size filled
1643 in appropriately. */
1645 if (source_decl
== NULL_TREE
)
1646 return FALSE
; /* No decl involved, so no overlap. */
1648 if (source_decl
!= dest_decl
)
1649 return FALSE
; /* Different decl, no overlap. */
1651 if (TREE_CODE (dest_size
) == ERROR_MARK
)
1652 return TRUE
; /* Assignment into entire assumed-size
1653 array? Shouldn't happen.... */
1655 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1656 ffecom_2 (PLUS_EXPR
, TREE_TYPE (dest_offset
),
1658 convert (TREE_TYPE (dest_offset
),
1660 convert (TREE_TYPE (dest_offset
),
1663 if (integer_onep (t
))
1664 return FALSE
; /* Destination precedes source. */
1667 || (source_size
== NULL_TREE
)
1668 || (TREE_CODE (source_size
) == ERROR_MARK
)
1669 || integer_zerop (source_size
))
1670 return TRUE
; /* No way to tell if dest follows source. */
1672 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1673 ffecom_2 (PLUS_EXPR
, TREE_TYPE (source_offset
),
1675 convert (TREE_TYPE (source_offset
),
1677 convert (TREE_TYPE (source_offset
),
1680 if (integer_onep (t
))
1681 return FALSE
; /* Destination follows source. */
1683 return TRUE
; /* Destination and source overlap. */
1686 /* Check whether dest might overlap any of a list of arguments or is
1687 in a COMMON area the callee might know about (and thus modify). */
1690 ffecom_args_overlapping_ (tree dest_tree
, ffebld dest UNUSED
,
1691 tree args
, tree callee_commons
,
1699 ffecom_tree_canonize_ref_ (&dest_decl
, &dest_offset
, &dest_size
,
1702 if (dest_decl
== NULL_TREE
)
1703 return FALSE
; /* Seems unlikely! */
1705 /* If the decl cannot be determined reliably, or if its in COMMON
1706 and the callee isn't known to not futz with COMMON via other
1707 means, overlap might happen. */
1709 if ((TREE_CODE (dest_decl
) == ERROR_MARK
)
1710 || ((callee_commons
!= NULL_TREE
)
1711 && TREE_PUBLIC (dest_decl
)))
1714 for (; args
!= NULL_TREE
; args
= TREE_CHAIN (args
))
1716 if (((arg
= TREE_VALUE (args
)) != NULL_TREE
)
1717 && ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1718 arg
, NULL
, scalar_args
))
1725 /* Build a string for a variable name as used by NAMELIST. This means that
1726 if we're using the f2c library, we build an uppercase string, since
1730 ffecom_build_f2c_string_ (int i
, const char *s
)
1732 if (!ffe_is_f2c_library ())
1733 return build_string (i
, s
);
1742 if (((size_t) i
) > ARRAY_SIZE (space
))
1743 tmp
= malloc_new_ks (malloc_pool_image (), "f2c_string", i
);
1747 for (p
= s
, q
= tmp
; *p
!= '\0'; ++p
, ++q
)
1751 t
= build_string (i
, tmp
);
1753 if (((size_t) i
) > ARRAY_SIZE (space
))
1754 malloc_kill_ks (malloc_pool_image (), tmp
, i
);
1760 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1761 type to just get whatever the function returns), handling the
1762 f2c value-returning convention, if required, by prepending
1763 to the arglist a pointer to a temporary to receive the return value. */
1766 ffecom_call_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1767 tree type
, tree args
, tree dest_tree
,
1768 ffebld dest
, bool *dest_used
, tree callee_commons
,
1769 bool scalar_args
, tree hook
)
1774 if (dest_used
!= NULL
)
1779 if ((dest_used
== NULL
)
1781 || (ffeinfo_basictype (ffebld_info (dest
))
1782 != FFEINFO_basictypeCOMPLEX
)
1783 || (ffeinfo_kindtype (ffebld_info (dest
)) != kt
)
1784 || ((type
!= NULL_TREE
) && (TREE_TYPE (dest_tree
) != type
))
1785 || ffecom_args_overlapping_ (dest_tree
, dest
, args
,
1790 tempvar
= ffecom_make_tempvar (ffecom_tree_type
1791 [FFEINFO_basictypeCOMPLEX
][kt
],
1792 FFETARGET_charactersizeNONE
,
1802 tempvar
= dest_tree
;
1807 = build_tree_list (NULL_TREE
,
1808 ffecom_1 (ADDR_EXPR
,
1809 build_pointer_type (TREE_TYPE (tempvar
)),
1811 TREE_CHAIN (item
) = args
;
1813 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1816 if (tempvar
!= dest_tree
)
1817 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
, tempvar
);
1820 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1823 if ((type
!= NULL_TREE
) && (TREE_TYPE (item
) != type
))
1824 item
= ffecom_convert_narrow_ (type
, item
);
1829 /* Given two arguments, transform them and make a call to the given
1830 function via ffecom_call_. */
1833 ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1834 tree type
, ffebld left
, ffebld right
,
1835 tree dest_tree
, ffebld dest
, bool *dest_used
,
1836 tree callee_commons
, bool scalar_args
, bool ref
, tree hook
)
1845 /* Pass arguments by reference. */
1846 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
1847 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
1851 /* Pass arguments by value. */
1852 left_tree
= ffecom_arg_expr (left
, &left_length
);
1853 right_tree
= ffecom_arg_expr (right
, &right_length
);
1857 left_tree
= build_tree_list (NULL_TREE
, left_tree
);
1858 right_tree
= build_tree_list (NULL_TREE
, right_tree
);
1859 TREE_CHAIN (left_tree
) = right_tree
;
1861 if (left_length
!= NULL_TREE
)
1863 left_length
= build_tree_list (NULL_TREE
, left_length
);
1864 TREE_CHAIN (right_tree
) = left_length
;
1867 if (right_length
!= NULL_TREE
)
1869 right_length
= build_tree_list (NULL_TREE
, right_length
);
1870 if (left_length
!= NULL_TREE
)
1871 TREE_CHAIN (left_length
) = right_length
;
1873 TREE_CHAIN (right_tree
) = right_length
;
1876 return ffecom_call_ (fn
, kt
, is_f2c_complex
, type
, left_tree
,
1877 dest_tree
, dest
, dest_used
, callee_commons
,
1881 /* Return ptr/length args for char subexpression
1883 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1884 subexpressions by constructing the appropriate trees for the ptr-to-
1885 character-text and length-of-character-text arguments in a calling
1888 Note that if with_null is TRUE, and the expression is an opCONTER,
1889 a null byte is appended to the string. */
1892 ffecom_char_args_x_ (tree
*xitem
, tree
*length
, ffebld expr
, bool with_null
)
1896 ffetargetCharacter1 val
;
1897 ffetargetCharacterSize newlen
;
1899 switch (ffebld_op (expr
))
1901 case FFEBLD_opCONTER
:
1902 val
= ffebld_constant_character1 (ffebld_conter (expr
));
1903 newlen
= ffetarget_length_character1 (val
);
1906 /* Begin FFETARGET-NULL-KLUDGE. */
1910 *length
= build_int_2 (newlen
, 0);
1911 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1912 high
= build_int_2 (newlen
, 0);
1913 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
1914 item
= build_string (newlen
,
1915 ffetarget_text_character1 (val
));
1916 /* End FFETARGET-NULL-KLUDGE. */
1918 = build_type_variant
1922 (ffecom_f2c_ftnlen_type_node
,
1923 ffecom_f2c_ftnlen_one_node
,
1926 TREE_CONSTANT (item
) = 1;
1927 TREE_STATIC (item
) = 1;
1928 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
1932 case FFEBLD_opSYMTER
:
1934 ffesymbol s
= ffebld_symter (expr
);
1936 item
= ffesymbol_hook (s
).decl_tree
;
1937 if (item
== NULL_TREE
)
1939 s
= ffecom_sym_transform_ (s
);
1940 item
= ffesymbol_hook (s
).decl_tree
;
1942 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
1944 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
1945 *length
= ffesymbol_hook (s
).length_tree
;
1948 *length
= build_int_2 (ffesymbol_size (s
), 0);
1949 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1952 else if (item
== error_mark_node
)
1953 *length
= error_mark_node
;
1955 /* FFEINFO_kindFUNCTION. */
1956 *length
= NULL_TREE
;
1957 if (!ffesymbol_hook (s
).addr
1958 && (item
!= error_mark_node
))
1959 item
= ffecom_1 (ADDR_EXPR
,
1960 build_pointer_type (TREE_TYPE (item
)),
1965 case FFEBLD_opARRAYREF
:
1967 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1969 if (item
== error_mark_node
|| *length
== error_mark_node
)
1971 item
= *length
= error_mark_node
;
1975 item
= ffecom_arrayref_ (item
, expr
, 1);
1979 case FFEBLD_opSUBSTR
:
1983 ffebld thing
= ffebld_right (expr
);
1986 const char *char_name
;
1990 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
1991 start
= ffebld_head (thing
);
1992 thing
= ffebld_trail (thing
);
1993 assert (ffebld_trail (thing
) == NULL
);
1994 end
= ffebld_head (thing
);
1996 /* Determine name for pretty-printing range-check errors. */
1997 for (left_symter
= ffebld_left (expr
);
1998 left_symter
&& ffebld_op (left_symter
) == FFEBLD_opARRAYREF
;
1999 left_symter
= ffebld_left (left_symter
))
2001 if (ffebld_op (left_symter
) == FFEBLD_opSYMTER
)
2002 char_name
= ffesymbol_text (ffebld_symter (left_symter
));
2004 char_name
= "[expr?]";
2006 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
2008 if (item
== error_mark_node
|| *length
== error_mark_node
)
2010 item
= *length
= error_mark_node
;
2014 array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
2016 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2024 end_tree
= ffecom_expr (end
);
2025 if (flag_bounds_check
)
2026 end_tree
= ffecom_subscript_check_ (array
, end_tree
, 1, 0,
2028 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2031 if (end_tree
== error_mark_node
)
2033 item
= *length
= error_mark_node
;
2042 start_tree
= ffecom_expr (start
);
2043 if (flag_bounds_check
)
2044 start_tree
= ffecom_subscript_check_ (array
, start_tree
, 0, 0,
2046 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2049 if (start_tree
== error_mark_node
)
2051 item
= *length
= error_mark_node
;
2055 start_tree
= ffecom_save_tree (start_tree
);
2057 item
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (item
),
2059 ffecom_2 (MINUS_EXPR
,
2060 TREE_TYPE (start_tree
),
2062 ffecom_f2c_ftnlen_one_node
));
2066 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
2067 ffecom_f2c_ftnlen_one_node
,
2068 ffecom_2 (MINUS_EXPR
,
2069 ffecom_f2c_ftnlen_type_node
,
2075 end_tree
= ffecom_expr (end
);
2076 if (flag_bounds_check
)
2077 end_tree
= ffecom_subscript_check_ (array
, end_tree
, 1, 0,
2079 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2082 if (end_tree
== error_mark_node
)
2084 item
= *length
= error_mark_node
;
2088 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
2089 ffecom_f2c_ftnlen_one_node
,
2090 ffecom_2 (MINUS_EXPR
,
2091 ffecom_f2c_ftnlen_type_node
,
2092 end_tree
, start_tree
));
2098 case FFEBLD_opFUNCREF
:
2100 ffesymbol s
= ffebld_symter (ffebld_left (expr
));
2103 ffetargetCharacterSize size
= ffeinfo_size (ffebld_info (expr
));
2106 if (size
== FFETARGET_charactersizeNONE
)
2107 /* ~~Kludge alert! This should someday be fixed. */
2110 *length
= build_int_2 (size
, 0);
2111 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2113 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
2114 == FFEINFO_whereINTRINSIC
)
2118 /* Invocation of an intrinsic returning CHARACTER*1. */
2119 item
= ffecom_expr_intrinsic_ (expr
, NULL_TREE
,
2123 ix
= ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr
)));
2124 assert (ix
!= FFECOM_gfrt
);
2125 item
= ffecom_gfrt_tree_ (ix
);
2130 item
= ffesymbol_hook (s
).decl_tree
;
2131 if (item
== NULL_TREE
)
2133 s
= ffecom_sym_transform_ (s
);
2134 item
= ffesymbol_hook (s
).decl_tree
;
2136 if (item
== error_mark_node
)
2138 item
= *length
= error_mark_node
;
2142 if (!ffesymbol_hook (s
).addr
)
2143 item
= ffecom_1_fn (item
);
2147 tempvar
= ffecom_push_tempvar (char_type_node
, size
, -1, TRUE
);
2149 tempvar
= ffebld_nonter_hook (expr
);
2152 tempvar
= ffecom_1 (ADDR_EXPR
,
2153 build_pointer_type (TREE_TYPE (tempvar
)),
2156 args
= build_tree_list (NULL_TREE
, tempvar
);
2158 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
) /* Sfunc args by value. */
2159 TREE_CHAIN (args
) = ffecom_list_expr (ffebld_right (expr
));
2162 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, *length
);
2163 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
2165 TREE_CHAIN (TREE_CHAIN (args
))
2166 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix
),
2167 ffebld_right (expr
));
2171 TREE_CHAIN (TREE_CHAIN (args
))
2172 = ffecom_list_ptr_to_expr (ffebld_right (expr
));
2176 item
= ffecom_3s (CALL_EXPR
,
2177 TREE_TYPE (TREE_TYPE (TREE_TYPE (item
))),
2178 item
, args
, NULL_TREE
);
2179 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
,
2184 case FFEBLD_opCONVERT
:
2186 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
2188 if (item
== error_mark_node
|| *length
== error_mark_node
)
2190 item
= *length
= error_mark_node
;
2194 if ((ffebld_size_known (ffebld_left (expr
))
2195 == FFETARGET_charactersizeNONE
)
2196 || (ffebld_size_known (ffebld_left (expr
)) < (ffebld_size (expr
))))
2197 { /* Possible blank-padding needed, copy into
2204 tempvar
= ffecom_make_tempvar (char_type_node
,
2205 ffebld_size (expr
), -1);
2207 tempvar
= ffebld_nonter_hook (expr
);
2210 tempvar
= ffecom_1 (ADDR_EXPR
,
2211 build_pointer_type (TREE_TYPE (tempvar
)),
2214 newlen
= build_int_2 (ffebld_size (expr
), 0);
2215 TREE_TYPE (newlen
) = ffecom_f2c_ftnlen_type_node
;
2217 args
= build_tree_list (NULL_TREE
, tempvar
);
2218 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, item
);
2219 TREE_CHAIN (TREE_CHAIN (args
)) = build_tree_list (NULL_TREE
, newlen
);
2220 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args
)))
2221 = build_tree_list (NULL_TREE
, *length
);
2223 item
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, args
, NULL_TREE
);
2224 TREE_SIDE_EFFECTS (item
) = 1;
2225 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), fold (item
),
2230 { /* Just truncate the length. */
2231 *length
= build_int_2 (ffebld_size (expr
), 0);
2232 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2237 assert ("bad op for single char arg expr" == NULL
);
2245 /* Check the size of the type to be sure it doesn't overflow the
2246 "portable" capacities of the compiler back end. `dummy' types
2247 can generally overflow the normal sizes as long as the computations
2248 themselves don't overflow. A particular target of the back end
2249 must still enforce its size requirements, though, and the back
2250 end takes care of this in stor-layout.c. */
2253 ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
)
2255 if (TREE_CODE (type
) == ERROR_MARK
)
2258 if (TYPE_SIZE (type
) == NULL_TREE
)
2261 if (TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
)
2264 if ((tree_int_cst_sgn (TYPE_SIZE (type
)) < 0)
2265 || (!dummy
&& TREE_OVERFLOW (TYPE_SIZE (type
))))
2267 ffebad_start (FFEBAD_ARRAY_LARGE
);
2268 ffebad_string (ffesymbol_text (s
));
2269 ffebad_here (0, ffesymbol_where_line (s
), ffesymbol_where_column (s
));
2272 return error_mark_node
;
2278 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2279 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2280 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2283 ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
)
2285 ffetargetCharacterSize sz
= ffesymbol_size (s
);
2290 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
2291 tlen
= NULL_TREE
; /* A statement function, no length passed. */
2294 if (ffesymbol_where (s
) == FFEINFO_whereDUMMY
)
2295 tlen
= ffecom_get_invented_identifier ("__g77_length_%s",
2296 ffesymbol_text (s
));
2298 tlen
= ffecom_get_invented_identifier ("__g77_%s", "length");
2299 tlen
= build_decl (PARM_DECL
, tlen
, ffecom_f2c_ftnlen_type_node
);
2300 DECL_ARTIFICIAL (tlen
) = 1;
2303 if (sz
== FFETARGET_charactersizeNONE
)
2305 assert (tlen
!= NULL_TREE
);
2306 highval
= variable_size (tlen
);
2310 highval
= build_int_2 (sz
, 0);
2311 TREE_TYPE (highval
) = ffecom_f2c_ftnlen_type_node
;
2314 type
= build_array_type (type
,
2315 build_range_type (ffecom_f2c_ftnlen_type_node
,
2316 ffecom_f2c_ftnlen_one_node
,
2323 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2325 ffecomConcatList_ catlist;
2326 ffebld expr; // expr of CHARACTER basictype.
2327 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2328 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2330 Scans expr for character subexpressions, updates and returns catlist
2333 static ffecomConcatList_
2334 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
, ffebld expr
,
2335 ffetargetCharacterSize max
)
2337 ffetargetCharacterSize sz
;
2344 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
>= max
))
2345 return catlist
; /* Don't append any more items. */
2347 switch (ffebld_op (expr
))
2349 case FFEBLD_opCONTER
:
2350 case FFEBLD_opSYMTER
:
2351 case FFEBLD_opARRAYREF
:
2352 case FFEBLD_opFUNCREF
:
2353 case FFEBLD_opSUBSTR
:
2354 case FFEBLD_opCONVERT
: /* Callers should strip this off beforehand
2355 if they don't need to preserve it. */
2356 if (catlist
.count
== catlist
.max
)
2357 { /* Make a (larger) list. */
2361 newmax
= (catlist
.max
== 0) ? 8 : catlist
.max
* 2;
2362 newx
= malloc_new_ks (malloc_pool_image (), "catlist",
2363 newmax
* sizeof (newx
[0]));
2364 if (catlist
.max
!= 0)
2366 memcpy (newx
, catlist
.exprs
, catlist
.max
* sizeof (newx
[0]));
2367 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2368 catlist
.max
* sizeof (newx
[0]));
2370 catlist
.max
= newmax
;
2371 catlist
.exprs
= newx
;
2373 if ((sz
= ffebld_size_known (expr
)) != FFETARGET_charactersizeNONE
)
2374 catlist
.minlen
+= sz
;
2376 ++catlist
.minlen
; /* Not true for F90; can be 0 length. */
2377 if ((sz
= ffebld_size_max (expr
)) == FFETARGET_charactersizeNONE
)
2378 catlist
.maxlen
= sz
;
2380 catlist
.maxlen
+= sz
;
2381 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
> max
))
2382 { /* This item overlaps (or is beyond) the end
2383 of the destination. */
2384 switch (ffebld_op (expr
))
2386 case FFEBLD_opCONTER
:
2387 case FFEBLD_opSYMTER
:
2388 case FFEBLD_opARRAYREF
:
2389 case FFEBLD_opFUNCREF
:
2390 case FFEBLD_opSUBSTR
:
2391 /* ~~Do useful truncations here. */
2395 assert ("op changed or inconsistent switches!" == NULL
);
2399 catlist
.exprs
[catlist
.count
++] = expr
;
2402 case FFEBLD_opPAREN
:
2403 expr
= ffebld_left (expr
);
2404 goto recurse
; /* :::::::::::::::::::: */
2406 case FFEBLD_opCONCATENATE
:
2407 catlist
= ffecom_concat_list_gather_ (catlist
, ffebld_left (expr
), max
);
2408 expr
= ffebld_right (expr
);
2409 goto recurse
; /* :::::::::::::::::::: */
2411 #if 0 /* Breaks passing small actual arg to larger
2412 dummy arg of sfunc */
2413 case FFEBLD_opCONVERT
:
2414 expr
= ffebld_left (expr
);
2416 ffetargetCharacterSize cmax
;
2418 cmax
= catlist
.len
+ ffebld_size_known (expr
);
2420 if ((max
== FFETARGET_charactersizeNONE
) || (max
> cmax
))
2423 goto recurse
; /* :::::::::::::::::::: */
2430 assert ("bad op in _gather_" == NULL
);
2435 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2437 ffecomConcatList_ catlist;
2438 ffecom_concat_list_kill_(catlist);
2440 Anything allocated within the list info is deallocated. */
2443 ffecom_concat_list_kill_ (ffecomConcatList_ catlist
)
2445 if (catlist
.max
!= 0)
2446 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2447 catlist
.max
* sizeof (catlist
.exprs
[0]));
2450 /* Make list of concatenated string exprs.
2452 Returns a flattened list of concatenated subexpressions given a
2453 tree of such expressions. */
2455 static ffecomConcatList_
2456 ffecom_concat_list_new_ (ffebld expr
, ffetargetCharacterSize max
)
2458 ffecomConcatList_ catlist
;
2460 catlist
.maxlen
= catlist
.minlen
= catlist
.max
= catlist
.count
= 0;
2461 return ffecom_concat_list_gather_ (catlist
, expr
, max
);
2464 /* Provide some kind of useful info on member of aggregate area,
2465 since current g77/gcc technology does not provide debug info
2466 on these members. */
2469 ffecom_debug_kludge_ (tree aggr
, const char *aggr_type
, ffesymbol member
,
2470 tree member_type UNUSED
, ffetargetOffset offset
)
2480 for (type_id
= member_type
;
2481 TREE_CODE (type_id
) != IDENTIFIER_NODE
;
2484 switch (TREE_CODE (type_id
))
2488 type_id
= TYPE_NAME (type_id
);
2493 type_id
= TREE_TYPE (type_id
);
2497 assert ("no IDENTIFIER_NODE for type!" == NULL
);
2498 type_id
= error_mark_node
;
2504 if (ffecom_transform_only_dummies_
2505 || !ffe_is_debug_kludge ())
2506 return; /* Can't do this yet, maybe later. */
2509 + strlen (aggr_type
)
2510 + IDENTIFIER_LENGTH (DECL_NAME (aggr
));
2512 + IDENTIFIER_LENGTH (type_id
);
2515 if (((size_t) len
) >= ARRAY_SIZE (space
))
2516 buff
= malloc_new_ks (malloc_pool_image (), "debug_kludge", len
+ 1);
2520 sprintf (&buff
[0], "At (%s) `%s' plus %ld bytes",
2522 IDENTIFIER_POINTER (DECL_NAME (aggr
)),
2525 value
= build_string (len
, buff
);
2527 = build_type_variant (build_array_type (char_type_node
,
2531 build_int_2 (strlen (buff
), 0))),
2533 decl
= build_decl (VAR_DECL
,
2534 ffecom_get_identifier_ (ffesymbol_text (member
)),
2536 TREE_CONSTANT (decl
) = 1;
2537 TREE_STATIC (decl
) = 1;
2538 DECL_INITIAL (decl
) = error_mark_node
;
2539 DECL_IN_SYSTEM_HEADER (decl
) = 1; /* Don't let -Wunused complain. */
2540 decl
= start_decl (decl
, FALSE
);
2541 finish_decl (decl
, value
, FALSE
);
2543 if (buff
!= &space
[0])
2544 malloc_kill_ks (malloc_pool_image (), buff
, len
+ 1);
2547 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2549 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2550 int i; // entry# for this entrypoint (used by master fn)
2551 ffecom_do_entrypoint_(s,i);
2553 Makes a public entry point that calls our private master fn (already
2557 ffecom_do_entry_ (ffesymbol fn
, int entrynum
)
2560 tree type
; /* Type of function. */
2561 tree multi_retval
; /* Var holding return value (union). */
2562 tree result
; /* Var holding result. */
2563 ffeinfoBasictype bt
;
2567 bool charfunc
; /* All entry points return same type
2569 bool cmplxfunc
; /* Use f2c way of returning COMPLEX. */
2570 bool multi
; /* Master fn has multiple return types. */
2571 bool altreturning
= FALSE
; /* This entry point has alternate returns. */
2572 int old_lineno
= lineno
;
2573 const char *old_input_filename
= input_filename
;
2575 input_filename
= ffesymbol_where_filename (fn
);
2576 lineno
= ffesymbol_where_filelinenum (fn
);
2578 ffecom_doing_entry_
= TRUE
; /* Don't bother with array dimensions. */
2580 switch (ffecom_primary_entry_kind_
)
2582 case FFEINFO_kindFUNCTION
:
2584 /* Determine actual return type for function. */
2586 gt
= FFEGLOBAL_typeFUNC
;
2587 bt
= ffesymbol_basictype (fn
);
2588 kt
= ffesymbol_kindtype (fn
);
2589 if (bt
== FFEINFO_basictypeNONE
)
2591 ffeimplic_establish_symbol (fn
);
2592 if (ffesymbol_funcresult (fn
) != NULL
)
2593 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
2594 bt
= ffesymbol_basictype (fn
);
2595 kt
= ffesymbol_kindtype (fn
);
2598 if (bt
== FFEINFO_basictypeCHARACTER
)
2599 charfunc
= TRUE
, cmplxfunc
= FALSE
;
2600 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
2601 && ffesymbol_is_f2c (fn
))
2602 charfunc
= FALSE
, cmplxfunc
= TRUE
;
2604 charfunc
= cmplxfunc
= FALSE
;
2607 type
= ffecom_tree_fun_type_void
;
2608 else if (ffesymbol_is_f2c (fn
))
2609 type
= ffecom_tree_fun_type
[bt
][kt
];
2611 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
2613 if ((type
== NULL_TREE
)
2614 || (TREE_TYPE (type
) == NULL_TREE
))
2615 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
2617 multi
= (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
2620 case FFEINFO_kindSUBROUTINE
:
2621 gt
= FFEGLOBAL_typeSUBR
;
2622 bt
= FFEINFO_basictypeNONE
;
2623 kt
= FFEINFO_kindtypeNONE
;
2624 if (ffecom_is_altreturning_
)
2625 { /* Am _I_ altreturning? */
2626 for (item
= ffesymbol_dummyargs (fn
);
2628 item
= ffebld_trail (item
))
2630 if (ffebld_op (ffebld_head (item
)) == FFEBLD_opSTAR
)
2632 altreturning
= TRUE
;
2637 type
= ffecom_tree_subr_type
;
2639 type
= ffecom_tree_fun_type_void
;
2642 type
= ffecom_tree_fun_type_void
;
2649 assert ("say what??" == NULL
);
2651 case FFEINFO_kindANY
:
2652 gt
= FFEGLOBAL_typeANY
;
2653 bt
= FFEINFO_basictypeNONE
;
2654 kt
= FFEINFO_kindtypeNONE
;
2655 type
= error_mark_node
;
2662 /* build_decl uses the current lineno and input_filename to set the decl
2663 source info. So, I've putzed with ffestd and ffeste code to update that
2664 source info to point to the appropriate statement just before calling
2665 ffecom_do_entrypoint (which calls this fn). */
2667 start_function (ffecom_get_external_identifier_ (fn
),
2669 0, /* nested/inline */
2670 1); /* TREE_PUBLIC */
2672 if (((g
= ffesymbol_global (fn
)) != NULL
)
2673 && ((ffeglobal_type (g
) == gt
)
2674 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
2676 ffeglobal_set_hook (g
, current_function_decl
);
2679 /* Reset args in master arg list so they get retransitioned. */
2681 for (item
= ffecom_master_arglist_
;
2683 item
= ffebld_trail (item
))
2688 arg
= ffebld_head (item
);
2689 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2690 continue; /* Alternate return or some such thing. */
2691 s
= ffebld_symter (arg
);
2692 ffesymbol_hook (s
).decl_tree
= NULL_TREE
;
2693 ffesymbol_hook (s
).length_tree
= NULL_TREE
;
2696 /* Build dummy arg list for this entry point. */
2698 if (charfunc
|| cmplxfunc
)
2699 { /* Prepend arg for where result goes. */
2704 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
2706 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
2708 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
2710 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2713 length
= ffecom_char_enhance_arg_ (&type
, fn
);
2715 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
2717 type
= build_pointer_type (type
);
2718 result
= build_decl (PARM_DECL
, result
, type
);
2720 push_parm_decl (result
);
2721 ffecom_func_result_
= result
;
2725 push_parm_decl (length
);
2726 ffecom_func_length_
= length
;
2730 result
= DECL_RESULT (current_function_decl
);
2732 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn
), FALSE
);
2734 store_parm_decls (0);
2736 ffecom_start_compstmt ();
2737 /* Disallow temp vars at this level. */
2738 current_binding_level
->prep_state
= 2;
2740 /* Make local var to hold return type for multi-type master fn. */
2744 multi_retval
= ffecom_get_invented_identifier ("__g77_%s",
2746 multi_retval
= build_decl (VAR_DECL
, multi_retval
,
2747 ffecom_multi_type_node_
);
2748 multi_retval
= start_decl (multi_retval
, FALSE
);
2749 finish_decl (multi_retval
, NULL_TREE
, FALSE
);
2752 multi_retval
= NULL_TREE
; /* Not actually ref'd if !multi. */
2754 /* Here we emit the actual code for the entry point. */
2760 tree arglist
= NULL_TREE
;
2761 tree
*plist
= &arglist
;
2767 /* Prepare actual arg list based on master arg list. */
2769 for (list
= ffecom_master_arglist_
;
2771 list
= ffebld_trail (list
))
2773 arg
= ffebld_head (list
);
2774 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2776 s
= ffebld_symter (arg
);
2777 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
2778 || ffesymbol_hook (s
).decl_tree
== error_mark_node
)
2779 actarg
= null_pointer_node
; /* We don't have this arg. */
2781 actarg
= ffesymbol_hook (s
).decl_tree
;
2782 *plist
= build_tree_list (NULL_TREE
, actarg
);
2783 plist
= &TREE_CHAIN (*plist
);
2786 /* This code appends the length arguments for character
2787 variables/arrays. */
2789 for (list
= ffecom_master_arglist_
;
2791 list
= ffebld_trail (list
))
2793 arg
= ffebld_head (list
);
2794 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2796 s
= ffebld_symter (arg
);
2797 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
2798 continue; /* Only looking for CHARACTER arguments. */
2799 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
2800 continue; /* Only looking for variables and arrays. */
2801 if (ffesymbol_hook (s
).length_tree
== NULL_TREE
2802 || ffesymbol_hook (s
).length_tree
== error_mark_node
)
2803 actarg
= ffecom_f2c_ftnlen_zero_node
; /* We don't have this arg. */
2805 actarg
= ffesymbol_hook (s
).length_tree
;
2806 *plist
= build_tree_list (NULL_TREE
, actarg
);
2807 plist
= &TREE_CHAIN (*plist
);
2810 /* Prepend character-value return info to actual arg list. */
2814 prepend
= build_tree_list (NULL_TREE
, ffecom_func_result_
);
2815 TREE_CHAIN (prepend
)
2816 = build_tree_list (NULL_TREE
, ffecom_func_length_
);
2817 TREE_CHAIN (TREE_CHAIN (prepend
)) = arglist
;
2821 /* Prepend multi-type return value to actual arg list. */
2826 = build_tree_list (NULL_TREE
,
2827 ffecom_1 (ADDR_EXPR
,
2828 build_pointer_type (TREE_TYPE (multi_retval
)),
2830 TREE_CHAIN (prepend
) = arglist
;
2834 /* Prepend my entry-point number to the actual arg list. */
2836 prepend
= build_tree_list (NULL_TREE
, build_int_2 (entrynum
, 0));
2837 TREE_CHAIN (prepend
) = arglist
;
2840 /* Build the call to the master function. */
2842 master_fn
= ffecom_1_fn (ffecom_previous_function_decl_
);
2843 call
= ffecom_3s (CALL_EXPR
,
2844 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn
))),
2845 master_fn
, arglist
, NULL_TREE
);
2847 /* Decide whether the master function is a function or subroutine, and
2848 handle the return value for my entry point. */
2850 if (charfunc
|| ((ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
2853 expand_expr_stmt (call
);
2854 expand_null_return ();
2856 else if (multi
&& cmplxfunc
)
2858 expand_expr_stmt (call
);
2860 = ffecom_1 (INDIRECT_REF
,
2861 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2863 result
= ffecom_modify (NULL_TREE
, result
,
2864 ffecom_2 (COMPONENT_REF
, TREE_TYPE (result
),
2866 ffecom_multi_fields_
[bt
][kt
]));
2867 expand_expr_stmt (result
);
2868 expand_null_return ();
2872 expand_expr_stmt (call
);
2874 = ffecom_modify (NULL_TREE
, result
,
2875 convert (TREE_TYPE (result
),
2876 ffecom_2 (COMPONENT_REF
,
2877 ffecom_tree_type
[bt
][kt
],
2879 ffecom_multi_fields_
[bt
][kt
])));
2880 expand_return (result
);
2885 = ffecom_1 (INDIRECT_REF
,
2886 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2888 result
= ffecom_modify (NULL_TREE
, result
, call
);
2889 expand_expr_stmt (result
);
2890 expand_null_return ();
2894 result
= ffecom_modify (NULL_TREE
,
2896 convert (TREE_TYPE (result
),
2898 expand_return (result
);
2902 ffecom_end_compstmt ();
2904 finish_function (0);
2906 lineno
= old_lineno
;
2907 input_filename
= old_input_filename
;
2909 ffecom_doing_entry_
= FALSE
;
2912 /* Transform expr into gcc tree with possible destination
2914 Recursive descent on expr while making corresponding tree nodes and
2915 attaching type info and such. If destination supplied and compatible
2916 with temporary that would be made in certain cases, temporary isn't
2917 made, destination used instead, and dest_used flag set TRUE. */
2920 ffecom_expr_ (ffebld expr
, tree dest_tree
, ffebld dest
,
2921 bool *dest_used
, bool assignp
, bool widenp
)
2926 ffeinfoBasictype bt
;
2929 tree dt
; /* decl_tree for an ffesymbol. */
2930 tree tree_type
, tree_type_x
;
2933 enum tree_code code
;
2935 assert (expr
!= NULL
);
2937 if (dest_used
!= NULL
)
2940 bt
= ffeinfo_basictype (ffebld_info (expr
));
2941 kt
= ffeinfo_kindtype (ffebld_info (expr
));
2942 tree_type
= ffecom_tree_type
[bt
][kt
];
2944 /* Widen integral arithmetic as desired while preserving signedness. */
2945 tree_type_x
= NULL_TREE
;
2946 if (widenp
&& tree_type
2947 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
2948 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
2949 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
2951 switch (ffebld_op (expr
))
2953 case FFEBLD_opACCTER
:
2956 ffebit bits
= ffebld_accter_bits (expr
);
2957 ffetargetOffset source_offset
= 0;
2958 ffetargetOffset dest_offset
= ffebld_accter_pad (expr
);
2961 assert (dest_offset
== 0
2962 || (bt
== FFEINFO_basictypeCHARACTER
2963 && kt
== FFEINFO_kindtypeCHARACTER1
));
2968 ffebldConstantUnion cu
;
2971 ffebldConstantArray ca
= ffebld_accter (expr
);
2973 ffebit_test (bits
, source_offset
, &value
, &length
);
2979 for (i
= 0; i
< length
; ++i
)
2981 cu
= ffebld_constantarray_get (ca
, bt
, kt
,
2984 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
2987 && dest_offset
!= 0)
2988 purpose
= build_int_2 (dest_offset
, 0);
2990 purpose
= NULL_TREE
;
2992 if (list
== NULL_TREE
)
2993 list
= item
= build_tree_list (purpose
, t
);
2996 TREE_CHAIN (item
) = build_tree_list (purpose
, t
);
2997 item
= TREE_CHAIN (item
);
3001 source_offset
+= length
;
3002 dest_offset
+= length
;
3006 item
= build_int_2 ((ffebld_accter_size (expr
)
3007 + ffebld_accter_pad (expr
)) - 1, 0);
3008 ffebit_kill (ffebld_accter_bits (expr
));
3009 TREE_TYPE (item
) = ffecom_integer_type_node
;
3013 build_range_type (ffecom_integer_type_node
,
3014 ffecom_integer_zero_node
,
3016 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
3017 TREE_CONSTANT (list
) = 1;
3018 TREE_STATIC (list
) = 1;
3021 case FFEBLD_opARRTER
:
3026 if (ffebld_arrter_pad (expr
) == 0)
3030 assert (bt
== FFEINFO_basictypeCHARACTER
3031 && kt
== FFEINFO_kindtypeCHARACTER1
);
3033 /* Becomes PURPOSE first time through loop. */
3034 item
= build_int_2 (ffebld_arrter_pad (expr
), 0);
3037 for (i
= 0; i
< ffebld_arrter_size (expr
); ++i
)
3039 ffebldConstantUnion cu
3040 = ffebld_constantarray_get (ffebld_arrter (expr
), bt
, kt
, i
);
3042 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
3044 if (list
== NULL_TREE
)
3045 /* Assume item is PURPOSE first time through loop. */
3046 list
= item
= build_tree_list (item
, t
);
3049 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
3050 item
= TREE_CHAIN (item
);
3055 item
= build_int_2 ((ffebld_arrter_size (expr
)
3056 + ffebld_arrter_pad (expr
)) - 1, 0);
3057 TREE_TYPE (item
) = ffecom_integer_type_node
;
3061 build_range_type (ffecom_integer_type_node
,
3062 ffecom_integer_zero_node
,
3064 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
3065 TREE_CONSTANT (list
) = 1;
3066 TREE_STATIC (list
) = 1;
3069 case FFEBLD_opCONTER
:
3070 assert (ffebld_conter_pad (expr
) == 0);
3072 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr
)),
3076 case FFEBLD_opSYMTER
:
3077 if ((ffebld_symter_generic (expr
) != FFEINTRIN_genNONE
)
3078 || (ffebld_symter_specific (expr
) != FFEINTRIN_specNONE
))
3079 return ffecom_ptr_to_expr (expr
); /* Same as %REF(intrinsic). */
3080 s
= ffebld_symter (expr
);
3081 t
= ffesymbol_hook (s
).decl_tree
;
3084 { /* ASSIGN'ed-label expr. */
3085 if (ffe_is_ugly_assign ())
3087 /* User explicitly wants ASSIGN'ed variables to be at the same
3088 memory address as the variables when used in non-ASSIGN
3089 contexts. That can make old, arcane, non-standard code
3090 work, but don't try to do it when a pointer wouldn't fit
3091 in the normal variable (take other approach, and warn,
3096 s
= ffecom_sym_transform_ (s
);
3097 t
= ffesymbol_hook (s
).decl_tree
;
3098 assert (t
!= NULL_TREE
);
3101 if (t
== error_mark_node
)
3104 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t
)))
3105 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
3107 if (ffesymbol_hook (s
).addr
)
3108 t
= ffecom_1 (INDIRECT_REF
,
3109 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
3113 if (ffesymbol_hook (s
).assign_tree
== NULL_TREE
)
3115 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3116 FFEBAD_severityWARNING
);
3117 ffebad_string (ffesymbol_text (s
));
3118 ffebad_here (0, ffesymbol_where_line (s
),
3119 ffesymbol_where_column (s
));
3124 /* Don't use the normal variable's tree for ASSIGN, though mark
3125 it as in the system header (housekeeping). Use an explicit,
3126 specially created sibling that is known to be wide enough
3127 to hold pointers to labels. */
3130 && TREE_CODE (t
) == VAR_DECL
)
3131 DECL_IN_SYSTEM_HEADER (t
) = 1; /* Don't let -Wunused complain. */
3133 t
= ffesymbol_hook (s
).assign_tree
;
3136 s
= ffecom_sym_transform_assign_ (s
);
3137 t
= ffesymbol_hook (s
).assign_tree
;
3138 assert (t
!= NULL_TREE
);
3145 s
= ffecom_sym_transform_ (s
);
3146 t
= ffesymbol_hook (s
).decl_tree
;
3147 assert (t
!= NULL_TREE
);
3149 if (ffesymbol_hook (s
).addr
)
3150 t
= ffecom_1 (INDIRECT_REF
,
3151 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
3155 case FFEBLD_opARRAYREF
:
3156 return ffecom_arrayref_ (NULL_TREE
, expr
, 0);
3158 case FFEBLD_opUPLUS
:
3159 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3160 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3162 case FFEBLD_opPAREN
:
3163 /* ~~~Make sure Fortran rules respected here */
3164 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3165 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3167 case FFEBLD_opUMINUS
:
3168 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3171 tree_type
= tree_type_x
;
3172 left
= convert (tree_type
, left
);
3174 return ffecom_1 (NEGATE_EXPR
, tree_type
, left
);
3177 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3178 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3181 tree_type
= tree_type_x
;
3182 left
= convert (tree_type
, left
);
3183 right
= convert (tree_type
, right
);
3185 return ffecom_2 (PLUS_EXPR
, tree_type
, left
, right
);
3187 case FFEBLD_opSUBTRACT
:
3188 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3189 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3192 tree_type
= tree_type_x
;
3193 left
= convert (tree_type
, left
);
3194 right
= convert (tree_type
, right
);
3196 return ffecom_2 (MINUS_EXPR
, tree_type
, left
, right
);
3198 case FFEBLD_opMULTIPLY
:
3199 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3200 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3203 tree_type
= tree_type_x
;
3204 left
= convert (tree_type
, left
);
3205 right
= convert (tree_type
, right
);
3207 return ffecom_2 (MULT_EXPR
, tree_type
, left
, right
);
3209 case FFEBLD_opDIVIDE
:
3210 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3211 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3214 tree_type
= tree_type_x
;
3215 left
= convert (tree_type
, left
);
3216 right
= convert (tree_type
, right
);
3218 return ffecom_tree_divide_ (tree_type
, left
, right
,
3219 dest_tree
, dest
, dest_used
,
3220 ffebld_nonter_hook (expr
));
3222 case FFEBLD_opPOWER
:
3224 ffebld left
= ffebld_left (expr
);
3225 ffebld right
= ffebld_right (expr
);
3227 ffeinfoKindtype rtkt
;
3228 ffeinfoKindtype ltkt
;
3231 switch (ffeinfo_basictype (ffebld_info (right
)))
3234 case FFEINFO_basictypeINTEGER
:
3237 item
= ffecom_expr_power_integer_ (expr
);
3238 if (item
!= NULL_TREE
)
3242 rtkt
= FFEINFO_kindtypeINTEGER1
;
3243 switch (ffeinfo_basictype (ffebld_info (left
)))
3245 case FFEINFO_basictypeINTEGER
:
3246 if ((ffeinfo_kindtype (ffebld_info (left
))
3247 == FFEINFO_kindtypeINTEGER4
)
3248 || (ffeinfo_kindtype (ffebld_info (right
))
3249 == FFEINFO_kindtypeINTEGER4
))
3251 code
= FFECOM_gfrtPOW_QQ
;
3252 ltkt
= FFEINFO_kindtypeINTEGER4
;
3253 rtkt
= FFEINFO_kindtypeINTEGER4
;
3257 code
= FFECOM_gfrtPOW_II
;
3258 ltkt
= FFEINFO_kindtypeINTEGER1
;
3262 case FFEINFO_basictypeREAL
:
3263 if (ffeinfo_kindtype (ffebld_info (left
))
3264 == FFEINFO_kindtypeREAL1
)
3266 code
= FFECOM_gfrtPOW_RI
;
3267 ltkt
= FFEINFO_kindtypeREAL1
;
3271 code
= FFECOM_gfrtPOW_DI
;
3272 ltkt
= FFEINFO_kindtypeREAL2
;
3276 case FFEINFO_basictypeCOMPLEX
:
3277 if (ffeinfo_kindtype (ffebld_info (left
))
3278 == FFEINFO_kindtypeREAL1
)
3280 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3281 ltkt
= FFEINFO_kindtypeREAL1
;
3285 code
= FFECOM_gfrtPOW_ZI
; /* Overlapping result okay. */
3286 ltkt
= FFEINFO_kindtypeREAL2
;
3291 assert ("bad pow_*i" == NULL
);
3292 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3293 ltkt
= FFEINFO_kindtypeREAL1
;
3296 if (ffeinfo_kindtype (ffebld_info (left
)) != ltkt
)
3297 left
= ffeexpr_convert (left
, NULL
, NULL
,
3298 ffeinfo_basictype (ffebld_info (left
)),
3300 FFETARGET_charactersizeNONE
,
3301 FFEEXPR_contextLET
);
3302 if (ffeinfo_kindtype (ffebld_info (right
)) != rtkt
)
3303 right
= ffeexpr_convert (right
, NULL
, NULL
,
3304 FFEINFO_basictypeINTEGER
,
3306 FFETARGET_charactersizeNONE
,
3307 FFEEXPR_contextLET
);
3310 case FFEINFO_basictypeREAL
:
3311 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3312 left
= ffeexpr_convert (left
, NULL
, NULL
, FFEINFO_basictypeREAL
,
3313 FFEINFO_kindtypeREALDOUBLE
, 0,
3314 FFETARGET_charactersizeNONE
,
3315 FFEEXPR_contextLET
);
3316 if (ffeinfo_kindtype (ffebld_info (right
))
3317 == FFEINFO_kindtypeREAL1
)
3318 right
= ffeexpr_convert (right
, NULL
, NULL
,
3319 FFEINFO_basictypeREAL
,
3320 FFEINFO_kindtypeREALDOUBLE
, 0,
3321 FFETARGET_charactersizeNONE
,
3322 FFEEXPR_contextLET
);
3323 /* We used to call FFECOM_gfrtPOW_DD here,
3324 which passes arguments by reference. */
3325 code
= FFECOM_gfrtL_POW
;
3326 /* Pass arguments by value. */
3330 case FFEINFO_basictypeCOMPLEX
:
3331 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3332 left
= ffeexpr_convert (left
, NULL
, NULL
,
3333 FFEINFO_basictypeCOMPLEX
,
3334 FFEINFO_kindtypeREALDOUBLE
, 0,
3335 FFETARGET_charactersizeNONE
,
3336 FFEEXPR_contextLET
);
3337 if (ffeinfo_kindtype (ffebld_info (right
))
3338 == FFEINFO_kindtypeREAL1
)
3339 right
= ffeexpr_convert (right
, NULL
, NULL
,
3340 FFEINFO_basictypeCOMPLEX
,
3341 FFEINFO_kindtypeREALDOUBLE
, 0,
3342 FFETARGET_charactersizeNONE
,
3343 FFEEXPR_contextLET
);
3344 code
= FFECOM_gfrtPOW_ZZ
; /* Overlapping result okay. */
3345 ref
= TRUE
; /* Pass arguments by reference. */
3349 assert ("bad pow_x*" == NULL
);
3350 code
= FFECOM_gfrtPOW_II
;
3353 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code
),
3354 ffecom_gfrt_kindtype (code
),
3355 (ffe_is_f2c_library ()
3356 && ffecom_gfrt_complex_
[code
]),
3357 tree_type
, left
, right
,
3358 dest_tree
, dest
, dest_used
,
3359 NULL_TREE
, FALSE
, ref
,
3360 ffebld_nonter_hook (expr
));
3366 case FFEINFO_basictypeLOGICAL
:
3367 item
= ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr
)));
3368 return convert (tree_type
, item
);
3370 case FFEINFO_basictypeINTEGER
:
3371 return ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3372 ffecom_expr (ffebld_left (expr
)));
3375 assert ("NOT bad basictype" == NULL
);
3377 case FFEINFO_basictypeANY
:
3378 return error_mark_node
;
3382 case FFEBLD_opFUNCREF
:
3383 assert (ffeinfo_basictype (ffebld_info (expr
))
3384 != FFEINFO_basictypeCHARACTER
);
3386 case FFEBLD_opSUBRREF
:
3387 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
3388 == FFEINFO_whereINTRINSIC
)
3389 { /* Invocation of an intrinsic. */
3390 item
= ffecom_expr_intrinsic_ (expr
, dest_tree
, dest
,
3394 s
= ffebld_symter (ffebld_left (expr
));
3395 dt
= ffesymbol_hook (s
).decl_tree
;
3396 if (dt
== NULL_TREE
)
3398 s
= ffecom_sym_transform_ (s
);
3399 dt
= ffesymbol_hook (s
).decl_tree
;
3401 if (dt
== error_mark_node
)
3404 if (ffesymbol_hook (s
).addr
)
3407 item
= ffecom_1_fn (dt
);
3409 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
3410 args
= ffecom_list_expr (ffebld_right (expr
));
3412 args
= ffecom_list_ptr_to_expr (ffebld_right (expr
));
3414 if (args
== error_mark_node
)
3415 return error_mark_node
;
3417 item
= ffecom_call_ (item
, kt
,
3418 ffesymbol_is_f2c (s
)
3419 && (bt
== FFEINFO_basictypeCOMPLEX
)
3420 && (ffesymbol_where (s
)
3421 != FFEINFO_whereCONSTANT
),
3424 dest_tree
, dest
, dest_used
,
3425 error_mark_node
, FALSE
,
3426 ffebld_nonter_hook (expr
));
3427 TREE_SIDE_EFFECTS (item
) = 1;
3433 case FFEINFO_basictypeLOGICAL
:
3435 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3436 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3437 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3438 return convert (tree_type
, item
);
3440 case FFEINFO_basictypeINTEGER
:
3441 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
3442 ffecom_expr (ffebld_left (expr
)),
3443 ffecom_expr (ffebld_right (expr
)));
3446 assert ("AND bad basictype" == NULL
);
3448 case FFEINFO_basictypeANY
:
3449 return error_mark_node
;
3456 case FFEINFO_basictypeLOGICAL
:
3458 = ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
3459 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3460 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3461 return convert (tree_type
, item
);
3463 case FFEINFO_basictypeINTEGER
:
3464 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
3465 ffecom_expr (ffebld_left (expr
)),
3466 ffecom_expr (ffebld_right (expr
)));
3469 assert ("OR bad basictype" == NULL
);
3471 case FFEINFO_basictypeANY
:
3472 return error_mark_node
;
3480 case FFEINFO_basictypeLOGICAL
:
3482 = ffecom_2 (NE_EXPR
, integer_type_node
,
3483 ffecom_expr (ffebld_left (expr
)),
3484 ffecom_expr (ffebld_right (expr
)));
3485 return convert (tree_type
, ffecom_truth_value (item
));
3487 case FFEINFO_basictypeINTEGER
:
3488 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3489 ffecom_expr (ffebld_left (expr
)),
3490 ffecom_expr (ffebld_right (expr
)));
3493 assert ("XOR/NEQV bad basictype" == NULL
);
3495 case FFEINFO_basictypeANY
:
3496 return error_mark_node
;
3503 case FFEINFO_basictypeLOGICAL
:
3505 = ffecom_2 (EQ_EXPR
, integer_type_node
,
3506 ffecom_expr (ffebld_left (expr
)),
3507 ffecom_expr (ffebld_right (expr
)));
3508 return convert (tree_type
, ffecom_truth_value (item
));
3510 case FFEINFO_basictypeINTEGER
:
3512 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3513 ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3514 ffecom_expr (ffebld_left (expr
)),
3515 ffecom_expr (ffebld_right (expr
))));
3518 assert ("EQV bad basictype" == NULL
);
3520 case FFEINFO_basictypeANY
:
3521 return error_mark_node
;
3525 case FFEBLD_opCONVERT
:
3526 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opANY
)
3527 return error_mark_node
;
3531 case FFEINFO_basictypeLOGICAL
:
3532 case FFEINFO_basictypeINTEGER
:
3533 case FFEINFO_basictypeREAL
:
3534 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3536 case FFEINFO_basictypeCOMPLEX
:
3537 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3539 case FFEINFO_basictypeINTEGER
:
3540 case FFEINFO_basictypeLOGICAL
:
3541 case FFEINFO_basictypeREAL
:
3542 item
= ffecom_expr (ffebld_left (expr
));
3543 if (item
== error_mark_node
)
3544 return error_mark_node
;
3545 /* convert() takes care of converting to the subtype first,
3546 at least in gcc-2.7.2. */
3547 item
= convert (tree_type
, item
);
3550 case FFEINFO_basictypeCOMPLEX
:
3551 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3554 assert ("CONVERT COMPLEX bad basictype" == NULL
);
3556 case FFEINFO_basictypeANY
:
3557 return error_mark_node
;
3562 assert ("CONVERT bad basictype" == NULL
);
3564 case FFEINFO_basictypeANY
:
3565 return error_mark_node
;
3571 goto relational
; /* :::::::::::::::::::: */
3575 goto relational
; /* :::::::::::::::::::: */
3579 goto relational
; /* :::::::::::::::::::: */
3583 goto relational
; /* :::::::::::::::::::: */
3587 goto relational
; /* :::::::::::::::::::: */
3592 relational
: /* :::::::::::::::::::: */
3593 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3595 case FFEINFO_basictypeLOGICAL
:
3596 case FFEINFO_basictypeINTEGER
:
3597 case FFEINFO_basictypeREAL
:
3598 item
= ffecom_2 (code
, integer_type_node
,
3599 ffecom_expr (ffebld_left (expr
)),
3600 ffecom_expr (ffebld_right (expr
)));
3601 return convert (tree_type
, item
);
3603 case FFEINFO_basictypeCOMPLEX
:
3604 assert (code
== EQ_EXPR
|| code
== NE_EXPR
);
3607 tree arg1
= ffecom_expr (ffebld_left (expr
));
3608 tree arg2
= ffecom_expr (ffebld_right (expr
));
3610 if (arg1
== error_mark_node
|| arg2
== error_mark_node
)
3611 return error_mark_node
;
3613 arg1
= ffecom_save_tree (arg1
);
3614 arg2
= ffecom_save_tree (arg2
);
3616 if (TREE_CODE (TREE_TYPE (arg1
)) == COMPLEX_TYPE
)
3618 real_type
= TREE_TYPE (TREE_TYPE (arg1
));
3619 assert (real_type
== TREE_TYPE (TREE_TYPE (arg2
)));
3623 real_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1
)));
3624 assert (real_type
== TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2
))));
3628 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3629 ffecom_2 (EQ_EXPR
, integer_type_node
,
3630 ffecom_1 (REALPART_EXPR
, real_type
, arg1
),
3631 ffecom_1 (REALPART_EXPR
, real_type
, arg2
)),
3632 ffecom_2 (EQ_EXPR
, integer_type_node
,
3633 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1
),
3634 ffecom_1 (IMAGPART_EXPR
, real_type
,
3636 if (code
== EQ_EXPR
)
3637 item
= ffecom_truth_value (item
);
3639 item
= ffecom_truth_value_invert (item
);
3640 return convert (tree_type
, item
);
3643 case FFEINFO_basictypeCHARACTER
:
3645 ffebld left
= ffebld_left (expr
);
3646 ffebld right
= ffebld_right (expr
);
3652 /* f2c run-time functions do the implicit blank-padding for us,
3653 so we don't usually have to implement blank-padding ourselves.
3654 (The exception is when we pass an argument to a separately
3655 compiled statement function -- if we know the arg is not the
3656 same length as the dummy, we must truncate or extend it. If
3657 we "inline" statement functions, that necessity goes away as
3660 Strip off the CONVERT operators that blank-pad. (Truncation by
3661 CONVERT shouldn't happen here, but it can happen in
3664 while (ffebld_op (left
) == FFEBLD_opCONVERT
)
3665 left
= ffebld_left (left
);
3666 while (ffebld_op (right
) == FFEBLD_opCONVERT
)
3667 right
= ffebld_left (right
);
3669 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
3670 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
3672 if (left_tree
== error_mark_node
|| left_length
== error_mark_node
3673 || right_tree
== error_mark_node
3674 || right_length
== error_mark_node
)
3675 return error_mark_node
;
3677 if ((ffebld_size_known (left
) == 1)
3678 && (ffebld_size_known (right
) == 1))
3681 = ffecom_1 (INDIRECT_REF
,
3682 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3685 = ffecom_1 (INDIRECT_REF
,
3686 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3690 = ffecom_2 (code
, integer_type_node
,
3691 ffecom_2 (ARRAY_REF
,
3692 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3695 ffecom_2 (ARRAY_REF
,
3696 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3702 item
= build_tree_list (NULL_TREE
, left_tree
);
3703 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, right_tree
);
3704 TREE_CHAIN (TREE_CHAIN (item
)) = build_tree_list (NULL_TREE
,
3706 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
3707 = build_tree_list (NULL_TREE
, right_length
);
3708 item
= ffecom_call_gfrt (FFECOM_gfrtCMP
, item
, NULL_TREE
);
3709 item
= ffecom_2 (code
, integer_type_node
,
3711 convert (TREE_TYPE (item
),
3712 integer_zero_node
));
3714 item
= convert (tree_type
, item
);
3720 assert ("relational bad basictype" == NULL
);
3722 case FFEINFO_basictypeANY
:
3723 return error_mark_node
;
3727 case FFEBLD_opPERCENT_LOC
:
3728 item
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &list
);
3729 return convert (tree_type
, item
);
3733 case FFEBLD_opBOUNDS
:
3734 case FFEBLD_opREPEAT
:
3735 case FFEBLD_opLABTER
:
3736 case FFEBLD_opLABTOK
:
3737 case FFEBLD_opIMPDO
:
3738 case FFEBLD_opCONCATENATE
:
3739 case FFEBLD_opSUBSTR
:
3741 assert ("bad op" == NULL
);
3744 return error_mark_node
;
3748 assert ("didn't think anything got here anymore!!" == NULL
);
3750 switch (ffebld_arity (expr
))
3753 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3754 TREE_OPERAND (item
, 1) = ffecom_expr (ffebld_right (expr
));
3755 if (TREE_OPERAND (item
, 0) == error_mark_node
3756 || TREE_OPERAND (item
, 1) == error_mark_node
)
3757 return error_mark_node
;
3761 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3762 if (TREE_OPERAND (item
, 0) == error_mark_node
)
3763 return error_mark_node
;
3774 /* Returns the tree that does the intrinsic invocation.
3776 Note: this function applies only to intrinsics returning
3777 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3781 ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
3782 ffebld dest
, bool *dest_used
)
3785 tree saved_expr1
; /* For those who need it. */
3786 tree saved_expr2
; /* For those who need it. */
3787 ffeinfoBasictype bt
;
3791 tree real_type
; /* REAL type corresponding to COMPLEX. */
3793 ffebld list
= ffebld_right (expr
); /* List of (some) args. */
3794 ffebld arg1
; /* For handy reference. */
3797 ffeintrinImp codegen_imp
;
3800 assert (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
);
3802 if (dest_used
!= NULL
)
3805 bt
= ffeinfo_basictype (ffebld_info (expr
));
3806 kt
= ffeinfo_kindtype (ffebld_info (expr
));
3807 tree_type
= ffecom_tree_type
[bt
][kt
];
3811 arg1
= ffebld_head (list
);
3812 if (arg1
!= NULL
&& ffebld_op (arg1
) == FFEBLD_opANY
)
3813 return error_mark_node
;
3814 if ((list
= ffebld_trail (list
)) != NULL
)
3816 arg2
= ffebld_head (list
);
3817 if (arg2
!= NULL
&& ffebld_op (arg2
) == FFEBLD_opANY
)
3818 return error_mark_node
;
3819 if ((list
= ffebld_trail (list
)) != NULL
)
3821 arg3
= ffebld_head (list
);
3822 if (arg3
!= NULL
&& ffebld_op (arg3
) == FFEBLD_opANY
)
3823 return error_mark_node
;
3832 arg1
= arg2
= arg3
= NULL
;
3834 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3835 args. This is used by the MAX/MIN expansions. */
3838 arg1_type
= ffecom_tree_type
3839 [ffeinfo_basictype (ffebld_info (arg1
))]
3840 [ffeinfo_kindtype (ffebld_info (arg1
))];
3842 arg1_type
= NULL_TREE
; /* Really not needed, but might catch bugs
3845 /* There are several ways for each of the cases in the following switch
3846 statements to exit (from simplest to use to most complicated):
3848 break; (when expr_tree == NULL)
3850 A standard call is made to the specific intrinsic just as if it had been
3851 passed in as a dummy procedure and called as any old procedure. This
3852 method can produce slower code but in some cases it's the easiest way for
3853 now. However, if a (presumably faster) direct call is available,
3854 that is used, so this is the easiest way in many more cases now.
3856 gfrt = FFECOM_gfrtWHATEVER;
3859 gfrt contains the gfrt index of a library function to call, passing the
3860 argument(s) by value rather than by reference. Used when a more
3861 careful choice of library function is needed than that provided
3862 by the vanilla `break;'.
3866 The expr_tree has been completely set up and is ready to be returned
3867 as is. No further actions are taken. Use this when the tree is not
3868 in the simple form for one of the arity_n labels. */
3870 /* For info on how the switch statement cases were written, see the files
3871 enclosed in comments below the switch statement. */
3873 codegen_imp
= ffebld_symter_implementation (ffebld_left (expr
));
3874 gfrt
= ffeintrin_gfrt_direct (codegen_imp
);
3875 if (gfrt
== FFECOM_gfrt
)
3876 gfrt
= ffeintrin_gfrt_indirect (codegen_imp
);
3878 switch (codegen_imp
)
3880 case FFEINTRIN_impABS
:
3881 case FFEINTRIN_impCABS
:
3882 case FFEINTRIN_impCDABS
:
3883 case FFEINTRIN_impDABS
:
3884 case FFEINTRIN_impIABS
:
3885 if (ffeinfo_basictype (ffebld_info (arg1
))
3886 == FFEINFO_basictypeCOMPLEX
)
3888 if (kt
== FFEINFO_kindtypeREAL1
)
3889 gfrt
= FFECOM_gfrtCABS
;
3890 else if (kt
== FFEINFO_kindtypeREAL2
)
3891 gfrt
= FFECOM_gfrtCDABS
;
3894 return ffecom_1 (ABS_EXPR
, tree_type
,
3895 convert (tree_type
, ffecom_expr (arg1
)));
3897 case FFEINTRIN_impACOS
:
3898 case FFEINTRIN_impDACOS
:
3901 case FFEINTRIN_impAIMAG
:
3902 case FFEINTRIN_impDIMAG
:
3903 case FFEINTRIN_impIMAGPART
:
3904 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
3905 arg1_type
= TREE_TYPE (arg1_type
);
3907 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
3911 ffecom_1 (IMAGPART_EXPR
, arg1_type
,
3912 ffecom_expr (arg1
)));
3914 case FFEINTRIN_impAINT
:
3915 case FFEINTRIN_impDINT
:
3917 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
3918 return ffecom_1 (FIX_TRUNC_EXPR
, tree_type
, ffecom_expr (arg1
));
3919 #else /* in the meantime, must use floor to avoid range problems with ints */
3920 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3921 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3924 ffecom_3 (COND_EXPR
, double_type_node
,
3926 (ffecom_2 (GE_EXPR
, integer_type_node
,
3929 ffecom_float_zero_
))),
3930 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3931 build_tree_list (NULL_TREE
,
3932 convert (double_type_node
,
3935 ffecom_1 (NEGATE_EXPR
, double_type_node
,
3936 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3937 build_tree_list (NULL_TREE
,
3938 convert (double_type_node
,
3939 ffecom_1 (NEGATE_EXPR
,
3947 case FFEINTRIN_impANINT
:
3948 case FFEINTRIN_impDNINT
:
3949 #if 0 /* This way of doing it won't handle real
3950 numbers of large magnitudes. */
3951 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3952 expr_tree
= convert (tree_type
,
3953 convert (integer_type_node
,
3954 ffecom_3 (COND_EXPR
, tree_type
,
3959 ffecom_float_zero_
)),
3960 ffecom_2 (PLUS_EXPR
,
3963 ffecom_float_half_
),
3964 ffecom_2 (MINUS_EXPR
,
3967 ffecom_float_half_
))));
3969 #else /* So we instead call floor. */
3970 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3971 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3974 ffecom_3 (COND_EXPR
, double_type_node
,
3976 (ffecom_2 (GE_EXPR
, integer_type_node
,
3979 ffecom_float_zero_
))),
3980 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3981 build_tree_list (NULL_TREE
,
3982 convert (double_type_node
,
3983 ffecom_2 (PLUS_EXPR
,
3987 ffecom_float_half_
)))),
3989 ffecom_1 (NEGATE_EXPR
, double_type_node
,
3990 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3991 build_tree_list (NULL_TREE
,
3992 convert (double_type_node
,
3993 ffecom_2 (MINUS_EXPR
,
3996 ffecom_float_half_
),
4003 case FFEINTRIN_impASIN
:
4004 case FFEINTRIN_impDASIN
:
4005 case FFEINTRIN_impATAN
:
4006 case FFEINTRIN_impDATAN
:
4007 case FFEINTRIN_impATAN2
:
4008 case FFEINTRIN_impDATAN2
:
4011 case FFEINTRIN_impCHAR
:
4012 case FFEINTRIN_impACHAR
:
4014 tempvar
= ffecom_make_tempvar (char_type_node
, 1, -1);
4016 tempvar
= ffebld_nonter_hook (expr
);
4020 tree tmv
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar
)));
4022 expr_tree
= ffecom_modify (tmv
,
4023 ffecom_2 (ARRAY_REF
, tmv
, tempvar
,
4025 convert (tmv
, ffecom_expr (arg1
)));
4027 expr_tree
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
),
4030 expr_tree
= ffecom_1 (ADDR_EXPR
,
4031 build_pointer_type (TREE_TYPE (expr_tree
)),
4035 case FFEINTRIN_impCMPLX
:
4036 case FFEINTRIN_impDCMPLX
:
4039 convert (tree_type
, ffecom_expr (arg1
));
4041 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
4043 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4044 convert (real_type
, ffecom_expr (arg1
)),
4046 ffecom_expr (arg2
)));
4048 case FFEINTRIN_impCOMPLEX
:
4050 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4052 ffecom_expr (arg2
));
4054 case FFEINTRIN_impCONJG
:
4055 case FFEINTRIN_impDCONJG
:
4059 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
4060 arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4062 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4063 ffecom_1 (REALPART_EXPR
, real_type
, arg1_tree
),
4064 ffecom_1 (NEGATE_EXPR
, real_type
,
4065 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1_tree
)));
4068 case FFEINTRIN_impCOS
:
4069 case FFEINTRIN_impCCOS
:
4070 case FFEINTRIN_impCDCOS
:
4071 case FFEINTRIN_impDCOS
:
4072 if (bt
== FFEINFO_basictypeCOMPLEX
)
4074 if (kt
== FFEINFO_kindtypeREAL1
)
4075 gfrt
= FFECOM_gfrtCCOS
; /* Overlapping result okay. */
4076 else if (kt
== FFEINFO_kindtypeREAL2
)
4077 gfrt
= FFECOM_gfrtCDCOS
; /* Overlapping result okay. */
4081 case FFEINTRIN_impCOSH
:
4082 case FFEINTRIN_impDCOSH
:
4085 case FFEINTRIN_impDBLE
:
4086 case FFEINTRIN_impDFLOAT
:
4087 case FFEINTRIN_impDREAL
:
4088 case FFEINTRIN_impFLOAT
:
4089 case FFEINTRIN_impIDINT
:
4090 case FFEINTRIN_impIFIX
:
4091 case FFEINTRIN_impINT2
:
4092 case FFEINTRIN_impINT8
:
4093 case FFEINTRIN_impINT
:
4094 case FFEINTRIN_impLONG
:
4095 case FFEINTRIN_impREAL
:
4096 case FFEINTRIN_impSHORT
:
4097 case FFEINTRIN_impSNGL
:
4098 return convert (tree_type
, ffecom_expr (arg1
));
4100 case FFEINTRIN_impDIM
:
4101 case FFEINTRIN_impDDIM
:
4102 case FFEINTRIN_impIDIM
:
4103 saved_expr1
= ffecom_save_tree (convert (tree_type
,
4104 ffecom_expr (arg1
)));
4105 saved_expr2
= ffecom_save_tree (convert (tree_type
,
4106 ffecom_expr (arg2
)));
4108 ffecom_3 (COND_EXPR
, tree_type
,
4110 (ffecom_2 (GT_EXPR
, integer_type_node
,
4113 ffecom_2 (MINUS_EXPR
, tree_type
,
4116 convert (tree_type
, ffecom_float_zero_
));
4118 case FFEINTRIN_impDPROD
:
4120 ffecom_2 (MULT_EXPR
, tree_type
,
4121 convert (tree_type
, ffecom_expr (arg1
)),
4122 convert (tree_type
, ffecom_expr (arg2
)));
4124 case FFEINTRIN_impEXP
:
4125 case FFEINTRIN_impCDEXP
:
4126 case FFEINTRIN_impCEXP
:
4127 case FFEINTRIN_impDEXP
:
4128 if (bt
== FFEINFO_basictypeCOMPLEX
)
4130 if (kt
== FFEINFO_kindtypeREAL1
)
4131 gfrt
= FFECOM_gfrtCEXP
; /* Overlapping result okay. */
4132 else if (kt
== FFEINFO_kindtypeREAL2
)
4133 gfrt
= FFECOM_gfrtCDEXP
; /* Overlapping result okay. */
4137 case FFEINTRIN_impICHAR
:
4138 case FFEINTRIN_impIACHAR
:
4139 #if 0 /* The simple approach. */
4140 ffecom_char_args_ (&expr_tree
, &saved_expr1
/* Ignored */ , arg1
);
4142 = ffecom_1 (INDIRECT_REF
,
4143 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
4146 = ffecom_2 (ARRAY_REF
,
4147 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
4150 return convert (tree_type
, expr_tree
);
4151 #else /* The more interesting (and more optimal) approach. */
4152 expr_tree
= ffecom_intrinsic_ichar_ (tree_type
, arg1
, &saved_expr1
);
4153 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
4156 convert (tree_type
, integer_zero_node
));
4160 case FFEINTRIN_impINDEX
:
4163 case FFEINTRIN_impLEN
:
4165 break; /* The simple approach. */
4167 return ffecom_intrinsic_len_ (arg1
); /* The more optimal approach. */
4170 case FFEINTRIN_impLGE
:
4171 case FFEINTRIN_impLGT
:
4172 case FFEINTRIN_impLLE
:
4173 case FFEINTRIN_impLLT
:
4176 case FFEINTRIN_impLOG
:
4177 case FFEINTRIN_impALOG
:
4178 case FFEINTRIN_impCDLOG
:
4179 case FFEINTRIN_impCLOG
:
4180 case FFEINTRIN_impDLOG
:
4181 if (bt
== FFEINFO_basictypeCOMPLEX
)
4183 if (kt
== FFEINFO_kindtypeREAL1
)
4184 gfrt
= FFECOM_gfrtCLOG
; /* Overlapping result okay. */
4185 else if (kt
== FFEINFO_kindtypeREAL2
)
4186 gfrt
= FFECOM_gfrtCDLOG
; /* Overlapping result okay. */
4190 case FFEINTRIN_impLOG10
:
4191 case FFEINTRIN_impALOG10
:
4192 case FFEINTRIN_impDLOG10
:
4193 if (gfrt
!= FFECOM_gfrt
)
4194 break; /* Already picked one, stick with it. */
4196 if (kt
== FFEINFO_kindtypeREAL1
)
4197 /* We used to call FFECOM_gfrtALOG10 here. */
4198 gfrt
= FFECOM_gfrtL_LOG10
;
4199 else if (kt
== FFEINFO_kindtypeREAL2
)
4200 /* We used to call FFECOM_gfrtDLOG10 here. */
4201 gfrt
= FFECOM_gfrtL_LOG10
;
4204 case FFEINTRIN_impMAX
:
4205 case FFEINTRIN_impAMAX0
:
4206 case FFEINTRIN_impAMAX1
:
4207 case FFEINTRIN_impDMAX1
:
4208 case FFEINTRIN_impMAX0
:
4209 case FFEINTRIN_impMAX1
:
4210 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4211 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4213 arg1_type
= tree_type
;
4214 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4215 convert (arg1_type
, ffecom_expr (arg1
)),
4216 convert (arg1_type
, ffecom_expr (arg2
)));
4217 for (; list
!= NULL
; list
= ffebld_trail (list
))
4219 if ((ffebld_head (list
) == NULL
)
4220 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4222 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4225 ffecom_expr (ffebld_head (list
))));
4227 return convert (tree_type
, expr_tree
);
4229 case FFEINTRIN_impMIN
:
4230 case FFEINTRIN_impAMIN0
:
4231 case FFEINTRIN_impAMIN1
:
4232 case FFEINTRIN_impDMIN1
:
4233 case FFEINTRIN_impMIN0
:
4234 case FFEINTRIN_impMIN1
:
4235 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4236 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4238 arg1_type
= tree_type
;
4239 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4240 convert (arg1_type
, ffecom_expr (arg1
)),
4241 convert (arg1_type
, ffecom_expr (arg2
)));
4242 for (; list
!= NULL
; list
= ffebld_trail (list
))
4244 if ((ffebld_head (list
) == NULL
)
4245 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4247 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4250 ffecom_expr (ffebld_head (list
))));
4252 return convert (tree_type
, expr_tree
);
4254 case FFEINTRIN_impMOD
:
4255 case FFEINTRIN_impAMOD
:
4256 case FFEINTRIN_impDMOD
:
4257 if (bt
!= FFEINFO_basictypeREAL
)
4258 return ffecom_2 (TRUNC_MOD_EXPR
, tree_type
,
4259 convert (tree_type
, ffecom_expr (arg1
)),
4260 convert (tree_type
, ffecom_expr (arg2
)));
4262 if (kt
== FFEINFO_kindtypeREAL1
)
4263 /* We used to call FFECOM_gfrtAMOD here. */
4264 gfrt
= FFECOM_gfrtL_FMOD
;
4265 else if (kt
== FFEINFO_kindtypeREAL2
)
4266 /* We used to call FFECOM_gfrtDMOD here. */
4267 gfrt
= FFECOM_gfrtL_FMOD
;
4270 case FFEINTRIN_impNINT
:
4271 case FFEINTRIN_impIDNINT
:
4273 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4274 return ffecom_1 (FIX_ROUND_EXPR
, tree_type
, ffecom_expr (arg1
));
4276 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4277 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4279 convert (ffecom_integer_type_node
,
4280 ffecom_3 (COND_EXPR
, arg1_type
,
4282 (ffecom_2 (GE_EXPR
, integer_type_node
,
4285 ffecom_float_zero_
))),
4286 ffecom_2 (PLUS_EXPR
, arg1_type
,
4289 ffecom_float_half_
)),
4290 ffecom_2 (MINUS_EXPR
, arg1_type
,
4293 ffecom_float_half_
))));
4296 case FFEINTRIN_impSIGN
:
4297 case FFEINTRIN_impDSIGN
:
4298 case FFEINTRIN_impISIGN
:
4300 tree arg2_tree
= ffecom_expr (arg2
);
4304 (ffecom_1 (ABS_EXPR
, tree_type
,
4306 ffecom_expr (arg1
))));
4308 = ffecom_3 (COND_EXPR
, tree_type
,
4310 (ffecom_2 (GE_EXPR
, integer_type_node
,
4312 convert (TREE_TYPE (arg2_tree
),
4313 integer_zero_node
))),
4315 ffecom_1 (NEGATE_EXPR
, tree_type
, saved_expr1
));
4316 /* Make sure SAVE_EXPRs get referenced early enough. */
4318 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4319 convert (void_type_node
, saved_expr1
),
4324 case FFEINTRIN_impSIN
:
4325 case FFEINTRIN_impCDSIN
:
4326 case FFEINTRIN_impCSIN
:
4327 case FFEINTRIN_impDSIN
:
4328 if (bt
== FFEINFO_basictypeCOMPLEX
)
4330 if (kt
== FFEINFO_kindtypeREAL1
)
4331 gfrt
= FFECOM_gfrtCSIN
; /* Overlapping result okay. */
4332 else if (kt
== FFEINFO_kindtypeREAL2
)
4333 gfrt
= FFECOM_gfrtCDSIN
; /* Overlapping result okay. */
4337 case FFEINTRIN_impSINH
:
4338 case FFEINTRIN_impDSINH
:
4341 case FFEINTRIN_impSQRT
:
4342 case FFEINTRIN_impCDSQRT
:
4343 case FFEINTRIN_impCSQRT
:
4344 case FFEINTRIN_impDSQRT
:
4345 if (bt
== FFEINFO_basictypeCOMPLEX
)
4347 if (kt
== FFEINFO_kindtypeREAL1
)
4348 gfrt
= FFECOM_gfrtCSQRT
; /* Overlapping result okay. */
4349 else if (kt
== FFEINFO_kindtypeREAL2
)
4350 gfrt
= FFECOM_gfrtCDSQRT
; /* Overlapping result okay. */
4354 case FFEINTRIN_impTAN
:
4355 case FFEINTRIN_impDTAN
:
4356 case FFEINTRIN_impTANH
:
4357 case FFEINTRIN_impDTANH
:
4360 case FFEINTRIN_impREALPART
:
4361 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
4362 arg1_type
= TREE_TYPE (arg1_type
);
4364 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
4368 ffecom_1 (REALPART_EXPR
, arg1_type
,
4369 ffecom_expr (arg1
)));
4371 case FFEINTRIN_impIAND
:
4372 case FFEINTRIN_impAND
:
4373 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
4375 ffecom_expr (arg1
)),
4377 ffecom_expr (arg2
)));
4379 case FFEINTRIN_impIOR
:
4380 case FFEINTRIN_impOR
:
4381 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4383 ffecom_expr (arg1
)),
4385 ffecom_expr (arg2
)));
4387 case FFEINTRIN_impIEOR
:
4388 case FFEINTRIN_impXOR
:
4389 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
4391 ffecom_expr (arg1
)),
4393 ffecom_expr (arg2
)));
4395 case FFEINTRIN_impLSHIFT
:
4396 return ffecom_2 (LSHIFT_EXPR
, tree_type
,
4398 convert (integer_type_node
,
4399 ffecom_expr (arg2
)));
4401 case FFEINTRIN_impRSHIFT
:
4402 return ffecom_2 (RSHIFT_EXPR
, tree_type
,
4404 convert (integer_type_node
,
4405 ffecom_expr (arg2
)));
4407 case FFEINTRIN_impNOT
:
4408 return ffecom_1 (BIT_NOT_EXPR
, tree_type
, ffecom_expr (arg1
));
4410 case FFEINTRIN_impBIT_SIZE
:
4411 return convert (tree_type
, TYPE_SIZE (arg1_type
));
4413 case FFEINTRIN_impBTEST
:
4415 ffetargetLogical1 target_true
;
4416 ffetargetLogical1 target_false
;
4420 ffetarget_logical1 (&target_true
, TRUE
);
4421 ffetarget_logical1 (&target_false
, FALSE
);
4422 if (target_true
== 1)
4423 true_tree
= convert (tree_type
, integer_one_node
);
4425 true_tree
= convert (tree_type
, build_int_2 (target_true
, 0));
4426 if (target_false
== 0)
4427 false_tree
= convert (tree_type
, integer_zero_node
);
4429 false_tree
= convert (tree_type
, build_int_2 (target_false
, 0));
4432 ffecom_3 (COND_EXPR
, tree_type
,
4434 (ffecom_2 (EQ_EXPR
, integer_type_node
,
4435 ffecom_2 (BIT_AND_EXPR
, arg1_type
,
4437 ffecom_2 (LSHIFT_EXPR
, arg1_type
,
4440 convert (integer_type_node
,
4441 ffecom_expr (arg2
)))),
4443 integer_zero_node
))),
4448 case FFEINTRIN_impIBCLR
:
4450 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4452 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4453 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4456 convert (integer_type_node
,
4457 ffecom_expr (arg2
)))));
4459 case FFEINTRIN_impIBITS
:
4461 tree arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4462 ffecom_expr (arg3
)));
4464 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4467 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4468 ffecom_2 (RSHIFT_EXPR
, tree_type
,
4470 convert (integer_type_node
,
4471 ffecom_expr (arg2
))),
4473 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4474 ffecom_1 (BIT_NOT_EXPR
,
4477 integer_zero_node
)),
4478 ffecom_2 (MINUS_EXPR
,
4480 TYPE_SIZE (uns_type
),
4482 /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE. */
4484 = ffecom_3 (COND_EXPR
, tree_type
,
4486 (ffecom_2 (NE_EXPR
, integer_type_node
,
4488 integer_zero_node
)),
4490 convert (tree_type
, integer_zero_node
));
4494 case FFEINTRIN_impIBSET
:
4496 ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4498 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4499 convert (tree_type
, integer_one_node
),
4500 convert (integer_type_node
,
4501 ffecom_expr (arg2
))));
4503 case FFEINTRIN_impISHFT
:
4505 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4506 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4507 ffecom_expr (arg2
)));
4509 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4512 = ffecom_3 (COND_EXPR
, tree_type
,
4514 (ffecom_2 (GE_EXPR
, integer_type_node
,
4516 integer_zero_node
)),
4517 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4521 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4522 convert (uns_type
, arg1_tree
),
4523 ffecom_1 (NEGATE_EXPR
,
4526 /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds. */
4528 = ffecom_3 (COND_EXPR
, tree_type
,
4530 (ffecom_2 (NE_EXPR
, integer_type_node
,
4534 TYPE_SIZE (uns_type
))),
4536 convert (tree_type
, integer_zero_node
));
4537 /* Make sure SAVE_EXPRs get referenced early enough. */
4539 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4540 convert (void_type_node
, arg1_tree
),
4541 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4542 convert (void_type_node
, arg2_tree
),
4547 case FFEINTRIN_impISHFTC
:
4549 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4550 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4551 ffecom_expr (arg2
)));
4552 tree arg3_tree
= (arg3
== NULL
) ? TYPE_SIZE (tree_type
)
4553 : ffecom_save_tree (convert (integer_type_node
, ffecom_expr (arg3
)));
4559 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4562 = ffecom_2 (LSHIFT_EXPR
, tree_type
,
4563 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4564 convert (tree_type
, integer_zero_node
)),
4566 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4568 = ffecom_3 (COND_EXPR
, tree_type
,
4570 (ffecom_2 (NE_EXPR
, integer_type_node
,
4572 TYPE_SIZE (uns_type
))),
4574 convert (tree_type
, integer_zero_node
));
4575 mask_arg1
= ffecom_save_tree (mask_arg1
);
4577 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4579 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4581 masked_arg1
= ffecom_save_tree (masked_arg1
);
4583 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4585 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4586 convert (uns_type
, masked_arg1
),
4587 ffecom_1 (NEGATE_EXPR
,
4590 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4592 ffecom_2 (PLUS_EXPR
, integer_type_node
,
4596 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4597 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4601 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4602 convert (uns_type
, masked_arg1
),
4603 ffecom_2 (MINUS_EXPR
,
4608 = ffecom_3 (COND_EXPR
, tree_type
,
4610 (ffecom_2 (LT_EXPR
, integer_type_node
,
4612 integer_zero_node
)),
4616 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4617 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4620 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4621 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4625 = ffecom_3 (COND_EXPR
, tree_type
,
4627 (ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
4628 ffecom_2 (EQ_EXPR
, integer_type_node
,
4633 ffecom_2 (EQ_EXPR
, integer_type_node
,
4635 integer_zero_node
))),
4638 /* Make sure SAVE_EXPRs get referenced early enough. */
4640 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4641 convert (void_type_node
, arg1_tree
),
4642 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4643 convert (void_type_node
, arg2_tree
),
4644 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4645 convert (void_type_node
,
4647 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4648 convert (void_type_node
,
4652 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4653 convert (void_type_node
,
4659 case FFEINTRIN_impLOC
:
4661 tree arg1_tree
= ffecom_expr (arg1
);
4664 = convert (tree_type
,
4665 ffecom_1 (ADDR_EXPR
,
4666 build_pointer_type (TREE_TYPE (arg1_tree
)),
4671 case FFEINTRIN_impMVBITS
:
4676 ffebld arg4
= ffebld_head (ffebld_trail (list
));
4679 ffebld arg5
= ffebld_head (ffebld_trail (ffebld_trail (list
)));
4683 tree arg5_plus_arg3
;
4685 arg2_tree
= convert (integer_type_node
,
4686 ffecom_expr (arg2
));
4687 arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4688 ffecom_expr (arg3
)));
4689 arg4_tree
= ffecom_expr_rw (NULL_TREE
, arg4
);
4690 arg4_type
= TREE_TYPE (arg4_tree
);
4692 arg1_tree
= ffecom_save_tree (convert (arg4_type
,
4693 ffecom_expr (arg1
)));
4695 arg5_tree
= ffecom_save_tree (convert (integer_type_node
,
4696 ffecom_expr (arg5
)));
4699 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4700 ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4701 ffecom_2 (RSHIFT_EXPR
, arg4_type
,
4704 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4705 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4706 ffecom_1 (BIT_NOT_EXPR
,
4710 integer_zero_node
)),
4714 = ffecom_save_tree (ffecom_2 (PLUS_EXPR
, arg4_type
,
4718 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4719 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4721 integer_zero_node
)),
4723 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4725 = ffecom_3 (COND_EXPR
, arg4_type
,
4727 (ffecom_2 (NE_EXPR
, integer_type_node
,
4729 convert (TREE_TYPE (arg5_plus_arg3
),
4730 TYPE_SIZE (arg4_type
)))),
4732 convert (arg4_type
, integer_zero_node
));
4734 = ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4736 ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4738 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4739 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4740 ffecom_1 (BIT_NOT_EXPR
,
4744 integer_zero_node
)),
4747 = ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4750 /* Fix up (twice), because LSHIFT_EXPR above
4751 can't shift over TYPE_SIZE. */
4753 = ffecom_3 (COND_EXPR
, arg4_type
,
4755 (ffecom_2 (NE_EXPR
, integer_type_node
,
4757 convert (TREE_TYPE (arg3_tree
),
4758 integer_zero_node
))),
4762 = ffecom_3 (COND_EXPR
, arg4_type
,
4764 (ffecom_2 (NE_EXPR
, integer_type_node
,
4766 convert (TREE_TYPE (arg3_tree
),
4767 TYPE_SIZE (arg4_type
)))),
4771 = ffecom_2s (MODIFY_EXPR
, void_type_node
,
4774 /* Make sure SAVE_EXPRs get referenced early enough. */
4776 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4778 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4780 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4782 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4786 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4793 case FFEINTRIN_impDERF
:
4794 case FFEINTRIN_impERF
:
4795 case FFEINTRIN_impDERFC
:
4796 case FFEINTRIN_impERFC
:
4799 case FFEINTRIN_impIARGC
:
4800 /* extern int xargc; i__1 = xargc - 1; */
4801 expr_tree
= ffecom_2 (MINUS_EXPR
, TREE_TYPE (ffecom_tree_xargc_
),
4803 convert (TREE_TYPE (ffecom_tree_xargc_
),
4807 case FFEINTRIN_impSIGNAL_func
:
4808 case FFEINTRIN_impSIGNAL_subr
:
4814 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4815 ffecom_expr (arg1
));
4816 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4817 build_pointer_type (TREE_TYPE (arg1_tree
)),
4820 /* Pass procedure as a pointer to it, anything else by value. */
4821 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4822 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4824 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4825 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4829 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
4831 arg3_tree
= NULL_TREE
;
4833 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4834 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4835 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4838 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4839 ffecom_gfrt_kindtype (gfrt
),
4841 ((codegen_imp
== FFEINTRIN_impSIGNAL_subr
) ?
4845 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4846 ffebld_nonter_hook (expr
));
4848 if (arg3_tree
!= NULL_TREE
)
4850 = ffecom_modify (NULL_TREE
, arg3_tree
,
4851 convert (TREE_TYPE (arg3_tree
),
4856 case FFEINTRIN_impALARM
:
4862 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4863 ffecom_expr (arg1
));
4864 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4865 build_pointer_type (TREE_TYPE (arg1_tree
)),
4868 /* Pass procedure as a pointer to it, anything else by value. */
4869 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4870 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4872 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4873 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4877 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
4879 arg3_tree
= NULL_TREE
;
4881 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4882 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4883 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4886 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4887 ffecom_gfrt_kindtype (gfrt
),
4891 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4892 ffebld_nonter_hook (expr
));
4894 if (arg3_tree
!= NULL_TREE
)
4896 = ffecom_modify (NULL_TREE
, arg3_tree
,
4897 convert (TREE_TYPE (arg3_tree
),
4902 case FFEINTRIN_impCHDIR_subr
:
4903 case FFEINTRIN_impFDATE_subr
:
4904 case FFEINTRIN_impFGET_subr
:
4905 case FFEINTRIN_impFPUT_subr
:
4906 case FFEINTRIN_impGETCWD_subr
:
4907 case FFEINTRIN_impHOSTNM_subr
:
4908 case FFEINTRIN_impSYSTEM_subr
:
4909 case FFEINTRIN_impUNLINK_subr
:
4911 tree arg1_len
= integer_zero_node
;
4915 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4918 arg2_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
4920 arg2_tree
= NULL_TREE
;
4922 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4923 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4924 TREE_CHAIN (arg1_tree
) = arg1_len
;
4927 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4928 ffecom_gfrt_kindtype (gfrt
),
4932 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4933 ffebld_nonter_hook (expr
));
4935 if (arg2_tree
!= NULL_TREE
)
4937 = ffecom_modify (NULL_TREE
, arg2_tree
,
4938 convert (TREE_TYPE (arg2_tree
),
4943 case FFEINTRIN_impEXIT
:
4947 expr_tree
= build_tree_list (NULL_TREE
,
4948 ffecom_1 (ADDR_EXPR
,
4950 (ffecom_integer_type_node
),
4951 integer_zero_node
));
4954 ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4955 ffecom_gfrt_kindtype (gfrt
),
4959 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4960 ffebld_nonter_hook (expr
));
4962 case FFEINTRIN_impFLUSH
:
4964 gfrt
= FFECOM_gfrtFLUSH
;
4966 gfrt
= FFECOM_gfrtFLUSH1
;
4969 case FFEINTRIN_impCHMOD_subr
:
4970 case FFEINTRIN_impLINK_subr
:
4971 case FFEINTRIN_impRENAME_subr
:
4972 case FFEINTRIN_impSYMLNK_subr
:
4974 tree arg1_len
= integer_zero_node
;
4976 tree arg2_len
= integer_zero_node
;
4980 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4981 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
4983 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
4985 arg3_tree
= NULL_TREE
;
4987 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4988 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4989 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4990 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
4991 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4992 TREE_CHAIN (arg2_tree
) = arg1_len
;
4993 TREE_CHAIN (arg1_len
) = arg2_len
;
4994 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4995 ffecom_gfrt_kindtype (gfrt
),
4999 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5000 ffebld_nonter_hook (expr
));
5001 if (arg3_tree
!= NULL_TREE
)
5002 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5003 convert (TREE_TYPE (arg3_tree
),
5008 case FFEINTRIN_impLSTAT_subr
:
5009 case FFEINTRIN_impSTAT_subr
:
5011 tree arg1_len
= integer_zero_node
;
5016 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
5018 arg2_tree
= ffecom_ptr_to_expr (arg2
);
5021 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5023 arg3_tree
= NULL_TREE
;
5025 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5026 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5027 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5028 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5029 TREE_CHAIN (arg2_tree
) = arg1_len
;
5030 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5031 ffecom_gfrt_kindtype (gfrt
),
5035 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5036 ffebld_nonter_hook (expr
));
5037 if (arg3_tree
!= NULL_TREE
)
5038 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5039 convert (TREE_TYPE (arg3_tree
),
5044 case FFEINTRIN_impFGETC_subr
:
5045 case FFEINTRIN_impFPUTC_subr
:
5049 tree arg2_len
= integer_zero_node
;
5052 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5053 ffecom_expr (arg1
));
5054 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5055 build_pointer_type (TREE_TYPE (arg1_tree
)),
5058 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
5060 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5062 arg3_tree
= NULL_TREE
;
5064 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5065 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5066 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
5067 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5068 TREE_CHAIN (arg2_tree
) = arg2_len
;
5070 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5071 ffecom_gfrt_kindtype (gfrt
),
5075 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5076 ffebld_nonter_hook (expr
));
5077 if (arg3_tree
!= NULL_TREE
)
5078 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5079 convert (TREE_TYPE (arg3_tree
),
5084 case FFEINTRIN_impFSTAT_subr
:
5090 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5091 ffecom_expr (arg1
));
5092 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5093 build_pointer_type (TREE_TYPE (arg1_tree
)),
5096 arg2_tree
= convert (ffecom_f2c_ptr_to_integer_type_node
,
5097 ffecom_ptr_to_expr (arg2
));
5100 arg3_tree
= NULL_TREE
;
5102 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5104 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5105 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5106 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5107 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5108 ffecom_gfrt_kindtype (gfrt
),
5112 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5113 ffebld_nonter_hook (expr
));
5114 if (arg3_tree
!= NULL_TREE
) {
5115 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5116 convert (TREE_TYPE (arg3_tree
),
5122 case FFEINTRIN_impKILL_subr
:
5128 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5129 ffecom_expr (arg1
));
5130 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5131 build_pointer_type (TREE_TYPE (arg1_tree
)),
5134 arg2_tree
= convert (ffecom_f2c_integer_type_node
,
5135 ffecom_expr (arg2
));
5136 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5137 build_pointer_type (TREE_TYPE (arg2_tree
)),
5141 arg3_tree
= NULL_TREE
;
5143 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5145 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5146 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5147 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5148 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5149 ffecom_gfrt_kindtype (gfrt
),
5153 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5154 ffebld_nonter_hook (expr
));
5155 if (arg3_tree
!= NULL_TREE
) {
5156 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5157 convert (TREE_TYPE (arg3_tree
),
5163 case FFEINTRIN_impCTIME_subr
:
5164 case FFEINTRIN_impTTYNAM_subr
:
5166 tree arg1_len
= integer_zero_node
;
5170 arg1_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg1_len
);
5172 arg2_tree
= convert (((codegen_imp
== FFEINTRIN_impCTIME_subr
) ?
5173 ffecom_f2c_longint_type_node
:
5174 ffecom_f2c_integer_type_node
),
5175 ffecom_expr (arg1
));
5176 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5177 build_pointer_type (TREE_TYPE (arg2_tree
)),
5180 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5181 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5182 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5183 TREE_CHAIN (arg1_len
) = arg2_tree
;
5184 TREE_CHAIN (arg1_tree
) = arg1_len
;
5187 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5188 ffecom_gfrt_kindtype (gfrt
),
5192 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5193 ffebld_nonter_hook (expr
));
5194 TREE_SIDE_EFFECTS (expr_tree
) = 1;
5198 case FFEINTRIN_impIRAND
:
5199 case FFEINTRIN_impRAND
:
5200 /* Arg defaults to 0 (normal random case) */
5205 arg1_tree
= ffecom_integer_zero_node
;
5207 arg1_tree
= ffecom_expr (arg1
);
5208 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5210 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5211 build_pointer_type (TREE_TYPE (arg1_tree
)),
5213 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5215 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5216 ffecom_gfrt_kindtype (gfrt
),
5218 ((codegen_imp
== FFEINTRIN_impIRAND
) ?
5219 ffecom_f2c_integer_type_node
:
5220 ffecom_f2c_real_type_node
),
5222 dest_tree
, dest
, dest_used
,
5224 ffebld_nonter_hook (expr
));
5228 case FFEINTRIN_impFTELL_subr
:
5229 case FFEINTRIN_impUMASK_subr
:
5234 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5235 ffecom_expr (arg1
));
5236 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5237 build_pointer_type (TREE_TYPE (arg1_tree
)),
5241 arg2_tree
= NULL_TREE
;
5243 arg2_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
5245 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5246 ffecom_gfrt_kindtype (gfrt
),
5249 build_tree_list (NULL_TREE
, arg1_tree
),
5250 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5252 ffebld_nonter_hook (expr
));
5253 if (arg2_tree
!= NULL_TREE
) {
5254 expr_tree
= ffecom_modify (NULL_TREE
, arg2_tree
,
5255 convert (TREE_TYPE (arg2_tree
),
5261 case FFEINTRIN_impCPU_TIME
:
5262 case FFEINTRIN_impSECOND_subr
:
5266 arg1_tree
= ffecom_expr_w (NULL_TREE
, arg1
);
5269 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5270 ffecom_gfrt_kindtype (gfrt
),
5274 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5275 ffebld_nonter_hook (expr
));
5278 = ffecom_modify (NULL_TREE
, arg1_tree
,
5279 convert (TREE_TYPE (arg1_tree
),
5284 case FFEINTRIN_impDTIME_subr
:
5285 case FFEINTRIN_impETIME_subr
:
5290 result_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
5292 arg1_tree
= ffecom_ptr_to_expr (arg1
);
5294 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5295 ffecom_gfrt_kindtype (gfrt
),
5298 build_tree_list (NULL_TREE
, arg1_tree
),
5299 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5301 ffebld_nonter_hook (expr
));
5302 expr_tree
= ffecom_modify (NULL_TREE
, result_tree
,
5303 convert (TREE_TYPE (result_tree
),
5308 /* Straightforward calls of libf2c routines: */
5309 case FFEINTRIN_impABORT
:
5310 case FFEINTRIN_impACCESS
:
5311 case FFEINTRIN_impBESJ0
:
5312 case FFEINTRIN_impBESJ1
:
5313 case FFEINTRIN_impBESJN
:
5314 case FFEINTRIN_impBESY0
:
5315 case FFEINTRIN_impBESY1
:
5316 case FFEINTRIN_impBESYN
:
5317 case FFEINTRIN_impCHDIR_func
:
5318 case FFEINTRIN_impCHMOD_func
:
5319 case FFEINTRIN_impDATE
:
5320 case FFEINTRIN_impDATE_AND_TIME
:
5321 case FFEINTRIN_impDBESJ0
:
5322 case FFEINTRIN_impDBESJ1
:
5323 case FFEINTRIN_impDBESJN
:
5324 case FFEINTRIN_impDBESY0
:
5325 case FFEINTRIN_impDBESY1
:
5326 case FFEINTRIN_impDBESYN
:
5327 case FFEINTRIN_impDTIME_func
:
5328 case FFEINTRIN_impETIME_func
:
5329 case FFEINTRIN_impFGETC_func
:
5330 case FFEINTRIN_impFGET_func
:
5331 case FFEINTRIN_impFNUM
:
5332 case FFEINTRIN_impFPUTC_func
:
5333 case FFEINTRIN_impFPUT_func
:
5334 case FFEINTRIN_impFSEEK
:
5335 case FFEINTRIN_impFSTAT_func
:
5336 case FFEINTRIN_impFTELL_func
:
5337 case FFEINTRIN_impGERROR
:
5338 case FFEINTRIN_impGETARG
:
5339 case FFEINTRIN_impGETCWD_func
:
5340 case FFEINTRIN_impGETENV
:
5341 case FFEINTRIN_impGETGID
:
5342 case FFEINTRIN_impGETLOG
:
5343 case FFEINTRIN_impGETPID
:
5344 case FFEINTRIN_impGETUID
:
5345 case FFEINTRIN_impGMTIME
:
5346 case FFEINTRIN_impHOSTNM_func
:
5347 case FFEINTRIN_impIDATE_unix
:
5348 case FFEINTRIN_impIDATE_vxt
:
5349 case FFEINTRIN_impIERRNO
:
5350 case FFEINTRIN_impISATTY
:
5351 case FFEINTRIN_impITIME
:
5352 case FFEINTRIN_impKILL_func
:
5353 case FFEINTRIN_impLINK_func
:
5354 case FFEINTRIN_impLNBLNK
:
5355 case FFEINTRIN_impLSTAT_func
:
5356 case FFEINTRIN_impLTIME
:
5357 case FFEINTRIN_impMCLOCK8
:
5358 case FFEINTRIN_impMCLOCK
:
5359 case FFEINTRIN_impPERROR
:
5360 case FFEINTRIN_impRENAME_func
:
5361 case FFEINTRIN_impSECNDS
:
5362 case FFEINTRIN_impSECOND_func
:
5363 case FFEINTRIN_impSLEEP
:
5364 case FFEINTRIN_impSRAND
:
5365 case FFEINTRIN_impSTAT_func
:
5366 case FFEINTRIN_impSYMLNK_func
:
5367 case FFEINTRIN_impSYSTEM_CLOCK
:
5368 case FFEINTRIN_impSYSTEM_func
:
5369 case FFEINTRIN_impTIME8
:
5370 case FFEINTRIN_impTIME_unix
:
5371 case FFEINTRIN_impTIME_vxt
:
5372 case FFEINTRIN_impUMASK_func
:
5373 case FFEINTRIN_impUNLINK_func
:
5376 case FFEINTRIN_impCTIME_func
: /* CHARACTER functions not handled here. */
5377 case FFEINTRIN_impFDATE_func
: /* CHARACTER functions not handled here. */
5378 case FFEINTRIN_impTTYNAM_func
: /* CHARACTER functions not handled here. */
5379 case FFEINTRIN_impNONE
:
5380 case FFEINTRIN_imp
: /* Hush up gcc warning. */
5381 fprintf (stderr
, "No %s implementation.\n",
5382 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr
))));
5383 assert ("unimplemented intrinsic" == NULL
);
5384 return error_mark_node
;
5387 assert (gfrt
!= FFECOM_gfrt
); /* Must have an implementation! */
5389 expr_tree
= ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt
),
5390 ffebld_right (expr
));
5392 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt
), ffecom_gfrt_kindtype (gfrt
),
5393 (ffe_is_f2c_library () && ffecom_gfrt_complex_
[gfrt
]),
5395 expr_tree
, dest_tree
, dest
, dest_used
,
5397 ffebld_nonter_hook (expr
));
5399 /* See bottom of this file for f2c transforms used to determine
5400 many of the above implementations. The info seems to confuse
5401 Emacs's C mode indentation, which is why it's been moved to
5402 the bottom of this source file. */
5405 /* For power (exponentiation) where right-hand operand is type INTEGER,
5406 generate in-line code to do it the fast way (which, if the operand
5407 is a constant, might just mean a series of multiplies). */
5410 ffecom_expr_power_integer_ (ffebld expr
)
5412 tree l
= ffecom_expr (ffebld_left (expr
));
5413 tree r
= ffecom_expr (ffebld_right (expr
));
5414 tree ltype
= TREE_TYPE (l
);
5415 tree rtype
= TREE_TYPE (r
);
5416 tree result
= NULL_TREE
;
5418 if (l
== error_mark_node
5419 || r
== error_mark_node
)
5420 return error_mark_node
;
5422 if (TREE_CODE (r
) == INTEGER_CST
)
5424 int sgn
= tree_int_cst_sgn (r
);
5427 return convert (ltype
, integer_one_node
);
5429 if ((TREE_CODE (ltype
) == INTEGER_TYPE
)
5432 /* Reciprocal of integer is either 0, -1, or 1, so after
5433 calculating that (which we leave to the back end to do
5434 or not do optimally), don't bother with any multiplying. */
5436 result
= ffecom_tree_divide_ (ltype
,
5437 convert (ltype
, integer_one_node
),
5439 NULL_TREE
, NULL
, NULL
, NULL_TREE
);
5440 r
= ffecom_1 (NEGATE_EXPR
,
5443 if ((TREE_INT_CST_LOW (r
) & 1) == 0)
5444 result
= ffecom_1 (ABS_EXPR
, rtype
,
5448 /* Generate appropriate series of multiplies, preceded
5449 by divide if the exponent is negative. */
5455 l
= ffecom_tree_divide_ (ltype
,
5456 convert (ltype
, integer_one_node
),
5458 NULL_TREE
, NULL
, NULL
,
5459 ffebld_nonter_hook (expr
));
5460 r
= ffecom_1 (NEGATE_EXPR
, rtype
, r
);
5461 assert (TREE_CODE (r
) == INTEGER_CST
);
5463 if (tree_int_cst_sgn (r
) < 0)
5464 { /* The "most negative" number. */
5465 r
= ffecom_1 (NEGATE_EXPR
, rtype
,
5466 ffecom_2 (RSHIFT_EXPR
, rtype
,
5470 l
= ffecom_2 (MULT_EXPR
, ltype
,
5478 if (TREE_INT_CST_LOW (r
) & 1)
5480 if (result
== NULL_TREE
)
5483 result
= ffecom_2 (MULT_EXPR
, ltype
,
5488 r
= ffecom_2 (RSHIFT_EXPR
, rtype
,
5491 if (integer_zerop (r
))
5493 assert (TREE_CODE (r
) == INTEGER_CST
);
5496 l
= ffecom_2 (MULT_EXPR
, ltype
,
5503 /* Though rhs isn't a constant, in-line code cannot be expanded
5504 while transforming dummies
5505 because the back end cannot be easily convinced to generate
5506 stores (MODIFY_EXPR), handle temporaries, and so on before
5507 all the appropriate rtx's have been generated for things like
5508 dummy args referenced in rhs -- which doesn't happen until
5509 store_parm_decls() is called (expand_function_start, I believe,
5510 does the actual rtx-stuffing of PARM_DECLs).
5512 So, in this case, let the caller generate the call to the
5513 run-time-library function to evaluate the power for us. */
5515 if (ffecom_transform_only_dummies_
)
5518 /* Right-hand operand not a constant, expand in-line code to figure
5519 out how to do the multiplies, &c.
5521 The returned expression is expressed this way in GNU C, where l and
5524 ({ typeof (r) rtmp = r;
5525 typeof (l) ltmp = l;
5532 if ((basetypeof (l) == basetypeof (int))
5535 result = ((typeof (l)) 1) / ltmp;
5536 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5542 if ((basetypeof (l) != basetypeof (int))
5545 ltmp = ((typeof (l)) 1) / ltmp;
5549 rtmp = -(rtmp >> 1);
5557 if ((rtmp >>= 1) == 0)
5566 Note that some of the above is compile-time collapsable, such as
5567 the first part of the if statements that checks the base type of
5568 l against int. The if statements are phrased that way to suggest
5569 an easy way to generate the if/else constructs here, knowing that
5570 the back end should (and probably does) eliminate the resulting
5571 dead code (either the int case or the non-int case), something
5572 it couldn't do without the redundant phrasing, requiring explicit
5573 dead-code elimination here, which would be kind of difficult to
5580 tree basetypeof_l_is_int
;
5585 = build_int_2 ((TREE_CODE (ltype
) == INTEGER_TYPE
), 0);
5587 se
= expand_start_stmt_expr ();
5589 ffecom_start_compstmt ();
5592 rtmp
= ffecom_make_tempvar ("power_r", rtype
,
5593 FFETARGET_charactersizeNONE
, -1);
5594 ltmp
= ffecom_make_tempvar ("power_l", ltype
,
5595 FFETARGET_charactersizeNONE
, -1);
5596 result
= ffecom_make_tempvar ("power_res", ltype
,
5597 FFETARGET_charactersizeNONE
, -1);
5598 if (TREE_CODE (ltype
) == COMPLEX_TYPE
5599 || TREE_CODE (ltype
) == RECORD_TYPE
)
5600 divide
= ffecom_make_tempvar ("power_div", ltype
,
5601 FFETARGET_charactersizeNONE
, -1);
5608 hook
= ffebld_nonter_hook (expr
);
5610 assert (TREE_CODE (hook
) == TREE_VEC
);
5611 assert (TREE_VEC_LENGTH (hook
) == 4);
5612 rtmp
= TREE_VEC_ELT (hook
, 0);
5613 ltmp
= TREE_VEC_ELT (hook
, 1);
5614 result
= TREE_VEC_ELT (hook
, 2);
5615 divide
= TREE_VEC_ELT (hook
, 3);
5616 if (TREE_CODE (ltype
) == COMPLEX_TYPE
5617 || TREE_CODE (ltype
) == RECORD_TYPE
)
5624 expand_expr_stmt (ffecom_modify (void_type_node
,
5627 expand_expr_stmt (ffecom_modify (void_type_node
,
5630 expand_start_cond (ffecom_truth_value
5631 (ffecom_2 (EQ_EXPR
, integer_type_node
,
5633 convert (rtype
, integer_zero_node
))),
5635 expand_expr_stmt (ffecom_modify (void_type_node
,
5637 convert (ltype
, integer_one_node
)));
5638 expand_start_else ();
5639 if (! integer_zerop (basetypeof_l_is_int
))
5641 expand_start_cond (ffecom_2 (LT_EXPR
, integer_type_node
,
5644 integer_zero_node
)),
5646 expand_expr_stmt (ffecom_modify (void_type_node
,
5650 convert (ltype
, integer_one_node
),
5652 NULL_TREE
, NULL
, NULL
,
5654 expand_start_cond (ffecom_truth_value
5655 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
5656 ffecom_2 (LT_EXPR
, integer_type_node
,
5659 integer_zero_node
)),
5660 ffecom_2 (EQ_EXPR
, integer_type_node
,
5661 ffecom_2 (BIT_AND_EXPR
,
5663 ffecom_1 (NEGATE_EXPR
,
5669 integer_zero_node
)))),
5671 expand_expr_stmt (ffecom_modify (void_type_node
,
5673 ffecom_1 (NEGATE_EXPR
,
5677 expand_start_else ();
5679 expand_expr_stmt (ffecom_modify (void_type_node
,
5681 convert (ltype
, integer_one_node
)));
5682 expand_start_cond (ffecom_truth_value
5683 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
5684 ffecom_truth_value_invert
5685 (basetypeof_l_is_int
),
5686 ffecom_2 (LT_EXPR
, integer_type_node
,
5689 integer_zero_node
)))),
5691 expand_expr_stmt (ffecom_modify (void_type_node
,
5695 convert (ltype
, integer_one_node
),
5697 NULL_TREE
, NULL
, NULL
,
5699 expand_expr_stmt (ffecom_modify (void_type_node
,
5701 ffecom_1 (NEGATE_EXPR
, rtype
,
5703 expand_start_cond (ffecom_truth_value
5704 (ffecom_2 (LT_EXPR
, integer_type_node
,
5706 convert (rtype
, integer_zero_node
))),
5708 expand_expr_stmt (ffecom_modify (void_type_node
,
5710 ffecom_1 (NEGATE_EXPR
, rtype
,
5711 ffecom_2 (RSHIFT_EXPR
,
5714 integer_one_node
))));
5715 expand_expr_stmt (ffecom_modify (void_type_node
,
5717 ffecom_2 (MULT_EXPR
, ltype
,
5722 expand_start_loop (1);
5723 expand_start_cond (ffecom_truth_value
5724 (ffecom_2 (BIT_AND_EXPR
, rtype
,
5726 convert (rtype
, integer_one_node
))),
5728 expand_expr_stmt (ffecom_modify (void_type_node
,
5730 ffecom_2 (MULT_EXPR
, ltype
,
5734 expand_exit_loop_if_false (NULL
,
5736 (ffecom_modify (rtype
,
5738 ffecom_2 (RSHIFT_EXPR
,
5741 integer_one_node
))));
5742 expand_expr_stmt (ffecom_modify (void_type_node
,
5744 ffecom_2 (MULT_EXPR
, ltype
,
5749 if (!integer_zerop (basetypeof_l_is_int
))
5751 expand_expr_stmt (result
);
5753 t
= ffecom_end_compstmt ();
5755 result
= expand_end_stmt_expr (se
);
5757 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5759 if (TREE_CODE (t
) == BLOCK
)
5761 /* Make a BIND_EXPR for the BLOCK already made. */
5762 result
= build (BIND_EXPR
, TREE_TYPE (result
),
5763 NULL_TREE
, result
, t
);
5764 /* Remove the block from the tree at this point.
5765 It gets put back at the proper place
5766 when the BIND_EXPR is expanded. */
5776 /* ffecom_expr_transform_ -- Transform symbols in expr
5778 ffebld expr; // FFE expression.
5779 ffecom_expr_transform_ (expr);
5781 Recursive descent on expr while transforming any untransformed SYMTERs. */
5784 ffecom_expr_transform_ (ffebld expr
)
5794 switch (ffebld_op (expr
))
5796 case FFEBLD_opSYMTER
:
5797 s
= ffebld_symter (expr
);
5798 t
= ffesymbol_hook (s
).decl_tree
;
5799 if ((t
== NULL_TREE
)
5800 && ((ffesymbol_kind (s
) != FFEINFO_kindNONE
)
5801 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
5802 && (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
))))
5804 s
= ffecom_sym_transform_ (s
);
5805 t
= ffesymbol_hook (s
).decl_tree
; /* Sfunc expr non-dummy,
5808 break; /* Ok if (t == NULL) here. */
5811 ffecom_expr_transform_ (ffebld_head (expr
));
5812 expr
= ffebld_trail (expr
);
5813 goto tail_recurse
; /* :::::::::::::::::::: */
5819 switch (ffebld_arity (expr
))
5822 ffecom_expr_transform_ (ffebld_left (expr
));
5823 expr
= ffebld_right (expr
);
5824 goto tail_recurse
; /* :::::::::::::::::::: */
5827 expr
= ffebld_left (expr
);
5828 goto tail_recurse
; /* :::::::::::::::::::: */
5837 /* Make a type based on info in live f2c.h file. */
5840 ffecom_f2c_make_type_ (tree
*type
, int tcode
, const char *name
)
5844 case FFECOM_f2ccodeCHAR
:
5845 *type
= make_signed_type (CHAR_TYPE_SIZE
);
5848 case FFECOM_f2ccodeSHORT
:
5849 *type
= make_signed_type (SHORT_TYPE_SIZE
);
5852 case FFECOM_f2ccodeINT
:
5853 *type
= make_signed_type (INT_TYPE_SIZE
);
5856 case FFECOM_f2ccodeLONG
:
5857 *type
= make_signed_type (LONG_TYPE_SIZE
);
5860 case FFECOM_f2ccodeLONGLONG
:
5861 *type
= make_signed_type (LONG_LONG_TYPE_SIZE
);
5864 case FFECOM_f2ccodeCHARPTR
:
5865 *type
= build_pointer_type (DEFAULT_SIGNED_CHAR
5866 ? signed_char_type_node
5867 : unsigned_char_type_node
);
5870 case FFECOM_f2ccodeFLOAT
:
5871 *type
= make_node (REAL_TYPE
);
5872 TYPE_PRECISION (*type
) = FLOAT_TYPE_SIZE
;
5873 layout_type (*type
);
5876 case FFECOM_f2ccodeDOUBLE
:
5877 *type
= make_node (REAL_TYPE
);
5878 TYPE_PRECISION (*type
) = DOUBLE_TYPE_SIZE
;
5879 layout_type (*type
);
5882 case FFECOM_f2ccodeLONGDOUBLE
:
5883 *type
= make_node (REAL_TYPE
);
5884 TYPE_PRECISION (*type
) = LONG_DOUBLE_TYPE_SIZE
;
5885 layout_type (*type
);
5888 case FFECOM_f2ccodeTWOREALS
:
5889 *type
= ffecom_make_complex_type_ (ffecom_f2c_real_type_node
);
5892 case FFECOM_f2ccodeTWODOUBLEREALS
:
5893 *type
= ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node
);
5897 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL
);
5898 *type
= error_mark_node
;
5902 pushdecl (build_decl (TYPE_DECL
,
5903 ffecom_get_invented_identifier ("__g77_f2c_%s", name
),
5907 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5911 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
5917 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
5918 if ((t
= ffecom_tree_type
[bt
][j
]) != NULL_TREE
5919 && compare_tree_int (TYPE_SIZE (t
), size
) == 0)
5921 assert (code
!= -1);
5922 ffecom_f2c_typecode_
[bt
][j
] = code
;
5927 /* Finish up globals after doing all program units in file
5929 Need to handle only uninitialized COMMON areas. */
5932 ffecom_finish_global_ (ffeglobal global
)
5938 if (ffeglobal_type (global
) != FFEGLOBAL_typeCOMMON
)
5941 if (ffeglobal_common_init (global
))
5944 cbt
= ffeglobal_hook (global
);
5945 if ((cbt
== NULL_TREE
)
5946 || !ffeglobal_common_have_size (global
))
5947 return global
; /* No need to make common, never ref'd. */
5949 DECL_EXTERNAL (cbt
) = 0;
5951 /* Give the array a size now. */
5953 size
= build_int_2 ((ffeglobal_common_size (global
)
5954 + ffeglobal_common_pad (global
)) - 1,
5957 cbtype
= TREE_TYPE (cbt
);
5958 TYPE_DOMAIN (cbtype
) = build_range_type (integer_type_node
,
5961 if (!TREE_TYPE (size
))
5962 TREE_TYPE (size
) = TYPE_DOMAIN (cbtype
);
5963 layout_type (cbtype
);
5965 cbt
= start_decl (cbt
, FALSE
);
5966 assert (cbt
== ffeglobal_hook (global
));
5968 finish_decl (cbt
, NULL_TREE
, FALSE
);
5973 /* Finish up any untransformed symbols. */
5976 ffecom_finish_symbol_transform_ (ffesymbol s
)
5978 if ((s
== NULL
) || (TREE_CODE (current_function_decl
) == ERROR_MARK
))
5981 /* It's easy to know to transform an untransformed symbol, to make sure
5982 we put out debugging info for it. But COMMON variables, unlike
5983 EQUIVALENCE ones, aren't given declarations in addition to the
5984 tree expressions that specify offsets, because COMMON variables
5985 can be referenced in the outer scope where only dummy arguments
5986 (PARM_DECLs) should really be seen. To be safe, just don't do any
5987 VAR_DECLs for COMMON variables when we transform them for real
5988 use, and therefore we do all the VAR_DECL creating here. */
5990 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
)
5992 if (ffesymbol_kind (s
) != FFEINFO_kindNONE
5993 || (ffesymbol_where (s
) != FFEINFO_whereNONE
5994 && ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
5995 && ffesymbol_where (s
) != FFEINFO_whereDUMMY
))
5996 /* Not transformed, and not CHARACTER*(*), and not a dummy
5997 argument, which can happen only if the entry point names
5998 it "rides in on" are all invalidated for other reasons. */
5999 s
= ffecom_sym_transform_ (s
);
6002 if ((ffesymbol_where (s
) == FFEINFO_whereCOMMON
)
6003 && (ffesymbol_hook (s
).decl_tree
!= error_mark_node
))
6005 /* This isn't working, at least for dbxout. The .s file looks
6006 okay to me (burley), but in gdb 4.9 at least, the variables
6007 appear to reside somewhere outside of the common area, so
6008 it doesn't make sense to mislead anyone by generating the info
6009 on those variables until this is fixed. NOTE: Same problem
6010 with EQUIVALENCE, sadly...see similar #if later. */
6011 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s
)),
6012 ffesymbol_storage (s
));
6018 /* Append underscore(s) to name before calling get_identifier. "us"
6019 is nonzero if the name already contains an underscore and thus
6020 needs two underscores appended. */
6023 ffecom_get_appended_identifier_ (char us
, const char *name
)
6029 newname
= xmalloc ((i
= strlen (name
)) + 1
6030 + ffe_is_underscoring ()
6032 memcpy (newname
, name
, i
);
6034 newname
[i
+ us
] = '_';
6035 newname
[i
+ 1 + us
] = '\0';
6036 id
= get_identifier (newname
);
6043 /* Decide whether to append underscore to name before calling
6047 ffecom_get_external_identifier_ (ffesymbol s
)
6050 const char *name
= ffesymbol_text (s
);
6052 /* If name is a built-in name, just return it as is. */
6054 if (!ffe_is_underscoring ()
6055 || (strcmp (name
, FFETARGET_nameBLANK_COMMON
) == 0)
6056 #if FFETARGET_isENFORCED_MAIN_NAME
6057 || (strcmp (name
, FFETARGET_nameENFORCED_NAME
) == 0)
6059 || (strcmp (name
, FFETARGET_nameUNNAMED_MAIN
) == 0)
6061 || (strcmp (name
, FFETARGET_nameUNNAMED_BLOCK_DATA
) == 0))
6062 return get_identifier (name
);
6064 us
= ffe_is_second_underscore ()
6065 ? (strchr (name
, '_') != NULL
)
6068 return ffecom_get_appended_identifier_ (us
, name
);
6071 /* Decide whether to append underscore to internal name before calling
6074 This is for non-external, top-function-context names only. Transform
6075 identifier so it doesn't conflict with the transformed result
6076 of using a _different_ external name. E.g. if "CALL FOO" is
6077 transformed into "FOO_();", then the variable in "FOO_ = 3"
6078 must be transformed into something that does not conflict, since
6079 these two things should be independent.
6081 The transformation is as follows. If the name does not contain
6082 an underscore, there is no possible conflict, so just return.
6083 If the name does contain an underscore, then transform it just
6084 like we transform an external identifier. */
6087 ffecom_get_identifier_ (const char *name
)
6089 /* If name does not contain an underscore, just return it as is. */
6091 if (!ffe_is_underscoring ()
6092 || (strchr (name
, '_') == NULL
))
6093 return get_identifier (name
);
6095 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6099 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6102 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6103 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6104 ffesymbol_kindtype(s));
6106 Call after setting up containing function and getting trees for all
6110 ffecom_gen_sfuncdef_ (ffesymbol s
, ffeinfoBasictype bt
, ffeinfoKindtype kt
)
6112 ffebld expr
= ffesymbol_sfexpr (s
);
6116 bool charfunc
= (bt
== FFEINFO_basictypeCHARACTER
);
6117 static bool recurse
= FALSE
;
6118 int old_lineno
= lineno
;
6119 const char *old_input_filename
= input_filename
;
6121 ffecom_nested_entry_
= s
;
6123 /* For now, we don't have a handy pointer to where the sfunc is actually
6124 defined, though that should be easy to add to an ffesymbol. (The
6125 token/where info available might well point to the place where the type
6126 of the sfunc is declared, especially if that precedes the place where
6127 the sfunc itself is defined, which is typically the case.) We should
6128 put out a null pointer rather than point somewhere wrong, but I want to
6129 see how it works at this point. */
6131 input_filename
= ffesymbol_where_filename (s
);
6132 lineno
= ffesymbol_where_filelinenum (s
);
6134 /* Pretransform the expression so any newly discovered things belong to the
6135 outer program unit, not to the statement function. */
6137 ffecom_expr_transform_ (expr
);
6139 /* Make sure no recursive invocation of this fn (a specific case of failing
6140 to pretransform an sfunc's expression, i.e. where its expression
6141 references another untransformed sfunc) happens. */
6146 push_f_function_context ();
6149 type
= void_type_node
;
6152 type
= ffecom_tree_type
[bt
][kt
];
6153 if (type
== NULL_TREE
)
6154 type
= integer_type_node
; /* _sym_exec_transition reports
6158 start_function (ffecom_get_identifier_ (ffesymbol_text (s
)),
6159 build_function_type (type
, NULL_TREE
),
6160 1, /* nested/inline */
6161 0); /* TREE_PUBLIC */
6163 /* We don't worry about COMPLEX return values here, because this is
6164 entirely internal to our code, and gcc has the ability to return COMPLEX
6165 directly as a value. */
6168 { /* Prepend arg for where result goes. */
6171 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
6173 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
6175 ffecom_char_enhance_arg_ (&type
, s
); /* Ignore returned length. */
6177 type
= build_pointer_type (type
);
6178 result
= build_decl (PARM_DECL
, result
, type
);
6180 push_parm_decl (result
);
6183 result
= NULL_TREE
; /* Not ref'd if !charfunc. */
6185 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s
), TRUE
);
6187 store_parm_decls (0);
6189 ffecom_start_compstmt ();
6195 ffetargetCharacterSize sz
= ffesymbol_size (s
);
6198 result_length
= build_int_2 (sz
, 0);
6199 TREE_TYPE (result_length
) = ffecom_f2c_ftnlen_type_node
;
6201 ffecom_prepare_let_char_ (sz
, expr
);
6203 ffecom_prepare_end ();
6205 ffecom_let_char_ (result
, result_length
, sz
, expr
);
6206 expand_null_return ();
6210 ffecom_prepare_expr (expr
);
6212 ffecom_prepare_end ();
6214 expand_return (ffecom_modify (NULL_TREE
,
6215 DECL_RESULT (current_function_decl
),
6216 ffecom_expr (expr
)));
6220 ffecom_end_compstmt ();
6222 func
= current_function_decl
;
6223 finish_function (1);
6225 pop_f_function_context ();
6229 lineno
= old_lineno
;
6230 input_filename
= old_input_filename
;
6232 ffecom_nested_entry_
= NULL
;
6238 ffecom_gfrt_args_ (ffecomGfrt ix
)
6240 return ffecom_gfrt_argstring_
[ix
];
6244 ffecom_gfrt_tree_ (ffecomGfrt ix
)
6246 if (ffecom_gfrt_
[ix
] == NULL_TREE
)
6247 ffecom_make_gfrt_ (ix
);
6249 return ffecom_1 (ADDR_EXPR
,
6250 build_pointer_type (TREE_TYPE (ffecom_gfrt_
[ix
])),
6254 /* Return initialize-to-zero expression for this VAR_DECL. */
6256 /* A somewhat evil way to prevent the garbage collector
6257 from collecting 'tree' structures. */
6258 #define NUM_TRACKED_CHUNK 63
6259 static struct tree_ggc_tracker
6261 struct tree_ggc_tracker
*next
;
6262 tree trees
[NUM_TRACKED_CHUNK
];
6263 } *tracker_head
= NULL
;
6266 mark_tracker_head (void *arg
)
6268 struct tree_ggc_tracker
*head
;
6271 for (head
= * (struct tree_ggc_tracker
**) arg
;
6276 for (i
= 0; i
< NUM_TRACKED_CHUNK
; i
++)
6277 ggc_mark_tree (head
->trees
[i
]);
6282 ffecom_save_tree_forever (tree t
)
6285 if (tracker_head
!= NULL
)
6286 for (i
= 0; i
< NUM_TRACKED_CHUNK
; i
++)
6287 if (tracker_head
->trees
[i
] == NULL
)
6289 tracker_head
->trees
[i
] = t
;
6294 /* Need to allocate a new block. */
6295 struct tree_ggc_tracker
*old_head
= tracker_head
;
6297 tracker_head
= ggc_alloc (sizeof (*tracker_head
));
6298 tracker_head
->next
= old_head
;
6299 tracker_head
->trees
[0] = t
;
6300 for (i
= 1; i
< NUM_TRACKED_CHUNK
; i
++)
6301 tracker_head
->trees
[i
] = NULL
;
6306 ffecom_init_zero_ (tree decl
)
6309 int incremental
= TREE_STATIC (decl
);
6310 tree type
= TREE_TYPE (decl
);
6314 make_decl_rtl (decl
, NULL
);
6315 assemble_variable (decl
, TREE_PUBLIC (decl
) ? 1 : 0, 0, 1);
6318 if ((TREE_CODE (type
) != ARRAY_TYPE
)
6319 && (TREE_CODE (type
) != RECORD_TYPE
)
6320 && (TREE_CODE (type
) != UNION_TYPE
)
6322 init
= convert (type
, integer_zero_node
);
6323 else if (!incremental
)
6325 init
= build (CONSTRUCTOR
, type
, NULL_TREE
, NULL_TREE
);
6326 TREE_CONSTANT (init
) = 1;
6327 TREE_STATIC (init
) = 1;
6331 assemble_zeros (int_size_in_bytes (type
));
6332 init
= error_mark_node
;
6339 ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
6345 switch (ffebld_op (arg
))
6347 case FFEBLD_opCONTER
: /* For F90, check 0-length. */
6348 if (ffetarget_length_character1
6349 (ffebld_constant_character1
6350 (ffebld_conter (arg
))) == 0)
6352 *maybe_tree
= integer_zero_node
;
6353 return convert (tree_type
, integer_zero_node
);
6356 *maybe_tree
= integer_one_node
;
6357 expr_tree
= build_int_2 (*ffetarget_text_character1
6358 (ffebld_constant_character1
6359 (ffebld_conter (arg
))),
6361 TREE_TYPE (expr_tree
) = tree_type
;
6364 case FFEBLD_opSYMTER
:
6365 case FFEBLD_opARRAYREF
:
6366 case FFEBLD_opFUNCREF
:
6367 case FFEBLD_opSUBSTR
:
6368 ffecom_char_args_ (&expr_tree
, &length_tree
, arg
);
6370 if ((expr_tree
== error_mark_node
)
6371 || (length_tree
== error_mark_node
))
6373 *maybe_tree
= error_mark_node
;
6374 return error_mark_node
;
6377 if (integer_zerop (length_tree
))
6379 *maybe_tree
= integer_zero_node
;
6380 return convert (tree_type
, integer_zero_node
);
6384 = ffecom_1 (INDIRECT_REF
,
6385 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
6388 = ffecom_2 (ARRAY_REF
,
6389 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
6392 expr_tree
= convert (tree_type
, expr_tree
);
6394 if (TREE_CODE (length_tree
) == INTEGER_CST
)
6395 *maybe_tree
= integer_one_node
;
6396 else /* Must check length at run time. */
6398 = ffecom_truth_value
6399 (ffecom_2 (GT_EXPR
, integer_type_node
,
6401 ffecom_f2c_ftnlen_zero_node
));
6404 case FFEBLD_opPAREN
:
6405 case FFEBLD_opCONVERT
:
6406 if (ffeinfo_size (ffebld_info (arg
)) == 0)
6408 *maybe_tree
= integer_zero_node
;
6409 return convert (tree_type
, integer_zero_node
);
6411 return ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
6414 case FFEBLD_opCONCATENATE
:
6421 expr_left
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
6423 expr_right
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_right (arg
),
6425 *maybe_tree
= ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
6428 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
6436 assert ("bad op in ICHAR" == NULL
);
6437 return error_mark_node
;
6441 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6445 length_arg = ffecom_intrinsic_len_ (expr);
6447 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6448 subexpressions by constructing the appropriate tree for the
6449 length-of-character-text argument in a calling sequence. */
6452 ffecom_intrinsic_len_ (ffebld expr
)
6454 ffetargetCharacter1 val
;
6457 switch (ffebld_op (expr
))
6459 case FFEBLD_opCONTER
:
6460 val
= ffebld_constant_character1 (ffebld_conter (expr
));
6461 length
= build_int_2 (ffetarget_length_character1 (val
), 0);
6462 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6465 case FFEBLD_opSYMTER
:
6467 ffesymbol s
= ffebld_symter (expr
);
6470 item
= ffesymbol_hook (s
).decl_tree
;
6471 if (item
== NULL_TREE
)
6473 s
= ffecom_sym_transform_ (s
);
6474 item
= ffesymbol_hook (s
).decl_tree
;
6476 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
6478 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
6479 length
= ffesymbol_hook (s
).length_tree
;
6482 length
= build_int_2 (ffesymbol_size (s
), 0);
6483 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6486 else if (item
== error_mark_node
)
6487 length
= error_mark_node
;
6488 else /* FFEINFO_kindFUNCTION: */
6493 case FFEBLD_opARRAYREF
:
6494 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
6497 case FFEBLD_opSUBSTR
:
6501 ffebld thing
= ffebld_right (expr
);
6505 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
6506 start
= ffebld_head (thing
);
6507 thing
= ffebld_trail (thing
);
6508 assert (ffebld_trail (thing
) == NULL
);
6509 end
= ffebld_head (thing
);
6511 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
6513 if (length
== error_mark_node
)
6522 length
= convert (ffecom_f2c_ftnlen_type_node
,
6528 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
6529 ffecom_expr (start
));
6531 if (start_tree
== error_mark_node
)
6533 length
= error_mark_node
;
6539 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6540 ffecom_f2c_ftnlen_one_node
,
6541 ffecom_2 (MINUS_EXPR
,
6542 ffecom_f2c_ftnlen_type_node
,
6548 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
6551 if (end_tree
== error_mark_node
)
6553 length
= error_mark_node
;
6557 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6558 ffecom_f2c_ftnlen_one_node
,
6559 ffecom_2 (MINUS_EXPR
,
6560 ffecom_f2c_ftnlen_type_node
,
6561 end_tree
, start_tree
));
6567 case FFEBLD_opCONCATENATE
:
6569 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6570 ffecom_intrinsic_len_ (ffebld_left (expr
)),
6571 ffecom_intrinsic_len_ (ffebld_right (expr
)));
6574 case FFEBLD_opFUNCREF
:
6575 case FFEBLD_opCONVERT
:
6576 length
= build_int_2 (ffebld_size (expr
), 0);
6577 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6581 assert ("bad op for single char arg expr" == NULL
);
6582 length
= ffecom_f2c_ftnlen_zero_node
;
6586 assert (length
!= NULL_TREE
);
6591 /* Handle CHARACTER assignments.
6593 Generates code to do the assignment. Used by ordinary assignment
6594 statement handler ffecom_let_stmt and by statement-function
6595 handler to generate code for a statement function. */
6598 ffecom_let_char_ (tree dest_tree
, tree dest_length
,
6599 ffetargetCharacterSize dest_size
, ffebld source
)
6601 ffecomConcatList_ catlist
;
6606 if ((dest_tree
== error_mark_node
)
6607 || (dest_length
== error_mark_node
))
6610 assert (dest_tree
!= NULL_TREE
);
6611 assert (dest_length
!= NULL_TREE
);
6613 /* Source might be an opCONVERT, which just means it is a different size
6614 than the destination. Since the underlying implementation here handles
6615 that (directly or via the s_copy or s_cat run-time-library functions),
6616 we don't need the "convenience" of an opCONVERT that tells us to
6617 truncate or blank-pad, particularly since the resulting implementation
6618 would probably be slower than otherwise. */
6620 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
6621 source
= ffebld_left (source
);
6623 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
6624 switch (ffecom_concat_list_count_ (catlist
))
6626 case 0: /* Shouldn't happen, but in case it does... */
6627 ffecom_concat_list_kill_ (catlist
);
6628 source_tree
= null_pointer_node
;
6629 source_length
= ffecom_f2c_ftnlen_zero_node
;
6630 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6631 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
6632 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6633 = build_tree_list (NULL_TREE
, dest_length
);
6634 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6635 = build_tree_list (NULL_TREE
, source_length
);
6637 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
, NULL_TREE
);
6638 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6640 expand_expr_stmt (expr_tree
);
6644 case 1: /* The (fairly) easy case. */
6645 ffecom_char_args_ (&source_tree
, &source_length
,
6646 ffecom_concat_list_expr_ (catlist
, 0));
6647 ffecom_concat_list_kill_ (catlist
);
6648 assert (source_tree
!= NULL_TREE
);
6649 assert (source_length
!= NULL_TREE
);
6651 if ((source_tree
== error_mark_node
)
6652 || (source_length
== error_mark_node
))
6658 = ffecom_1 (INDIRECT_REF
,
6659 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6663 = ffecom_2 (ARRAY_REF
,
6664 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6669 = ffecom_1 (INDIRECT_REF
,
6670 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6674 = ffecom_2 (ARRAY_REF
,
6675 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6680 expr_tree
= ffecom_modify (void_type_node
, dest_tree
, source_tree
);
6682 expand_expr_stmt (expr_tree
);
6687 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6688 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
6689 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6690 = build_tree_list (NULL_TREE
, dest_length
);
6691 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6692 = build_tree_list (NULL_TREE
, source_length
);
6694 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
, NULL_TREE
);
6695 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6697 expand_expr_stmt (expr_tree
);
6701 default: /* Must actually concatenate things. */
6705 /* Heavy-duty concatenation. */
6708 int count
= ffecom_concat_list_count_ (catlist
);
6720 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
6721 FFETARGET_charactersizeNONE
, count
, TRUE
);
6722 item_array
= items
= ffecom_push_tempvar (ffecom_f2c_address_type_node
,
6723 FFETARGET_charactersizeNONE
,
6729 hook
= ffebld_nonter_hook (source
);
6731 assert (TREE_CODE (hook
) == TREE_VEC
);
6732 assert (TREE_VEC_LENGTH (hook
) == 2);
6733 length_array
= lengths
= TREE_VEC_ELT (hook
, 0);
6734 item_array
= items
= TREE_VEC_ELT (hook
, 1);
6738 for (i
= 0; i
< count
; ++i
)
6740 ffecom_char_args_ (&citem
, &clength
,
6741 ffecom_concat_list_expr_ (catlist
, i
));
6742 if ((citem
== error_mark_node
)
6743 || (clength
== error_mark_node
))
6745 ffecom_concat_list_kill_ (catlist
);
6750 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
6751 ffecom_modify (void_type_node
,
6752 ffecom_2 (ARRAY_REF
,
6753 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
6755 build_int_2 (i
, 0)),
6759 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
6760 ffecom_modify (void_type_node
,
6761 ffecom_2 (ARRAY_REF
,
6762 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
6764 build_int_2 (i
, 0)),
6769 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6770 TREE_CHAIN (expr_tree
)
6771 = build_tree_list (NULL_TREE
,
6772 ffecom_1 (ADDR_EXPR
,
6773 build_pointer_type (TREE_TYPE (items
)),
6775 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6776 = build_tree_list (NULL_TREE
,
6777 ffecom_1 (ADDR_EXPR
,
6778 build_pointer_type (TREE_TYPE (lengths
)),
6780 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6783 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
6784 convert (ffecom_f2c_ftnlen_type_node
,
6785 build_int_2 (count
, 0))));
6786 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
))))
6787 = build_tree_list (NULL_TREE
, dest_length
);
6789 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCAT
, expr_tree
, NULL_TREE
);
6790 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6792 expand_expr_stmt (expr_tree
);
6795 ffecom_concat_list_kill_ (catlist
);
6798 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6801 ffecom_make_gfrt_(ix);
6803 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6804 for the indicated run-time routine (ix). */
6807 ffecom_make_gfrt_ (ffecomGfrt ix
)
6812 switch (ffecom_gfrt_type_
[ix
])
6814 case FFECOM_rttypeVOID_
:
6815 ttype
= void_type_node
;
6818 case FFECOM_rttypeVOIDSTAR_
:
6819 ttype
= TREE_TYPE (null_pointer_node
); /* `void *'. */
6822 case FFECOM_rttypeFTNINT_
:
6823 ttype
= ffecom_f2c_ftnint_type_node
;
6826 case FFECOM_rttypeINTEGER_
:
6827 ttype
= ffecom_f2c_integer_type_node
;
6830 case FFECOM_rttypeLONGINT_
:
6831 ttype
= ffecom_f2c_longint_type_node
;
6834 case FFECOM_rttypeLOGICAL_
:
6835 ttype
= ffecom_f2c_logical_type_node
;
6838 case FFECOM_rttypeREAL_F2C_
:
6839 ttype
= double_type_node
;
6842 case FFECOM_rttypeREAL_GNU_
:
6843 ttype
= float_type_node
;
6846 case FFECOM_rttypeCOMPLEX_F2C_
:
6847 ttype
= void_type_node
;
6850 case FFECOM_rttypeCOMPLEX_GNU_
:
6851 ttype
= ffecom_f2c_complex_type_node
;
6854 case FFECOM_rttypeDOUBLE_
:
6855 ttype
= double_type_node
;
6858 case FFECOM_rttypeDOUBLEREAL_
:
6859 ttype
= ffecom_f2c_doublereal_type_node
;
6862 case FFECOM_rttypeDBLCMPLX_F2C_
:
6863 ttype
= void_type_node
;
6866 case FFECOM_rttypeDBLCMPLX_GNU_
:
6867 ttype
= ffecom_f2c_doublecomplex_type_node
;
6870 case FFECOM_rttypeCHARACTER_
:
6871 ttype
= void_type_node
;
6876 assert ("bad rttype" == NULL
);
6880 ttype
= build_function_type (ttype
, NULL_TREE
);
6881 t
= build_decl (FUNCTION_DECL
,
6882 get_identifier (ffecom_gfrt_name_
[ix
]),
6884 DECL_EXTERNAL (t
) = 1;
6885 TREE_READONLY (t
) = ffecom_gfrt_const_
[ix
] ? 1 : 0;
6886 TREE_PUBLIC (t
) = 1;
6887 TREE_THIS_VOLATILE (t
) = ffecom_gfrt_volatile_
[ix
] ? 1 : 0;
6889 /* Sanity check: A function that's const cannot be volatile. */
6891 assert (ffecom_gfrt_const_
[ix
] ? !ffecom_gfrt_volatile_
[ix
] : 1);
6893 /* Sanity check: A function that's const cannot return complex. */
6895 assert (ffecom_gfrt_const_
[ix
] ? !ffecom_gfrt_complex_
[ix
] : 1);
6897 t
= start_decl (t
, TRUE
);
6899 finish_decl (t
, NULL_TREE
, TRUE
);
6901 ffecom_gfrt_
[ix
] = t
;
6904 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
6907 ffecom_member_phase1_ (ffestorag mst UNUSED
, ffestorag st
)
6909 ffesymbol s
= ffestorag_symbol (st
);
6911 if (ffesymbol_namelisted (s
))
6912 ffecom_member_namelisted_
= TRUE
;
6915 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
6916 the member so debugger will see it. Otherwise nobody should be
6917 referencing the member. */
6920 ffecom_member_phase2_ (ffestorag mst
, ffestorag st
)
6928 || ((mt
= ffestorag_hook (mst
)) == NULL
)
6929 || (mt
== error_mark_node
))
6933 || ((s
= ffestorag_symbol (st
)) == NULL
))
6936 type
= ffecom_type_localvar_ (s
,
6937 ffesymbol_basictype (s
),
6938 ffesymbol_kindtype (s
));
6939 if (type
== error_mark_node
)
6942 t
= build_decl (VAR_DECL
,
6943 ffecom_get_identifier_ (ffesymbol_text (s
)),
6946 TREE_STATIC (t
) = TREE_STATIC (mt
);
6947 DECL_INITIAL (t
) = NULL_TREE
;
6948 TREE_ASM_WRITTEN (t
) = 1;
6952 gen_rtx (MEM
, TYPE_MODE (type
),
6953 plus_constant (XEXP (DECL_RTL (mt
), 0),
6954 ffestorag_modulo (mst
)
6955 + ffestorag_offset (st
)
6956 - ffestorag_offset (mst
))));
6958 t
= start_decl (t
, FALSE
);
6960 finish_decl (t
, NULL_TREE
, FALSE
);
6963 /* Prepare source expression for assignment into a destination perhaps known
6964 to be of a specific size. */
6967 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size
, ffebld source
)
6969 ffecomConcatList_ catlist
;
6974 tree tempvar
= NULL_TREE
;
6976 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
6977 source
= ffebld_left (source
);
6979 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
6980 count
= ffecom_concat_list_count_ (catlist
);
6985 = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node
,
6986 FFETARGET_charactersizeNONE
, count
);
6988 = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node
,
6989 FFETARGET_charactersizeNONE
, count
);
6991 tempvar
= make_tree_vec (2);
6992 TREE_VEC_ELT (tempvar
, 0) = ltmp
;
6993 TREE_VEC_ELT (tempvar
, 1) = itmp
;
6996 for (i
= 0; i
< count
; ++i
)
6997 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist
, i
));
6999 ffecom_concat_list_kill_ (catlist
);
7003 ffebld_nonter_set_hook (source
, tempvar
);
7004 current_binding_level
->prep_state
= 1;
7008 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7010 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
7011 (which generates their trees) and then their trees get push_parm_decl'd.
7013 The second arg is TRUE if the dummies are for a statement function, in
7014 which case lengths are not pushed for character arguments (since they are
7015 always known by both the caller and the callee, though the code allows
7016 for someday permitting CHAR*(*) stmtfunc dummies). */
7019 ffecom_push_dummy_decls_ (ffebld dummy_list
, bool stmtfunc
)
7026 ffecom_transform_only_dummies_
= TRUE
;
7028 /* First push the parms corresponding to actual dummy "contents". */
7030 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7032 dummy
= ffebld_head (dumlist
);
7033 switch (ffebld_op (dummy
))
7037 continue; /* Forget alternate returns. */
7042 assert (ffebld_op (dummy
) == FFEBLD_opSYMTER
);
7043 s
= ffebld_symter (dummy
);
7044 parm
= ffesymbol_hook (s
).decl_tree
;
7045 if (parm
== NULL_TREE
)
7047 s
= ffecom_sym_transform_ (s
);
7048 parm
= ffesymbol_hook (s
).decl_tree
;
7049 assert (parm
!= NULL_TREE
);
7051 if (parm
!= error_mark_node
)
7052 push_parm_decl (parm
);
7055 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7057 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7059 dummy
= ffebld_head (dumlist
);
7060 switch (ffebld_op (dummy
))
7064 continue; /* Forget alternate returns, they mean
7070 s
= ffebld_symter (dummy
);
7071 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
7072 continue; /* Only looking for CHARACTER arguments. */
7073 if (stmtfunc
&& (ffesymbol_size (s
) != FFETARGET_charactersizeNONE
))
7074 continue; /* Stmtfunc arg with known size needs no
7076 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
7077 continue; /* Only looking for variables and arrays. */
7078 parm
= ffesymbol_hook (s
).length_tree
;
7079 assert (parm
!= NULL_TREE
);
7080 if (parm
!= error_mark_node
)
7081 push_parm_decl (parm
);
7084 ffecom_transform_only_dummies_
= FALSE
;
7087 /* ffecom_start_progunit_ -- Beginning of program unit
7089 Does GNU back end stuff necessary to teach it about the start of its
7090 equivalent of a Fortran program unit. */
7093 ffecom_start_progunit_ ()
7095 ffesymbol fn
= ffecom_primary_entry_
;
7097 tree id
; /* Identifier (name) of function. */
7098 tree type
; /* Type of function. */
7099 tree result
; /* Result of function. */
7100 ffeinfoBasictype bt
;
7104 ffeglobalType egt
= FFEGLOBAL_type
;
7107 bool altentries
= (ffecom_num_entrypoints_
!= 0);
7110 && (ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
7111 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
7112 bool main_program
= FALSE
;
7113 int old_lineno
= lineno
;
7114 const char *old_input_filename
= input_filename
;
7116 assert (fn
!= NULL
);
7117 assert (ffesymbol_hook (fn
).decl_tree
== NULL_TREE
);
7119 input_filename
= ffesymbol_where_filename (fn
);
7120 lineno
= ffesymbol_where_filelinenum (fn
);
7122 switch (ffecom_primary_entry_kind_
)
7124 case FFEINFO_kindPROGRAM
:
7125 main_program
= TRUE
;
7126 gt
= FFEGLOBAL_typeMAIN
;
7127 bt
= FFEINFO_basictypeNONE
;
7128 kt
= FFEINFO_kindtypeNONE
;
7129 type
= ffecom_tree_fun_type_void
;
7134 case FFEINFO_kindBLOCKDATA
:
7135 gt
= FFEGLOBAL_typeBDATA
;
7136 bt
= FFEINFO_basictypeNONE
;
7137 kt
= FFEINFO_kindtypeNONE
;
7138 type
= ffecom_tree_fun_type_void
;
7143 case FFEINFO_kindFUNCTION
:
7144 gt
= FFEGLOBAL_typeFUNC
;
7145 egt
= FFEGLOBAL_typeEXT
;
7146 bt
= ffesymbol_basictype (fn
);
7147 kt
= ffesymbol_kindtype (fn
);
7148 if (bt
== FFEINFO_basictypeNONE
)
7150 ffeimplic_establish_symbol (fn
);
7151 if (ffesymbol_funcresult (fn
) != NULL
)
7152 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
7153 bt
= ffesymbol_basictype (fn
);
7154 kt
= ffesymbol_kindtype (fn
);
7158 charfunc
= cmplxfunc
= FALSE
;
7159 else if (bt
== FFEINFO_basictypeCHARACTER
)
7160 charfunc
= TRUE
, cmplxfunc
= FALSE
;
7161 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
7162 && ffesymbol_is_f2c (fn
)
7164 charfunc
= FALSE
, cmplxfunc
= TRUE
;
7166 charfunc
= cmplxfunc
= FALSE
;
7168 if (multi
|| charfunc
)
7169 type
= ffecom_tree_fun_type_void
;
7170 else if (ffesymbol_is_f2c (fn
) && !altentries
)
7171 type
= ffecom_tree_fun_type
[bt
][kt
];
7173 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
7175 if ((type
== NULL_TREE
)
7176 || (TREE_TYPE (type
) == NULL_TREE
))
7177 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
7180 case FFEINFO_kindSUBROUTINE
:
7181 gt
= FFEGLOBAL_typeSUBR
;
7182 egt
= FFEGLOBAL_typeEXT
;
7183 bt
= FFEINFO_basictypeNONE
;
7184 kt
= FFEINFO_kindtypeNONE
;
7185 if (ffecom_is_altreturning_
)
7186 type
= ffecom_tree_subr_type
;
7188 type
= ffecom_tree_fun_type_void
;
7194 assert ("say what??" == NULL
);
7196 case FFEINFO_kindANY
:
7197 gt
= FFEGLOBAL_typeANY
;
7198 bt
= FFEINFO_basictypeNONE
;
7199 kt
= FFEINFO_kindtypeNONE
;
7200 type
= error_mark_node
;
7208 id
= ffecom_get_invented_identifier ("__g77_masterfun_%s",
7209 ffesymbol_text (fn
));
7211 #if FFETARGET_isENFORCED_MAIN
7212 else if (main_program
)
7213 id
= get_identifier (FFETARGET_nameENFORCED_MAIN_NAME
);
7216 id
= ffecom_get_external_identifier_ (fn
);
7220 0, /* nested/inline */
7221 !altentries
); /* TREE_PUBLIC */
7223 TREE_USED (current_function_decl
) = 1; /* Avoid spurious warning if altentries. */
7226 && ((g
= ffesymbol_global (fn
)) != NULL
)
7227 && ((ffeglobal_type (g
) == gt
)
7228 || (ffeglobal_type (g
) == egt
)))
7230 ffeglobal_set_hook (g
, current_function_decl
);
7233 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7234 exec-transitioning needs current_function_decl to be filled in. So we
7235 do these things in two phases. */
7238 { /* 1st arg identifies which entrypoint. */
7239 ffecom_which_entrypoint_decl_
7240 = build_decl (PARM_DECL
,
7241 ffecom_get_invented_identifier ("__g77_%s",
7242 "which_entrypoint"),
7244 push_parm_decl (ffecom_which_entrypoint_decl_
);
7250 { /* Arg for result (return value). */
7255 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
7257 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
7259 type
= ffecom_multi_type_node_
;
7261 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
7263 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7266 length
= ffecom_char_enhance_arg_ (&type
, fn
);
7268 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
7270 type
= build_pointer_type (type
);
7271 result
= build_decl (PARM_DECL
, result
, type
);
7273 push_parm_decl (result
);
7275 ffecom_multi_retval_
= result
;
7277 ffecom_func_result_
= result
;
7281 push_parm_decl (length
);
7282 ffecom_func_length_
= length
;
7286 if (ffecom_primary_entry_is_proc_
)
7289 arglist
= ffecom_master_arglist_
;
7291 arglist
= ffesymbol_dummyargs (fn
);
7292 ffecom_push_dummy_decls_ (arglist
, FALSE
);
7295 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
7296 store_parm_decls (main_program
? 1 : 0);
7298 ffecom_start_compstmt ();
7299 /* Disallow temp vars at this level. */
7300 current_binding_level
->prep_state
= 2;
7302 lineno
= old_lineno
;
7303 input_filename
= old_input_filename
;
7305 /* This handles any symbols still untransformed, in case -g specified.
7306 This used to be done in ffecom_finish_progunit, but it turns out to
7307 be necessary to do it here so that statement functions are
7308 expanded before code. But don't bother for BLOCK DATA. */
7310 if (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
7311 ffesymbol_drive (ffecom_finish_symbol_transform_
);
7314 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7317 ffecom_sym_transform_(s);
7319 The ffesymbol_hook info for s is updated with appropriate backend info
7323 ffecom_sym_transform_ (ffesymbol s
)
7325 tree t
; /* Transformed thingy. */
7326 tree tlen
; /* Length if CHAR*(*). */
7327 bool addr
; /* Is t the address of the thingy? */
7328 ffeinfoBasictype bt
;
7331 int old_lineno
= lineno
;
7332 const char *old_input_filename
= input_filename
;
7334 /* Must ensure special ASSIGN variables are declared at top of outermost
7335 block, else they'll end up in the innermost block when their first
7336 ASSIGN is seen, which leaves them out of scope when they're the
7337 subject of a GOTO or I/O statement.
7339 We make this variable even if -fugly-assign. Just let it go unused,
7340 in case it turns out there are cases where we really want to use this
7341 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7343 if (! ffecom_transform_only_dummies_
7344 && ffesymbol_assigned (s
)
7345 && ! ffesymbol_hook (s
).assign_tree
)
7346 s
= ffecom_sym_transform_assign_ (s
);
7348 if (ffesymbol_sfdummyparent (s
) == NULL
)
7350 input_filename
= ffesymbol_where_filename (s
);
7351 lineno
= ffesymbol_where_filelinenum (s
);
7355 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
7357 input_filename
= ffesymbol_where_filename (sf
);
7358 lineno
= ffesymbol_where_filelinenum (sf
);
7361 bt
= ffeinfo_basictype (ffebld_info (s
));
7362 kt
= ffeinfo_kindtype (ffebld_info (s
));
7368 switch (ffesymbol_kind (s
))
7370 case FFEINFO_kindNONE
:
7371 switch (ffesymbol_where (s
))
7373 case FFEINFO_whereDUMMY
: /* Subroutine or function. */
7374 assert (ffecom_transform_only_dummies_
);
7376 /* Before 0.4, this could be ENTITY/DUMMY, but see
7377 ffestu_sym_end_transition -- no longer true (in particular, if
7378 it could be an ENTITY, it _will_ be made one, so that
7379 possibility won't come through here). So we never make length
7380 arg for CHARACTER type. */
7382 t
= build_decl (PARM_DECL
,
7383 ffecom_get_identifier_ (ffesymbol_text (s
)),
7384 ffecom_tree_ptr_to_subr_type
);
7385 DECL_ARTIFICIAL (t
) = 1;
7389 case FFEINFO_whereGLOBAL
: /* Subroutine or function. */
7390 assert (!ffecom_transform_only_dummies_
);
7392 if (((g
= ffesymbol_global (s
)) != NULL
)
7393 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
7394 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7395 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
7396 && (ffeglobal_hook (g
) != NULL_TREE
)
7397 && ffe_is_globals ())
7399 t
= ffeglobal_hook (g
);
7403 t
= build_decl (FUNCTION_DECL
,
7404 ffecom_get_external_identifier_ (s
),
7405 ffecom_tree_subr_type
); /* Assume subr. */
7406 DECL_EXTERNAL (t
) = 1;
7407 TREE_PUBLIC (t
) = 1;
7409 t
= start_decl (t
, FALSE
);
7410 finish_decl (t
, NULL_TREE
, FALSE
);
7413 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
7414 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7415 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
7416 ffeglobal_set_hook (g
, t
);
7418 ffecom_save_tree_forever (t
);
7423 assert ("NONE where unexpected" == NULL
);
7425 case FFEINFO_whereANY
:
7430 case FFEINFO_kindENTITY
:
7431 switch (ffeinfo_where (ffesymbol_info (s
)))
7434 case FFEINFO_whereCONSTANT
:
7435 /* ~~Debugging info needed? */
7436 assert (!ffecom_transform_only_dummies_
);
7437 t
= error_mark_node
; /* Shouldn't ever see this in expr. */
7440 case FFEINFO_whereLOCAL
:
7441 assert (!ffecom_transform_only_dummies_
);
7444 ffestorag st
= ffesymbol_storage (s
);
7448 && (ffestorag_size (st
) == 0))
7450 t
= error_mark_node
;
7454 type
= ffecom_type_localvar_ (s
, bt
, kt
);
7456 if (type
== error_mark_node
)
7458 t
= error_mark_node
;
7463 && (ffestorag_parent (st
) != NULL
))
7464 { /* Child of EQUIVALENCE parent. */
7467 ffetargetOffset offset
;
7469 est
= ffestorag_parent (st
);
7470 ffecom_transform_equiv_ (est
);
7472 et
= ffestorag_hook (est
);
7473 assert (et
!= NULL_TREE
);
7475 if (! TREE_STATIC (et
))
7476 put_var_into_stack (et
);
7478 offset
= ffestorag_modulo (est
)
7479 + ffestorag_offset (ffesymbol_storage (s
))
7480 - ffestorag_offset (est
);
7482 ffecom_debug_kludge_ (et
, "EQUIVALENCE", s
, type
, offset
);
7484 /* (t_type *) (((char *) &et) + offset) */
7486 t
= convert (string_type_node
, /* (char *) */
7487 ffecom_1 (ADDR_EXPR
,
7488 build_pointer_type (TREE_TYPE (et
)),
7490 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
7492 build_int_2 (offset
, 0));
7493 t
= convert (build_pointer_type (type
),
7495 TREE_CONSTANT (t
) = staticp (et
);
7502 bool init
= ffesymbol_is_init (s
);
7504 t
= build_decl (VAR_DECL
,
7505 ffecom_get_identifier_ (ffesymbol_text (s
)),
7509 || ffesymbol_namelisted (s
)
7510 #ifdef FFECOM_sizeMAXSTACKITEM
7512 && (ffestorag_size (st
) > FFECOM_sizeMAXSTACKITEM
))
7514 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
7515 && (ffecom_primary_entry_kind_
7516 != FFEINFO_kindBLOCKDATA
)
7517 && (ffesymbol_is_save (s
) || ffe_is_saveall ())))
7518 TREE_STATIC (t
) = !ffesymbol_attr (s
, FFESYMBOL_attrADJUSTABLE
);
7520 TREE_STATIC (t
) = 0; /* No need to make static. */
7522 if (init
|| ffe_is_init_local_zero ())
7523 DECL_INITIAL (t
) = error_mark_node
;
7525 /* Keep -Wunused from complaining about var if it
7526 is used as sfunc arg or DATA implied-DO. */
7527 if (ffesymbol_attrs (s
) & FFESYMBOL_attrsSFARG
)
7528 DECL_IN_SYSTEM_HEADER (t
) = 1;
7530 t
= start_decl (t
, FALSE
);
7534 if (ffesymbol_init (s
) != NULL
)
7535 initexpr
= ffecom_expr (ffesymbol_init (s
));
7537 initexpr
= ffecom_init_zero_ (t
);
7539 else if (ffe_is_init_local_zero ())
7540 initexpr
= ffecom_init_zero_ (t
);
7542 initexpr
= NULL_TREE
; /* Not ref'd if !init. */
7544 finish_decl (t
, initexpr
, FALSE
);
7546 if (st
!= NULL
&& DECL_SIZE (t
) != error_mark_node
)
7548 assert (TREE_CODE (DECL_SIZE_UNIT (t
)) == INTEGER_CST
);
7549 assert (0 == compare_tree_int (DECL_SIZE_UNIT (t
),
7550 ffestorag_size (st
)));
7556 case FFEINFO_whereRESULT
:
7557 assert (!ffecom_transform_only_dummies_
);
7559 if (bt
== FFEINFO_basictypeCHARACTER
)
7560 { /* Result is already in list of dummies, use
7562 t
= ffecom_func_result_
;
7563 tlen
= ffecom_func_length_
;
7567 if ((ffecom_num_entrypoints_
== 0)
7568 && (bt
== FFEINFO_basictypeCOMPLEX
)
7569 && (ffesymbol_is_f2c (ffecom_primary_entry_
)))
7570 { /* Result is already in list of dummies, use
7572 t
= ffecom_func_result_
;
7576 if (ffecom_func_result_
!= NULL_TREE
)
7578 t
= ffecom_func_result_
;
7581 if ((ffecom_num_entrypoints_
!= 0)
7582 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
))
7584 assert (ffecom_multi_retval_
!= NULL_TREE
);
7585 t
= ffecom_1 (INDIRECT_REF
, ffecom_multi_type_node_
,
7586 ffecom_multi_retval_
);
7587 t
= ffecom_2 (COMPONENT_REF
, ffecom_tree_type
[bt
][kt
],
7588 t
, ffecom_multi_fields_
[bt
][kt
]);
7593 t
= build_decl (VAR_DECL
,
7594 ffecom_get_identifier_ (ffesymbol_text (s
)),
7595 ffecom_tree_type
[bt
][kt
]);
7596 TREE_STATIC (t
) = 0; /* Put result on stack. */
7597 t
= start_decl (t
, FALSE
);
7598 finish_decl (t
, NULL_TREE
, FALSE
);
7600 ffecom_func_result_
= t
;
7604 case FFEINFO_whereDUMMY
:
7612 bool adjustable
= FALSE
; /* Conditionally adjustable? */
7614 type
= ffecom_tree_type
[bt
][kt
];
7615 if (ffesymbol_sfdummyparent (s
) != NULL
)
7617 if (current_function_decl
== ffecom_outer_function_decl_
)
7618 { /* Exec transition before sfunc
7619 context; get it later. */
7622 t
= ffecom_get_identifier_ (ffesymbol_text
7623 (ffesymbol_sfdummyparent (s
)));
7626 t
= ffecom_get_identifier_ (ffesymbol_text (s
));
7628 assert (ffecom_transform_only_dummies_
);
7630 old_sizes
= get_pending_sizes ();
7631 put_pending_sizes (old_sizes
);
7633 if (bt
== FFEINFO_basictypeCHARACTER
)
7634 tlen
= ffecom_char_enhance_arg_ (&type
, s
);
7635 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
7637 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
7639 if (type
== error_mark_node
)
7642 dim
= ffebld_head (dl
);
7643 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
7644 if ((ffebld_left (dim
) == NULL
) || ffecom_doing_entry_
)
7645 low
= ffecom_integer_one_node
;
7647 low
= ffecom_expr (ffebld_left (dim
));
7648 assert (ffebld_right (dim
) != NULL
);
7649 if ((ffebld_op (ffebld_right (dim
)) == FFEBLD_opSTAR
)
7650 || ffecom_doing_entry_
)
7652 /* Used to just do high=low. But for ffecom_tree_
7653 canonize_ref_, it probably is important to correctly
7654 assess the size. E.g. given COMPLEX C(*),CFUNC and
7655 C(2)=CFUNC(C), overlap can happen, while it can't
7656 for, say, C(1)=CFUNC(C(2)). */
7657 /* Even more recently used to set to INT_MAX, but that
7658 broke when some overflow checking went into the back
7659 end. Now we just leave the upper bound unspecified. */
7663 high
= ffecom_expr (ffebld_right (dim
));
7665 /* Determine whether array is conditionally adjustable,
7666 to decide whether back-end magic is needed.
7668 Normally the front end uses the back-end function
7669 variable_size to wrap SAVE_EXPR's around expressions
7670 affecting the size/shape of an array so that the
7671 size/shape info doesn't change during execution
7672 of the compiled code even though variables and
7673 functions referenced in those expressions might.
7675 variable_size also makes sure those saved expressions
7676 get evaluated immediately upon entry to the
7677 compiled procedure -- the front end normally doesn't
7678 have to worry about that.
7680 However, there is a problem with this that affects
7681 g77's implementation of entry points, and that is
7682 that it is _not_ true that each invocation of the
7683 compiled procedure is permitted to evaluate
7684 array size/shape info -- because it is possible
7685 that, for some invocations, that info is invalid (in
7686 which case it is "promised" -- i.e. a violation of
7687 the Fortran standard -- that the compiled code
7688 won't reference the array or its size/shape
7689 during that particular invocation).
7691 To phrase this in C terms, consider this gcc function:
7693 void foo (int *n, float (*a)[*n])
7695 // a is "pointer to array ...", fyi.
7698 Suppose that, for some invocations, it is permitted
7699 for a caller of foo to do this:
7703 Now the _written_ code for foo can take such a call
7704 into account by either testing explicitly for whether
7705 (a == NULL) || (n == NULL) -- presumably it is
7706 not permitted to reference *a in various fashions
7707 if (n == NULL) I suppose -- or it can avoid it by
7708 looking at other info (other arguments, static/global
7711 However, this won't work in gcc 2.5.8 because it'll
7712 automatically emit the code to save the "*n"
7713 expression, which'll yield a NULL dereference for
7714 the "foo (NULL, NULL)" call, something the code
7715 for foo cannot prevent.
7717 g77 definitely needs to avoid executing such
7718 code anytime the pointer to the adjustable array
7719 is NULL, because even if its bounds expressions
7720 don't have any references to possible "absent"
7721 variables like "*n" -- say all variable references
7722 are to COMMON variables, i.e. global (though in C,
7723 local static could actually make sense) -- the
7724 expressions could yield other run-time problems
7725 for allowably "dead" values in those variables.
7727 For example, let's consider a more complicated
7733 void foo (float (*a)[i/j])
7738 The above is (essentially) quite valid for Fortran
7739 but, again, for a call like "foo (NULL);", it is
7740 permitted for i and j to be undefined when the
7741 call is made. If j happened to be zero, for
7742 example, emitting the code to evaluate "i/j"
7743 could result in a run-time error.
7745 Offhand, though I don't have my F77 or F90
7746 standards handy, it might even be valid for a
7747 bounds expression to contain a function reference,
7748 in which case I doubt it is permitted for an
7749 implementation to invoke that function in the
7750 Fortran case involved here (invocation of an
7751 alternate ENTRY point that doesn't have the adjustable
7752 array as one of its arguments).
7754 So, the code that the compiler would normally emit
7755 to preevaluate the size/shape info for an
7756 adjustable array _must not_ be executed at run time
7757 in certain cases. Specifically, for Fortran,
7758 the case is when the pointer to the adjustable
7759 array == NULL. (For gnu-ish C, it might be nice
7760 for the source code itself to specify an expression
7761 that, if TRUE, inhibits execution of the code. Or
7762 reverse the sense for elegance.)
7764 (Note that g77 could use a different test than NULL,
7765 actually, since it happens to always pass an
7766 integer to the called function that specifies which
7767 entry point is being invoked. Hmm, this might
7768 solve the next problem.)
7770 One way a user could, I suppose, write "foo" so
7771 it works is to insert COND_EXPR's for the
7772 size/shape info so the dangerous stuff isn't
7773 actually done, as in:
7775 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7780 The next problem is that the front end needs to
7781 be able to tell the back end about the array's
7782 decl _before_ it tells it about the conditional
7783 expression to inhibit evaluation of size/shape info,
7786 To solve this, the front end needs to be able
7787 to give the back end the expression to inhibit
7788 generation of the preevaluation code _after_
7789 it makes the decl for the adjustable array.
7791 Until then, the above example using the COND_EXPR
7792 doesn't pass muster with gcc because the "(a == NULL)"
7793 part has a reference to "a", which is still
7794 undefined at that point.
7796 g77 will therefore use a different mechanism in the
7800 && ((TREE_CODE (low
) != INTEGER_CST
)
7801 || (high
&& TREE_CODE (high
) != INTEGER_CST
)))
7804 #if 0 /* Old approach -- see below. */
7805 if (TREE_CODE (low
) != INTEGER_CST
)
7806 low
= ffecom_3 (COND_EXPR
, integer_type_node
,
7807 ffecom_adjarray_passed_ (s
),
7809 ffecom_integer_zero_node
);
7811 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
7812 high
= ffecom_3 (COND_EXPR
, integer_type_node
,
7813 ffecom_adjarray_passed_ (s
),
7815 ffecom_integer_zero_node
);
7818 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7819 probably. Fixes 950302-1.f. */
7821 if (TREE_CODE (low
) != INTEGER_CST
)
7822 low
= variable_size (low
);
7824 /* ~~~Similarly, this fixes dumb0.f. The C front end
7825 does this, which is why dumb0.c would work. */
7827 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
7828 high
= variable_size (high
);
7833 build_range_type (ffecom_integer_type_node
,
7835 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
7838 if (type
== error_mark_node
)
7840 t
= error_mark_node
;
7844 if ((ffesymbol_sfdummyparent (s
) == NULL
)
7845 || (ffesymbol_basictype (s
) == FFEINFO_basictypeCHARACTER
))
7847 type
= build_pointer_type (type
);
7851 t
= build_decl (PARM_DECL
, t
, type
);
7852 DECL_ARTIFICIAL (t
) = 1;
7854 /* If this arg is present in every entry point's list of
7855 dummy args, then we're done. */
7857 if (ffesymbol_numentries (s
)
7858 == (ffecom_num_entrypoints_
+ 1))
7863 /* If variable_size in stor-layout has been called during
7864 the above, then get_pending_sizes should have the
7865 yet-to-be-evaluated saved expressions pending.
7866 Make the whole lot of them get emitted, conditionally
7867 on whether the array decl ("t" above) is not NULL. */
7870 tree sizes
= get_pending_sizes ();
7875 tem
= TREE_CHAIN (tem
))
7877 tree temv
= TREE_VALUE (tem
);
7883 = ffecom_2 (COMPOUND_EXPR
,
7892 = ffecom_3 (COND_EXPR
,
7899 convert (TREE_TYPE (sizes
),
7900 integer_zero_node
));
7901 sizes
= ffecom_save_tree (sizes
);
7904 = tree_cons (NULL_TREE
, sizes
, tem
);
7908 put_pending_sizes (sizes
);
7914 && (ffesymbol_numentries (s
)
7915 != ffecom_num_entrypoints_
+ 1))
7917 = ffecom_2 (NE_EXPR
, integer_type_node
,
7923 && (ffesymbol_numentries (s
)
7924 != ffecom_num_entrypoints_
+ 1))
7926 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED
);
7927 ffebad_here (0, ffesymbol_where_line (s
),
7928 ffesymbol_where_column (s
));
7929 ffebad_string (ffesymbol_text (s
));
7938 case FFEINFO_whereCOMMON
:
7943 ffestorag st
= ffesymbol_storage (s
);
7946 cs
= ffesymbol_common (s
); /* The COMMON area itself. */
7947 if (st
!= NULL
) /* Else not laid out. */
7949 ffecom_transform_common_ (cs
);
7950 st
= ffesymbol_storage (s
);
7953 type
= ffecom_type_localvar_ (s
, bt
, kt
);
7955 cg
= ffesymbol_global (cs
); /* The global COMMON info. */
7957 || (ffeglobal_type (cg
) != FFEGLOBAL_typeCOMMON
))
7960 ct
= ffeglobal_hook (cg
); /* The common area's tree. */
7962 if ((ct
== NULL_TREE
)
7964 || (type
== error_mark_node
))
7965 t
= error_mark_node
;
7968 ffetargetOffset offset
;
7971 cst
= ffestorag_parent (st
);
7972 assert (cst
== ffesymbol_storage (cs
));
7974 offset
= ffestorag_modulo (cst
)
7975 + ffestorag_offset (st
)
7976 - ffestorag_offset (cst
);
7978 ffecom_debug_kludge_ (ct
, "COMMON", s
, type
, offset
);
7980 /* (t_type *) (((char *) &ct) + offset) */
7982 t
= convert (string_type_node
, /* (char *) */
7983 ffecom_1 (ADDR_EXPR
,
7984 build_pointer_type (TREE_TYPE (ct
)),
7986 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
7988 build_int_2 (offset
, 0));
7989 t
= convert (build_pointer_type (type
),
7991 TREE_CONSTANT (t
) = 1;
7998 case FFEINFO_whereIMMEDIATE
:
7999 case FFEINFO_whereGLOBAL
:
8000 case FFEINFO_whereFLEETING
:
8001 case FFEINFO_whereFLEETING_CADDR
:
8002 case FFEINFO_whereFLEETING_IADDR
:
8003 case FFEINFO_whereINTRINSIC
:
8004 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8006 assert ("ENTITY where unheard of" == NULL
);
8008 case FFEINFO_whereANY
:
8009 t
= error_mark_node
;
8014 case FFEINFO_kindFUNCTION
:
8015 switch (ffeinfo_where (ffesymbol_info (s
)))
8017 case FFEINFO_whereLOCAL
: /* Me. */
8018 assert (!ffecom_transform_only_dummies_
);
8019 t
= current_function_decl
;
8022 case FFEINFO_whereGLOBAL
:
8023 assert (!ffecom_transform_only_dummies_
);
8025 if (((g
= ffesymbol_global (s
)) != NULL
)
8026 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8027 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8028 && (ffeglobal_hook (g
) != NULL_TREE
)
8029 && ffe_is_globals ())
8031 t
= ffeglobal_hook (g
);
8035 if (ffesymbol_is_f2c (s
)
8036 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8037 t
= ffecom_tree_fun_type
[bt
][kt
];
8039 t
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
8041 t
= build_decl (FUNCTION_DECL
,
8042 ffecom_get_external_identifier_ (s
),
8044 DECL_EXTERNAL (t
) = 1;
8045 TREE_PUBLIC (t
) = 1;
8047 t
= start_decl (t
, FALSE
);
8048 finish_decl (t
, NULL_TREE
, FALSE
);
8051 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8052 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8053 ffeglobal_set_hook (g
, t
);
8055 ffecom_save_tree_forever (t
);
8059 case FFEINFO_whereDUMMY
:
8060 assert (ffecom_transform_only_dummies_
);
8062 if (ffesymbol_is_f2c (s
)
8063 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8064 t
= ffecom_tree_ptr_to_fun_type
[bt
][kt
];
8066 t
= build_pointer_type
8067 (build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
));
8069 t
= build_decl (PARM_DECL
,
8070 ffecom_get_identifier_ (ffesymbol_text (s
)),
8072 DECL_ARTIFICIAL (t
) = 1;
8076 case FFEINFO_whereCONSTANT
: /* Statement function. */
8077 assert (!ffecom_transform_only_dummies_
);
8078 t
= ffecom_gen_sfuncdef_ (s
, bt
, kt
);
8081 case FFEINFO_whereINTRINSIC
:
8082 assert (!ffecom_transform_only_dummies_
);
8083 break; /* Let actual references generate their
8087 assert ("FUNCTION where unheard of" == NULL
);
8089 case FFEINFO_whereANY
:
8090 t
= error_mark_node
;
8095 case FFEINFO_kindSUBROUTINE
:
8096 switch (ffeinfo_where (ffesymbol_info (s
)))
8098 case FFEINFO_whereLOCAL
: /* Me. */
8099 assert (!ffecom_transform_only_dummies_
);
8100 t
= current_function_decl
;
8103 case FFEINFO_whereGLOBAL
:
8104 assert (!ffecom_transform_only_dummies_
);
8106 if (((g
= ffesymbol_global (s
)) != NULL
)
8107 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8108 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8109 && (ffeglobal_hook (g
) != NULL_TREE
)
8110 && ffe_is_globals ())
8112 t
= ffeglobal_hook (g
);
8116 t
= build_decl (FUNCTION_DECL
,
8117 ffecom_get_external_identifier_ (s
),
8118 ffecom_tree_subr_type
);
8119 DECL_EXTERNAL (t
) = 1;
8120 TREE_PUBLIC (t
) = 1;
8122 t
= start_decl (t
, FALSE
);
8123 finish_decl (t
, NULL_TREE
, FALSE
);
8126 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8127 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8128 ffeglobal_set_hook (g
, t
);
8130 ffecom_save_tree_forever (t
);
8134 case FFEINFO_whereDUMMY
:
8135 assert (ffecom_transform_only_dummies_
);
8137 t
= build_decl (PARM_DECL
,
8138 ffecom_get_identifier_ (ffesymbol_text (s
)),
8139 ffecom_tree_ptr_to_subr_type
);
8140 DECL_ARTIFICIAL (t
) = 1;
8144 case FFEINFO_whereINTRINSIC
:
8145 assert (!ffecom_transform_only_dummies_
);
8146 break; /* Let actual references generate their
8150 assert ("SUBROUTINE where unheard of" == NULL
);
8152 case FFEINFO_whereANY
:
8153 t
= error_mark_node
;
8158 case FFEINFO_kindPROGRAM
:
8159 switch (ffeinfo_where (ffesymbol_info (s
)))
8161 case FFEINFO_whereLOCAL
: /* Me. */
8162 assert (!ffecom_transform_only_dummies_
);
8163 t
= current_function_decl
;
8166 case FFEINFO_whereCOMMON
:
8167 case FFEINFO_whereDUMMY
:
8168 case FFEINFO_whereGLOBAL
:
8169 case FFEINFO_whereRESULT
:
8170 case FFEINFO_whereFLEETING
:
8171 case FFEINFO_whereFLEETING_CADDR
:
8172 case FFEINFO_whereFLEETING_IADDR
:
8173 case FFEINFO_whereIMMEDIATE
:
8174 case FFEINFO_whereINTRINSIC
:
8175 case FFEINFO_whereCONSTANT
:
8176 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8178 assert ("PROGRAM where unheard of" == NULL
);
8180 case FFEINFO_whereANY
:
8181 t
= error_mark_node
;
8186 case FFEINFO_kindBLOCKDATA
:
8187 switch (ffeinfo_where (ffesymbol_info (s
)))
8189 case FFEINFO_whereLOCAL
: /* Me. */
8190 assert (!ffecom_transform_only_dummies_
);
8191 t
= current_function_decl
;
8194 case FFEINFO_whereGLOBAL
:
8195 assert (!ffecom_transform_only_dummies_
);
8197 t
= build_decl (FUNCTION_DECL
,
8198 ffecom_get_external_identifier_ (s
),
8199 ffecom_tree_blockdata_type
);
8200 DECL_EXTERNAL (t
) = 1;
8201 TREE_PUBLIC (t
) = 1;
8203 t
= start_decl (t
, FALSE
);
8204 finish_decl (t
, NULL_TREE
, FALSE
);
8206 ffecom_save_tree_forever (t
);
8210 case FFEINFO_whereCOMMON
:
8211 case FFEINFO_whereDUMMY
:
8212 case FFEINFO_whereRESULT
:
8213 case FFEINFO_whereFLEETING
:
8214 case FFEINFO_whereFLEETING_CADDR
:
8215 case FFEINFO_whereFLEETING_IADDR
:
8216 case FFEINFO_whereIMMEDIATE
:
8217 case FFEINFO_whereINTRINSIC
:
8218 case FFEINFO_whereCONSTANT
:
8219 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8221 assert ("BLOCKDATA where unheard of" == NULL
);
8223 case FFEINFO_whereANY
:
8224 t
= error_mark_node
;
8229 case FFEINFO_kindCOMMON
:
8230 switch (ffeinfo_where (ffesymbol_info (s
)))
8232 case FFEINFO_whereLOCAL
:
8233 assert (!ffecom_transform_only_dummies_
);
8234 ffecom_transform_common_ (s
);
8237 case FFEINFO_whereNONE
:
8238 case FFEINFO_whereCOMMON
:
8239 case FFEINFO_whereDUMMY
:
8240 case FFEINFO_whereGLOBAL
:
8241 case FFEINFO_whereRESULT
:
8242 case FFEINFO_whereFLEETING
:
8243 case FFEINFO_whereFLEETING_CADDR
:
8244 case FFEINFO_whereFLEETING_IADDR
:
8245 case FFEINFO_whereIMMEDIATE
:
8246 case FFEINFO_whereINTRINSIC
:
8247 case FFEINFO_whereCONSTANT
:
8248 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8250 assert ("COMMON where unheard of" == NULL
);
8252 case FFEINFO_whereANY
:
8253 t
= error_mark_node
;
8258 case FFEINFO_kindCONSTRUCT
:
8259 switch (ffeinfo_where (ffesymbol_info (s
)))
8261 case FFEINFO_whereLOCAL
:
8262 assert (!ffecom_transform_only_dummies_
);
8265 case FFEINFO_whereNONE
:
8266 case FFEINFO_whereCOMMON
:
8267 case FFEINFO_whereDUMMY
:
8268 case FFEINFO_whereGLOBAL
:
8269 case FFEINFO_whereRESULT
:
8270 case FFEINFO_whereFLEETING
:
8271 case FFEINFO_whereFLEETING_CADDR
:
8272 case FFEINFO_whereFLEETING_IADDR
:
8273 case FFEINFO_whereIMMEDIATE
:
8274 case FFEINFO_whereINTRINSIC
:
8275 case FFEINFO_whereCONSTANT
:
8276 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8278 assert ("CONSTRUCT where unheard of" == NULL
);
8280 case FFEINFO_whereANY
:
8281 t
= error_mark_node
;
8286 case FFEINFO_kindNAMELIST
:
8287 switch (ffeinfo_where (ffesymbol_info (s
)))
8289 case FFEINFO_whereLOCAL
:
8290 assert (!ffecom_transform_only_dummies_
);
8291 t
= ffecom_transform_namelist_ (s
);
8294 case FFEINFO_whereNONE
:
8295 case FFEINFO_whereCOMMON
:
8296 case FFEINFO_whereDUMMY
:
8297 case FFEINFO_whereGLOBAL
:
8298 case FFEINFO_whereRESULT
:
8299 case FFEINFO_whereFLEETING
:
8300 case FFEINFO_whereFLEETING_CADDR
:
8301 case FFEINFO_whereFLEETING_IADDR
:
8302 case FFEINFO_whereIMMEDIATE
:
8303 case FFEINFO_whereINTRINSIC
:
8304 case FFEINFO_whereCONSTANT
:
8305 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8307 assert ("NAMELIST where unheard of" == NULL
);
8309 case FFEINFO_whereANY
:
8310 t
= error_mark_node
;
8316 assert ("kind unheard of" == NULL
);
8318 case FFEINFO_kindANY
:
8319 t
= error_mark_node
;
8323 ffesymbol_hook (s
).decl_tree
= t
;
8324 ffesymbol_hook (s
).length_tree
= tlen
;
8325 ffesymbol_hook (s
).addr
= addr
;
8327 lineno
= old_lineno
;
8328 input_filename
= old_input_filename
;
8333 /* Transform into ASSIGNable symbol.
8335 Symbol has already been transformed, but for whatever reason, the
8336 resulting decl_tree has been deemed not usable for an ASSIGN target.
8337 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8338 another local symbol of type void * and stuff that in the assign_tree
8339 argument. The F77/F90 standards allow this implementation. */
8342 ffecom_sym_transform_assign_ (ffesymbol s
)
8344 tree t
; /* Transformed thingy. */
8345 int old_lineno
= lineno
;
8346 const char *old_input_filename
= input_filename
;
8348 if (ffesymbol_sfdummyparent (s
) == NULL
)
8350 input_filename
= ffesymbol_where_filename (s
);
8351 lineno
= ffesymbol_where_filelinenum (s
);
8355 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
8357 input_filename
= ffesymbol_where_filename (sf
);
8358 lineno
= ffesymbol_where_filelinenum (sf
);
8361 assert (!ffecom_transform_only_dummies_
);
8363 t
= build_decl (VAR_DECL
,
8364 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8365 ffesymbol_text (s
)),
8366 TREE_TYPE (null_pointer_node
));
8368 switch (ffesymbol_where (s
))
8370 case FFEINFO_whereLOCAL
:
8371 /* Unlike for regular vars, SAVE status is easy to determine for
8372 ASSIGNed vars, since there's no initialization, there's no
8373 effective storage association (so "SAVE J" does not apply to
8374 K even given "EQUIVALENCE (J,K)"), there's no size issue
8375 to worry about, etc. */
8376 if ((ffesymbol_is_save (s
) || ffe_is_saveall ())
8377 && (ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8378 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
))
8379 TREE_STATIC (t
) = 1; /* SAVEd in proc, make static. */
8381 TREE_STATIC (t
) = 0; /* No need to make static. */
8384 case FFEINFO_whereCOMMON
:
8385 TREE_STATIC (t
) = 1; /* Assume COMMONs always SAVEd. */
8388 case FFEINFO_whereDUMMY
:
8389 /* Note that twinning a DUMMY means the caller won't see
8390 the ASSIGNed value. But both F77 and F90 allow implementations
8391 to do this, i.e. disallow Fortran code that would try and
8392 take advantage of actually putting a label into a variable
8393 via a dummy argument (or any other storage association, for
8395 TREE_STATIC (t
) = 0;
8399 TREE_STATIC (t
) = 0;
8403 t
= start_decl (t
, FALSE
);
8404 finish_decl (t
, NULL_TREE
, FALSE
);
8406 ffesymbol_hook (s
).assign_tree
= t
;
8408 lineno
= old_lineno
;
8409 input_filename
= old_input_filename
;
8414 /* Implement COMMON area in back end.
8416 Because COMMON-based variables can be referenced in the dimension
8417 expressions of dummy (adjustable) arrays, and because dummies
8418 (in the gcc back end) need to be put in the outer binding level
8419 of a function (which has two binding levels, the outer holding
8420 the dummies and the inner holding the other vars), special care
8421 must be taken to handle COMMON areas.
8423 The current strategy is basically to always tell the back end about
8424 the COMMON area as a top-level external reference to just a block
8425 of storage of the master type of that area (e.g. integer, real,
8426 character, whatever -- not a structure). As a distinct action,
8427 if initial values are provided, tell the back end about the area
8428 as a top-level non-external (initialized) area and remember not to
8429 allow further initialization or expansion of the area. Meanwhile,
8430 if no initialization happens at all, tell the back end about
8431 the largest size we've seen declared so the space does get reserved.
8432 (This function doesn't handle all that stuff, but it does some
8433 of the important things.)
8435 Meanwhile, for COMMON variables themselves, just keep creating
8436 references like *((float *) (&common_area + offset)) each time
8437 we reference the variable. In other words, don't make a VAR_DECL
8438 or any kind of component reference (like we used to do before 0.4),
8439 though we might do that as well just for debugging purposes (and
8440 stuff the rtl with the appropriate offset expression). */
8443 ffecom_transform_common_ (ffesymbol s
)
8445 ffestorag st
= ffesymbol_storage (s
);
8446 ffeglobal g
= ffesymbol_global (s
);
8451 bool is_init
= ffestorag_is_init (st
);
8453 assert (st
!= NULL
);
8456 || (ffeglobal_type (g
) != FFEGLOBAL_typeCOMMON
))
8459 /* First update the size of the area in global terms. */
8461 ffeglobal_size_common (s
, ffestorag_size (st
));
8463 if (!ffeglobal_common_init (g
))
8464 is_init
= FALSE
; /* No explicit init, don't let erroneous joins init. */
8466 cbt
= ffeglobal_hook (g
);
8468 /* If we already have declared this common block for a previous program
8469 unit, and either we already initialized it or we don't have new
8470 initialization for it, just return what we have without changing it. */
8472 if ((cbt
!= NULL_TREE
)
8474 || !DECL_EXTERNAL (cbt
)))
8476 if (st
->hook
== NULL
) ffestorag_set_hook (st
, cbt
);
8480 /* Process inits. */
8484 if (ffestorag_init (st
) != NULL
)
8488 /* Set the padding for the expression, so ffecom_expr
8489 knows to insert that many zeros. */
8490 switch (ffebld_op (sexp
= ffestorag_init (st
)))
8492 case FFEBLD_opCONTER
:
8493 ffebld_conter_set_pad (sexp
, ffestorag_modulo (st
));
8496 case FFEBLD_opARRTER
:
8497 ffebld_arrter_set_pad (sexp
, ffestorag_modulo (st
));
8500 case FFEBLD_opACCTER
:
8501 ffebld_accter_set_pad (sexp
, ffestorag_modulo (st
));
8505 assert ("bad op for cmn init (pad)" == NULL
);
8509 init
= ffecom_expr (sexp
);
8510 if (init
== error_mark_node
)
8511 { /* Hopefully the back end complained! */
8513 if (cbt
!= NULL_TREE
)
8518 init
= error_mark_node
;
8523 /* cbtype must be permanently allocated! */
8525 /* Allocate the MAX of the areas so far, seen filewide. */
8526 high
= build_int_2 ((ffeglobal_common_size (g
)
8527 + ffeglobal_common_pad (g
)) - 1, 0);
8528 TREE_TYPE (high
) = ffecom_integer_type_node
;
8531 cbtype
= build_array_type (char_type_node
,
8532 build_range_type (integer_type_node
,
8536 cbtype
= build_array_type (char_type_node
, NULL_TREE
);
8538 if (cbt
== NULL_TREE
)
8541 = build_decl (VAR_DECL
,
8542 ffecom_get_external_identifier_ (s
),
8544 TREE_STATIC (cbt
) = 1;
8545 TREE_PUBLIC (cbt
) = 1;
8550 TREE_TYPE (cbt
) = cbtype
;
8552 DECL_EXTERNAL (cbt
) = init
? 0 : 1;
8553 DECL_INITIAL (cbt
) = init
? error_mark_node
: NULL_TREE
;
8555 cbt
= start_decl (cbt
, TRUE
);
8556 if (ffeglobal_hook (g
) != NULL
)
8557 assert (cbt
== ffeglobal_hook (g
));
8559 assert (!init
|| !DECL_EXTERNAL (cbt
));
8561 /* Make sure that any type can live in COMMON and be referenced
8562 without getting a bus error. We could pick the most restrictive
8563 alignment of all entities actually placed in the COMMON, but
8564 this seems easy enough. */
8566 DECL_ALIGN (cbt
) = BIGGEST_ALIGNMENT
;
8567 DECL_USER_ALIGN (cbt
) = 0;
8569 if (is_init
&& (ffestorag_init (st
) == NULL
))
8570 init
= ffecom_init_zero_ (cbt
);
8572 finish_decl (cbt
, init
, TRUE
);
8575 ffestorag_set_init (st
, ffebld_new_any ());
8579 assert (DECL_SIZE_UNIT (cbt
) != NULL_TREE
);
8580 assert (TREE_CODE (DECL_SIZE_UNIT (cbt
)) == INTEGER_CST
);
8581 assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt
),
8582 (ffeglobal_common_size (g
)
8583 + ffeglobal_common_pad (g
))));
8586 ffeglobal_set_hook (g
, cbt
);
8588 ffestorag_set_hook (st
, cbt
);
8590 ffecom_save_tree_forever (cbt
);
8593 /* Make master area for local EQUIVALENCE. */
8596 ffecom_transform_equiv_ (ffestorag eqst
)
8602 bool is_init
= ffestorag_is_init (eqst
);
8604 assert (eqst
!= NULL
);
8606 eqt
= ffestorag_hook (eqst
);
8608 if (eqt
!= NULL_TREE
)
8611 /* Process inits. */
8615 if (ffestorag_init (eqst
) != NULL
)
8619 /* Set the padding for the expression, so ffecom_expr
8620 knows to insert that many zeros. */
8621 switch (ffebld_op (sexp
= ffestorag_init (eqst
)))
8623 case FFEBLD_opCONTER
:
8624 ffebld_conter_set_pad (sexp
, ffestorag_modulo (eqst
));
8627 case FFEBLD_opARRTER
:
8628 ffebld_arrter_set_pad (sexp
, ffestorag_modulo (eqst
));
8631 case FFEBLD_opACCTER
:
8632 ffebld_accter_set_pad (sexp
, ffestorag_modulo (eqst
));
8636 assert ("bad op for eqv init (pad)" == NULL
);
8640 init
= ffecom_expr (sexp
);
8641 if (init
== error_mark_node
)
8642 init
= NULL_TREE
; /* Hopefully the back end complained! */
8645 init
= error_mark_node
;
8647 else if (ffe_is_init_local_zero ())
8648 init
= error_mark_node
;
8652 ffecom_member_namelisted_
= FALSE
;
8653 ffestorag_drive (ffestorag_list_equivs (eqst
),
8654 &ffecom_member_phase1_
,
8657 high
= build_int_2 ((ffestorag_size (eqst
)
8658 + ffestorag_modulo (eqst
)) - 1, 0);
8659 TREE_TYPE (high
) = ffecom_integer_type_node
;
8661 eqtype
= build_array_type (char_type_node
,
8662 build_range_type (ffecom_integer_type_node
,
8663 ffecom_integer_zero_node
,
8666 eqt
= build_decl (VAR_DECL
,
8667 ffecom_get_invented_identifier ("__g77_equiv_%s",
8669 (ffestorag_symbol (eqst
))),
8671 DECL_EXTERNAL (eqt
) = 0;
8673 || ffecom_member_namelisted_
8674 #ifdef FFECOM_sizeMAXSTACKITEM
8675 || (ffestorag_size (eqst
) > FFECOM_sizeMAXSTACKITEM
)
8677 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8678 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
8679 && (ffestorag_is_save (eqst
) || ffe_is_saveall ())))
8680 TREE_STATIC (eqt
) = 1;
8682 TREE_STATIC (eqt
) = 0;
8683 TREE_PUBLIC (eqt
) = 0;
8684 TREE_ADDRESSABLE (eqt
) = 1; /* Ensure non-register allocation */
8685 DECL_CONTEXT (eqt
) = current_function_decl
;
8687 DECL_INITIAL (eqt
) = error_mark_node
;
8689 DECL_INITIAL (eqt
) = NULL_TREE
;
8691 eqt
= start_decl (eqt
, FALSE
);
8693 /* Make sure that any type can live in EQUIVALENCE and be referenced
8694 without getting a bus error. We could pick the most restrictive
8695 alignment of all entities actually placed in the EQUIVALENCE, but
8696 this seems easy enough. */
8698 DECL_ALIGN (eqt
) = BIGGEST_ALIGNMENT
;
8699 DECL_USER_ALIGN (eqt
) = 0;
8701 if ((!is_init
&& ffe_is_init_local_zero ())
8702 || (is_init
&& (ffestorag_init (eqst
) == NULL
)))
8703 init
= ffecom_init_zero_ (eqt
);
8705 finish_decl (eqt
, init
, FALSE
);
8708 ffestorag_set_init (eqst
, ffebld_new_any ());
8711 assert (TREE_CODE (DECL_SIZE_UNIT (eqt
)) == INTEGER_CST
);
8712 assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt
),
8713 (ffestorag_size (eqst
)
8714 + ffestorag_modulo (eqst
))));
8717 ffestorag_set_hook (eqst
, eqt
);
8719 ffestorag_drive (ffestorag_list_equivs (eqst
),
8720 &ffecom_member_phase2_
,
8724 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8727 ffecom_transform_namelist_ (ffesymbol s
)
8730 tree nmltype
= ffecom_type_namelist_ ();
8738 static int mynumber
= 0;
8740 nmlt
= build_decl (VAR_DECL
,
8741 ffecom_get_invented_identifier ("__g77_namelist_%d",
8744 TREE_STATIC (nmlt
) = 1;
8745 DECL_INITIAL (nmlt
) = error_mark_node
;
8747 nmlt
= start_decl (nmlt
, FALSE
);
8749 /* Process inits. */
8751 i
= strlen (ffesymbol_text (s
));
8753 high
= build_int_2 (i
, 0);
8754 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
8756 nameinit
= ffecom_build_f2c_string_ (i
+ 1,
8757 ffesymbol_text (s
));
8758 TREE_TYPE (nameinit
)
8759 = build_type_variant
8762 build_range_type (ffecom_f2c_ftnlen_type_node
,
8763 ffecom_f2c_ftnlen_one_node
,
8766 TREE_CONSTANT (nameinit
) = 1;
8767 TREE_STATIC (nameinit
) = 1;
8768 nameinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (nameinit
)),
8771 varsinit
= ffecom_vardesc_array_ (s
);
8772 varsinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (varsinit
)),
8774 TREE_CONSTANT (varsinit
) = 1;
8775 TREE_STATIC (varsinit
) = 1;
8780 for (i
= 0, b
= ffesymbol_namelist (s
); b
!= NULL
; b
= ffebld_trail (b
))
8783 nvarsinit
= build_int_2 (i
, 0);
8784 TREE_TYPE (nvarsinit
) = integer_type_node
;
8785 TREE_CONSTANT (nvarsinit
) = 1;
8786 TREE_STATIC (nvarsinit
) = 1;
8788 nmlinits
= build_tree_list ((field
= TYPE_FIELDS (nmltype
)), nameinit
);
8789 TREE_CHAIN (nmlinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
8791 TREE_CHAIN (TREE_CHAIN (nmlinits
))
8792 = build_tree_list ((field
= TREE_CHAIN (field
)), nvarsinit
);
8794 nmlinits
= build (CONSTRUCTOR
, nmltype
, NULL_TREE
, nmlinits
);
8795 TREE_CONSTANT (nmlinits
) = 1;
8796 TREE_STATIC (nmlinits
) = 1;
8798 finish_decl (nmlt
, nmlinits
, FALSE
);
8800 nmlt
= ffecom_1 (ADDR_EXPR
, build_pointer_type (nmltype
), nmlt
);
8805 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8806 analyzed on the assumption it is calculating a pointer to be
8807 indirected through. It must return the proper decl and offset,
8808 taking into account different units of measurements for offsets. */
8811 ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
8814 switch (TREE_CODE (t
))
8818 case NON_LVALUE_EXPR
:
8819 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
8823 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
8824 if ((*decl
== NULL_TREE
)
8825 || (*decl
== error_mark_node
))
8828 if (TREE_CODE (TREE_OPERAND (t
, 1)) == INTEGER_CST
)
8830 /* An offset into COMMON. */
8831 *offset
= fold (build (PLUS_EXPR
, TREE_TYPE (*offset
),
8832 *offset
, TREE_OPERAND (t
, 1)));
8833 /* Convert offset (presumably in bytes) into canonical units
8834 (presumably bits). */
8835 *offset
= size_binop (MULT_EXPR
,
8836 convert (bitsizetype
, *offset
),
8837 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t
))));
8840 /* Not a COMMON reference, so an unrecognized pattern. */
8841 *decl
= error_mark_node
;
8846 *offset
= bitsize_zero_node
;
8850 if (TREE_CODE (TREE_OPERAND (t
, 0)) == VAR_DECL
)
8852 /* A reference to COMMON. */
8853 *decl
= TREE_OPERAND (t
, 0);
8854 *offset
= bitsize_zero_node
;
8859 /* Not a COMMON reference, so an unrecognized pattern. */
8860 *decl
= error_mark_node
;
8865 /* Given a tree that is possibly intended for use as an lvalue, return
8866 information representing a canonical view of that tree as a decl, an
8867 offset into that decl, and a size for the lvalue.
8869 If there's no applicable decl, NULL_TREE is returned for the decl,
8870 and the other fields are left undefined.
8872 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8873 is returned for the decl, and the other fields are left undefined.
8875 Otherwise, the decl returned currently is either a VAR_DECL or a
8878 The offset returned is always valid, but of course not necessarily
8879 a constant, and not necessarily converted into the appropriate
8880 type, leaving that up to the caller (so as to avoid that overhead
8881 if the decls being looked at are different anyway).
8883 If the size cannot be determined (e.g. an adjustable array),
8884 an ERROR_MARK node is returned for the size. Otherwise, the
8885 size returned is valid, not necessarily a constant, and not
8886 necessarily converted into the appropriate type as with the
8889 Note that the offset and size expressions are expressed in the
8890 base storage units (usually bits) rather than in the units of
8891 the type of the decl, because two decls with different types
8892 might overlap but with apparently non-overlapping array offsets,
8893 whereas converting the array offsets to consistant offsets will
8894 reveal the overlap. */
8897 ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
8900 /* The default path is to report a nonexistant decl. */
8906 switch (TREE_CODE (t
))
8909 case IDENTIFIER_NODE
:
8918 case TRUNC_DIV_EXPR
:
8920 case FLOOR_DIV_EXPR
:
8921 case ROUND_DIV_EXPR
:
8922 case TRUNC_MOD_EXPR
:
8924 case FLOOR_MOD_EXPR
:
8925 case ROUND_MOD_EXPR
:
8927 case EXACT_DIV_EXPR
:
8928 case FIX_TRUNC_EXPR
:
8930 case FIX_FLOOR_EXPR
:
8931 case FIX_ROUND_EXPR
:
8945 case BIT_ANDTC_EXPR
:
8947 case TRUTH_ANDIF_EXPR
:
8948 case TRUTH_ORIF_EXPR
:
8949 case TRUTH_AND_EXPR
:
8951 case TRUTH_XOR_EXPR
:
8952 case TRUTH_NOT_EXPR
:
8972 *offset
= bitsize_zero_node
;
8973 *size
= TYPE_SIZE (TREE_TYPE (t
));
8978 tree array
= TREE_OPERAND (t
, 0);
8979 tree element
= TREE_OPERAND (t
, 1);
8982 if ((array
== NULL_TREE
)
8983 || (element
== NULL_TREE
))
8985 *decl
= error_mark_node
;
8989 ffecom_tree_canonize_ref_ (decl
, &init_offset
, size
,
8991 if ((*decl
== NULL_TREE
)
8992 || (*decl
== error_mark_node
))
8995 /* Calculate ((element - base) * NBBY) + init_offset. */
8996 *offset
= fold (build (MINUS_EXPR
, TREE_TYPE (element
),
8998 TYPE_MIN_VALUE (TYPE_DOMAIN
8999 (TREE_TYPE (array
)))));
9001 *offset
= size_binop (MULT_EXPR
,
9002 convert (bitsizetype
, *offset
),
9003 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array
))));
9005 *offset
= size_binop (PLUS_EXPR
, init_offset
, *offset
);
9007 *size
= TYPE_SIZE (TREE_TYPE (t
));
9013 /* Most of this code is to handle references to COMMON. And so
9014 far that is useful only for calling library functions, since
9015 external (user) functions might reference common areas. But
9016 even calling an external function, it's worthwhile to decode
9017 COMMON references because if not storing into COMMON, we don't
9018 want COMMON-based arguments to gratuitously force use of a
9021 *size
= TYPE_SIZE (TREE_TYPE (t
));
9023 ffecom_tree_canonize_ptr_ (decl
, offset
,
9024 TREE_OPERAND (t
, 0));
9031 case NON_LVALUE_EXPR
:
9034 case COND_EXPR
: /* More cases than we can handle. */
9036 case REFERENCE_EXPR
:
9037 case PREDECREMENT_EXPR
:
9038 case PREINCREMENT_EXPR
:
9039 case POSTDECREMENT_EXPR
:
9040 case POSTINCREMENT_EXPR
:
9043 *decl
= error_mark_node
;
9048 /* Do divide operation appropriate to type of operands. */
9051 ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
9052 tree dest_tree
, ffebld dest
, bool *dest_used
,
9055 if ((left
== error_mark_node
)
9056 || (right
== error_mark_node
))
9057 return error_mark_node
;
9059 switch (TREE_CODE (tree_type
))
9062 return ffecom_2 (TRUNC_DIV_EXPR
, tree_type
,
9067 if (! optimize_size
)
9068 return ffecom_2 (RDIV_EXPR
, tree_type
,
9074 if (TREE_TYPE (tree_type
)
9075 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9076 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9078 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9080 left
= ffecom_1 (ADDR_EXPR
,
9081 build_pointer_type (TREE_TYPE (left
)),
9083 left
= build_tree_list (NULL_TREE
, left
);
9084 right
= ffecom_1 (ADDR_EXPR
,
9085 build_pointer_type (TREE_TYPE (right
)),
9087 right
= build_tree_list (NULL_TREE
, right
);
9088 TREE_CHAIN (left
) = right
;
9090 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9091 ffecom_gfrt_kindtype (ix
),
9092 ffe_is_f2c_library (),
9095 dest_tree
, dest
, dest_used
,
9096 NULL_TREE
, TRUE
, hook
);
9104 if (TREE_TYPE (TYPE_FIELDS (tree_type
))
9105 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9106 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9108 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9110 left
= ffecom_1 (ADDR_EXPR
,
9111 build_pointer_type (TREE_TYPE (left
)),
9113 left
= build_tree_list (NULL_TREE
, left
);
9114 right
= ffecom_1 (ADDR_EXPR
,
9115 build_pointer_type (TREE_TYPE (right
)),
9117 right
= build_tree_list (NULL_TREE
, right
);
9118 TREE_CHAIN (left
) = right
;
9120 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9121 ffecom_gfrt_kindtype (ix
),
9122 ffe_is_f2c_library (),
9125 dest_tree
, dest
, dest_used
,
9126 NULL_TREE
, TRUE
, hook
);
9131 return ffecom_2 (RDIV_EXPR
, tree_type
,
9137 /* Build type info for non-dummy variable. */
9140 ffecom_type_localvar_ (ffesymbol s
, ffeinfoBasictype bt
,
9149 type
= ffecom_tree_type
[bt
][kt
];
9150 if (bt
== FFEINFO_basictypeCHARACTER
)
9152 hight
= build_int_2 (ffesymbol_size (s
), 0);
9153 TREE_TYPE (hight
) = ffecom_f2c_ftnlen_type_node
;
9158 build_range_type (ffecom_f2c_ftnlen_type_node
,
9159 ffecom_f2c_ftnlen_one_node
,
9161 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9164 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
9166 if (type
== error_mark_node
)
9169 dim
= ffebld_head (dl
);
9170 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
9172 if (ffebld_left (dim
) == NULL
)
9173 lowt
= integer_one_node
;
9175 lowt
= ffecom_expr (ffebld_left (dim
));
9177 if (TREE_CODE (lowt
) != INTEGER_CST
)
9178 lowt
= variable_size (lowt
);
9180 assert (ffebld_right (dim
) != NULL
);
9181 hight
= ffecom_expr (ffebld_right (dim
));
9183 if (TREE_CODE (hight
) != INTEGER_CST
)
9184 hight
= variable_size (hight
);
9186 type
= build_array_type (type
,
9187 build_range_type (ffecom_integer_type_node
,
9189 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9195 /* Build Namelist type. */
9198 ffecom_type_namelist_ ()
9200 static tree type
= NULL_TREE
;
9202 if (type
== NULL_TREE
)
9204 static tree namefield
, varsfield
, nvarsfield
;
9207 vardesctype
= ffecom_type_vardesc_ ();
9209 type
= make_node (RECORD_TYPE
);
9211 vardesctype
= build_pointer_type (build_pointer_type (vardesctype
));
9213 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9215 varsfield
= ffecom_decl_field (type
, namefield
, "vars", vardesctype
);
9216 nvarsfield
= ffecom_decl_field (type
, varsfield
, "nvars",
9219 TYPE_FIELDS (type
) = namefield
;
9222 ggc_add_tree_root (&type
, 1);
9228 /* Build Vardesc type. */
9231 ffecom_type_vardesc_ ()
9233 static tree type
= NULL_TREE
;
9234 static tree namefield
, addrfield
, dimsfield
, typefield
;
9236 if (type
== NULL_TREE
)
9238 type
= make_node (RECORD_TYPE
);
9240 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9242 addrfield
= ffecom_decl_field (type
, namefield
, "addr",
9244 dimsfield
= ffecom_decl_field (type
, addrfield
, "dims",
9245 ffecom_f2c_ptr_to_ftnlen_type_node
);
9246 typefield
= ffecom_decl_field (type
, dimsfield
, "type",
9249 TYPE_FIELDS (type
) = namefield
;
9252 ggc_add_tree_root (&type
, 1);
9259 ffecom_vardesc_ (ffebld expr
)
9263 assert (ffebld_op (expr
) == FFEBLD_opSYMTER
);
9264 s
= ffebld_symter (expr
);
9266 if (ffesymbol_hook (s
).vardesc_tree
== NULL_TREE
)
9269 tree vardesctype
= ffecom_type_vardesc_ ();
9277 static int mynumber
= 0;
9279 var
= build_decl (VAR_DECL
,
9280 ffecom_get_invented_identifier ("__g77_vardesc_%d",
9283 TREE_STATIC (var
) = 1;
9284 DECL_INITIAL (var
) = error_mark_node
;
9286 var
= start_decl (var
, FALSE
);
9288 /* Process inits. */
9290 nameinit
= ffecom_build_f2c_string_ ((i
= strlen (ffesymbol_text (s
)))
9292 ffesymbol_text (s
));
9293 TREE_TYPE (nameinit
)
9294 = build_type_variant
9297 build_range_type (integer_type_node
,
9299 build_int_2 (i
, 0))),
9301 TREE_CONSTANT (nameinit
) = 1;
9302 TREE_STATIC (nameinit
) = 1;
9303 nameinit
= ffecom_1 (ADDR_EXPR
,
9304 build_pointer_type (TREE_TYPE (nameinit
)),
9307 addrinit
= ffecom_arg_ptr_to_expr (expr
, &typeinit
);
9309 dimsinit
= ffecom_vardesc_dims_ (s
);
9311 if (typeinit
== NULL_TREE
)
9313 ffeinfoBasictype bt
= ffesymbol_basictype (s
);
9314 ffeinfoKindtype kt
= ffesymbol_kindtype (s
);
9315 int tc
= ffecom_f2c_typecode (bt
, kt
);
9318 typeinit
= build_int_2 (tc
, (tc
< 0) ? -1 : 0);
9321 typeinit
= ffecom_1 (NEGATE_EXPR
, TREE_TYPE (typeinit
), typeinit
);
9323 varinits
= build_tree_list ((field
= TYPE_FIELDS (vardesctype
)),
9325 TREE_CHAIN (varinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
9327 TREE_CHAIN (TREE_CHAIN (varinits
))
9328 = build_tree_list ((field
= TREE_CHAIN (field
)), dimsinit
);
9329 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits
)))
9330 = build_tree_list ((field
= TREE_CHAIN (field
)), typeinit
);
9332 varinits
= build (CONSTRUCTOR
, vardesctype
, NULL_TREE
, varinits
);
9333 TREE_CONSTANT (varinits
) = 1;
9334 TREE_STATIC (varinits
) = 1;
9336 finish_decl (var
, varinits
, FALSE
);
9338 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (vardesctype
), var
);
9340 ffesymbol_hook (s
).vardesc_tree
= var
;
9343 return ffesymbol_hook (s
).vardesc_tree
;
9347 ffecom_vardesc_array_ (ffesymbol s
)
9351 tree item
= NULL_TREE
;
9354 static int mynumber
= 0;
9356 for (i
= 0, list
= NULL_TREE
, b
= ffesymbol_namelist (s
);
9358 b
= ffebld_trail (b
), ++i
)
9362 t
= ffecom_vardesc_ (ffebld_head (b
));
9364 if (list
== NULL_TREE
)
9365 list
= item
= build_tree_list (NULL_TREE
, t
);
9368 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
9369 item
= TREE_CHAIN (item
);
9373 item
= build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9374 build_range_type (integer_type_node
,
9376 build_int_2 (i
, 0)));
9377 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
9378 TREE_CONSTANT (list
) = 1;
9379 TREE_STATIC (list
) = 1;
9381 var
= ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber
++);
9382 var
= build_decl (VAR_DECL
, var
, item
);
9383 TREE_STATIC (var
) = 1;
9384 DECL_INITIAL (var
) = error_mark_node
;
9385 var
= start_decl (var
, FALSE
);
9386 finish_decl (var
, list
, FALSE
);
9392 ffecom_vardesc_dims_ (ffesymbol s
)
9394 if (ffesymbol_dims (s
) == NULL
)
9395 return convert (ffecom_f2c_ptr_to_ftnlen_type_node
,
9403 tree item
= NULL_TREE
;
9407 tree baseoff
= NULL_TREE
;
9408 static int mynumber
= 0;
9410 numdim
= build_int_2 ((int) ffesymbol_rank (s
), 0);
9411 TREE_TYPE (numdim
) = ffecom_f2c_ftnlen_type_node
;
9413 numelem
= ffecom_expr (ffesymbol_arraysize (s
));
9414 TREE_TYPE (numelem
) = ffecom_f2c_ftnlen_type_node
;
9417 backlist
= NULL_TREE
;
9418 for (b
= ffesymbol_dims (s
), e
= ffesymbol_extents (s
);
9420 b
= ffebld_trail (b
), e
= ffebld_trail (e
))
9426 if (ffebld_trail (b
) == NULL
)
9430 t
= convert (ffecom_f2c_ftnlen_type_node
,
9431 ffecom_expr (ffebld_head (e
)));
9433 if (list
== NULL_TREE
)
9434 list
= item
= build_tree_list (NULL_TREE
, t
);
9437 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
9438 item
= TREE_CHAIN (item
);
9442 if (ffebld_left (ffebld_head (b
)) == NULL
)
9443 low
= ffecom_integer_one_node
;
9445 low
= ffecom_expr (ffebld_left (ffebld_head (b
)));
9446 low
= convert (ffecom_f2c_ftnlen_type_node
, low
);
9448 back
= build_tree_list (low
, t
);
9449 TREE_CHAIN (back
) = backlist
;
9453 for (item
= backlist
; item
!= NULL_TREE
; item
= TREE_CHAIN (item
))
9455 if (TREE_VALUE (item
) == NULL_TREE
)
9456 baseoff
= TREE_PURPOSE (item
);
9458 baseoff
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
9459 TREE_PURPOSE (item
),
9460 ffecom_2 (MULT_EXPR
,
9461 ffecom_f2c_ftnlen_type_node
,
9466 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9468 baseoff
= build_tree_list (NULL_TREE
, baseoff
);
9469 TREE_CHAIN (baseoff
) = list
;
9471 numelem
= build_tree_list (NULL_TREE
, numelem
);
9472 TREE_CHAIN (numelem
) = baseoff
;
9474 numdim
= build_tree_list (NULL_TREE
, numdim
);
9475 TREE_CHAIN (numdim
) = numelem
;
9477 item
= build_array_type (ffecom_f2c_ftnlen_type_node
,
9478 build_range_type (integer_type_node
,
9481 ((int) ffesymbol_rank (s
)
9483 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, numdim
);
9484 TREE_CONSTANT (list
) = 1;
9485 TREE_STATIC (list
) = 1;
9487 var
= ffecom_get_invented_identifier ("__g77_dims_%d", mynumber
++);
9488 var
= build_decl (VAR_DECL
, var
, item
);
9489 TREE_STATIC (var
) = 1;
9490 DECL_INITIAL (var
) = error_mark_node
;
9491 var
= start_decl (var
, FALSE
);
9492 finish_decl (var
, list
, FALSE
);
9494 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (item
), var
);
9500 /* Essentially does a "fold (build1 (code, type, node))" while checking
9501 for certain housekeeping things.
9503 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9504 ffecom_1_fn instead. */
9507 ffecom_1 (enum tree_code code
, tree type
, tree node
)
9511 if ((node
== error_mark_node
)
9512 || (type
== error_mark_node
))
9513 return error_mark_node
;
9515 if (code
== ADDR_EXPR
)
9517 if (!mark_addressable (node
))
9518 assert ("can't mark_addressable this node!" == NULL
);
9521 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
9526 item
= build (COMPONENT_REF
, type
, node
, TYPE_FIELDS (TREE_TYPE (node
)));
9530 item
= build (COMPONENT_REF
, type
, node
, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node
))));
9535 if (TREE_CODE (type
) != RECORD_TYPE
)
9537 item
= build1 (code
, type
, node
);
9540 node
= ffecom_stabilize_aggregate_ (node
);
9541 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9543 ffecom_2 (COMPLEX_EXPR
, type
,
9544 ffecom_1 (NEGATE_EXPR
, realtype
,
9545 ffecom_1 (REALPART_EXPR
, realtype
,
9547 ffecom_1 (NEGATE_EXPR
, realtype
,
9548 ffecom_1 (IMAGPART_EXPR
, realtype
,
9553 item
= build1 (code
, type
, node
);
9557 if (TREE_SIDE_EFFECTS (node
))
9558 TREE_SIDE_EFFECTS (item
) = 1;
9559 if (code
== ADDR_EXPR
&& staticp (node
))
9560 TREE_CONSTANT (item
) = 1;
9561 else if (code
== INDIRECT_REF
)
9562 TREE_READONLY (item
) = TYPE_READONLY (type
);
9566 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9567 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9568 does not set TREE_ADDRESSABLE (because calling an inline
9569 function does not mean the function needs to be separately
9573 ffecom_1_fn (tree node
)
9578 if (node
== error_mark_node
)
9579 return error_mark_node
;
9581 type
= build_type_variant (TREE_TYPE (node
),
9582 TREE_READONLY (node
),
9583 TREE_THIS_VOLATILE (node
));
9584 item
= build1 (ADDR_EXPR
,
9585 build_pointer_type (type
), node
);
9586 if (TREE_SIDE_EFFECTS (node
))
9587 TREE_SIDE_EFFECTS (item
) = 1;
9589 TREE_CONSTANT (item
) = 1;
9593 /* Essentially does a "fold (build (code, type, node1, node2))" while
9594 checking for certain housekeeping things. */
9597 ffecom_2 (enum tree_code code
, tree type
, tree node1
,
9602 if ((node1
== error_mark_node
)
9603 || (node2
== error_mark_node
)
9604 || (type
== error_mark_node
))
9605 return error_mark_node
;
9607 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
9609 tree a
, b
, c
, d
, realtype
;
9612 assert ("no CONJ_EXPR support yet" == NULL
);
9613 return error_mark_node
;
9616 item
= build_tree_list (TYPE_FIELDS (type
), node1
);
9617 TREE_CHAIN (item
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), node2
);
9618 item
= build (CONSTRUCTOR
, type
, NULL_TREE
, item
);
9622 if (TREE_CODE (type
) != RECORD_TYPE
)
9624 item
= build (code
, type
, node1
, node2
);
9627 node1
= ffecom_stabilize_aggregate_ (node1
);
9628 node2
= ffecom_stabilize_aggregate_ (node2
);
9629 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9631 ffecom_2 (COMPLEX_EXPR
, type
,
9632 ffecom_2 (PLUS_EXPR
, realtype
,
9633 ffecom_1 (REALPART_EXPR
, realtype
,
9635 ffecom_1 (REALPART_EXPR
, realtype
,
9637 ffecom_2 (PLUS_EXPR
, realtype
,
9638 ffecom_1 (IMAGPART_EXPR
, realtype
,
9640 ffecom_1 (IMAGPART_EXPR
, realtype
,
9645 if (TREE_CODE (type
) != RECORD_TYPE
)
9647 item
= build (code
, type
, node1
, node2
);
9650 node1
= ffecom_stabilize_aggregate_ (node1
);
9651 node2
= ffecom_stabilize_aggregate_ (node2
);
9652 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9654 ffecom_2 (COMPLEX_EXPR
, type
,
9655 ffecom_2 (MINUS_EXPR
, realtype
,
9656 ffecom_1 (REALPART_EXPR
, realtype
,
9658 ffecom_1 (REALPART_EXPR
, realtype
,
9660 ffecom_2 (MINUS_EXPR
, realtype
,
9661 ffecom_1 (IMAGPART_EXPR
, realtype
,
9663 ffecom_1 (IMAGPART_EXPR
, realtype
,
9668 if (TREE_CODE (type
) != RECORD_TYPE
)
9670 item
= build (code
, type
, node1
, node2
);
9673 node1
= ffecom_stabilize_aggregate_ (node1
);
9674 node2
= ffecom_stabilize_aggregate_ (node2
);
9675 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9676 a
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
9678 b
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
9680 c
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
9682 d
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
9685 ffecom_2 (COMPLEX_EXPR
, type
,
9686 ffecom_2 (MINUS_EXPR
, realtype
,
9687 ffecom_2 (MULT_EXPR
, realtype
,
9690 ffecom_2 (MULT_EXPR
, realtype
,
9693 ffecom_2 (PLUS_EXPR
, realtype
,
9694 ffecom_2 (MULT_EXPR
, realtype
,
9697 ffecom_2 (MULT_EXPR
, realtype
,
9703 if ((TREE_CODE (node1
) != RECORD_TYPE
)
9704 && (TREE_CODE (node2
) != RECORD_TYPE
))
9706 item
= build (code
, type
, node1
, node2
);
9709 assert (TREE_CODE (node1
) == RECORD_TYPE
);
9710 assert (TREE_CODE (node2
) == RECORD_TYPE
);
9711 node1
= ffecom_stabilize_aggregate_ (node1
);
9712 node2
= ffecom_stabilize_aggregate_ (node2
);
9713 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9715 ffecom_2 (TRUTH_ANDIF_EXPR
, type
,
9716 ffecom_2 (code
, type
,
9717 ffecom_1 (REALPART_EXPR
, realtype
,
9719 ffecom_1 (REALPART_EXPR
, realtype
,
9721 ffecom_2 (code
, type
,
9722 ffecom_1 (IMAGPART_EXPR
, realtype
,
9724 ffecom_1 (IMAGPART_EXPR
, realtype
,
9729 if ((TREE_CODE (node1
) != RECORD_TYPE
)
9730 && (TREE_CODE (node2
) != RECORD_TYPE
))
9732 item
= build (code
, type
, node1
, node2
);
9735 assert (TREE_CODE (node1
) == RECORD_TYPE
);
9736 assert (TREE_CODE (node2
) == RECORD_TYPE
);
9737 node1
= ffecom_stabilize_aggregate_ (node1
);
9738 node2
= ffecom_stabilize_aggregate_ (node2
);
9739 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9741 ffecom_2 (TRUTH_ORIF_EXPR
, type
,
9742 ffecom_2 (code
, type
,
9743 ffecom_1 (REALPART_EXPR
, realtype
,
9745 ffecom_1 (REALPART_EXPR
, realtype
,
9747 ffecom_2 (code
, type
,
9748 ffecom_1 (IMAGPART_EXPR
, realtype
,
9750 ffecom_1 (IMAGPART_EXPR
, realtype
,
9755 item
= build (code
, type
, node1
, node2
);
9759 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
))
9760 TREE_SIDE_EFFECTS (item
) = 1;
9764 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9766 ffesymbol s; // the ENTRY point itself
9767 if (ffecom_2pass_advise_entrypoint(s))
9768 // the ENTRY point has been accepted
9770 Does whatever compiler needs to do when it learns about the entrypoint,
9771 like determine the return type of the master function, count the
9772 number of entrypoints, etc. Returns FALSE if the return type is
9773 not compatible with the return type(s) of other entrypoint(s).
9775 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9776 later (after _finish_progunit) be called with the same entrypoint(s)
9777 as passed to this fn for which TRUE was returned.
9780 Return FALSE if the return type conflicts with previous entrypoints. */
9783 ffecom_2pass_advise_entrypoint (ffesymbol entry
)
9785 ffebld list
; /* opITEM. */
9786 ffebld mlist
; /* opITEM. */
9787 ffebld plist
; /* opITEM. */
9788 ffebld arg
; /* ffebld_head(opITEM). */
9789 ffebld item
; /* opITEM. */
9790 ffesymbol s
; /* ffebld_symter(arg). */
9791 ffeinfoBasictype bt
= ffesymbol_basictype (entry
);
9792 ffeinfoKindtype kt
= ffesymbol_kindtype (entry
);
9793 ffetargetCharacterSize size
= ffesymbol_size (entry
);
9796 if (ffecom_num_entrypoints_
== 0)
9797 { /* First entrypoint, make list of main
9798 arglist's dummies. */
9799 assert (ffecom_primary_entry_
!= NULL
);
9801 ffecom_master_bt_
= ffesymbol_basictype (ffecom_primary_entry_
);
9802 ffecom_master_kt_
= ffesymbol_kindtype (ffecom_primary_entry_
);
9803 ffecom_master_size_
= ffesymbol_size (ffecom_primary_entry_
);
9805 for (plist
= NULL
, list
= ffesymbol_dummyargs (ffecom_primary_entry_
);
9807 list
= ffebld_trail (list
))
9809 arg
= ffebld_head (list
);
9810 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
9811 continue; /* Alternate return or some such thing. */
9812 item
= ffebld_new_item (arg
, NULL
);
9814 ffecom_master_arglist_
= item
;
9816 ffebld_set_trail (plist
, item
);
9821 /* If necessary, scan entry arglist for alternate returns. Do this scan
9822 apparently redundantly (it's done below to UNIONize the arglists) so
9823 that we don't complain about RETURN 1 if an offending ENTRY is the only
9824 one with an alternate return. */
9826 if (!ffecom_is_altreturning_
)
9828 for (list
= ffesymbol_dummyargs (entry
);
9830 list
= ffebld_trail (list
))
9832 arg
= ffebld_head (list
);
9833 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
9835 ffecom_is_altreturning_
= TRUE
;
9841 /* Now check type compatibility. */
9843 switch (ffecom_master_bt_
)
9845 case FFEINFO_basictypeNONE
:
9846 ok
= (bt
!= FFEINFO_basictypeCHARACTER
);
9849 case FFEINFO_basictypeCHARACTER
:
9851 = (bt
== FFEINFO_basictypeCHARACTER
)
9852 && (kt
== ffecom_master_kt_
)
9853 && (size
== ffecom_master_size_
);
9856 case FFEINFO_basictypeANY
:
9857 return FALSE
; /* Just don't bother. */
9860 if (bt
== FFEINFO_basictypeCHARACTER
)
9866 if ((bt
!= ffecom_master_bt_
) || (kt
!= ffecom_master_kt_
))
9868 ffecom_master_bt_
= FFEINFO_basictypeNONE
;
9869 ffecom_master_kt_
= FFEINFO_kindtypeNONE
;
9876 ffebad_start (FFEBAD_ENTRY_CONFLICTS
);
9877 ffest_ffebad_here_current_stmt (0);
9879 return FALSE
; /* Can't handle entrypoint. */
9882 /* Entrypoint type compatible with previous types. */
9884 ++ffecom_num_entrypoints_
;
9886 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9888 for (list
= ffesymbol_dummyargs (entry
);
9890 list
= ffebld_trail (list
))
9892 arg
= ffebld_head (list
);
9893 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
9894 continue; /* Alternate return or some such thing. */
9895 s
= ffebld_symter (arg
);
9896 for (plist
= NULL
, mlist
= ffecom_master_arglist_
;
9898 plist
= mlist
, mlist
= ffebld_trail (mlist
))
9899 { /* plist points to previous item for easy
9900 appending of arg. */
9901 if (ffebld_symter (ffebld_head (mlist
)) == s
)
9902 break; /* Already have this arg in the master list. */
9905 continue; /* Already have this arg in the master list. */
9907 /* Append this arg to the master list. */
9909 item
= ffebld_new_item (arg
, NULL
);
9911 ffecom_master_arglist_
= item
;
9913 ffebld_set_trail (plist
, item
);
9919 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9921 ffesymbol s; // the ENTRY point itself
9922 ffecom_2pass_do_entrypoint(s);
9924 Does whatever compiler needs to do to make the entrypoint actually
9925 happen. Must be called for each entrypoint after
9926 ffecom_finish_progunit is called. */
9929 ffecom_2pass_do_entrypoint (ffesymbol entry
)
9931 static int mfn_num
= 0;
9934 if (mfn_num
!= ffecom_num_fns_
)
9935 { /* First entrypoint for this program unit. */
9937 mfn_num
= ffecom_num_fns_
;
9938 ffecom_do_entry_ (ffecom_primary_entry_
, 0);
9943 --ffecom_num_entrypoints_
;
9945 ffecom_do_entry_ (entry
, ent_num
);
9948 /* Essentially does a "fold (build (code, type, node1, node2))" while
9949 checking for certain housekeeping things. Always sets
9950 TREE_SIDE_EFFECTS. */
9953 ffecom_2s (enum tree_code code
, tree type
, tree node1
,
9958 if ((node1
== error_mark_node
)
9959 || (node2
== error_mark_node
)
9960 || (type
== error_mark_node
))
9961 return error_mark_node
;
9963 item
= build (code
, type
, node1
, node2
);
9964 TREE_SIDE_EFFECTS (item
) = 1;
9968 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9969 checking for certain housekeeping things. */
9972 ffecom_3 (enum tree_code code
, tree type
, tree node1
,
9973 tree node2
, tree node3
)
9977 if ((node1
== error_mark_node
)
9978 || (node2
== error_mark_node
)
9979 || (node3
== error_mark_node
)
9980 || (type
== error_mark_node
))
9981 return error_mark_node
;
9983 item
= build (code
, type
, node1
, node2
, node3
);
9984 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
)
9985 || (node3
!= NULL_TREE
&& TREE_SIDE_EFFECTS (node3
)))
9986 TREE_SIDE_EFFECTS (item
) = 1;
9990 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9991 checking for certain housekeeping things. Always sets
9992 TREE_SIDE_EFFECTS. */
9995 ffecom_3s (enum tree_code code
, tree type
, tree node1
,
9996 tree node2
, tree node3
)
10000 if ((node1
== error_mark_node
)
10001 || (node2
== error_mark_node
)
10002 || (node3
== error_mark_node
)
10003 || (type
== error_mark_node
))
10004 return error_mark_node
;
10006 item
= build (code
, type
, node1
, node2
, node3
);
10007 TREE_SIDE_EFFECTS (item
) = 1;
10008 return fold (item
);
10011 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10013 See use by ffecom_list_expr.
10015 If expression is NULL, returns an integer zero tree. If it is not
10016 a CHARACTER expression, returns whatever ffecom_expr
10017 returns and sets the length return value to NULL_TREE. Otherwise
10018 generates code to evaluate the character expression, returns the proper
10019 pointer to the result, but does NOT set the length return value to a tree
10020 that specifies the length of the result. (In other words, the length
10021 variable is always set to NULL_TREE, because a length is never passed.)
10024 Don't set returned length, since nobody needs it (yet; someday if
10025 we allow CHARACTER*(*) dummies to statement functions, we'll need
10029 ffecom_arg_expr (ffebld expr
, tree
*length
)
10033 *length
= NULL_TREE
;
10036 return integer_zero_node
;
10038 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10039 return ffecom_expr (expr
);
10041 return ffecom_arg_ptr_to_expr (expr
, &ign
);
10044 /* Transform expression into constant argument-pointer-to-expression tree.
10046 If the expression can be transformed into a argument-pointer-to-expression
10047 tree that is constant, that is done, and the tree returned. Else
10048 NULL_TREE is returned.
10050 That way, a caller can attempt to provide compile-time initialization
10051 of a variable and, if that fails, *then* choose to start a new block
10052 and resort to using temporaries, as appropriate. */
10055 ffecom_arg_ptr_to_const_expr (ffebld expr
, tree
*length
)
10058 return integer_zero_node
;
10060 if (ffebld_op (expr
) == FFEBLD_opANY
)
10063 *length
= error_mark_node
;
10064 return error_mark_node
;
10067 if (ffebld_arity (expr
) == 0
10068 && (ffebld_op (expr
) != FFEBLD_opSYMTER
10069 || ffebld_where (expr
) == FFEINFO_whereCOMMON
10070 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
10071 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
10075 t
= ffecom_arg_ptr_to_expr (expr
, length
);
10076 assert (TREE_CONSTANT (t
));
10077 assert (! length
|| TREE_CONSTANT (*length
));
10082 && ffebld_size (expr
) != FFETARGET_charactersizeNONE
)
10083 *length
= build_int_2 (ffebld_size (expr
), 0);
10085 *length
= NULL_TREE
;
10089 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10091 See use by ffecom_list_ptr_to_expr.
10093 If expression is NULL, returns an integer zero tree. If it is not
10094 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10095 returns and sets the length return value to NULL_TREE. Otherwise
10096 generates code to evaluate the character expression, returns the proper
10097 pointer to the result, AND sets the length return value to a tree that
10098 specifies the length of the result.
10100 If the length argument is NULL, this is a slightly special
10101 case of building a FORMAT expression, that is, an expression that
10102 will be used at run time without regard to length. For the current
10103 implementation, which uses the libf2c library, this means it is nice
10104 to append a null byte to the end of the expression, where feasible,
10105 to make sure any diagnostic about the FORMAT string terminates at
10108 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10109 length argument. This might even be seen as a feature, if a null
10110 byte can always be appended. */
10113 ffecom_arg_ptr_to_expr (ffebld expr
, tree
*length
)
10117 ffecomConcatList_ catlist
;
10119 if (length
!= NULL
)
10120 *length
= NULL_TREE
;
10123 return integer_zero_node
;
10125 switch (ffebld_op (expr
))
10127 case FFEBLD_opPERCENT_VAL
:
10128 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10129 return ffecom_expr (ffebld_left (expr
));
10134 temp_exp
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &temp_length
);
10135 if (temp_exp
== error_mark_node
)
10136 return error_mark_node
;
10138 return ffecom_1 (INDIRECT_REF
, TREE_TYPE (TREE_TYPE (temp_exp
)),
10142 case FFEBLD_opPERCENT_REF
:
10143 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10144 return ffecom_ptr_to_expr (ffebld_left (expr
));
10145 if (length
!= NULL
)
10147 ign_length
= NULL_TREE
;
10148 length
= &ign_length
;
10150 expr
= ffebld_left (expr
);
10153 case FFEBLD_opPERCENT_DESCR
:
10154 switch (ffeinfo_basictype (ffebld_info (expr
)))
10156 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10157 case FFEINFO_basictypeHOLLERITH
:
10159 case FFEINFO_basictypeCHARACTER
:
10160 break; /* Passed by descriptor anyway. */
10163 item
= ffecom_ptr_to_expr (expr
);
10164 if (item
!= error_mark_node
)
10165 *length
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (item
)));
10174 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10175 if ((ffeinfo_basictype (ffebld_info (expr
)) == FFEINFO_basictypeHOLLERITH
)
10176 && (length
!= NULL
))
10177 { /* Pass Hollerith by descriptor. */
10178 ffetargetHollerith h
;
10180 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
10181 h
= ffebld_cu_val_hollerith (ffebld_constant_union
10182 (ffebld_conter (expr
)));
10184 = build_int_2 (h
.length
, 0);
10185 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10189 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10190 return ffecom_ptr_to_expr (expr
);
10192 assert (ffeinfo_kindtype (ffebld_info (expr
))
10193 == FFEINFO_kindtypeCHARACTER1
);
10195 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
10196 expr
= ffebld_left (expr
);
10198 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
10199 switch (ffecom_concat_list_count_ (catlist
))
10201 case 0: /* Shouldn't happen, but in case it does... */
10202 if (length
!= NULL
)
10204 *length
= ffecom_f2c_ftnlen_zero_node
;
10205 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10207 ffecom_concat_list_kill_ (catlist
);
10208 return null_pointer_node
;
10210 case 1: /* The (fairly) easy case. */
10211 if (length
== NULL
)
10212 ffecom_char_args_with_null_ (&item
, &ign_length
,
10213 ffecom_concat_list_expr_ (catlist
, 0));
10215 ffecom_char_args_ (&item
, length
,
10216 ffecom_concat_list_expr_ (catlist
, 0));
10217 ffecom_concat_list_kill_ (catlist
);
10218 assert (item
!= NULL_TREE
);
10221 default: /* Must actually concatenate things. */
10226 int count
= ffecom_concat_list_count_ (catlist
);
10237 ffetargetCharacterSize sz
;
10239 sz
= ffecom_concat_list_maxlen_ (catlist
);
10241 assert (sz
!= FFETARGET_charactersizeNONE
);
10246 = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node
,
10247 FFETARGET_charactersizeNONE
, count
, TRUE
);
10250 = ffecom_push_tempvar (ffecom_f2c_address_type_node
,
10251 FFETARGET_charactersizeNONE
, count
, TRUE
);
10252 temporary
= ffecom_push_tempvar (char_type_node
,
10258 hook
= ffebld_nonter_hook (expr
);
10260 assert (TREE_CODE (hook
) == TREE_VEC
);
10261 assert (TREE_VEC_LENGTH (hook
) == 3);
10262 length_array
= lengths
= TREE_VEC_ELT (hook
, 0);
10263 item_array
= items
= TREE_VEC_ELT (hook
, 1);
10264 temporary
= TREE_VEC_ELT (hook
, 2);
10268 known_length
= ffecom_f2c_ftnlen_zero_node
;
10270 for (i
= 0; i
< count
; ++i
)
10273 && (length
== NULL
))
10274 ffecom_char_args_with_null_ (&citem
, &clength
,
10275 ffecom_concat_list_expr_ (catlist
, i
));
10277 ffecom_char_args_ (&citem
, &clength
,
10278 ffecom_concat_list_expr_ (catlist
, i
));
10279 if ((citem
== error_mark_node
)
10280 || (clength
== error_mark_node
))
10282 ffecom_concat_list_kill_ (catlist
);
10283 *length
= error_mark_node
;
10284 return error_mark_node
;
10288 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
10289 ffecom_modify (void_type_node
,
10290 ffecom_2 (ARRAY_REF
,
10291 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
10293 build_int_2 (i
, 0)),
10296 clength
= ffecom_save_tree (clength
);
10297 if (length
!= NULL
)
10299 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
10303 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
10304 ffecom_modify (void_type_node
,
10305 ffecom_2 (ARRAY_REF
,
10306 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
10308 build_int_2 (i
, 0)),
10313 temporary
= ffecom_1 (ADDR_EXPR
,
10314 build_pointer_type (TREE_TYPE (temporary
)),
10317 item
= build_tree_list (NULL_TREE
, temporary
);
10319 = build_tree_list (NULL_TREE
,
10320 ffecom_1 (ADDR_EXPR
,
10321 build_pointer_type (TREE_TYPE (items
)),
10323 TREE_CHAIN (TREE_CHAIN (item
))
10324 = build_tree_list (NULL_TREE
,
10325 ffecom_1 (ADDR_EXPR
,
10326 build_pointer_type (TREE_TYPE (lengths
)),
10328 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
10331 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
10332 convert (ffecom_f2c_ftnlen_type_node
,
10333 build_int_2 (count
, 0))));
10334 num
= build_int_2 (sz
, 0);
10335 TREE_TYPE (num
) = ffecom_f2c_ftnlen_type_node
;
10336 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
))))
10337 = build_tree_list (NULL_TREE
, num
);
10339 item
= ffecom_call_gfrt (FFECOM_gfrtCAT
, item
, NULL_TREE
);
10340 TREE_SIDE_EFFECTS (item
) = 1;
10341 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (temporary
),
10345 if (length
!= NULL
)
10346 *length
= known_length
;
10349 ffecom_concat_list_kill_ (catlist
);
10350 assert (item
!= NULL_TREE
);
10354 /* Generate call to run-time function.
10356 The first arg is the GNU Fortran Run-Time function index, the second
10357 arg is the list of arguments to pass to it. Returned is the expression
10358 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10359 result (which may be void). */
10362 ffecom_call_gfrt (ffecomGfrt ix
, tree args
, tree hook
)
10364 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
10365 ffecom_gfrt_kindtype (ix
),
10366 ffe_is_f2c_library () && ffecom_gfrt_complex_
[ix
],
10367 NULL_TREE
, args
, NULL_TREE
, NULL
,
10368 NULL
, NULL_TREE
, TRUE
, hook
);
10371 /* Transform constant-union to tree. */
10374 ffecom_constantunion (ffebldConstantUnion
*cu
, ffeinfoBasictype bt
,
10375 ffeinfoKindtype kt
, tree tree_type
)
10381 case FFEINFO_basictypeINTEGER
:
10387 #if FFETARGET_okINTEGER1
10388 case FFEINFO_kindtypeINTEGER1
:
10389 val
= ffebld_cu_val_integer1 (*cu
);
10393 #if FFETARGET_okINTEGER2
10394 case FFEINFO_kindtypeINTEGER2
:
10395 val
= ffebld_cu_val_integer2 (*cu
);
10399 #if FFETARGET_okINTEGER3
10400 case FFEINFO_kindtypeINTEGER3
:
10401 val
= ffebld_cu_val_integer3 (*cu
);
10405 #if FFETARGET_okINTEGER4
10406 case FFEINFO_kindtypeINTEGER4
:
10407 val
= ffebld_cu_val_integer4 (*cu
);
10412 assert ("bad INTEGER constant kind type" == NULL
);
10413 /* Fall through. */
10414 case FFEINFO_kindtypeANY
:
10415 return error_mark_node
;
10417 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
10418 TREE_TYPE (item
) = tree_type
;
10422 case FFEINFO_basictypeLOGICAL
:
10428 #if FFETARGET_okLOGICAL1
10429 case FFEINFO_kindtypeLOGICAL1
:
10430 val
= ffebld_cu_val_logical1 (*cu
);
10434 #if FFETARGET_okLOGICAL2
10435 case FFEINFO_kindtypeLOGICAL2
:
10436 val
= ffebld_cu_val_logical2 (*cu
);
10440 #if FFETARGET_okLOGICAL3
10441 case FFEINFO_kindtypeLOGICAL3
:
10442 val
= ffebld_cu_val_logical3 (*cu
);
10446 #if FFETARGET_okLOGICAL4
10447 case FFEINFO_kindtypeLOGICAL4
:
10448 val
= ffebld_cu_val_logical4 (*cu
);
10453 assert ("bad LOGICAL constant kind type" == NULL
);
10454 /* Fall through. */
10455 case FFEINFO_kindtypeANY
:
10456 return error_mark_node
;
10458 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
10459 TREE_TYPE (item
) = tree_type
;
10463 case FFEINFO_basictypeREAL
:
10465 REAL_VALUE_TYPE val
;
10469 #if FFETARGET_okREAL1
10470 case FFEINFO_kindtypeREAL1
:
10471 val
= ffetarget_value_real1 (ffebld_cu_val_real1 (*cu
));
10475 #if FFETARGET_okREAL2
10476 case FFEINFO_kindtypeREAL2
:
10477 val
= ffetarget_value_real2 (ffebld_cu_val_real2 (*cu
));
10481 #if FFETARGET_okREAL3
10482 case FFEINFO_kindtypeREAL3
:
10483 val
= ffetarget_value_real3 (ffebld_cu_val_real3 (*cu
));
10487 #if FFETARGET_okREAL4
10488 case FFEINFO_kindtypeREAL4
:
10489 val
= ffetarget_value_real4 (ffebld_cu_val_real4 (*cu
));
10494 assert ("bad REAL constant kind type" == NULL
);
10495 /* Fall through. */
10496 case FFEINFO_kindtypeANY
:
10497 return error_mark_node
;
10499 item
= build_real (tree_type
, val
);
10503 case FFEINFO_basictypeCOMPLEX
:
10505 REAL_VALUE_TYPE real
;
10506 REAL_VALUE_TYPE imag
;
10507 tree el_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
10511 #if FFETARGET_okCOMPLEX1
10512 case FFEINFO_kindtypeREAL1
:
10513 real
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).real
);
10514 imag
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).imaginary
);
10518 #if FFETARGET_okCOMPLEX2
10519 case FFEINFO_kindtypeREAL2
:
10520 real
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).real
);
10521 imag
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).imaginary
);
10525 #if FFETARGET_okCOMPLEX3
10526 case FFEINFO_kindtypeREAL3
:
10527 real
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).real
);
10528 imag
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).imaginary
);
10532 #if FFETARGET_okCOMPLEX4
10533 case FFEINFO_kindtypeREAL4
:
10534 real
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).real
);
10535 imag
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).imaginary
);
10540 assert ("bad REAL constant kind type" == NULL
);
10541 /* Fall through. */
10542 case FFEINFO_kindtypeANY
:
10543 return error_mark_node
;
10545 item
= ffecom_build_complex_constant_ (tree_type
,
10546 build_real (el_type
, real
),
10547 build_real (el_type
, imag
));
10551 case FFEINFO_basictypeCHARACTER
:
10552 { /* Happens only in DATA and similar contexts. */
10553 ffetargetCharacter1 val
;
10557 #if FFETARGET_okCHARACTER1
10558 case FFEINFO_kindtypeLOGICAL1
:
10559 val
= ffebld_cu_val_character1 (*cu
);
10564 assert ("bad CHARACTER constant kind type" == NULL
);
10565 /* Fall through. */
10566 case FFEINFO_kindtypeANY
:
10567 return error_mark_node
;
10569 item
= build_string (ffetarget_length_character1 (val
),
10570 ffetarget_text_character1 (val
));
10572 = build_type_variant (build_array_type (char_type_node
,
10574 (integer_type_node
,
10577 (ffetarget_length_character1
10583 case FFEINFO_basictypeHOLLERITH
:
10585 ffetargetHollerith h
;
10587 h
= ffebld_cu_val_hollerith (*cu
);
10589 /* If not at least as wide as default INTEGER, widen it. */
10590 if (h
.length
>= FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
)
10591 item
= build_string (h
.length
, h
.text
);
10594 char str
[FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
];
10596 memcpy (str
, h
.text
, h
.length
);
10597 memset (&str
[h
.length
], ' ',
10598 FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
10600 item
= build_string (FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
,
10604 = build_type_variant (build_array_type (char_type_node
,
10606 (integer_type_node
,
10614 case FFEINFO_basictypeTYPELESS
:
10616 ffetargetInteger1 ival
;
10617 ffetargetTypeless tless
;
10620 tless
= ffebld_cu_val_typeless (*cu
);
10621 error
= ffetarget_convert_integer1_typeless (&ival
, tless
);
10622 assert (error
== FFEBAD
);
10624 item
= build_int_2 ((int) ival
, 0);
10629 assert ("not yet on constant type" == NULL
);
10630 /* Fall through. */
10631 case FFEINFO_basictypeANY
:
10632 return error_mark_node
;
10635 TREE_CONSTANT (item
) = 1;
10640 /* Transform expression into constant tree.
10642 If the expression can be transformed into a tree that is constant,
10643 that is done, and the tree returned. Else NULL_TREE is returned.
10645 That way, a caller can attempt to provide compile-time initialization
10646 of a variable and, if that fails, *then* choose to start a new block
10647 and resort to using temporaries, as appropriate. */
10650 ffecom_const_expr (ffebld expr
)
10653 return integer_zero_node
;
10655 if (ffebld_op (expr
) == FFEBLD_opANY
)
10656 return error_mark_node
;
10658 if (ffebld_arity (expr
) == 0
10659 && (ffebld_op (expr
) != FFEBLD_opSYMTER
10661 /* ~~Enable once common/equivalence is handled properly? */
10662 || ffebld_where (expr
) == FFEINFO_whereCOMMON
10664 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
10665 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
10669 t
= ffecom_expr (expr
);
10670 assert (TREE_CONSTANT (t
));
10677 /* Handy way to make a field in a struct/union. */
10680 ffecom_decl_field (tree context
, tree prevfield
,
10681 const char *name
, tree type
)
10685 field
= build_decl (FIELD_DECL
, get_identifier (name
), type
);
10686 DECL_CONTEXT (field
) = context
;
10687 DECL_ALIGN (field
) = 0;
10688 DECL_USER_ALIGN (field
) = 0;
10689 if (prevfield
!= NULL_TREE
)
10690 TREE_CHAIN (prevfield
) = field
;
10696 ffecom_close_include (FILE *f
)
10698 ffecom_close_include_ (f
);
10702 ffecom_decode_include_option (char *spec
)
10704 return ffecom_decode_include_option_ (spec
);
10707 /* End a compound statement (block). */
10710 ffecom_end_compstmt (void)
10712 return bison_rule_compstmt_ ();
10715 /* ffecom_end_transition -- Perform end transition on all symbols
10717 ffecom_end_transition();
10719 Calls ffecom_sym_end_transition for each global and local symbol. */
10722 ffecom_end_transition ()
10726 if (ffe_is_ffedebug ())
10727 fprintf (dmpout
, "; end_stmt_transition\n");
10729 ffecom_list_blockdata_
= NULL
;
10730 ffecom_list_common_
= NULL
;
10732 ffesymbol_drive (ffecom_sym_end_transition
);
10733 if (ffe_is_ffedebug ())
10735 ffestorag_report ();
10738 ffecom_start_progunit_ ();
10740 for (item
= ffecom_list_blockdata_
;
10742 item
= ffebld_trail (item
))
10749 static int number
= 0;
10751 callee
= ffebld_head (item
);
10752 s
= ffebld_symter (callee
);
10753 t
= ffesymbol_hook (s
).decl_tree
;
10754 if (t
== NULL_TREE
)
10756 s
= ffecom_sym_transform_ (s
);
10757 t
= ffesymbol_hook (s
).decl_tree
;
10760 dt
= build_pointer_type (TREE_TYPE (t
));
10762 var
= build_decl (VAR_DECL
,
10763 ffecom_get_invented_identifier ("__g77_forceload_%d",
10766 DECL_EXTERNAL (var
) = 0;
10767 TREE_STATIC (var
) = 1;
10768 TREE_PUBLIC (var
) = 0;
10769 DECL_INITIAL (var
) = error_mark_node
;
10770 TREE_USED (var
) = 1;
10772 var
= start_decl (var
, FALSE
);
10774 t
= ffecom_1 (ADDR_EXPR
, dt
, t
);
10776 finish_decl (var
, t
, FALSE
);
10779 /* This handles any COMMON areas that weren't referenced but have, for
10780 example, important initial data. */
10782 for (item
= ffecom_list_common_
;
10784 item
= ffebld_trail (item
))
10785 ffecom_transform_common_ (ffebld_symter (ffebld_head (item
)));
10787 ffecom_list_common_
= NULL
;
10790 /* ffecom_exec_transition -- Perform exec transition on all symbols
10792 ffecom_exec_transition();
10794 Calls ffecom_sym_exec_transition for each global and local symbol.
10795 Make sure error updating not inhibited. */
10798 ffecom_exec_transition ()
10802 if (ffe_is_ffedebug ())
10803 fprintf (dmpout
, "; exec_stmt_transition\n");
10805 inhibited
= ffebad_inhibit ();
10806 ffebad_set_inhibit (FALSE
);
10808 ffesymbol_drive (ffecom_sym_exec_transition
); /* Don't retract! */
10809 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
10810 if (ffe_is_ffedebug ())
10812 ffestorag_report ();
10816 ffebad_set_inhibit (TRUE
);
10819 /* Handle assignment statement.
10821 Convert dest and source using ffecom_expr, then join them
10822 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
10825 ffecom_expand_let_stmt (ffebld dest
, ffebld source
)
10832 if (ffeinfo_basictype (ffebld_info (dest
)) != FFEINFO_basictypeCHARACTER
)
10837 /* This attempts to replicate the test below, but must not be
10838 true when the test below is false. (Always err on the side
10839 of creating unused temporaries, to avoid ICEs.) */
10840 if (ffebld_op (dest
) != FFEBLD_opSYMTER
10841 || ((dest_tree
= ffesymbol_hook (ffebld_symter (dest
)).decl_tree
)
10842 && (TREE_CODE (dest_tree
) != VAR_DECL
10843 || TREE_ADDRESSABLE (dest_tree
))))
10845 ffecom_prepare_expr_ (source
, dest
);
10850 ffecom_prepare_expr_ (source
, NULL
);
10854 ffecom_prepare_expr_w (NULL_TREE
, dest
);
10856 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10857 create a temporary through which the assignment is to take place,
10858 since MODIFY_EXPR doesn't handle partial overlap properly. */
10859 if (ffebld_basictype (dest
) == FFEINFO_basictypeCOMPLEX
10860 && ffecom_possible_partial_overlap_ (dest
, source
))
10862 assign_temp
= ffecom_make_tempvar ("complex_let",
10864 [ffebld_basictype (dest
)]
10865 [ffebld_kindtype (dest
)],
10866 FFETARGET_charactersizeNONE
,
10870 assign_temp
= NULL_TREE
;
10872 ffecom_prepare_end ();
10874 dest_tree
= ffecom_expr_w (NULL_TREE
, dest
);
10875 if (dest_tree
== error_mark_node
)
10878 if ((TREE_CODE (dest_tree
) != VAR_DECL
)
10879 || TREE_ADDRESSABLE (dest_tree
))
10880 source_tree
= ffecom_expr_ (source
, dest_tree
, dest
, &dest_used
,
10884 assert (! dest_used
);
10886 source_tree
= ffecom_expr (source
);
10888 if (source_tree
== error_mark_node
)
10892 expr_tree
= source_tree
;
10893 else if (assign_temp
)
10896 /* The back end understands a conceptual move (evaluate source;
10897 store into dest), so use that, in case it can determine
10898 that it is going to use, say, two registers as temporaries
10899 anyway. So don't use the temp (and someday avoid generating
10900 it, once this code starts triggering regularly). */
10901 expr_tree
= ffecom_2s (MOVE_EXPR
, void_type_node
,
10905 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
10908 expand_expr_stmt (expr_tree
);
10909 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
10915 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
10919 expand_expr_stmt (expr_tree
);
10923 ffecom_prepare_let_char_ (ffebld_size_known (dest
), source
);
10924 ffecom_prepare_expr_w (NULL_TREE
, dest
);
10926 ffecom_prepare_end ();
10928 ffecom_char_args_ (&dest_tree
, &dest_length
, dest
);
10929 ffecom_let_char_ (dest_tree
, dest_length
, ffebld_size_known (dest
),
10933 /* ffecom_expr -- Transform expr into gcc tree
10936 ffebld expr; // FFE expression.
10937 tree = ffecom_expr(expr);
10939 Recursive descent on expr while making corresponding tree nodes and
10940 attaching type info and such. */
10943 ffecom_expr (ffebld expr
)
10945 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, FALSE
, FALSE
);
10948 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
10951 ffecom_expr_assign (ffebld expr
)
10953 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
10956 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
10959 ffecom_expr_assign_w (ffebld expr
)
10961 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
10964 /* Transform expr for use as into read/write tree and stabilize the
10965 reference. Not for use on CHARACTER expressions.
10967 Recursive descent on expr while making corresponding tree nodes and
10968 attaching type info and such. */
10971 ffecom_expr_rw (tree type
, ffebld expr
)
10973 assert (expr
!= NULL
);
10974 /* Different target types not yet supported. */
10975 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
10977 return stabilize_reference (ffecom_expr (expr
));
10980 /* Transform expr for use as into write tree and stabilize the
10981 reference. Not for use on CHARACTER expressions.
10983 Recursive descent on expr while making corresponding tree nodes and
10984 attaching type info and such. */
10987 ffecom_expr_w (tree type
, ffebld expr
)
10989 assert (expr
!= NULL
);
10990 /* Different target types not yet supported. */
10991 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
10993 return stabilize_reference (ffecom_expr (expr
));
10996 /* Do global stuff. */
10999 ffecom_finish_compile ()
11001 assert (ffecom_outer_function_decl_
== NULL_TREE
);
11002 assert (current_function_decl
== NULL_TREE
);
11004 ffeglobal_drive (ffecom_finish_global_
);
11007 /* Public entry point for front end to access finish_decl. */
11010 ffecom_finish_decl (tree decl
, tree init
, bool is_top_level
)
11012 assert (!is_top_level
);
11013 finish_decl (decl
, init
, FALSE
);
11016 /* Finish a program unit. */
11019 ffecom_finish_progunit ()
11021 ffecom_end_compstmt ();
11023 ffecom_previous_function_decl_
= current_function_decl
;
11024 ffecom_which_entrypoint_decl_
= NULL_TREE
;
11026 finish_function (0);
11029 /* Wrapper for get_identifier. pattern is sprintf-like. */
11032 ffecom_get_invented_identifier (const char *pattern
, ...)
11038 va_start (ap
, pattern
);
11039 if (vasprintf (&nam
, pattern
, ap
) == 0)
11042 decl
= get_identifier (nam
);
11044 IDENTIFIER_INVENTED (decl
) = 1;
11049 ffecom_gfrt_basictype (ffecomGfrt gfrt
)
11051 assert (gfrt
< FFECOM_gfrt
);
11053 switch (ffecom_gfrt_type_
[gfrt
])
11055 case FFECOM_rttypeVOID_
:
11056 case FFECOM_rttypeVOIDSTAR_
:
11057 return FFEINFO_basictypeNONE
;
11059 case FFECOM_rttypeFTNINT_
:
11060 return FFEINFO_basictypeINTEGER
;
11062 case FFECOM_rttypeINTEGER_
:
11063 return FFEINFO_basictypeINTEGER
;
11065 case FFECOM_rttypeLONGINT_
:
11066 return FFEINFO_basictypeINTEGER
;
11068 case FFECOM_rttypeLOGICAL_
:
11069 return FFEINFO_basictypeLOGICAL
;
11071 case FFECOM_rttypeREAL_F2C_
:
11072 case FFECOM_rttypeREAL_GNU_
:
11073 return FFEINFO_basictypeREAL
;
11075 case FFECOM_rttypeCOMPLEX_F2C_
:
11076 case FFECOM_rttypeCOMPLEX_GNU_
:
11077 return FFEINFO_basictypeCOMPLEX
;
11079 case FFECOM_rttypeDOUBLE_
:
11080 case FFECOM_rttypeDOUBLEREAL_
:
11081 return FFEINFO_basictypeREAL
;
11083 case FFECOM_rttypeDBLCMPLX_F2C_
:
11084 case FFECOM_rttypeDBLCMPLX_GNU_
:
11085 return FFEINFO_basictypeCOMPLEX
;
11087 case FFECOM_rttypeCHARACTER_
:
11088 return FFEINFO_basictypeCHARACTER
;
11091 return FFEINFO_basictypeANY
;
11096 ffecom_gfrt_kindtype (ffecomGfrt gfrt
)
11098 assert (gfrt
< FFECOM_gfrt
);
11100 switch (ffecom_gfrt_type_
[gfrt
])
11102 case FFECOM_rttypeVOID_
:
11103 case FFECOM_rttypeVOIDSTAR_
:
11104 return FFEINFO_kindtypeNONE
;
11106 case FFECOM_rttypeFTNINT_
:
11107 return FFEINFO_kindtypeINTEGER1
;
11109 case FFECOM_rttypeINTEGER_
:
11110 return FFEINFO_kindtypeINTEGER1
;
11112 case FFECOM_rttypeLONGINT_
:
11113 return FFEINFO_kindtypeINTEGER4
;
11115 case FFECOM_rttypeLOGICAL_
:
11116 return FFEINFO_kindtypeLOGICAL1
;
11118 case FFECOM_rttypeREAL_F2C_
:
11119 case FFECOM_rttypeREAL_GNU_
:
11120 return FFEINFO_kindtypeREAL1
;
11122 case FFECOM_rttypeCOMPLEX_F2C_
:
11123 case FFECOM_rttypeCOMPLEX_GNU_
:
11124 return FFEINFO_kindtypeREAL1
;
11126 case FFECOM_rttypeDOUBLE_
:
11127 case FFECOM_rttypeDOUBLEREAL_
:
11128 return FFEINFO_kindtypeREAL2
;
11130 case FFECOM_rttypeDBLCMPLX_F2C_
:
11131 case FFECOM_rttypeDBLCMPLX_GNU_
:
11132 return FFEINFO_kindtypeREAL2
;
11134 case FFECOM_rttypeCHARACTER_
:
11135 return FFEINFO_kindtypeCHARACTER1
;
11138 return FFEINFO_kindtypeANY
;
11152 tree double_ftype_double
;
11153 tree float_ftype_float
;
11154 tree ldouble_ftype_ldouble
;
11155 tree ffecom_tree_ptr_to_fun_type_void
;
11157 /* This block of code comes from the now-obsolete cktyps.c. It checks
11158 whether the compiler environment is buggy in known ways, some of which
11159 would, if not explicitly checked here, result in subtle bugs in g77. */
11161 if (ffe_is_do_internal_checks ())
11163 static const char names
[][12]
11165 {"bar", "bletch", "foo", "foobar"};
11170 name
= bsearch ("foo", &names
[0], ARRAY_SIZE (names
), sizeof (names
[0]),
11171 (int (*)(const void *, const void *)) strcmp
);
11172 if (name
!= &names
[0][2])
11174 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11179 ul
= strtoul ("123456789", NULL
, 10);
11180 if (ul
!= 123456789L)
11182 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11183 in proj.h" == NULL
);
11187 fl
= atof ("56.789");
11188 if ((fl
< 56.788) || (fl
> 56.79))
11190 assert ("atof not type double, fix your #include <stdio.h>"
11196 ffecom_outer_function_decl_
= NULL_TREE
;
11197 current_function_decl
= NULL_TREE
;
11198 named_labels
= NULL_TREE
;
11199 current_binding_level
= NULL_BINDING_LEVEL
;
11200 free_binding_level
= NULL_BINDING_LEVEL
;
11201 /* Make the binding_level structure for global names. */
11203 global_binding_level
= current_binding_level
;
11204 current_binding_level
->prep_state
= 2;
11206 build_common_tree_nodes (1);
11208 /* Define `int' and `char' first so that dbx will output them first. */
11209 pushdecl (build_decl (TYPE_DECL
, get_identifier ("int"),
11210 integer_type_node
));
11211 /* CHARACTER*1 is unsigned in ICHAR contexts. */
11212 char_type_node
= make_unsigned_type (CHAR_TYPE_SIZE
);
11213 pushdecl (build_decl (TYPE_DECL
, get_identifier ("char"),
11215 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long int"),
11216 long_integer_type_node
));
11217 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned int"),
11218 unsigned_type_node
));
11219 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long unsigned int"),
11220 long_unsigned_type_node
));
11221 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long int"),
11222 long_long_integer_type_node
));
11223 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long unsigned int"),
11224 long_long_unsigned_type_node
));
11225 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short int"),
11226 short_integer_type_node
));
11227 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short unsigned int"),
11228 short_unsigned_type_node
));
11230 /* Set the sizetype before we make other types. This *should* be the
11231 first type we create. */
11234 (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE
))));
11235 ffecom_typesize_pointer_
11236 = TREE_INT_CST_LOW (TYPE_SIZE (sizetype
)) / BITS_PER_UNIT
;
11238 build_common_tree_nodes_2 (0);
11240 /* Define both `signed char' and `unsigned char'. */
11241 pushdecl (build_decl (TYPE_DECL
, get_identifier ("signed char"),
11242 signed_char_type_node
));
11244 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned char"),
11245 unsigned_char_type_node
));
11247 pushdecl (build_decl (TYPE_DECL
, get_identifier ("float"),
11249 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double"),
11250 double_type_node
));
11251 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long double"),
11252 long_double_type_node
));
11254 /* For now, override what build_common_tree_nodes has done. */
11255 complex_integer_type_node
= ffecom_make_complex_type_ (integer_type_node
);
11256 complex_float_type_node
= ffecom_make_complex_type_ (float_type_node
);
11257 complex_double_type_node
= ffecom_make_complex_type_ (double_type_node
);
11258 complex_long_double_type_node
11259 = ffecom_make_complex_type_ (long_double_type_node
);
11261 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex int"),
11262 complex_integer_type_node
));
11263 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex float"),
11264 complex_float_type_node
));
11265 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex double"),
11266 complex_double_type_node
));
11267 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex long double"),
11268 complex_long_double_type_node
));
11270 pushdecl (build_decl (TYPE_DECL
, get_identifier ("void"),
11272 /* We are not going to have real types in C with less than byte alignment,
11273 so we might as well not have any types that claim to have it. */
11274 TYPE_ALIGN (void_type_node
) = BITS_PER_UNIT
;
11275 TYPE_USER_ALIGN (void_type_node
) = 0;
11277 string_type_node
= build_pointer_type (char_type_node
);
11279 ffecom_tree_fun_type_void
11280 = build_function_type (void_type_node
, NULL_TREE
);
11282 ffecom_tree_ptr_to_fun_type_void
11283 = build_pointer_type (ffecom_tree_fun_type_void
);
11285 endlink
= tree_cons (NULL_TREE
, void_type_node
, NULL_TREE
);
11288 = build_function_type (float_type_node
,
11289 tree_cons (NULL_TREE
, float_type_node
, endlink
));
11291 double_ftype_double
11292 = build_function_type (double_type_node
,
11293 tree_cons (NULL_TREE
, double_type_node
, endlink
));
11295 ldouble_ftype_ldouble
11296 = build_function_type (long_double_type_node
,
11297 tree_cons (NULL_TREE
, long_double_type_node
,
11300 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11301 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11303 ffecom_tree_type
[i
][j
] = NULL_TREE
;
11304 ffecom_tree_fun_type
[i
][j
] = NULL_TREE
;
11305 ffecom_tree_ptr_to_fun_type
[i
][j
] = NULL_TREE
;
11306 ffecom_f2c_typecode_
[i
][j
] = -1;
11309 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11310 to size FLOAT_TYPE_SIZE because they have to be the same size as
11311 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11312 Compiler options and other such stuff that change the ways these
11313 types are set should not affect this particular setup. */
11315 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
]
11316 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
11317 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer"),
11319 type
= ffetype_new ();
11321 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER1
,
11323 ffetype_set_ams (type
,
11324 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11325 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11326 ffetype_set_star (base_type
,
11327 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11329 ffetype_set_kind (base_type
, 1, type
);
11330 ffecom_typesize_integer1_
= ffetype_size (type
);
11331 assert (ffetype_size (type
) == sizeof (ffetargetInteger1
));
11333 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER1
]
11334 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
); /* HOLLERITH means unsigned. */
11335 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned"),
11338 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER2
]
11339 = t
= make_signed_type (CHAR_TYPE_SIZE
);
11340 pushdecl (build_decl (TYPE_DECL
, get_identifier ("byte"),
11342 type
= ffetype_new ();
11343 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER2
,
11345 ffetype_set_ams (type
,
11346 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11347 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11348 ffetype_set_star (base_type
,
11349 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11351 ffetype_set_kind (base_type
, 3, type
);
11352 assert (ffetype_size (type
) == sizeof (ffetargetInteger2
));
11354 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER2
]
11355 = t
= make_unsigned_type (CHAR_TYPE_SIZE
);
11356 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned byte"),
11359 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER3
]
11360 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
11361 pushdecl (build_decl (TYPE_DECL
, get_identifier ("word"),
11363 type
= ffetype_new ();
11364 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER3
,
11366 ffetype_set_ams (type
,
11367 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11368 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11369 ffetype_set_star (base_type
,
11370 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11372 ffetype_set_kind (base_type
, 6, type
);
11373 assert (ffetype_size (type
) == sizeof (ffetargetInteger3
));
11375 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER3
]
11376 = t
= make_unsigned_type (CHAR_TYPE_SIZE
* 2);
11377 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned word"),
11380 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER4
]
11381 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
11382 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer4"),
11384 type
= ffetype_new ();
11385 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER4
,
11387 ffetype_set_ams (type
,
11388 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11389 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11390 ffetype_set_star (base_type
,
11391 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11393 ffetype_set_kind (base_type
, 2, type
);
11394 assert (ffetype_size (type
) == sizeof (ffetargetInteger4
));
11396 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER4
]
11397 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
* 2);
11398 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned4"),
11402 if (ffe_is_do_internal_checks ()
11403 && LONG_TYPE_SIZE
!= FLOAT_TYPE_SIZE
11404 && LONG_TYPE_SIZE
!= CHAR_TYPE_SIZE
11405 && LONG_TYPE_SIZE
!= SHORT_TYPE_SIZE
11406 && LONG_TYPE_SIZE
!= LONG_LONG_TYPE_SIZE
)
11408 fprintf (stderr
, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11413 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL1
]
11414 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
11415 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical"),
11417 type
= ffetype_new ();
11419 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL1
,
11421 ffetype_set_ams (type
,
11422 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11423 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11424 ffetype_set_star (base_type
,
11425 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11427 ffetype_set_kind (base_type
, 1, type
);
11428 assert (ffetype_size (type
) == sizeof (ffetargetLogical1
));
11430 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL2
]
11431 = t
= make_signed_type (CHAR_TYPE_SIZE
);
11432 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical2"),
11434 type
= ffetype_new ();
11435 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL2
,
11437 ffetype_set_ams (type
,
11438 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11439 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11440 ffetype_set_star (base_type
,
11441 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11443 ffetype_set_kind (base_type
, 3, type
);
11444 assert (ffetype_size (type
) == sizeof (ffetargetLogical2
));
11446 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL3
]
11447 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
11448 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical3"),
11450 type
= ffetype_new ();
11451 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL3
,
11453 ffetype_set_ams (type
,
11454 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11455 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11456 ffetype_set_star (base_type
,
11457 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11459 ffetype_set_kind (base_type
, 6, type
);
11460 assert (ffetype_size (type
) == sizeof (ffetargetLogical3
));
11462 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL4
]
11463 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
11464 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical4"),
11466 type
= ffetype_new ();
11467 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL4
,
11469 ffetype_set_ams (type
,
11470 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11471 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11472 ffetype_set_star (base_type
,
11473 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11475 ffetype_set_kind (base_type
, 2, type
);
11476 assert (ffetype_size (type
) == sizeof (ffetargetLogical4
));
11478 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
11479 = t
= make_node (REAL_TYPE
);
11480 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
;
11481 pushdecl (build_decl (TYPE_DECL
, get_identifier ("real"),
11484 type
= ffetype_new ();
11486 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREAL1
,
11488 ffetype_set_ams (type
,
11489 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11490 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11491 ffetype_set_star (base_type
,
11492 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11494 ffetype_set_kind (base_type
, 1, type
);
11495 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
11496 = FFETARGET_f2cTYREAL
;
11497 assert (ffetype_size (type
) == sizeof (ffetargetReal1
));
11499 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREALDOUBLE
]
11500 = t
= make_node (REAL_TYPE
);
11501 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
* 2; /* Always twice REAL. */
11502 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double precision"),
11505 type
= ffetype_new ();
11506 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREALDOUBLE
,
11508 ffetype_set_ams (type
,
11509 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11510 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11511 ffetype_set_star (base_type
,
11512 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11514 ffetype_set_kind (base_type
, 2, type
);
11515 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]
11516 = FFETARGET_f2cTYDREAL
;
11517 assert (ffetype_size (type
) == sizeof (ffetargetReal2
));
11519 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
11520 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]);
11521 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex"),
11523 type
= ffetype_new ();
11525 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREAL1
,
11527 ffetype_set_ams (type
,
11528 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11529 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11530 ffetype_set_star (base_type
,
11531 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11533 ffetype_set_kind (base_type
, 1, type
);
11534 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
11535 = FFETARGET_f2cTYCOMPLEX
;
11536 assert (ffetype_size (type
) == sizeof (ffetargetComplex1
));
11538 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREALDOUBLE
]
11539 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]);
11540 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double complex"),
11542 type
= ffetype_new ();
11543 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREALDOUBLE
,
11545 ffetype_set_ams (type
,
11546 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11547 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11548 ffetype_set_star (base_type
,
11549 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11551 ffetype_set_kind (base_type
, 2,
11553 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL2
]
11554 = FFETARGET_f2cTYDCOMPLEX
;
11555 assert (ffetype_size (type
) == sizeof (ffetargetComplex2
));
11557 /* Make function and ptr-to-function types for non-CHARACTER types. */
11559 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11560 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11562 if ((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
11564 if (i
== FFEINFO_basictypeINTEGER
)
11566 /* Figure out the smallest INTEGER type that can hold
11567 a pointer on this machine. */
11568 if (GET_MODE_SIZE (TYPE_MODE (t
))
11569 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
11571 if ((ffecom_pointer_kind_
== FFEINFO_kindtypeNONE
)
11572 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type
[i
][ffecom_pointer_kind_
]))
11573 > GET_MODE_SIZE (TYPE_MODE (t
))))
11574 ffecom_pointer_kind_
= j
;
11577 else if (i
== FFEINFO_basictypeCOMPLEX
)
11578 t
= void_type_node
;
11579 /* For f2c compatibility, REAL functions are really
11580 implemented as DOUBLE PRECISION. */
11581 else if ((i
== FFEINFO_basictypeREAL
)
11582 && (j
== FFEINFO_kindtypeREAL1
))
11583 t
= ffecom_tree_type
11584 [FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
];
11586 t
= ffecom_tree_fun_type
[i
][j
] = build_function_type (t
,
11588 ffecom_tree_ptr_to_fun_type
[i
][j
] = build_pointer_type (t
);
11592 /* Set up pointer types. */
11594 if (ffecom_pointer_kind_
== FFEINFO_basictypeNONE
)
11595 fatal_error ("no INTEGER type can hold a pointer on this configuration");
11596 else if (0 && ffe_is_do_internal_checks ())
11597 fprintf (stderr
, "Pointer type kt=%d\n", ffecom_pointer_kind_
);
11598 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER
,
11599 FFEINFO_kindtypeINTEGERDEFAULT
),
11601 ffeinfo_type (FFEINFO_basictypeINTEGER
,
11602 ffecom_pointer_kind_
));
11604 if (ffe_is_ugly_assign ())
11605 ffecom_label_kind_
= ffecom_pointer_kind_
; /* Require ASSIGN etc to this. */
11607 ffecom_label_kind_
= FFEINFO_kindtypeINTEGERDEFAULT
;
11608 if (0 && ffe_is_do_internal_checks ())
11609 fprintf (stderr
, "Label type kt=%d\n", ffecom_label_kind_
);
11611 ffecom_integer_type_node
11612 = ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
];
11613 ffecom_integer_zero_node
= convert (ffecom_integer_type_node
,
11614 integer_zero_node
);
11615 ffecom_integer_one_node
= convert (ffecom_integer_type_node
,
11618 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11619 Turns out that by TYLONG, runtime/libI77/lio.h really means
11620 "whatever size an ftnint is". For consistency and sanity,
11621 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11622 all are INTEGER, which we also make out of whatever back-end
11623 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11624 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11625 accommodate machines like the Alpha. Note that this suggests
11626 f2c and libf2c are missing a distinction perhaps needed on
11627 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11629 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, FLOAT_TYPE_SIZE
,
11630 FFETARGET_f2cTYLONG
);
11631 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, SHORT_TYPE_SIZE
,
11632 FFETARGET_f2cTYSHORT
);
11633 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, CHAR_TYPE_SIZE
,
11634 FFETARGET_f2cTYINT1
);
11635 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, LONG_LONG_TYPE_SIZE
,
11636 FFETARGET_f2cTYQUAD
);
11637 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, FLOAT_TYPE_SIZE
,
11638 FFETARGET_f2cTYLOGICAL
);
11639 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, SHORT_TYPE_SIZE
,
11640 FFETARGET_f2cTYLOGICAL2
);
11641 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, CHAR_TYPE_SIZE
,
11642 FFETARGET_f2cTYLOGICAL1
);
11643 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11644 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, LONG_LONG_TYPE_SIZE
,
11645 FFETARGET_f2cTYQUAD
);
11647 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11648 loop. CHARACTER items are built as arrays of unsigned char. */
11650 ffecom_tree_type
[FFEINFO_basictypeCHARACTER
]
11651 [FFEINFO_kindtypeCHARACTER1
] = t
= char_type_node
;
11652 type
= ffetype_new ();
11654 ffeinfo_set_type (FFEINFO_basictypeCHARACTER
,
11655 FFEINFO_kindtypeCHARACTER1
,
11657 ffetype_set_ams (type
,
11658 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11659 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11660 ffetype_set_kind (base_type
, 1, type
);
11661 assert (ffetype_size (type
)
11662 == sizeof (((ffetargetCharacter1
) { 0, NULL
}).text
[0]));
11664 ffecom_tree_fun_type
[FFEINFO_basictypeCHARACTER
]
11665 [FFEINFO_kindtypeCHARACTER1
] = ffecom_tree_fun_type_void
;
11666 ffecom_tree_ptr_to_fun_type
[FFEINFO_basictypeCHARACTER
]
11667 [FFEINFO_kindtypeCHARACTER1
]
11668 = ffecom_tree_ptr_to_fun_type_void
;
11669 ffecom_f2c_typecode_
[FFEINFO_basictypeCHARACTER
][FFEINFO_kindtypeCHARACTER1
]
11670 = FFETARGET_f2cTYCHAR
;
11672 ffecom_f2c_typecode_
[FFEINFO_basictypeANY
][FFEINFO_kindtypeANY
]
11675 /* Make multi-return-value type and fields. */
11677 ffecom_multi_type_node_
= make_node (UNION_TYPE
);
11681 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11682 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11686 if (ffecom_tree_type
[i
][j
] == NULL_TREE
)
11687 continue; /* Not supported. */
11688 sprintf (&name
[0], "bt_%s_kt_%s",
11689 ffeinfo_basictype_string ((ffeinfoBasictype
) i
),
11690 ffeinfo_kindtype_string ((ffeinfoKindtype
) j
));
11691 ffecom_multi_fields_
[i
][j
] = build_decl (FIELD_DECL
,
11692 get_identifier (name
),
11693 ffecom_tree_type
[i
][j
]);
11694 DECL_CONTEXT (ffecom_multi_fields_
[i
][j
])
11695 = ffecom_multi_type_node_
;
11696 DECL_ALIGN (ffecom_multi_fields_
[i
][j
]) = 0;
11697 DECL_USER_ALIGN (ffecom_multi_fields_
[i
][j
]) = 0;
11698 TREE_CHAIN (ffecom_multi_fields_
[i
][j
]) = field
;
11699 field
= ffecom_multi_fields_
[i
][j
];
11702 TYPE_FIELDS (ffecom_multi_type_node_
) = field
;
11703 layout_type (ffecom_multi_type_node_
);
11705 /* Subroutines usually return integer because they might have alternate
11708 ffecom_tree_subr_type
11709 = build_function_type (integer_type_node
, NULL_TREE
);
11710 ffecom_tree_ptr_to_subr_type
11711 = build_pointer_type (ffecom_tree_subr_type
);
11712 ffecom_tree_blockdata_type
11713 = build_function_type (void_type_node
, NULL_TREE
);
11715 builtin_function ("__builtin_sqrtf", float_ftype_float
,
11716 BUILT_IN_SQRTF
, BUILT_IN_NORMAL
, "sqrtf");
11717 builtin_function ("__builtin_sqrt", double_ftype_double
,
11718 BUILT_IN_SQRT
, BUILT_IN_NORMAL
, "sqrt");
11719 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble
,
11720 BUILT_IN_SQRTL
, BUILT_IN_NORMAL
, "sqrtl");
11721 builtin_function ("__builtin_sinf", float_ftype_float
,
11722 BUILT_IN_SINF
, BUILT_IN_NORMAL
, "sinf");
11723 builtin_function ("__builtin_sin", double_ftype_double
,
11724 BUILT_IN_SIN
, BUILT_IN_NORMAL
, "sin");
11725 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble
,
11726 BUILT_IN_SINL
, BUILT_IN_NORMAL
, "sinl");
11727 builtin_function ("__builtin_cosf", float_ftype_float
,
11728 BUILT_IN_COSF
, BUILT_IN_NORMAL
, "cosf");
11729 builtin_function ("__builtin_cos", double_ftype_double
,
11730 BUILT_IN_COS
, BUILT_IN_NORMAL
, "cos");
11731 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble
,
11732 BUILT_IN_COSL
, BUILT_IN_NORMAL
, "cosl");
11734 pedantic_lvalues
= FALSE
;
11736 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node
,
11739 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node
,
11742 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node
,
11745 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node
,
11746 FFECOM_f2cDOUBLEREAL
,
11748 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node
,
11751 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node
,
11752 FFECOM_f2cDOUBLECOMPLEX
,
11754 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node
,
11757 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node
,
11760 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node
,
11763 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node
,
11766 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node
,
11770 ffecom_f2c_ftnlen_zero_node
11771 = convert (ffecom_f2c_ftnlen_type_node
, integer_zero_node
);
11773 ffecom_f2c_ftnlen_one_node
11774 = convert (ffecom_f2c_ftnlen_type_node
, integer_one_node
);
11776 ffecom_f2c_ftnlen_two_node
= build_int_2 (2, 0);
11777 TREE_TYPE (ffecom_f2c_ftnlen_two_node
) = ffecom_integer_type_node
;
11779 ffecom_f2c_ptr_to_ftnlen_type_node
11780 = build_pointer_type (ffecom_f2c_ftnlen_type_node
);
11782 ffecom_f2c_ptr_to_ftnint_type_node
11783 = build_pointer_type (ffecom_f2c_ftnint_type_node
);
11785 ffecom_f2c_ptr_to_integer_type_node
11786 = build_pointer_type (ffecom_f2c_integer_type_node
);
11788 ffecom_f2c_ptr_to_real_type_node
11789 = build_pointer_type (ffecom_f2c_real_type_node
);
11791 ffecom_float_zero_
= build_real (float_type_node
, dconst0
);
11792 ffecom_double_zero_
= build_real (double_type_node
, dconst0
);
11794 REAL_VALUE_TYPE point_5
;
11796 #ifdef REAL_ARITHMETIC
11797 REAL_ARITHMETIC (point_5
, RDIV_EXPR
, dconst1
, dconst2
);
11801 ffecom_float_half_
= build_real (float_type_node
, point_5
);
11802 ffecom_double_half_
= build_real (double_type_node
, point_5
);
11805 /* Do "extern int xargc;". */
11807 ffecom_tree_xargc_
= build_decl (VAR_DECL
,
11808 get_identifier ("f__xargc"),
11809 integer_type_node
);
11810 DECL_EXTERNAL (ffecom_tree_xargc_
) = 1;
11811 TREE_STATIC (ffecom_tree_xargc_
) = 1;
11812 TREE_PUBLIC (ffecom_tree_xargc_
) = 1;
11813 ffecom_tree_xargc_
= start_decl (ffecom_tree_xargc_
, FALSE
);
11814 finish_decl (ffecom_tree_xargc_
, NULL_TREE
, FALSE
);
11816 #if 0 /* This is being fixed, and seems to be working now. */
11817 if ((FLOAT_TYPE_SIZE
!= 32)
11818 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))) != 32))
11820 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11821 (int) FLOAT_TYPE_SIZE
);
11822 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11823 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))));
11824 warning ("properly unless they all are 32 bits wide");
11825 warning ("Please keep this in mind before you report bugs. g77 should");
11826 warning ("support non-32-bit machines better as of version 0.6");
11830 #if 0 /* Code in ste.c that would crash has been commented out. */
11831 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
11832 < TYPE_PRECISION (string_type_node
))
11833 /* I/O will probably crash. */
11834 warning ("configuration: char * holds %d bits, but ftnlen only %d",
11835 TYPE_PRECISION (string_type_node
),
11836 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
));
11839 #if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
11840 if (TYPE_PRECISION (ffecom_integer_type_node
)
11841 < TYPE_PRECISION (string_type_node
))
11842 /* ASSIGN 10 TO I will crash. */
11843 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11844 ASSIGN statement might fail",
11845 TYPE_PRECISION (string_type_node
),
11846 TYPE_PRECISION (ffecom_integer_type_node
));
11850 /* ffecom_init_2 -- Initialize
11852 ffecom_init_2(); */
11857 assert (ffecom_outer_function_decl_
== NULL_TREE
);
11858 assert (current_function_decl
== NULL_TREE
);
11859 assert (ffecom_which_entrypoint_decl_
== NULL_TREE
);
11861 ffecom_master_arglist_
= NULL
;
11863 ffecom_primary_entry_
= NULL
;
11864 ffecom_is_altreturning_
= FALSE
;
11865 ffecom_func_result_
= NULL_TREE
;
11866 ffecom_multi_retval_
= NULL_TREE
;
11869 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11872 ffebld expr; // FFE opITEM list.
11873 tree = ffecom_list_expr(expr);
11875 List of actual args is transformed into corresponding gcc backend list. */
11878 ffecom_list_expr (ffebld expr
)
11881 tree
*plist
= &list
;
11882 tree trail
= NULL_TREE
; /* Append char length args here. */
11883 tree
*ptrail
= &trail
;
11886 while (expr
!= NULL
)
11888 tree texpr
= ffecom_arg_expr (ffebld_head (expr
), &length
);
11890 if (texpr
== error_mark_node
)
11891 return error_mark_node
;
11893 *plist
= build_tree_list (NULL_TREE
, texpr
);
11894 plist
= &TREE_CHAIN (*plist
);
11895 expr
= ffebld_trail (expr
);
11896 if (length
!= NULL_TREE
)
11898 *ptrail
= build_tree_list (NULL_TREE
, length
);
11899 ptrail
= &TREE_CHAIN (*ptrail
);
11908 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11911 ffebld expr; // FFE opITEM list.
11912 tree = ffecom_list_ptr_to_expr(expr);
11914 List of actual args is transformed into corresponding gcc backend list for
11915 use in calling an external procedure (vs. a statement function). */
11918 ffecom_list_ptr_to_expr (ffebld expr
)
11921 tree
*plist
= &list
;
11922 tree trail
= NULL_TREE
; /* Append char length args here. */
11923 tree
*ptrail
= &trail
;
11926 while (expr
!= NULL
)
11928 tree texpr
= ffecom_arg_ptr_to_expr (ffebld_head (expr
), &length
);
11930 if (texpr
== error_mark_node
)
11931 return error_mark_node
;
11933 *plist
= build_tree_list (NULL_TREE
, texpr
);
11934 plist
= &TREE_CHAIN (*plist
);
11935 expr
= ffebld_trail (expr
);
11936 if (length
!= NULL_TREE
)
11938 *ptrail
= build_tree_list (NULL_TREE
, length
);
11939 ptrail
= &TREE_CHAIN (*ptrail
);
11948 /* Obtain gcc's LABEL_DECL tree for label. */
11951 ffecom_lookup_label (ffelab label
)
11955 if (ffelab_hook (label
) == NULL_TREE
)
11957 char labelname
[16];
11959 switch (ffelab_type (label
))
11961 case FFELAB_typeLOOPEND
:
11962 case FFELAB_typeNOTLOOP
:
11963 case FFELAB_typeENDIF
:
11964 sprintf (labelname
, "%" ffelabValue_f
"u", ffelab_value (label
));
11965 glabel
= build_decl (LABEL_DECL
, get_identifier (labelname
),
11967 DECL_CONTEXT (glabel
) = current_function_decl
;
11968 DECL_MODE (glabel
) = VOIDmode
;
11971 case FFELAB_typeFORMAT
:
11972 glabel
= build_decl (VAR_DECL
,
11973 ffecom_get_invented_identifier
11974 ("__g77_format_%d", (int) ffelab_value (label
)),
11975 build_type_variant (build_array_type
11979 TREE_CONSTANT (glabel
) = 1;
11980 TREE_STATIC (glabel
) = 1;
11981 DECL_CONTEXT (glabel
) = current_function_decl
;
11982 DECL_INITIAL (glabel
) = NULL
;
11983 make_decl_rtl (glabel
, NULL
);
11984 expand_decl (glabel
);
11986 ffecom_save_tree_forever (glabel
);
11990 case FFELAB_typeANY
:
11991 glabel
= error_mark_node
;
11995 assert ("bad label type" == NULL
);
11999 ffelab_set_hook (label
, glabel
);
12003 glabel
= ffelab_hook (label
);
12009 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
12010 a single source specification (as in the fourth argument of MVBITS).
12011 If the type is NULL_TREE, the type of lhs is used to make the type of
12012 the MODIFY_EXPR. */
12015 ffecom_modify (tree newtype
, tree lhs
,
12018 if (lhs
== error_mark_node
|| rhs
== error_mark_node
)
12019 return error_mark_node
;
12021 if (newtype
== NULL_TREE
)
12022 newtype
= TREE_TYPE (lhs
);
12024 if (TREE_SIDE_EFFECTS (lhs
))
12025 lhs
= stabilize_reference (lhs
);
12027 return ffecom_2s (MODIFY_EXPR
, newtype
, lhs
, rhs
);
12030 /* Register source file name. */
12033 ffecom_file (const char *name
)
12035 ffecom_file_ (name
);
12038 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12041 ffecom_notify_init_storage(st);
12043 Gets called when all possible units in an aggregate storage area (a LOCAL
12044 with equivalences or a COMMON) have been initialized. The initialization
12045 info either is in ffestorag_init or, if that is NULL,
12046 ffestorag_accretion:
12048 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12049 even for an array if the array is one element in length!
12051 ffestorag_accretion will contain an opACCTER. It is much like an
12052 opARRTER except it has an ffebit object in it instead of just a size.
12053 The back end can use the info in the ffebit object, if it wants, to
12054 reduce the amount of actual initialization, but in any case it should
12055 kill the ffebit object when done. Also, set accretion to NULL but
12056 init to a non-NULL value.
12058 After performing initialization, DO NOT set init to NULL, because that'll
12059 tell the front end it is ok for more initialization to happen. Instead,
12060 set init to an opANY expression or some such thing that you can use to
12061 tell that you've already initialized the object.
12064 Support two-pass FFE. */
12067 ffecom_notify_init_storage (ffestorag st
)
12069 ffebld init
; /* The initialization expression. */
12071 if (ffestorag_init (st
) == NULL
)
12073 init
= ffestorag_accretion (st
);
12074 assert (init
!= NULL
);
12075 ffestorag_set_accretion (st
, NULL
);
12076 ffestorag_set_accretes (st
, 0);
12077 ffestorag_set_init (st
, init
);
12081 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12084 ffecom_notify_init_symbol(s);
12086 Gets called when all possible units in a symbol (not placed in COMMON
12087 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12088 have been initialized. The initialization info either is in
12089 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12091 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12092 even for an array if the array is one element in length!
12094 ffesymbol_accretion will contain an opACCTER. It is much like an
12095 opARRTER except it has an ffebit object in it instead of just a size.
12096 The back end can use the info in the ffebit object, if it wants, to
12097 reduce the amount of actual initialization, but in any case it should
12098 kill the ffebit object when done. Also, set accretion to NULL but
12099 init to a non-NULL value.
12101 After performing initialization, DO NOT set init to NULL, because that'll
12102 tell the front end it is ok for more initialization to happen. Instead,
12103 set init to an opANY expression or some such thing that you can use to
12104 tell that you've already initialized the object.
12107 Support two-pass FFE. */
12110 ffecom_notify_init_symbol (ffesymbol s
)
12112 ffebld init
; /* The initialization expression. */
12114 if (ffesymbol_storage (s
) == NULL
)
12115 return; /* Do nothing until COMMON/EQUIVALENCE
12116 possibilities checked. */
12118 if ((ffesymbol_init (s
) == NULL
)
12119 && ((init
= ffesymbol_accretion (s
)) != NULL
))
12121 ffesymbol_set_accretion (s
, NULL
);
12122 ffesymbol_set_accretes (s
, 0);
12123 ffesymbol_set_init (s
, init
);
12127 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12130 ffecom_notify_primary_entry(s);
12132 Gets called when implicit or explicit PROGRAM statement seen or when
12133 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12134 global symbol that serves as the entry point. */
12137 ffecom_notify_primary_entry (ffesymbol s
)
12139 ffecom_primary_entry_
= s
;
12140 ffecom_primary_entry_kind_
= ffesymbol_kind (s
);
12142 if ((ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
12143 || (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
))
12144 ffecom_primary_entry_is_proc_
= TRUE
;
12146 ffecom_primary_entry_is_proc_
= FALSE
;
12148 if (!ffe_is_silent ())
12150 if (ffecom_primary_entry_kind_
== FFEINFO_kindPROGRAM
)
12151 fprintf (stderr
, "%s:\n", ffesymbol_text (s
));
12153 fprintf (stderr
, " %s:\n", ffesymbol_text (s
));
12156 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
12161 for (list
= ffesymbol_dummyargs (s
);
12163 list
= ffebld_trail (list
))
12165 arg
= ffebld_head (list
);
12166 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
12168 ffecom_is_altreturning_
= TRUE
;
12176 ffecom_open_include (char *name
, ffewhereLine l
, ffewhereColumn c
)
12178 return ffecom_open_include_ (name
, l
, c
);
12181 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12184 ffebld expr; // FFE expression.
12185 tree = ffecom_ptr_to_expr(expr);
12187 Like ffecom_expr, but sticks address-of in front of most things. */
12190 ffecom_ptr_to_expr (ffebld expr
)
12193 ffeinfoBasictype bt
;
12194 ffeinfoKindtype kt
;
12197 assert (expr
!= NULL
);
12199 switch (ffebld_op (expr
))
12201 case FFEBLD_opSYMTER
:
12202 s
= ffebld_symter (expr
);
12203 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
12207 ix
= ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr
));
12208 assert (ix
!= FFECOM_gfrt
);
12209 if ((item
= ffecom_gfrt_
[ix
]) == NULL_TREE
)
12211 ffecom_make_gfrt_ (ix
);
12212 item
= ffecom_gfrt_
[ix
];
12217 item
= ffesymbol_hook (s
).decl_tree
;
12218 if (item
== NULL_TREE
)
12220 s
= ffecom_sym_transform_ (s
);
12221 item
= ffesymbol_hook (s
).decl_tree
;
12224 assert (item
!= NULL
);
12225 if (item
== error_mark_node
)
12227 if (!ffesymbol_hook (s
).addr
)
12228 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12232 case FFEBLD_opARRAYREF
:
12233 return ffecom_arrayref_ (NULL_TREE
, expr
, 1);
12235 case FFEBLD_opCONTER
:
12237 bt
= ffeinfo_basictype (ffebld_info (expr
));
12238 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12240 item
= ffecom_constantunion (&ffebld_constant_union
12241 (ffebld_conter (expr
)), bt
, kt
,
12242 ffecom_tree_type
[bt
][kt
]);
12243 if (item
== error_mark_node
)
12244 return error_mark_node
;
12245 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12250 return error_mark_node
;
12253 bt
= ffeinfo_basictype (ffebld_info (expr
));
12254 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12256 item
= ffecom_expr (expr
);
12257 if (item
== error_mark_node
)
12258 return error_mark_node
;
12260 /* The back end currently optimizes a bit too zealously for us, in that
12261 we fail JCB001 if the following block of code is omitted. It checks
12262 to see if the transformed expression is a symbol or array reference,
12263 and encloses it in a SAVE_EXPR if that is the case. */
12266 if ((TREE_CODE (item
) == VAR_DECL
)
12267 || (TREE_CODE (item
) == PARM_DECL
)
12268 || (TREE_CODE (item
) == RESULT_DECL
)
12269 || (TREE_CODE (item
) == INDIRECT_REF
)
12270 || (TREE_CODE (item
) == ARRAY_REF
)
12271 || (TREE_CODE (item
) == COMPONENT_REF
)
12273 || (TREE_CODE (item
) == OFFSET_REF
)
12275 || (TREE_CODE (item
) == BUFFER_REF
)
12276 || (TREE_CODE (item
) == REALPART_EXPR
)
12277 || (TREE_CODE (item
) == IMAGPART_EXPR
))
12279 item
= ffecom_save_tree (item
);
12282 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12287 assert ("fall-through error" == NULL
);
12288 return error_mark_node
;
12291 /* Obtain a temp var with given data type.
12293 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12294 or >= 0 for a CHARACTER type.
12296 elements is -1 for a scalar or > 0 for an array of type. */
12299 ffecom_make_tempvar (const char *commentary
, tree type
,
12300 ffetargetCharacterSize size
, int elements
)
12303 static int mynumber
;
12305 assert (current_binding_level
->prep_state
< 2);
12307 if (type
== error_mark_node
)
12308 return error_mark_node
;
12310 if (size
!= FFETARGET_charactersizeNONE
)
12311 type
= build_array_type (type
,
12312 build_range_type (ffecom_f2c_ftnlen_type_node
,
12313 ffecom_f2c_ftnlen_one_node
,
12314 build_int_2 (size
, 0)));
12315 if (elements
!= -1)
12316 type
= build_array_type (type
,
12317 build_range_type (integer_type_node
,
12319 build_int_2 (elements
- 1,
12321 t
= build_decl (VAR_DECL
,
12322 ffecom_get_invented_identifier ("__g77_%s_%d",
12327 t
= start_decl (t
, FALSE
);
12328 finish_decl (t
, NULL_TREE
, FALSE
);
12333 /* Prepare argument pointer to expression.
12335 Like ffecom_prepare_expr, except for expressions to be evaluated
12336 via ffecom_arg_ptr_to_expr. */
12339 ffecom_prepare_arg_ptr_to_expr (ffebld expr
)
12341 /* ~~For now, it seems to be the same thing. */
12342 ffecom_prepare_expr (expr
);
12346 /* End of preparations. */
12349 ffecom_prepare_end (void)
12351 int prep_state
= current_binding_level
->prep_state
;
12353 assert (prep_state
< 2);
12354 current_binding_level
->prep_state
= 2;
12356 return (prep_state
== 1) ? TRUE
: FALSE
;
12359 /* Prepare expression.
12361 This is called before any code is generated for the current block.
12362 It scans the expression, declares any temporaries that might be needed
12363 during evaluation of the expression, and stores those temporaries in
12364 the appropriate "hook" fields of the expression. `dest', if not NULL,
12365 specifies the destination that ffecom_expr_ will see, in case that
12366 helps avoid generating unused temporaries.
12368 ~~Improve to avoid allocating unused temporaries by taking `dest'
12369 into account vis-a-vis aliasing requirements of complex/character
12373 ffecom_prepare_expr_ (ffebld expr
, ffebld dest UNUSED
)
12375 ffeinfoBasictype bt
;
12376 ffeinfoKindtype kt
;
12377 ffetargetCharacterSize sz
;
12378 tree tempvar
= NULL_TREE
;
12380 assert (current_binding_level
->prep_state
< 2);
12385 bt
= ffeinfo_basictype (ffebld_info (expr
));
12386 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12387 sz
= ffeinfo_size (ffebld_info (expr
));
12389 /* Generate whatever temporaries are needed to represent the result
12390 of the expression. */
12392 if (bt
== FFEINFO_basictypeCHARACTER
)
12394 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
12395 expr
= ffebld_left (expr
);
12398 switch (ffebld_op (expr
))
12401 /* Don't make temps for SYMTER, CONTER, etc. */
12402 if (ffebld_arity (expr
) == 0)
12407 case FFEINFO_basictypeCOMPLEX
:
12408 if (ffebld_op (expr
) == FFEBLD_opFUNCREF
)
12412 if (ffebld_op (ffebld_left (expr
)) != FFEBLD_opSYMTER
)
12415 s
= ffebld_symter (ffebld_left (expr
));
12416 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
12417 || (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
12418 && ! ffesymbol_is_f2c (s
))
12419 || (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
12420 && ! ffe_is_f2c_library ()))
12423 else if (ffebld_op (expr
) == FFEBLD_opPOWER
)
12425 /* Requires special treatment. There's no POW_CC function
12426 in libg2c, so POW_ZZ is used, which means we always
12427 need a double-complex temp, not a single-complex. */
12428 kt
= FFEINFO_kindtypeREAL2
;
12430 else if (ffebld_op (expr
) != FFEBLD_opDIVIDE
)
12431 /* The other ops don't need temps for complex operands. */
12434 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12435 REAL(C). See 19990325-0.f, routine `check', for cases. */
12436 tempvar
= ffecom_make_tempvar ("complex",
12438 [FFEINFO_basictypeCOMPLEX
][kt
],
12439 FFETARGET_charactersizeNONE
,
12443 case FFEINFO_basictypeCHARACTER
:
12444 if (ffebld_op (expr
) != FFEBLD_opFUNCREF
)
12447 if (sz
== FFETARGET_charactersizeNONE
)
12448 /* ~~Kludge alert! This should someday be fixed. */
12451 tempvar
= ffecom_make_tempvar ("char", char_type_node
, sz
, -1);
12460 case FFEBLD_opPOWER
:
12463 tree rtmp
, ltmp
, result
;
12465 ltype
= ffecom_type_expr (ffebld_left (expr
));
12466 rtype
= ffecom_type_expr (ffebld_right (expr
));
12468 rtmp
= ffecom_make_tempvar (rtype
, FFETARGET_charactersizeNONE
, -1);
12469 ltmp
= ffecom_make_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1);
12470 result
= ffecom_make_tempvar (ltype
, FFETARGET_charactersizeNONE
, -1);
12472 tempvar
= make_tree_vec (3);
12473 TREE_VEC_ELT (tempvar
, 0) = rtmp
;
12474 TREE_VEC_ELT (tempvar
, 1) = ltmp
;
12475 TREE_VEC_ELT (tempvar
, 2) = result
;
12480 case FFEBLD_opCONCATENATE
:
12482 /* This gets special handling, because only one set of temps
12483 is needed for a tree of these -- the tree is treated as
12484 a flattened list of concatenations when generating code. */
12486 ffecomConcatList_ catlist
;
12487 tree ltmp
, itmp
, result
;
12491 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
12492 count
= ffecom_concat_list_count_ (catlist
);
12497 = ffecom_make_tempvar ("concat_len",
12498 ffecom_f2c_ftnlen_type_node
,
12499 FFETARGET_charactersizeNONE
, count
);
12501 = ffecom_make_tempvar ("concat_item",
12502 ffecom_f2c_address_type_node
,
12503 FFETARGET_charactersizeNONE
, count
);
12505 = ffecom_make_tempvar ("concat_res",
12507 ffecom_concat_list_maxlen_ (catlist
),
12510 tempvar
= make_tree_vec (3);
12511 TREE_VEC_ELT (tempvar
, 0) = ltmp
;
12512 TREE_VEC_ELT (tempvar
, 1) = itmp
;
12513 TREE_VEC_ELT (tempvar
, 2) = result
;
12516 for (i
= 0; i
< count
; ++i
)
12517 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist
,
12520 ffecom_concat_list_kill_ (catlist
);
12524 ffebld_nonter_set_hook (expr
, tempvar
);
12525 current_binding_level
->prep_state
= 1;
12530 case FFEBLD_opCONVERT
:
12531 if (bt
== FFEINFO_basictypeCHARACTER
12532 && ((ffebld_size_known (ffebld_left (expr
))
12533 == FFETARGET_charactersizeNONE
)
12534 || (ffebld_size_known (ffebld_left (expr
)) >= sz
)))
12535 tempvar
= ffecom_make_tempvar ("convert", char_type_node
, sz
, -1);
12541 ffebld_nonter_set_hook (expr
, tempvar
);
12542 current_binding_level
->prep_state
= 1;
12545 /* Prepare subexpressions for this expr. */
12547 switch (ffebld_op (expr
))
12549 case FFEBLD_opPERCENT_LOC
:
12550 ffecom_prepare_ptr_to_expr (ffebld_left (expr
));
12553 case FFEBLD_opPERCENT_VAL
:
12554 case FFEBLD_opPERCENT_REF
:
12555 ffecom_prepare_expr (ffebld_left (expr
));
12558 case FFEBLD_opPERCENT_DESCR
:
12559 ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr
));
12562 case FFEBLD_opITEM
:
12568 item
= ffebld_trail (item
))
12569 if (ffebld_head (item
) != NULL
)
12570 ffecom_prepare_expr (ffebld_head (item
));
12575 /* Need to handle character conversion specially. */
12576 switch (ffebld_arity (expr
))
12579 ffecom_prepare_expr (ffebld_left (expr
));
12580 ffecom_prepare_expr (ffebld_right (expr
));
12584 ffecom_prepare_expr (ffebld_left (expr
));
12595 /* Prepare expression for reading and writing.
12597 Like ffecom_prepare_expr, except for expressions to be evaluated
12598 via ffecom_expr_rw. */
12601 ffecom_prepare_expr_rw (tree type
, ffebld expr
)
12603 /* This is all we support for now. */
12604 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
12606 /* ~~For now, it seems to be the same thing. */
12607 ffecom_prepare_expr (expr
);
12611 /* Prepare expression for writing.
12613 Like ffecom_prepare_expr, except for expressions to be evaluated
12614 via ffecom_expr_w. */
12617 ffecom_prepare_expr_w (tree type
, ffebld expr
)
12619 /* This is all we support for now. */
12620 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
12622 /* ~~For now, it seems to be the same thing. */
12623 ffecom_prepare_expr (expr
);
12627 /* Prepare expression for returning.
12629 Like ffecom_prepare_expr, except for expressions to be evaluated
12630 via ffecom_return_expr. */
12633 ffecom_prepare_return_expr (ffebld expr
)
12635 assert (current_binding_level
->prep_state
< 2);
12637 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
12638 && ffecom_is_altreturning_
12640 ffecom_prepare_expr (expr
);
12643 /* Prepare pointer to expression.
12645 Like ffecom_prepare_expr, except for expressions to be evaluated
12646 via ffecom_ptr_to_expr. */
12649 ffecom_prepare_ptr_to_expr (ffebld expr
)
12651 /* ~~For now, it seems to be the same thing. */
12652 ffecom_prepare_expr (expr
);
12656 /* Transform expression into constant pointer-to-expression tree.
12658 If the expression can be transformed into a pointer-to-expression tree
12659 that is constant, that is done, and the tree returned. Else NULL_TREE
12662 That way, a caller can attempt to provide compile-time initialization
12663 of a variable and, if that fails, *then* choose to start a new block
12664 and resort to using temporaries, as appropriate. */
12667 ffecom_ptr_to_const_expr (ffebld expr
)
12670 return integer_zero_node
;
12672 if (ffebld_op (expr
) == FFEBLD_opANY
)
12673 return error_mark_node
;
12675 if (ffebld_arity (expr
) == 0
12676 && (ffebld_op (expr
) != FFEBLD_opSYMTER
12677 || ffebld_where (expr
) == FFEINFO_whereCOMMON
12678 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
12679 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
12683 t
= ffecom_ptr_to_expr (expr
);
12684 assert (TREE_CONSTANT (t
));
12691 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12693 tree rtn; // NULL_TREE means use expand_null_return()
12694 ffebld expr; // NULL if no alt return expr to RETURN stmt
12695 rtn = ffecom_return_expr(expr);
12697 Based on the program unit type and other info (like return function
12698 type, return master function type when alternate ENTRY points,
12699 whether subroutine has any alternate RETURN points, etc), returns the
12700 appropriate expression to be returned to the caller, or NULL_TREE
12701 meaning no return value or the caller expects it to be returned somewhere
12702 else (which is handled by other parts of this module). */
12705 ffecom_return_expr (ffebld expr
)
12709 switch (ffecom_primary_entry_kind_
)
12711 case FFEINFO_kindPROGRAM
:
12712 case FFEINFO_kindBLOCKDATA
:
12716 case FFEINFO_kindSUBROUTINE
:
12717 if (!ffecom_is_altreturning_
)
12718 rtn
= NULL_TREE
; /* No alt returns, never an expr. */
12719 else if (expr
== NULL
)
12720 rtn
= integer_zero_node
;
12722 rtn
= ffecom_expr (expr
);
12725 case FFEINFO_kindFUNCTION
:
12726 if ((ffecom_multi_retval_
!= NULL_TREE
)
12727 || (ffesymbol_basictype (ffecom_primary_entry_
)
12728 == FFEINFO_basictypeCHARACTER
)
12729 || ((ffesymbol_basictype (ffecom_primary_entry_
)
12730 == FFEINFO_basictypeCOMPLEX
)
12731 && (ffecom_num_entrypoints_
== 0)
12732 && ffesymbol_is_f2c (ffecom_primary_entry_
)))
12733 { /* Value is returned by direct assignment
12734 into (implicit) dummy. */
12738 rtn
= ffecom_func_result_
;
12740 /* Spurious error if RETURN happens before first reference! So elide
12741 this code. In particular, for debugging registry, rtn should always
12742 be non-null after all, but TREE_USED won't be set until we encounter
12743 a reference in the code. Perfectly okay (but weird) code that,
12744 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12745 this diagnostic for no reason. Have people use -O -Wuninitialized
12746 and leave it to the back end to find obviously weird cases. */
12748 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12749 situation; if the return value has never been referenced, it won't
12750 have a tree under 2pass mode. */
12751 if ((rtn
== NULL_TREE
)
12752 || !TREE_USED (rtn
))
12754 ffebad_start (FFEBAD_RETURN_VALUE_UNSET
);
12755 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_
),
12756 ffesymbol_where_column (ffecom_primary_entry_
));
12757 ffebad_string (ffesymbol_text (ffesymbol_funcresult
12758 (ffecom_primary_entry_
)));
12765 assert ("bad unit kind" == NULL
);
12766 case FFEINFO_kindANY
:
12767 rtn
= error_mark_node
;
12774 /* Do save_expr only if tree is not error_mark_node. */
12777 ffecom_save_tree (tree t
)
12779 return save_expr (t
);
12782 /* Start a compound statement (block). */
12785 ffecom_start_compstmt (void)
12787 bison_rule_pushlevel_ ();
12790 /* Public entry point for front end to access start_decl. */
12793 ffecom_start_decl (tree decl
, bool is_initialized
)
12795 DECL_INITIAL (decl
) = is_initialized
? error_mark_node
: NULL_TREE
;
12796 return start_decl (decl
, FALSE
);
12799 /* ffecom_sym_commit -- Symbol's state being committed to reality
12802 ffecom_sym_commit(s);
12804 Does whatever the backend needs when a symbol is committed after having
12805 been backtrackable for a period of time. */
12808 ffecom_sym_commit (ffesymbol s UNUSED
)
12810 assert (!ffesymbol_retractable ());
12813 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12815 ffecom_sym_end_transition();
12817 Does backend-specific stuff and also calls ffest_sym_end_transition
12818 to do the necessary FFE stuff.
12820 Backtracking is never enabled when this fn is called, so don't worry
12824 ffecom_sym_end_transition (ffesymbol s
)
12828 assert (!ffesymbol_retractable ());
12830 s
= ffest_sym_end_transition (s
);
12832 if ((ffesymbol_kind (s
) == FFEINFO_kindBLOCKDATA
)
12833 && (ffesymbol_where (s
) == FFEINFO_whereGLOBAL
))
12835 ffecom_list_blockdata_
12836 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
12837 FFEINTRIN_specNONE
,
12838 FFEINTRIN_impNONE
),
12839 ffecom_list_blockdata_
);
12842 /* This is where we finally notice that a symbol has partial initialization
12843 and finalize it. */
12845 if (ffesymbol_accretion (s
) != NULL
)
12847 assert (ffesymbol_init (s
) == NULL
);
12848 ffecom_notify_init_symbol (s
);
12850 else if (((st
= ffesymbol_storage (s
)) != NULL
)
12851 && ((st
= ffestorag_parent (st
)) != NULL
)
12852 && (ffestorag_accretion (st
) != NULL
))
12854 assert (ffestorag_init (st
) == NULL
);
12855 ffecom_notify_init_storage (st
);
12858 if ((ffesymbol_kind (s
) == FFEINFO_kindCOMMON
)
12859 && (ffesymbol_where (s
) == FFEINFO_whereLOCAL
)
12860 && (ffesymbol_storage (s
) != NULL
))
12862 ffecom_list_common_
12863 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
12864 FFEINTRIN_specNONE
,
12865 FFEINTRIN_impNONE
),
12866 ffecom_list_common_
);
12872 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12874 ffecom_sym_exec_transition();
12876 Does backend-specific stuff and also calls ffest_sym_exec_transition
12877 to do the necessary FFE stuff.
12879 See the long-winded description in ffecom_sym_learned for info
12880 on handling the situation where backtracking is inhibited. */
12883 ffecom_sym_exec_transition (ffesymbol s
)
12885 s
= ffest_sym_exec_transition (s
);
12890 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12893 s = ffecom_sym_learned(s);
12895 Called when a new symbol is seen after the exec transition or when more
12896 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
12897 it arrives here is that all its latest info is updated already, so its
12898 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12899 field filled in if its gone through here or exec_transition first, and
12902 The backend probably wants to check ffesymbol_retractable() to see if
12903 backtracking is in effect. If so, the FFE's changes to the symbol may
12904 be retracted (undone) or committed (ratified), at which time the
12905 appropriate ffecom_sym_retract or _commit function will be called
12908 If the backend has its own backtracking mechanism, great, use it so that
12909 committal is a simple operation. Though it doesn't make much difference,
12910 I suppose: the reason for tentative symbol evolution in the FFE is to
12911 enable error detection in weird incorrect statements early and to disable
12912 incorrect error detection on a correct statement. The backend is not
12913 likely to introduce any information that'll get involved in these
12914 considerations, so it is probably just fine that the implementation
12915 model for this fn and for _exec_transition is to not do anything
12916 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12917 and instead wait until ffecom_sym_commit is called (which it never
12918 will be as long as we're using ambiguity-detecting statement analysis in
12919 the FFE, which we are initially to shake out the code, but don't depend
12920 on this), otherwise go ahead and do whatever is needed.
12922 In essence, then, when this fn and _exec_transition get called while
12923 backtracking is enabled, a general mechanism would be to flag which (or
12924 both) of these were called (and in what order? neat question as to what
12925 might happen that I'm too lame to think through right now) and then when
12926 _commit is called reproduce the original calling sequence, if any, for
12927 the two fns (at which point backtracking will, of course, be disabled). */
12930 ffecom_sym_learned (ffesymbol s
)
12932 ffestorag_exec_layout (s
);
12937 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12940 ffecom_sym_retract(s);
12942 Does whatever the backend needs when a symbol is retracted after having
12943 been backtrackable for a period of time. */
12946 ffecom_sym_retract (ffesymbol s UNUSED
)
12948 assert (!ffesymbol_retractable ());
12950 #if 0 /* GCC doesn't commit any backtrackable sins,
12951 so nothing needed here. */
12952 switch (ffesymbol_hook (s
).state
)
12954 case 0: /* nothing happened yet. */
12957 case 1: /* exec transition happened. */
12960 case 2: /* learned happened. */
12963 case 3: /* learned then exec. */
12966 case 4: /* exec then learned. */
12970 assert ("bad hook state" == NULL
);
12976 /* Create temporary gcc label. */
12979 ffecom_temp_label ()
12982 static int mynumber
= 0;
12984 glabel
= build_decl (LABEL_DECL
,
12985 ffecom_get_invented_identifier ("__g77_label_%d",
12988 DECL_CONTEXT (glabel
) = current_function_decl
;
12989 DECL_MODE (glabel
) = VOIDmode
;
12994 /* Return an expression that is usable as an arg in a conditional context
12995 (IF, DO WHILE, .NOT., and so on).
12997 Use the one provided for the back end as of >2.6.0. */
13000 ffecom_truth_value (tree expr
)
13002 return truthvalue_conversion (expr
);
13005 /* Return the inversion of a truth value (the inversion of what
13006 ffecom_truth_value builds).
13008 Apparently invert_truthvalue, which is properly in the back end, is
13009 enough for now, so just use it. */
13012 ffecom_truth_value_invert (tree expr
)
13014 return invert_truthvalue (ffecom_truth_value (expr
));
13017 /* Return the tree that is the type of the expression, as would be
13018 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13019 transforming the expression, generating temporaries, etc. */
13022 ffecom_type_expr (ffebld expr
)
13024 ffeinfoBasictype bt
;
13025 ffeinfoKindtype kt
;
13028 assert (expr
!= NULL
);
13030 bt
= ffeinfo_basictype (ffebld_info (expr
));
13031 kt
= ffeinfo_kindtype (ffebld_info (expr
));
13032 tree_type
= ffecom_tree_type
[bt
][kt
];
13034 switch (ffebld_op (expr
))
13036 case FFEBLD_opCONTER
:
13037 case FFEBLD_opSYMTER
:
13038 case FFEBLD_opARRAYREF
:
13039 case FFEBLD_opUPLUS
:
13040 case FFEBLD_opPAREN
:
13041 case FFEBLD_opUMINUS
:
13043 case FFEBLD_opSUBTRACT
:
13044 case FFEBLD_opMULTIPLY
:
13045 case FFEBLD_opDIVIDE
:
13046 case FFEBLD_opPOWER
:
13048 case FFEBLD_opFUNCREF
:
13049 case FFEBLD_opSUBRREF
:
13053 case FFEBLD_opNEQV
:
13055 case FFEBLD_opCONVERT
:
13062 case FFEBLD_opPERCENT_LOC
:
13065 case FFEBLD_opACCTER
:
13066 case FFEBLD_opARRTER
:
13067 case FFEBLD_opITEM
:
13068 case FFEBLD_opSTAR
:
13069 case FFEBLD_opBOUNDS
:
13070 case FFEBLD_opREPEAT
:
13071 case FFEBLD_opLABTER
:
13072 case FFEBLD_opLABTOK
:
13073 case FFEBLD_opIMPDO
:
13074 case FFEBLD_opCONCATENATE
:
13075 case FFEBLD_opSUBSTR
:
13077 assert ("bad op for ffecom_type_expr" == NULL
);
13078 /* Fall through. */
13080 return error_mark_node
;
13084 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13086 If the PARM_DECL already exists, return it, else create it. It's an
13087 integer_type_node argument for the master function that implements a
13088 subroutine or function with more than one entrypoint and is bound at
13089 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13090 first ENTRY statement, and so on). */
13093 ffecom_which_entrypoint_decl ()
13095 assert (ffecom_which_entrypoint_decl_
!= NULL_TREE
);
13097 return ffecom_which_entrypoint_decl_
;
13100 /* The following sections consists of private and public functions
13101 that have the same names and perform roughly the same functions
13102 as counterparts in the C front end. Changes in the C front end
13103 might affect how things should be done here. Only functions
13104 needed by the back end should be public here; the rest should
13105 be private (static in the C sense). Functions needed by other
13106 g77 front-end modules should be accessed by them via public
13107 ffecom_* names, which should themselves call private versions
13108 in this section so the private versions are easy to recognize
13109 when upgrading to a new gcc and finding interesting changes
13112 Functions named after rule "foo:" in c-parse.y are named
13113 "bison_rule_foo_" so they are easy to find. */
13116 bison_rule_pushlevel_ ()
13118 emit_line_note (input_filename
, lineno
);
13120 clear_last_expr ();
13121 expand_start_bindings (0);
13125 bison_rule_compstmt_ ()
13128 int keep
= kept_level_p ();
13130 /* Make the temps go away. */
13132 current_binding_level
->names
= NULL_TREE
;
13134 emit_line_note (input_filename
, lineno
);
13135 expand_end_bindings (getdecls (), keep
, 0);
13136 t
= poplevel (keep
, 1, 0);
13141 /* Return a definition for a builtin function named NAME and whose data type
13142 is TYPE. TYPE should be a function type with argument types.
13143 FUNCTION_CODE tells later passes how to compile calls to this function.
13144 See tree.h for its possible values.
13146 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13147 the name to be called if we can't opencode the function. */
13150 builtin_function (const char *name
, tree type
, int function_code
,
13151 enum built_in_class
class,
13152 const char *library_name
)
13154 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
13155 DECL_EXTERNAL (decl
) = 1;
13156 TREE_PUBLIC (decl
) = 1;
13158 SET_DECL_ASSEMBLER_NAME (decl
, get_identifier (library_name
));
13159 make_decl_rtl (decl
, NULL
);
13161 DECL_BUILT_IN_CLASS (decl
) = class;
13162 DECL_FUNCTION_CODE (decl
) = function_code
;
13167 /* Handle when a new declaration NEWDECL
13168 has the same name as an old one OLDDECL
13169 in the same binding contour.
13170 Prints an error message if appropriate.
13172 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13173 Otherwise, return 0. */
13176 duplicate_decls (tree newdecl
, tree olddecl
)
13178 int types_match
= 1;
13179 int new_is_definition
= (TREE_CODE (newdecl
) == FUNCTION_DECL
13180 && DECL_INITIAL (newdecl
) != 0);
13181 tree oldtype
= TREE_TYPE (olddecl
);
13182 tree newtype
= TREE_TYPE (newdecl
);
13184 if (olddecl
== newdecl
)
13187 if (TREE_CODE (newtype
) == ERROR_MARK
13188 || TREE_CODE (oldtype
) == ERROR_MARK
)
13191 /* New decl is completely inconsistent with the old one =>
13192 tell caller to replace the old one.
13193 This is always an error except in the case of shadowing a builtin. */
13194 if (TREE_CODE (olddecl
) != TREE_CODE (newdecl
))
13197 /* For real parm decl following a forward decl,
13198 return 1 so old decl will be reused. */
13199 if (types_match
&& TREE_CODE (newdecl
) == PARM_DECL
13200 && TREE_ASM_WRITTEN (olddecl
) && ! TREE_ASM_WRITTEN (newdecl
))
13203 /* The new declaration is the same kind of object as the old one.
13204 The declarations may partially match. Print warnings if they don't
13205 match enough. Ultimately, copy most of the information from the new
13206 decl to the old one, and keep using the old one. */
13208 if (TREE_CODE (olddecl
) == FUNCTION_DECL
13209 && DECL_BUILT_IN (olddecl
))
13211 /* A function declaration for a built-in function. */
13212 if (!TREE_PUBLIC (newdecl
))
13214 else if (!types_match
)
13216 /* Accept the return type of the new declaration if same modes. */
13217 tree oldreturntype
= TREE_TYPE (TREE_TYPE (olddecl
));
13218 tree newreturntype
= TREE_TYPE (TREE_TYPE (newdecl
));
13220 if (TYPE_MODE (oldreturntype
) == TYPE_MODE (newreturntype
))
13222 /* Function types may be shared, so we can't just modify
13223 the return type of olddecl's function type. */
13225 = build_function_type (newreturntype
,
13226 TYPE_ARG_TYPES (TREE_TYPE (olddecl
)));
13230 TREE_TYPE (olddecl
) = newtype
;
13236 else if (TREE_CODE (olddecl
) == FUNCTION_DECL
13237 && DECL_SOURCE_LINE (olddecl
) == 0)
13239 /* A function declaration for a predeclared function
13240 that isn't actually built in. */
13241 if (!TREE_PUBLIC (newdecl
))
13243 else if (!types_match
)
13245 /* If the types don't match, preserve volatility indication.
13246 Later on, we will discard everything else about the
13247 default declaration. */
13248 TREE_THIS_VOLATILE (newdecl
) |= TREE_THIS_VOLATILE (olddecl
);
13252 /* Copy all the DECL_... slots specified in the new decl
13253 except for any that we copy here from the old type.
13255 Past this point, we don't change OLDTYPE and NEWTYPE
13256 even if we change the types of NEWDECL and OLDDECL. */
13260 /* Merge the data types specified in the two decls. */
13261 if (TREE_CODE (newdecl
) != FUNCTION_DECL
|| !DECL_BUILT_IN (olddecl
))
13262 TREE_TYPE (newdecl
)
13263 = TREE_TYPE (olddecl
)
13264 = TREE_TYPE (newdecl
);
13266 /* Lay the type out, unless already done. */
13267 if (oldtype
!= TREE_TYPE (newdecl
))
13269 if (TREE_TYPE (newdecl
) != error_mark_node
)
13270 layout_type (TREE_TYPE (newdecl
));
13271 if (TREE_CODE (newdecl
) != FUNCTION_DECL
13272 && TREE_CODE (newdecl
) != TYPE_DECL
13273 && TREE_CODE (newdecl
) != CONST_DECL
)
13274 layout_decl (newdecl
, 0);
13278 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13279 DECL_SIZE (newdecl
) = DECL_SIZE (olddecl
);
13280 DECL_SIZE_UNIT (newdecl
) = DECL_SIZE_UNIT (olddecl
);
13281 if (TREE_CODE (olddecl
) != FUNCTION_DECL
)
13282 if (DECL_ALIGN (olddecl
) > DECL_ALIGN (newdecl
))
13284 DECL_ALIGN (newdecl
) = DECL_ALIGN (olddecl
);
13285 DECL_USER_ALIGN (newdecl
) |= DECL_USER_ALIGN (olddecl
);
13289 /* Keep the old rtl since we can safely use it. */
13290 COPY_DECL_RTL (olddecl
, newdecl
);
13292 /* Merge the type qualifiers. */
13293 if (DECL_BUILT_IN_NONANSI (olddecl
) && TREE_THIS_VOLATILE (olddecl
)
13294 && !TREE_THIS_VOLATILE (newdecl
))
13295 TREE_THIS_VOLATILE (olddecl
) = 0;
13296 if (TREE_READONLY (newdecl
))
13297 TREE_READONLY (olddecl
) = 1;
13298 if (TREE_THIS_VOLATILE (newdecl
))
13300 TREE_THIS_VOLATILE (olddecl
) = 1;
13301 if (TREE_CODE (newdecl
) == VAR_DECL
)
13302 make_var_volatile (newdecl
);
13305 /* Keep source location of definition rather than declaration.
13306 Likewise, keep decl at outer scope. */
13307 if ((DECL_INITIAL (newdecl
) == 0 && DECL_INITIAL (olddecl
) != 0)
13308 || (DECL_CONTEXT (newdecl
) != 0 && DECL_CONTEXT (olddecl
) == 0))
13310 DECL_SOURCE_LINE (newdecl
) = DECL_SOURCE_LINE (olddecl
);
13311 DECL_SOURCE_FILE (newdecl
) = DECL_SOURCE_FILE (olddecl
);
13313 if (DECL_CONTEXT (olddecl
) == 0
13314 && TREE_CODE (newdecl
) != FUNCTION_DECL
)
13315 DECL_CONTEXT (newdecl
) = 0;
13318 /* Merge the unused-warning information. */
13319 if (DECL_IN_SYSTEM_HEADER (olddecl
))
13320 DECL_IN_SYSTEM_HEADER (newdecl
) = 1;
13321 else if (DECL_IN_SYSTEM_HEADER (newdecl
))
13322 DECL_IN_SYSTEM_HEADER (olddecl
) = 1;
13324 /* Merge the initialization information. */
13325 if (DECL_INITIAL (newdecl
) == 0)
13326 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13328 /* Merge the section attribute.
13329 We want to issue an error if the sections conflict but that must be
13330 done later in decl_attributes since we are called before attributes
13332 if (DECL_SECTION_NAME (newdecl
) == NULL_TREE
)
13333 DECL_SECTION_NAME (newdecl
) = DECL_SECTION_NAME (olddecl
);
13335 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13337 DECL_STATIC_CONSTRUCTOR(newdecl
) |= DECL_STATIC_CONSTRUCTOR(olddecl
);
13338 DECL_STATIC_DESTRUCTOR (newdecl
) |= DECL_STATIC_DESTRUCTOR (olddecl
);
13341 /* If cannot merge, then use the new type and qualifiers,
13342 and don't preserve the old rtl. */
13345 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13346 TREE_READONLY (olddecl
) = TREE_READONLY (newdecl
);
13347 TREE_THIS_VOLATILE (olddecl
) = TREE_THIS_VOLATILE (newdecl
);
13348 TREE_SIDE_EFFECTS (olddecl
) = TREE_SIDE_EFFECTS (newdecl
);
13351 /* Merge the storage class information. */
13352 /* For functions, static overrides non-static. */
13353 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13355 TREE_PUBLIC (newdecl
) &= TREE_PUBLIC (olddecl
);
13356 /* This is since we don't automatically
13357 copy the attributes of NEWDECL into OLDDECL. */
13358 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13359 /* If this clears `static', clear it in the identifier too. */
13360 if (! TREE_PUBLIC (olddecl
))
13361 TREE_PUBLIC (DECL_NAME (olddecl
)) = 0;
13363 if (DECL_EXTERNAL (newdecl
))
13365 TREE_STATIC (newdecl
) = TREE_STATIC (olddecl
);
13366 DECL_EXTERNAL (newdecl
) = DECL_EXTERNAL (olddecl
);
13367 /* An extern decl does not override previous storage class. */
13368 TREE_PUBLIC (newdecl
) = TREE_PUBLIC (olddecl
);
13372 TREE_STATIC (olddecl
) = TREE_STATIC (newdecl
);
13373 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13376 /* If either decl says `inline', this fn is inline,
13377 unless its definition was passed already. */
13378 if (DECL_INLINE (newdecl
) && DECL_INITIAL (olddecl
) == 0)
13379 DECL_INLINE (olddecl
) = 1;
13380 DECL_INLINE (newdecl
) = DECL_INLINE (olddecl
);
13382 /* Get rid of any built-in function if new arg types don't match it
13383 or if we have a function definition. */
13384 if (TREE_CODE (newdecl
) == FUNCTION_DECL
13385 && DECL_BUILT_IN (olddecl
)
13386 && (!types_match
|| new_is_definition
))
13388 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13389 DECL_BUILT_IN_CLASS (olddecl
) = NOT_BUILT_IN
;
13392 /* If redeclaring a builtin function, and not a definition,
13394 Also preserve various other info from the definition. */
13395 if (TREE_CODE (newdecl
) == FUNCTION_DECL
&& !new_is_definition
)
13397 if (DECL_BUILT_IN (olddecl
))
13399 DECL_BUILT_IN_CLASS (newdecl
) = DECL_BUILT_IN_CLASS (olddecl
);
13400 DECL_FUNCTION_CODE (newdecl
) = DECL_FUNCTION_CODE (olddecl
);
13403 DECL_RESULT (newdecl
) = DECL_RESULT (olddecl
);
13404 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13405 DECL_SAVED_INSNS (newdecl
) = DECL_SAVED_INSNS (olddecl
);
13406 DECL_ARGUMENTS (newdecl
) = DECL_ARGUMENTS (olddecl
);
13409 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13410 But preserve olddecl's DECL_UID. */
13412 register unsigned olddecl_uid
= DECL_UID (olddecl
);
13414 memcpy ((char *) olddecl
+ sizeof (struct tree_common
),
13415 (char *) newdecl
+ sizeof (struct tree_common
),
13416 sizeof (struct tree_decl
) - sizeof (struct tree_common
));
13417 DECL_UID (olddecl
) = olddecl_uid
;
13423 /* Finish processing of a declaration;
13424 install its initial value.
13425 If the length of an array type is not known before,
13426 it must be determined now, from the initial value, or it is an error. */
13429 finish_decl (tree decl
, tree init
, bool is_top_level
)
13431 register tree type
= TREE_TYPE (decl
);
13432 int was_incomplete
= (DECL_SIZE (decl
) == 0);
13433 bool at_top_level
= (current_binding_level
== global_binding_level
);
13434 bool top_level
= is_top_level
|| at_top_level
;
13436 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13438 assert (!is_top_level
|| !at_top_level
);
13440 if (TREE_CODE (decl
) == PARM_DECL
)
13441 assert (init
== NULL_TREE
);
13442 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13443 overlaps DECL_ARG_TYPE. */
13444 else if (init
== NULL_TREE
)
13445 assert (DECL_INITIAL (decl
) == NULL_TREE
);
13447 assert (DECL_INITIAL (decl
) == error_mark_node
);
13449 if (init
!= NULL_TREE
)
13451 if (TREE_CODE (decl
) != TYPE_DECL
)
13452 DECL_INITIAL (decl
) = init
;
13455 /* typedef foo = bar; store the type of bar as the type of foo. */
13456 TREE_TYPE (decl
) = TREE_TYPE (init
);
13457 DECL_INITIAL (decl
) = init
= 0;
13461 /* Deduce size of array from initialization, if not already known */
13463 if (TREE_CODE (type
) == ARRAY_TYPE
13464 && TYPE_DOMAIN (type
) == 0
13465 && TREE_CODE (decl
) != TYPE_DECL
)
13467 assert (top_level
);
13468 assert (was_incomplete
);
13470 layout_decl (decl
, 0);
13473 if (TREE_CODE (decl
) == VAR_DECL
)
13475 if (DECL_SIZE (decl
) == NULL_TREE
13476 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
13477 layout_decl (decl
, 0);
13479 if (DECL_SIZE (decl
) == NULL_TREE
13480 && (TREE_STATIC (decl
)
13482 /* A static variable with an incomplete type is an error if it is
13483 initialized. Also if it is not file scope. Otherwise, let it
13484 through, but if it is not `extern' then it may cause an error
13486 (DECL_INITIAL (decl
) != 0 || DECL_CONTEXT (decl
) != 0)
13488 /* An automatic variable with an incomplete type is an error. */
13489 !DECL_EXTERNAL (decl
)))
13491 assert ("storage size not known" == NULL
);
13495 if ((DECL_EXTERNAL (decl
) || TREE_STATIC (decl
))
13496 && (DECL_SIZE (decl
) != 0)
13497 && (TREE_CODE (DECL_SIZE (decl
)) != INTEGER_CST
))
13499 assert ("storage size not constant" == NULL
);
13504 /* Output the assembler code and/or RTL code for variables and functions,
13505 unless the type is an undefined structure or union. If not, it will get
13506 done when the type is completed. */
13508 if (TREE_CODE (decl
) == VAR_DECL
|| TREE_CODE (decl
) == FUNCTION_DECL
)
13510 rest_of_decl_compilation (decl
, NULL
,
13511 DECL_CONTEXT (decl
) == 0,
13514 if (DECL_CONTEXT (decl
) != 0)
13516 /* Recompute the RTL of a local array now if it used to be an
13517 incomplete type. */
13519 && !TREE_STATIC (decl
) && !DECL_EXTERNAL (decl
))
13521 /* If we used it already as memory, it must stay in memory. */
13522 TREE_ADDRESSABLE (decl
) = TREE_USED (decl
);
13523 /* If it's still incomplete now, no init will save it. */
13524 if (DECL_SIZE (decl
) == 0)
13525 DECL_INITIAL (decl
) = 0;
13526 expand_decl (decl
);
13528 /* Compute and store the initial value. */
13529 if (TREE_CODE (decl
) != FUNCTION_DECL
)
13530 expand_decl_init (decl
);
13533 else if (TREE_CODE (decl
) == TYPE_DECL
)
13535 rest_of_decl_compilation (decl
, NULL
,
13536 DECL_CONTEXT (decl
) == 0,
13540 /* At the end of a declaration, throw away any variable type sizes of types
13541 defined inside that declaration. There is no use computing them in the
13542 following function definition. */
13543 if (current_binding_level
== global_binding_level
)
13544 get_pending_sizes ();
13547 /* Finish up a function declaration and compile that function
13548 all the way to assembler language output. The free the storage
13549 for the function definition.
13551 This is called after parsing the body of the function definition.
13553 NESTED is nonzero if the function being finished is nested in another. */
13556 finish_function (int nested
)
13558 register tree fndecl
= current_function_decl
;
13560 assert (fndecl
!= NULL_TREE
);
13561 if (TREE_CODE (fndecl
) != ERROR_MARK
)
13564 assert (DECL_CONTEXT (fndecl
) != NULL_TREE
);
13566 assert (DECL_CONTEXT (fndecl
) == NULL_TREE
);
13569 /* TREE_READONLY (fndecl) = 1;
13570 This caused &foo to be of type ptr-to-const-function
13571 which then got a warning when stored in a ptr-to-function variable. */
13573 poplevel (1, 0, 1);
13575 if (TREE_CODE (fndecl
) != ERROR_MARK
)
13577 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
13579 /* Must mark the RESULT_DECL as being in this function. */
13581 DECL_CONTEXT (DECL_RESULT (fndecl
)) = fndecl
;
13583 /* Obey `register' declarations if `setjmp' is called in this fn. */
13584 /* Generate rtl for function exit. */
13585 expand_function_end (input_filename
, lineno
, 0);
13587 /* If this is a nested function, protect the local variables in the stack
13588 above us from being collected while we're compiling this function. */
13590 ggc_push_context ();
13592 /* Run the optimizers and output the assembler code for this function. */
13593 rest_of_compilation (fndecl
);
13595 /* Undo the GC context switch. */
13597 ggc_pop_context ();
13600 if (TREE_CODE (fndecl
) != ERROR_MARK
13602 && DECL_SAVED_INSNS (fndecl
) == 0)
13604 /* Stop pointing to the local nodes about to be freed. */
13605 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13606 function definition. */
13607 /* For a nested function, this is done in pop_f_function_context. */
13608 /* If rest_of_compilation set this to 0, leave it 0. */
13609 if (DECL_INITIAL (fndecl
) != 0)
13610 DECL_INITIAL (fndecl
) = error_mark_node
;
13611 DECL_ARGUMENTS (fndecl
) = 0;
13616 /* Let the error reporting routines know that we're outside a function.
13617 For a nested function, this value is used in pop_c_function_context
13618 and then reset via pop_function_context. */
13619 ffecom_outer_function_decl_
= current_function_decl
= NULL
;
13623 /* Plug-in replacement for identifying the name of a decl and, for a
13624 function, what we call it in diagnostics. For now, "program unit"
13625 should suffice, since it's a bit of a hassle to figure out which
13626 of several kinds of things it is. Note that it could conceivably
13627 be a statement function, which probably isn't really a program unit
13628 per se, but if that comes up, it should be easy to check (being a
13629 nested function and all). */
13631 static const char *
13632 lang_printable_name (tree decl
, int v
)
13634 /* Just to keep GCC quiet about the unused variable.
13635 In theory, differing values of V should produce different
13640 if (TREE_CODE (decl
) == ERROR_MARK
)
13641 return "erroneous code";
13642 return IDENTIFIER_POINTER (DECL_NAME (decl
));
13646 /* g77's function to print out name of current function that caused
13650 lang_print_error_function (diagnostic_context
*context
__attribute__((unused
)),
13653 static ffeglobal last_g
= NULL
;
13654 static ffesymbol last_s
= NULL
;
13659 if ((ffecom_primary_entry_
== NULL
)
13660 || (ffesymbol_global (ffecom_primary_entry_
) == NULL
))
13668 g
= ffesymbol_global (ffecom_primary_entry_
);
13669 if (ffecom_nested_entry_
== NULL
)
13671 s
= ffecom_primary_entry_
;
13672 switch (ffesymbol_kind (s
))
13674 case FFEINFO_kindFUNCTION
:
13678 case FFEINFO_kindSUBROUTINE
:
13679 kind
= "subroutine";
13682 case FFEINFO_kindPROGRAM
:
13686 case FFEINFO_kindBLOCKDATA
:
13687 kind
= "block-data";
13691 kind
= ffeinfo_kind_message (ffesymbol_kind (s
));
13697 s
= ffecom_nested_entry_
;
13698 kind
= "statement function";
13702 if ((last_g
!= g
) || (last_s
!= s
))
13705 fprintf (stderr
, "%s: ", file
);
13708 fprintf (stderr
, "Outside of any program unit:\n");
13711 const char *name
= ffesymbol_text (s
);
13713 fprintf (stderr
, "In %s `%s':\n", kind
, name
);
13721 /* Similar to `lookup_name' but look only at current binding level. */
13724 lookup_name_current_level (tree name
)
13728 if (current_binding_level
== global_binding_level
)
13729 return IDENTIFIER_GLOBAL_VALUE (name
);
13731 if (IDENTIFIER_LOCAL_VALUE (name
) == 0)
13734 for (t
= current_binding_level
->names
; t
; t
= TREE_CHAIN (t
))
13735 if (DECL_NAME (t
) == name
)
13741 /* Create a new `struct binding_level'. */
13743 static struct binding_level
*
13744 make_binding_level ()
13747 return (struct binding_level
*) xmalloc (sizeof (struct binding_level
));
13750 /* Save and restore the variables in this file and elsewhere
13751 that keep track of the progress of compilation of the current function.
13752 Used for nested functions. */
13756 struct f_function
*next
;
13758 tree shadowed_labels
;
13759 struct binding_level
*binding_level
;
13762 struct f_function
*f_function_chain
;
13764 /* Restore the variables used during compilation of a C function. */
13767 pop_f_function_context ()
13769 struct f_function
*p
= f_function_chain
;
13772 /* Bring back all the labels that were shadowed. */
13773 for (link
= shadowed_labels
; link
; link
= TREE_CHAIN (link
))
13774 if (DECL_NAME (TREE_VALUE (link
)) != 0)
13775 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link
)))
13776 = TREE_VALUE (link
);
13778 if (current_function_decl
!= error_mark_node
13779 && DECL_SAVED_INSNS (current_function_decl
) == 0)
13781 /* Stop pointing to the local nodes about to be freed. */
13782 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13783 function definition. */
13784 DECL_INITIAL (current_function_decl
) = error_mark_node
;
13785 DECL_ARGUMENTS (current_function_decl
) = 0;
13788 pop_function_context ();
13790 f_function_chain
= p
->next
;
13792 named_labels
= p
->named_labels
;
13793 shadowed_labels
= p
->shadowed_labels
;
13794 current_binding_level
= p
->binding_level
;
13799 /* Save and reinitialize the variables
13800 used during compilation of a C function. */
13803 push_f_function_context ()
13805 struct f_function
*p
13806 = (struct f_function
*) xmalloc (sizeof (struct f_function
));
13808 push_function_context ();
13810 p
->next
= f_function_chain
;
13811 f_function_chain
= p
;
13813 p
->named_labels
= named_labels
;
13814 p
->shadowed_labels
= shadowed_labels
;
13815 p
->binding_level
= current_binding_level
;
13819 push_parm_decl (tree parm
)
13821 int old_immediate_size_expand
= immediate_size_expand
;
13823 /* Don't try computing parm sizes now -- wait till fn is called. */
13825 immediate_size_expand
= 0;
13827 /* Fill in arg stuff. */
13829 DECL_ARG_TYPE (parm
) = TREE_TYPE (parm
);
13830 DECL_ARG_TYPE_AS_WRITTEN (parm
) = TREE_TYPE (parm
);
13831 TREE_READONLY (parm
) = 1; /* All implementation args are read-only. */
13833 parm
= pushdecl (parm
);
13835 immediate_size_expand
= old_immediate_size_expand
;
13837 finish_decl (parm
, NULL_TREE
, FALSE
);
13840 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
13843 pushdecl_top_level (x
)
13847 register struct binding_level
*b
= current_binding_level
;
13848 register tree f
= current_function_decl
;
13850 current_binding_level
= global_binding_level
;
13851 current_function_decl
= NULL_TREE
;
13853 current_binding_level
= b
;
13854 current_function_decl
= f
;
13858 /* Store the list of declarations of the current level.
13859 This is done for the parameter declarations of a function being defined,
13860 after they are modified in the light of any missing parameters. */
13866 return current_binding_level
->names
= decls
;
13869 /* Store the parameter declarations into the current function declaration.
13870 This is called after parsing the parameter declarations, before
13871 digesting the body of the function.
13873 For an old-style definition, modify the function's type
13874 to specify at least the number of arguments. */
13877 store_parm_decls (int is_main_program UNUSED
)
13879 register tree fndecl
= current_function_decl
;
13881 if (fndecl
== error_mark_node
)
13884 /* This is a chain of PARM_DECLs from old-style parm declarations. */
13885 DECL_ARGUMENTS (fndecl
) = storedecls (nreverse (getdecls ()));
13887 /* Initialize the RTL code for the function. */
13889 init_function_start (fndecl
, input_filename
, lineno
);
13891 /* Set up parameters and prepare for return, for the function. */
13893 expand_function_start (fndecl
, 0);
13897 start_decl (tree decl
, bool is_top_level
)
13900 bool at_top_level
= (current_binding_level
== global_binding_level
);
13901 bool top_level
= is_top_level
|| at_top_level
;
13903 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13905 assert (!is_top_level
|| !at_top_level
);
13907 if (DECL_INITIAL (decl
) != NULL_TREE
)
13909 assert (DECL_INITIAL (decl
) == error_mark_node
);
13910 assert (!DECL_EXTERNAL (decl
));
13912 else if (top_level
)
13913 assert ((TREE_STATIC (decl
) == 1) || DECL_EXTERNAL (decl
) == 1);
13915 /* For Fortran, we by default put things in .common when possible. */
13916 DECL_COMMON (decl
) = 1;
13918 /* Add this decl to the current binding level. TEM may equal DECL or it may
13919 be a previous decl of the same name. */
13921 tem
= pushdecl_top_level (decl
);
13923 tem
= pushdecl (decl
);
13925 /* For a local variable, define the RTL now. */
13927 /* But not if this is a duplicate decl and we preserved the rtl from the
13928 previous one (which may or may not happen). */
13929 && !DECL_RTL_SET_P (tem
))
13931 if (TYPE_SIZE (TREE_TYPE (tem
)) != 0)
13933 else if (TREE_CODE (TREE_TYPE (tem
)) == ARRAY_TYPE
13934 && DECL_INITIAL (tem
) != 0)
13941 /* Create the FUNCTION_DECL for a function definition.
13942 DECLSPECS and DECLARATOR are the parts of the declaration;
13943 they describe the function's name and the type it returns,
13944 but twisted together in a fashion that parallels the syntax of C.
13946 This function creates a binding context for the function body
13947 as well as setting up the FUNCTION_DECL in current_function_decl.
13949 Returns 1 on success. If the DECLARATOR is not suitable for a function
13950 (it defines a datum instead), we return 0, which tells
13951 yyparse to report a parse error.
13953 NESTED is nonzero for a function nested within another function. */
13956 start_function (tree name
, tree type
, int nested
, int public)
13960 int old_immediate_size_expand
= immediate_size_expand
;
13963 shadowed_labels
= 0;
13965 /* Don't expand any sizes in the return type of the function. */
13966 immediate_size_expand
= 0;
13971 assert (current_function_decl
!= NULL_TREE
);
13972 assert (DECL_CONTEXT (current_function_decl
) == NULL_TREE
);
13976 assert (current_function_decl
== NULL_TREE
);
13979 if (TREE_CODE (type
) == ERROR_MARK
)
13980 decl1
= current_function_decl
= error_mark_node
;
13983 decl1
= build_decl (FUNCTION_DECL
,
13986 TREE_PUBLIC (decl1
) = public ? 1 : 0;
13988 DECL_INLINE (decl1
) = 1;
13989 TREE_STATIC (decl1
) = 1;
13990 DECL_EXTERNAL (decl1
) = 0;
13992 announce_function (decl1
);
13994 /* Make the init_value nonzero so pushdecl knows this is not tentative.
13995 error_mark_node is replaced below (in poplevel) with the BLOCK. */
13996 DECL_INITIAL (decl1
) = error_mark_node
;
13998 /* Record the decl so that the function name is defined. If we already have
13999 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
14001 current_function_decl
= pushdecl (decl1
);
14005 ffecom_outer_function_decl_
= current_function_decl
;
14008 current_binding_level
->prep_state
= 2;
14010 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
14012 make_decl_rtl (current_function_decl
, NULL
);
14014 restype
= TREE_TYPE (TREE_TYPE (current_function_decl
));
14015 DECL_RESULT (current_function_decl
)
14016 = build_decl (RESULT_DECL
, NULL_TREE
, restype
);
14019 if (!nested
&& (TREE_CODE (current_function_decl
) != ERROR_MARK
))
14020 TREE_ADDRESSABLE (current_function_decl
) = 1;
14022 immediate_size_expand
= old_immediate_size_expand
;
14025 /* Here are the public functions the GNU back end needs. */
14028 convert (type
, expr
)
14031 register tree e
= expr
;
14032 register enum tree_code code
= TREE_CODE (type
);
14034 if (type
== TREE_TYPE (e
)
14035 || TREE_CODE (e
) == ERROR_MARK
)
14037 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
14038 return fold (build1 (NOP_EXPR
, type
, e
));
14039 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
14040 || code
== ERROR_MARK
)
14041 return error_mark_node
;
14042 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
14044 assert ("void value not ignored as it ought to be" == NULL
);
14045 return error_mark_node
;
14047 if (code
== VOID_TYPE
)
14048 return build1 (CONVERT_EXPR
, type
, e
);
14049 if ((code
!= RECORD_TYPE
)
14050 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
14051 e
= ffecom_1 (REALPART_EXPR
, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
))),
14053 if (code
== INTEGER_TYPE
|| code
== ENUMERAL_TYPE
)
14054 return fold (convert_to_integer (type
, e
));
14055 if (code
== POINTER_TYPE
)
14056 return fold (convert_to_pointer (type
, e
));
14057 if (code
== REAL_TYPE
)
14058 return fold (convert_to_real (type
, e
));
14059 if (code
== COMPLEX_TYPE
)
14060 return fold (convert_to_complex (type
, e
));
14061 if (code
== RECORD_TYPE
)
14062 return fold (ffecom_convert_to_complex_ (type
, e
));
14064 assert ("conversion to non-scalar type requested" == NULL
);
14065 return error_mark_node
;
14068 /* integrate_decl_tree calls this function, but since we don't use the
14069 DECL_LANG_SPECIFIC field, this is a no-op. */
14072 copy_lang_decl (node
)
14077 /* Return the list of declarations of the current level.
14078 Note that this list is in reverse order unless/until
14079 you nreverse it; and when you do nreverse it, you must
14080 store the result back using `storedecls' or you will lose. */
14085 return current_binding_level
->names
;
14088 /* Nonzero if we are currently in the global binding level. */
14091 global_bindings_p ()
14093 return current_binding_level
== global_binding_level
;
14096 /* Print an error message for invalid use of an incomplete type.
14097 VALUE is the expression that was used (or 0 if that isn't known)
14098 and TYPE is the type that was invalid. */
14101 incomplete_type_error (value
, type
)
14105 if (TREE_CODE (type
) == ERROR_MARK
)
14108 assert ("incomplete type?!?" == NULL
);
14111 /* Mark ARG for GC. */
14113 mark_binding_level (void *arg
)
14115 struct binding_level
*level
= *(struct binding_level
**) arg
;
14119 ggc_mark_tree (level
->names
);
14120 ggc_mark_tree (level
->blocks
);
14121 ggc_mark_tree (level
->this_block
);
14122 level
= level
->level_chain
;
14127 ffecom_init_decl_processing ()
14129 static tree
*const tree_roots
[] = {
14130 ¤t_function_decl
,
14132 &ffecom_tree_fun_type_void
,
14133 &ffecom_integer_zero_node
,
14134 &ffecom_integer_one_node
,
14135 &ffecom_tree_subr_type
,
14136 &ffecom_tree_ptr_to_subr_type
,
14137 &ffecom_tree_blockdata_type
,
14138 &ffecom_tree_xargc_
,
14139 &ffecom_f2c_integer_type_node
,
14140 &ffecom_f2c_ptr_to_integer_type_node
,
14141 &ffecom_f2c_address_type_node
,
14142 &ffecom_f2c_real_type_node
,
14143 &ffecom_f2c_ptr_to_real_type_node
,
14144 &ffecom_f2c_doublereal_type_node
,
14145 &ffecom_f2c_complex_type_node
,
14146 &ffecom_f2c_doublecomplex_type_node
,
14147 &ffecom_f2c_longint_type_node
,
14148 &ffecom_f2c_logical_type_node
,
14149 &ffecom_f2c_flag_type_node
,
14150 &ffecom_f2c_ftnlen_type_node
,
14151 &ffecom_f2c_ftnlen_zero_node
,
14152 &ffecom_f2c_ftnlen_one_node
,
14153 &ffecom_f2c_ftnlen_two_node
,
14154 &ffecom_f2c_ptr_to_ftnlen_type_node
,
14155 &ffecom_f2c_ftnint_type_node
,
14156 &ffecom_f2c_ptr_to_ftnint_type_node
,
14157 &ffecom_outer_function_decl_
,
14158 &ffecom_previous_function_decl_
,
14159 &ffecom_which_entrypoint_decl_
,
14160 &ffecom_float_zero_
,
14161 &ffecom_float_half_
,
14162 &ffecom_double_zero_
,
14163 &ffecom_double_half_
,
14164 &ffecom_func_result_
,
14165 &ffecom_func_length_
,
14166 &ffecom_multi_type_node_
,
14167 &ffecom_multi_retval_
,
14175 /* Record our roots. */
14176 for (i
= 0; i
< ARRAY_SIZE (tree_roots
); i
++)
14177 ggc_add_tree_root (tree_roots
[i
], 1);
14178 ggc_add_tree_root (&ffecom_tree_type
[0][0],
14179 FFEINFO_basictype
*FFEINFO_kindtype
);
14180 ggc_add_tree_root (&ffecom_tree_fun_type
[0][0],
14181 FFEINFO_basictype
*FFEINFO_kindtype
);
14182 ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type
[0][0],
14183 FFEINFO_basictype
*FFEINFO_kindtype
);
14184 ggc_add_tree_root (ffecom_gfrt_
, FFECOM_gfrt
);
14185 ggc_add_root (¤t_binding_level
, 1, sizeof current_binding_level
,
14186 mark_binding_level
);
14187 ggc_add_root (&free_binding_level
, 1, sizeof current_binding_level
,
14188 mark_binding_level
);
14189 ggc_add_root (&tracker_head
, 1, sizeof tracker_head
, mark_tracker_head
);
14194 /* Delete the node BLOCK from the current binding level.
14195 This is used for the block inside a stmt expr ({...})
14196 so that the block can be reinserted where appropriate. */
14199 delete_block (block
)
14203 if (current_binding_level
->blocks
== block
)
14204 current_binding_level
->blocks
= TREE_CHAIN (block
);
14205 for (t
= current_binding_level
->blocks
; t
;)
14207 if (TREE_CHAIN (t
) == block
)
14208 TREE_CHAIN (t
) = TREE_CHAIN (block
);
14210 t
= TREE_CHAIN (t
);
14212 TREE_CHAIN (block
) = NULL
;
14213 /* Clear TREE_USED which is always set by poplevel.
14214 The flag is set again if insert_block is called. */
14215 TREE_USED (block
) = 0;
14219 insert_block (block
)
14222 TREE_USED (block
) = 1;
14223 current_binding_level
->blocks
14224 = chainon (current_binding_level
->blocks
, block
);
14227 /* Each front end provides its own. */
14228 static const char *ffe_init
PARAMS ((const char *));
14229 static void ffe_finish
PARAMS ((void));
14230 static void ffe_init_options
PARAMS ((void));
14231 static void ffe_print_identifier
PARAMS ((FILE *, tree
, int));
14233 #undef LANG_HOOKS_NAME
14234 #define LANG_HOOKS_NAME "GNU F77"
14235 #undef LANG_HOOKS_INIT
14236 #define LANG_HOOKS_INIT ffe_init
14237 #undef LANG_HOOKS_FINISH
14238 #define LANG_HOOKS_FINISH ffe_finish
14239 #undef LANG_HOOKS_INIT_OPTIONS
14240 #define LANG_HOOKS_INIT_OPTIONS ffe_init_options
14241 #undef LANG_HOOKS_DECODE_OPTION
14242 #define LANG_HOOKS_DECODE_OPTION ffe_decode_option
14243 #undef LANG_HOOKS_PRINT_IDENTIFIER
14244 #define LANG_HOOKS_PRINT_IDENTIFIER ffe_print_identifier
14246 /* We do not wish to use alias-set based aliasing at all. Used in the
14247 extreme (every object with its own set, with equivalences recorded) it
14248 might be helpful, but there are problems when it comes to inlining. We
14249 get on ok with flag_argument_noalias, and alias-set aliasing does
14250 currently limit how stack slots can be reused, which is a lose. */
14251 #undef LANG_HOOKS_GET_ALIAS_SET
14252 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14254 const struct lang_hooks lang_hooks
= LANG_HOOKS_INITIALIZER
;
14256 static const char *
14257 ffe_init (filename
)
14258 const char *filename
;
14260 /* Open input file. */
14261 if (filename
== 0 || !strcmp (filename
, "-"))
14264 filename
= "stdin";
14267 finput
= fopen (filename
, "r");
14269 fatal_io_error ("can't open %s", filename
);
14271 #ifdef IO_BUFFER_SIZE
14272 setvbuf (finput
, (char *) xmalloc (IO_BUFFER_SIZE
), _IOFBF
, IO_BUFFER_SIZE
);
14275 ffecom_init_decl_processing ();
14276 decl_printable_name
= lang_printable_name
;
14277 print_error_function
= lang_print_error_function
;
14279 /* If the file is output from cpp, it should contain a first line
14280 `# 1 "real-filename"', and the current design of gcc (toplev.c
14281 in particular and the way it sets up information relied on by
14282 INCLUDE) requires that we read this now, and store the
14283 "real-filename" info in master_input_filename. Ask the lexer
14284 to try doing this. */
14285 ffelex_hash_kludge (finput
);
14287 /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14288 return the new file name. */
14289 if (main_input_filename
)
14290 filename
= main_input_filename
;
14298 ffe_terminate_0 ();
14300 if (ffe_is_ffedebug ())
14301 malloc_pool_display (malloc_pool_image ());
14307 ffe_init_options ()
14309 /* Set default options for Fortran. */
14310 flag_move_all_movables
= 1;
14311 flag_reduce_all_givs
= 1;
14312 flag_argument_noalias
= 2;
14313 flag_merge_constants
= 2;
14314 flag_errno_math
= 0;
14315 flag_complex_divide_method
= 1;
14319 mark_addressable (exp
)
14322 register tree x
= exp
;
14324 switch (TREE_CODE (x
))
14327 case COMPONENT_REF
:
14329 x
= TREE_OPERAND (x
, 0);
14333 TREE_ADDRESSABLE (x
) = 1;
14340 if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
)
14341 && DECL_NONLOCAL (x
))
14343 if (TREE_PUBLIC (x
))
14345 assert ("address of global register var requested" == NULL
);
14348 assert ("address of register variable requested" == NULL
);
14350 else if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
))
14352 if (TREE_PUBLIC (x
))
14354 assert ("address of global register var requested" == NULL
);
14357 assert ("address of register var requested" == NULL
);
14359 put_var_into_stack (x
);
14362 case FUNCTION_DECL
:
14363 TREE_ADDRESSABLE (x
) = 1;
14364 #if 0 /* poplevel deals with this now. */
14365 if (DECL_CONTEXT (x
) == 0)
14366 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x
)) = 1;
14374 /* If DECL has a cleanup, build and return that cleanup here.
14375 This is a callback called by expand_expr. */
14378 maybe_build_cleanup (decl
)
14381 /* There are no cleanups in Fortran. */
14385 /* Exit a binding level.
14386 Pop the level off, and restore the state of the identifier-decl mappings
14387 that were in effect when this level was entered.
14389 If KEEP is nonzero, this level had explicit declarations, so
14390 and create a "block" (a BLOCK node) for the level
14391 to record its declarations and subblocks for symbol table output.
14393 If FUNCTIONBODY is nonzero, this level is the body of a function,
14394 so create a block as if KEEP were set and also clear out all
14397 If REVERSE is nonzero, reverse the order of decls before putting
14398 them into the BLOCK. */
14401 poplevel (keep
, reverse
, functionbody
)
14406 register tree link
;
14407 /* The chain of decls was accumulated in reverse order.
14408 Put it into forward order, just for cleanliness. */
14410 tree subblocks
= current_binding_level
->blocks
;
14413 int block_previously_created
;
14415 /* Get the decls in the order they were written.
14416 Usually current_binding_level->names is in reverse order.
14417 But parameter decls were previously put in forward order. */
14420 current_binding_level
->names
14421 = decls
= nreverse (current_binding_level
->names
);
14423 decls
= current_binding_level
->names
;
14425 /* Output any nested inline functions within this block
14426 if they weren't already output. */
14428 for (decl
= decls
; decl
; decl
= TREE_CHAIN (decl
))
14429 if (TREE_CODE (decl
) == FUNCTION_DECL
14430 && ! TREE_ASM_WRITTEN (decl
)
14431 && DECL_INITIAL (decl
) != 0
14432 && TREE_ADDRESSABLE (decl
))
14434 /* If this decl was copied from a file-scope decl
14435 on account of a block-scope extern decl,
14436 propagate TREE_ADDRESSABLE to the file-scope decl.
14438 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14439 true, since then the decl goes through save_for_inline_copying. */
14440 if (DECL_ABSTRACT_ORIGIN (decl
) != 0
14441 && DECL_ABSTRACT_ORIGIN (decl
) != decl
)
14442 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl
)) = 1;
14443 else if (DECL_SAVED_INSNS (decl
) != 0)
14445 push_function_context ();
14446 output_inline_function (decl
);
14447 pop_function_context ();
14451 /* If there were any declarations or structure tags in that level,
14452 or if this level is a function body,
14453 create a BLOCK to record them for the life of this function. */
14456 block_previously_created
= (current_binding_level
->this_block
!= 0);
14457 if (block_previously_created
)
14458 block
= current_binding_level
->this_block
;
14459 else if (keep
|| functionbody
)
14460 block
= make_node (BLOCK
);
14463 BLOCK_VARS (block
) = decls
;
14464 BLOCK_SUBBLOCKS (block
) = subblocks
;
14467 /* In each subblock, record that this is its superior. */
14469 for (link
= subblocks
; link
; link
= TREE_CHAIN (link
))
14470 BLOCK_SUPERCONTEXT (link
) = block
;
14472 /* Clear out the meanings of the local variables of this level. */
14474 for (link
= decls
; link
; link
= TREE_CHAIN (link
))
14476 if (DECL_NAME (link
) != 0)
14478 /* If the ident. was used or addressed via a local extern decl,
14479 don't forget that fact. */
14480 if (DECL_EXTERNAL (link
))
14482 if (TREE_USED (link
))
14483 TREE_USED (DECL_NAME (link
)) = 1;
14484 if (TREE_ADDRESSABLE (link
))
14485 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link
)) = 1;
14487 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link
)) = 0;
14491 /* If the level being exited is the top level of a function,
14492 check over all the labels, and clear out the current
14493 (function local) meanings of their names. */
14497 /* If this is the top level block of a function,
14498 the vars are the function's parameters.
14499 Don't leave them in the BLOCK because they are
14500 found in the FUNCTION_DECL instead. */
14502 BLOCK_VARS (block
) = 0;
14505 /* Pop the current level, and free the structure for reuse. */
14508 register struct binding_level
*level
= current_binding_level
;
14509 current_binding_level
= current_binding_level
->level_chain
;
14511 level
->level_chain
= free_binding_level
;
14512 free_binding_level
= level
;
14515 /* Dispose of the block that we just made inside some higher level. */
14517 && current_function_decl
!= error_mark_node
)
14518 DECL_INITIAL (current_function_decl
) = block
;
14521 if (!block_previously_created
)
14522 current_binding_level
->blocks
14523 = chainon (current_binding_level
->blocks
, block
);
14525 /* If we did not make a block for the level just exited,
14526 any blocks made for inner levels
14527 (since they cannot be recorded as subblocks in that level)
14528 must be carried forward so they will later become subblocks
14529 of something else. */
14530 else if (subblocks
)
14531 current_binding_level
->blocks
14532 = chainon (current_binding_level
->blocks
, subblocks
);
14535 TREE_USED (block
) = 1;
14540 ffe_print_identifier (file
, node
, indent
)
14545 print_node (file
, "global", IDENTIFIER_GLOBAL_VALUE (node
), indent
+ 4);
14546 print_node (file
, "local", IDENTIFIER_LOCAL_VALUE (node
), indent
+ 4);
14549 /* Record a decl-node X as belonging to the current lexical scope.
14550 Check for errors (such as an incompatible declaration for the same
14551 name already seen in the same scope).
14553 Returns either X or an old decl for the same name.
14554 If an old decl is returned, it may have been smashed
14555 to agree with what X says. */
14562 register tree name
= DECL_NAME (x
);
14563 register struct binding_level
*b
= current_binding_level
;
14565 if ((TREE_CODE (x
) == FUNCTION_DECL
)
14566 && (DECL_INITIAL (x
) == 0)
14567 && DECL_EXTERNAL (x
))
14568 DECL_CONTEXT (x
) = NULL_TREE
;
14570 DECL_CONTEXT (x
) = current_function_decl
;
14574 if (IDENTIFIER_INVENTED (name
))
14576 DECL_ARTIFICIAL (x
) = 1;
14577 DECL_IN_SYSTEM_HEADER (x
) = 1;
14580 t
= lookup_name_current_level (name
);
14582 assert ((t
== NULL_TREE
) || (DECL_CONTEXT (x
) == NULL_TREE
));
14584 /* Don't push non-parms onto list for parms until we understand
14585 why we're doing this and whether it works. */
14587 assert ((b
== global_binding_level
)
14588 || !ffecom_transform_only_dummies_
14589 || TREE_CODE (x
) == PARM_DECL
);
14591 if ((t
!= NULL_TREE
) && duplicate_decls (x
, t
))
14594 /* If we are processing a typedef statement, generate a whole new
14595 ..._TYPE node (which will be just an variant of the existing
14596 ..._TYPE node with identical properties) and then install the
14597 TYPE_DECL node generated to represent the typedef name as the
14598 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14600 The whole point here is to end up with a situation where each and every
14601 ..._TYPE node the compiler creates will be uniquely associated with
14602 AT MOST one node representing a typedef name. This way, even though
14603 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14604 (i.e. "typedef name") nodes very early on, later parts of the
14605 compiler can always do the reverse translation and get back the
14606 corresponding typedef name. For example, given:
14608 typedef struct S MY_TYPE; MY_TYPE object;
14610 Later parts of the compiler might only know that `object' was of type
14611 `struct S' if it were not for code just below. With this code
14612 however, later parts of the compiler see something like:
14614 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14616 And they can then deduce (from the node for type struct S') that the
14617 original object declaration was:
14621 Being able to do this is important for proper support of protoize, and
14622 also for generating precise symbolic debugging information which
14623 takes full account of the programmer's (typedef) vocabulary.
14625 Obviously, we don't want to generate a duplicate ..._TYPE node if the
14626 TYPE_DECL node that we are now processing really represents a
14627 standard built-in type.
14629 Since all standard types are effectively declared at line zero in the
14630 source file, we can easily check to see if we are working on a
14631 standard type by checking the current value of lineno. */
14633 if (TREE_CODE (x
) == TYPE_DECL
)
14635 if (DECL_SOURCE_LINE (x
) == 0)
14637 if (TYPE_NAME (TREE_TYPE (x
)) == 0)
14638 TYPE_NAME (TREE_TYPE (x
)) = x
;
14640 else if (TREE_TYPE (x
) != error_mark_node
)
14642 tree tt
= TREE_TYPE (x
);
14644 tt
= build_type_copy (tt
);
14645 TYPE_NAME (tt
) = x
;
14646 TREE_TYPE (x
) = tt
;
14650 /* This name is new in its binding level. Install the new declaration
14652 if (b
== global_binding_level
)
14653 IDENTIFIER_GLOBAL_VALUE (name
) = x
;
14655 IDENTIFIER_LOCAL_VALUE (name
) = x
;
14658 /* Put decls on list in reverse order. We will reverse them later if
14660 TREE_CHAIN (x
) = b
->names
;
14666 /* Nonzero if the current level needs to have a BLOCK made. */
14673 for (decl
= current_binding_level
->names
;
14675 decl
= TREE_CHAIN (decl
))
14677 if (TREE_USED (decl
) || TREE_CODE (decl
) != VAR_DECL
14678 || (DECL_NAME (decl
) && ! DECL_ARTIFICIAL (decl
)))
14679 /* Currently, there aren't supposed to be non-artificial names
14680 at other than the top block for a function -- they're
14681 believed to always be temps. But it's wise to check anyway. */
14687 /* Enter a new binding level.
14688 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14689 not for that of tags. */
14692 pushlevel (tag_transparent
)
14693 int tag_transparent
;
14695 register struct binding_level
*newlevel
= NULL_BINDING_LEVEL
;
14697 assert (! tag_transparent
);
14699 if (current_binding_level
== global_binding_level
)
14704 /* Reuse or create a struct for this binding level. */
14706 if (free_binding_level
)
14708 newlevel
= free_binding_level
;
14709 free_binding_level
= free_binding_level
->level_chain
;
14713 newlevel
= make_binding_level ();
14716 /* Add this level to the front of the chain (stack) of levels that
14719 *newlevel
= clear_binding_level
;
14720 newlevel
->level_chain
= current_binding_level
;
14721 current_binding_level
= newlevel
;
14724 /* Set the BLOCK node for the innermost scope
14725 (the one we are currently in). */
14729 register tree block
;
14731 current_binding_level
->this_block
= block
;
14732 current_binding_level
->names
= chainon (current_binding_level
->names
,
14733 BLOCK_VARS (block
));
14734 current_binding_level
->blocks
= chainon (current_binding_level
->blocks
,
14735 BLOCK_SUBBLOCKS (block
));
14739 signed_or_unsigned_type (unsignedp
, type
)
14745 if (! INTEGRAL_TYPE_P (type
))
14747 if (TYPE_PRECISION (type
) == TYPE_PRECISION (signed_char_type_node
))
14748 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
14749 if (TYPE_PRECISION (type
) == TYPE_PRECISION (integer_type_node
))
14750 return unsignedp
? unsigned_type_node
: integer_type_node
;
14751 if (TYPE_PRECISION (type
) == TYPE_PRECISION (short_integer_type_node
))
14752 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
14753 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_integer_type_node
))
14754 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
14755 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_long_integer_type_node
))
14756 return (unsignedp
? long_long_unsigned_type_node
14757 : long_long_integer_type_node
);
14759 type2
= type_for_size (TYPE_PRECISION (type
), unsignedp
);
14760 if (type2
== NULL_TREE
)
14770 tree type1
= TYPE_MAIN_VARIANT (type
);
14771 ffeinfoKindtype kt
;
14774 if (type1
== unsigned_char_type_node
|| type1
== char_type_node
)
14775 return signed_char_type_node
;
14776 if (type1
== unsigned_type_node
)
14777 return integer_type_node
;
14778 if (type1
== short_unsigned_type_node
)
14779 return short_integer_type_node
;
14780 if (type1
== long_unsigned_type_node
)
14781 return long_integer_type_node
;
14782 if (type1
== long_long_unsigned_type_node
)
14783 return long_long_integer_type_node
;
14784 #if 0 /* gcc/c-* files only */
14785 if (type1
== unsigned_intDI_type_node
)
14786 return intDI_type_node
;
14787 if (type1
== unsigned_intSI_type_node
)
14788 return intSI_type_node
;
14789 if (type1
== unsigned_intHI_type_node
)
14790 return intHI_type_node
;
14791 if (type1
== unsigned_intQI_type_node
)
14792 return intQI_type_node
;
14795 type2
= type_for_size (TYPE_PRECISION (type1
), 0);
14796 if (type2
!= NULL_TREE
)
14799 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
14801 type2
= ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
14803 if (type1
== type2
)
14804 return ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
14810 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14811 or validate its data type for an `if' or `while' statement or ?..: exp.
14813 This preparation consists of taking the ordinary
14814 representation of an expression expr and producing a valid tree
14815 boolean expression describing whether expr is nonzero. We could
14816 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14817 but we optimize comparisons, &&, ||, and !.
14819 The resulting type should always be `integer_type_node'. */
14822 truthvalue_conversion (expr
)
14825 if (TREE_CODE (expr
) == ERROR_MARK
)
14828 #if 0 /* This appears to be wrong for C++. */
14829 /* These really should return error_mark_node after 2.4 is stable.
14830 But not all callers handle ERROR_MARK properly. */
14831 switch (TREE_CODE (TREE_TYPE (expr
)))
14834 error ("struct type value used where scalar is required");
14835 return integer_zero_node
;
14838 error ("union type value used where scalar is required");
14839 return integer_zero_node
;
14842 error ("array type value used where scalar is required");
14843 return integer_zero_node
;
14850 switch (TREE_CODE (expr
))
14852 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14853 or comparison expressions as truth values at this level. */
14855 case COMPONENT_REF
:
14856 /* A one-bit unsigned bit-field is already acceptable. */
14857 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr
, 1)))
14858 && TREE_UNSIGNED (TREE_OPERAND (expr
, 1)))
14864 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14865 or comparison expressions as truth values at this level. */
14867 if (integer_zerop (TREE_OPERAND (expr
, 1)))
14868 return build_unary_op (TRUTH_NOT_EXPR
, TREE_OPERAND (expr
, 0), 0);
14870 case NE_EXPR
: case LE_EXPR
: case GE_EXPR
: case LT_EXPR
: case GT_EXPR
:
14871 case TRUTH_ANDIF_EXPR
:
14872 case TRUTH_ORIF_EXPR
:
14873 case TRUTH_AND_EXPR
:
14874 case TRUTH_OR_EXPR
:
14875 case TRUTH_XOR_EXPR
:
14876 TREE_TYPE (expr
) = integer_type_node
;
14883 return integer_zerop (expr
) ? integer_zero_node
: integer_one_node
;
14886 return real_zerop (expr
) ? integer_zero_node
: integer_one_node
;
14889 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 0)))
14890 return build (COMPOUND_EXPR
, integer_type_node
,
14891 TREE_OPERAND (expr
, 0), integer_one_node
);
14893 return integer_one_node
;
14896 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1))
14897 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
14899 truthvalue_conversion (TREE_OPERAND (expr
, 0)),
14900 truthvalue_conversion (TREE_OPERAND (expr
, 1)));
14906 /* These don't change whether an object is non-zero or zero. */
14907 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
14911 /* These don't change whether an object is zero or non-zero, but
14912 we can't ignore them if their second arg has side-effects. */
14913 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1)))
14914 return build (COMPOUND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 1),
14915 truthvalue_conversion (TREE_OPERAND (expr
, 0)));
14917 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
14920 /* Distribute the conversion into the arms of a COND_EXPR. */
14921 return fold (build (COND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 0),
14922 truthvalue_conversion (TREE_OPERAND (expr
, 1)),
14923 truthvalue_conversion (TREE_OPERAND (expr
, 2))));
14926 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14927 since that affects how `default_conversion' will behave. */
14928 if (TREE_CODE (TREE_TYPE (expr
)) == REFERENCE_TYPE
14929 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == REFERENCE_TYPE
)
14931 /* fall through... */
14933 /* If this is widening the argument, we can ignore it. */
14934 if (TYPE_PRECISION (TREE_TYPE (expr
))
14935 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr
, 0))))
14936 return truthvalue_conversion (TREE_OPERAND (expr
, 0));
14940 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14942 if (TARGET_FLOAT_FORMAT
== IEEE_FLOAT_FORMAT
14943 && TREE_CODE (TREE_TYPE (expr
)) == REAL_TYPE
)
14945 /* fall through... */
14947 /* This and MINUS_EXPR can be changed into a comparison of the
14949 if (TREE_TYPE (TREE_OPERAND (expr
, 0))
14950 == TREE_TYPE (TREE_OPERAND (expr
, 1)))
14951 return ffecom_2 (NE_EXPR
, integer_type_node
,
14952 TREE_OPERAND (expr
, 0),
14953 TREE_OPERAND (expr
, 1));
14954 return ffecom_2 (NE_EXPR
, integer_type_node
,
14955 TREE_OPERAND (expr
, 0),
14956 fold (build1 (NOP_EXPR
,
14957 TREE_TYPE (TREE_OPERAND (expr
, 0)),
14958 TREE_OPERAND (expr
, 1))));
14961 if (integer_onep (TREE_OPERAND (expr
, 1)))
14966 #if 0 /* No such thing in Fortran. */
14967 if (warn_parentheses
&& C_EXP_ORIGINAL_CODE (expr
) == MODIFY_EXPR
)
14968 warning ("suggest parentheses around assignment used as truth value");
14976 if (TREE_CODE (TREE_TYPE (expr
)) == COMPLEX_TYPE
)
14978 ((TREE_SIDE_EFFECTS (expr
)
14979 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
14981 truthvalue_conversion (ffecom_1 (REALPART_EXPR
,
14982 TREE_TYPE (TREE_TYPE (expr
)),
14984 truthvalue_conversion (ffecom_1 (IMAGPART_EXPR
,
14985 TREE_TYPE (TREE_TYPE (expr
)),
14988 return ffecom_2 (NE_EXPR
, integer_type_node
,
14990 convert (TREE_TYPE (expr
), integer_zero_node
));
14994 type_for_mode (mode
, unsignedp
)
14995 enum machine_mode mode
;
15002 if (mode
== TYPE_MODE (integer_type_node
))
15003 return unsignedp
? unsigned_type_node
: integer_type_node
;
15005 if (mode
== TYPE_MODE (signed_char_type_node
))
15006 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15008 if (mode
== TYPE_MODE (short_integer_type_node
))
15009 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15011 if (mode
== TYPE_MODE (long_integer_type_node
))
15012 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15014 if (mode
== TYPE_MODE (long_long_integer_type_node
))
15015 return unsignedp
? long_long_unsigned_type_node
: long_long_integer_type_node
;
15017 #if HOST_BITS_PER_WIDE_INT >= 64
15018 if (mode
== TYPE_MODE (intTI_type_node
))
15019 return unsignedp
? unsigned_intTI_type_node
: intTI_type_node
;
15022 if (mode
== TYPE_MODE (float_type_node
))
15023 return float_type_node
;
15025 if (mode
== TYPE_MODE (double_type_node
))
15026 return double_type_node
;
15028 if (mode
== TYPE_MODE (build_pointer_type (char_type_node
)))
15029 return build_pointer_type (char_type_node
);
15031 if (mode
== TYPE_MODE (build_pointer_type (integer_type_node
)))
15032 return build_pointer_type (integer_type_node
);
15034 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
15035 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
15037 if (((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
15038 && (mode
== TYPE_MODE (t
)))
15040 if ((i
== FFEINFO_basictypeINTEGER
) && unsignedp
)
15041 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][j
];
15051 type_for_size (bits
, unsignedp
)
15055 ffeinfoKindtype kt
;
15058 if (bits
== TYPE_PRECISION (integer_type_node
))
15059 return unsignedp
? unsigned_type_node
: integer_type_node
;
15061 if (bits
== TYPE_PRECISION (signed_char_type_node
))
15062 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
15064 if (bits
== TYPE_PRECISION (short_integer_type_node
))
15065 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
15067 if (bits
== TYPE_PRECISION (long_integer_type_node
))
15068 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
15070 if (bits
== TYPE_PRECISION (long_long_integer_type_node
))
15071 return (unsignedp
? long_long_unsigned_type_node
15072 : long_long_integer_type_node
);
15074 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15076 type_node
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15078 if ((type_node
!= NULL_TREE
) && (bits
== TYPE_PRECISION (type_node
)))
15079 return unsignedp
? ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
]
15087 unsigned_type (type
)
15090 tree type1
= TYPE_MAIN_VARIANT (type
);
15091 ffeinfoKindtype kt
;
15094 if (type1
== signed_char_type_node
|| type1
== char_type_node
)
15095 return unsigned_char_type_node
;
15096 if (type1
== integer_type_node
)
15097 return unsigned_type_node
;
15098 if (type1
== short_integer_type_node
)
15099 return short_unsigned_type_node
;
15100 if (type1
== long_integer_type_node
)
15101 return long_unsigned_type_node
;
15102 if (type1
== long_long_integer_type_node
)
15103 return long_long_unsigned_type_node
;
15104 #if 0 /* gcc/c-* files only */
15105 if (type1
== intDI_type_node
)
15106 return unsigned_intDI_type_node
;
15107 if (type1
== intSI_type_node
)
15108 return unsigned_intSI_type_node
;
15109 if (type1
== intHI_type_node
)
15110 return unsigned_intHI_type_node
;
15111 if (type1
== intQI_type_node
)
15112 return unsigned_intQI_type_node
;
15115 type2
= type_for_size (TYPE_PRECISION (type1
), 1);
15116 if (type2
!= NULL_TREE
)
15119 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
15121 type2
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
15123 if (type1
== type2
)
15124 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
15132 union tree_node
*t ATTRIBUTE_UNUSED
;
15134 if (TREE_CODE (t
) == IDENTIFIER_NODE
)
15136 struct lang_identifier
*i
= (struct lang_identifier
*) t
;
15137 ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i
));
15138 ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i
));
15139 ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i
));
15141 else if (TYPE_P (t
) && TYPE_LANG_SPECIFIC (t
))
15142 ggc_mark (TYPE_LANG_SPECIFIC (t
));
15145 /* From gcc/cccp.c, the code to handle -I. */
15147 /* Skip leading "./" from a directory name.
15148 This may yield the empty string, which represents the current directory. */
15150 static const char *
15151 skip_redundant_dir_prefix (const char *dir
)
15153 while (dir
[0] == '.' && dir
[1] == '/')
15154 for (dir
+= 2; *dir
== '/'; dir
++)
15156 if (dir
[0] == '.' && !dir
[1])
15161 /* The file_name_map structure holds a mapping of file names for a
15162 particular directory. This mapping is read from the file named
15163 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15164 map filenames on a file system with severe filename restrictions,
15165 such as DOS. The format of the file name map file is just a series
15166 of lines with two tokens on each line. The first token is the name
15167 to map, and the second token is the actual name to use. */
15169 struct file_name_map
15171 struct file_name_map
*map_next
;
15176 #define FILE_NAME_MAP_FILE "header.gcc"
15178 /* Current maximum length of directory names in the search path
15179 for include files. (Altered as we get more of them.) */
15181 static int max_include_len
= 0;
15183 struct file_name_list
15185 struct file_name_list
*next
;
15187 /* Mapping of file names for this directory. */
15188 struct file_name_map
*name_map
;
15189 /* Non-zero if name_map is valid. */
15193 static struct file_name_list
*include
= NULL
; /* First dir to search */
15194 static struct file_name_list
*last_include
= NULL
; /* Last in chain */
15196 /* I/O buffer structure.
15197 The `fname' field is nonzero for source files and #include files
15198 and for the dummy text used for -D and -U.
15199 It is zero for rescanning results of macro expansion
15200 and for expanding macro arguments. */
15201 #define INPUT_STACK_MAX 400
15202 static struct file_buf
{
15204 /* Filename specified with #line command. */
15205 const char *nominal_fname
;
15206 /* Record where in the search path this file was found.
15207 For #include_next. */
15208 struct file_name_list
*dir
;
15210 ffewhereColumn column
;
15211 } instack
[INPUT_STACK_MAX
];
15213 static int last_error_tick
= 0; /* Incremented each time we print it. */
15214 static int input_file_stack_tick
= 0; /* Incremented when status changes. */
15216 /* Current nesting level of input sources.
15217 `instack[indepth]' is the level currently being read. */
15218 static int indepth
= -1;
15220 typedef struct file_buf FILE_BUF
;
15222 /* Nonzero means -I- has been seen,
15223 so don't look for #include "foo" the source-file directory. */
15224 static int ignore_srcdir
;
15226 #ifndef INCLUDE_LEN_FUDGE
15227 #define INCLUDE_LEN_FUDGE 0
15230 static void append_include_chain (struct file_name_list
*first
,
15231 struct file_name_list
*last
);
15232 static FILE *open_include_file (char *filename
,
15233 struct file_name_list
*searchptr
);
15234 static void print_containing_files (ffebadSeverity sev
);
15235 static char *read_filename_string (int ch
, FILE *f
);
15236 static struct file_name_map
*read_name_map (const char *dirname
);
15238 /* Append a chain of `struct file_name_list's
15239 to the end of the main include chain.
15240 FIRST is the beginning of the chain to append, and LAST is the end. */
15243 append_include_chain (first
, last
)
15244 struct file_name_list
*first
, *last
;
15246 struct file_name_list
*dir
;
15248 if (!first
|| !last
)
15254 last_include
->next
= first
;
15256 for (dir
= first
; ; dir
= dir
->next
) {
15257 int len
= strlen (dir
->fname
) + INCLUDE_LEN_FUDGE
;
15258 if (len
> max_include_len
)
15259 max_include_len
= len
;
15265 last_include
= last
;
15268 /* Try to open include file FILENAME. SEARCHPTR is the directory
15269 being tried from the include file search path. This function maps
15270 filenames on file systems based on information read by
15274 open_include_file (filename
, searchptr
)
15276 struct file_name_list
*searchptr
;
15278 register struct file_name_map
*map
;
15279 register char *from
;
15282 if (searchptr
&& ! searchptr
->got_name_map
)
15284 searchptr
->name_map
= read_name_map (searchptr
->fname
15285 ? searchptr
->fname
: ".");
15286 searchptr
->got_name_map
= 1;
15289 /* First check the mapping for the directory we are using. */
15290 if (searchptr
&& searchptr
->name_map
)
15293 if (searchptr
->fname
)
15294 from
+= strlen (searchptr
->fname
) + 1;
15295 for (map
= searchptr
->name_map
; map
; map
= map
->map_next
)
15297 if (! strcmp (map
->map_from
, from
))
15299 /* Found a match. */
15300 return fopen (map
->map_to
, "r");
15305 /* Try to find a mapping file for the particular directory we are
15306 looking in. Thus #include <sys/types.h> will look up sys/types.h
15307 in /usr/include/header.gcc and look up types.h in
15308 /usr/include/sys/header.gcc. */
15309 p
= strrchr (filename
, '/');
15310 #ifdef DIR_SEPARATOR
15311 if (! p
) p
= strrchr (filename
, DIR_SEPARATOR
);
15313 char *tmp
= strrchr (filename
, DIR_SEPARATOR
);
15314 if (tmp
!= NULL
&& tmp
> p
) p
= tmp
;
15320 && searchptr
->fname
15321 && strlen (searchptr
->fname
) == (size_t) (p
- filename
)
15322 && ! strncmp (searchptr
->fname
, filename
, (int) (p
- filename
)))
15324 /* FILENAME is in SEARCHPTR, which we've already checked. */
15325 return fopen (filename
, "r");
15331 map
= read_name_map (".");
15335 dir
= (char *) xmalloc (p
- filename
+ 1);
15336 memcpy (dir
, filename
, p
- filename
);
15337 dir
[p
- filename
] = '\0';
15339 map
= read_name_map (dir
);
15342 for (; map
; map
= map
->map_next
)
15343 if (! strcmp (map
->map_from
, from
))
15344 return fopen (map
->map_to
, "r");
15346 return fopen (filename
, "r");
15349 /* Print the file names and line numbers of the #include
15350 commands which led to the current file. */
15353 print_containing_files (ffebadSeverity sev
)
15355 FILE_BUF
*ip
= NULL
;
15361 /* If stack of files hasn't changed since we last printed
15362 this info, don't repeat it. */
15363 if (last_error_tick
== input_file_stack_tick
)
15366 for (i
= indepth
; i
>= 0; i
--)
15367 if (instack
[i
].fname
!= NULL
) {
15372 /* Give up if we don't find a source file. */
15376 /* Find the other, outer source files. */
15377 for (i
--; i
>= 0; i
--)
15378 if (instack
[i
].fname
!= NULL
)
15384 str1
= "In file included";
15396 ffebad_start_msg ("%A from %B at %0%C", sev
);
15397 ffebad_here (0, ip
->line
, ip
->column
);
15398 ffebad_string (str1
);
15399 ffebad_string (ip
->nominal_fname
);
15400 ffebad_string (str2
);
15404 /* Record we have printed the status as of this time. */
15405 last_error_tick
= input_file_stack_tick
;
15408 /* Read a space delimited string of unlimited length from a stdio
15412 read_filename_string (ch
, f
)
15420 set
= alloc
= xmalloc (len
+ 1);
15421 if (! ISSPACE (ch
))
15424 while ((ch
= getc (f
)) != EOF
&& ! ISSPACE (ch
))
15426 if (set
- alloc
== len
)
15429 alloc
= xrealloc (alloc
, len
+ 1);
15430 set
= alloc
+ len
/ 2;
15440 /* Read the file name map file for DIRNAME. */
15442 static struct file_name_map
*
15443 read_name_map (dirname
)
15444 const char *dirname
;
15446 /* This structure holds a linked list of file name maps, one per
15448 struct file_name_map_list
15450 struct file_name_map_list
*map_list_next
;
15451 char *map_list_name
;
15452 struct file_name_map
*map_list_map
;
15454 static struct file_name_map_list
*map_list
;
15455 register struct file_name_map_list
*map_list_ptr
;
15459 int separator_needed
;
15461 dirname
= skip_redundant_dir_prefix (dirname
);
15463 for (map_list_ptr
= map_list
; map_list_ptr
;
15464 map_list_ptr
= map_list_ptr
->map_list_next
)
15465 if (! strcmp (map_list_ptr
->map_list_name
, dirname
))
15466 return map_list_ptr
->map_list_map
;
15468 map_list_ptr
= ((struct file_name_map_list
*)
15469 xmalloc (sizeof (struct file_name_map_list
)));
15470 map_list_ptr
->map_list_name
= xstrdup (dirname
);
15471 map_list_ptr
->map_list_map
= NULL
;
15473 dirlen
= strlen (dirname
);
15474 separator_needed
= dirlen
!= 0 && dirname
[dirlen
- 1] != '/';
15475 name
= (char *) xmalloc (dirlen
+ strlen (FILE_NAME_MAP_FILE
) + 2);
15476 strcpy (name
, dirname
);
15477 name
[dirlen
] = '/';
15478 strcpy (name
+ dirlen
+ separator_needed
, FILE_NAME_MAP_FILE
);
15479 f
= fopen (name
, "r");
15482 map_list_ptr
->map_list_map
= NULL
;
15487 while ((ch
= getc (f
)) != EOF
)
15490 struct file_name_map
*ptr
;
15494 from
= read_filename_string (ch
, f
);
15495 while ((ch
= getc (f
)) != EOF
&& ISSPACE (ch
) && ch
!= '\n')
15497 to
= read_filename_string (ch
, f
);
15499 ptr
= ((struct file_name_map
*)
15500 xmalloc (sizeof (struct file_name_map
)));
15501 ptr
->map_from
= from
;
15503 /* Make the real filename absolute. */
15508 ptr
->map_to
= xmalloc (dirlen
+ strlen (to
) + 2);
15509 strcpy (ptr
->map_to
, dirname
);
15510 ptr
->map_to
[dirlen
] = '/';
15511 strcpy (ptr
->map_to
+ dirlen
+ separator_needed
, to
);
15515 ptr
->map_next
= map_list_ptr
->map_list_map
;
15516 map_list_ptr
->map_list_map
= ptr
;
15518 while ((ch
= getc (f
)) != '\n')
15525 map_list_ptr
->map_list_next
= map_list
;
15526 map_list
= map_list_ptr
;
15528 return map_list_ptr
->map_list_map
;
15532 ffecom_file_ (const char *name
)
15536 /* Do partial setup of input buffer for the sake of generating
15537 early #line directives (when -g is in effect). */
15539 fp
= &instack
[++indepth
];
15540 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
15543 fp
->nominal_fname
= fp
->fname
= name
;
15547 ffecom_close_include_ (FILE *f
)
15552 input_file_stack_tick
++;
15554 ffewhere_line_kill (instack
[indepth
].line
);
15555 ffewhere_column_kill (instack
[indepth
].column
);
15559 ffecom_decode_include_option_ (char *spec
)
15561 struct file_name_list
*dirtmp
;
15563 if (! ignore_srcdir
&& !strcmp (spec
, "-"))
15567 dirtmp
= (struct file_name_list
*)
15568 xmalloc (sizeof (struct file_name_list
));
15569 dirtmp
->next
= 0; /* New one goes on the end */
15570 dirtmp
->fname
= spec
;
15571 dirtmp
->got_name_map
= 0;
15573 error ("directory name must immediately follow -I");
15575 append_include_chain (dirtmp
, dirtmp
);
15580 /* Open INCLUDEd file. */
15583 ffecom_open_include_ (char *name
, ffewhereLine l
, ffewhereColumn c
)
15586 size_t flen
= strlen (fbeg
);
15587 struct file_name_list
*search_start
= include
; /* Chain of dirs to search */
15588 struct file_name_list dsp
[1]; /* First in chain, if #include "..." */
15589 struct file_name_list
*searchptr
= 0;
15590 char *fname
; /* Dynamically allocated fname buffer */
15597 dsp
[0].fname
= NULL
;
15599 /* If -I- was specified, don't search current dir, only spec'd ones. */
15600 if (!ignore_srcdir
)
15602 for (fp
= &instack
[indepth
]; fp
>= instack
; fp
--)
15608 if ((nam
= fp
->nominal_fname
) != NULL
)
15610 /* Found a named file. Figure out dir of the file,
15611 and put it in front of the search list. */
15612 dsp
[0].next
= search_start
;
15613 search_start
= dsp
;
15615 ep
= strrchr (nam
, '/');
15616 #ifdef DIR_SEPARATOR
15617 if (ep
== NULL
) ep
= strrchr (nam
, DIR_SEPARATOR
);
15619 char *tmp
= strrchr (nam
, DIR_SEPARATOR
);
15620 if (tmp
!= NULL
&& tmp
> ep
) ep
= tmp
;
15624 ep
= strrchr (nam
, ']');
15625 if (ep
== NULL
) ep
= strrchr (nam
, '>');
15626 if (ep
== NULL
) ep
= strrchr (nam
, ':');
15627 if (ep
!= NULL
) ep
++;
15632 dsp
[0].fname
= (char *) xmalloc (n
+ 1);
15633 strncpy (dsp
[0].fname
, nam
, n
);
15634 dsp
[0].fname
[n
] = '\0';
15635 if (n
+ INCLUDE_LEN_FUDGE
> max_include_len
)
15636 max_include_len
= n
+ INCLUDE_LEN_FUDGE
;
15639 dsp
[0].fname
= NULL
; /* Current directory */
15640 dsp
[0].got_name_map
= 0;
15646 /* Allocate this permanently, because it gets stored in the definitions
15648 fname
= xmalloc (max_include_len
+ flen
+ 4);
15649 /* + 2 above for slash and terminating null. */
15650 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15653 /* If specified file name is absolute, just open it. */
15656 #ifdef DIR_SEPARATOR
15657 || *fbeg
== DIR_SEPARATOR
15661 strncpy (fname
, (char *) fbeg
, flen
);
15663 f
= open_include_file (fname
, NULL
);
15669 /* Search directory path, trying to open the file.
15670 Copy each filename tried into FNAME. */
15672 for (searchptr
= search_start
; searchptr
; searchptr
= searchptr
->next
)
15674 if (searchptr
->fname
)
15676 /* The empty string in a search path is ignored.
15677 This makes it possible to turn off entirely
15678 a standard piece of the list. */
15679 if (searchptr
->fname
[0] == 0)
15681 strcpy (fname
, skip_redundant_dir_prefix (searchptr
->fname
));
15682 if (fname
[0] && fname
[strlen (fname
) - 1] != '/')
15683 strcat (fname
, "/");
15684 fname
[strlen (fname
) + flen
] = 0;
15689 strncat (fname
, fbeg
, flen
);
15691 /* Change this 1/2 Unix 1/2 VMS file specification into a
15692 full VMS file specification */
15693 if (searchptr
->fname
&& (searchptr
->fname
[0] != 0))
15695 /* Fix up the filename */
15696 hack_vms_include_specification (fname
);
15700 /* This is a normal VMS filespec, so use it unchanged. */
15701 strncpy (fname
, (char *) fbeg
, flen
);
15703 #if 0 /* Not for g77. */
15704 /* if it's '#include filename', add the missing .h */
15705 if (strchr (fname
, '.') == NULL
)
15706 strcat (fname
, ".h");
15710 f
= open_include_file (fname
, searchptr
);
15712 if (f
== NULL
&& errno
== EACCES
)
15714 print_containing_files (FFEBAD_severityWARNING
);
15715 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15716 FFEBAD_severityWARNING
);
15717 ffebad_string (fname
);
15718 ffebad_here (0, l
, c
);
15729 /* A file that was not found. */
15731 strncpy (fname
, (char *) fbeg
, flen
);
15733 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE
));
15734 ffebad_start (FFEBAD_OPEN_INCLUDE
);
15735 ffebad_here (0, l
, c
);
15736 ffebad_string (fname
);
15740 if (dsp
[0].fname
!= NULL
)
15741 free (dsp
[0].fname
);
15746 if (indepth
>= (INPUT_STACK_MAX
- 1))
15748 print_containing_files (FFEBAD_severityFATAL
);
15749 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15750 FFEBAD_severityFATAL
);
15751 ffebad_string (fname
);
15752 ffebad_here (0, l
, c
);
15757 instack
[indepth
].line
= ffewhere_line_use (l
);
15758 instack
[indepth
].column
= ffewhere_column_use (c
);
15760 fp
= &instack
[indepth
+ 1];
15761 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
15762 fp
->nominal_fname
= fp
->fname
= fname
;
15763 fp
->dir
= searchptr
;
15766 input_file_stack_tick
++;
15771 /**INDENT* (Do not reformat this comment even with -fca option.)
15772 Data-gathering files: Given the source file listed below, compiled with
15773 f2c I obtained the output file listed after that, and from the output
15774 file I derived the above code.
15776 -------- (begin input file to f2c)
15782 double precision D1,D2
15784 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15811 c FFEINTRIN_impACOS
15812 call fooR(ACOS(R1))
15813 c FFEINTRIN_impAIMAG
15814 call fooR(AIMAG(C1))
15815 c FFEINTRIN_impAINT
15816 call fooR(AINT(R1))
15817 c FFEINTRIN_impALOG
15818 call fooR(ALOG(R1))
15819 c FFEINTRIN_impALOG10
15820 call fooR(ALOG10(R1))
15821 c FFEINTRIN_impAMAX0
15822 call fooR(AMAX0(I1,I2))
15823 c FFEINTRIN_impAMAX1
15824 call fooR(AMAX1(R1,R2))
15825 c FFEINTRIN_impAMIN0
15826 call fooR(AMIN0(I1,I2))
15827 c FFEINTRIN_impAMIN1
15828 call fooR(AMIN1(R1,R2))
15829 c FFEINTRIN_impAMOD
15830 call fooR(AMOD(R1,R2))
15831 c FFEINTRIN_impANINT
15832 call fooR(ANINT(R1))
15833 c FFEINTRIN_impASIN
15834 call fooR(ASIN(R1))
15835 c FFEINTRIN_impATAN
15836 call fooR(ATAN(R1))
15837 c FFEINTRIN_impATAN2
15838 call fooR(ATAN2(R1,R2))
15839 c FFEINTRIN_impCABS
15840 call fooR(CABS(C1))
15841 c FFEINTRIN_impCCOS
15842 call fooC(CCOS(C1))
15843 c FFEINTRIN_impCEXP
15844 call fooC(CEXP(C1))
15845 c FFEINTRIN_impCHAR
15846 call fooA(CHAR(I1))
15847 c FFEINTRIN_impCLOG
15848 call fooC(CLOG(C1))
15849 c FFEINTRIN_impCONJG
15850 call fooC(CONJG(C1))
15853 c FFEINTRIN_impCOSH
15854 call fooR(COSH(R1))
15855 c FFEINTRIN_impCSIN
15856 call fooC(CSIN(C1))
15857 c FFEINTRIN_impCSQRT
15858 call fooC(CSQRT(C1))
15859 c FFEINTRIN_impDABS
15860 call fooD(DABS(D1))
15861 c FFEINTRIN_impDACOS
15862 call fooD(DACOS(D1))
15863 c FFEINTRIN_impDASIN
15864 call fooD(DASIN(D1))
15865 c FFEINTRIN_impDATAN
15866 call fooD(DATAN(D1))
15867 c FFEINTRIN_impDATAN2
15868 call fooD(DATAN2(D1,D2))
15869 c FFEINTRIN_impDCOS
15870 call fooD(DCOS(D1))
15871 c FFEINTRIN_impDCOSH
15872 call fooD(DCOSH(D1))
15873 c FFEINTRIN_impDDIM
15874 call fooD(DDIM(D1,D2))
15875 c FFEINTRIN_impDEXP
15876 call fooD(DEXP(D1))
15878 call fooR(DIM(R1,R2))
15879 c FFEINTRIN_impDINT
15880 call fooD(DINT(D1))
15881 c FFEINTRIN_impDLOG
15882 call fooD(DLOG(D1))
15883 c FFEINTRIN_impDLOG10
15884 call fooD(DLOG10(D1))
15885 c FFEINTRIN_impDMAX1
15886 call fooD(DMAX1(D1,D2))
15887 c FFEINTRIN_impDMIN1
15888 call fooD(DMIN1(D1,D2))
15889 c FFEINTRIN_impDMOD
15890 call fooD(DMOD(D1,D2))
15891 c FFEINTRIN_impDNINT
15892 call fooD(DNINT(D1))
15893 c FFEINTRIN_impDPROD
15894 call fooD(DPROD(R1,R2))
15895 c FFEINTRIN_impDSIGN
15896 call fooD(DSIGN(D1,D2))
15897 c FFEINTRIN_impDSIN
15898 call fooD(DSIN(D1))
15899 c FFEINTRIN_impDSINH
15900 call fooD(DSINH(D1))
15901 c FFEINTRIN_impDSQRT
15902 call fooD(DSQRT(D1))
15903 c FFEINTRIN_impDTAN
15904 call fooD(DTAN(D1))
15905 c FFEINTRIN_impDTANH
15906 call fooD(DTANH(D1))
15909 c FFEINTRIN_impIABS
15910 call fooI(IABS(I1))
15911 c FFEINTRIN_impICHAR
15912 call fooI(ICHAR(A1))
15913 c FFEINTRIN_impIDIM
15914 call fooI(IDIM(I1,I2))
15915 c FFEINTRIN_impIDNINT
15916 call fooI(IDNINT(D1))
15917 c FFEINTRIN_impINDEX
15918 call fooI(INDEX(A1,A2))
15919 c FFEINTRIN_impISIGN
15920 call fooI(ISIGN(I1,I2))
15924 call fooL(LGE(A1,A2))
15926 call fooL(LGT(A1,A2))
15928 call fooL(LLE(A1,A2))
15930 call fooL(LLT(A1,A2))
15931 c FFEINTRIN_impMAX0
15932 call fooI(MAX0(I1,I2))
15933 c FFEINTRIN_impMAX1
15934 call fooI(MAX1(R1,R2))
15935 c FFEINTRIN_impMIN0
15936 call fooI(MIN0(I1,I2))
15937 c FFEINTRIN_impMIN1
15938 call fooI(MIN1(R1,R2))
15940 call fooI(MOD(I1,I2))
15941 c FFEINTRIN_impNINT
15942 call fooI(NINT(R1))
15943 c FFEINTRIN_impSIGN
15944 call fooR(SIGN(R1,R2))
15947 c FFEINTRIN_impSINH
15948 call fooR(SINH(R1))
15949 c FFEINTRIN_impSQRT
15950 call fooR(SQRT(R1))
15953 c FFEINTRIN_impTANH
15954 call fooR(TANH(R1))
15955 c FFEINTRIN_imp_CMPLX_C
15956 call fooC(cmplx(C1,C2))
15957 c FFEINTRIN_imp_CMPLX_D
15958 call fooZ(cmplx(D1,D2))
15959 c FFEINTRIN_imp_CMPLX_I
15960 call fooC(cmplx(I1,I2))
15961 c FFEINTRIN_imp_CMPLX_R
15962 call fooC(cmplx(R1,R2))
15963 c FFEINTRIN_imp_DBLE_C
15964 call fooD(dble(C1))
15965 c FFEINTRIN_imp_DBLE_D
15966 call fooD(dble(D1))
15967 c FFEINTRIN_imp_DBLE_I
15968 call fooD(dble(I1))
15969 c FFEINTRIN_imp_DBLE_R
15970 call fooD(dble(R1))
15971 c FFEINTRIN_imp_INT_C
15973 c FFEINTRIN_imp_INT_D
15975 c FFEINTRIN_imp_INT_I
15977 c FFEINTRIN_imp_INT_R
15979 c FFEINTRIN_imp_REAL_C
15980 call fooR(real(C1))
15981 c FFEINTRIN_imp_REAL_D
15982 call fooR(real(D1))
15983 c FFEINTRIN_imp_REAL_I
15984 call fooR(real(I1))
15985 c FFEINTRIN_imp_REAL_R
15986 call fooR(real(R1))
15988 c FFEINTRIN_imp_INT_D:
15990 c FFEINTRIN_specIDINT
15991 call fooI(IDINT(D1))
15993 c FFEINTRIN_imp_INT_R:
15995 c FFEINTRIN_specIFIX
15996 call fooI(IFIX(R1))
15997 c FFEINTRIN_specINT
16000 c FFEINTRIN_imp_REAL_D:
16002 c FFEINTRIN_specSNGL
16003 call fooR(SNGL(D1))
16005 c FFEINTRIN_imp_REAL_I:
16007 c FFEINTRIN_specFLOAT
16008 call fooR(FLOAT(I1))
16009 c FFEINTRIN_specREAL
16010 call fooR(REAL(I1))
16013 -------- (end input file to f2c)
16015 -------- (begin output from providing above input file as input to:
16016 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16017 -------- -e "s:^#.*$::g"')
16019 // -- translated by f2c (version 19950223).
16020 You must link the resulting object file with the libraries:
16021 -lf2c -lm (in that order)
16025 // f2c.h -- Standard Fortran to C header file //
16027 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
16029 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16034 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16035 // we assume short, float are OK //
16036 typedef long int // long int // integer;
16037 typedef char *address;
16038 typedef short int shortint;
16039 typedef float real;
16040 typedef double doublereal;
16041 typedef struct { real r, i; } complex;
16042 typedef struct { doublereal r, i; } doublecomplex;
16043 typedef long int // long int // logical;
16044 typedef short int shortlogical;
16045 typedef char logical1;
16046 typedef char integer1;
16047 // typedef long long longint; // // system-dependent //
16052 // Extern is for use with -E //
16066 typedef long int // int or long int // flag;
16067 typedef long int // int or long int // ftnlen;
16068 typedef long int // int or long int // ftnint;
16071 //external read, write//
16080 //internal read, write//
16110 //rewind, backspace, endfile//
16122 ftnint *inex; //parameters in standard's order//
16148 union Multitype { // for multiple entry points //
16159 typedef union Multitype Multitype;
16161 typedef long Long; // No longer used; formerly in Namelist //
16163 struct Vardesc { // for Namelist //
16169 typedef struct Vardesc Vardesc;
16176 typedef struct Namelist Namelist;
16185 // procedure parameter types for -A and -C++ //
16190 typedef int // Unknown procedure type // (*U_fp)();
16191 typedef shortint (*J_fp)();
16192 typedef integer (*I_fp)();
16193 typedef real (*R_fp)();
16194 typedef doublereal (*D_fp)(), (*E_fp)();
16195 typedef // Complex // void (*C_fp)();
16196 typedef // Double Complex // void (*Z_fp)();
16197 typedef logical (*L_fp)();
16198 typedef shortlogical (*K_fp)();
16199 typedef // Character // void (*H_fp)();
16200 typedef // Subroutine // int (*S_fp)();
16202 // E_fp is for real functions when -R is not specified //
16203 typedef void C_f; // complex function //
16204 typedef void H_f; // character function //
16205 typedef void Z_f; // double complex function //
16206 typedef doublereal E_f; // real function with -R not specified //
16208 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16211 // (No such symbols should be defined in a strict ANSI C compiler.
16212 We can avoid trouble with f2c-translated code by using
16213 gcc -ansi [-traditional].) //
16237 // Main program // MAIN__()
16239 // System generated locals //
16242 doublereal d__1, d__2;
16244 doublecomplex z__1, z__2, z__3;
16248 // Builtin functions //
16251 double pow_ri(), pow_di();
16255 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16256 asin(), atan(), atan2(), c_abs();
16257 void c_cos(), c_exp(), c_log(), r_cnjg();
16258 double cos(), cosh();
16259 void c_sin(), c_sqrt();
16260 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16261 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16262 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16263 logical l_ge(), l_gt(), l_le(), l_lt();
16267 // Local variables //
16268 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16269 fool_(), fooz_(), getem_();
16270 static char a1[10], a2[10];
16271 static complex c1, c2;
16272 static doublereal d1, d2;
16273 static integer i1, i2;
16274 static real r1, r2;
16277 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16285 d__1 = (doublereal) i1;
16286 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16296 c_div(&q__1, &c1, &c2);
16298 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16300 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16303 i__1 = pow_ii(&i1, &i2);
16305 r__1 = pow_ri(&r1, &i1);
16307 d__1 = pow_di(&d1, &i1);
16309 pow_ci(&q__1, &c1, &i1);
16311 d__1 = (doublereal) r1;
16312 d__2 = (doublereal) r2;
16313 r__1 = pow_dd(&d__1, &d__2);
16315 d__2 = (doublereal) r1;
16316 d__1 = pow_dd(&d__2, &d1);
16318 d__1 = pow_dd(&d1, &d2);
16320 d__2 = (doublereal) r1;
16321 d__1 = pow_dd(&d1, &d__2);
16323 z__2.r = c1.r, z__2.i = c1.i;
16324 z__3.r = c2.r, z__3.i = c2.i;
16325 pow_zz(&z__1, &z__2, &z__3);
16326 q__1.r = z__1.r, q__1.i = z__1.i;
16328 z__2.r = c1.r, z__2.i = c1.i;
16329 z__3.r = r1, z__3.i = 0.;
16330 pow_zz(&z__1, &z__2, &z__3);
16331 q__1.r = z__1.r, q__1.i = z__1.i;
16333 z__2.r = c1.r, z__2.i = c1.i;
16334 z__3.r = d1, z__3.i = 0.;
16335 pow_zz(&z__1, &z__2, &z__3);
16337 // FFEINTRIN_impABS //
16338 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16340 // FFEINTRIN_impACOS //
16343 // FFEINTRIN_impAIMAG //
16344 r__1 = r_imag(&c1);
16346 // FFEINTRIN_impAINT //
16349 // FFEINTRIN_impALOG //
16352 // FFEINTRIN_impALOG10 //
16353 r__1 = r_lg10(&r1);
16355 // FFEINTRIN_impAMAX0 //
16356 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16358 // FFEINTRIN_impAMAX1 //
16359 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16361 // FFEINTRIN_impAMIN0 //
16362 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16364 // FFEINTRIN_impAMIN1 //
16365 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16367 // FFEINTRIN_impAMOD //
16368 r__1 = r_mod(&r1, &r2);
16370 // FFEINTRIN_impANINT //
16371 r__1 = r_nint(&r1);
16373 // FFEINTRIN_impASIN //
16376 // FFEINTRIN_impATAN //
16379 // FFEINTRIN_impATAN2 //
16380 r__1 = atan2(r1, r2);
16382 // FFEINTRIN_impCABS //
16385 // FFEINTRIN_impCCOS //
16388 // FFEINTRIN_impCEXP //
16391 // FFEINTRIN_impCHAR //
16392 *(unsigned char *)&ch__1[0] = i1;
16394 // FFEINTRIN_impCLOG //
16397 // FFEINTRIN_impCONJG //
16398 r_cnjg(&q__1, &c1);
16400 // FFEINTRIN_impCOS //
16403 // FFEINTRIN_impCOSH //
16406 // FFEINTRIN_impCSIN //
16409 // FFEINTRIN_impCSQRT //
16410 c_sqrt(&q__1, &c1);
16412 // FFEINTRIN_impDABS //
16413 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16415 // FFEINTRIN_impDACOS //
16418 // FFEINTRIN_impDASIN //
16421 // FFEINTRIN_impDATAN //
16424 // FFEINTRIN_impDATAN2 //
16425 d__1 = atan2(d1, d2);
16427 // FFEINTRIN_impDCOS //
16430 // FFEINTRIN_impDCOSH //
16433 // FFEINTRIN_impDDIM //
16434 d__1 = d_dim(&d1, &d2);
16436 // FFEINTRIN_impDEXP //
16439 // FFEINTRIN_impDIM //
16440 r__1 = r_dim(&r1, &r2);
16442 // FFEINTRIN_impDINT //
16445 // FFEINTRIN_impDLOG //
16448 // FFEINTRIN_impDLOG10 //
16449 d__1 = d_lg10(&d1);
16451 // FFEINTRIN_impDMAX1 //
16452 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16454 // FFEINTRIN_impDMIN1 //
16455 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16457 // FFEINTRIN_impDMOD //
16458 d__1 = d_mod(&d1, &d2);
16460 // FFEINTRIN_impDNINT //
16461 d__1 = d_nint(&d1);
16463 // FFEINTRIN_impDPROD //
16464 d__1 = (doublereal) r1 * r2;
16466 // FFEINTRIN_impDSIGN //
16467 d__1 = d_sign(&d1, &d2);
16469 // FFEINTRIN_impDSIN //
16472 // FFEINTRIN_impDSINH //
16475 // FFEINTRIN_impDSQRT //
16478 // FFEINTRIN_impDTAN //
16481 // FFEINTRIN_impDTANH //
16484 // FFEINTRIN_impEXP //
16487 // FFEINTRIN_impIABS //
16488 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16490 // FFEINTRIN_impICHAR //
16491 i__1 = *(unsigned char *)a1;
16493 // FFEINTRIN_impIDIM //
16494 i__1 = i_dim(&i1, &i2);
16496 // FFEINTRIN_impIDNINT //
16497 i__1 = i_dnnt(&d1);
16499 // FFEINTRIN_impINDEX //
16500 i__1 = i_indx(a1, a2, 10L, 10L);
16502 // FFEINTRIN_impISIGN //
16503 i__1 = i_sign(&i1, &i2);
16505 // FFEINTRIN_impLEN //
16506 i__1 = i_len(a1, 10L);
16508 // FFEINTRIN_impLGE //
16509 L__1 = l_ge(a1, a2, 10L, 10L);
16511 // FFEINTRIN_impLGT //
16512 L__1 = l_gt(a1, a2, 10L, 10L);
16514 // FFEINTRIN_impLLE //
16515 L__1 = l_le(a1, a2, 10L, 10L);
16517 // FFEINTRIN_impLLT //
16518 L__1 = l_lt(a1, a2, 10L, 10L);
16520 // FFEINTRIN_impMAX0 //
16521 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16523 // FFEINTRIN_impMAX1 //
16524 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16526 // FFEINTRIN_impMIN0 //
16527 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16529 // FFEINTRIN_impMIN1 //
16530 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16532 // FFEINTRIN_impMOD //
16535 // FFEINTRIN_impNINT //
16536 i__1 = i_nint(&r1);
16538 // FFEINTRIN_impSIGN //
16539 r__1 = r_sign(&r1, &r2);
16541 // FFEINTRIN_impSIN //
16544 // FFEINTRIN_impSINH //
16547 // FFEINTRIN_impSQRT //
16550 // FFEINTRIN_impTAN //
16553 // FFEINTRIN_impTANH //
16556 // FFEINTRIN_imp_CMPLX_C //
16559 q__1.r = r__1, q__1.i = r__2;
16561 // FFEINTRIN_imp_CMPLX_D //
16562 z__1.r = d1, z__1.i = d2;
16564 // FFEINTRIN_imp_CMPLX_I //
16567 q__1.r = r__1, q__1.i = r__2;
16569 // FFEINTRIN_imp_CMPLX_R //
16570 q__1.r = r1, q__1.i = r2;
16572 // FFEINTRIN_imp_DBLE_C //
16573 d__1 = (doublereal) c1.r;
16575 // FFEINTRIN_imp_DBLE_D //
16578 // FFEINTRIN_imp_DBLE_I //
16579 d__1 = (doublereal) i1;
16581 // FFEINTRIN_imp_DBLE_R //
16582 d__1 = (doublereal) r1;
16584 // FFEINTRIN_imp_INT_C //
16585 i__1 = (integer) c1.r;
16587 // FFEINTRIN_imp_INT_D //
16588 i__1 = (integer) d1;
16590 // FFEINTRIN_imp_INT_I //
16593 // FFEINTRIN_imp_INT_R //
16594 i__1 = (integer) r1;
16596 // FFEINTRIN_imp_REAL_C //
16599 // FFEINTRIN_imp_REAL_D //
16602 // FFEINTRIN_imp_REAL_I //
16605 // FFEINTRIN_imp_REAL_R //
16609 // FFEINTRIN_imp_INT_D: //
16611 // FFEINTRIN_specIDINT //
16612 i__1 = (integer) d1;
16615 // FFEINTRIN_imp_INT_R: //
16617 // FFEINTRIN_specIFIX //
16618 i__1 = (integer) r1;
16620 // FFEINTRIN_specINT //
16621 i__1 = (integer) r1;
16624 // FFEINTRIN_imp_REAL_D: //
16626 // FFEINTRIN_specSNGL //
16630 // FFEINTRIN_imp_REAL_I: //
16632 // FFEINTRIN_specFLOAT //
16635 // FFEINTRIN_specREAL //
16641 -------- (end output file from f2c)