1 /* com.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
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);
89 #include "output.h" /* Must follow tree.h so TREE_CODE is defined! */
92 #include "diagnostic.h"
94 #include "langhooks.h"
95 #include "langhooks-def.h"
98 /* VMS-specific definitions */
101 #define O_RDONLY 0 /* Open arg for Read/Only */
102 #define O_WRONLY 1 /* Open arg for Write/Only */
103 #define read(fd,buf,size) VMS_read (fd,buf,size)
104 #define write(fd,buf,size) VMS_write (fd,buf,size)
105 #define open(fname,mode,prot) VMS_open (fname,mode,prot)
106 #define fopen(fname,mode) VMS_fopen (fname,mode)
107 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
108 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
109 #define fstat(fd,stbuf) VMS_fstat (fd,stbuf)
110 static int VMS_fstat (), VMS_stat ();
111 static char * VMS_strncat ();
112 static int VMS_read ();
113 static int VMS_write ();
114 static int VMS_open ();
115 static FILE * VMS_fopen ();
116 static FILE * VMS_freopen ();
117 static void hack_vms_include_specification ();
118 typedef struct { unsigned :16, :16, :16; } vms_ino_t
;
119 #define ino_t vms_ino_t
120 #define INCLUDE_LEN_FUDGE 10 /* leave room for VMS syntax conversion */
123 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
140 /* Externals defined here. */
142 /* Stream for reading from the input file. */
145 /* These definitions parallel those in c-decl.c so that code from that
146 module can be used pretty much as is. Much of these defs aren't
147 otherwise used, i.e. by g77 code per se, except some of them are used
148 to build some of them that are. The ones that are global (i.e. not
149 "static") are those that ste.c and such might use (directly
150 or by using com macros that reference them in their definitions). */
152 tree string_type_node
;
154 /* The rest of these are inventions for g77, though there might be
155 similar things in the C front end. As they are found, these
156 inventions should be renamed to be canonical. Note that only
157 the ones currently required to be global are so. */
159 static GTY(()) tree ffecom_tree_fun_type_void
;
161 tree ffecom_integer_type_node
; /* Abbrev for _tree_type[blah][blah]. */
162 tree ffecom_integer_zero_node
; /* Like *_*_* with g77's integer type. */
163 tree ffecom_integer_one_node
; /* " */
164 tree ffecom_tree_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
166 /* _fun_type things are the f2c-specific versions. For -fno-f2c,
167 just use build_function_type and build_pointer_type on the
168 appropriate _tree_type array element. */
170 static GTY(()) tree ffecom_tree_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
172 ffecom_tree_ptr_to_fun_type
[FFEINFO_basictype
][FFEINFO_kindtype
];
173 static GTY(()) tree ffecom_tree_subr_type
;
174 static GTY(()) tree ffecom_tree_ptr_to_subr_type
;
175 static GTY(()) tree ffecom_tree_blockdata_type
;
177 static GTY(()) tree ffecom_tree_xargc_
;
179 ffecomSymbol ffecom_symbol_null_
188 ffeinfoKindtype ffecom_pointer_kind_
= FFEINFO_basictypeNONE
;
189 ffeinfoKindtype ffecom_label_kind_
= FFEINFO_basictypeNONE
;
191 int ffecom_f2c_typecode_
[FFEINFO_basictype
][FFEINFO_kindtype
];
192 tree ffecom_f2c_integer_type_node
;
193 static GTY(()) tree ffecom_f2c_ptr_to_integer_type_node
;
194 tree ffecom_f2c_address_type_node
;
195 tree ffecom_f2c_real_type_node
;
196 static GTY(()) tree ffecom_f2c_ptr_to_real_type_node
;
197 tree ffecom_f2c_doublereal_type_node
;
198 tree ffecom_f2c_complex_type_node
;
199 tree ffecom_f2c_doublecomplex_type_node
;
200 tree ffecom_f2c_longint_type_node
;
201 tree ffecom_f2c_logical_type_node
;
202 tree ffecom_f2c_flag_type_node
;
203 tree ffecom_f2c_ftnlen_type_node
;
204 tree ffecom_f2c_ftnlen_zero_node
;
205 tree ffecom_f2c_ftnlen_one_node
;
206 tree ffecom_f2c_ftnlen_two_node
;
207 tree ffecom_f2c_ptr_to_ftnlen_type_node
;
208 tree ffecom_f2c_ftnint_type_node
;
209 tree ffecom_f2c_ptr_to_ftnint_type_node
;
211 /* Simple definitions and enumerations. */
213 #ifndef FFECOM_sizeMAXSTACKITEM
214 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
215 larger than this # bytes
216 off stack if possible. */
219 /* For systems that have large enough stacks, they should define
220 this to 0, and here, for ease of use later on, we just undefine
223 #if FFECOM_sizeMAXSTACKITEM == 0
224 #undef FFECOM_sizeMAXSTACKITEM
230 FFECOM_rttypeVOIDSTAR_
, /* C's `void *' type. */
231 FFECOM_rttypeFTNINT_
, /* f2c's `ftnint' type. */
232 FFECOM_rttypeINTEGER_
, /* f2c's `integer' type. */
233 FFECOM_rttypeLONGINT_
, /* f2c's `longint' type. */
234 FFECOM_rttypeLOGICAL_
, /* f2c's `logical' type. */
235 FFECOM_rttypeREAL_F2C_
, /* f2c's `real' returned as `double'. */
236 FFECOM_rttypeREAL_GNU_
, /* `real' returned as such. */
237 FFECOM_rttypeCOMPLEX_F2C_
, /* f2c's `complex' returned via 1st arg. */
238 FFECOM_rttypeCOMPLEX_GNU_
, /* f2c's `complex' returned directly. */
239 FFECOM_rttypeDOUBLE_
, /* C's `double' type. */
240 FFECOM_rttypeDOUBLEREAL_
, /* f2c's `doublereal' type. */
241 FFECOM_rttypeDBLCMPLX_F2C_
, /* f2c's `doublecomplex' returned via 1st arg. */
242 FFECOM_rttypeDBLCMPLX_GNU_
, /* f2c's `doublecomplex' returned directly. */
243 FFECOM_rttypeCHARACTER_
, /* f2c `char *'/`ftnlen' pair. */
247 /* Internal typedefs. */
249 typedef struct _ffecom_concat_list_ ffecomConcatList_
;
251 /* Private include files. */
254 /* Internal structure definitions. */
256 struct _ffecom_concat_list_
261 ffetargetCharacterSize minlen
;
262 ffetargetCharacterSize maxlen
;
265 /* Static functions (internal). */
267 static tree ffe_type_for_mode
PARAMS ((enum machine_mode
, int));
268 static tree ffe_type_for_size
PARAMS ((unsigned int, int));
269 static tree ffe_unsigned_type
PARAMS ((tree
));
270 static tree ffe_signed_type
PARAMS ((tree
));
271 static tree ffe_signed_or_unsigned_type
PARAMS ((int, tree
));
272 static bool ffe_mark_addressable
PARAMS ((tree
));
273 static tree ffe_truthvalue_conversion
PARAMS ((tree
));
274 static void ffecom_init_decl_processing
PARAMS ((void));
275 static tree
ffecom_arglist_expr_ (const char *argstring
, ffebld args
);
276 static tree
ffecom_widest_expr_type_ (ffebld list
);
277 static bool ffecom_overlap_ (tree dest_decl
, tree dest_offset
,
278 tree dest_size
, tree source_tree
,
279 ffebld source
, bool scalar_arg
);
280 static bool ffecom_args_overlapping_ (tree dest_tree
, ffebld dest
,
281 tree args
, tree callee_commons
,
283 static tree
ffecom_build_f2c_string_ (int i
, const char *s
);
284 static tree
ffecom_call_ (tree fn
, ffeinfoKindtype kt
,
285 bool is_f2c_complex
, tree type
,
286 tree args
, tree dest_tree
,
287 ffebld dest
, bool *dest_used
,
288 tree callee_commons
, bool scalar_args
, tree hook
);
289 static tree
ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
,
290 bool is_f2c_complex
, tree type
,
291 ffebld left
, ffebld right
,
292 tree dest_tree
, ffebld dest
,
293 bool *dest_used
, tree callee_commons
,
294 bool scalar_args
, bool ref
, tree hook
);
295 static void ffecom_char_args_x_ (tree
*xitem
, tree
*length
,
296 ffebld expr
, bool with_null
);
297 static tree
ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
);
298 static tree
ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
);
299 static ffecomConcatList_
300 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
,
302 ffetargetCharacterSize max
);
303 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist
);
304 static ffecomConcatList_
ffecom_concat_list_new_ (ffebld expr
,
305 ffetargetCharacterSize max
);
306 static void ffecom_debug_kludge_ (tree aggr
, const char *aggr_type
,
307 ffesymbol member
, tree member_type
,
308 ffetargetOffset offset
);
309 static void ffecom_do_entry_ (ffesymbol fn
, int entrynum
);
310 static tree
ffecom_expr_ (ffebld expr
, tree dest_tree
, ffebld dest
,
311 bool *dest_used
, bool assignp
, bool widenp
);
312 static tree
ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
313 ffebld dest
, bool *dest_used
);
314 static tree
ffecom_expr_power_integer_ (ffebld expr
);
315 static void ffecom_expr_transform_ (ffebld expr
);
316 static void ffecom_f2c_make_type_ (tree
*type
, int tcode
, const char *name
);
317 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
319 static ffeglobal
ffecom_finish_global_ (ffeglobal global
);
320 static ffesymbol
ffecom_finish_symbol_transform_ (ffesymbol s
);
321 static tree
ffecom_get_appended_identifier_ (char us
, const char *text
);
322 static tree
ffecom_get_external_identifier_ (ffesymbol s
);
323 static tree
ffecom_get_identifier_ (const char *text
);
324 static tree
ffecom_gen_sfuncdef_ (ffesymbol s
,
327 static const char *ffecom_gfrt_args_ (ffecomGfrt ix
);
328 static tree
ffecom_gfrt_tree_ (ffecomGfrt ix
);
329 static tree
ffecom_init_zero_ (tree decl
);
330 static tree
ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
332 static tree
ffecom_intrinsic_len_ (ffebld expr
);
333 static void ffecom_let_char_ (tree dest_tree
,
335 ffetargetCharacterSize dest_size
,
337 static void ffecom_make_gfrt_ (ffecomGfrt ix
);
338 static void ffecom_member_phase1_ (ffestorag mst
, ffestorag st
);
339 static void ffecom_member_phase2_ (ffestorag mst
, ffestorag st
);
340 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size
,
342 static void ffecom_push_dummy_decls_ (ffebld dumlist
,
344 static void ffecom_start_progunit_ (void);
345 static ffesymbol
ffecom_sym_transform_ (ffesymbol s
);
346 static ffesymbol
ffecom_sym_transform_assign_ (ffesymbol s
);
347 static void ffecom_transform_common_ (ffesymbol s
);
348 static void ffecom_transform_equiv_ (ffestorag st
);
349 static tree
ffecom_transform_namelist_ (ffesymbol s
);
350 static void ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
352 static void ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
353 tree
*size
, tree tree
);
354 static tree
ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
355 tree dest_tree
, ffebld dest
,
356 bool *dest_used
, tree hook
);
357 static tree
ffecom_type_localvar_ (ffesymbol s
,
360 static tree
ffecom_type_namelist_ (void);
361 static tree
ffecom_type_vardesc_ (void);
362 static tree
ffecom_vardesc_ (ffebld expr
);
363 static tree
ffecom_vardesc_array_ (ffesymbol s
);
364 static tree
ffecom_vardesc_dims_ (ffesymbol s
);
365 static tree
ffecom_convert_narrow_ (tree type
, tree expr
);
366 static tree
ffecom_convert_widen_ (tree type
, tree expr
);
368 /* These are static functions that parallel those found in the C front
369 end and thus have the same names. */
371 static tree
bison_rule_compstmt_ (void);
372 static void bison_rule_pushlevel_ (void);
373 static void delete_block (tree block
);
374 static int duplicate_decls (tree newdecl
, tree olddecl
);
375 static void finish_decl (tree decl
, tree init
, bool is_top_level
);
376 static void finish_function (int nested
);
377 static const char *ffe_printable_name (tree decl
, int v
);
378 static void ffe_print_error_function (diagnostic_context
*, const char *);
379 static tree
lookup_name_current_level (tree name
);
380 static struct f_binding_level
*make_binding_level (void);
381 static void pop_f_function_context (void);
382 static void push_f_function_context (void);
383 static void push_parm_decl (tree parm
);
384 static tree
pushdecl_top_level (tree decl
);
385 static int kept_level_p (void);
386 static tree
storedecls (tree decls
);
387 static void store_parm_decls (int is_main_program
);
388 static tree
start_decl (tree decl
, bool is_top_level
);
389 static void start_function (tree name
, tree type
, int nested
, int public);
390 static void ffecom_file_ (const char *name
);
391 static void ffecom_close_include_ (FILE *f
);
392 static int ffecom_decode_include_option_ (char *spec
);
393 static FILE *ffecom_open_include_ (char *name
, ffewhereLine l
,
396 /* Static objects accessed by functions in this module. */
398 static ffesymbol ffecom_primary_entry_
= NULL
;
399 static ffesymbol ffecom_nested_entry_
= NULL
;
400 static ffeinfoKind ffecom_primary_entry_kind_
;
401 static bool ffecom_primary_entry_is_proc_
;
402 static GTY(()) tree ffecom_outer_function_decl_
;
403 static GTY(()) tree ffecom_previous_function_decl_
;
404 static GTY(()) tree ffecom_which_entrypoint_decl_
;
405 static GTY(()) tree ffecom_float_zero_
;
406 static GTY(()) tree ffecom_float_half_
;
407 static GTY(()) tree ffecom_double_zero_
;
408 static GTY(()) tree ffecom_double_half_
;
409 static GTY(()) tree ffecom_func_result_
;/* For functions. */
410 static GTY(()) tree ffecom_func_length_
;/* For CHARACTER fns. */
411 static ffebld ffecom_list_blockdata_
;
412 static ffebld ffecom_list_common_
;
413 static ffebld ffecom_master_arglist_
;
414 static ffeinfoBasictype ffecom_master_bt_
;
415 static ffeinfoKindtype ffecom_master_kt_
;
416 static ffetargetCharacterSize ffecom_master_size_
;
417 static int ffecom_num_fns_
= 0;
418 static int ffecom_num_entrypoints_
= 0;
419 static bool ffecom_is_altreturning_
= FALSE
;
420 static GTY(()) tree ffecom_multi_type_node_
;
421 static GTY(()) tree ffecom_multi_retval_
;
423 ffecom_multi_fields_
[FFEINFO_basictype
][FFEINFO_kindtype
];
424 static bool ffecom_member_namelisted_
; /* _member_phase1_ namelisted? */
425 static bool ffecom_doing_entry_
= FALSE
;
426 static bool ffecom_transform_only_dummies_
= FALSE
;
427 static int ffecom_typesize_pointer_
;
428 static int ffecom_typesize_integer1_
;
430 /* Holds pointer-to-function expressions. */
432 static GTY(()) tree ffecom_gfrt_
[FFECOM_gfrt
];
434 /* Holds the external names of the functions. */
436 static const char *const ffecom_gfrt_name_
[FFECOM_gfrt
]
439 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
440 #include "com-rt.def"
444 /* Whether the function returns. */
446 static const bool ffecom_gfrt_volatile_
[FFECOM_gfrt
]
449 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
450 #include "com-rt.def"
454 /* Whether the function returns type complex. */
456 static const bool ffecom_gfrt_complex_
[FFECOM_gfrt
]
459 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
460 #include "com-rt.def"
464 /* Whether the function is const
465 (i.e., has no side effects and only depends on its arguments). */
467 static const bool ffecom_gfrt_const_
[FFECOM_gfrt
]
470 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
471 #include "com-rt.def"
475 /* Type code for the function return value. */
477 static const ffecomRttype_ ffecom_gfrt_type_
[FFECOM_gfrt
]
480 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
481 #include "com-rt.def"
485 /* String of codes for the function's arguments. */
487 static const char *const ffecom_gfrt_argstring_
[FFECOM_gfrt
]
490 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
491 #include "com-rt.def"
495 /* Internal macros. */
497 /* We let tm.h override the types used here, to handle trivial differences
498 such as the choice of unsigned int or long unsigned int for size_t.
499 When machines start needing nontrivial differences in the size type,
500 it would be best to do something here to figure out automatically
501 from other information what type to use. */
504 #define SIZE_TYPE "long unsigned int"
507 #define ffecom_concat_list_count_(catlist) ((catlist).count)
508 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
509 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
510 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
512 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
513 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
515 /* For each binding contour we allocate a binding_level structure
516 * which records the names defined in that contour.
519 * 1) one for each function definition,
520 * where internal declarations of the parameters appear.
522 * The current meaning of a name can be found by searching the levels from
523 * the current one out to the global one.
526 /* Note that the information in the `names' component of the global contour
527 is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers. */
529 struct f_binding_level
GTY(())
531 /* A chain of _DECL nodes for all variables, constants, functions,
532 and typedef types. These are in the reverse of the order supplied.
536 /* For each level (except not the global one),
537 a chain of BLOCK nodes for all the levels
538 that were entered and exited one level down. */
541 /* The BLOCK node for this level, if one has been preallocated.
542 If 0, the BLOCK is allocated (if needed) when the level is popped. */
545 /* The binding level which this one is contained in (inherits from). */
546 struct f_binding_level
*level_chain
;
548 /* 0: no ffecom_prepare_* functions called at this level yet;
549 1: ffecom_prepare* functions called, except not ffecom_prepare_end;
550 2: ffecom_prepare_end called. */
554 #define NULL_BINDING_LEVEL (struct f_binding_level *) NULL
556 /* The binding level currently in effect. */
558 static GTY(()) struct f_binding_level
*current_binding_level
;
560 /* A chain of binding_level structures awaiting reuse. */
562 static GTY((deletable (""))) struct f_binding_level
*free_binding_level
;
564 /* The outermost binding level, for names of file scope.
565 This is created when the compiler is started and exists
566 through the entire run. */
568 static struct f_binding_level
*global_binding_level
;
570 /* Binding level structures are initialized by copying this one. */
572 static const struct f_binding_level clear_binding_level
574 {NULL
, NULL
, NULL
, NULL_BINDING_LEVEL
, 0};
576 /* Language-dependent contents of an identifier. */
578 struct lang_identifier
GTY(())
580 struct tree_identifier common
;
587 /* Macros for access to language-specific slots in an identifier. */
588 /* Each of these slots contains a DECL node or null. */
590 /* This represents the value which the identifier has in the
591 file-scope namespace. */
592 #define IDENTIFIER_GLOBAL_VALUE(NODE) \
593 (((struct lang_identifier *)(NODE))->global_value)
594 /* This represents the value which the identifier has in the current
596 #define IDENTIFIER_LOCAL_VALUE(NODE) \
597 (((struct lang_identifier *)(NODE))->local_value)
598 /* This represents the value which the identifier has as a label in
599 the current label scope. */
600 #define IDENTIFIER_LABEL_VALUE(NODE) \
601 (((struct lang_identifier *)(NODE))->label_value)
602 /* This is nonzero if the identifier was "made up" by g77 code. */
603 #define IDENTIFIER_INVENTED(NODE) \
604 (((struct lang_identifier *)(NODE))->invented)
606 /* The resulting tree type. */
608 GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE"),
609 chain_next ("(union lang_tree_node *)TREE_CHAIN (&%h.generic)")))
611 union tree_node
GTY ((tag ("0"),
612 desc ("tree_node_structure (&%h)")))
614 struct lang_identifier
GTY ((tag ("1"))) identifier
;
617 /* Fortran doesn't use either of these. */
618 struct lang_decl
GTY(())
621 struct lang_type
GTY(())
625 /* In identifiers, C uses the following fields in a special way:
626 TREE_PUBLIC to record that there was a previous local extern decl.
627 TREE_USED to record that such a decl was used.
628 TREE_ADDRESSABLE to record that the address of such a decl was used. */
630 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
631 that have names. Here so we can clear out their names' definitions
632 at the end of the function. */
634 static GTY(()) tree named_labels
;
636 /* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
638 static GTY(()) tree shadowed_labels
;
640 /* Return the subscript expression, modified to do range-checking.
642 `array' is the array to be checked against.
643 `element' is the subscript expression to check.
644 `dim' is the dimension number (starting at 0).
645 `total_dims' is the total number of dimensions (0 for CHARACTER substring).
649 ffecom_subscript_check_ (tree array
, tree element
, int dim
, int total_dims
,
650 const char *array_name
)
652 tree low
= TYPE_MIN_VALUE (TYPE_DOMAIN (array
));
653 tree high
= TYPE_MAX_VALUE (TYPE_DOMAIN (array
));
658 if (element
== error_mark_node
)
661 if (TREE_TYPE (low
) != TREE_TYPE (element
))
663 if (TYPE_PRECISION (TREE_TYPE (low
))
664 > TYPE_PRECISION (TREE_TYPE (element
)))
665 element
= convert (TREE_TYPE (low
), element
);
668 low
= convert (TREE_TYPE (element
), low
);
670 high
= convert (TREE_TYPE (element
), high
);
674 element
= ffecom_save_tree (element
);
677 /* Special handling for substring range checks. Fortran allows the
678 end subscript < begin subscript, which means that expressions like
679 string(1:0) are valid (and yield a null string). In view of this,
680 enforce two simpler conditions:
681 1) element<=high for end-substring;
682 2) element>=low for start-substring.
683 Run-time character movement will enforce remaining conditions.
685 More complicated checks would be better, but present structure only
686 provides one index element at a time, so it is not possible to
687 enforce a check of both i and j in string(i:j). If it were, the
688 complete set of rules would read,
689 if ( ((j<i) && ((low<=i<=high) || (low<=j<=high))) ||
690 ((low<=i<=high) && (low<=j<=high)) )
696 cond
= ffecom_2 (LE_EXPR
, integer_type_node
, element
, high
);
698 cond
= ffecom_2 (LE_EXPR
, integer_type_node
, low
, element
);
702 /* Array reference substring range checking. */
704 cond
= ffecom_2 (LE_EXPR
, integer_type_node
,
709 cond
= ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
711 ffecom_2 (LE_EXPR
, integer_type_node
,
729 var
= concat (array_name
, "[", (dim
? "end" : "start"),
730 "-substring]", NULL
);
731 len
= strlen (var
) + 1;
732 arg1
= build_string (len
, var
);
737 len
= strlen (array_name
) + 1;
738 arg1
= build_string (len
, array_name
);
742 var
= xmalloc (strlen (array_name
) + 40);
743 sprintf (var
, "%s[subscript-%d-of-%d]",
745 dim
+ 1, total_dims
);
746 len
= strlen (var
) + 1;
747 arg1
= build_string (len
, var
);
753 = build_type_variant (build_array_type (char_type_node
,
757 build_int_2 (len
, 0))),
759 TREE_CONSTANT (arg1
) = 1;
760 TREE_STATIC (arg1
) = 1;
761 arg1
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (arg1
)),
764 /* s_rnge adds one to the element to print it, so bias against
765 that -- want to print a faithful *subscript* value. */
766 arg2
= convert (ffecom_f2c_ftnint_type_node
,
767 ffecom_2 (MINUS_EXPR
,
770 convert (TREE_TYPE (element
),
773 proc
= concat (input_filename
, "/",
774 IDENTIFIER_POINTER (DECL_NAME (current_function_decl
)),
776 len
= strlen (proc
) + 1;
777 arg3
= build_string (len
, proc
);
782 = build_type_variant (build_array_type (char_type_node
,
786 build_int_2 (len
, 0))),
788 TREE_CONSTANT (arg3
) = 1;
789 TREE_STATIC (arg3
) = 1;
790 arg3
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (arg3
)),
793 arg4
= convert (ffecom_f2c_ftnint_type_node
,
794 build_int_2 (lineno
, 0));
796 arg1
= build_tree_list (NULL_TREE
, arg1
);
797 arg2
= build_tree_list (NULL_TREE
, arg2
);
798 arg3
= build_tree_list (NULL_TREE
, arg3
);
799 arg4
= build_tree_list (NULL_TREE
, arg4
);
800 TREE_CHAIN (arg3
) = arg4
;
801 TREE_CHAIN (arg2
) = arg3
;
802 TREE_CHAIN (arg1
) = arg2
;
806 die
= ffecom_call_gfrt (FFECOM_gfrtRANGE
,
808 TREE_SIDE_EFFECTS (die
) = 1;
809 die
= convert (void_type_node
, die
);
811 element
= ffecom_3 (COND_EXPR
,
820 /* Return the computed element of an array reference.
822 `item' is NULL_TREE, or the transformed pointer to the array.
823 `expr' is the original opARRAYREF expression, which is transformed
824 if `item' is NULL_TREE.
825 `want_ptr' is nonzero if a pointer to the element, instead of
826 the element itself, is to be returned. */
829 ffecom_arrayref_ (tree item
, ffebld expr
, int want_ptr
)
831 ffebld dims
[FFECOM_dimensionsMAX
];
834 int flatten
= ffe_is_flatten_arrays ();
840 const char *array_name
;
844 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
)
845 array_name
= ffesymbol_text (ffebld_symter (ffebld_left (expr
)));
847 array_name
= "[expr?]";
849 /* Build up ARRAY_REFs in reverse order (since we're column major
850 here in Fortran land). */
852 for (i
= 0, list
= ffebld_right (expr
);
854 ++i
, list
= ffebld_trail (list
))
856 dims
[i
] = ffebld_head (list
);
857 type
= ffeinfo_type (ffebld_basictype (dims
[i
]),
858 ffebld_kindtype (dims
[i
]));
860 && ffecom_typesize_pointer_
> ffecom_typesize_integer1_
861 && ffetype_size (type
) > ffecom_typesize_integer1_
)
862 /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
863 pointers and 32-bit integers. Do the full 64-bit pointer
864 arithmetic, for codes using arrays for nonstandard heap-like
871 need_ptr
= want_ptr
|| flatten
;
876 item
= ffecom_ptr_to_expr (ffebld_left (expr
));
878 item
= ffecom_expr (ffebld_left (expr
));
880 if (item
== error_mark_node
)
883 if (ffeinfo_where (ffebld_info (expr
)) == FFEINFO_whereFLEETING
884 && ! ffe_mark_addressable (item
))
885 return error_mark_node
;
888 if (item
== error_mark_node
)
895 for (--i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
897 --i
, array
= TYPE_MAIN_VARIANT (TREE_TYPE (array
)))
899 min
= TYPE_MIN_VALUE (TYPE_DOMAIN (array
));
900 element
= ffecom_expr_ (dims
[i
], NULL
, NULL
, NULL
, FALSE
, TRUE
);
901 if (flag_bounds_check
)
902 element
= ffecom_subscript_check_ (array
, element
, i
, total_dims
,
904 if (element
== error_mark_node
)
907 /* Widen integral arithmetic as desired while preserving
909 tree_type
= TREE_TYPE (element
);
910 tree_type_x
= tree_type
;
912 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
913 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
914 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
916 if (TREE_TYPE (min
) != tree_type_x
)
917 min
= convert (tree_type_x
, min
);
918 if (TREE_TYPE (element
) != tree_type_x
)
919 element
= convert (tree_type_x
, element
);
921 item
= ffecom_2 (PLUS_EXPR
,
922 build_pointer_type (TREE_TYPE (array
)),
924 size_binop (MULT_EXPR
,
925 size_in_bytes (TREE_TYPE (array
)),
927 fold (build (MINUS_EXPR
,
933 item
= ffecom_1 (INDIRECT_REF
,
934 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
))),
944 array
= TYPE_MAIN_VARIANT (TREE_TYPE (item
));
946 element
= ffecom_expr_ (dims
[i
], NULL
, NULL
, NULL
, FALSE
, TRUE
);
947 if (flag_bounds_check
)
948 element
= ffecom_subscript_check_ (array
, element
, i
, total_dims
,
950 if (element
== error_mark_node
)
953 /* Widen integral arithmetic as desired while preserving
955 tree_type
= TREE_TYPE (element
);
956 tree_type_x
= tree_type
;
958 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
959 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
960 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
962 element
= convert (tree_type_x
, element
);
964 item
= ffecom_2 (ARRAY_REF
,
965 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
))),
974 /* This is like gcc's stabilize_reference -- in fact, most of the code
975 comes from that -- but it handles the situation where the reference
976 is going to have its subparts picked at, and it shouldn't change
977 (or trigger extra invocations of functions in the subtrees) due to
978 this. save_expr is a bit overzealous, because we don't need the
979 entire thing calculated and saved like a temp. So, for DECLs, no
980 change is needed, because these are stable aggregates, and ARRAY_REF
981 and such might well be stable too, but for things like calculations,
982 we do need to calculate a snapshot of a value before picking at it. */
985 ffecom_stabilize_aggregate_ (tree ref
)
988 enum tree_code code
= TREE_CODE (ref
);
995 /* No action is needed in this case. */
1001 case FIX_TRUNC_EXPR
:
1002 case FIX_FLOOR_EXPR
:
1003 case FIX_ROUND_EXPR
:
1005 result
= build_nt (code
, stabilize_reference (TREE_OPERAND (ref
, 0)));
1009 result
= build_nt (INDIRECT_REF
,
1010 stabilize_reference_1 (TREE_OPERAND (ref
, 0)));
1014 result
= build_nt (COMPONENT_REF
,
1015 stabilize_reference (TREE_OPERAND (ref
, 0)),
1016 TREE_OPERAND (ref
, 1));
1020 result
= build_nt (BIT_FIELD_REF
,
1021 stabilize_reference (TREE_OPERAND (ref
, 0)),
1022 stabilize_reference_1 (TREE_OPERAND (ref
, 1)),
1023 stabilize_reference_1 (TREE_OPERAND (ref
, 2)));
1027 result
= build_nt (ARRAY_REF
,
1028 stabilize_reference (TREE_OPERAND (ref
, 0)),
1029 stabilize_reference_1 (TREE_OPERAND (ref
, 1)));
1033 result
= build_nt (COMPOUND_EXPR
,
1034 stabilize_reference_1 (TREE_OPERAND (ref
, 0)),
1035 stabilize_reference (TREE_OPERAND (ref
, 1)));
1043 return save_expr (ref
);
1046 return error_mark_node
;
1049 TREE_TYPE (result
) = TREE_TYPE (ref
);
1050 TREE_READONLY (result
) = TREE_READONLY (ref
);
1051 TREE_SIDE_EFFECTS (result
) = TREE_SIDE_EFFECTS (ref
);
1052 TREE_THIS_VOLATILE (result
) = TREE_THIS_VOLATILE (ref
);
1057 /* A rip-off of gcc's convert.c convert_to_complex function,
1058 reworked to handle complex implemented as C structures
1059 (RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
1062 ffecom_convert_to_complex_ (tree type
, tree expr
)
1064 register enum tree_code form
= TREE_CODE (TREE_TYPE (expr
));
1067 assert (TREE_CODE (type
) == RECORD_TYPE
);
1069 subtype
= TREE_TYPE (TYPE_FIELDS (type
));
1071 if (form
== REAL_TYPE
|| form
== INTEGER_TYPE
|| form
== ENUMERAL_TYPE
)
1073 expr
= convert (subtype
, expr
);
1074 return ffecom_2 (COMPLEX_EXPR
, type
, expr
,
1075 convert (subtype
, integer_zero_node
));
1078 if (form
== RECORD_TYPE
)
1080 tree elt_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
)));
1081 if (TYPE_MAIN_VARIANT (elt_type
) == TYPE_MAIN_VARIANT (subtype
))
1085 expr
= save_expr (expr
);
1086 return ffecom_2 (COMPLEX_EXPR
,
1089 ffecom_1 (REALPART_EXPR
,
1090 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
1093 ffecom_1 (IMAGPART_EXPR
,
1094 TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr
))),
1099 if (form
== POINTER_TYPE
|| form
== REFERENCE_TYPE
)
1100 error ("pointer value used where a complex was expected");
1102 error ("aggregate value used where a complex was expected");
1104 return ffecom_2 (COMPLEX_EXPR
, type
,
1105 convert (subtype
, integer_zero_node
),
1106 convert (subtype
, integer_zero_node
));
1109 /* Like gcc's convert(), but crashes if widening might happen. */
1112 ffecom_convert_narrow_ (type
, expr
)
1115 register tree e
= expr
;
1116 register enum tree_code code
= TREE_CODE (type
);
1118 if (type
== TREE_TYPE (e
)
1119 || TREE_CODE (e
) == ERROR_MARK
)
1121 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
1122 return fold (build1 (NOP_EXPR
, type
, e
));
1123 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
1124 || code
== ERROR_MARK
)
1125 return error_mark_node
;
1126 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
1128 assert ("void value not ignored as it ought to be" == NULL
);
1129 return error_mark_node
;
1131 assert (code
!= VOID_TYPE
);
1132 if ((code
!= RECORD_TYPE
)
1133 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
1134 assert ("converting COMPLEX to REAL" == NULL
);
1135 assert (code
!= ENUMERAL_TYPE
);
1136 if (code
== INTEGER_TYPE
)
1138 assert ((TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
1139 && TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)))
1140 || (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
1141 && (TYPE_PRECISION (type
)
1142 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e
))))));
1143 return fold (convert_to_integer (type
, e
));
1145 if (code
== POINTER_TYPE
)
1147 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1148 return fold (convert_to_pointer (type
, e
));
1150 if (code
== REAL_TYPE
)
1152 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1153 assert (TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)));
1154 return fold (convert_to_real (type
, e
));
1156 if (code
== COMPLEX_TYPE
)
1158 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1159 assert (TYPE_PRECISION (TREE_TYPE (type
)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1160 return fold (convert_to_complex (type
, e
));
1162 if (code
== RECORD_TYPE
)
1164 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1165 /* Check that at least the first field name agrees. */
1166 assert (DECL_NAME (TYPE_FIELDS (type
))
1167 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e
))));
1168 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1169 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1170 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1171 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))))
1173 return fold (ffecom_convert_to_complex_ (type
, e
));
1176 assert ("conversion to non-scalar type requested" == NULL
);
1177 return error_mark_node
;
1180 /* Like gcc's convert(), but crashes if narrowing might happen. */
1183 ffecom_convert_widen_ (type
, expr
)
1186 register tree e
= expr
;
1187 register enum tree_code code
= TREE_CODE (type
);
1189 if (type
== TREE_TYPE (e
)
1190 || TREE_CODE (e
) == ERROR_MARK
)
1192 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
1193 return fold (build1 (NOP_EXPR
, type
, e
));
1194 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
1195 || code
== ERROR_MARK
)
1196 return error_mark_node
;
1197 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
1199 assert ("void value not ignored as it ought to be" == NULL
);
1200 return error_mark_node
;
1202 assert (code
!= VOID_TYPE
);
1203 if ((code
!= RECORD_TYPE
)
1204 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
1205 assert ("narrowing COMPLEX to REAL" == NULL
);
1206 assert (code
!= ENUMERAL_TYPE
);
1207 if (code
== INTEGER_TYPE
)
1209 assert ((TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
1210 && TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)))
1211 || (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
1212 && (TYPE_PRECISION (type
)
1213 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e
))))));
1214 return fold (convert_to_integer (type
, e
));
1216 if (code
== POINTER_TYPE
)
1218 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1219 return fold (convert_to_pointer (type
, e
));
1221 if (code
== REAL_TYPE
)
1223 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1224 assert (TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)));
1225 return fold (convert_to_real (type
, e
));
1227 if (code
== COMPLEX_TYPE
)
1229 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1230 assert (TYPE_PRECISION (TREE_TYPE (type
)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1231 return fold (convert_to_complex (type
, e
));
1233 if (code
== RECORD_TYPE
)
1235 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1236 /* Check that at least the first field name agrees. */
1237 assert (DECL_NAME (TYPE_FIELDS (type
))
1238 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e
))));
1239 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1240 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1241 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1242 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))))
1244 return fold (ffecom_convert_to_complex_ (type
, e
));
1247 assert ("conversion to non-scalar type requested" == NULL
);
1248 return error_mark_node
;
1251 /* Handles making a COMPLEX type, either the standard
1252 (but buggy?) gbe way, or the safer (but less elegant?)
1256 ffecom_make_complex_type_ (tree subtype
)
1262 if (ffe_is_emulate_complex ())
1264 type
= make_node (RECORD_TYPE
);
1265 realfield
= ffecom_decl_field (type
, NULL_TREE
, "r", subtype
);
1266 imagfield
= ffecom_decl_field (type
, realfield
, "i", subtype
);
1267 TYPE_FIELDS (type
) = realfield
;
1272 type
= make_node (COMPLEX_TYPE
);
1273 TREE_TYPE (type
) = subtype
;
1280 /* Chooses either the gbe or the f2c way to build a
1281 complex constant. */
1284 ffecom_build_complex_constant_ (tree type
, tree realpart
, tree imagpart
)
1288 if (ffe_is_emulate_complex ())
1290 bothparts
= build_tree_list (TYPE_FIELDS (type
), realpart
);
1291 TREE_CHAIN (bothparts
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), imagpart
);
1292 bothparts
= build (CONSTRUCTOR
, type
, NULL_TREE
, bothparts
);
1296 bothparts
= build_complex (type
, realpart
, imagpart
);
1303 ffecom_arglist_expr_ (const char *c
, ffebld expr
)
1306 tree
*plist
= &list
;
1307 tree trail
= NULL_TREE
; /* Append char length args here. */
1308 tree
*ptrail
= &trail
;
1313 tree wanted
= NULL_TREE
;
1314 static const char zed
[] = "0";
1319 while (expr
!= NULL
)
1342 wanted
= ffecom_f2c_complex_type_node
;
1346 wanted
= ffecom_f2c_doublereal_type_node
;
1350 wanted
= ffecom_f2c_doublecomplex_type_node
;
1354 wanted
= ffecom_f2c_real_type_node
;
1358 wanted
= ffecom_f2c_integer_type_node
;
1362 wanted
= ffecom_f2c_longint_type_node
;
1366 assert ("bad argstring code" == NULL
);
1372 exprh
= ffebld_head (expr
);
1376 if ((wanted
== NULL_TREE
)
1379 (ffecom_tree_type
[ffeinfo_basictype (ffebld_info (exprh
))]
1380 [ffeinfo_kindtype (ffebld_info (exprh
))])
1381 == TYPE_MODE (wanted
))))
1383 = build_tree_list (NULL_TREE
,
1384 ffecom_arg_ptr_to_expr (exprh
,
1388 item
= ffecom_arg_expr (exprh
, &length
);
1389 item
= ffecom_convert_widen_ (wanted
, item
);
1392 item
= ffecom_1 (ADDR_EXPR
,
1393 build_pointer_type (TREE_TYPE (item
)),
1397 = build_tree_list (NULL_TREE
,
1401 plist
= &TREE_CHAIN (*plist
);
1402 expr
= ffebld_trail (expr
);
1403 if (length
!= NULL_TREE
)
1405 *ptrail
= build_tree_list (NULL_TREE
, length
);
1406 ptrail
= &TREE_CHAIN (*ptrail
);
1410 /* We've run out of args in the call; if the implementation expects
1411 more, supply null pointers for them, which the implementation can
1412 check to see if an arg was omitted. */
1414 while (*c
!= '\0' && *c
!= '0')
1419 assert ("missing arg to run-time routine!" == NULL
);
1434 assert ("bad arg string code" == NULL
);
1438 = build_tree_list (NULL_TREE
,
1440 plist
= &TREE_CHAIN (*plist
);
1449 ffecom_widest_expr_type_ (ffebld list
)
1452 ffebld widest
= NULL
;
1454 ffetype widest_type
= NULL
;
1457 for (; list
!= NULL
; list
= ffebld_trail (list
))
1459 item
= ffebld_head (list
);
1462 if ((widest
!= NULL
)
1463 && (ffeinfo_basictype (ffebld_info (item
))
1464 != ffeinfo_basictype (ffebld_info (widest
))))
1466 type
= ffeinfo_type (ffeinfo_basictype (ffebld_info (item
)),
1467 ffeinfo_kindtype (ffebld_info (item
)));
1468 if ((widest
== FFEINFO_kindtypeNONE
)
1469 || (ffetype_size (type
)
1470 > ffetype_size (widest_type
)))
1477 assert (widest
!= NULL
);
1478 t
= ffecom_tree_type
[ffeinfo_basictype (ffebld_info (widest
))]
1479 [ffeinfo_kindtype (ffebld_info (widest
))];
1480 assert (t
!= NULL_TREE
);
1484 /* Check whether a partial overlap between two expressions is possible.
1486 Can *starting* to write a portion of expr1 change the value
1487 computed (perhaps already, *partially*) by expr2?
1489 Currently, this is a concern only for a COMPLEX expr1. But if it
1490 isn't in COMMON or local EQUIVALENCE, since we don't support
1491 aliasing of arguments, it isn't a concern. */
1494 ffecom_possible_partial_overlap_ (ffebld expr1
, ffebld expr2 ATTRIBUTE_UNUSED
)
1499 switch (ffebld_op (expr1
))
1501 case FFEBLD_opSYMTER
:
1502 sym
= ffebld_symter (expr1
);
1505 case FFEBLD_opARRAYREF
:
1506 if (ffebld_op (ffebld_left (expr1
)) != FFEBLD_opSYMTER
)
1508 sym
= ffebld_symter (ffebld_left (expr1
));
1515 if (ffesymbol_where (sym
) != FFEINFO_whereCOMMON
1516 && (ffesymbol_where (sym
) != FFEINFO_whereLOCAL
1517 || ! (st
= ffesymbol_storage (sym
))
1518 || ! ffestorag_parent (st
)))
1521 /* It's in COMMON or local EQUIVALENCE. */
1526 /* Check whether dest and source might overlap. ffebld versions of these
1527 might or might not be passed, will be NULL if not.
1529 The test is really whether source_tree is modifiable and, if modified,
1530 might overlap destination such that the value(s) in the destination might
1531 change before it is finally modified. dest_* are the canonized
1532 destination itself. */
1535 ffecom_overlap_ (tree dest_decl
, tree dest_offset
, tree dest_size
,
1536 tree source_tree
, ffebld source UNUSED
,
1544 if (source_tree
== NULL_TREE
)
1547 switch (TREE_CODE (source_tree
))
1550 case IDENTIFIER_NODE
:
1561 case TRUNC_DIV_EXPR
:
1563 case FLOOR_DIV_EXPR
:
1564 case ROUND_DIV_EXPR
:
1565 case TRUNC_MOD_EXPR
:
1567 case FLOOR_MOD_EXPR
:
1568 case ROUND_MOD_EXPR
:
1570 case EXACT_DIV_EXPR
:
1571 case FIX_TRUNC_EXPR
:
1573 case FIX_FLOOR_EXPR
:
1574 case FIX_ROUND_EXPR
:
1588 case BIT_ANDTC_EXPR
:
1590 case TRUTH_ANDIF_EXPR
:
1591 case TRUTH_ORIF_EXPR
:
1592 case TRUTH_AND_EXPR
:
1594 case TRUTH_XOR_EXPR
:
1595 case TRUTH_NOT_EXPR
:
1611 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1612 TREE_OPERAND (source_tree
, 1), NULL
,
1616 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1617 TREE_OPERAND (source_tree
, 0), NULL
,
1622 case NON_LVALUE_EXPR
:
1624 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1627 ffecom_tree_canonize_ptr_ (&source_decl
, &source_offset
,
1629 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1634 ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1635 TREE_OPERAND (source_tree
, 1), NULL
,
1637 || ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1638 TREE_OPERAND (source_tree
, 2), NULL
,
1643 ffecom_tree_canonize_ref_ (&source_decl
, &source_offset
,
1645 TREE_OPERAND (source_tree
, 0));
1649 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1652 source_decl
= source_tree
;
1653 source_offset
= bitsize_zero_node
;
1654 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1658 case REFERENCE_EXPR
:
1659 case PREDECREMENT_EXPR
:
1660 case PREINCREMENT_EXPR
:
1661 case POSTDECREMENT_EXPR
:
1662 case POSTINCREMENT_EXPR
:
1670 /* Come here when source_decl, source_offset, and source_size filled
1671 in appropriately. */
1673 if (source_decl
== NULL_TREE
)
1674 return FALSE
; /* No decl involved, so no overlap. */
1676 if (source_decl
!= dest_decl
)
1677 return FALSE
; /* Different decl, no overlap. */
1679 if (TREE_CODE (dest_size
) == ERROR_MARK
)
1680 return TRUE
; /* Assignment into entire assumed-size
1681 array? Shouldn't happen.... */
1683 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1684 ffecom_2 (PLUS_EXPR
, TREE_TYPE (dest_offset
),
1686 convert (TREE_TYPE (dest_offset
),
1688 convert (TREE_TYPE (dest_offset
),
1691 if (integer_onep (t
))
1692 return FALSE
; /* Destination precedes source. */
1695 || (source_size
== NULL_TREE
)
1696 || (TREE_CODE (source_size
) == ERROR_MARK
)
1697 || integer_zerop (source_size
))
1698 return TRUE
; /* No way to tell if dest follows source. */
1700 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1701 ffecom_2 (PLUS_EXPR
, TREE_TYPE (source_offset
),
1703 convert (TREE_TYPE (source_offset
),
1705 convert (TREE_TYPE (source_offset
),
1708 if (integer_onep (t
))
1709 return FALSE
; /* Destination follows source. */
1711 return TRUE
; /* Destination and source overlap. */
1714 /* Check whether dest might overlap any of a list of arguments or is
1715 in a COMMON area the callee might know about (and thus modify). */
1718 ffecom_args_overlapping_ (tree dest_tree
, ffebld dest UNUSED
,
1719 tree args
, tree callee_commons
,
1727 ffecom_tree_canonize_ref_ (&dest_decl
, &dest_offset
, &dest_size
,
1730 if (dest_decl
== NULL_TREE
)
1731 return FALSE
; /* Seems unlikely! */
1733 /* If the decl cannot be determined reliably, or if its in COMMON
1734 and the callee isn't known to not futz with COMMON via other
1735 means, overlap might happen. */
1737 if ((TREE_CODE (dest_decl
) == ERROR_MARK
)
1738 || ((callee_commons
!= NULL_TREE
)
1739 && TREE_PUBLIC (dest_decl
)))
1742 for (; args
!= NULL_TREE
; args
= TREE_CHAIN (args
))
1744 if (((arg
= TREE_VALUE (args
)) != NULL_TREE
)
1745 && ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1746 arg
, NULL
, scalar_args
))
1753 /* Build a string for a variable name as used by NAMELIST. This means that
1754 if we're using the f2c library, we build an uppercase string, since
1758 ffecom_build_f2c_string_ (int i
, const char *s
)
1760 if (!ffe_is_f2c_library ())
1761 return build_string (i
, s
);
1770 if (((size_t) i
) > ARRAY_SIZE (space
))
1771 tmp
= malloc_new_ks (malloc_pool_image (), "f2c_string", i
);
1775 for (p
= s
, q
= tmp
; *p
!= '\0'; ++p
, ++q
)
1779 t
= build_string (i
, tmp
);
1781 if (((size_t) i
) > ARRAY_SIZE (space
))
1782 malloc_kill_ks (malloc_pool_image (), tmp
, i
);
1788 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1789 type to just get whatever the function returns), handling the
1790 f2c value-returning convention, if required, by prepending
1791 to the arglist a pointer to a temporary to receive the return value. */
1794 ffecom_call_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1795 tree type
, tree args
, tree dest_tree
,
1796 ffebld dest
, bool *dest_used
, tree callee_commons
,
1797 bool scalar_args
, tree hook
)
1802 if (dest_used
!= NULL
)
1807 if ((dest_used
== NULL
)
1809 || (ffeinfo_basictype (ffebld_info (dest
))
1810 != FFEINFO_basictypeCOMPLEX
)
1811 || (ffeinfo_kindtype (ffebld_info (dest
)) != kt
)
1812 || ((type
!= NULL_TREE
) && (TREE_TYPE (dest_tree
) != type
))
1813 || ffecom_args_overlapping_ (dest_tree
, dest
, args
,
1823 tempvar
= dest_tree
;
1828 = build_tree_list (NULL_TREE
,
1829 ffecom_1 (ADDR_EXPR
,
1830 build_pointer_type (TREE_TYPE (tempvar
)),
1832 TREE_CHAIN (item
) = args
;
1834 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1837 if (tempvar
!= dest_tree
)
1838 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
, tempvar
);
1841 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1844 if ((type
!= NULL_TREE
) && (TREE_TYPE (item
) != type
))
1845 item
= ffecom_convert_narrow_ (type
, item
);
1850 /* Given two arguments, transform them and make a call to the given
1851 function via ffecom_call_. */
1854 ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1855 tree type
, ffebld left
, ffebld right
,
1856 tree dest_tree
, ffebld dest
, bool *dest_used
,
1857 tree callee_commons
, bool scalar_args
, bool ref
, tree hook
)
1866 /* Pass arguments by reference. */
1867 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
1868 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
1872 /* Pass arguments by value. */
1873 left_tree
= ffecom_arg_expr (left
, &left_length
);
1874 right_tree
= ffecom_arg_expr (right
, &right_length
);
1878 left_tree
= build_tree_list (NULL_TREE
, left_tree
);
1879 right_tree
= build_tree_list (NULL_TREE
, right_tree
);
1880 TREE_CHAIN (left_tree
) = right_tree
;
1882 if (left_length
!= NULL_TREE
)
1884 left_length
= build_tree_list (NULL_TREE
, left_length
);
1885 TREE_CHAIN (right_tree
) = left_length
;
1888 if (right_length
!= NULL_TREE
)
1890 right_length
= build_tree_list (NULL_TREE
, right_length
);
1891 if (left_length
!= NULL_TREE
)
1892 TREE_CHAIN (left_length
) = right_length
;
1894 TREE_CHAIN (right_tree
) = right_length
;
1897 return ffecom_call_ (fn
, kt
, is_f2c_complex
, type
, left_tree
,
1898 dest_tree
, dest
, dest_used
, callee_commons
,
1902 /* Return ptr/length args for char subexpression
1904 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1905 subexpressions by constructing the appropriate trees for the ptr-to-
1906 character-text and length-of-character-text arguments in a calling
1909 Note that if with_null is TRUE, and the expression is an opCONTER,
1910 a null byte is appended to the string. */
1913 ffecom_char_args_x_ (tree
*xitem
, tree
*length
, ffebld expr
, bool with_null
)
1917 ffetargetCharacter1 val
;
1918 ffetargetCharacterSize newlen
;
1920 switch (ffebld_op (expr
))
1922 case FFEBLD_opCONTER
:
1923 val
= ffebld_constant_character1 (ffebld_conter (expr
));
1924 newlen
= ffetarget_length_character1 (val
);
1927 /* Begin FFETARGET-NULL-KLUDGE. */
1931 *length
= build_int_2 (newlen
, 0);
1932 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1933 high
= build_int_2 (newlen
, 0);
1934 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
1935 item
= build_string (newlen
,
1936 ffetarget_text_character1 (val
));
1937 /* End FFETARGET-NULL-KLUDGE. */
1939 = build_type_variant
1943 (ffecom_f2c_ftnlen_type_node
,
1944 ffecom_f2c_ftnlen_one_node
,
1947 TREE_CONSTANT (item
) = 1;
1948 TREE_STATIC (item
) = 1;
1949 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
1953 case FFEBLD_opSYMTER
:
1955 ffesymbol s
= ffebld_symter (expr
);
1957 item
= ffesymbol_hook (s
).decl_tree
;
1958 if (item
== NULL_TREE
)
1960 s
= ffecom_sym_transform_ (s
);
1961 item
= ffesymbol_hook (s
).decl_tree
;
1963 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
1965 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
1966 *length
= ffesymbol_hook (s
).length_tree
;
1969 *length
= build_int_2 (ffesymbol_size (s
), 0);
1970 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1973 else if (item
== error_mark_node
)
1974 *length
= error_mark_node
;
1976 /* FFEINFO_kindFUNCTION. */
1977 *length
= NULL_TREE
;
1978 if (!ffesymbol_hook (s
).addr
1979 && (item
!= error_mark_node
))
1980 item
= ffecom_1 (ADDR_EXPR
,
1981 build_pointer_type (TREE_TYPE (item
)),
1986 case FFEBLD_opARRAYREF
:
1988 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1990 if (item
== error_mark_node
|| *length
== error_mark_node
)
1992 item
= *length
= error_mark_node
;
1996 item
= ffecom_arrayref_ (item
, expr
, 1);
2000 case FFEBLD_opSUBSTR
:
2004 ffebld thing
= ffebld_right (expr
);
2007 const char *char_name
;
2011 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
2012 start
= ffebld_head (thing
);
2013 thing
= ffebld_trail (thing
);
2014 assert (ffebld_trail (thing
) == NULL
);
2015 end
= ffebld_head (thing
);
2017 /* Determine name for pretty-printing range-check errors. */
2018 for (left_symter
= ffebld_left (expr
);
2019 left_symter
&& ffebld_op (left_symter
) == FFEBLD_opARRAYREF
;
2020 left_symter
= ffebld_left (left_symter
))
2022 if (ffebld_op (left_symter
) == FFEBLD_opSYMTER
)
2023 char_name
= ffesymbol_text (ffebld_symter (left_symter
));
2025 char_name
= "[expr?]";
2027 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
2029 if (item
== error_mark_node
|| *length
== error_mark_node
)
2031 item
= *length
= error_mark_node
;
2035 array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
2037 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2045 end_tree
= ffecom_expr (end
);
2046 if (flag_bounds_check
)
2047 end_tree
= ffecom_subscript_check_ (array
, end_tree
, 1, 0,
2049 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2052 if (end_tree
== error_mark_node
)
2054 item
= *length
= error_mark_node
;
2063 start_tree
= ffecom_expr (start
);
2064 if (flag_bounds_check
)
2065 start_tree
= ffecom_subscript_check_ (array
, start_tree
, 0, 0,
2067 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2070 if (start_tree
== error_mark_node
)
2072 item
= *length
= error_mark_node
;
2076 start_tree
= ffecom_save_tree (start_tree
);
2078 item
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (item
),
2080 ffecom_2 (MINUS_EXPR
,
2081 TREE_TYPE (start_tree
),
2083 ffecom_f2c_ftnlen_one_node
));
2087 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
2088 ffecom_f2c_ftnlen_one_node
,
2089 ffecom_2 (MINUS_EXPR
,
2090 ffecom_f2c_ftnlen_type_node
,
2096 end_tree
= ffecom_expr (end
);
2097 if (flag_bounds_check
)
2098 end_tree
= ffecom_subscript_check_ (array
, end_tree
, 1, 0,
2100 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2103 if (end_tree
== error_mark_node
)
2105 item
= *length
= error_mark_node
;
2109 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
2110 ffecom_f2c_ftnlen_one_node
,
2111 ffecom_2 (MINUS_EXPR
,
2112 ffecom_f2c_ftnlen_type_node
,
2113 end_tree
, start_tree
));
2119 case FFEBLD_opFUNCREF
:
2121 ffesymbol s
= ffebld_symter (ffebld_left (expr
));
2124 ffetargetCharacterSize size
= ffeinfo_size (ffebld_info (expr
));
2127 if (size
== FFETARGET_charactersizeNONE
)
2128 /* ~~Kludge alert! This should someday be fixed. */
2131 *length
= build_int_2 (size
, 0);
2132 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2134 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
2135 == FFEINFO_whereINTRINSIC
)
2139 /* Invocation of an intrinsic returning CHARACTER*1. */
2140 item
= ffecom_expr_intrinsic_ (expr
, NULL_TREE
,
2144 ix
= ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr
)));
2145 assert (ix
!= FFECOM_gfrt
);
2146 item
= ffecom_gfrt_tree_ (ix
);
2151 item
= ffesymbol_hook (s
).decl_tree
;
2152 if (item
== NULL_TREE
)
2154 s
= ffecom_sym_transform_ (s
);
2155 item
= ffesymbol_hook (s
).decl_tree
;
2157 if (item
== error_mark_node
)
2159 item
= *length
= error_mark_node
;
2163 if (!ffesymbol_hook (s
).addr
)
2164 item
= ffecom_1_fn (item
);
2166 tempvar
= ffebld_nonter_hook (expr
);
2168 tempvar
= ffecom_1 (ADDR_EXPR
,
2169 build_pointer_type (TREE_TYPE (tempvar
)),
2172 args
= build_tree_list (NULL_TREE
, tempvar
);
2174 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
) /* Sfunc args by value. */
2175 TREE_CHAIN (args
) = ffecom_list_expr (ffebld_right (expr
));
2178 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, *length
);
2179 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
2181 TREE_CHAIN (TREE_CHAIN (args
))
2182 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix
),
2183 ffebld_right (expr
));
2187 TREE_CHAIN (TREE_CHAIN (args
))
2188 = ffecom_list_ptr_to_expr (ffebld_right (expr
));
2192 item
= ffecom_3s (CALL_EXPR
,
2193 TREE_TYPE (TREE_TYPE (TREE_TYPE (item
))),
2194 item
, args
, NULL_TREE
);
2195 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
,
2200 case FFEBLD_opCONVERT
:
2202 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
2204 if (item
== error_mark_node
|| *length
== error_mark_node
)
2206 item
= *length
= error_mark_node
;
2210 if ((ffebld_size_known (ffebld_left (expr
))
2211 == FFETARGET_charactersizeNONE
)
2212 || (ffebld_size_known (ffebld_left (expr
)) < (ffebld_size (expr
))))
2213 { /* Possible blank-padding needed, copy into
2219 tempvar
= ffebld_nonter_hook (expr
);
2221 tempvar
= ffecom_1 (ADDR_EXPR
,
2222 build_pointer_type (TREE_TYPE (tempvar
)),
2225 newlen
= build_int_2 (ffebld_size (expr
), 0);
2226 TREE_TYPE (newlen
) = ffecom_f2c_ftnlen_type_node
;
2228 args
= build_tree_list (NULL_TREE
, tempvar
);
2229 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, item
);
2230 TREE_CHAIN (TREE_CHAIN (args
)) = build_tree_list (NULL_TREE
, newlen
);
2231 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args
)))
2232 = build_tree_list (NULL_TREE
, *length
);
2234 item
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, args
, NULL_TREE
);
2235 TREE_SIDE_EFFECTS (item
) = 1;
2236 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), fold (item
),
2241 { /* Just truncate the length. */
2242 *length
= build_int_2 (ffebld_size (expr
), 0);
2243 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2248 assert ("bad op for single char arg expr" == NULL
);
2256 /* Check the size of the type to be sure it doesn't overflow the
2257 "portable" capacities of the compiler back end. `dummy' types
2258 can generally overflow the normal sizes as long as the computations
2259 themselves don't overflow. A particular target of the back end
2260 must still enforce its size requirements, though, and the back
2261 end takes care of this in stor-layout.c. */
2264 ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
)
2266 if (TREE_CODE (type
) == ERROR_MARK
)
2269 if (TYPE_SIZE (type
) == NULL_TREE
)
2272 if (TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
)
2275 /* An array is too large if size is negative or the type_size overflows
2276 or its "upper half" is larger than 3 (which would make the signed
2277 byte size and offset computations overflow). */
2279 if ((tree_int_cst_sgn (TYPE_SIZE (type
)) < 0)
2280 || (!dummy
&& (TREE_INT_CST_HIGH (TYPE_SIZE (type
)) > 3
2281 || TREE_OVERFLOW (TYPE_SIZE (type
)))))
2283 ffebad_start (FFEBAD_ARRAY_LARGE
);
2284 ffebad_string (ffesymbol_text (s
));
2285 ffebad_here (0, ffesymbol_where_line (s
), ffesymbol_where_column (s
));
2288 return error_mark_node
;
2294 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2295 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2296 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2299 ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
)
2301 ffetargetCharacterSize sz
= ffesymbol_size (s
);
2306 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
2307 tlen
= NULL_TREE
; /* A statement function, no length passed. */
2310 if (ffesymbol_where (s
) == FFEINFO_whereDUMMY
)
2311 tlen
= ffecom_get_invented_identifier ("__g77_length_%s",
2312 ffesymbol_text (s
));
2314 tlen
= ffecom_get_invented_identifier ("__g77_%s", "length");
2315 tlen
= build_decl (PARM_DECL
, tlen
, ffecom_f2c_ftnlen_type_node
);
2316 DECL_ARTIFICIAL (tlen
) = 1;
2319 if (sz
== FFETARGET_charactersizeNONE
)
2321 assert (tlen
!= NULL_TREE
);
2322 highval
= variable_size (tlen
);
2326 highval
= build_int_2 (sz
, 0);
2327 TREE_TYPE (highval
) = ffecom_f2c_ftnlen_type_node
;
2330 type
= build_array_type (type
,
2331 build_range_type (ffecom_f2c_ftnlen_type_node
,
2332 ffecom_f2c_ftnlen_one_node
,
2339 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2341 ffecomConcatList_ catlist;
2342 ffebld expr; // expr of CHARACTER basictype.
2343 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2344 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2346 Scans expr for character subexpressions, updates and returns catlist
2349 static ffecomConcatList_
2350 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
, ffebld expr
,
2351 ffetargetCharacterSize max
)
2353 ffetargetCharacterSize sz
;
2360 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
>= max
))
2361 return catlist
; /* Don't append any more items. */
2363 switch (ffebld_op (expr
))
2365 case FFEBLD_opCONTER
:
2366 case FFEBLD_opSYMTER
:
2367 case FFEBLD_opARRAYREF
:
2368 case FFEBLD_opFUNCREF
:
2369 case FFEBLD_opSUBSTR
:
2370 case FFEBLD_opCONVERT
: /* Callers should strip this off beforehand
2371 if they don't need to preserve it. */
2372 if (catlist
.count
== catlist
.max
)
2373 { /* Make a (larger) list. */
2377 newmax
= (catlist
.max
== 0) ? 8 : catlist
.max
* 2;
2378 newx
= malloc_new_ks (malloc_pool_image (), "catlist",
2379 newmax
* sizeof (newx
[0]));
2380 if (catlist
.max
!= 0)
2382 memcpy (newx
, catlist
.exprs
, catlist
.max
* sizeof (newx
[0]));
2383 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2384 catlist
.max
* sizeof (newx
[0]));
2386 catlist
.max
= newmax
;
2387 catlist
.exprs
= newx
;
2389 if ((sz
= ffebld_size_known (expr
)) != FFETARGET_charactersizeNONE
)
2390 catlist
.minlen
+= sz
;
2392 ++catlist
.minlen
; /* Not true for F90; can be 0 length. */
2393 if ((sz
= ffebld_size_max (expr
)) == FFETARGET_charactersizeNONE
)
2394 catlist
.maxlen
= sz
;
2396 catlist
.maxlen
+= sz
;
2397 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
> max
))
2398 { /* This item overlaps (or is beyond) the end
2399 of the destination. */
2400 switch (ffebld_op (expr
))
2402 case FFEBLD_opCONTER
:
2403 case FFEBLD_opSYMTER
:
2404 case FFEBLD_opARRAYREF
:
2405 case FFEBLD_opFUNCREF
:
2406 case FFEBLD_opSUBSTR
:
2407 /* ~~Do useful truncations here. */
2411 assert ("op changed or inconsistent switches!" == NULL
);
2415 catlist
.exprs
[catlist
.count
++] = expr
;
2418 case FFEBLD_opPAREN
:
2419 expr
= ffebld_left (expr
);
2420 goto recurse
; /* :::::::::::::::::::: */
2422 case FFEBLD_opCONCATENATE
:
2423 catlist
= ffecom_concat_list_gather_ (catlist
, ffebld_left (expr
), max
);
2424 expr
= ffebld_right (expr
);
2425 goto recurse
; /* :::::::::::::::::::: */
2427 #if 0 /* Breaks passing small actual arg to larger
2428 dummy arg of sfunc */
2429 case FFEBLD_opCONVERT
:
2430 expr
= ffebld_left (expr
);
2432 ffetargetCharacterSize cmax
;
2434 cmax
= catlist
.len
+ ffebld_size_known (expr
);
2436 if ((max
== FFETARGET_charactersizeNONE
) || (max
> cmax
))
2439 goto recurse
; /* :::::::::::::::::::: */
2446 assert ("bad op in _gather_" == NULL
);
2451 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2453 ffecomConcatList_ catlist;
2454 ffecom_concat_list_kill_(catlist);
2456 Anything allocated within the list info is deallocated. */
2459 ffecom_concat_list_kill_ (ffecomConcatList_ catlist
)
2461 if (catlist
.max
!= 0)
2462 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2463 catlist
.max
* sizeof (catlist
.exprs
[0]));
2466 /* Make list of concatenated string exprs.
2468 Returns a flattened list of concatenated subexpressions given a
2469 tree of such expressions. */
2471 static ffecomConcatList_
2472 ffecom_concat_list_new_ (ffebld expr
, ffetargetCharacterSize max
)
2474 ffecomConcatList_ catlist
;
2476 catlist
.maxlen
= catlist
.minlen
= catlist
.max
= catlist
.count
= 0;
2477 return ffecom_concat_list_gather_ (catlist
, expr
, max
);
2480 /* Provide some kind of useful info on member of aggregate area,
2481 since current g77/gcc technology does not provide debug info
2482 on these members. */
2485 ffecom_debug_kludge_ (tree aggr
, const char *aggr_type
, ffesymbol member
,
2486 tree member_type UNUSED
, ffetargetOffset offset
)
2496 for (type_id
= member_type
;
2497 TREE_CODE (type_id
) != IDENTIFIER_NODE
;
2500 switch (TREE_CODE (type_id
))
2504 type_id
= TYPE_NAME (type_id
);
2509 type_id
= TREE_TYPE (type_id
);
2513 assert ("no IDENTIFIER_NODE for type!" == NULL
);
2514 type_id
= error_mark_node
;
2520 if (ffecom_transform_only_dummies_
2521 || !ffe_is_debug_kludge ())
2522 return; /* Can't do this yet, maybe later. */
2525 + strlen (aggr_type
)
2526 + IDENTIFIER_LENGTH (DECL_NAME (aggr
));
2528 + IDENTIFIER_LENGTH (type_id
);
2531 if (((size_t) len
) >= ARRAY_SIZE (space
))
2532 buff
= malloc_new_ks (malloc_pool_image (), "debug_kludge", len
+ 1);
2536 sprintf (&buff
[0], "At (%s) `%s' plus %ld bytes",
2538 IDENTIFIER_POINTER (DECL_NAME (aggr
)),
2541 value
= build_string (len
, buff
);
2543 = build_type_variant (build_array_type (char_type_node
,
2547 build_int_2 (strlen (buff
), 0))),
2549 decl
= build_decl (VAR_DECL
,
2550 ffecom_get_identifier_ (ffesymbol_text (member
)),
2552 TREE_CONSTANT (decl
) = 1;
2553 TREE_STATIC (decl
) = 1;
2554 DECL_INITIAL (decl
) = error_mark_node
;
2555 DECL_IN_SYSTEM_HEADER (decl
) = 1; /* Don't let -Wunused complain. */
2556 decl
= start_decl (decl
, FALSE
);
2557 finish_decl (decl
, value
, FALSE
);
2559 if (buff
!= &space
[0])
2560 malloc_kill_ks (malloc_pool_image (), buff
, len
+ 1);
2563 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2565 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2566 int i; // entry# for this entrypoint (used by master fn)
2567 ffecom_do_entrypoint_(s,i);
2569 Makes a public entry point that calls our private master fn (already
2573 ffecom_do_entry_ (ffesymbol fn
, int entrynum
)
2576 tree type
; /* Type of function. */
2577 tree multi_retval
; /* Var holding return value (union). */
2578 tree result
; /* Var holding result. */
2579 ffeinfoBasictype bt
;
2583 bool charfunc
; /* All entry points return same type
2585 bool cmplxfunc
; /* Use f2c way of returning COMPLEX. */
2586 bool multi
; /* Master fn has multiple return types. */
2587 bool altreturning
= FALSE
; /* This entry point has alternate returns. */
2588 int old_lineno
= lineno
;
2589 const char *old_input_filename
= input_filename
;
2591 input_filename
= ffesymbol_where_filename (fn
);
2592 lineno
= ffesymbol_where_filelinenum (fn
);
2594 ffecom_doing_entry_
= TRUE
; /* Don't bother with array dimensions. */
2596 switch (ffecom_primary_entry_kind_
)
2598 case FFEINFO_kindFUNCTION
:
2600 /* Determine actual return type for function. */
2602 gt
= FFEGLOBAL_typeFUNC
;
2603 bt
= ffesymbol_basictype (fn
);
2604 kt
= ffesymbol_kindtype (fn
);
2605 if (bt
== FFEINFO_basictypeNONE
)
2607 ffeimplic_establish_symbol (fn
);
2608 if (ffesymbol_funcresult (fn
) != NULL
)
2609 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
2610 bt
= ffesymbol_basictype (fn
);
2611 kt
= ffesymbol_kindtype (fn
);
2614 if (bt
== FFEINFO_basictypeCHARACTER
)
2615 charfunc
= TRUE
, cmplxfunc
= FALSE
;
2616 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
2617 && ffesymbol_is_f2c (fn
))
2618 charfunc
= FALSE
, cmplxfunc
= TRUE
;
2620 charfunc
= cmplxfunc
= FALSE
;
2623 type
= ffecom_tree_fun_type_void
;
2624 else if (ffesymbol_is_f2c (fn
))
2625 type
= ffecom_tree_fun_type
[bt
][kt
];
2627 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
2629 if ((type
== NULL_TREE
)
2630 || (TREE_TYPE (type
) == NULL_TREE
))
2631 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
2633 multi
= (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
2636 case FFEINFO_kindSUBROUTINE
:
2637 gt
= FFEGLOBAL_typeSUBR
;
2638 bt
= FFEINFO_basictypeNONE
;
2639 kt
= FFEINFO_kindtypeNONE
;
2640 if (ffecom_is_altreturning_
)
2641 { /* Am _I_ altreturning? */
2642 for (item
= ffesymbol_dummyargs (fn
);
2644 item
= ffebld_trail (item
))
2646 if (ffebld_op (ffebld_head (item
)) == FFEBLD_opSTAR
)
2648 altreturning
= TRUE
;
2653 type
= ffecom_tree_subr_type
;
2655 type
= ffecom_tree_fun_type_void
;
2658 type
= ffecom_tree_fun_type_void
;
2665 assert ("say what??" == NULL
);
2667 case FFEINFO_kindANY
:
2668 gt
= FFEGLOBAL_typeANY
;
2669 bt
= FFEINFO_basictypeNONE
;
2670 kt
= FFEINFO_kindtypeNONE
;
2671 type
= error_mark_node
;
2678 /* build_decl uses the current lineno and input_filename to set the decl
2679 source info. So, I've putzed with ffestd and ffeste code to update that
2680 source info to point to the appropriate statement just before calling
2681 ffecom_do_entrypoint (which calls this fn). */
2683 start_function (ffecom_get_external_identifier_ (fn
),
2685 0, /* nested/inline */
2686 1); /* TREE_PUBLIC */
2688 if (((g
= ffesymbol_global (fn
)) != NULL
)
2689 && ((ffeglobal_type (g
) == gt
)
2690 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
2692 ffeglobal_set_hook (g
, current_function_decl
);
2695 /* Reset args in master arg list so they get retransitioned. */
2697 for (item
= ffecom_master_arglist_
;
2699 item
= ffebld_trail (item
))
2704 arg
= ffebld_head (item
);
2705 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2706 continue; /* Alternate return or some such thing. */
2707 s
= ffebld_symter (arg
);
2708 ffesymbol_hook (s
).decl_tree
= NULL_TREE
;
2709 ffesymbol_hook (s
).length_tree
= NULL_TREE
;
2712 /* Build dummy arg list for this entry point. */
2714 if (charfunc
|| cmplxfunc
)
2715 { /* Prepend arg for where result goes. */
2720 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
2722 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
2724 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
2726 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2729 length
= ffecom_char_enhance_arg_ (&type
, fn
);
2731 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
2733 type
= build_pointer_type (type
);
2734 result
= build_decl (PARM_DECL
, result
, type
);
2736 push_parm_decl (result
);
2737 ffecom_func_result_
= result
;
2741 push_parm_decl (length
);
2742 ffecom_func_length_
= length
;
2746 result
= DECL_RESULT (current_function_decl
);
2748 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn
), FALSE
);
2750 store_parm_decls (0);
2752 ffecom_start_compstmt ();
2753 /* Disallow temp vars at this level. */
2754 current_binding_level
->prep_state
= 2;
2756 /* Make local var to hold return type for multi-type master fn. */
2760 multi_retval
= ffecom_get_invented_identifier ("__g77_%s",
2762 multi_retval
= build_decl (VAR_DECL
, multi_retval
,
2763 ffecom_multi_type_node_
);
2764 multi_retval
= start_decl (multi_retval
, FALSE
);
2765 finish_decl (multi_retval
, NULL_TREE
, FALSE
);
2768 multi_retval
= NULL_TREE
; /* Not actually ref'd if !multi. */
2770 /* Here we emit the actual code for the entry point. */
2776 tree arglist
= NULL_TREE
;
2777 tree
*plist
= &arglist
;
2783 /* Prepare actual arg list based on master arg list. */
2785 for (list
= ffecom_master_arglist_
;
2787 list
= ffebld_trail (list
))
2789 arg
= ffebld_head (list
);
2790 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2792 s
= ffebld_symter (arg
);
2793 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
2794 || ffesymbol_hook (s
).decl_tree
== error_mark_node
)
2795 actarg
= null_pointer_node
; /* We don't have this arg. */
2797 actarg
= ffesymbol_hook (s
).decl_tree
;
2798 *plist
= build_tree_list (NULL_TREE
, actarg
);
2799 plist
= &TREE_CHAIN (*plist
);
2802 /* This code appends the length arguments for character
2803 variables/arrays. */
2805 for (list
= ffecom_master_arglist_
;
2807 list
= ffebld_trail (list
))
2809 arg
= ffebld_head (list
);
2810 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2812 s
= ffebld_symter (arg
);
2813 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
2814 continue; /* Only looking for CHARACTER arguments. */
2815 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
2816 continue; /* Only looking for variables and arrays. */
2817 if (ffesymbol_hook (s
).length_tree
== NULL_TREE
2818 || ffesymbol_hook (s
).length_tree
== error_mark_node
)
2819 actarg
= ffecom_f2c_ftnlen_zero_node
; /* We don't have this arg. */
2821 actarg
= ffesymbol_hook (s
).length_tree
;
2822 *plist
= build_tree_list (NULL_TREE
, actarg
);
2823 plist
= &TREE_CHAIN (*plist
);
2826 /* Prepend character-value return info to actual arg list. */
2830 prepend
= build_tree_list (NULL_TREE
, ffecom_func_result_
);
2831 TREE_CHAIN (prepend
)
2832 = build_tree_list (NULL_TREE
, ffecom_func_length_
);
2833 TREE_CHAIN (TREE_CHAIN (prepend
)) = arglist
;
2837 /* Prepend multi-type return value to actual arg list. */
2842 = build_tree_list (NULL_TREE
,
2843 ffecom_1 (ADDR_EXPR
,
2844 build_pointer_type (TREE_TYPE (multi_retval
)),
2846 TREE_CHAIN (prepend
) = arglist
;
2850 /* Prepend my entry-point number to the actual arg list. */
2852 prepend
= build_tree_list (NULL_TREE
, build_int_2 (entrynum
, 0));
2853 TREE_CHAIN (prepend
) = arglist
;
2856 /* Build the call to the master function. */
2858 master_fn
= ffecom_1_fn (ffecom_previous_function_decl_
);
2859 call
= ffecom_3s (CALL_EXPR
,
2860 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn
))),
2861 master_fn
, arglist
, NULL_TREE
);
2863 /* Decide whether the master function is a function or subroutine, and
2864 handle the return value for my entry point. */
2866 if (charfunc
|| ((ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
2869 expand_expr_stmt (call
);
2870 expand_null_return ();
2872 else if (multi
&& cmplxfunc
)
2874 expand_expr_stmt (call
);
2876 = ffecom_1 (INDIRECT_REF
,
2877 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2879 result
= ffecom_modify (NULL_TREE
, result
,
2880 ffecom_2 (COMPONENT_REF
, TREE_TYPE (result
),
2882 ffecom_multi_fields_
[bt
][kt
]));
2883 expand_expr_stmt (result
);
2884 expand_null_return ();
2888 expand_expr_stmt (call
);
2890 = ffecom_modify (NULL_TREE
, result
,
2891 convert (TREE_TYPE (result
),
2892 ffecom_2 (COMPONENT_REF
,
2893 ffecom_tree_type
[bt
][kt
],
2895 ffecom_multi_fields_
[bt
][kt
])));
2896 expand_return (result
);
2901 = ffecom_1 (INDIRECT_REF
,
2902 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2904 result
= ffecom_modify (NULL_TREE
, result
, call
);
2905 expand_expr_stmt (result
);
2906 expand_null_return ();
2910 result
= ffecom_modify (NULL_TREE
,
2912 convert (TREE_TYPE (result
),
2914 expand_return (result
);
2918 ffecom_end_compstmt ();
2920 finish_function (0);
2922 lineno
= old_lineno
;
2923 input_filename
= old_input_filename
;
2925 ffecom_doing_entry_
= FALSE
;
2928 /* Transform expr into gcc tree with possible destination
2930 Recursive descent on expr while making corresponding tree nodes and
2931 attaching type info and such. If destination supplied and compatible
2932 with temporary that would be made in certain cases, temporary isn't
2933 made, destination used instead, and dest_used flag set TRUE. */
2936 ffecom_expr_ (ffebld expr
, tree dest_tree
, ffebld dest
,
2937 bool *dest_used
, bool assignp
, bool widenp
)
2942 ffeinfoBasictype bt
;
2945 tree dt
; /* decl_tree for an ffesymbol. */
2946 tree tree_type
, tree_type_x
;
2949 enum tree_code code
;
2951 assert (expr
!= NULL
);
2953 if (dest_used
!= NULL
)
2956 bt
= ffeinfo_basictype (ffebld_info (expr
));
2957 kt
= ffeinfo_kindtype (ffebld_info (expr
));
2958 tree_type
= ffecom_tree_type
[bt
][kt
];
2960 /* Widen integral arithmetic as desired while preserving signedness. */
2961 tree_type_x
= NULL_TREE
;
2962 if (widenp
&& tree_type
2963 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
2964 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
2965 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
2967 switch (ffebld_op (expr
))
2969 case FFEBLD_opACCTER
:
2972 ffebit bits
= ffebld_accter_bits (expr
);
2973 ffetargetOffset source_offset
= 0;
2974 ffetargetOffset dest_offset
= ffebld_accter_pad (expr
);
2977 assert (dest_offset
== 0
2978 || (bt
== FFEINFO_basictypeCHARACTER
2979 && kt
== FFEINFO_kindtypeCHARACTER1
));
2984 ffebldConstantUnion cu
;
2987 ffebldConstantArray ca
= ffebld_accter (expr
);
2989 ffebit_test (bits
, source_offset
, &value
, &length
);
2995 for (i
= 0; i
< length
; ++i
)
2997 cu
= ffebld_constantarray_get (ca
, bt
, kt
,
3000 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
3003 && dest_offset
!= 0)
3004 purpose
= build_int_2 (dest_offset
, 0);
3006 purpose
= NULL_TREE
;
3008 if (list
== NULL_TREE
)
3009 list
= item
= build_tree_list (purpose
, t
);
3012 TREE_CHAIN (item
) = build_tree_list (purpose
, t
);
3013 item
= TREE_CHAIN (item
);
3017 source_offset
+= length
;
3018 dest_offset
+= length
;
3022 item
= build_int_2 ((ffebld_accter_size (expr
)
3023 + ffebld_accter_pad (expr
)) - 1, 0);
3024 ffebit_kill (ffebld_accter_bits (expr
));
3025 TREE_TYPE (item
) = ffecom_integer_type_node
;
3029 build_range_type (ffecom_integer_type_node
,
3030 ffecom_integer_zero_node
,
3032 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
3033 TREE_CONSTANT (list
) = 1;
3034 TREE_STATIC (list
) = 1;
3037 case FFEBLD_opARRTER
:
3042 if (ffebld_arrter_pad (expr
) == 0)
3046 assert (bt
== FFEINFO_basictypeCHARACTER
3047 && kt
== FFEINFO_kindtypeCHARACTER1
);
3049 /* Becomes PURPOSE first time through loop. */
3050 item
= build_int_2 (ffebld_arrter_pad (expr
), 0);
3053 for (i
= 0; i
< ffebld_arrter_size (expr
); ++i
)
3055 ffebldConstantUnion cu
3056 = ffebld_constantarray_get (ffebld_arrter (expr
), bt
, kt
, i
);
3058 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
3060 if (list
== NULL_TREE
)
3061 /* Assume item is PURPOSE first time through loop. */
3062 list
= item
= build_tree_list (item
, t
);
3065 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
3066 item
= TREE_CHAIN (item
);
3071 item
= build_int_2 ((ffebld_arrter_size (expr
)
3072 + ffebld_arrter_pad (expr
)) - 1, 0);
3073 TREE_TYPE (item
) = ffecom_integer_type_node
;
3077 build_range_type (ffecom_integer_type_node
,
3078 ffecom_integer_zero_node
,
3080 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
3081 TREE_CONSTANT (list
) = 1;
3082 TREE_STATIC (list
) = 1;
3085 case FFEBLD_opCONTER
:
3086 assert (ffebld_conter_pad (expr
) == 0);
3088 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr
)),
3092 case FFEBLD_opSYMTER
:
3093 if ((ffebld_symter_generic (expr
) != FFEINTRIN_genNONE
)
3094 || (ffebld_symter_specific (expr
) != FFEINTRIN_specNONE
))
3095 return ffecom_ptr_to_expr (expr
); /* Same as %REF(intrinsic). */
3096 s
= ffebld_symter (expr
);
3097 t
= ffesymbol_hook (s
).decl_tree
;
3100 { /* ASSIGN'ed-label expr. */
3101 if (ffe_is_ugly_assign ())
3103 /* User explicitly wants ASSIGN'ed variables to be at the same
3104 memory address as the variables when used in non-ASSIGN
3105 contexts. That can make old, arcane, non-standard code
3106 work, but don't try to do it when a pointer wouldn't fit
3107 in the normal variable (take other approach, and warn,
3112 s
= ffecom_sym_transform_ (s
);
3113 t
= ffesymbol_hook (s
).decl_tree
;
3114 assert (t
!= NULL_TREE
);
3117 if (t
== error_mark_node
)
3120 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t
)))
3121 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
3123 if (ffesymbol_hook (s
).addr
)
3124 t
= ffecom_1 (INDIRECT_REF
,
3125 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
3129 if (ffesymbol_hook (s
).assign_tree
== NULL_TREE
)
3131 /* xgettext:no-c-format */
3132 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3133 FFEBAD_severityWARNING
);
3134 ffebad_string (ffesymbol_text (s
));
3135 ffebad_here (0, ffesymbol_where_line (s
),
3136 ffesymbol_where_column (s
));
3141 /* Don't use the normal variable's tree for ASSIGN, though mark
3142 it as in the system header (housekeeping). Use an explicit,
3143 specially created sibling that is known to be wide enough
3144 to hold pointers to labels. */
3147 && TREE_CODE (t
) == VAR_DECL
)
3148 DECL_IN_SYSTEM_HEADER (t
) = 1; /* Don't let -Wunused complain. */
3150 t
= ffesymbol_hook (s
).assign_tree
;
3153 s
= ffecom_sym_transform_assign_ (s
);
3154 t
= ffesymbol_hook (s
).assign_tree
;
3155 assert (t
!= NULL_TREE
);
3162 s
= ffecom_sym_transform_ (s
);
3163 t
= ffesymbol_hook (s
).decl_tree
;
3164 assert (t
!= NULL_TREE
);
3166 if (ffesymbol_hook (s
).addr
)
3167 t
= ffecom_1 (INDIRECT_REF
,
3168 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
3172 case FFEBLD_opARRAYREF
:
3173 return ffecom_arrayref_ (NULL_TREE
, expr
, 0);
3175 case FFEBLD_opUPLUS
:
3176 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3177 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3179 case FFEBLD_opPAREN
:
3180 /* ~~~Make sure Fortran rules respected here */
3181 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3182 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3184 case FFEBLD_opUMINUS
:
3185 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3188 tree_type
= tree_type_x
;
3189 left
= convert (tree_type
, left
);
3191 return ffecom_1 (NEGATE_EXPR
, tree_type
, left
);
3194 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3195 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3198 tree_type
= tree_type_x
;
3199 left
= convert (tree_type
, left
);
3200 right
= convert (tree_type
, right
);
3202 return ffecom_2 (PLUS_EXPR
, tree_type
, left
, right
);
3204 case FFEBLD_opSUBTRACT
:
3205 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3206 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3209 tree_type
= tree_type_x
;
3210 left
= convert (tree_type
, left
);
3211 right
= convert (tree_type
, right
);
3213 return ffecom_2 (MINUS_EXPR
, tree_type
, left
, right
);
3215 case FFEBLD_opMULTIPLY
:
3216 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3217 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3220 tree_type
= tree_type_x
;
3221 left
= convert (tree_type
, left
);
3222 right
= convert (tree_type
, right
);
3224 return ffecom_2 (MULT_EXPR
, tree_type
, left
, right
);
3226 case FFEBLD_opDIVIDE
:
3227 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3228 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3231 tree_type
= tree_type_x
;
3232 left
= convert (tree_type
, left
);
3233 right
= convert (tree_type
, right
);
3235 return ffecom_tree_divide_ (tree_type
, left
, right
,
3236 dest_tree
, dest
, dest_used
,
3237 ffebld_nonter_hook (expr
));
3239 case FFEBLD_opPOWER
:
3241 ffebld left
= ffebld_left (expr
);
3242 ffebld right
= ffebld_right (expr
);
3244 ffeinfoKindtype rtkt
;
3245 ffeinfoKindtype ltkt
;
3248 switch (ffeinfo_basictype (ffebld_info (right
)))
3251 case FFEINFO_basictypeINTEGER
:
3254 item
= ffecom_expr_power_integer_ (expr
);
3255 if (item
!= NULL_TREE
)
3259 rtkt
= FFEINFO_kindtypeINTEGER1
;
3260 switch (ffeinfo_basictype (ffebld_info (left
)))
3262 case FFEINFO_basictypeINTEGER
:
3263 if ((ffeinfo_kindtype (ffebld_info (left
))
3264 == FFEINFO_kindtypeINTEGER4
)
3265 || (ffeinfo_kindtype (ffebld_info (right
))
3266 == FFEINFO_kindtypeINTEGER4
))
3268 code
= FFECOM_gfrtPOW_QQ
;
3269 ltkt
= FFEINFO_kindtypeINTEGER4
;
3270 rtkt
= FFEINFO_kindtypeINTEGER4
;
3274 code
= FFECOM_gfrtPOW_II
;
3275 ltkt
= FFEINFO_kindtypeINTEGER1
;
3279 case FFEINFO_basictypeREAL
:
3280 if (ffeinfo_kindtype (ffebld_info (left
))
3281 == FFEINFO_kindtypeREAL1
)
3283 code
= FFECOM_gfrtPOW_RI
;
3284 ltkt
= FFEINFO_kindtypeREAL1
;
3288 code
= FFECOM_gfrtPOW_DI
;
3289 ltkt
= FFEINFO_kindtypeREAL2
;
3293 case FFEINFO_basictypeCOMPLEX
:
3294 if (ffeinfo_kindtype (ffebld_info (left
))
3295 == FFEINFO_kindtypeREAL1
)
3297 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3298 ltkt
= FFEINFO_kindtypeREAL1
;
3302 code
= FFECOM_gfrtPOW_ZI
; /* Overlapping result okay. */
3303 ltkt
= FFEINFO_kindtypeREAL2
;
3308 assert ("bad pow_*i" == NULL
);
3309 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3310 ltkt
= FFEINFO_kindtypeREAL1
;
3313 if (ffeinfo_kindtype (ffebld_info (left
)) != ltkt
)
3314 left
= ffeexpr_convert (left
, NULL
, NULL
,
3315 ffeinfo_basictype (ffebld_info (left
)),
3317 FFETARGET_charactersizeNONE
,
3318 FFEEXPR_contextLET
);
3319 if (ffeinfo_kindtype (ffebld_info (right
)) != rtkt
)
3320 right
= ffeexpr_convert (right
, NULL
, NULL
,
3321 FFEINFO_basictypeINTEGER
,
3323 FFETARGET_charactersizeNONE
,
3324 FFEEXPR_contextLET
);
3327 case FFEINFO_basictypeREAL
:
3328 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3329 left
= ffeexpr_convert (left
, NULL
, NULL
, FFEINFO_basictypeREAL
,
3330 FFEINFO_kindtypeREALDOUBLE
, 0,
3331 FFETARGET_charactersizeNONE
,
3332 FFEEXPR_contextLET
);
3333 if (ffeinfo_kindtype (ffebld_info (right
))
3334 == FFEINFO_kindtypeREAL1
)
3335 right
= ffeexpr_convert (right
, NULL
, NULL
,
3336 FFEINFO_basictypeREAL
,
3337 FFEINFO_kindtypeREALDOUBLE
, 0,
3338 FFETARGET_charactersizeNONE
,
3339 FFEEXPR_contextLET
);
3340 /* We used to call FFECOM_gfrtPOW_DD here,
3341 which passes arguments by reference. */
3342 code
= FFECOM_gfrtL_POW
;
3343 /* Pass arguments by value. */
3347 case FFEINFO_basictypeCOMPLEX
:
3348 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3349 left
= ffeexpr_convert (left
, NULL
, NULL
,
3350 FFEINFO_basictypeCOMPLEX
,
3351 FFEINFO_kindtypeREALDOUBLE
, 0,
3352 FFETARGET_charactersizeNONE
,
3353 FFEEXPR_contextLET
);
3354 if (ffeinfo_kindtype (ffebld_info (right
))
3355 == FFEINFO_kindtypeREAL1
)
3356 right
= ffeexpr_convert (right
, NULL
, NULL
,
3357 FFEINFO_basictypeCOMPLEX
,
3358 FFEINFO_kindtypeREALDOUBLE
, 0,
3359 FFETARGET_charactersizeNONE
,
3360 FFEEXPR_contextLET
);
3361 code
= FFECOM_gfrtPOW_ZZ
; /* Overlapping result okay. */
3362 ref
= TRUE
; /* Pass arguments by reference. */
3366 assert ("bad pow_x*" == NULL
);
3367 code
= FFECOM_gfrtPOW_II
;
3370 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code
),
3371 ffecom_gfrt_kindtype (code
),
3372 (ffe_is_f2c_library ()
3373 && ffecom_gfrt_complex_
[code
]),
3374 tree_type
, left
, right
,
3375 dest_tree
, dest
, dest_used
,
3376 NULL_TREE
, FALSE
, ref
,
3377 ffebld_nonter_hook (expr
));
3383 case FFEINFO_basictypeLOGICAL
:
3384 item
= ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr
)));
3385 return convert (tree_type
, item
);
3387 case FFEINFO_basictypeINTEGER
:
3388 return ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3389 ffecom_expr (ffebld_left (expr
)));
3392 assert ("NOT bad basictype" == NULL
);
3394 case FFEINFO_basictypeANY
:
3395 return error_mark_node
;
3399 case FFEBLD_opFUNCREF
:
3400 assert (ffeinfo_basictype (ffebld_info (expr
))
3401 != FFEINFO_basictypeCHARACTER
);
3403 case FFEBLD_opSUBRREF
:
3404 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
3405 == FFEINFO_whereINTRINSIC
)
3406 { /* Invocation of an intrinsic. */
3407 item
= ffecom_expr_intrinsic_ (expr
, dest_tree
, dest
,
3411 s
= ffebld_symter (ffebld_left (expr
));
3412 dt
= ffesymbol_hook (s
).decl_tree
;
3413 if (dt
== NULL_TREE
)
3415 s
= ffecom_sym_transform_ (s
);
3416 dt
= ffesymbol_hook (s
).decl_tree
;
3418 if (dt
== error_mark_node
)
3421 if (ffesymbol_hook (s
).addr
)
3424 item
= ffecom_1_fn (dt
);
3426 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
3427 args
= ffecom_list_expr (ffebld_right (expr
));
3429 args
= ffecom_list_ptr_to_expr (ffebld_right (expr
));
3431 if (args
== error_mark_node
)
3432 return error_mark_node
;
3434 item
= ffecom_call_ (item
, kt
,
3435 ffesymbol_is_f2c (s
)
3436 && (bt
== FFEINFO_basictypeCOMPLEX
)
3437 && (ffesymbol_where (s
)
3438 != FFEINFO_whereCONSTANT
),
3441 dest_tree
, dest
, dest_used
,
3442 error_mark_node
, FALSE
,
3443 ffebld_nonter_hook (expr
));
3444 TREE_SIDE_EFFECTS (item
) = 1;
3450 case FFEINFO_basictypeLOGICAL
:
3452 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3453 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3454 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3455 return convert (tree_type
, item
);
3457 case FFEINFO_basictypeINTEGER
:
3458 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
3459 ffecom_expr (ffebld_left (expr
)),
3460 ffecom_expr (ffebld_right (expr
)));
3463 assert ("AND bad basictype" == NULL
);
3465 case FFEINFO_basictypeANY
:
3466 return error_mark_node
;
3473 case FFEINFO_basictypeLOGICAL
:
3475 = ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
3476 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3477 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3478 return convert (tree_type
, item
);
3480 case FFEINFO_basictypeINTEGER
:
3481 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
3482 ffecom_expr (ffebld_left (expr
)),
3483 ffecom_expr (ffebld_right (expr
)));
3486 assert ("OR bad basictype" == NULL
);
3488 case FFEINFO_basictypeANY
:
3489 return error_mark_node
;
3497 case FFEINFO_basictypeLOGICAL
:
3499 = ffecom_2 (NE_EXPR
, integer_type_node
,
3500 ffecom_expr (ffebld_left (expr
)),
3501 ffecom_expr (ffebld_right (expr
)));
3502 return convert (tree_type
, ffecom_truth_value (item
));
3504 case FFEINFO_basictypeINTEGER
:
3505 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3506 ffecom_expr (ffebld_left (expr
)),
3507 ffecom_expr (ffebld_right (expr
)));
3510 assert ("XOR/NEQV bad basictype" == NULL
);
3512 case FFEINFO_basictypeANY
:
3513 return error_mark_node
;
3520 case FFEINFO_basictypeLOGICAL
:
3522 = ffecom_2 (EQ_EXPR
, integer_type_node
,
3523 ffecom_expr (ffebld_left (expr
)),
3524 ffecom_expr (ffebld_right (expr
)));
3525 return convert (tree_type
, ffecom_truth_value (item
));
3527 case FFEINFO_basictypeINTEGER
:
3529 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3530 ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3531 ffecom_expr (ffebld_left (expr
)),
3532 ffecom_expr (ffebld_right (expr
))));
3535 assert ("EQV bad basictype" == NULL
);
3537 case FFEINFO_basictypeANY
:
3538 return error_mark_node
;
3542 case FFEBLD_opCONVERT
:
3543 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opANY
)
3544 return error_mark_node
;
3548 case FFEINFO_basictypeLOGICAL
:
3549 case FFEINFO_basictypeINTEGER
:
3550 case FFEINFO_basictypeREAL
:
3551 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3553 case FFEINFO_basictypeCOMPLEX
:
3554 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3556 case FFEINFO_basictypeINTEGER
:
3557 case FFEINFO_basictypeLOGICAL
:
3558 case FFEINFO_basictypeREAL
:
3559 item
= ffecom_expr (ffebld_left (expr
));
3560 if (item
== error_mark_node
)
3561 return error_mark_node
;
3562 /* convert() takes care of converting to the subtype first,
3563 at least in gcc-2.7.2. */
3564 item
= convert (tree_type
, item
);
3567 case FFEINFO_basictypeCOMPLEX
:
3568 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3571 assert ("CONVERT COMPLEX bad basictype" == NULL
);
3573 case FFEINFO_basictypeANY
:
3574 return error_mark_node
;
3579 assert ("CONVERT bad basictype" == NULL
);
3581 case FFEINFO_basictypeANY
:
3582 return error_mark_node
;
3588 goto relational
; /* :::::::::::::::::::: */
3592 goto relational
; /* :::::::::::::::::::: */
3596 goto relational
; /* :::::::::::::::::::: */
3600 goto relational
; /* :::::::::::::::::::: */
3604 goto relational
; /* :::::::::::::::::::: */
3609 relational
: /* :::::::::::::::::::: */
3610 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3612 case FFEINFO_basictypeLOGICAL
:
3613 case FFEINFO_basictypeINTEGER
:
3614 case FFEINFO_basictypeREAL
:
3615 item
= ffecom_2 (code
, integer_type_node
,
3616 ffecom_expr (ffebld_left (expr
)),
3617 ffecom_expr (ffebld_right (expr
)));
3618 return convert (tree_type
, item
);
3620 case FFEINFO_basictypeCOMPLEX
:
3621 assert (code
== EQ_EXPR
|| code
== NE_EXPR
);
3624 tree arg1
= ffecom_expr (ffebld_left (expr
));
3625 tree arg2
= ffecom_expr (ffebld_right (expr
));
3627 if (arg1
== error_mark_node
|| arg2
== error_mark_node
)
3628 return error_mark_node
;
3630 arg1
= ffecom_save_tree (arg1
);
3631 arg2
= ffecom_save_tree (arg2
);
3633 if (TREE_CODE (TREE_TYPE (arg1
)) == COMPLEX_TYPE
)
3635 real_type
= TREE_TYPE (TREE_TYPE (arg1
));
3636 assert (real_type
== TREE_TYPE (TREE_TYPE (arg2
)));
3640 real_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1
)));
3641 assert (real_type
== TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2
))));
3645 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3646 ffecom_2 (EQ_EXPR
, integer_type_node
,
3647 ffecom_1 (REALPART_EXPR
, real_type
, arg1
),
3648 ffecom_1 (REALPART_EXPR
, real_type
, arg2
)),
3649 ffecom_2 (EQ_EXPR
, integer_type_node
,
3650 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1
),
3651 ffecom_1 (IMAGPART_EXPR
, real_type
,
3653 if (code
== EQ_EXPR
)
3654 item
= ffecom_truth_value (item
);
3656 item
= ffecom_truth_value_invert (item
);
3657 return convert (tree_type
, item
);
3660 case FFEINFO_basictypeCHARACTER
:
3662 ffebld left
= ffebld_left (expr
);
3663 ffebld right
= ffebld_right (expr
);
3669 /* f2c run-time functions do the implicit blank-padding for us,
3670 so we don't usually have to implement blank-padding ourselves.
3671 (The exception is when we pass an argument to a separately
3672 compiled statement function -- if we know the arg is not the
3673 same length as the dummy, we must truncate or extend it. If
3674 we "inline" statement functions, that necessity goes away as
3677 Strip off the CONVERT operators that blank-pad. (Truncation by
3678 CONVERT shouldn't happen here, but it can happen in
3681 while (ffebld_op (left
) == FFEBLD_opCONVERT
)
3682 left
= ffebld_left (left
);
3683 while (ffebld_op (right
) == FFEBLD_opCONVERT
)
3684 right
= ffebld_left (right
);
3686 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
3687 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
3689 if (left_tree
== error_mark_node
|| left_length
== error_mark_node
3690 || right_tree
== error_mark_node
3691 || right_length
== error_mark_node
)
3692 return error_mark_node
;
3694 if ((ffebld_size_known (left
) == 1)
3695 && (ffebld_size_known (right
) == 1))
3698 = ffecom_1 (INDIRECT_REF
,
3699 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3702 = ffecom_1 (INDIRECT_REF
,
3703 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3707 = ffecom_2 (code
, integer_type_node
,
3708 ffecom_2 (ARRAY_REF
,
3709 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3712 ffecom_2 (ARRAY_REF
,
3713 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3719 item
= build_tree_list (NULL_TREE
, left_tree
);
3720 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, right_tree
);
3721 TREE_CHAIN (TREE_CHAIN (item
)) = build_tree_list (NULL_TREE
,
3723 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
3724 = build_tree_list (NULL_TREE
, right_length
);
3725 item
= ffecom_call_gfrt (FFECOM_gfrtCMP
, item
, NULL_TREE
);
3726 item
= ffecom_2 (code
, integer_type_node
,
3728 convert (TREE_TYPE (item
),
3729 integer_zero_node
));
3731 item
= convert (tree_type
, item
);
3737 assert ("relational bad basictype" == NULL
);
3739 case FFEINFO_basictypeANY
:
3740 return error_mark_node
;
3744 case FFEBLD_opPERCENT_LOC
:
3745 item
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &list
);
3746 return convert (tree_type
, item
);
3748 case FFEBLD_opPERCENT_VAL
:
3749 item
= ffecom_arg_expr (ffebld_left (expr
), &list
);
3750 return convert (tree_type
, item
);
3754 case FFEBLD_opBOUNDS
:
3755 case FFEBLD_opREPEAT
:
3756 case FFEBLD_opLABTER
:
3757 case FFEBLD_opLABTOK
:
3758 case FFEBLD_opIMPDO
:
3759 case FFEBLD_opCONCATENATE
:
3760 case FFEBLD_opSUBSTR
:
3762 assert ("bad op" == NULL
);
3765 return error_mark_node
;
3769 assert ("didn't think anything got here anymore!!" == NULL
);
3771 switch (ffebld_arity (expr
))
3774 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3775 TREE_OPERAND (item
, 1) = ffecom_expr (ffebld_right (expr
));
3776 if (TREE_OPERAND (item
, 0) == error_mark_node
3777 || TREE_OPERAND (item
, 1) == error_mark_node
)
3778 return error_mark_node
;
3782 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3783 if (TREE_OPERAND (item
, 0) == error_mark_node
)
3784 return error_mark_node
;
3795 /* Returns the tree that does the intrinsic invocation.
3797 Note: this function applies only to intrinsics returning
3798 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3802 ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
3803 ffebld dest
, bool *dest_used
)
3806 tree saved_expr1
; /* For those who need it. */
3807 tree saved_expr2
; /* For those who need it. */
3808 ffeinfoBasictype bt
;
3812 tree real_type
; /* REAL type corresponding to COMPLEX. */
3814 ffebld list
= ffebld_right (expr
); /* List of (some) args. */
3815 ffebld arg1
; /* For handy reference. */
3818 ffeintrinImp codegen_imp
;
3821 assert (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
);
3823 if (dest_used
!= NULL
)
3826 bt
= ffeinfo_basictype (ffebld_info (expr
));
3827 kt
= ffeinfo_kindtype (ffebld_info (expr
));
3828 tree_type
= ffecom_tree_type
[bt
][kt
];
3832 arg1
= ffebld_head (list
);
3833 if (arg1
!= NULL
&& ffebld_op (arg1
) == FFEBLD_opANY
)
3834 return error_mark_node
;
3835 if ((list
= ffebld_trail (list
)) != NULL
)
3837 arg2
= ffebld_head (list
);
3838 if (arg2
!= NULL
&& ffebld_op (arg2
) == FFEBLD_opANY
)
3839 return error_mark_node
;
3840 if ((list
= ffebld_trail (list
)) != NULL
)
3842 arg3
= ffebld_head (list
);
3843 if (arg3
!= NULL
&& ffebld_op (arg3
) == FFEBLD_opANY
)
3844 return error_mark_node
;
3853 arg1
= arg2
= arg3
= NULL
;
3855 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3856 args. This is used by the MAX/MIN expansions. */
3859 arg1_type
= ffecom_tree_type
3860 [ffeinfo_basictype (ffebld_info (arg1
))]
3861 [ffeinfo_kindtype (ffebld_info (arg1
))];
3863 arg1_type
= NULL_TREE
; /* Really not needed, but might catch bugs
3866 /* There are several ways for each of the cases in the following switch
3867 statements to exit (from simplest to use to most complicated):
3869 break; (when expr_tree == NULL)
3871 A standard call is made to the specific intrinsic just as if it had been
3872 passed in as a dummy procedure and called as any old procedure. This
3873 method can produce slower code but in some cases it's the easiest way for
3874 now. However, if a (presumably faster) direct call is available,
3875 that is used, so this is the easiest way in many more cases now.
3877 gfrt = FFECOM_gfrtWHATEVER;
3880 gfrt contains the gfrt index of a library function to call, passing the
3881 argument(s) by value rather than by reference. Used when a more
3882 careful choice of library function is needed than that provided
3883 by the vanilla `break;'.
3887 The expr_tree has been completely set up and is ready to be returned
3888 as is. No further actions are taken. Use this when the tree is not
3889 in the simple form for one of the arity_n labels. */
3891 /* For info on how the switch statement cases were written, see the files
3892 enclosed in comments below the switch statement. */
3894 codegen_imp
= ffebld_symter_implementation (ffebld_left (expr
));
3895 gfrt
= ffeintrin_gfrt_direct (codegen_imp
);
3896 if (gfrt
== FFECOM_gfrt
)
3897 gfrt
= ffeintrin_gfrt_indirect (codegen_imp
);
3899 switch (codegen_imp
)
3901 case FFEINTRIN_impABS
:
3902 case FFEINTRIN_impCABS
:
3903 case FFEINTRIN_impCDABS
:
3904 case FFEINTRIN_impDABS
:
3905 case FFEINTRIN_impIABS
:
3906 if (ffeinfo_basictype (ffebld_info (arg1
))
3907 == FFEINFO_basictypeCOMPLEX
)
3909 if (kt
== FFEINFO_kindtypeREAL1
)
3910 gfrt
= FFECOM_gfrtCABS
;
3911 else if (kt
== FFEINFO_kindtypeREAL2
)
3912 gfrt
= FFECOM_gfrtCDABS
;
3915 return ffecom_1 (ABS_EXPR
, tree_type
,
3916 convert (tree_type
, ffecom_expr (arg1
)));
3918 case FFEINTRIN_impACOS
:
3919 case FFEINTRIN_impDACOS
:
3922 case FFEINTRIN_impAIMAG
:
3923 case FFEINTRIN_impDIMAG
:
3924 case FFEINTRIN_impIMAGPART
:
3925 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
3926 arg1_type
= TREE_TYPE (arg1_type
);
3928 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
3932 ffecom_1 (IMAGPART_EXPR
, arg1_type
,
3933 ffecom_expr (arg1
)));
3935 case FFEINTRIN_impAINT
:
3936 case FFEINTRIN_impDINT
:
3938 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
3939 return ffecom_1 (FIX_TRUNC_EXPR
, tree_type
, ffecom_expr (arg1
));
3940 #else /* in the meantime, must use floor to avoid range problems with ints */
3941 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3942 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3945 ffecom_3 (COND_EXPR
, double_type_node
,
3947 (ffecom_2 (GE_EXPR
, integer_type_node
,
3950 ffecom_float_zero_
))),
3951 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3952 build_tree_list (NULL_TREE
,
3953 convert (double_type_node
,
3956 ffecom_1 (NEGATE_EXPR
, double_type_node
,
3957 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3958 build_tree_list (NULL_TREE
,
3959 convert (double_type_node
,
3960 ffecom_1 (NEGATE_EXPR
,
3968 case FFEINTRIN_impANINT
:
3969 case FFEINTRIN_impDNINT
:
3970 #if 0 /* This way of doing it won't handle real
3971 numbers of large magnitudes. */
3972 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3973 expr_tree
= convert (tree_type
,
3974 convert (integer_type_node
,
3975 ffecom_3 (COND_EXPR
, tree_type
,
3980 ffecom_float_zero_
)),
3981 ffecom_2 (PLUS_EXPR
,
3984 ffecom_float_half_
),
3985 ffecom_2 (MINUS_EXPR
,
3988 ffecom_float_half_
))));
3990 #else /* So we instead call floor. */
3991 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3992 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3995 ffecom_3 (COND_EXPR
, double_type_node
,
3997 (ffecom_2 (GE_EXPR
, integer_type_node
,
4000 ffecom_float_zero_
))),
4001 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
4002 build_tree_list (NULL_TREE
,
4003 convert (double_type_node
,
4004 ffecom_2 (PLUS_EXPR
,
4008 ffecom_float_half_
)))),
4010 ffecom_1 (NEGATE_EXPR
, double_type_node
,
4011 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
4012 build_tree_list (NULL_TREE
,
4013 convert (double_type_node
,
4014 ffecom_2 (MINUS_EXPR
,
4017 ffecom_float_half_
),
4024 case FFEINTRIN_impASIN
:
4025 case FFEINTRIN_impDASIN
:
4026 case FFEINTRIN_impATAN
:
4027 case FFEINTRIN_impDATAN
:
4028 case FFEINTRIN_impATAN2
:
4029 case FFEINTRIN_impDATAN2
:
4032 case FFEINTRIN_impCHAR
:
4033 case FFEINTRIN_impACHAR
:
4034 tempvar
= ffebld_nonter_hook (expr
);
4037 tree tmv
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar
)));
4039 expr_tree
= ffecom_modify (tmv
,
4040 ffecom_2 (ARRAY_REF
, tmv
, tempvar
,
4042 convert (tmv
, ffecom_expr (arg1
)));
4044 expr_tree
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
),
4047 expr_tree
= ffecom_1 (ADDR_EXPR
,
4048 build_pointer_type (TREE_TYPE (expr_tree
)),
4052 case FFEINTRIN_impCMPLX
:
4053 case FFEINTRIN_impDCMPLX
:
4056 convert (tree_type
, ffecom_expr (arg1
));
4058 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
4060 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4061 convert (real_type
, ffecom_expr (arg1
)),
4063 ffecom_expr (arg2
)));
4065 case FFEINTRIN_impCOMPLEX
:
4067 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4069 ffecom_expr (arg2
));
4071 case FFEINTRIN_impCONJG
:
4072 case FFEINTRIN_impDCONJG
:
4076 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
4077 arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4079 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4080 ffecom_1 (REALPART_EXPR
, real_type
, arg1_tree
),
4081 ffecom_1 (NEGATE_EXPR
, real_type
,
4082 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1_tree
)));
4085 case FFEINTRIN_impCOS
:
4086 case FFEINTRIN_impCCOS
:
4087 case FFEINTRIN_impCDCOS
:
4088 case FFEINTRIN_impDCOS
:
4089 if (bt
== FFEINFO_basictypeCOMPLEX
)
4091 if (kt
== FFEINFO_kindtypeREAL1
)
4092 gfrt
= FFECOM_gfrtCCOS
; /* Overlapping result okay. */
4093 else if (kt
== FFEINFO_kindtypeREAL2
)
4094 gfrt
= FFECOM_gfrtCDCOS
; /* Overlapping result okay. */
4098 case FFEINTRIN_impCOSH
:
4099 case FFEINTRIN_impDCOSH
:
4102 case FFEINTRIN_impDBLE
:
4103 case FFEINTRIN_impDFLOAT
:
4104 case FFEINTRIN_impDREAL
:
4105 case FFEINTRIN_impFLOAT
:
4106 case FFEINTRIN_impIDINT
:
4107 case FFEINTRIN_impIFIX
:
4108 case FFEINTRIN_impINT2
:
4109 case FFEINTRIN_impINT8
:
4110 case FFEINTRIN_impINT
:
4111 case FFEINTRIN_impLONG
:
4112 case FFEINTRIN_impREAL
:
4113 case FFEINTRIN_impSHORT
:
4114 case FFEINTRIN_impSNGL
:
4115 return convert (tree_type
, ffecom_expr (arg1
));
4117 case FFEINTRIN_impDIM
:
4118 case FFEINTRIN_impDDIM
:
4119 case FFEINTRIN_impIDIM
:
4120 saved_expr1
= ffecom_save_tree (convert (tree_type
,
4121 ffecom_expr (arg1
)));
4122 saved_expr2
= ffecom_save_tree (convert (tree_type
,
4123 ffecom_expr (arg2
)));
4125 ffecom_3 (COND_EXPR
, tree_type
,
4127 (ffecom_2 (GT_EXPR
, integer_type_node
,
4130 ffecom_2 (MINUS_EXPR
, tree_type
,
4133 convert (tree_type
, ffecom_float_zero_
));
4135 case FFEINTRIN_impDPROD
:
4137 ffecom_2 (MULT_EXPR
, tree_type
,
4138 convert (tree_type
, ffecom_expr (arg1
)),
4139 convert (tree_type
, ffecom_expr (arg2
)));
4141 case FFEINTRIN_impEXP
:
4142 case FFEINTRIN_impCDEXP
:
4143 case FFEINTRIN_impCEXP
:
4144 case FFEINTRIN_impDEXP
:
4145 if (bt
== FFEINFO_basictypeCOMPLEX
)
4147 if (kt
== FFEINFO_kindtypeREAL1
)
4148 gfrt
= FFECOM_gfrtCEXP
; /* Overlapping result okay. */
4149 else if (kt
== FFEINFO_kindtypeREAL2
)
4150 gfrt
= FFECOM_gfrtCDEXP
; /* Overlapping result okay. */
4154 case FFEINTRIN_impICHAR
:
4155 case FFEINTRIN_impIACHAR
:
4156 #if 0 /* The simple approach. */
4157 ffecom_char_args_ (&expr_tree
, &saved_expr1
/* Ignored */ , arg1
);
4159 = ffecom_1 (INDIRECT_REF
,
4160 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
4163 = ffecom_2 (ARRAY_REF
,
4164 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
4167 return convert (tree_type
, expr_tree
);
4168 #else /* The more interesting (and more optimal) approach. */
4169 expr_tree
= ffecom_intrinsic_ichar_ (tree_type
, arg1
, &saved_expr1
);
4170 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
4173 convert (tree_type
, integer_zero_node
));
4177 case FFEINTRIN_impINDEX
:
4180 case FFEINTRIN_impLEN
:
4182 break; /* The simple approach. */
4184 return ffecom_intrinsic_len_ (arg1
); /* The more optimal approach. */
4187 case FFEINTRIN_impLGE
:
4188 case FFEINTRIN_impLGT
:
4189 case FFEINTRIN_impLLE
:
4190 case FFEINTRIN_impLLT
:
4193 case FFEINTRIN_impLOG
:
4194 case FFEINTRIN_impALOG
:
4195 case FFEINTRIN_impCDLOG
:
4196 case FFEINTRIN_impCLOG
:
4197 case FFEINTRIN_impDLOG
:
4198 if (bt
== FFEINFO_basictypeCOMPLEX
)
4200 if (kt
== FFEINFO_kindtypeREAL1
)
4201 gfrt
= FFECOM_gfrtCLOG
; /* Overlapping result okay. */
4202 else if (kt
== FFEINFO_kindtypeREAL2
)
4203 gfrt
= FFECOM_gfrtCDLOG
; /* Overlapping result okay. */
4207 case FFEINTRIN_impLOG10
:
4208 case FFEINTRIN_impALOG10
:
4209 case FFEINTRIN_impDLOG10
:
4210 if (gfrt
!= FFECOM_gfrt
)
4211 break; /* Already picked one, stick with it. */
4213 if (kt
== FFEINFO_kindtypeREAL1
)
4214 /* We used to call FFECOM_gfrtALOG10 here. */
4215 gfrt
= FFECOM_gfrtL_LOG10
;
4216 else if (kt
== FFEINFO_kindtypeREAL2
)
4217 /* We used to call FFECOM_gfrtDLOG10 here. */
4218 gfrt
= FFECOM_gfrtL_LOG10
;
4221 case FFEINTRIN_impMAX
:
4222 case FFEINTRIN_impAMAX0
:
4223 case FFEINTRIN_impAMAX1
:
4224 case FFEINTRIN_impDMAX1
:
4225 case FFEINTRIN_impMAX0
:
4226 case FFEINTRIN_impMAX1
:
4227 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4228 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4230 arg1_type
= tree_type
;
4231 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4232 convert (arg1_type
, ffecom_expr (arg1
)),
4233 convert (arg1_type
, ffecom_expr (arg2
)));
4234 for (; list
!= NULL
; list
= ffebld_trail (list
))
4236 if ((ffebld_head (list
) == NULL
)
4237 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4239 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4242 ffecom_expr (ffebld_head (list
))));
4244 return convert (tree_type
, expr_tree
);
4246 case FFEINTRIN_impMIN
:
4247 case FFEINTRIN_impAMIN0
:
4248 case FFEINTRIN_impAMIN1
:
4249 case FFEINTRIN_impDMIN1
:
4250 case FFEINTRIN_impMIN0
:
4251 case FFEINTRIN_impMIN1
:
4252 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4253 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4255 arg1_type
= tree_type
;
4256 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4257 convert (arg1_type
, ffecom_expr (arg1
)),
4258 convert (arg1_type
, ffecom_expr (arg2
)));
4259 for (; list
!= NULL
; list
= ffebld_trail (list
))
4261 if ((ffebld_head (list
) == NULL
)
4262 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4264 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4267 ffecom_expr (ffebld_head (list
))));
4269 return convert (tree_type
, expr_tree
);
4271 case FFEINTRIN_impMOD
:
4272 case FFEINTRIN_impAMOD
:
4273 case FFEINTRIN_impDMOD
:
4274 if (bt
!= FFEINFO_basictypeREAL
)
4275 return ffecom_2 (TRUNC_MOD_EXPR
, tree_type
,
4276 convert (tree_type
, ffecom_expr (arg1
)),
4277 convert (tree_type
, ffecom_expr (arg2
)));
4279 if (kt
== FFEINFO_kindtypeREAL1
)
4280 /* We used to call FFECOM_gfrtAMOD here. */
4281 gfrt
= FFECOM_gfrtL_FMOD
;
4282 else if (kt
== FFEINFO_kindtypeREAL2
)
4283 /* We used to call FFECOM_gfrtDMOD here. */
4284 gfrt
= FFECOM_gfrtL_FMOD
;
4287 case FFEINTRIN_impNINT
:
4288 case FFEINTRIN_impIDNINT
:
4290 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4291 return ffecom_1 (FIX_ROUND_EXPR
, tree_type
, ffecom_expr (arg1
));
4293 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4294 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4296 convert (ffecom_integer_type_node
,
4297 ffecom_3 (COND_EXPR
, arg1_type
,
4299 (ffecom_2 (GE_EXPR
, integer_type_node
,
4302 ffecom_float_zero_
))),
4303 ffecom_2 (PLUS_EXPR
, arg1_type
,
4306 ffecom_float_half_
)),
4307 ffecom_2 (MINUS_EXPR
, arg1_type
,
4310 ffecom_float_half_
))));
4313 case FFEINTRIN_impSIGN
:
4314 case FFEINTRIN_impDSIGN
:
4315 case FFEINTRIN_impISIGN
:
4317 tree arg2_tree
= ffecom_expr (arg2
);
4321 (ffecom_1 (ABS_EXPR
, tree_type
,
4323 ffecom_expr (arg1
))));
4325 = ffecom_3 (COND_EXPR
, tree_type
,
4327 (ffecom_2 (GE_EXPR
, integer_type_node
,
4329 convert (TREE_TYPE (arg2_tree
),
4330 integer_zero_node
))),
4332 ffecom_1 (NEGATE_EXPR
, tree_type
, saved_expr1
));
4333 /* Make sure SAVE_EXPRs get referenced early enough. */
4335 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4336 convert (void_type_node
, saved_expr1
),
4341 case FFEINTRIN_impSIN
:
4342 case FFEINTRIN_impCDSIN
:
4343 case FFEINTRIN_impCSIN
:
4344 case FFEINTRIN_impDSIN
:
4345 if (bt
== FFEINFO_basictypeCOMPLEX
)
4347 if (kt
== FFEINFO_kindtypeREAL1
)
4348 gfrt
= FFECOM_gfrtCSIN
; /* Overlapping result okay. */
4349 else if (kt
== FFEINFO_kindtypeREAL2
)
4350 gfrt
= FFECOM_gfrtCDSIN
; /* Overlapping result okay. */
4354 case FFEINTRIN_impSINH
:
4355 case FFEINTRIN_impDSINH
:
4358 case FFEINTRIN_impSQRT
:
4359 case FFEINTRIN_impCDSQRT
:
4360 case FFEINTRIN_impCSQRT
:
4361 case FFEINTRIN_impDSQRT
:
4362 if (bt
== FFEINFO_basictypeCOMPLEX
)
4364 if (kt
== FFEINFO_kindtypeREAL1
)
4365 gfrt
= FFECOM_gfrtCSQRT
; /* Overlapping result okay. */
4366 else if (kt
== FFEINFO_kindtypeREAL2
)
4367 gfrt
= FFECOM_gfrtCDSQRT
; /* Overlapping result okay. */
4371 case FFEINTRIN_impTAN
:
4372 case FFEINTRIN_impDTAN
:
4373 case FFEINTRIN_impTANH
:
4374 case FFEINTRIN_impDTANH
:
4377 case FFEINTRIN_impREALPART
:
4378 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
4379 arg1_type
= TREE_TYPE (arg1_type
);
4381 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
4385 ffecom_1 (REALPART_EXPR
, arg1_type
,
4386 ffecom_expr (arg1
)));
4388 case FFEINTRIN_impIAND
:
4389 case FFEINTRIN_impAND
:
4390 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
4392 ffecom_expr (arg1
)),
4394 ffecom_expr (arg2
)));
4396 case FFEINTRIN_impIOR
:
4397 case FFEINTRIN_impOR
:
4398 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4400 ffecom_expr (arg1
)),
4402 ffecom_expr (arg2
)));
4404 case FFEINTRIN_impIEOR
:
4405 case FFEINTRIN_impXOR
:
4406 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
4408 ffecom_expr (arg1
)),
4410 ffecom_expr (arg2
)));
4412 case FFEINTRIN_impLSHIFT
:
4413 return ffecom_2 (LSHIFT_EXPR
, tree_type
,
4415 convert (integer_type_node
,
4416 ffecom_expr (arg2
)));
4418 case FFEINTRIN_impRSHIFT
:
4419 return ffecom_2 (RSHIFT_EXPR
, tree_type
,
4421 convert (integer_type_node
,
4422 ffecom_expr (arg2
)));
4424 case FFEINTRIN_impNOT
:
4425 return ffecom_1 (BIT_NOT_EXPR
, tree_type
, ffecom_expr (arg1
));
4427 case FFEINTRIN_impBIT_SIZE
:
4428 return convert (tree_type
, TYPE_SIZE (arg1_type
));
4430 case FFEINTRIN_impBTEST
:
4432 ffetargetLogical1 target_true
;
4433 ffetargetLogical1 target_false
;
4437 ffetarget_logical1 (&target_true
, TRUE
);
4438 ffetarget_logical1 (&target_false
, FALSE
);
4439 if (target_true
== 1)
4440 true_tree
= convert (tree_type
, integer_one_node
);
4442 true_tree
= convert (tree_type
, build_int_2 (target_true
, 0));
4443 if (target_false
== 0)
4444 false_tree
= convert (tree_type
, integer_zero_node
);
4446 false_tree
= convert (tree_type
, build_int_2 (target_false
, 0));
4449 ffecom_3 (COND_EXPR
, tree_type
,
4451 (ffecom_2 (EQ_EXPR
, integer_type_node
,
4452 ffecom_2 (BIT_AND_EXPR
, arg1_type
,
4454 ffecom_2 (LSHIFT_EXPR
, arg1_type
,
4457 convert (integer_type_node
,
4458 ffecom_expr (arg2
)))),
4460 integer_zero_node
))),
4465 case FFEINTRIN_impIBCLR
:
4467 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4469 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4470 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4473 convert (integer_type_node
,
4474 ffecom_expr (arg2
)))));
4476 case FFEINTRIN_impIBITS
:
4478 tree arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4479 ffecom_expr (arg3
)));
4481 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4484 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4485 ffecom_2 (RSHIFT_EXPR
, tree_type
,
4487 convert (integer_type_node
,
4488 ffecom_expr (arg2
))),
4490 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4491 ffecom_1 (BIT_NOT_EXPR
,
4494 integer_zero_node
)),
4495 ffecom_2 (MINUS_EXPR
,
4497 TYPE_SIZE (uns_type
),
4499 /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE. */
4501 = ffecom_3 (COND_EXPR
, tree_type
,
4503 (ffecom_2 (NE_EXPR
, integer_type_node
,
4505 integer_zero_node
)),
4507 convert (tree_type
, integer_zero_node
));
4511 case FFEINTRIN_impIBSET
:
4513 ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4515 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4516 convert (tree_type
, integer_one_node
),
4517 convert (integer_type_node
,
4518 ffecom_expr (arg2
))));
4520 case FFEINTRIN_impISHFT
:
4522 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4523 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4524 ffecom_expr (arg2
)));
4526 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4529 = ffecom_3 (COND_EXPR
, tree_type
,
4531 (ffecom_2 (GE_EXPR
, integer_type_node
,
4533 integer_zero_node
)),
4534 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4538 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4539 convert (uns_type
, arg1_tree
),
4540 ffecom_1 (NEGATE_EXPR
,
4543 /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds. */
4545 = ffecom_3 (COND_EXPR
, tree_type
,
4547 (ffecom_2 (NE_EXPR
, integer_type_node
,
4551 TYPE_SIZE (uns_type
))),
4553 convert (tree_type
, integer_zero_node
));
4554 /* Make sure SAVE_EXPRs get referenced early enough. */
4556 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4557 convert (void_type_node
, arg1_tree
),
4558 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4559 convert (void_type_node
, arg2_tree
),
4564 case FFEINTRIN_impISHFTC
:
4566 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4567 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4568 ffecom_expr (arg2
)));
4569 tree arg3_tree
= (arg3
== NULL
) ? TYPE_SIZE (tree_type
)
4570 : ffecom_save_tree (convert (integer_type_node
, ffecom_expr (arg3
)));
4576 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4579 = ffecom_2 (LSHIFT_EXPR
, tree_type
,
4580 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4581 convert (tree_type
, integer_zero_node
)),
4583 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4585 = ffecom_3 (COND_EXPR
, tree_type
,
4587 (ffecom_2 (NE_EXPR
, integer_type_node
,
4589 TYPE_SIZE (uns_type
))),
4591 convert (tree_type
, integer_zero_node
));
4592 mask_arg1
= ffecom_save_tree (mask_arg1
);
4594 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4596 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4598 masked_arg1
= ffecom_save_tree (masked_arg1
);
4600 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4602 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4603 convert (uns_type
, masked_arg1
),
4604 ffecom_1 (NEGATE_EXPR
,
4607 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4609 ffecom_2 (PLUS_EXPR
, integer_type_node
,
4613 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4614 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4618 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4619 convert (uns_type
, masked_arg1
),
4620 ffecom_2 (MINUS_EXPR
,
4625 = ffecom_3 (COND_EXPR
, tree_type
,
4627 (ffecom_2 (LT_EXPR
, integer_type_node
,
4629 integer_zero_node
)),
4633 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4634 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4637 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4638 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4642 = ffecom_3 (COND_EXPR
, tree_type
,
4644 (ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
4645 ffecom_2 (EQ_EXPR
, integer_type_node
,
4650 ffecom_2 (EQ_EXPR
, integer_type_node
,
4652 integer_zero_node
))),
4655 /* Make sure SAVE_EXPRs get referenced early enough. */
4657 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4658 convert (void_type_node
, arg1_tree
),
4659 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4660 convert (void_type_node
, arg2_tree
),
4661 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4662 convert (void_type_node
,
4664 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4665 convert (void_type_node
,
4669 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4670 convert (void_type_node
,
4676 case FFEINTRIN_impLOC
:
4678 tree arg1_tree
= ffecom_expr (arg1
);
4681 = convert (tree_type
,
4682 ffecom_1 (ADDR_EXPR
,
4683 build_pointer_type (TREE_TYPE (arg1_tree
)),
4688 case FFEINTRIN_impMVBITS
:
4693 ffebld arg4
= ffebld_head (ffebld_trail (list
));
4696 ffebld arg5
= ffebld_head (ffebld_trail (ffebld_trail (list
)));
4700 tree arg5_plus_arg3
;
4702 arg2_tree
= convert (integer_type_node
,
4703 ffecom_expr (arg2
));
4704 arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4705 ffecom_expr (arg3
)));
4706 arg4_tree
= ffecom_expr_rw (NULL_TREE
, arg4
);
4707 arg4_type
= TREE_TYPE (arg4_tree
);
4709 arg1_tree
= ffecom_save_tree (convert (arg4_type
,
4710 ffecom_expr (arg1
)));
4712 arg5_tree
= ffecom_save_tree (convert (integer_type_node
,
4713 ffecom_expr (arg5
)));
4716 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4717 ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4718 ffecom_2 (RSHIFT_EXPR
, arg4_type
,
4721 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4722 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4723 ffecom_1 (BIT_NOT_EXPR
,
4727 integer_zero_node
)),
4731 = ffecom_save_tree (ffecom_2 (PLUS_EXPR
, arg4_type
,
4735 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4736 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4738 integer_zero_node
)),
4740 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4742 = ffecom_3 (COND_EXPR
, arg4_type
,
4744 (ffecom_2 (NE_EXPR
, integer_type_node
,
4746 convert (TREE_TYPE (arg5_plus_arg3
),
4747 TYPE_SIZE (arg4_type
)))),
4749 convert (arg4_type
, integer_zero_node
));
4751 = ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4753 ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4755 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4756 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4757 ffecom_1 (BIT_NOT_EXPR
,
4761 integer_zero_node
)),
4764 = ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4767 /* Fix up (twice), because LSHIFT_EXPR above
4768 can't shift over TYPE_SIZE. */
4770 = ffecom_3 (COND_EXPR
, arg4_type
,
4772 (ffecom_2 (NE_EXPR
, integer_type_node
,
4774 convert (TREE_TYPE (arg3_tree
),
4775 integer_zero_node
))),
4779 = ffecom_3 (COND_EXPR
, arg4_type
,
4781 (ffecom_2 (NE_EXPR
, integer_type_node
,
4783 convert (TREE_TYPE (arg3_tree
),
4784 TYPE_SIZE (arg4_type
)))),
4788 = ffecom_2s (MODIFY_EXPR
, void_type_node
,
4791 /* Make sure SAVE_EXPRs get referenced early enough. */
4793 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4795 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4797 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4799 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4803 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4810 case FFEINTRIN_impDERF
:
4811 case FFEINTRIN_impERF
:
4812 case FFEINTRIN_impDERFC
:
4813 case FFEINTRIN_impERFC
:
4816 case FFEINTRIN_impIARGC
:
4817 /* extern int xargc; i__1 = xargc - 1; */
4818 expr_tree
= ffecom_2 (MINUS_EXPR
, TREE_TYPE (ffecom_tree_xargc_
),
4820 convert (TREE_TYPE (ffecom_tree_xargc_
),
4824 case FFEINTRIN_impSIGNAL_func
:
4825 case FFEINTRIN_impSIGNAL_subr
:
4831 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4832 ffecom_expr (arg1
));
4833 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4834 build_pointer_type (TREE_TYPE (arg1_tree
)),
4837 /* Pass procedure as a pointer to it, anything else by value. */
4838 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4839 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4841 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4842 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4846 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
4848 arg3_tree
= NULL_TREE
;
4850 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4851 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4852 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4855 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4856 ffecom_gfrt_kindtype (gfrt
),
4858 ((codegen_imp
== FFEINTRIN_impSIGNAL_subr
) ?
4862 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4863 ffebld_nonter_hook (expr
));
4865 if (arg3_tree
!= NULL_TREE
)
4867 = ffecom_modify (NULL_TREE
, arg3_tree
,
4868 convert (TREE_TYPE (arg3_tree
),
4873 case FFEINTRIN_impALARM
:
4879 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4880 ffecom_expr (arg1
));
4881 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4882 build_pointer_type (TREE_TYPE (arg1_tree
)),
4885 /* Pass procedure as a pointer to it, anything else by value. */
4886 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4887 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4889 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4890 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4894 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
4896 arg3_tree
= NULL_TREE
;
4898 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4899 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4900 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4903 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4904 ffecom_gfrt_kindtype (gfrt
),
4908 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4909 ffebld_nonter_hook (expr
));
4911 if (arg3_tree
!= NULL_TREE
)
4913 = ffecom_modify (NULL_TREE
, arg3_tree
,
4914 convert (TREE_TYPE (arg3_tree
),
4919 case FFEINTRIN_impCHDIR_subr
:
4920 case FFEINTRIN_impFDATE_subr
:
4921 case FFEINTRIN_impFGET_subr
:
4922 case FFEINTRIN_impFPUT_subr
:
4923 case FFEINTRIN_impGETCWD_subr
:
4924 case FFEINTRIN_impHOSTNM_subr
:
4925 case FFEINTRIN_impSYSTEM_subr
:
4926 case FFEINTRIN_impUNLINK_subr
:
4928 tree arg1_len
= integer_zero_node
;
4932 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4935 arg2_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
4937 arg2_tree
= NULL_TREE
;
4939 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4940 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4941 TREE_CHAIN (arg1_tree
) = arg1_len
;
4944 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4945 ffecom_gfrt_kindtype (gfrt
),
4949 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4950 ffebld_nonter_hook (expr
));
4952 if (arg2_tree
!= NULL_TREE
)
4954 = ffecom_modify (NULL_TREE
, arg2_tree
,
4955 convert (TREE_TYPE (arg2_tree
),
4960 case FFEINTRIN_impEXIT
:
4964 expr_tree
= build_tree_list (NULL_TREE
,
4965 ffecom_1 (ADDR_EXPR
,
4967 (ffecom_integer_type_node
),
4968 integer_zero_node
));
4971 ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4972 ffecom_gfrt_kindtype (gfrt
),
4976 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4977 ffebld_nonter_hook (expr
));
4979 case FFEINTRIN_impFLUSH
:
4981 gfrt
= FFECOM_gfrtFLUSH
;
4983 gfrt
= FFECOM_gfrtFLUSH1
;
4986 case FFEINTRIN_impCHMOD_subr
:
4987 case FFEINTRIN_impLINK_subr
:
4988 case FFEINTRIN_impRENAME_subr
:
4989 case FFEINTRIN_impSYMLNK_subr
:
4991 tree arg1_len
= integer_zero_node
;
4993 tree arg2_len
= integer_zero_node
;
4997 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4998 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
5000 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5002 arg3_tree
= NULL_TREE
;
5004 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5005 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5006 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5007 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
5008 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5009 TREE_CHAIN (arg2_tree
) = arg1_len
;
5010 TREE_CHAIN (arg1_len
) = arg2_len
;
5011 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5012 ffecom_gfrt_kindtype (gfrt
),
5016 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5017 ffebld_nonter_hook (expr
));
5018 if (arg3_tree
!= NULL_TREE
)
5019 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5020 convert (TREE_TYPE (arg3_tree
),
5025 case FFEINTRIN_impLSTAT_subr
:
5026 case FFEINTRIN_impSTAT_subr
:
5028 tree arg1_len
= integer_zero_node
;
5033 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
5035 arg2_tree
= ffecom_ptr_to_expr (arg2
);
5038 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5040 arg3_tree
= NULL_TREE
;
5042 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5043 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5044 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5045 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5046 TREE_CHAIN (arg2_tree
) = arg1_len
;
5047 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5048 ffecom_gfrt_kindtype (gfrt
),
5052 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5053 ffebld_nonter_hook (expr
));
5054 if (arg3_tree
!= NULL_TREE
)
5055 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5056 convert (TREE_TYPE (arg3_tree
),
5061 case FFEINTRIN_impFGETC_subr
:
5062 case FFEINTRIN_impFPUTC_subr
:
5066 tree arg2_len
= integer_zero_node
;
5069 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5070 ffecom_expr (arg1
));
5071 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5072 build_pointer_type (TREE_TYPE (arg1_tree
)),
5075 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
5077 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5079 arg3_tree
= NULL_TREE
;
5081 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5082 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5083 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
5084 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5085 TREE_CHAIN (arg2_tree
) = arg2_len
;
5087 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5088 ffecom_gfrt_kindtype (gfrt
),
5092 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5093 ffebld_nonter_hook (expr
));
5094 if (arg3_tree
!= NULL_TREE
)
5095 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5096 convert (TREE_TYPE (arg3_tree
),
5101 case FFEINTRIN_impFSTAT_subr
:
5107 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5108 ffecom_expr (arg1
));
5109 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5110 build_pointer_type (TREE_TYPE (arg1_tree
)),
5113 arg2_tree
= convert (ffecom_f2c_ptr_to_integer_type_node
,
5114 ffecom_ptr_to_expr (arg2
));
5117 arg3_tree
= NULL_TREE
;
5119 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5121 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5122 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5123 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5124 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5125 ffecom_gfrt_kindtype (gfrt
),
5129 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5130 ffebld_nonter_hook (expr
));
5131 if (arg3_tree
!= NULL_TREE
) {
5132 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5133 convert (TREE_TYPE (arg3_tree
),
5139 case FFEINTRIN_impKILL_subr
:
5145 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5146 ffecom_expr (arg1
));
5147 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5148 build_pointer_type (TREE_TYPE (arg1_tree
)),
5151 arg2_tree
= convert (ffecom_f2c_integer_type_node
,
5152 ffecom_expr (arg2
));
5153 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5154 build_pointer_type (TREE_TYPE (arg2_tree
)),
5158 arg3_tree
= NULL_TREE
;
5160 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5162 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5163 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5164 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5165 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5166 ffecom_gfrt_kindtype (gfrt
),
5170 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5171 ffebld_nonter_hook (expr
));
5172 if (arg3_tree
!= NULL_TREE
) {
5173 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5174 convert (TREE_TYPE (arg3_tree
),
5180 case FFEINTRIN_impCTIME_subr
:
5181 case FFEINTRIN_impTTYNAM_subr
:
5183 tree arg1_len
= integer_zero_node
;
5187 arg1_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg1_len
);
5189 arg2_tree
= convert (((codegen_imp
== FFEINTRIN_impCTIME_subr
) ?
5190 ffecom_f2c_longint_type_node
:
5191 ffecom_f2c_integer_type_node
),
5192 ffecom_expr (arg1
));
5193 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5194 build_pointer_type (TREE_TYPE (arg2_tree
)),
5197 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5198 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5199 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5200 TREE_CHAIN (arg1_len
) = arg2_tree
;
5201 TREE_CHAIN (arg1_tree
) = arg1_len
;
5204 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5205 ffecom_gfrt_kindtype (gfrt
),
5209 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5210 ffebld_nonter_hook (expr
));
5211 TREE_SIDE_EFFECTS (expr_tree
) = 1;
5215 case FFEINTRIN_impIRAND
:
5216 case FFEINTRIN_impRAND
:
5217 /* Arg defaults to 0 (normal random case) */
5222 arg1_tree
= ffecom_integer_zero_node
;
5224 arg1_tree
= ffecom_expr (arg1
);
5225 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5227 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5228 build_pointer_type (TREE_TYPE (arg1_tree
)),
5230 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5232 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5233 ffecom_gfrt_kindtype (gfrt
),
5235 ((codegen_imp
== FFEINTRIN_impIRAND
) ?
5236 ffecom_f2c_integer_type_node
:
5237 ffecom_f2c_real_type_node
),
5239 dest_tree
, dest
, dest_used
,
5241 ffebld_nonter_hook (expr
));
5245 case FFEINTRIN_impFTELL_subr
:
5246 case FFEINTRIN_impUMASK_subr
:
5251 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5252 ffecom_expr (arg1
));
5253 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5254 build_pointer_type (TREE_TYPE (arg1_tree
)),
5258 arg2_tree
= NULL_TREE
;
5260 arg2_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
5262 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5263 ffecom_gfrt_kindtype (gfrt
),
5266 build_tree_list (NULL_TREE
, arg1_tree
),
5267 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5269 ffebld_nonter_hook (expr
));
5270 if (arg2_tree
!= NULL_TREE
) {
5271 expr_tree
= ffecom_modify (NULL_TREE
, arg2_tree
,
5272 convert (TREE_TYPE (arg2_tree
),
5278 case FFEINTRIN_impCPU_TIME
:
5279 case FFEINTRIN_impSECOND_subr
:
5283 arg1_tree
= ffecom_expr_w (NULL_TREE
, arg1
);
5286 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5287 ffecom_gfrt_kindtype (gfrt
),
5291 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5292 ffebld_nonter_hook (expr
));
5295 = ffecom_modify (NULL_TREE
, arg1_tree
,
5296 convert (TREE_TYPE (arg1_tree
),
5301 case FFEINTRIN_impDTIME_subr
:
5302 case FFEINTRIN_impETIME_subr
:
5307 result_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
5309 arg1_tree
= ffecom_ptr_to_expr (arg1
);
5311 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5312 ffecom_gfrt_kindtype (gfrt
),
5315 build_tree_list (NULL_TREE
, arg1_tree
),
5316 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5318 ffebld_nonter_hook (expr
));
5319 expr_tree
= ffecom_modify (NULL_TREE
, result_tree
,
5320 convert (TREE_TYPE (result_tree
),
5325 /* Straightforward calls of libf2c routines: */
5326 case FFEINTRIN_impABORT
:
5327 case FFEINTRIN_impACCESS
:
5328 case FFEINTRIN_impBESJ0
:
5329 case FFEINTRIN_impBESJ1
:
5330 case FFEINTRIN_impBESJN
:
5331 case FFEINTRIN_impBESY0
:
5332 case FFEINTRIN_impBESY1
:
5333 case FFEINTRIN_impBESYN
:
5334 case FFEINTRIN_impCHDIR_func
:
5335 case FFEINTRIN_impCHMOD_func
:
5336 case FFEINTRIN_impDATE
:
5337 case FFEINTRIN_impDATE_AND_TIME
:
5338 case FFEINTRIN_impDBESJ0
:
5339 case FFEINTRIN_impDBESJ1
:
5340 case FFEINTRIN_impDBESJN
:
5341 case FFEINTRIN_impDBESY0
:
5342 case FFEINTRIN_impDBESY1
:
5343 case FFEINTRIN_impDBESYN
:
5344 case FFEINTRIN_impDTIME_func
:
5345 case FFEINTRIN_impETIME_func
:
5346 case FFEINTRIN_impFGETC_func
:
5347 case FFEINTRIN_impFGET_func
:
5348 case FFEINTRIN_impFNUM
:
5349 case FFEINTRIN_impFPUTC_func
:
5350 case FFEINTRIN_impFPUT_func
:
5351 case FFEINTRIN_impFSEEK
:
5352 case FFEINTRIN_impFSTAT_func
:
5353 case FFEINTRIN_impFTELL_func
:
5354 case FFEINTRIN_impGERROR
:
5355 case FFEINTRIN_impGETARG
:
5356 case FFEINTRIN_impGETCWD_func
:
5357 case FFEINTRIN_impGETENV
:
5358 case FFEINTRIN_impGETGID
:
5359 case FFEINTRIN_impGETLOG
:
5360 case FFEINTRIN_impGETPID
:
5361 case FFEINTRIN_impGETUID
:
5362 case FFEINTRIN_impGMTIME
:
5363 case FFEINTRIN_impHOSTNM_func
:
5364 case FFEINTRIN_impIDATE_unix
:
5365 case FFEINTRIN_impIDATE_vxt
:
5366 case FFEINTRIN_impIERRNO
:
5367 case FFEINTRIN_impISATTY
:
5368 case FFEINTRIN_impITIME
:
5369 case FFEINTRIN_impKILL_func
:
5370 case FFEINTRIN_impLINK_func
:
5371 case FFEINTRIN_impLNBLNK
:
5372 case FFEINTRIN_impLSTAT_func
:
5373 case FFEINTRIN_impLTIME
:
5374 case FFEINTRIN_impMCLOCK8
:
5375 case FFEINTRIN_impMCLOCK
:
5376 case FFEINTRIN_impPERROR
:
5377 case FFEINTRIN_impRENAME_func
:
5378 case FFEINTRIN_impSECNDS
:
5379 case FFEINTRIN_impSECOND_func
:
5380 case FFEINTRIN_impSLEEP
:
5381 case FFEINTRIN_impSRAND
:
5382 case FFEINTRIN_impSTAT_func
:
5383 case FFEINTRIN_impSYMLNK_func
:
5384 case FFEINTRIN_impSYSTEM_CLOCK
:
5385 case FFEINTRIN_impSYSTEM_func
:
5386 case FFEINTRIN_impTIME8
:
5387 case FFEINTRIN_impTIME_unix
:
5388 case FFEINTRIN_impTIME_vxt
:
5389 case FFEINTRIN_impUMASK_func
:
5390 case FFEINTRIN_impUNLINK_func
:
5393 case FFEINTRIN_impCTIME_func
: /* CHARACTER functions not handled here. */
5394 case FFEINTRIN_impFDATE_func
: /* CHARACTER functions not handled here. */
5395 case FFEINTRIN_impTTYNAM_func
: /* CHARACTER functions not handled here. */
5396 case FFEINTRIN_impNONE
:
5397 case FFEINTRIN_imp
: /* Hush up gcc warning. */
5398 fprintf (stderr
, "No %s implementation.\n",
5399 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr
))));
5400 assert ("unimplemented intrinsic" == NULL
);
5401 return error_mark_node
;
5404 assert (gfrt
!= FFECOM_gfrt
); /* Must have an implementation! */
5406 expr_tree
= ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt
),
5407 ffebld_right (expr
));
5409 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt
), ffecom_gfrt_kindtype (gfrt
),
5410 (ffe_is_f2c_library () && ffecom_gfrt_complex_
[gfrt
]),
5412 expr_tree
, dest_tree
, dest
, dest_used
,
5414 ffebld_nonter_hook (expr
));
5416 /* See bottom of this file for f2c transforms used to determine
5417 many of the above implementations. The info seems to confuse
5418 Emacs's C mode indentation, which is why it's been moved to
5419 the bottom of this source file. */
5422 /* For power (exponentiation) where right-hand operand is type INTEGER,
5423 generate in-line code to do it the fast way (which, if the operand
5424 is a constant, might just mean a series of multiplies). */
5427 ffecom_expr_power_integer_ (ffebld expr
)
5429 tree l
= ffecom_expr (ffebld_left (expr
));
5430 tree r
= ffecom_expr (ffebld_right (expr
));
5431 tree ltype
= TREE_TYPE (l
);
5432 tree rtype
= TREE_TYPE (r
);
5433 tree result
= NULL_TREE
;
5435 if (l
== error_mark_node
5436 || r
== error_mark_node
)
5437 return error_mark_node
;
5439 if (TREE_CODE (r
) == INTEGER_CST
)
5441 int sgn
= tree_int_cst_sgn (r
);
5444 return convert (ltype
, integer_one_node
);
5446 if ((TREE_CODE (ltype
) == INTEGER_TYPE
)
5449 /* Reciprocal of integer is either 0, -1, or 1, so after
5450 calculating that (which we leave to the back end to do
5451 or not do optimally), don't bother with any multiplying. */
5453 result
= ffecom_tree_divide_ (ltype
,
5454 convert (ltype
, integer_one_node
),
5456 NULL_TREE
, NULL
, NULL
, NULL_TREE
);
5457 r
= ffecom_1 (NEGATE_EXPR
,
5460 if ((TREE_INT_CST_LOW (r
) & 1) == 0)
5461 result
= ffecom_1 (ABS_EXPR
, rtype
,
5465 /* Generate appropriate series of multiplies, preceded
5466 by divide if the exponent is negative. */
5472 l
= ffecom_tree_divide_ (ltype
,
5473 convert (ltype
, integer_one_node
),
5475 NULL_TREE
, NULL
, NULL
,
5476 ffebld_nonter_hook (expr
));
5477 r
= ffecom_1 (NEGATE_EXPR
, rtype
, r
);
5478 assert (TREE_CODE (r
) == INTEGER_CST
);
5480 if (tree_int_cst_sgn (r
) < 0)
5481 { /* The "most negative" number. */
5482 r
= ffecom_1 (NEGATE_EXPR
, rtype
,
5483 ffecom_2 (RSHIFT_EXPR
, rtype
,
5487 l
= ffecom_2 (MULT_EXPR
, ltype
,
5495 if (TREE_INT_CST_LOW (r
) & 1)
5497 if (result
== NULL_TREE
)
5500 result
= ffecom_2 (MULT_EXPR
, ltype
,
5505 r
= ffecom_2 (RSHIFT_EXPR
, rtype
,
5508 if (integer_zerop (r
))
5510 assert (TREE_CODE (r
) == INTEGER_CST
);
5513 l
= ffecom_2 (MULT_EXPR
, ltype
,
5520 /* Though rhs isn't a constant, in-line code cannot be expanded
5521 while transforming dummies
5522 because the back end cannot be easily convinced to generate
5523 stores (MODIFY_EXPR), handle temporaries, and so on before
5524 all the appropriate rtx's have been generated for things like
5525 dummy args referenced in rhs -- which doesn't happen until
5526 store_parm_decls() is called (expand_function_start, I believe,
5527 does the actual rtx-stuffing of PARM_DECLs).
5529 So, in this case, let the caller generate the call to the
5530 run-time-library function to evaluate the power for us. */
5532 if (ffecom_transform_only_dummies_
)
5535 /* Right-hand operand not a constant, expand in-line code to figure
5536 out how to do the multiplies, &c.
5538 The returned expression is expressed this way in GNU C, where l and
5541 ({ typeof (r) rtmp = r;
5542 typeof (l) ltmp = l;
5549 if ((basetypeof (l) == basetypeof (int))
5552 result = ((typeof (l)) 1) / ltmp;
5553 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5559 if ((basetypeof (l) != basetypeof (int))
5562 ltmp = ((typeof (l)) 1) / ltmp;
5566 rtmp = -(rtmp >> 1);
5574 if ((rtmp >>= 1) == 0)
5583 Note that some of the above is compile-time collapsable, such as
5584 the first part of the if statements that checks the base type of
5585 l against int. The if statements are phrased that way to suggest
5586 an easy way to generate the if/else constructs here, knowing that
5587 the back end should (and probably does) eliminate the resulting
5588 dead code (either the int case or the non-int case), something
5589 it couldn't do without the redundant phrasing, requiring explicit
5590 dead-code elimination here, which would be kind of difficult to
5597 tree basetypeof_l_is_int
;
5602 = build_int_2 ((TREE_CODE (ltype
) == INTEGER_TYPE
), 0);
5604 se
= expand_start_stmt_expr (/*has_scope=*/1);
5606 ffecom_start_compstmt ();
5608 rtmp
= ffecom_make_tempvar ("power_r", rtype
,
5609 FFETARGET_charactersizeNONE
, -1);
5610 ltmp
= ffecom_make_tempvar ("power_l", ltype
,
5611 FFETARGET_charactersizeNONE
, -1);
5612 result
= ffecom_make_tempvar ("power_res", ltype
,
5613 FFETARGET_charactersizeNONE
, -1);
5614 if (TREE_CODE (ltype
) == COMPLEX_TYPE
5615 || TREE_CODE (ltype
) == RECORD_TYPE
)
5616 divide
= ffecom_make_tempvar ("power_div", ltype
,
5617 FFETARGET_charactersizeNONE
, -1);
5621 expand_expr_stmt (ffecom_modify (void_type_node
,
5624 expand_expr_stmt (ffecom_modify (void_type_node
,
5627 expand_start_cond (ffecom_truth_value
5628 (ffecom_2 (EQ_EXPR
, integer_type_node
,
5630 convert (rtype
, integer_zero_node
))),
5632 expand_expr_stmt (ffecom_modify (void_type_node
,
5634 convert (ltype
, integer_one_node
)));
5635 expand_start_else ();
5636 if (! integer_zerop (basetypeof_l_is_int
))
5638 expand_start_cond (ffecom_2 (LT_EXPR
, integer_type_node
,
5641 integer_zero_node
)),
5643 expand_expr_stmt (ffecom_modify (void_type_node
,
5647 convert (ltype
, integer_one_node
),
5649 NULL_TREE
, NULL
, NULL
,
5651 expand_start_cond (ffecom_truth_value
5652 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
5653 ffecom_2 (LT_EXPR
, integer_type_node
,
5656 integer_zero_node
)),
5657 ffecom_2 (EQ_EXPR
, integer_type_node
,
5658 ffecom_2 (BIT_AND_EXPR
,
5660 ffecom_1 (NEGATE_EXPR
,
5666 integer_zero_node
)))),
5668 expand_expr_stmt (ffecom_modify (void_type_node
,
5670 ffecom_1 (NEGATE_EXPR
,
5674 expand_start_else ();
5676 expand_expr_stmt (ffecom_modify (void_type_node
,
5678 convert (ltype
, integer_one_node
)));
5679 expand_start_cond (ffecom_truth_value
5680 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
5681 ffecom_truth_value_invert
5682 (basetypeof_l_is_int
),
5683 ffecom_2 (LT_EXPR
, integer_type_node
,
5686 integer_zero_node
)))),
5688 expand_expr_stmt (ffecom_modify (void_type_node
,
5692 convert (ltype
, integer_one_node
),
5694 NULL_TREE
, NULL
, NULL
,
5696 expand_expr_stmt (ffecom_modify (void_type_node
,
5698 ffecom_1 (NEGATE_EXPR
, rtype
,
5700 expand_start_cond (ffecom_truth_value
5701 (ffecom_2 (LT_EXPR
, integer_type_node
,
5703 convert (rtype
, integer_zero_node
))),
5705 expand_expr_stmt (ffecom_modify (void_type_node
,
5707 ffecom_1 (NEGATE_EXPR
, rtype
,
5708 ffecom_2 (RSHIFT_EXPR
,
5711 integer_one_node
))));
5712 expand_expr_stmt (ffecom_modify (void_type_node
,
5714 ffecom_2 (MULT_EXPR
, ltype
,
5719 expand_start_loop (1);
5720 expand_start_cond (ffecom_truth_value
5721 (ffecom_2 (BIT_AND_EXPR
, rtype
,
5723 convert (rtype
, integer_one_node
))),
5725 expand_expr_stmt (ffecom_modify (void_type_node
,
5727 ffecom_2 (MULT_EXPR
, ltype
,
5731 expand_exit_loop_if_false (NULL
,
5733 (ffecom_modify (rtype
,
5735 ffecom_2 (RSHIFT_EXPR
,
5738 integer_one_node
))));
5739 expand_expr_stmt (ffecom_modify (void_type_node
,
5741 ffecom_2 (MULT_EXPR
, ltype
,
5746 if (!integer_zerop (basetypeof_l_is_int
))
5748 expand_expr_stmt (result
);
5750 t
= ffecom_end_compstmt ();
5752 result
= expand_end_stmt_expr (se
);
5754 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5756 if (TREE_CODE (t
) == BLOCK
)
5758 /* Make a BIND_EXPR for the BLOCK already made. */
5759 result
= build (BIND_EXPR
, TREE_TYPE (result
),
5760 NULL_TREE
, result
, t
);
5761 /* Remove the block from the tree at this point.
5762 It gets put back at the proper place
5763 when the BIND_EXPR is expanded. */
5773 /* ffecom_expr_transform_ -- Transform symbols in expr
5775 ffebld expr; // FFE expression.
5776 ffecom_expr_transform_ (expr);
5778 Recursive descent on expr while transforming any untransformed SYMTERs. */
5781 ffecom_expr_transform_ (ffebld expr
)
5791 switch (ffebld_op (expr
))
5793 case FFEBLD_opSYMTER
:
5794 s
= ffebld_symter (expr
);
5795 t
= ffesymbol_hook (s
).decl_tree
;
5796 if ((t
== NULL_TREE
)
5797 && ((ffesymbol_kind (s
) != FFEINFO_kindNONE
)
5798 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
5799 && (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
))))
5801 s
= ffecom_sym_transform_ (s
);
5802 t
= ffesymbol_hook (s
).decl_tree
; /* Sfunc expr non-dummy,
5805 break; /* Ok if (t == NULL) here. */
5808 ffecom_expr_transform_ (ffebld_head (expr
));
5809 expr
= ffebld_trail (expr
);
5810 goto tail_recurse
; /* :::::::::::::::::::: */
5816 switch (ffebld_arity (expr
))
5819 ffecom_expr_transform_ (ffebld_left (expr
));
5820 expr
= ffebld_right (expr
);
5821 goto tail_recurse
; /* :::::::::::::::::::: */
5824 expr
= ffebld_left (expr
);
5825 goto tail_recurse
; /* :::::::::::::::::::: */
5834 /* Make a type based on info in live f2c.h file. */
5837 ffecom_f2c_make_type_ (tree
*type
, int tcode
, const char *name
)
5841 case FFECOM_f2ccodeCHAR
:
5842 *type
= make_signed_type (CHAR_TYPE_SIZE
);
5845 case FFECOM_f2ccodeSHORT
:
5846 *type
= make_signed_type (SHORT_TYPE_SIZE
);
5849 case FFECOM_f2ccodeINT
:
5850 *type
= make_signed_type (INT_TYPE_SIZE
);
5853 case FFECOM_f2ccodeLONG
:
5854 *type
= make_signed_type (LONG_TYPE_SIZE
);
5857 case FFECOM_f2ccodeLONGLONG
:
5858 *type
= make_signed_type (LONG_LONG_TYPE_SIZE
);
5861 case FFECOM_f2ccodeCHARPTR
:
5862 *type
= build_pointer_type (DEFAULT_SIGNED_CHAR
5863 ? signed_char_type_node
5864 : unsigned_char_type_node
);
5867 case FFECOM_f2ccodeFLOAT
:
5868 *type
= make_node (REAL_TYPE
);
5869 TYPE_PRECISION (*type
) = FLOAT_TYPE_SIZE
;
5870 layout_type (*type
);
5873 case FFECOM_f2ccodeDOUBLE
:
5874 *type
= make_node (REAL_TYPE
);
5875 TYPE_PRECISION (*type
) = DOUBLE_TYPE_SIZE
;
5876 layout_type (*type
);
5879 case FFECOM_f2ccodeLONGDOUBLE
:
5880 *type
= make_node (REAL_TYPE
);
5881 TYPE_PRECISION (*type
) = LONG_DOUBLE_TYPE_SIZE
;
5882 layout_type (*type
);
5885 case FFECOM_f2ccodeTWOREALS
:
5886 *type
= ffecom_make_complex_type_ (ffecom_f2c_real_type_node
);
5889 case FFECOM_f2ccodeTWODOUBLEREALS
:
5890 *type
= ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node
);
5894 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL
);
5895 *type
= error_mark_node
;
5899 pushdecl (build_decl (TYPE_DECL
,
5900 ffecom_get_invented_identifier ("__g77_f2c_%s", name
),
5904 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5908 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
5914 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
5915 if ((t
= ffecom_tree_type
[bt
][j
]) != NULL_TREE
5916 && compare_tree_int (TYPE_SIZE (t
), size
) == 0)
5918 assert (code
!= -1);
5919 ffecom_f2c_typecode_
[bt
][j
] = code
;
5924 /* Finish up globals after doing all program units in file
5926 Need to handle only uninitialized COMMON areas. */
5929 ffecom_finish_global_ (ffeglobal global
)
5935 if (ffeglobal_type (global
) != FFEGLOBAL_typeCOMMON
)
5938 if (ffeglobal_common_init (global
))
5941 cbt
= ffeglobal_hook (global
);
5942 if ((cbt
== NULL_TREE
)
5943 || !ffeglobal_common_have_size (global
))
5944 return global
; /* No need to make common, never ref'd. */
5946 DECL_EXTERNAL (cbt
) = 0;
5948 /* Give the array a size now. */
5950 size
= build_int_2 ((ffeglobal_common_size (global
)
5951 + ffeglobal_common_pad (global
)) - 1,
5954 cbtype
= TREE_TYPE (cbt
);
5955 TYPE_DOMAIN (cbtype
) = build_range_type (integer_type_node
,
5958 if (!TREE_TYPE (size
))
5959 TREE_TYPE (size
) = TYPE_DOMAIN (cbtype
);
5960 layout_type (cbtype
);
5962 cbt
= start_decl (cbt
, FALSE
);
5963 assert (cbt
== ffeglobal_hook (global
));
5965 finish_decl (cbt
, NULL_TREE
, FALSE
);
5970 /* Finish up any untransformed symbols. */
5973 ffecom_finish_symbol_transform_ (ffesymbol s
)
5975 if ((s
== NULL
) || (TREE_CODE (current_function_decl
) == ERROR_MARK
))
5978 /* It's easy to know to transform an untransformed symbol, to make sure
5979 we put out debugging info for it. But COMMON variables, unlike
5980 EQUIVALENCE ones, aren't given declarations in addition to the
5981 tree expressions that specify offsets, because COMMON variables
5982 can be referenced in the outer scope where only dummy arguments
5983 (PARM_DECLs) should really be seen. To be safe, just don't do any
5984 VAR_DECLs for COMMON variables when we transform them for real
5985 use, and therefore we do all the VAR_DECL creating here. */
5987 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
)
5989 if (ffesymbol_kind (s
) != FFEINFO_kindNONE
5990 || (ffesymbol_where (s
) != FFEINFO_whereNONE
5991 && ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
5992 && ffesymbol_where (s
) != FFEINFO_whereDUMMY
))
5993 /* Not transformed, and not CHARACTER*(*), and not a dummy
5994 argument, which can happen only if the entry point names
5995 it "rides in on" are all invalidated for other reasons. */
5996 s
= ffecom_sym_transform_ (s
);
5999 if ((ffesymbol_where (s
) == FFEINFO_whereCOMMON
)
6000 && (ffesymbol_hook (s
).decl_tree
!= error_mark_node
))
6002 /* This isn't working, at least for dbxout. The .s file looks
6003 okay to me (burley), but in gdb 4.9 at least, the variables
6004 appear to reside somewhere outside of the common area, so
6005 it doesn't make sense to mislead anyone by generating the info
6006 on those variables until this is fixed. NOTE: Same problem
6007 with EQUIVALENCE, sadly...see similar #if later. */
6008 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s
)),
6009 ffesymbol_storage (s
));
6015 /* Append underscore(s) to name before calling get_identifier. "us"
6016 is nonzero if the name already contains an underscore and thus
6017 needs two underscores appended. */
6020 ffecom_get_appended_identifier_ (char us
, const char *name
)
6026 newname
= xmalloc ((i
= strlen (name
)) + 1
6027 + ffe_is_underscoring ()
6029 memcpy (newname
, name
, i
);
6031 newname
[i
+ us
] = '_';
6032 newname
[i
+ 1 + us
] = '\0';
6033 id
= get_identifier (newname
);
6040 /* Decide whether to append underscore to name before calling
6044 ffecom_get_external_identifier_ (ffesymbol s
)
6047 const char *name
= ffesymbol_text (s
);
6049 /* If name is a built-in name, just return it as is. */
6051 if (!ffe_is_underscoring ()
6052 || (strcmp (name
, FFETARGET_nameBLANK_COMMON
) == 0)
6053 #if FFETARGET_isENFORCED_MAIN_NAME
6054 || (strcmp (name
, FFETARGET_nameENFORCED_NAME
) == 0)
6056 || (strcmp (name
, FFETARGET_nameUNNAMED_MAIN
) == 0)
6058 || (strcmp (name
, FFETARGET_nameUNNAMED_BLOCK_DATA
) == 0))
6059 return get_identifier (name
);
6061 us
= ffe_is_second_underscore ()
6062 ? (strchr (name
, '_') != NULL
)
6065 return ffecom_get_appended_identifier_ (us
, name
);
6068 /* Decide whether to append underscore to internal name before calling
6071 This is for non-external, top-function-context names only. Transform
6072 identifier so it doesn't conflict with the transformed result
6073 of using a _different_ external name. E.g. if "CALL FOO" is
6074 transformed into "FOO_();", then the variable in "FOO_ = 3"
6075 must be transformed into something that does not conflict, since
6076 these two things should be independent.
6078 The transformation is as follows. If the name does not contain
6079 an underscore, there is no possible conflict, so just return.
6080 If the name does contain an underscore, then transform it just
6081 like we transform an external identifier. */
6084 ffecom_get_identifier_ (const char *name
)
6086 /* If name does not contain an underscore, just return it as is. */
6088 if (!ffe_is_underscoring ()
6089 || (strchr (name
, '_') == NULL
))
6090 return get_identifier (name
);
6092 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6096 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6099 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6100 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6101 ffesymbol_kindtype(s));
6103 Call after setting up containing function and getting trees for all
6107 ffecom_gen_sfuncdef_ (ffesymbol s
, ffeinfoBasictype bt
, ffeinfoKindtype kt
)
6109 ffebld expr
= ffesymbol_sfexpr (s
);
6113 bool charfunc
= (bt
== FFEINFO_basictypeCHARACTER
);
6114 static bool recurse
= FALSE
;
6115 int old_lineno
= lineno
;
6116 const char *old_input_filename
= input_filename
;
6118 ffecom_nested_entry_
= s
;
6120 /* For now, we don't have a handy pointer to where the sfunc is actually
6121 defined, though that should be easy to add to an ffesymbol. (The
6122 token/where info available might well point to the place where the type
6123 of the sfunc is declared, especially if that precedes the place where
6124 the sfunc itself is defined, which is typically the case.) We should
6125 put out a null pointer rather than point somewhere wrong, but I want to
6126 see how it works at this point. */
6128 input_filename
= ffesymbol_where_filename (s
);
6129 lineno
= ffesymbol_where_filelinenum (s
);
6131 /* Pretransform the expression so any newly discovered things belong to the
6132 outer program unit, not to the statement function. */
6134 ffecom_expr_transform_ (expr
);
6136 /* Make sure no recursive invocation of this fn (a specific case of failing
6137 to pretransform an sfunc's expression, i.e. where its expression
6138 references another untransformed sfunc) happens. */
6143 push_f_function_context ();
6146 type
= void_type_node
;
6149 type
= ffecom_tree_type
[bt
][kt
];
6150 if (type
== NULL_TREE
)
6151 type
= integer_type_node
; /* _sym_exec_transition reports
6155 start_function (ffecom_get_identifier_ (ffesymbol_text (s
)),
6156 build_function_type (type
, NULL_TREE
),
6157 1, /* nested/inline */
6158 0); /* TREE_PUBLIC */
6160 /* We don't worry about COMPLEX return values here, because this is
6161 entirely internal to our code, and gcc has the ability to return COMPLEX
6162 directly as a value. */
6165 { /* Prepend arg for where result goes. */
6168 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
6170 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
6172 ffecom_char_enhance_arg_ (&type
, s
); /* Ignore returned length. */
6174 type
= build_pointer_type (type
);
6175 result
= build_decl (PARM_DECL
, result
, type
);
6177 push_parm_decl (result
);
6180 result
= NULL_TREE
; /* Not ref'd if !charfunc. */
6182 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s
), TRUE
);
6184 store_parm_decls (0);
6186 ffecom_start_compstmt ();
6192 ffetargetCharacterSize sz
= ffesymbol_size (s
);
6195 result_length
= build_int_2 (sz
, 0);
6196 TREE_TYPE (result_length
) = ffecom_f2c_ftnlen_type_node
;
6198 ffecom_prepare_let_char_ (sz
, expr
);
6200 ffecom_prepare_end ();
6202 ffecom_let_char_ (result
, result_length
, sz
, expr
);
6203 expand_null_return ();
6207 ffecom_prepare_expr (expr
);
6209 ffecom_prepare_end ();
6211 expand_return (ffecom_modify (NULL_TREE
,
6212 DECL_RESULT (current_function_decl
),
6213 ffecom_expr (expr
)));
6217 ffecom_end_compstmt ();
6219 func
= current_function_decl
;
6220 finish_function (1);
6222 pop_f_function_context ();
6226 lineno
= old_lineno
;
6227 input_filename
= old_input_filename
;
6229 ffecom_nested_entry_
= NULL
;
6235 ffecom_gfrt_args_ (ffecomGfrt ix
)
6237 return ffecom_gfrt_argstring_
[ix
];
6241 ffecom_gfrt_tree_ (ffecomGfrt ix
)
6243 if (ffecom_gfrt_
[ix
] == NULL_TREE
)
6244 ffecom_make_gfrt_ (ix
);
6246 return ffecom_1 (ADDR_EXPR
,
6247 build_pointer_type (TREE_TYPE (ffecom_gfrt_
[ix
])),
6251 /* Return initialize-to-zero expression for this VAR_DECL. */
6253 /* A somewhat evil way to prevent the garbage collector
6254 from collecting 'tree' structures. */
6255 #define NUM_TRACKED_CHUNK 63
6256 struct tree_ggc_tracker
GTY(())
6258 struct tree_ggc_tracker
*next
;
6259 tree trees
[NUM_TRACKED_CHUNK
];
6261 static GTY(()) struct tree_ggc_tracker
*tracker_head
;
6264 ffecom_save_tree_forever (tree t
)
6267 if (tracker_head
!= NULL
)
6268 for (i
= 0; i
< NUM_TRACKED_CHUNK
; i
++)
6269 if (tracker_head
->trees
[i
] == NULL
)
6271 tracker_head
->trees
[i
] = t
;
6276 /* Need to allocate a new block. */
6277 struct tree_ggc_tracker
*old_head
= tracker_head
;
6279 tracker_head
= ggc_alloc (sizeof (*tracker_head
));
6280 tracker_head
->next
= old_head
;
6281 tracker_head
->trees
[0] = t
;
6282 for (i
= 1; i
< NUM_TRACKED_CHUNK
; i
++)
6283 tracker_head
->trees
[i
] = NULL
;
6288 ffecom_init_zero_ (tree decl
)
6291 int incremental
= TREE_STATIC (decl
);
6292 tree type
= TREE_TYPE (decl
);
6296 make_decl_rtl (decl
, NULL
);
6297 assemble_variable (decl
, TREE_PUBLIC (decl
) ? 1 : 0, 0, 1);
6300 if ((TREE_CODE (type
) != ARRAY_TYPE
)
6301 && (TREE_CODE (type
) != RECORD_TYPE
)
6302 && (TREE_CODE (type
) != UNION_TYPE
)
6304 init
= convert (type
, integer_zero_node
);
6305 else if (!incremental
)
6307 init
= build (CONSTRUCTOR
, type
, NULL_TREE
, NULL_TREE
);
6308 TREE_CONSTANT (init
) = 1;
6309 TREE_STATIC (init
) = 1;
6313 assemble_zeros (int_size_in_bytes (type
));
6314 init
= error_mark_node
;
6321 ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
6327 switch (ffebld_op (arg
))
6329 case FFEBLD_opCONTER
: /* For F90, check 0-length. */
6330 if (ffetarget_length_character1
6331 (ffebld_constant_character1
6332 (ffebld_conter (arg
))) == 0)
6334 *maybe_tree
= integer_zero_node
;
6335 return convert (tree_type
, integer_zero_node
);
6338 *maybe_tree
= integer_one_node
;
6339 expr_tree
= build_int_2 (*ffetarget_text_character1
6340 (ffebld_constant_character1
6341 (ffebld_conter (arg
))),
6343 TREE_TYPE (expr_tree
) = tree_type
;
6346 case FFEBLD_opSYMTER
:
6347 case FFEBLD_opARRAYREF
:
6348 case FFEBLD_opFUNCREF
:
6349 case FFEBLD_opSUBSTR
:
6350 ffecom_char_args_ (&expr_tree
, &length_tree
, arg
);
6352 if ((expr_tree
== error_mark_node
)
6353 || (length_tree
== error_mark_node
))
6355 *maybe_tree
= error_mark_node
;
6356 return error_mark_node
;
6359 if (integer_zerop (length_tree
))
6361 *maybe_tree
= integer_zero_node
;
6362 return convert (tree_type
, integer_zero_node
);
6366 = ffecom_1 (INDIRECT_REF
,
6367 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
6370 = ffecom_2 (ARRAY_REF
,
6371 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
6374 expr_tree
= convert (tree_type
, expr_tree
);
6376 if (TREE_CODE (length_tree
) == INTEGER_CST
)
6377 *maybe_tree
= integer_one_node
;
6378 else /* Must check length at run time. */
6380 = ffecom_truth_value
6381 (ffecom_2 (GT_EXPR
, integer_type_node
,
6383 ffecom_f2c_ftnlen_zero_node
));
6386 case FFEBLD_opPAREN
:
6387 case FFEBLD_opCONVERT
:
6388 if (ffeinfo_size (ffebld_info (arg
)) == 0)
6390 *maybe_tree
= integer_zero_node
;
6391 return convert (tree_type
, integer_zero_node
);
6393 return ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
6396 case FFEBLD_opCONCATENATE
:
6403 expr_left
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
6405 expr_right
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_right (arg
),
6407 *maybe_tree
= ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
6410 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
6418 assert ("bad op in ICHAR" == NULL
);
6419 return error_mark_node
;
6423 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6427 length_arg = ffecom_intrinsic_len_ (expr);
6429 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6430 subexpressions by constructing the appropriate tree for the
6431 length-of-character-text argument in a calling sequence. */
6434 ffecom_intrinsic_len_ (ffebld expr
)
6436 ffetargetCharacter1 val
;
6439 switch (ffebld_op (expr
))
6441 case FFEBLD_opCONTER
:
6442 val
= ffebld_constant_character1 (ffebld_conter (expr
));
6443 length
= build_int_2 (ffetarget_length_character1 (val
), 0);
6444 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6447 case FFEBLD_opSYMTER
:
6449 ffesymbol s
= ffebld_symter (expr
);
6452 item
= ffesymbol_hook (s
).decl_tree
;
6453 if (item
== NULL_TREE
)
6455 s
= ffecom_sym_transform_ (s
);
6456 item
= ffesymbol_hook (s
).decl_tree
;
6458 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
6460 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
6461 length
= ffesymbol_hook (s
).length_tree
;
6464 length
= build_int_2 (ffesymbol_size (s
), 0);
6465 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6468 else if (item
== error_mark_node
)
6469 length
= error_mark_node
;
6470 else /* FFEINFO_kindFUNCTION: */
6475 case FFEBLD_opARRAYREF
:
6476 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
6479 case FFEBLD_opSUBSTR
:
6483 ffebld thing
= ffebld_right (expr
);
6487 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
6488 start
= ffebld_head (thing
);
6489 thing
= ffebld_trail (thing
);
6490 assert (ffebld_trail (thing
) == NULL
);
6491 end
= ffebld_head (thing
);
6493 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
6495 if (length
== error_mark_node
)
6504 length
= convert (ffecom_f2c_ftnlen_type_node
,
6510 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
6511 ffecom_expr (start
));
6513 if (start_tree
== error_mark_node
)
6515 length
= error_mark_node
;
6521 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6522 ffecom_f2c_ftnlen_one_node
,
6523 ffecom_2 (MINUS_EXPR
,
6524 ffecom_f2c_ftnlen_type_node
,
6530 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
6533 if (end_tree
== error_mark_node
)
6535 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
,
6543 end_tree
, start_tree
));
6549 case FFEBLD_opCONCATENATE
:
6551 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6552 ffecom_intrinsic_len_ (ffebld_left (expr
)),
6553 ffecom_intrinsic_len_ (ffebld_right (expr
)));
6556 case FFEBLD_opFUNCREF
:
6557 case FFEBLD_opCONVERT
:
6558 length
= build_int_2 (ffebld_size (expr
), 0);
6559 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6563 assert ("bad op for single char arg expr" == NULL
);
6564 length
= ffecom_f2c_ftnlen_zero_node
;
6568 assert (length
!= NULL_TREE
);
6573 /* Handle CHARACTER assignments.
6575 Generates code to do the assignment. Used by ordinary assignment
6576 statement handler ffecom_let_stmt and by statement-function
6577 handler to generate code for a statement function. */
6580 ffecom_let_char_ (tree dest_tree
, tree dest_length
,
6581 ffetargetCharacterSize dest_size
, ffebld source
)
6583 ffecomConcatList_ catlist
;
6588 if ((dest_tree
== error_mark_node
)
6589 || (dest_length
== error_mark_node
))
6592 assert (dest_tree
!= NULL_TREE
);
6593 assert (dest_length
!= NULL_TREE
);
6595 /* Source might be an opCONVERT, which just means it is a different size
6596 than the destination. Since the underlying implementation here handles
6597 that (directly or via the s_copy or s_cat run-time-library functions),
6598 we don't need the "convenience" of an opCONVERT that tells us to
6599 truncate or blank-pad, particularly since the resulting implementation
6600 would probably be slower than otherwise. */
6602 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
6603 source
= ffebld_left (source
);
6605 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
6606 switch (ffecom_concat_list_count_ (catlist
))
6608 case 0: /* Shouldn't happen, but in case it does... */
6609 ffecom_concat_list_kill_ (catlist
);
6610 source_tree
= null_pointer_node
;
6611 source_length
= ffecom_f2c_ftnlen_zero_node
;
6612 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6613 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
6614 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6615 = build_tree_list (NULL_TREE
, dest_length
);
6616 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6617 = build_tree_list (NULL_TREE
, source_length
);
6619 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
, NULL_TREE
);
6620 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6622 expand_expr_stmt (expr_tree
);
6626 case 1: /* The (fairly) easy case. */
6627 ffecom_char_args_ (&source_tree
, &source_length
,
6628 ffecom_concat_list_expr_ (catlist
, 0));
6629 ffecom_concat_list_kill_ (catlist
);
6630 assert (source_tree
!= NULL_TREE
);
6631 assert (source_length
!= NULL_TREE
);
6633 if ((source_tree
== error_mark_node
)
6634 || (source_length
== error_mark_node
))
6640 = ffecom_1 (INDIRECT_REF
,
6641 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6645 = ffecom_2 (ARRAY_REF
,
6646 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6651 = ffecom_1 (INDIRECT_REF
,
6652 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6656 = ffecom_2 (ARRAY_REF
,
6657 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6662 expr_tree
= ffecom_modify (void_type_node
, dest_tree
, source_tree
);
6664 expand_expr_stmt (expr_tree
);
6669 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6670 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
6671 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6672 = build_tree_list (NULL_TREE
, dest_length
);
6673 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6674 = build_tree_list (NULL_TREE
, source_length
);
6676 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
, NULL_TREE
);
6677 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6679 expand_expr_stmt (expr_tree
);
6683 default: /* Must actually concatenate things. */
6687 /* Heavy-duty concatenation. */
6690 int count
= ffecom_concat_list_count_ (catlist
);
6702 hook
= ffebld_nonter_hook (source
);
6704 assert (TREE_CODE (hook
) == TREE_VEC
);
6705 assert (TREE_VEC_LENGTH (hook
) == 2);
6706 length_array
= lengths
= TREE_VEC_ELT (hook
, 0);
6707 item_array
= items
= TREE_VEC_ELT (hook
, 1);
6710 for (i
= 0; i
< count
; ++i
)
6712 ffecom_char_args_ (&citem
, &clength
,
6713 ffecom_concat_list_expr_ (catlist
, i
));
6714 if ((citem
== error_mark_node
)
6715 || (clength
== error_mark_node
))
6717 ffecom_concat_list_kill_ (catlist
);
6722 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
6723 ffecom_modify (void_type_node
,
6724 ffecom_2 (ARRAY_REF
,
6725 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
6727 build_int_2 (i
, 0)),
6731 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
6732 ffecom_modify (void_type_node
,
6733 ffecom_2 (ARRAY_REF
,
6734 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
6736 build_int_2 (i
, 0)),
6741 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6742 TREE_CHAIN (expr_tree
)
6743 = build_tree_list (NULL_TREE
,
6744 ffecom_1 (ADDR_EXPR
,
6745 build_pointer_type (TREE_TYPE (items
)),
6747 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6748 = build_tree_list (NULL_TREE
,
6749 ffecom_1 (ADDR_EXPR
,
6750 build_pointer_type (TREE_TYPE (lengths
)),
6752 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6755 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
6756 convert (ffecom_f2c_ftnlen_type_node
,
6757 build_int_2 (count
, 0))));
6758 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
))))
6759 = build_tree_list (NULL_TREE
, dest_length
);
6761 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCAT
, expr_tree
, NULL_TREE
);
6762 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6764 expand_expr_stmt (expr_tree
);
6767 ffecom_concat_list_kill_ (catlist
);
6770 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6773 ffecom_make_gfrt_(ix);
6775 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6776 for the indicated run-time routine (ix). */
6779 ffecom_make_gfrt_ (ffecomGfrt ix
)
6784 switch (ffecom_gfrt_type_
[ix
])
6786 case FFECOM_rttypeVOID_
:
6787 ttype
= void_type_node
;
6790 case FFECOM_rttypeVOIDSTAR_
:
6791 ttype
= TREE_TYPE (null_pointer_node
); /* `void *'. */
6794 case FFECOM_rttypeFTNINT_
:
6795 ttype
= ffecom_f2c_ftnint_type_node
;
6798 case FFECOM_rttypeINTEGER_
:
6799 ttype
= ffecom_f2c_integer_type_node
;
6802 case FFECOM_rttypeLONGINT_
:
6803 ttype
= ffecom_f2c_longint_type_node
;
6806 case FFECOM_rttypeLOGICAL_
:
6807 ttype
= ffecom_f2c_logical_type_node
;
6810 case FFECOM_rttypeREAL_F2C_
:
6811 ttype
= double_type_node
;
6814 case FFECOM_rttypeREAL_GNU_
:
6815 ttype
= float_type_node
;
6818 case FFECOM_rttypeCOMPLEX_F2C_
:
6819 ttype
= void_type_node
;
6822 case FFECOM_rttypeCOMPLEX_GNU_
:
6823 ttype
= ffecom_f2c_complex_type_node
;
6826 case FFECOM_rttypeDOUBLE_
:
6827 ttype
= double_type_node
;
6830 case FFECOM_rttypeDOUBLEREAL_
:
6831 ttype
= ffecom_f2c_doublereal_type_node
;
6834 case FFECOM_rttypeDBLCMPLX_F2C_
:
6835 ttype
= void_type_node
;
6838 case FFECOM_rttypeDBLCMPLX_GNU_
:
6839 ttype
= ffecom_f2c_doublecomplex_type_node
;
6842 case FFECOM_rttypeCHARACTER_
:
6843 ttype
= void_type_node
;
6848 assert ("bad rttype" == NULL
);
6852 ttype
= build_function_type (ttype
, NULL_TREE
);
6853 t
= build_decl (FUNCTION_DECL
,
6854 get_identifier (ffecom_gfrt_name_
[ix
]),
6856 DECL_EXTERNAL (t
) = 1;
6857 TREE_READONLY (t
) = ffecom_gfrt_const_
[ix
] ? 1 : 0;
6858 TREE_PUBLIC (t
) = 1;
6859 TREE_THIS_VOLATILE (t
) = ffecom_gfrt_volatile_
[ix
] ? 1 : 0;
6861 /* Sanity check: A function that's const cannot be volatile. */
6863 assert (ffecom_gfrt_const_
[ix
] ? !ffecom_gfrt_volatile_
[ix
] : 1);
6865 /* Sanity check: A function that's const cannot return complex. */
6867 assert (ffecom_gfrt_const_
[ix
] ? !ffecom_gfrt_complex_
[ix
] : 1);
6869 t
= start_decl (t
, TRUE
);
6871 finish_decl (t
, NULL_TREE
, TRUE
);
6873 ffecom_gfrt_
[ix
] = t
;
6876 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
6879 ffecom_member_phase1_ (ffestorag mst UNUSED
, ffestorag st
)
6881 ffesymbol s
= ffestorag_symbol (st
);
6883 if (ffesymbol_namelisted (s
))
6884 ffecom_member_namelisted_
= TRUE
;
6887 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
6888 the member so debugger will see it. Otherwise nobody should be
6889 referencing the member. */
6892 ffecom_member_phase2_ (ffestorag mst
, ffestorag st
)
6900 || ((mt
= ffestorag_hook (mst
)) == NULL
)
6901 || (mt
== error_mark_node
))
6905 || ((s
= ffestorag_symbol (st
)) == NULL
))
6908 type
= ffecom_type_localvar_ (s
,
6909 ffesymbol_basictype (s
),
6910 ffesymbol_kindtype (s
));
6911 if (type
== error_mark_node
)
6914 t
= build_decl (VAR_DECL
,
6915 ffecom_get_identifier_ (ffesymbol_text (s
)),
6918 TREE_STATIC (t
) = TREE_STATIC (mt
);
6919 DECL_INITIAL (t
) = NULL_TREE
;
6920 TREE_ASM_WRITTEN (t
) = 1;
6924 gen_rtx (MEM
, TYPE_MODE (type
),
6925 plus_constant (XEXP (DECL_RTL (mt
), 0),
6926 ffestorag_modulo (mst
)
6927 + ffestorag_offset (st
)
6928 - ffestorag_offset (mst
))));
6930 t
= start_decl (t
, FALSE
);
6932 finish_decl (t
, NULL_TREE
, FALSE
);
6935 /* Prepare source expression for assignment into a destination perhaps known
6936 to be of a specific size. */
6939 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size
, ffebld source
)
6941 ffecomConcatList_ catlist
;
6946 tree tempvar
= NULL_TREE
;
6948 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
6949 source
= ffebld_left (source
);
6951 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
6952 count
= ffecom_concat_list_count_ (catlist
);
6957 = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node
,
6958 FFETARGET_charactersizeNONE
, count
);
6960 = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node
,
6961 FFETARGET_charactersizeNONE
, count
);
6963 tempvar
= make_tree_vec (2);
6964 TREE_VEC_ELT (tempvar
, 0) = ltmp
;
6965 TREE_VEC_ELT (tempvar
, 1) = itmp
;
6968 for (i
= 0; i
< count
; ++i
)
6969 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist
, i
));
6971 ffecom_concat_list_kill_ (catlist
);
6975 ffebld_nonter_set_hook (source
, tempvar
);
6976 current_binding_level
->prep_state
= 1;
6980 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
6982 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
6983 (which generates their trees) and then their trees get push_parm_decl'd.
6985 The second arg is TRUE if the dummies are for a statement function, in
6986 which case lengths are not pushed for character arguments (since they are
6987 always known by both the caller and the callee, though the code allows
6988 for someday permitting CHAR*(*) stmtfunc dummies). */
6991 ffecom_push_dummy_decls_ (ffebld dummy_list
, bool stmtfunc
)
6998 ffecom_transform_only_dummies_
= TRUE
;
7000 /* First push the parms corresponding to actual dummy "contents". */
7002 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7004 dummy
= ffebld_head (dumlist
);
7005 switch (ffebld_op (dummy
))
7009 continue; /* Forget alternate returns. */
7014 assert (ffebld_op (dummy
) == FFEBLD_opSYMTER
);
7015 s
= ffebld_symter (dummy
);
7016 parm
= ffesymbol_hook (s
).decl_tree
;
7017 if (parm
== NULL_TREE
)
7019 s
= ffecom_sym_transform_ (s
);
7020 parm
= ffesymbol_hook (s
).decl_tree
;
7021 assert (parm
!= NULL_TREE
);
7023 if (parm
!= error_mark_node
)
7024 push_parm_decl (parm
);
7027 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7029 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7031 dummy
= ffebld_head (dumlist
);
7032 switch (ffebld_op (dummy
))
7036 continue; /* Forget alternate returns, they mean
7042 s
= ffebld_symter (dummy
);
7043 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
7044 continue; /* Only looking for CHARACTER arguments. */
7045 if (stmtfunc
&& (ffesymbol_size (s
) != FFETARGET_charactersizeNONE
))
7046 continue; /* Stmtfunc arg with known size needs no
7048 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
7049 continue; /* Only looking for variables and arrays. */
7050 parm
= ffesymbol_hook (s
).length_tree
;
7051 assert (parm
!= NULL_TREE
);
7052 if (parm
!= error_mark_node
)
7053 push_parm_decl (parm
);
7056 ffecom_transform_only_dummies_
= FALSE
;
7059 /* ffecom_start_progunit_ -- Beginning of program unit
7061 Does GNU back end stuff necessary to teach it about the start of its
7062 equivalent of a Fortran program unit. */
7065 ffecom_start_progunit_ ()
7067 ffesymbol fn
= ffecom_primary_entry_
;
7069 tree id
; /* Identifier (name) of function. */
7070 tree type
; /* Type of function. */
7071 tree result
; /* Result of function. */
7072 ffeinfoBasictype bt
;
7076 ffeglobalType egt
= FFEGLOBAL_type
;
7079 bool altentries
= (ffecom_num_entrypoints_
!= 0);
7082 && (ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
7083 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
7084 bool main_program
= FALSE
;
7085 int old_lineno
= lineno
;
7086 const char *old_input_filename
= input_filename
;
7088 assert (fn
!= NULL
);
7089 assert (ffesymbol_hook (fn
).decl_tree
== NULL_TREE
);
7091 input_filename
= ffesymbol_where_filename (fn
);
7092 lineno
= ffesymbol_where_filelinenum (fn
);
7094 switch (ffecom_primary_entry_kind_
)
7096 case FFEINFO_kindPROGRAM
:
7097 main_program
= TRUE
;
7098 gt
= FFEGLOBAL_typeMAIN
;
7099 bt
= FFEINFO_basictypeNONE
;
7100 kt
= FFEINFO_kindtypeNONE
;
7101 type
= ffecom_tree_fun_type_void
;
7106 case FFEINFO_kindBLOCKDATA
:
7107 gt
= FFEGLOBAL_typeBDATA
;
7108 bt
= FFEINFO_basictypeNONE
;
7109 kt
= FFEINFO_kindtypeNONE
;
7110 type
= ffecom_tree_fun_type_void
;
7115 case FFEINFO_kindFUNCTION
:
7116 gt
= FFEGLOBAL_typeFUNC
;
7117 egt
= FFEGLOBAL_typeEXT
;
7118 bt
= ffesymbol_basictype (fn
);
7119 kt
= ffesymbol_kindtype (fn
);
7120 if (bt
== FFEINFO_basictypeNONE
)
7122 ffeimplic_establish_symbol (fn
);
7123 if (ffesymbol_funcresult (fn
) != NULL
)
7124 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
7125 bt
= ffesymbol_basictype (fn
);
7126 kt
= ffesymbol_kindtype (fn
);
7130 charfunc
= cmplxfunc
= FALSE
;
7131 else if (bt
== FFEINFO_basictypeCHARACTER
)
7132 charfunc
= TRUE
, cmplxfunc
= FALSE
;
7133 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
7134 && ffesymbol_is_f2c (fn
)
7136 charfunc
= FALSE
, cmplxfunc
= TRUE
;
7138 charfunc
= cmplxfunc
= FALSE
;
7140 if (multi
|| charfunc
)
7141 type
= ffecom_tree_fun_type_void
;
7142 else if (ffesymbol_is_f2c (fn
) && !altentries
)
7143 type
= ffecom_tree_fun_type
[bt
][kt
];
7145 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
7147 if ((type
== NULL_TREE
)
7148 || (TREE_TYPE (type
) == NULL_TREE
))
7149 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
7152 case FFEINFO_kindSUBROUTINE
:
7153 gt
= FFEGLOBAL_typeSUBR
;
7154 egt
= FFEGLOBAL_typeEXT
;
7155 bt
= FFEINFO_basictypeNONE
;
7156 kt
= FFEINFO_kindtypeNONE
;
7157 if (ffecom_is_altreturning_
)
7158 type
= ffecom_tree_subr_type
;
7160 type
= ffecom_tree_fun_type_void
;
7166 assert ("say what??" == NULL
);
7168 case FFEINFO_kindANY
:
7169 gt
= FFEGLOBAL_typeANY
;
7170 bt
= FFEINFO_basictypeNONE
;
7171 kt
= FFEINFO_kindtypeNONE
;
7172 type
= error_mark_node
;
7180 id
= ffecom_get_invented_identifier ("__g77_masterfun_%s",
7181 ffesymbol_text (fn
));
7183 #if FFETARGET_isENFORCED_MAIN
7184 else if (main_program
)
7185 id
= get_identifier (FFETARGET_nameENFORCED_MAIN_NAME
);
7188 id
= ffecom_get_external_identifier_ (fn
);
7192 0, /* nested/inline */
7193 !altentries
); /* TREE_PUBLIC */
7195 TREE_USED (current_function_decl
) = 1; /* Avoid spurious warning if altentries. */
7198 && ((g
= ffesymbol_global (fn
)) != NULL
)
7199 && ((ffeglobal_type (g
) == gt
)
7200 || (ffeglobal_type (g
) == egt
)))
7202 ffeglobal_set_hook (g
, current_function_decl
);
7205 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7206 exec-transitioning needs current_function_decl to be filled in. So we
7207 do these things in two phases. */
7210 { /* 1st arg identifies which entrypoint. */
7211 ffecom_which_entrypoint_decl_
7212 = build_decl (PARM_DECL
,
7213 ffecom_get_invented_identifier ("__g77_%s",
7214 "which_entrypoint"),
7216 push_parm_decl (ffecom_which_entrypoint_decl_
);
7222 { /* Arg for result (return value). */
7227 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
7229 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
7231 type
= ffecom_multi_type_node_
;
7233 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
7235 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7238 length
= ffecom_char_enhance_arg_ (&type
, fn
);
7240 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
7242 type
= build_pointer_type (type
);
7243 result
= build_decl (PARM_DECL
, result
, type
);
7245 push_parm_decl (result
);
7247 ffecom_multi_retval_
= result
;
7249 ffecom_func_result_
= result
;
7253 push_parm_decl (length
);
7254 ffecom_func_length_
= length
;
7258 if (ffecom_primary_entry_is_proc_
)
7261 arglist
= ffecom_master_arglist_
;
7263 arglist
= ffesymbol_dummyargs (fn
);
7264 ffecom_push_dummy_decls_ (arglist
, FALSE
);
7267 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
7268 store_parm_decls (main_program
? 1 : 0);
7270 ffecom_start_compstmt ();
7271 /* Disallow temp vars at this level. */
7272 current_binding_level
->prep_state
= 2;
7274 lineno
= old_lineno
;
7275 input_filename
= old_input_filename
;
7277 /* This handles any symbols still untransformed, in case -g specified.
7278 This used to be done in ffecom_finish_progunit, but it turns out to
7279 be necessary to do it here so that statement functions are
7280 expanded before code. But don't bother for BLOCK DATA. */
7282 if (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
7283 ffesymbol_drive (ffecom_finish_symbol_transform_
);
7286 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7289 ffecom_sym_transform_(s);
7291 The ffesymbol_hook info for s is updated with appropriate backend info
7295 ffecom_sym_transform_ (ffesymbol s
)
7297 tree t
; /* Transformed thingy. */
7298 tree tlen
; /* Length if CHAR*(*). */
7299 bool addr
; /* Is t the address of the thingy? */
7300 ffeinfoBasictype bt
;
7303 int old_lineno
= lineno
;
7304 const char *old_input_filename
= input_filename
;
7306 /* Must ensure special ASSIGN variables are declared at top of outermost
7307 block, else they'll end up in the innermost block when their first
7308 ASSIGN is seen, which leaves them out of scope when they're the
7309 subject of a GOTO or I/O statement.
7311 We make this variable even if -fugly-assign. Just let it go unused,
7312 in case it turns out there are cases where we really want to use this
7313 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7315 if (! ffecom_transform_only_dummies_
7316 && ffesymbol_assigned (s
)
7317 && ! ffesymbol_hook (s
).assign_tree
)
7318 s
= ffecom_sym_transform_assign_ (s
);
7320 if (ffesymbol_sfdummyparent (s
) == NULL
)
7322 input_filename
= ffesymbol_where_filename (s
);
7323 lineno
= ffesymbol_where_filelinenum (s
);
7327 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
7329 input_filename
= ffesymbol_where_filename (sf
);
7330 lineno
= ffesymbol_where_filelinenum (sf
);
7333 bt
= ffeinfo_basictype (ffebld_info (s
));
7334 kt
= ffeinfo_kindtype (ffebld_info (s
));
7340 switch (ffesymbol_kind (s
))
7342 case FFEINFO_kindNONE
:
7343 switch (ffesymbol_where (s
))
7345 case FFEINFO_whereDUMMY
: /* Subroutine or function. */
7346 assert (ffecom_transform_only_dummies_
);
7348 /* Before 0.4, this could be ENTITY/DUMMY, but see
7349 ffestu_sym_end_transition -- no longer true (in particular, if
7350 it could be an ENTITY, it _will_ be made one, so that
7351 possibility won't come through here). So we never make length
7352 arg for CHARACTER type. */
7354 t
= build_decl (PARM_DECL
,
7355 ffecom_get_identifier_ (ffesymbol_text (s
)),
7356 ffecom_tree_ptr_to_subr_type
);
7357 DECL_ARTIFICIAL (t
) = 1;
7361 case FFEINFO_whereGLOBAL
: /* Subroutine or function. */
7362 assert (!ffecom_transform_only_dummies_
);
7364 if (((g
= ffesymbol_global (s
)) != NULL
)
7365 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
7366 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7367 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
7368 && (ffeglobal_hook (g
) != NULL_TREE
)
7369 && ffe_is_globals ())
7371 t
= ffeglobal_hook (g
);
7375 t
= build_decl (FUNCTION_DECL
,
7376 ffecom_get_external_identifier_ (s
),
7377 ffecom_tree_subr_type
); /* Assume subr. */
7378 DECL_EXTERNAL (t
) = 1;
7379 TREE_PUBLIC (t
) = 1;
7381 t
= start_decl (t
, FALSE
);
7382 finish_decl (t
, NULL_TREE
, FALSE
);
7385 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
7386 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7387 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
7388 ffeglobal_set_hook (g
, t
);
7390 ffecom_save_tree_forever (t
);
7395 assert ("NONE where unexpected" == NULL
);
7397 case FFEINFO_whereANY
:
7402 case FFEINFO_kindENTITY
:
7403 switch (ffeinfo_where (ffesymbol_info (s
)))
7406 case FFEINFO_whereCONSTANT
:
7407 /* ~~Debugging info needed? */
7408 assert (!ffecom_transform_only_dummies_
);
7409 t
= error_mark_node
; /* Shouldn't ever see this in expr. */
7412 case FFEINFO_whereLOCAL
:
7413 assert (!ffecom_transform_only_dummies_
);
7416 ffestorag st
= ffesymbol_storage (s
);
7420 && (ffestorag_size (st
) == 0))
7422 t
= error_mark_node
;
7426 type
= ffecom_type_localvar_ (s
, bt
, kt
);
7428 if (type
== error_mark_node
)
7430 t
= error_mark_node
;
7435 && (ffestorag_parent (st
) != NULL
))
7436 { /* Child of EQUIVALENCE parent. */
7439 ffetargetOffset offset
;
7441 est
= ffestorag_parent (st
);
7442 ffecom_transform_equiv_ (est
);
7444 et
= ffestorag_hook (est
);
7445 assert (et
!= NULL_TREE
);
7447 if (! TREE_STATIC (et
))
7448 put_var_into_stack (et
);
7450 offset
= ffestorag_modulo (est
)
7451 + ffestorag_offset (ffesymbol_storage (s
))
7452 - ffestorag_offset (est
);
7454 ffecom_debug_kludge_ (et
, "EQUIVALENCE", s
, type
, offset
);
7456 /* (t_type *) (((char *) &et) + offset) */
7458 t
= convert (string_type_node
, /* (char *) */
7459 ffecom_1 (ADDR_EXPR
,
7460 build_pointer_type (TREE_TYPE (et
)),
7462 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
7464 build_int_2 (offset
, 0));
7465 t
= convert (build_pointer_type (type
),
7467 TREE_CONSTANT (t
) = staticp (et
);
7474 bool init
= ffesymbol_is_init (s
);
7476 t
= build_decl (VAR_DECL
,
7477 ffecom_get_identifier_ (ffesymbol_text (s
)),
7481 || ffesymbol_namelisted (s
)
7482 #ifdef FFECOM_sizeMAXSTACKITEM
7484 && (ffestorag_size (st
) > FFECOM_sizeMAXSTACKITEM
))
7486 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
7487 && (ffecom_primary_entry_kind_
7488 != FFEINFO_kindBLOCKDATA
)
7489 && (ffesymbol_is_save (s
) || ffe_is_saveall ())))
7490 TREE_STATIC (t
) = !ffesymbol_attr (s
, FFESYMBOL_attrADJUSTABLE
);
7492 TREE_STATIC (t
) = 0; /* No need to make static. */
7494 if (init
|| ffe_is_init_local_zero ())
7495 DECL_INITIAL (t
) = error_mark_node
;
7497 /* Keep -Wunused from complaining about var if it
7498 is used as sfunc arg or DATA implied-DO. */
7499 if (ffesymbol_attrs (s
) & FFESYMBOL_attrsSFARG
)
7500 DECL_IN_SYSTEM_HEADER (t
) = 1;
7502 t
= start_decl (t
, FALSE
);
7506 if (ffesymbol_init (s
) != NULL
)
7507 initexpr
= ffecom_expr (ffesymbol_init (s
));
7509 initexpr
= ffecom_init_zero_ (t
);
7511 else if (ffe_is_init_local_zero ())
7512 initexpr
= ffecom_init_zero_ (t
);
7514 initexpr
= NULL_TREE
; /* Not ref'd if !init. */
7516 finish_decl (t
, initexpr
, FALSE
);
7518 if (st
!= NULL
&& DECL_SIZE (t
) != error_mark_node
)
7520 assert (TREE_CODE (DECL_SIZE_UNIT (t
)) == INTEGER_CST
);
7521 assert (0 == compare_tree_int (DECL_SIZE_UNIT (t
),
7522 ffestorag_size (st
)));
7528 case FFEINFO_whereRESULT
:
7529 assert (!ffecom_transform_only_dummies_
);
7531 if (bt
== FFEINFO_basictypeCHARACTER
)
7532 { /* Result is already in list of dummies, use
7534 t
= ffecom_func_result_
;
7535 tlen
= ffecom_func_length_
;
7539 if ((ffecom_num_entrypoints_
== 0)
7540 && (bt
== FFEINFO_basictypeCOMPLEX
)
7541 && (ffesymbol_is_f2c (ffecom_primary_entry_
)))
7542 { /* Result is already in list of dummies, use
7544 t
= ffecom_func_result_
;
7548 if (ffecom_func_result_
!= NULL_TREE
)
7550 t
= ffecom_func_result_
;
7553 if ((ffecom_num_entrypoints_
!= 0)
7554 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
))
7556 assert (ffecom_multi_retval_
!= NULL_TREE
);
7557 t
= ffecom_1 (INDIRECT_REF
, ffecom_multi_type_node_
,
7558 ffecom_multi_retval_
);
7559 t
= ffecom_2 (COMPONENT_REF
, ffecom_tree_type
[bt
][kt
],
7560 t
, ffecom_multi_fields_
[bt
][kt
]);
7565 t
= build_decl (VAR_DECL
,
7566 ffecom_get_identifier_ (ffesymbol_text (s
)),
7567 ffecom_tree_type
[bt
][kt
]);
7568 TREE_STATIC (t
) = 0; /* Put result on stack. */
7569 t
= start_decl (t
, FALSE
);
7570 finish_decl (t
, NULL_TREE
, FALSE
);
7572 ffecom_func_result_
= t
;
7576 case FFEINFO_whereDUMMY
:
7584 bool adjustable
= FALSE
; /* Conditionally adjustable? */
7586 type
= ffecom_tree_type
[bt
][kt
];
7587 if (ffesymbol_sfdummyparent (s
) != NULL
)
7589 if (current_function_decl
== ffecom_outer_function_decl_
)
7590 { /* Exec transition before sfunc
7591 context; get it later. */
7594 t
= ffecom_get_identifier_ (ffesymbol_text
7595 (ffesymbol_sfdummyparent (s
)));
7598 t
= ffecom_get_identifier_ (ffesymbol_text (s
));
7600 assert (ffecom_transform_only_dummies_
);
7602 old_sizes
= get_pending_sizes ();
7603 put_pending_sizes (old_sizes
);
7605 if (bt
== FFEINFO_basictypeCHARACTER
)
7606 tlen
= ffecom_char_enhance_arg_ (&type
, s
);
7607 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
7609 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
7611 if (type
== error_mark_node
)
7614 dim
= ffebld_head (dl
);
7615 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
7616 if ((ffebld_left (dim
) == NULL
) || ffecom_doing_entry_
)
7617 low
= ffecom_integer_one_node
;
7619 low
= ffecom_expr (ffebld_left (dim
));
7620 assert (ffebld_right (dim
) != NULL
);
7621 if ((ffebld_op (ffebld_right (dim
)) == FFEBLD_opSTAR
)
7622 || ffecom_doing_entry_
)
7624 /* Used to just do high=low. But for ffecom_tree_
7625 canonize_ref_, it probably is important to correctly
7626 assess the size. E.g. given COMPLEX C(*),CFUNC and
7627 C(2)=CFUNC(C), overlap can happen, while it can't
7628 for, say, C(1)=CFUNC(C(2)). */
7629 /* Even more recently used to set to INT_MAX, but that
7630 broke when some overflow checking went into the back
7631 end. Now we just leave the upper bound unspecified. */
7635 high
= ffecom_expr (ffebld_right (dim
));
7637 /* Determine whether array is conditionally adjustable,
7638 to decide whether back-end magic is needed.
7640 Normally the front end uses the back-end function
7641 variable_size to wrap SAVE_EXPR's around expressions
7642 affecting the size/shape of an array so that the
7643 size/shape info doesn't change during execution
7644 of the compiled code even though variables and
7645 functions referenced in those expressions might.
7647 variable_size also makes sure those saved expressions
7648 get evaluated immediately upon entry to the
7649 compiled procedure -- the front end normally doesn't
7650 have to worry about that.
7652 However, there is a problem with this that affects
7653 g77's implementation of entry points, and that is
7654 that it is _not_ true that each invocation of the
7655 compiled procedure is permitted to evaluate
7656 array size/shape info -- because it is possible
7657 that, for some invocations, that info is invalid (in
7658 which case it is "promised" -- i.e. a violation of
7659 the Fortran standard -- that the compiled code
7660 won't reference the array or its size/shape
7661 during that particular invocation).
7663 To phrase this in C terms, consider this gcc function:
7665 void foo (int *n, float (*a)[*n])
7667 // a is "pointer to array ...", fyi.
7670 Suppose that, for some invocations, it is permitted
7671 for a caller of foo to do this:
7675 Now the _written_ code for foo can take such a call
7676 into account by either testing explicitly for whether
7677 (a == NULL) || (n == NULL) -- presumably it is
7678 not permitted to reference *a in various fashions
7679 if (n == NULL) I suppose -- or it can avoid it by
7680 looking at other info (other arguments, static/global
7683 However, this won't work in gcc 2.5.8 because it'll
7684 automatically emit the code to save the "*n"
7685 expression, which'll yield a NULL dereference for
7686 the "foo (NULL, NULL)" call, something the code
7687 for foo cannot prevent.
7689 g77 definitely needs to avoid executing such
7690 code anytime the pointer to the adjustable array
7691 is NULL, because even if its bounds expressions
7692 don't have any references to possible "absent"
7693 variables like "*n" -- say all variable references
7694 are to COMMON variables, i.e. global (though in C,
7695 local static could actually make sense) -- the
7696 expressions could yield other run-time problems
7697 for allowably "dead" values in those variables.
7699 For example, let's consider a more complicated
7705 void foo (float (*a)[i/j])
7710 The above is (essentially) quite valid for Fortran
7711 but, again, for a call like "foo (NULL);", it is
7712 permitted for i and j to be undefined when the
7713 call is made. If j happened to be zero, for
7714 example, emitting the code to evaluate "i/j"
7715 could result in a run-time error.
7717 Offhand, though I don't have my F77 or F90
7718 standards handy, it might even be valid for a
7719 bounds expression to contain a function reference,
7720 in which case I doubt it is permitted for an
7721 implementation to invoke that function in the
7722 Fortran case involved here (invocation of an
7723 alternate ENTRY point that doesn't have the adjustable
7724 array as one of its arguments).
7726 So, the code that the compiler would normally emit
7727 to preevaluate the size/shape info for an
7728 adjustable array _must not_ be executed at run time
7729 in certain cases. Specifically, for Fortran,
7730 the case is when the pointer to the adjustable
7731 array == NULL. (For gnu-ish C, it might be nice
7732 for the source code itself to specify an expression
7733 that, if TRUE, inhibits execution of the code. Or
7734 reverse the sense for elegance.)
7736 (Note that g77 could use a different test than NULL,
7737 actually, since it happens to always pass an
7738 integer to the called function that specifies which
7739 entry point is being invoked. Hmm, this might
7740 solve the next problem.)
7742 One way a user could, I suppose, write "foo" so
7743 it works is to insert COND_EXPR's for the
7744 size/shape info so the dangerous stuff isn't
7745 actually done, as in:
7747 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7752 The next problem is that the front end needs to
7753 be able to tell the back end about the array's
7754 decl _before_ it tells it about the conditional
7755 expression to inhibit evaluation of size/shape info,
7758 To solve this, the front end needs to be able
7759 to give the back end the expression to inhibit
7760 generation of the preevaluation code _after_
7761 it makes the decl for the adjustable array.
7763 Until then, the above example using the COND_EXPR
7764 doesn't pass muster with gcc because the "(a == NULL)"
7765 part has a reference to "a", which is still
7766 undefined at that point.
7768 g77 will therefore use a different mechanism in the
7772 && ((TREE_CODE (low
) != INTEGER_CST
)
7773 || (high
&& TREE_CODE (high
) != INTEGER_CST
)))
7776 #if 0 /* Old approach -- see below. */
7777 if (TREE_CODE (low
) != INTEGER_CST
)
7778 low
= ffecom_3 (COND_EXPR
, integer_type_node
,
7779 ffecom_adjarray_passed_ (s
),
7781 ffecom_integer_zero_node
);
7783 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
7784 high
= ffecom_3 (COND_EXPR
, integer_type_node
,
7785 ffecom_adjarray_passed_ (s
),
7787 ffecom_integer_zero_node
);
7790 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7791 probably. Fixes 950302-1.f. */
7793 if (TREE_CODE (low
) != INTEGER_CST
)
7794 low
= variable_size (low
);
7796 /* ~~~Similarly, this fixes dumb0.f. The C front end
7797 does this, which is why dumb0.c would work. */
7799 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
7800 high
= variable_size (high
);
7805 build_range_type (ffecom_integer_type_node
,
7807 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
7810 if (type
== error_mark_node
)
7812 t
= error_mark_node
;
7816 if ((ffesymbol_sfdummyparent (s
) == NULL
)
7817 || (ffesymbol_basictype (s
) == FFEINFO_basictypeCHARACTER
))
7819 type
= build_pointer_type (type
);
7823 t
= build_decl (PARM_DECL
, t
, type
);
7824 DECL_ARTIFICIAL (t
) = 1;
7826 /* If this arg is present in every entry point's list of
7827 dummy args, then we're done. */
7829 if (ffesymbol_numentries (s
)
7830 == (ffecom_num_entrypoints_
+ 1))
7835 /* If variable_size in stor-layout has been called during
7836 the above, then get_pending_sizes should have the
7837 yet-to-be-evaluated saved expressions pending.
7838 Make the whole lot of them get emitted, conditionally
7839 on whether the array decl ("t" above) is not NULL. */
7842 tree sizes
= get_pending_sizes ();
7847 tem
= TREE_CHAIN (tem
))
7849 tree temv
= TREE_VALUE (tem
);
7855 = ffecom_2 (COMPOUND_EXPR
,
7864 = ffecom_3 (COND_EXPR
,
7871 convert (TREE_TYPE (sizes
),
7872 integer_zero_node
));
7873 sizes
= ffecom_save_tree (sizes
);
7876 = tree_cons (NULL_TREE
, sizes
, tem
);
7880 put_pending_sizes (sizes
);
7886 && (ffesymbol_numentries (s
)
7887 != ffecom_num_entrypoints_
+ 1))
7889 = ffecom_2 (NE_EXPR
, integer_type_node
,
7895 && (ffesymbol_numentries (s
)
7896 != ffecom_num_entrypoints_
+ 1))
7898 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED
);
7899 ffebad_here (0, ffesymbol_where_line (s
),
7900 ffesymbol_where_column (s
));
7901 ffebad_string (ffesymbol_text (s
));
7910 case FFEINFO_whereCOMMON
:
7915 ffestorag st
= ffesymbol_storage (s
);
7918 cs
= ffesymbol_common (s
); /* The COMMON area itself. */
7919 if (st
!= NULL
) /* Else not laid out. */
7921 ffecom_transform_common_ (cs
);
7922 st
= ffesymbol_storage (s
);
7925 type
= ffecom_type_localvar_ (s
, bt
, kt
);
7927 cg
= ffesymbol_global (cs
); /* The global COMMON info. */
7929 || (ffeglobal_type (cg
) != FFEGLOBAL_typeCOMMON
))
7932 ct
= ffeglobal_hook (cg
); /* The common area's tree. */
7934 if ((ct
== NULL_TREE
)
7936 || (type
== error_mark_node
))
7937 t
= error_mark_node
;
7940 ffetargetOffset offset
;
7943 cst
= ffestorag_parent (st
);
7944 assert (cst
== ffesymbol_storage (cs
));
7946 offset
= ffestorag_modulo (cst
)
7947 + ffestorag_offset (st
)
7948 - ffestorag_offset (cst
);
7950 ffecom_debug_kludge_ (ct
, "COMMON", s
, type
, offset
);
7952 /* (t_type *) (((char *) &ct) + offset) */
7954 t
= convert (string_type_node
, /* (char *) */
7955 ffecom_1 (ADDR_EXPR
,
7956 build_pointer_type (TREE_TYPE (ct
)),
7958 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
7960 build_int_2 (offset
, 0));
7961 t
= convert (build_pointer_type (type
),
7963 TREE_CONSTANT (t
) = 1;
7970 case FFEINFO_whereIMMEDIATE
:
7971 case FFEINFO_whereGLOBAL
:
7972 case FFEINFO_whereFLEETING
:
7973 case FFEINFO_whereFLEETING_CADDR
:
7974 case FFEINFO_whereFLEETING_IADDR
:
7975 case FFEINFO_whereINTRINSIC
:
7976 case FFEINFO_whereCONSTANT_SUBOBJECT
:
7978 assert ("ENTITY where unheard of" == NULL
);
7980 case FFEINFO_whereANY
:
7981 t
= error_mark_node
;
7986 case FFEINFO_kindFUNCTION
:
7987 switch (ffeinfo_where (ffesymbol_info (s
)))
7989 case FFEINFO_whereLOCAL
: /* Me. */
7990 assert (!ffecom_transform_only_dummies_
);
7991 t
= current_function_decl
;
7994 case FFEINFO_whereGLOBAL
:
7995 assert (!ffecom_transform_only_dummies_
);
7997 if (((g
= ffesymbol_global (s
)) != NULL
)
7998 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7999 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8000 && (ffeglobal_hook (g
) != NULL_TREE
)
8001 && ffe_is_globals ())
8003 t
= ffeglobal_hook (g
);
8007 if (ffesymbol_is_f2c (s
)
8008 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8009 t
= ffecom_tree_fun_type
[bt
][kt
];
8011 t
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
8013 t
= build_decl (FUNCTION_DECL
,
8014 ffecom_get_external_identifier_ (s
),
8016 DECL_EXTERNAL (t
) = 1;
8017 TREE_PUBLIC (t
) = 1;
8019 t
= start_decl (t
, FALSE
);
8020 finish_decl (t
, NULL_TREE
, FALSE
);
8023 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8024 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8025 ffeglobal_set_hook (g
, t
);
8027 ffecom_save_tree_forever (t
);
8031 case FFEINFO_whereDUMMY
:
8032 assert (ffecom_transform_only_dummies_
);
8034 if (ffesymbol_is_f2c (s
)
8035 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8036 t
= ffecom_tree_ptr_to_fun_type
[bt
][kt
];
8038 t
= build_pointer_type
8039 (build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
));
8041 t
= build_decl (PARM_DECL
,
8042 ffecom_get_identifier_ (ffesymbol_text (s
)),
8044 DECL_ARTIFICIAL (t
) = 1;
8048 case FFEINFO_whereCONSTANT
: /* Statement function. */
8049 assert (!ffecom_transform_only_dummies_
);
8050 t
= ffecom_gen_sfuncdef_ (s
, bt
, kt
);
8053 case FFEINFO_whereINTRINSIC
:
8054 assert (!ffecom_transform_only_dummies_
);
8055 break; /* Let actual references generate their
8059 assert ("FUNCTION where unheard of" == NULL
);
8061 case FFEINFO_whereANY
:
8062 t
= error_mark_node
;
8067 case FFEINFO_kindSUBROUTINE
:
8068 switch (ffeinfo_where (ffesymbol_info (s
)))
8070 case FFEINFO_whereLOCAL
: /* Me. */
8071 assert (!ffecom_transform_only_dummies_
);
8072 t
= current_function_decl
;
8075 case FFEINFO_whereGLOBAL
:
8076 assert (!ffecom_transform_only_dummies_
);
8078 if (((g
= ffesymbol_global (s
)) != NULL
)
8079 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8080 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8081 && (ffeglobal_hook (g
) != NULL_TREE
)
8082 && ffe_is_globals ())
8084 t
= ffeglobal_hook (g
);
8088 t
= build_decl (FUNCTION_DECL
,
8089 ffecom_get_external_identifier_ (s
),
8090 ffecom_tree_subr_type
);
8091 DECL_EXTERNAL (t
) = 1;
8092 TREE_PUBLIC (t
) = 1;
8094 t
= start_decl (t
, FALSE
);
8095 finish_decl (t
, NULL_TREE
, FALSE
);
8098 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8099 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8100 ffeglobal_set_hook (g
, t
);
8102 ffecom_save_tree_forever (t
);
8106 case FFEINFO_whereDUMMY
:
8107 assert (ffecom_transform_only_dummies_
);
8109 t
= build_decl (PARM_DECL
,
8110 ffecom_get_identifier_ (ffesymbol_text (s
)),
8111 ffecom_tree_ptr_to_subr_type
);
8112 DECL_ARTIFICIAL (t
) = 1;
8116 case FFEINFO_whereINTRINSIC
:
8117 assert (!ffecom_transform_only_dummies_
);
8118 break; /* Let actual references generate their
8122 assert ("SUBROUTINE where unheard of" == NULL
);
8124 case FFEINFO_whereANY
:
8125 t
= error_mark_node
;
8130 case FFEINFO_kindPROGRAM
:
8131 switch (ffeinfo_where (ffesymbol_info (s
)))
8133 case FFEINFO_whereLOCAL
: /* Me. */
8134 assert (!ffecom_transform_only_dummies_
);
8135 t
= current_function_decl
;
8138 case FFEINFO_whereCOMMON
:
8139 case FFEINFO_whereDUMMY
:
8140 case FFEINFO_whereGLOBAL
:
8141 case FFEINFO_whereRESULT
:
8142 case FFEINFO_whereFLEETING
:
8143 case FFEINFO_whereFLEETING_CADDR
:
8144 case FFEINFO_whereFLEETING_IADDR
:
8145 case FFEINFO_whereIMMEDIATE
:
8146 case FFEINFO_whereINTRINSIC
:
8147 case FFEINFO_whereCONSTANT
:
8148 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8150 assert ("PROGRAM where unheard of" == NULL
);
8152 case FFEINFO_whereANY
:
8153 t
= error_mark_node
;
8158 case FFEINFO_kindBLOCKDATA
:
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_whereGLOBAL
:
8167 assert (!ffecom_transform_only_dummies_
);
8169 t
= build_decl (FUNCTION_DECL
,
8170 ffecom_get_external_identifier_ (s
),
8171 ffecom_tree_blockdata_type
);
8172 DECL_EXTERNAL (t
) = 1;
8173 TREE_PUBLIC (t
) = 1;
8175 t
= start_decl (t
, FALSE
);
8176 finish_decl (t
, NULL_TREE
, FALSE
);
8178 ffecom_save_tree_forever (t
);
8182 case FFEINFO_whereCOMMON
:
8183 case FFEINFO_whereDUMMY
:
8184 case FFEINFO_whereRESULT
:
8185 case FFEINFO_whereFLEETING
:
8186 case FFEINFO_whereFLEETING_CADDR
:
8187 case FFEINFO_whereFLEETING_IADDR
:
8188 case FFEINFO_whereIMMEDIATE
:
8189 case FFEINFO_whereINTRINSIC
:
8190 case FFEINFO_whereCONSTANT
:
8191 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8193 assert ("BLOCKDATA where unheard of" == NULL
);
8195 case FFEINFO_whereANY
:
8196 t
= error_mark_node
;
8201 case FFEINFO_kindCOMMON
:
8202 switch (ffeinfo_where (ffesymbol_info (s
)))
8204 case FFEINFO_whereLOCAL
:
8205 assert (!ffecom_transform_only_dummies_
);
8206 ffecom_transform_common_ (s
);
8209 case FFEINFO_whereNONE
:
8210 case FFEINFO_whereCOMMON
:
8211 case FFEINFO_whereDUMMY
:
8212 case FFEINFO_whereGLOBAL
:
8213 case FFEINFO_whereRESULT
:
8214 case FFEINFO_whereFLEETING
:
8215 case FFEINFO_whereFLEETING_CADDR
:
8216 case FFEINFO_whereFLEETING_IADDR
:
8217 case FFEINFO_whereIMMEDIATE
:
8218 case FFEINFO_whereINTRINSIC
:
8219 case FFEINFO_whereCONSTANT
:
8220 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8222 assert ("COMMON where unheard of" == NULL
);
8224 case FFEINFO_whereANY
:
8225 t
= error_mark_node
;
8230 case FFEINFO_kindCONSTRUCT
:
8231 switch (ffeinfo_where (ffesymbol_info (s
)))
8233 case FFEINFO_whereLOCAL
:
8234 assert (!ffecom_transform_only_dummies_
);
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 ("CONSTRUCT where unheard of" == NULL
);
8252 case FFEINFO_whereANY
:
8253 t
= error_mark_node
;
8258 case FFEINFO_kindNAMELIST
:
8259 switch (ffeinfo_where (ffesymbol_info (s
)))
8261 case FFEINFO_whereLOCAL
:
8262 assert (!ffecom_transform_only_dummies_
);
8263 t
= ffecom_transform_namelist_ (s
);
8266 case FFEINFO_whereNONE
:
8267 case FFEINFO_whereCOMMON
:
8268 case FFEINFO_whereDUMMY
:
8269 case FFEINFO_whereGLOBAL
:
8270 case FFEINFO_whereRESULT
:
8271 case FFEINFO_whereFLEETING
:
8272 case FFEINFO_whereFLEETING_CADDR
:
8273 case FFEINFO_whereFLEETING_IADDR
:
8274 case FFEINFO_whereIMMEDIATE
:
8275 case FFEINFO_whereINTRINSIC
:
8276 case FFEINFO_whereCONSTANT
:
8277 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8279 assert ("NAMELIST where unheard of" == NULL
);
8281 case FFEINFO_whereANY
:
8282 t
= error_mark_node
;
8288 assert ("kind unheard of" == NULL
);
8290 case FFEINFO_kindANY
:
8291 t
= error_mark_node
;
8295 ffesymbol_hook (s
).decl_tree
= t
;
8296 ffesymbol_hook (s
).length_tree
= tlen
;
8297 ffesymbol_hook (s
).addr
= addr
;
8299 lineno
= old_lineno
;
8300 input_filename
= old_input_filename
;
8305 /* Transform into ASSIGNable symbol.
8307 Symbol has already been transformed, but for whatever reason, the
8308 resulting decl_tree has been deemed not usable for an ASSIGN target.
8309 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8310 another local symbol of type void * and stuff that in the assign_tree
8311 argument. The F77/F90 standards allow this implementation. */
8314 ffecom_sym_transform_assign_ (ffesymbol s
)
8316 tree t
; /* Transformed thingy. */
8317 int old_lineno
= lineno
;
8318 const char *old_input_filename
= input_filename
;
8320 if (ffesymbol_sfdummyparent (s
) == NULL
)
8322 input_filename
= ffesymbol_where_filename (s
);
8323 lineno
= ffesymbol_where_filelinenum (s
);
8327 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
8329 input_filename
= ffesymbol_where_filename (sf
);
8330 lineno
= ffesymbol_where_filelinenum (sf
);
8333 assert (!ffecom_transform_only_dummies_
);
8335 t
= build_decl (VAR_DECL
,
8336 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8337 ffesymbol_text (s
)),
8338 TREE_TYPE (null_pointer_node
));
8340 switch (ffesymbol_where (s
))
8342 case FFEINFO_whereLOCAL
:
8343 /* Unlike for regular vars, SAVE status is easy to determine for
8344 ASSIGNed vars, since there's no initialization, there's no
8345 effective storage association (so "SAVE J" does not apply to
8346 K even given "EQUIVALENCE (J,K)"), there's no size issue
8347 to worry about, etc. */
8348 if ((ffesymbol_is_save (s
) || ffe_is_saveall ())
8349 && (ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8350 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
))
8351 TREE_STATIC (t
) = 1; /* SAVEd in proc, make static. */
8353 TREE_STATIC (t
) = 0; /* No need to make static. */
8356 case FFEINFO_whereCOMMON
:
8357 TREE_STATIC (t
) = 1; /* Assume COMMONs always SAVEd. */
8360 case FFEINFO_whereDUMMY
:
8361 /* Note that twinning a DUMMY means the caller won't see
8362 the ASSIGNed value. But both F77 and F90 allow implementations
8363 to do this, i.e. disallow Fortran code that would try and
8364 take advantage of actually putting a label into a variable
8365 via a dummy argument (or any other storage association, for
8367 TREE_STATIC (t
) = 0;
8371 TREE_STATIC (t
) = 0;
8375 t
= start_decl (t
, FALSE
);
8376 finish_decl (t
, NULL_TREE
, FALSE
);
8378 ffesymbol_hook (s
).assign_tree
= t
;
8380 lineno
= old_lineno
;
8381 input_filename
= old_input_filename
;
8386 /* Implement COMMON area in back end.
8388 Because COMMON-based variables can be referenced in the dimension
8389 expressions of dummy (adjustable) arrays, and because dummies
8390 (in the gcc back end) need to be put in the outer binding level
8391 of a function (which has two binding levels, the outer holding
8392 the dummies and the inner holding the other vars), special care
8393 must be taken to handle COMMON areas.
8395 The current strategy is basically to always tell the back end about
8396 the COMMON area as a top-level external reference to just a block
8397 of storage of the master type of that area (e.g. integer, real,
8398 character, whatever -- not a structure). As a distinct action,
8399 if initial values are provided, tell the back end about the area
8400 as a top-level non-external (initialized) area and remember not to
8401 allow further initialization or expansion of the area. Meanwhile,
8402 if no initialization happens at all, tell the back end about
8403 the largest size we've seen declared so the space does get reserved.
8404 (This function doesn't handle all that stuff, but it does some
8405 of the important things.)
8407 Meanwhile, for COMMON variables themselves, just keep creating
8408 references like *((float *) (&common_area + offset)) each time
8409 we reference the variable. In other words, don't make a VAR_DECL
8410 or any kind of component reference (like we used to do before 0.4),
8411 though we might do that as well just for debugging purposes (and
8412 stuff the rtl with the appropriate offset expression). */
8415 ffecom_transform_common_ (ffesymbol s
)
8417 ffestorag st
= ffesymbol_storage (s
);
8418 ffeglobal g
= ffesymbol_global (s
);
8423 bool is_init
= ffestorag_is_init (st
);
8425 assert (st
!= NULL
);
8428 || (ffeglobal_type (g
) != FFEGLOBAL_typeCOMMON
))
8431 /* First update the size of the area in global terms. */
8433 ffeglobal_size_common (s
, ffestorag_size (st
));
8435 if (!ffeglobal_common_init (g
))
8436 is_init
= FALSE
; /* No explicit init, don't let erroneous joins init. */
8438 cbt
= ffeglobal_hook (g
);
8440 /* If we already have declared this common block for a previous program
8441 unit, and either we already initialized it or we don't have new
8442 initialization for it, just return what we have without changing it. */
8444 if ((cbt
!= NULL_TREE
)
8446 || !DECL_EXTERNAL (cbt
)))
8448 if (st
->hook
== NULL
) ffestorag_set_hook (st
, cbt
);
8452 /* Process inits. */
8456 if (ffestorag_init (st
) != NULL
)
8460 /* Set the padding for the expression, so ffecom_expr
8461 knows to insert that many zeros. */
8462 switch (ffebld_op (sexp
= ffestorag_init (st
)))
8464 case FFEBLD_opCONTER
:
8465 ffebld_conter_set_pad (sexp
, ffestorag_modulo (st
));
8468 case FFEBLD_opARRTER
:
8469 ffebld_arrter_set_pad (sexp
, ffestorag_modulo (st
));
8472 case FFEBLD_opACCTER
:
8473 ffebld_accter_set_pad (sexp
, ffestorag_modulo (st
));
8477 assert ("bad op for cmn init (pad)" == NULL
);
8481 init
= ffecom_expr (sexp
);
8482 if (init
== error_mark_node
)
8483 { /* Hopefully the back end complained! */
8485 if (cbt
!= NULL_TREE
)
8490 init
= error_mark_node
;
8495 /* cbtype must be permanently allocated! */
8497 /* Allocate the MAX of the areas so far, seen filewide. */
8498 high
= build_int_2 ((ffeglobal_common_size (g
)
8499 + ffeglobal_common_pad (g
)) - 1, 0);
8500 TREE_TYPE (high
) = ffecom_integer_type_node
;
8503 cbtype
= build_array_type (char_type_node
,
8504 build_range_type (integer_type_node
,
8508 cbtype
= build_array_type (char_type_node
, NULL_TREE
);
8510 if (cbt
== NULL_TREE
)
8513 = build_decl (VAR_DECL
,
8514 ffecom_get_external_identifier_ (s
),
8516 TREE_STATIC (cbt
) = 1;
8517 TREE_PUBLIC (cbt
) = 1;
8522 TREE_TYPE (cbt
) = cbtype
;
8524 DECL_EXTERNAL (cbt
) = init
? 0 : 1;
8525 DECL_INITIAL (cbt
) = init
? error_mark_node
: NULL_TREE
;
8527 cbt
= start_decl (cbt
, TRUE
);
8528 if (ffeglobal_hook (g
) != NULL
)
8529 assert (cbt
== ffeglobal_hook (g
));
8531 assert (!init
|| !DECL_EXTERNAL (cbt
));
8533 /* Make sure that any type can live in COMMON and be referenced
8534 without getting a bus error. We could pick the most restrictive
8535 alignment of all entities actually placed in the COMMON, but
8536 this seems easy enough. */
8538 DECL_ALIGN (cbt
) = BIGGEST_ALIGNMENT
;
8539 DECL_USER_ALIGN (cbt
) = 0;
8541 if (is_init
&& (ffestorag_init (st
) == NULL
))
8542 init
= ffecom_init_zero_ (cbt
);
8544 finish_decl (cbt
, init
, TRUE
);
8547 ffestorag_set_init (st
, ffebld_new_any ());
8551 assert (DECL_SIZE_UNIT (cbt
) != NULL_TREE
);
8552 assert (TREE_CODE (DECL_SIZE_UNIT (cbt
)) == INTEGER_CST
);
8553 assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt
),
8554 (ffeglobal_common_size (g
)
8555 + ffeglobal_common_pad (g
))));
8558 ffeglobal_set_hook (g
, cbt
);
8560 ffestorag_set_hook (st
, cbt
);
8562 ffecom_save_tree_forever (cbt
);
8565 /* Make master area for local EQUIVALENCE. */
8568 ffecom_transform_equiv_ (ffestorag eqst
)
8574 bool is_init
= ffestorag_is_init (eqst
);
8576 assert (eqst
!= NULL
);
8578 eqt
= ffestorag_hook (eqst
);
8580 if (eqt
!= NULL_TREE
)
8583 /* Process inits. */
8587 if (ffestorag_init (eqst
) != NULL
)
8591 /* Set the padding for the expression, so ffecom_expr
8592 knows to insert that many zeros. */
8593 switch (ffebld_op (sexp
= ffestorag_init (eqst
)))
8595 case FFEBLD_opCONTER
:
8596 ffebld_conter_set_pad (sexp
, ffestorag_modulo (eqst
));
8599 case FFEBLD_opARRTER
:
8600 ffebld_arrter_set_pad (sexp
, ffestorag_modulo (eqst
));
8603 case FFEBLD_opACCTER
:
8604 ffebld_accter_set_pad (sexp
, ffestorag_modulo (eqst
));
8608 assert ("bad op for eqv init (pad)" == NULL
);
8612 init
= ffecom_expr (sexp
);
8613 if (init
== error_mark_node
)
8614 init
= NULL_TREE
; /* Hopefully the back end complained! */
8617 init
= error_mark_node
;
8619 else if (ffe_is_init_local_zero ())
8620 init
= error_mark_node
;
8624 ffecom_member_namelisted_
= FALSE
;
8625 ffestorag_drive (ffestorag_list_equivs (eqst
),
8626 &ffecom_member_phase1_
,
8629 high
= build_int_2 ((ffestorag_size (eqst
)
8630 + ffestorag_modulo (eqst
)) - 1, 0);
8631 TREE_TYPE (high
) = ffecom_integer_type_node
;
8633 eqtype
= build_array_type (char_type_node
,
8634 build_range_type (ffecom_integer_type_node
,
8635 ffecom_integer_zero_node
,
8638 eqt
= build_decl (VAR_DECL
,
8639 ffecom_get_invented_identifier ("__g77_equiv_%s",
8641 (ffestorag_symbol (eqst
))),
8643 DECL_EXTERNAL (eqt
) = 0;
8645 || ffecom_member_namelisted_
8646 #ifdef FFECOM_sizeMAXSTACKITEM
8647 || (ffestorag_size (eqst
) > FFECOM_sizeMAXSTACKITEM
)
8649 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8650 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
8651 && (ffestorag_is_save (eqst
) || ffe_is_saveall ())))
8652 TREE_STATIC (eqt
) = 1;
8654 TREE_STATIC (eqt
) = 0;
8655 TREE_PUBLIC (eqt
) = 0;
8656 TREE_ADDRESSABLE (eqt
) = 1; /* Ensure non-register allocation */
8657 DECL_CONTEXT (eqt
) = current_function_decl
;
8659 DECL_INITIAL (eqt
) = error_mark_node
;
8661 DECL_INITIAL (eqt
) = NULL_TREE
;
8663 eqt
= start_decl (eqt
, FALSE
);
8665 /* Make sure that any type can live in EQUIVALENCE and be referenced
8666 without getting a bus error. We could pick the most restrictive
8667 alignment of all entities actually placed in the EQUIVALENCE, but
8668 this seems easy enough. */
8670 DECL_ALIGN (eqt
) = BIGGEST_ALIGNMENT
;
8671 DECL_USER_ALIGN (eqt
) = 0;
8673 if ((!is_init
&& ffe_is_init_local_zero ())
8674 || (is_init
&& (ffestorag_init (eqst
) == NULL
)))
8675 init
= ffecom_init_zero_ (eqt
);
8677 finish_decl (eqt
, init
, FALSE
);
8680 ffestorag_set_init (eqst
, ffebld_new_any ());
8683 assert (TREE_CODE (DECL_SIZE_UNIT (eqt
)) == INTEGER_CST
);
8684 assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt
),
8685 (ffestorag_size (eqst
)
8686 + ffestorag_modulo (eqst
))));
8689 ffestorag_set_hook (eqst
, eqt
);
8691 ffestorag_drive (ffestorag_list_equivs (eqst
),
8692 &ffecom_member_phase2_
,
8696 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8699 ffecom_transform_namelist_ (ffesymbol s
)
8702 tree nmltype
= ffecom_type_namelist_ ();
8710 static int mynumber
= 0;
8712 nmlt
= build_decl (VAR_DECL
,
8713 ffecom_get_invented_identifier ("__g77_namelist_%d",
8716 TREE_STATIC (nmlt
) = 1;
8717 DECL_INITIAL (nmlt
) = error_mark_node
;
8719 nmlt
= start_decl (nmlt
, FALSE
);
8721 /* Process inits. */
8723 i
= strlen (ffesymbol_text (s
));
8725 high
= build_int_2 (i
, 0);
8726 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
8728 nameinit
= ffecom_build_f2c_string_ (i
+ 1,
8729 ffesymbol_text (s
));
8730 TREE_TYPE (nameinit
)
8731 = build_type_variant
8734 build_range_type (ffecom_f2c_ftnlen_type_node
,
8735 ffecom_f2c_ftnlen_one_node
,
8738 TREE_CONSTANT (nameinit
) = 1;
8739 TREE_STATIC (nameinit
) = 1;
8740 nameinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (nameinit
)),
8743 varsinit
= ffecom_vardesc_array_ (s
);
8744 varsinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (varsinit
)),
8746 TREE_CONSTANT (varsinit
) = 1;
8747 TREE_STATIC (varsinit
) = 1;
8752 for (i
= 0, b
= ffesymbol_namelist (s
); b
!= NULL
; b
= ffebld_trail (b
))
8755 nvarsinit
= build_int_2 (i
, 0);
8756 TREE_TYPE (nvarsinit
) = integer_type_node
;
8757 TREE_CONSTANT (nvarsinit
) = 1;
8758 TREE_STATIC (nvarsinit
) = 1;
8760 nmlinits
= build_tree_list ((field
= TYPE_FIELDS (nmltype
)), nameinit
);
8761 TREE_CHAIN (nmlinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
8763 TREE_CHAIN (TREE_CHAIN (nmlinits
))
8764 = build_tree_list ((field
= TREE_CHAIN (field
)), nvarsinit
);
8766 nmlinits
= build (CONSTRUCTOR
, nmltype
, NULL_TREE
, nmlinits
);
8767 TREE_CONSTANT (nmlinits
) = 1;
8768 TREE_STATIC (nmlinits
) = 1;
8770 finish_decl (nmlt
, nmlinits
, FALSE
);
8772 nmlt
= ffecom_1 (ADDR_EXPR
, build_pointer_type (nmltype
), nmlt
);
8777 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8778 analyzed on the assumption it is calculating a pointer to be
8779 indirected through. It must return the proper decl and offset,
8780 taking into account different units of measurements for offsets. */
8783 ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
8786 switch (TREE_CODE (t
))
8790 case NON_LVALUE_EXPR
:
8791 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
8795 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
8796 if ((*decl
== NULL_TREE
)
8797 || (*decl
== error_mark_node
))
8800 if (TREE_CODE (TREE_OPERAND (t
, 1)) == INTEGER_CST
)
8802 /* An offset into COMMON. */
8803 *offset
= fold (build (PLUS_EXPR
, TREE_TYPE (*offset
),
8804 *offset
, TREE_OPERAND (t
, 1)));
8805 /* Convert offset (presumably in bytes) into canonical units
8806 (presumably bits). */
8807 *offset
= size_binop (MULT_EXPR
,
8808 convert (bitsizetype
, *offset
),
8809 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t
))));
8812 /* Not a COMMON reference, so an unrecognized pattern. */
8813 *decl
= error_mark_node
;
8818 *offset
= bitsize_zero_node
;
8822 if (TREE_CODE (TREE_OPERAND (t
, 0)) == VAR_DECL
)
8824 /* A reference to COMMON. */
8825 *decl
= TREE_OPERAND (t
, 0);
8826 *offset
= bitsize_zero_node
;
8831 /* Not a COMMON reference, so an unrecognized pattern. */
8832 *decl
= error_mark_node
;
8837 /* Given a tree that is possibly intended for use as an lvalue, return
8838 information representing a canonical view of that tree as a decl, an
8839 offset into that decl, and a size for the lvalue.
8841 If there's no applicable decl, NULL_TREE is returned for the decl,
8842 and the other fields are left undefined.
8844 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8845 is returned for the decl, and the other fields are left undefined.
8847 Otherwise, the decl returned currently is either a VAR_DECL or a
8850 The offset returned is always valid, but of course not necessarily
8851 a constant, and not necessarily converted into the appropriate
8852 type, leaving that up to the caller (so as to avoid that overhead
8853 if the decls being looked at are different anyway).
8855 If the size cannot be determined (e.g. an adjustable array),
8856 an ERROR_MARK node is returned for the size. Otherwise, the
8857 size returned is valid, not necessarily a constant, and not
8858 necessarily converted into the appropriate type as with the
8861 Note that the offset and size expressions are expressed in the
8862 base storage units (usually bits) rather than in the units of
8863 the type of the decl, because two decls with different types
8864 might overlap but with apparently non-overlapping array offsets,
8865 whereas converting the array offsets to consistant offsets will
8866 reveal the overlap. */
8869 ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
8872 /* The default path is to report a nonexistant decl. */
8878 switch (TREE_CODE (t
))
8881 case IDENTIFIER_NODE
:
8890 case TRUNC_DIV_EXPR
:
8892 case FLOOR_DIV_EXPR
:
8893 case ROUND_DIV_EXPR
:
8894 case TRUNC_MOD_EXPR
:
8896 case FLOOR_MOD_EXPR
:
8897 case ROUND_MOD_EXPR
:
8899 case EXACT_DIV_EXPR
:
8900 case FIX_TRUNC_EXPR
:
8902 case FIX_FLOOR_EXPR
:
8903 case FIX_ROUND_EXPR
:
8917 case BIT_ANDTC_EXPR
:
8919 case TRUTH_ANDIF_EXPR
:
8920 case TRUTH_ORIF_EXPR
:
8921 case TRUTH_AND_EXPR
:
8923 case TRUTH_XOR_EXPR
:
8924 case TRUTH_NOT_EXPR
:
8944 *offset
= bitsize_zero_node
;
8945 *size
= TYPE_SIZE (TREE_TYPE (t
));
8950 tree array
= TREE_OPERAND (t
, 0);
8951 tree element
= TREE_OPERAND (t
, 1);
8954 if ((array
== NULL_TREE
)
8955 || (element
== NULL_TREE
))
8957 *decl
= error_mark_node
;
8961 ffecom_tree_canonize_ref_ (decl
, &init_offset
, size
,
8963 if ((*decl
== NULL_TREE
)
8964 || (*decl
== error_mark_node
))
8967 /* Calculate ((element - base) * NBBY) + init_offset. */
8968 *offset
= fold (build (MINUS_EXPR
, TREE_TYPE (element
),
8970 TYPE_MIN_VALUE (TYPE_DOMAIN
8971 (TREE_TYPE (array
)))));
8973 *offset
= size_binop (MULT_EXPR
,
8974 convert (bitsizetype
, *offset
),
8975 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array
))));
8977 *offset
= size_binop (PLUS_EXPR
, init_offset
, *offset
);
8979 *size
= TYPE_SIZE (TREE_TYPE (t
));
8985 /* Most of this code is to handle references to COMMON. And so
8986 far that is useful only for calling library functions, since
8987 external (user) functions might reference common areas. But
8988 even calling an external function, it's worthwhile to decode
8989 COMMON references because if not storing into COMMON, we don't
8990 want COMMON-based arguments to gratuitously force use of a
8993 *size
= TYPE_SIZE (TREE_TYPE (t
));
8995 ffecom_tree_canonize_ptr_ (decl
, offset
,
8996 TREE_OPERAND (t
, 0));
9003 case NON_LVALUE_EXPR
:
9006 case COND_EXPR
: /* More cases than we can handle. */
9008 case REFERENCE_EXPR
:
9009 case PREDECREMENT_EXPR
:
9010 case PREINCREMENT_EXPR
:
9011 case POSTDECREMENT_EXPR
:
9012 case POSTINCREMENT_EXPR
:
9015 *decl
= error_mark_node
;
9020 /* Do divide operation appropriate to type of operands. */
9023 ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
9024 tree dest_tree
, ffebld dest
, bool *dest_used
,
9027 if ((left
== error_mark_node
)
9028 || (right
== error_mark_node
))
9029 return error_mark_node
;
9031 switch (TREE_CODE (tree_type
))
9034 return ffecom_2 (TRUNC_DIV_EXPR
, tree_type
,
9039 if (! optimize_size
)
9040 return ffecom_2 (RDIV_EXPR
, tree_type
,
9046 if (TREE_TYPE (tree_type
)
9047 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9048 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9050 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9052 left
= ffecom_1 (ADDR_EXPR
,
9053 build_pointer_type (TREE_TYPE (left
)),
9055 left
= build_tree_list (NULL_TREE
, left
);
9056 right
= ffecom_1 (ADDR_EXPR
,
9057 build_pointer_type (TREE_TYPE (right
)),
9059 right
= build_tree_list (NULL_TREE
, right
);
9060 TREE_CHAIN (left
) = right
;
9062 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9063 ffecom_gfrt_kindtype (ix
),
9064 ffe_is_f2c_library (),
9067 dest_tree
, dest
, dest_used
,
9068 NULL_TREE
, TRUE
, hook
);
9076 if (TREE_TYPE (TYPE_FIELDS (tree_type
))
9077 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9078 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9080 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9082 left
= ffecom_1 (ADDR_EXPR
,
9083 build_pointer_type (TREE_TYPE (left
)),
9085 left
= build_tree_list (NULL_TREE
, left
);
9086 right
= ffecom_1 (ADDR_EXPR
,
9087 build_pointer_type (TREE_TYPE (right
)),
9089 right
= build_tree_list (NULL_TREE
, right
);
9090 TREE_CHAIN (left
) = right
;
9092 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9093 ffecom_gfrt_kindtype (ix
),
9094 ffe_is_f2c_library (),
9097 dest_tree
, dest
, dest_used
,
9098 NULL_TREE
, TRUE
, hook
);
9103 return ffecom_2 (RDIV_EXPR
, tree_type
,
9109 /* Build type info for non-dummy variable. */
9112 ffecom_type_localvar_ (ffesymbol s
, ffeinfoBasictype bt
,
9121 type
= ffecom_tree_type
[bt
][kt
];
9122 if (bt
== FFEINFO_basictypeCHARACTER
)
9124 hight
= build_int_2 (ffesymbol_size (s
), 0);
9125 TREE_TYPE (hight
) = ffecom_f2c_ftnlen_type_node
;
9130 build_range_type (ffecom_f2c_ftnlen_type_node
,
9131 ffecom_f2c_ftnlen_one_node
,
9133 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9136 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
9138 if (type
== error_mark_node
)
9141 dim
= ffebld_head (dl
);
9142 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
9144 if (ffebld_left (dim
) == NULL
)
9145 lowt
= integer_one_node
;
9147 lowt
= ffecom_expr (ffebld_left (dim
));
9149 if (TREE_CODE (lowt
) != INTEGER_CST
)
9150 lowt
= variable_size (lowt
);
9152 assert (ffebld_right (dim
) != NULL
);
9153 hight
= ffecom_expr (ffebld_right (dim
));
9155 if (TREE_CODE (hight
) != INTEGER_CST
)
9156 hight
= variable_size (hight
);
9158 type
= build_array_type (type
,
9159 build_range_type (ffecom_integer_type_node
,
9161 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9167 /* Build Namelist type. */
9169 static GTY(()) tree ffecom_type_namelist_var
;
9171 ffecom_type_namelist_ ()
9173 if (ffecom_type_namelist_var
== NULL_TREE
)
9175 tree namefield
, varsfield
, nvarsfield
, vardesctype
, type
;
9177 vardesctype
= ffecom_type_vardesc_ ();
9179 type
= make_node (RECORD_TYPE
);
9181 vardesctype
= build_pointer_type (build_pointer_type (vardesctype
));
9183 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9185 varsfield
= ffecom_decl_field (type
, namefield
, "vars", vardesctype
);
9186 nvarsfield
= ffecom_decl_field (type
, varsfield
, "nvars",
9189 TYPE_FIELDS (type
) = namefield
;
9192 ffecom_type_namelist_var
= type
;
9195 return ffecom_type_namelist_var
;
9198 /* Build Vardesc type. */
9200 static GTY(()) tree ffecom_type_vardesc_var
;
9202 ffecom_type_vardesc_ ()
9204 if (ffecom_type_vardesc_var
== NULL_TREE
)
9206 tree namefield
, addrfield
, dimsfield
, typefield
, type
;
9207 type
= make_node (RECORD_TYPE
);
9209 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9211 addrfield
= ffecom_decl_field (type
, namefield
, "addr",
9213 dimsfield
= ffecom_decl_field (type
, addrfield
, "dims",
9214 ffecom_f2c_ptr_to_ftnlen_type_node
);
9215 typefield
= ffecom_decl_field (type
, dimsfield
, "type",
9218 TYPE_FIELDS (type
) = namefield
;
9221 ffecom_type_vardesc_var
= type
;
9224 return ffecom_type_vardesc_var
;
9228 ffecom_vardesc_ (ffebld expr
)
9232 assert (ffebld_op (expr
) == FFEBLD_opSYMTER
);
9233 s
= ffebld_symter (expr
);
9235 if (ffesymbol_hook (s
).vardesc_tree
== NULL_TREE
)
9238 tree vardesctype
= ffecom_type_vardesc_ ();
9246 static int mynumber
= 0;
9248 var
= build_decl (VAR_DECL
,
9249 ffecom_get_invented_identifier ("__g77_vardesc_%d",
9252 TREE_STATIC (var
) = 1;
9253 DECL_INITIAL (var
) = error_mark_node
;
9255 var
= start_decl (var
, FALSE
);
9257 /* Process inits. */
9259 nameinit
= ffecom_build_f2c_string_ ((i
= strlen (ffesymbol_text (s
)))
9261 ffesymbol_text (s
));
9262 TREE_TYPE (nameinit
)
9263 = build_type_variant
9266 build_range_type (integer_type_node
,
9268 build_int_2 (i
, 0))),
9270 TREE_CONSTANT (nameinit
) = 1;
9271 TREE_STATIC (nameinit
) = 1;
9272 nameinit
= ffecom_1 (ADDR_EXPR
,
9273 build_pointer_type (TREE_TYPE (nameinit
)),
9276 addrinit
= ffecom_arg_ptr_to_expr (expr
, &typeinit
);
9278 dimsinit
= ffecom_vardesc_dims_ (s
);
9280 if (typeinit
== NULL_TREE
)
9282 ffeinfoBasictype bt
= ffesymbol_basictype (s
);
9283 ffeinfoKindtype kt
= ffesymbol_kindtype (s
);
9284 int tc
= ffecom_f2c_typecode (bt
, kt
);
9287 typeinit
= build_int_2 (tc
, (tc
< 0) ? -1 : 0);
9290 typeinit
= ffecom_1 (NEGATE_EXPR
, TREE_TYPE (typeinit
), typeinit
);
9292 varinits
= build_tree_list ((field
= TYPE_FIELDS (vardesctype
)),
9294 TREE_CHAIN (varinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
9296 TREE_CHAIN (TREE_CHAIN (varinits
))
9297 = build_tree_list ((field
= TREE_CHAIN (field
)), dimsinit
);
9298 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits
)))
9299 = build_tree_list ((field
= TREE_CHAIN (field
)), typeinit
);
9301 varinits
= build (CONSTRUCTOR
, vardesctype
, NULL_TREE
, varinits
);
9302 TREE_CONSTANT (varinits
) = 1;
9303 TREE_STATIC (varinits
) = 1;
9305 finish_decl (var
, varinits
, FALSE
);
9307 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (vardesctype
), var
);
9309 ffesymbol_hook (s
).vardesc_tree
= var
;
9312 return ffesymbol_hook (s
).vardesc_tree
;
9316 ffecom_vardesc_array_ (ffesymbol s
)
9320 tree item
= NULL_TREE
;
9323 static int mynumber
= 0;
9325 for (i
= 0, list
= NULL_TREE
, b
= ffesymbol_namelist (s
);
9327 b
= ffebld_trail (b
), ++i
)
9331 t
= ffecom_vardesc_ (ffebld_head (b
));
9333 if (list
== NULL_TREE
)
9334 list
= item
= build_tree_list (NULL_TREE
, t
);
9337 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
9338 item
= TREE_CHAIN (item
);
9342 item
= build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9343 build_range_type (integer_type_node
,
9345 build_int_2 (i
, 0)));
9346 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
9347 TREE_CONSTANT (list
) = 1;
9348 TREE_STATIC (list
) = 1;
9350 var
= ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber
++);
9351 var
= build_decl (VAR_DECL
, var
, item
);
9352 TREE_STATIC (var
) = 1;
9353 DECL_INITIAL (var
) = error_mark_node
;
9354 var
= start_decl (var
, FALSE
);
9355 finish_decl (var
, list
, FALSE
);
9361 ffecom_vardesc_dims_ (ffesymbol s
)
9363 if (ffesymbol_dims (s
) == NULL
)
9364 return convert (ffecom_f2c_ptr_to_ftnlen_type_node
,
9372 tree item
= NULL_TREE
;
9376 tree baseoff
= NULL_TREE
;
9377 static int mynumber
= 0;
9379 numdim
= build_int_2 ((int) ffesymbol_rank (s
), 0);
9380 TREE_TYPE (numdim
) = ffecom_f2c_ftnlen_type_node
;
9382 numelem
= ffecom_expr (ffesymbol_arraysize (s
));
9383 TREE_TYPE (numelem
) = ffecom_f2c_ftnlen_type_node
;
9386 backlist
= NULL_TREE
;
9387 for (b
= ffesymbol_dims (s
), e
= ffesymbol_extents (s
);
9389 b
= ffebld_trail (b
), e
= ffebld_trail (e
))
9395 if (ffebld_trail (b
) == NULL
)
9399 t
= convert (ffecom_f2c_ftnlen_type_node
,
9400 ffecom_expr (ffebld_head (e
)));
9402 if (list
== NULL_TREE
)
9403 list
= item
= build_tree_list (NULL_TREE
, t
);
9406 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
9407 item
= TREE_CHAIN (item
);
9411 if (ffebld_left (ffebld_head (b
)) == NULL
)
9412 low
= ffecom_integer_one_node
;
9414 low
= ffecom_expr (ffebld_left (ffebld_head (b
)));
9415 low
= convert (ffecom_f2c_ftnlen_type_node
, low
);
9417 back
= build_tree_list (low
, t
);
9418 TREE_CHAIN (back
) = backlist
;
9422 for (item
= backlist
; item
!= NULL_TREE
; item
= TREE_CHAIN (item
))
9424 if (TREE_VALUE (item
) == NULL_TREE
)
9425 baseoff
= TREE_PURPOSE (item
);
9427 baseoff
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
9428 TREE_PURPOSE (item
),
9429 ffecom_2 (MULT_EXPR
,
9430 ffecom_f2c_ftnlen_type_node
,
9435 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9437 baseoff
= build_tree_list (NULL_TREE
, baseoff
);
9438 TREE_CHAIN (baseoff
) = list
;
9440 numelem
= build_tree_list (NULL_TREE
, numelem
);
9441 TREE_CHAIN (numelem
) = baseoff
;
9443 numdim
= build_tree_list (NULL_TREE
, numdim
);
9444 TREE_CHAIN (numdim
) = numelem
;
9446 item
= build_array_type (ffecom_f2c_ftnlen_type_node
,
9447 build_range_type (integer_type_node
,
9450 ((int) ffesymbol_rank (s
)
9452 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, numdim
);
9453 TREE_CONSTANT (list
) = 1;
9454 TREE_STATIC (list
) = 1;
9456 var
= ffecom_get_invented_identifier ("__g77_dims_%d", mynumber
++);
9457 var
= build_decl (VAR_DECL
, var
, item
);
9458 TREE_STATIC (var
) = 1;
9459 DECL_INITIAL (var
) = error_mark_node
;
9460 var
= start_decl (var
, FALSE
);
9461 finish_decl (var
, list
, FALSE
);
9463 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (item
), var
);
9469 /* Essentially does a "fold (build1 (code, type, node))" while checking
9470 for certain housekeeping things.
9472 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9473 ffecom_1_fn instead. */
9476 ffecom_1 (enum tree_code code
, tree type
, tree node
)
9480 if ((node
== error_mark_node
)
9481 || (type
== error_mark_node
))
9482 return error_mark_node
;
9484 if (code
== ADDR_EXPR
)
9486 if (!ffe_mark_addressable (node
))
9487 assert ("can't mark_addressable this node!" == NULL
);
9490 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
9495 item
= build (COMPONENT_REF
, type
, node
, TYPE_FIELDS (TREE_TYPE (node
)));
9499 item
= build (COMPONENT_REF
, type
, node
, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node
))));
9504 if (TREE_CODE (type
) != RECORD_TYPE
)
9506 item
= build1 (code
, type
, node
);
9509 node
= ffecom_stabilize_aggregate_ (node
);
9510 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9512 ffecom_2 (COMPLEX_EXPR
, type
,
9513 ffecom_1 (NEGATE_EXPR
, realtype
,
9514 ffecom_1 (REALPART_EXPR
, realtype
,
9516 ffecom_1 (NEGATE_EXPR
, realtype
,
9517 ffecom_1 (IMAGPART_EXPR
, realtype
,
9522 item
= build1 (code
, type
, node
);
9526 if (TREE_SIDE_EFFECTS (node
))
9527 TREE_SIDE_EFFECTS (item
) = 1;
9528 if (code
== ADDR_EXPR
&& staticp (node
))
9529 TREE_CONSTANT (item
) = 1;
9530 else if (code
== INDIRECT_REF
)
9531 TREE_READONLY (item
) = TYPE_READONLY (type
);
9535 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9536 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9537 does not set TREE_ADDRESSABLE (because calling an inline
9538 function does not mean the function needs to be separately
9542 ffecom_1_fn (tree node
)
9547 if (node
== error_mark_node
)
9548 return error_mark_node
;
9550 type
= build_type_variant (TREE_TYPE (node
),
9551 TREE_READONLY (node
),
9552 TREE_THIS_VOLATILE (node
));
9553 item
= build1 (ADDR_EXPR
,
9554 build_pointer_type (type
), node
);
9555 if (TREE_SIDE_EFFECTS (node
))
9556 TREE_SIDE_EFFECTS (item
) = 1;
9558 TREE_CONSTANT (item
) = 1;
9562 /* Essentially does a "fold (build (code, type, node1, node2))" while
9563 checking for certain housekeeping things. */
9566 ffecom_2 (enum tree_code code
, tree type
, tree node1
,
9571 if ((node1
== error_mark_node
)
9572 || (node2
== error_mark_node
)
9573 || (type
== error_mark_node
))
9574 return error_mark_node
;
9576 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
9578 tree a
, b
, c
, d
, realtype
;
9581 assert ("no CONJ_EXPR support yet" == NULL
);
9582 return error_mark_node
;
9585 item
= build_tree_list (TYPE_FIELDS (type
), node1
);
9586 TREE_CHAIN (item
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), node2
);
9587 item
= build (CONSTRUCTOR
, type
, NULL_TREE
, item
);
9591 if (TREE_CODE (type
) != RECORD_TYPE
)
9593 item
= build (code
, type
, node1
, node2
);
9596 node1
= ffecom_stabilize_aggregate_ (node1
);
9597 node2
= ffecom_stabilize_aggregate_ (node2
);
9598 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9600 ffecom_2 (COMPLEX_EXPR
, type
,
9601 ffecom_2 (PLUS_EXPR
, realtype
,
9602 ffecom_1 (REALPART_EXPR
, realtype
,
9604 ffecom_1 (REALPART_EXPR
, realtype
,
9606 ffecom_2 (PLUS_EXPR
, realtype
,
9607 ffecom_1 (IMAGPART_EXPR
, realtype
,
9609 ffecom_1 (IMAGPART_EXPR
, realtype
,
9614 if (TREE_CODE (type
) != RECORD_TYPE
)
9616 item
= build (code
, type
, node1
, node2
);
9619 node1
= ffecom_stabilize_aggregate_ (node1
);
9620 node2
= ffecom_stabilize_aggregate_ (node2
);
9621 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9623 ffecom_2 (COMPLEX_EXPR
, type
,
9624 ffecom_2 (MINUS_EXPR
, realtype
,
9625 ffecom_1 (REALPART_EXPR
, realtype
,
9627 ffecom_1 (REALPART_EXPR
, realtype
,
9629 ffecom_2 (MINUS_EXPR
, realtype
,
9630 ffecom_1 (IMAGPART_EXPR
, realtype
,
9632 ffecom_1 (IMAGPART_EXPR
, realtype
,
9637 if (TREE_CODE (type
) != RECORD_TYPE
)
9639 item
= build (code
, type
, node1
, node2
);
9642 node1
= ffecom_stabilize_aggregate_ (node1
);
9643 node2
= ffecom_stabilize_aggregate_ (node2
);
9644 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9645 a
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
9647 b
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
9649 c
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
9651 d
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
9654 ffecom_2 (COMPLEX_EXPR
, type
,
9655 ffecom_2 (MINUS_EXPR
, realtype
,
9656 ffecom_2 (MULT_EXPR
, realtype
,
9659 ffecom_2 (MULT_EXPR
, realtype
,
9662 ffecom_2 (PLUS_EXPR
, realtype
,
9663 ffecom_2 (MULT_EXPR
, realtype
,
9666 ffecom_2 (MULT_EXPR
, realtype
,
9672 if ((TREE_CODE (node1
) != RECORD_TYPE
)
9673 && (TREE_CODE (node2
) != RECORD_TYPE
))
9675 item
= build (code
, type
, node1
, node2
);
9678 assert (TREE_CODE (node1
) == RECORD_TYPE
);
9679 assert (TREE_CODE (node2
) == RECORD_TYPE
);
9680 node1
= ffecom_stabilize_aggregate_ (node1
);
9681 node2
= ffecom_stabilize_aggregate_ (node2
);
9682 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9684 ffecom_2 (TRUTH_ANDIF_EXPR
, type
,
9685 ffecom_2 (code
, type
,
9686 ffecom_1 (REALPART_EXPR
, realtype
,
9688 ffecom_1 (REALPART_EXPR
, realtype
,
9690 ffecom_2 (code
, type
,
9691 ffecom_1 (IMAGPART_EXPR
, realtype
,
9693 ffecom_1 (IMAGPART_EXPR
, realtype
,
9698 if ((TREE_CODE (node1
) != RECORD_TYPE
)
9699 && (TREE_CODE (node2
) != RECORD_TYPE
))
9701 item
= build (code
, type
, node1
, node2
);
9704 assert (TREE_CODE (node1
) == RECORD_TYPE
);
9705 assert (TREE_CODE (node2
) == RECORD_TYPE
);
9706 node1
= ffecom_stabilize_aggregate_ (node1
);
9707 node2
= ffecom_stabilize_aggregate_ (node2
);
9708 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9710 ffecom_2 (TRUTH_ORIF_EXPR
, type
,
9711 ffecom_2 (code
, type
,
9712 ffecom_1 (REALPART_EXPR
, realtype
,
9714 ffecom_1 (REALPART_EXPR
, realtype
,
9716 ffecom_2 (code
, type
,
9717 ffecom_1 (IMAGPART_EXPR
, realtype
,
9719 ffecom_1 (IMAGPART_EXPR
, realtype
,
9724 item
= build (code
, type
, node1
, node2
);
9728 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
))
9729 TREE_SIDE_EFFECTS (item
) = 1;
9733 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9735 ffesymbol s; // the ENTRY point itself
9736 if (ffecom_2pass_advise_entrypoint(s))
9737 // the ENTRY point has been accepted
9739 Does whatever compiler needs to do when it learns about the entrypoint,
9740 like determine the return type of the master function, count the
9741 number of entrypoints, etc. Returns FALSE if the return type is
9742 not compatible with the return type(s) of other entrypoint(s).
9744 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9745 later (after _finish_progunit) be called with the same entrypoint(s)
9746 as passed to this fn for which TRUE was returned.
9749 Return FALSE if the return type conflicts with previous entrypoints. */
9752 ffecom_2pass_advise_entrypoint (ffesymbol entry
)
9754 ffebld list
; /* opITEM. */
9755 ffebld mlist
; /* opITEM. */
9756 ffebld plist
; /* opITEM. */
9757 ffebld arg
; /* ffebld_head(opITEM). */
9758 ffebld item
; /* opITEM. */
9759 ffesymbol s
; /* ffebld_symter(arg). */
9760 ffeinfoBasictype bt
= ffesymbol_basictype (entry
);
9761 ffeinfoKindtype kt
= ffesymbol_kindtype (entry
);
9762 ffetargetCharacterSize size
= ffesymbol_size (entry
);
9765 if (ffecom_num_entrypoints_
== 0)
9766 { /* First entrypoint, make list of main
9767 arglist's dummies. */
9768 assert (ffecom_primary_entry_
!= NULL
);
9770 ffecom_master_bt_
= ffesymbol_basictype (ffecom_primary_entry_
);
9771 ffecom_master_kt_
= ffesymbol_kindtype (ffecom_primary_entry_
);
9772 ffecom_master_size_
= ffesymbol_size (ffecom_primary_entry_
);
9774 for (plist
= NULL
, list
= ffesymbol_dummyargs (ffecom_primary_entry_
);
9776 list
= ffebld_trail (list
))
9778 arg
= ffebld_head (list
);
9779 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
9780 continue; /* Alternate return or some such thing. */
9781 item
= ffebld_new_item (arg
, NULL
);
9783 ffecom_master_arglist_
= item
;
9785 ffebld_set_trail (plist
, item
);
9790 /* If necessary, scan entry arglist for alternate returns. Do this scan
9791 apparently redundantly (it's done below to UNIONize the arglists) so
9792 that we don't complain about RETURN 1 if an offending ENTRY is the only
9793 one with an alternate return. */
9795 if (!ffecom_is_altreturning_
)
9797 for (list
= ffesymbol_dummyargs (entry
);
9799 list
= ffebld_trail (list
))
9801 arg
= ffebld_head (list
);
9802 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
9804 ffecom_is_altreturning_
= TRUE
;
9810 /* Now check type compatibility. */
9812 switch (ffecom_master_bt_
)
9814 case FFEINFO_basictypeNONE
:
9815 ok
= (bt
!= FFEINFO_basictypeCHARACTER
);
9818 case FFEINFO_basictypeCHARACTER
:
9820 = (bt
== FFEINFO_basictypeCHARACTER
)
9821 && (kt
== ffecom_master_kt_
)
9822 && (size
== ffecom_master_size_
);
9825 case FFEINFO_basictypeANY
:
9826 return FALSE
; /* Just don't bother. */
9829 if (bt
== FFEINFO_basictypeCHARACTER
)
9835 if ((bt
!= ffecom_master_bt_
) || (kt
!= ffecom_master_kt_
))
9837 ffecom_master_bt_
= FFEINFO_basictypeNONE
;
9838 ffecom_master_kt_
= FFEINFO_kindtypeNONE
;
9845 ffebad_start (FFEBAD_ENTRY_CONFLICTS
);
9846 ffest_ffebad_here_current_stmt (0);
9848 return FALSE
; /* Can't handle entrypoint. */
9851 /* Entrypoint type compatible with previous types. */
9853 ++ffecom_num_entrypoints_
;
9855 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9857 for (list
= ffesymbol_dummyargs (entry
);
9859 list
= ffebld_trail (list
))
9861 arg
= ffebld_head (list
);
9862 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
9863 continue; /* Alternate return or some such thing. */
9864 s
= ffebld_symter (arg
);
9865 for (plist
= NULL
, mlist
= ffecom_master_arglist_
;
9867 plist
= mlist
, mlist
= ffebld_trail (mlist
))
9868 { /* plist points to previous item for easy
9869 appending of arg. */
9870 if (ffebld_symter (ffebld_head (mlist
)) == s
)
9871 break; /* Already have this arg in the master list. */
9874 continue; /* Already have this arg in the master list. */
9876 /* Append this arg to the master list. */
9878 item
= ffebld_new_item (arg
, NULL
);
9880 ffecom_master_arglist_
= item
;
9882 ffebld_set_trail (plist
, item
);
9888 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9890 ffesymbol s; // the ENTRY point itself
9891 ffecom_2pass_do_entrypoint(s);
9893 Does whatever compiler needs to do to make the entrypoint actually
9894 happen. Must be called for each entrypoint after
9895 ffecom_finish_progunit is called. */
9898 ffecom_2pass_do_entrypoint (ffesymbol entry
)
9900 static int mfn_num
= 0;
9903 if (mfn_num
!= ffecom_num_fns_
)
9904 { /* First entrypoint for this program unit. */
9906 mfn_num
= ffecom_num_fns_
;
9907 ffecom_do_entry_ (ffecom_primary_entry_
, 0);
9912 --ffecom_num_entrypoints_
;
9914 ffecom_do_entry_ (entry
, ent_num
);
9917 /* Essentially does a "fold (build (code, type, node1, node2))" while
9918 checking for certain housekeeping things. Always sets
9919 TREE_SIDE_EFFECTS. */
9922 ffecom_2s (enum tree_code code
, tree type
, tree node1
,
9927 if ((node1
== error_mark_node
)
9928 || (node2
== error_mark_node
)
9929 || (type
== error_mark_node
))
9930 return error_mark_node
;
9932 item
= build (code
, type
, node1
, node2
);
9933 TREE_SIDE_EFFECTS (item
) = 1;
9937 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9938 checking for certain housekeeping things. */
9941 ffecom_3 (enum tree_code code
, tree type
, tree node1
,
9942 tree node2
, tree node3
)
9946 if ((node1
== error_mark_node
)
9947 || (node2
== error_mark_node
)
9948 || (node3
== error_mark_node
)
9949 || (type
== error_mark_node
))
9950 return error_mark_node
;
9952 item
= build (code
, type
, node1
, node2
, node3
);
9953 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
)
9954 || (node3
!= NULL_TREE
&& TREE_SIDE_EFFECTS (node3
)))
9955 TREE_SIDE_EFFECTS (item
) = 1;
9959 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9960 checking for certain housekeeping things. Always sets
9961 TREE_SIDE_EFFECTS. */
9964 ffecom_3s (enum tree_code code
, tree type
, tree node1
,
9965 tree node2
, tree node3
)
9969 if ((node1
== error_mark_node
)
9970 || (node2
== error_mark_node
)
9971 || (node3
== error_mark_node
)
9972 || (type
== error_mark_node
))
9973 return error_mark_node
;
9975 item
= build (code
, type
, node1
, node2
, node3
);
9976 TREE_SIDE_EFFECTS (item
) = 1;
9980 /* ffecom_arg_expr -- Transform argument expr into gcc tree
9982 See use by ffecom_list_expr.
9984 If expression is NULL, returns an integer zero tree. If it is not
9985 a CHARACTER expression, returns whatever ffecom_expr
9986 returns and sets the length return value to NULL_TREE. Otherwise
9987 generates code to evaluate the character expression, returns the proper
9988 pointer to the result, but does NOT set the length return value to a tree
9989 that specifies the length of the result. (In other words, the length
9990 variable is always set to NULL_TREE, because a length is never passed.)
9993 Don't set returned length, since nobody needs it (yet; someday if
9994 we allow CHARACTER*(*) dummies to statement functions, we'll need
9998 ffecom_arg_expr (ffebld expr
, tree
*length
)
10002 *length
= NULL_TREE
;
10005 return integer_zero_node
;
10007 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10008 return ffecom_expr (expr
);
10010 return ffecom_arg_ptr_to_expr (expr
, &ign
);
10013 /* Transform expression into constant argument-pointer-to-expression tree.
10015 If the expression can be transformed into a argument-pointer-to-expression
10016 tree that is constant, that is done, and the tree returned. Else
10017 NULL_TREE is returned.
10019 That way, a caller can attempt to provide compile-time initialization
10020 of a variable and, if that fails, *then* choose to start a new block
10021 and resort to using temporaries, as appropriate. */
10024 ffecom_arg_ptr_to_const_expr (ffebld expr
, tree
*length
)
10027 return integer_zero_node
;
10029 if (ffebld_op (expr
) == FFEBLD_opANY
)
10032 *length
= error_mark_node
;
10033 return error_mark_node
;
10036 if (ffebld_arity (expr
) == 0
10037 && (ffebld_op (expr
) != FFEBLD_opSYMTER
10038 || ffebld_where (expr
) == FFEINFO_whereCOMMON
10039 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
10040 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
10044 t
= ffecom_arg_ptr_to_expr (expr
, length
);
10045 assert (TREE_CONSTANT (t
));
10046 assert (! length
|| TREE_CONSTANT (*length
));
10051 && ffebld_size (expr
) != FFETARGET_charactersizeNONE
)
10052 *length
= build_int_2 (ffebld_size (expr
), 0);
10054 *length
= NULL_TREE
;
10058 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10060 See use by ffecom_list_ptr_to_expr.
10062 If expression is NULL, returns an integer zero tree. If it is not
10063 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10064 returns and sets the length return value to NULL_TREE. Otherwise
10065 generates code to evaluate the character expression, returns the proper
10066 pointer to the result, AND sets the length return value to a tree that
10067 specifies the length of the result.
10069 If the length argument is NULL, this is a slightly special
10070 case of building a FORMAT expression, that is, an expression that
10071 will be used at run time without regard to length. For the current
10072 implementation, which uses the libf2c library, this means it is nice
10073 to append a null byte to the end of the expression, where feasible,
10074 to make sure any diagnostic about the FORMAT string terminates at
10077 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10078 length argument. This might even be seen as a feature, if a null
10079 byte can always be appended. */
10082 ffecom_arg_ptr_to_expr (ffebld expr
, tree
*length
)
10086 ffecomConcatList_ catlist
;
10088 if (length
!= NULL
)
10089 *length
= NULL_TREE
;
10092 return integer_zero_node
;
10094 switch (ffebld_op (expr
))
10096 case FFEBLD_opPERCENT_VAL
:
10097 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10098 return ffecom_expr (ffebld_left (expr
));
10103 temp_exp
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &temp_length
);
10104 if (temp_exp
== error_mark_node
)
10105 return error_mark_node
;
10107 return ffecom_1 (INDIRECT_REF
, TREE_TYPE (TREE_TYPE (temp_exp
)),
10111 case FFEBLD_opPERCENT_REF
:
10112 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10113 return ffecom_ptr_to_expr (ffebld_left (expr
));
10114 if (length
!= NULL
)
10116 ign_length
= NULL_TREE
;
10117 length
= &ign_length
;
10119 expr
= ffebld_left (expr
);
10122 case FFEBLD_opPERCENT_DESCR
:
10123 switch (ffeinfo_basictype (ffebld_info (expr
)))
10125 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10126 case FFEINFO_basictypeHOLLERITH
:
10128 case FFEINFO_basictypeCHARACTER
:
10129 break; /* Passed by descriptor anyway. */
10132 item
= ffecom_ptr_to_expr (expr
);
10133 if (item
!= error_mark_node
)
10134 *length
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (item
)));
10143 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10144 if ((ffeinfo_basictype (ffebld_info (expr
)) == FFEINFO_basictypeHOLLERITH
)
10145 && (length
!= NULL
))
10146 { /* Pass Hollerith by descriptor. */
10147 ffetargetHollerith h
;
10149 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
10150 h
= ffebld_cu_val_hollerith (ffebld_constant_union
10151 (ffebld_conter (expr
)));
10153 = build_int_2 (h
.length
, 0);
10154 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10158 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10159 return ffecom_ptr_to_expr (expr
);
10161 assert (ffeinfo_kindtype (ffebld_info (expr
))
10162 == FFEINFO_kindtypeCHARACTER1
);
10164 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
10165 expr
= ffebld_left (expr
);
10167 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
10168 switch (ffecom_concat_list_count_ (catlist
))
10170 case 0: /* Shouldn't happen, but in case it does... */
10171 if (length
!= NULL
)
10173 *length
= ffecom_f2c_ftnlen_zero_node
;
10174 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10176 ffecom_concat_list_kill_ (catlist
);
10177 return null_pointer_node
;
10179 case 1: /* The (fairly) easy case. */
10180 if (length
== NULL
)
10181 ffecom_char_args_with_null_ (&item
, &ign_length
,
10182 ffecom_concat_list_expr_ (catlist
, 0));
10184 ffecom_char_args_ (&item
, length
,
10185 ffecom_concat_list_expr_ (catlist
, 0));
10186 ffecom_concat_list_kill_ (catlist
);
10187 assert (item
!= NULL_TREE
);
10190 default: /* Must actually concatenate things. */
10195 int count
= ffecom_concat_list_count_ (catlist
);
10206 ffetargetCharacterSize sz
;
10208 sz
= ffecom_concat_list_maxlen_ (catlist
);
10210 assert (sz
!= FFETARGET_charactersizeNONE
);
10215 hook
= ffebld_nonter_hook (expr
);
10217 assert (TREE_CODE (hook
) == TREE_VEC
);
10218 assert (TREE_VEC_LENGTH (hook
) == 3);
10219 length_array
= lengths
= TREE_VEC_ELT (hook
, 0);
10220 item_array
= items
= TREE_VEC_ELT (hook
, 1);
10221 temporary
= TREE_VEC_ELT (hook
, 2);
10224 known_length
= ffecom_f2c_ftnlen_zero_node
;
10226 for (i
= 0; i
< count
; ++i
)
10229 && (length
== NULL
))
10230 ffecom_char_args_with_null_ (&citem
, &clength
,
10231 ffecom_concat_list_expr_ (catlist
, i
));
10233 ffecom_char_args_ (&citem
, &clength
,
10234 ffecom_concat_list_expr_ (catlist
, i
));
10235 if ((citem
== error_mark_node
)
10236 || (clength
== error_mark_node
))
10238 ffecom_concat_list_kill_ (catlist
);
10239 *length
= error_mark_node
;
10240 return error_mark_node
;
10244 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
10245 ffecom_modify (void_type_node
,
10246 ffecom_2 (ARRAY_REF
,
10247 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
10249 build_int_2 (i
, 0)),
10252 clength
= ffecom_save_tree (clength
);
10253 if (length
!= NULL
)
10255 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
10259 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
10260 ffecom_modify (void_type_node
,
10261 ffecom_2 (ARRAY_REF
,
10262 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
10264 build_int_2 (i
, 0)),
10269 temporary
= ffecom_1 (ADDR_EXPR
,
10270 build_pointer_type (TREE_TYPE (temporary
)),
10273 item
= build_tree_list (NULL_TREE
, temporary
);
10275 = build_tree_list (NULL_TREE
,
10276 ffecom_1 (ADDR_EXPR
,
10277 build_pointer_type (TREE_TYPE (items
)),
10279 TREE_CHAIN (TREE_CHAIN (item
))
10280 = build_tree_list (NULL_TREE
,
10281 ffecom_1 (ADDR_EXPR
,
10282 build_pointer_type (TREE_TYPE (lengths
)),
10284 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
10287 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
10288 convert (ffecom_f2c_ftnlen_type_node
,
10289 build_int_2 (count
, 0))));
10290 num
= build_int_2 (sz
, 0);
10291 TREE_TYPE (num
) = ffecom_f2c_ftnlen_type_node
;
10292 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
))))
10293 = build_tree_list (NULL_TREE
, num
);
10295 item
= ffecom_call_gfrt (FFECOM_gfrtCAT
, item
, NULL_TREE
);
10296 TREE_SIDE_EFFECTS (item
) = 1;
10297 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (temporary
),
10301 if (length
!= NULL
)
10302 *length
= known_length
;
10305 ffecom_concat_list_kill_ (catlist
);
10306 assert (item
!= NULL_TREE
);
10310 /* Generate call to run-time function.
10312 The first arg is the GNU Fortran Run-Time function index, the second
10313 arg is the list of arguments to pass to it. Returned is the expression
10314 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10315 result (which may be void). */
10318 ffecom_call_gfrt (ffecomGfrt ix
, tree args
, tree hook
)
10320 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
10321 ffecom_gfrt_kindtype (ix
),
10322 ffe_is_f2c_library () && ffecom_gfrt_complex_
[ix
],
10323 NULL_TREE
, args
, NULL_TREE
, NULL
,
10324 NULL
, NULL_TREE
, TRUE
, hook
);
10327 /* Transform constant-union to tree. */
10330 ffecom_constantunion (ffebldConstantUnion
*cu
, ffeinfoBasictype bt
,
10331 ffeinfoKindtype kt
, tree tree_type
)
10337 case FFEINFO_basictypeINTEGER
:
10343 #if FFETARGET_okINTEGER1
10344 case FFEINFO_kindtypeINTEGER1
:
10345 val
= ffebld_cu_val_integer1 (*cu
);
10349 #if FFETARGET_okINTEGER2
10350 case FFEINFO_kindtypeINTEGER2
:
10351 val
= ffebld_cu_val_integer2 (*cu
);
10355 #if FFETARGET_okINTEGER3
10356 case FFEINFO_kindtypeINTEGER3
:
10357 val
= ffebld_cu_val_integer3 (*cu
);
10361 #if FFETARGET_okINTEGER4
10362 case FFEINFO_kindtypeINTEGER4
:
10363 val
= ffebld_cu_val_integer4 (*cu
);
10368 assert ("bad INTEGER constant kind type" == NULL
);
10369 /* Fall through. */
10370 case FFEINFO_kindtypeANY
:
10371 return error_mark_node
;
10373 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
10374 TREE_TYPE (item
) = tree_type
;
10378 case FFEINFO_basictypeLOGICAL
:
10384 #if FFETARGET_okLOGICAL1
10385 case FFEINFO_kindtypeLOGICAL1
:
10386 val
= ffebld_cu_val_logical1 (*cu
);
10390 #if FFETARGET_okLOGICAL2
10391 case FFEINFO_kindtypeLOGICAL2
:
10392 val
= ffebld_cu_val_logical2 (*cu
);
10396 #if FFETARGET_okLOGICAL3
10397 case FFEINFO_kindtypeLOGICAL3
:
10398 val
= ffebld_cu_val_logical3 (*cu
);
10402 #if FFETARGET_okLOGICAL4
10403 case FFEINFO_kindtypeLOGICAL4
:
10404 val
= ffebld_cu_val_logical4 (*cu
);
10409 assert ("bad LOGICAL constant kind type" == NULL
);
10410 /* Fall through. */
10411 case FFEINFO_kindtypeANY
:
10412 return error_mark_node
;
10414 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
10415 TREE_TYPE (item
) = tree_type
;
10419 case FFEINFO_basictypeREAL
:
10421 REAL_VALUE_TYPE val
;
10425 #if FFETARGET_okREAL1
10426 case FFEINFO_kindtypeREAL1
:
10427 val
= ffetarget_value_real1 (ffebld_cu_val_real1 (*cu
));
10431 #if FFETARGET_okREAL2
10432 case FFEINFO_kindtypeREAL2
:
10433 val
= ffetarget_value_real2 (ffebld_cu_val_real2 (*cu
));
10437 #if FFETARGET_okREAL3
10438 case FFEINFO_kindtypeREAL3
:
10439 val
= ffetarget_value_real3 (ffebld_cu_val_real3 (*cu
));
10443 #if FFETARGET_okREAL4
10444 case FFEINFO_kindtypeREAL4
:
10445 val
= ffetarget_value_real4 (ffebld_cu_val_real4 (*cu
));
10450 assert ("bad REAL constant kind type" == NULL
);
10451 /* Fall through. */
10452 case FFEINFO_kindtypeANY
:
10453 return error_mark_node
;
10455 item
= build_real (tree_type
, val
);
10459 case FFEINFO_basictypeCOMPLEX
:
10461 REAL_VALUE_TYPE real
;
10462 REAL_VALUE_TYPE imag
;
10463 tree el_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
10467 #if FFETARGET_okCOMPLEX1
10468 case FFEINFO_kindtypeREAL1
:
10469 real
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).real
);
10470 imag
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).imaginary
);
10474 #if FFETARGET_okCOMPLEX2
10475 case FFEINFO_kindtypeREAL2
:
10476 real
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).real
);
10477 imag
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).imaginary
);
10481 #if FFETARGET_okCOMPLEX3
10482 case FFEINFO_kindtypeREAL3
:
10483 real
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).real
);
10484 imag
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).imaginary
);
10488 #if FFETARGET_okCOMPLEX4
10489 case FFEINFO_kindtypeREAL4
:
10490 real
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).real
);
10491 imag
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).imaginary
);
10496 assert ("bad REAL constant kind type" == NULL
);
10497 /* Fall through. */
10498 case FFEINFO_kindtypeANY
:
10499 return error_mark_node
;
10501 item
= ffecom_build_complex_constant_ (tree_type
,
10502 build_real (el_type
, real
),
10503 build_real (el_type
, imag
));
10507 case FFEINFO_basictypeCHARACTER
:
10508 { /* Happens only in DATA and similar contexts. */
10509 ffetargetCharacter1 val
;
10513 #if FFETARGET_okCHARACTER1
10514 case FFEINFO_kindtypeLOGICAL1
:
10515 val
= ffebld_cu_val_character1 (*cu
);
10520 assert ("bad CHARACTER constant kind type" == NULL
);
10521 /* Fall through. */
10522 case FFEINFO_kindtypeANY
:
10523 return error_mark_node
;
10525 item
= build_string (ffetarget_length_character1 (val
),
10526 ffetarget_text_character1 (val
));
10528 = build_type_variant (build_array_type (char_type_node
,
10530 (integer_type_node
,
10533 (ffetarget_length_character1
10539 case FFEINFO_basictypeHOLLERITH
:
10541 ffetargetHollerith h
;
10543 h
= ffebld_cu_val_hollerith (*cu
);
10545 /* If not at least as wide as default INTEGER, widen it. */
10546 if (h
.length
>= FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
)
10547 item
= build_string (h
.length
, h
.text
);
10550 char str
[FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
];
10552 memcpy (str
, h
.text
, h
.length
);
10553 memset (&str
[h
.length
], ' ',
10554 FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
10556 item
= build_string (FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
,
10560 = build_type_variant (build_array_type (char_type_node
,
10562 (integer_type_node
,
10570 case FFEINFO_basictypeTYPELESS
:
10572 ffetargetInteger1 ival
;
10573 ffetargetTypeless tless
;
10576 tless
= ffebld_cu_val_typeless (*cu
);
10577 error
= ffetarget_convert_integer1_typeless (&ival
, tless
);
10578 assert (error
== FFEBAD
);
10580 item
= build_int_2 ((int) ival
, 0);
10585 assert ("not yet on constant type" == NULL
);
10586 /* Fall through. */
10587 case FFEINFO_basictypeANY
:
10588 return error_mark_node
;
10591 TREE_CONSTANT (item
) = 1;
10596 /* Transform expression into constant tree.
10598 If the expression can be transformed into a tree that is constant,
10599 that is done, and the tree returned. Else NULL_TREE is returned.
10601 That way, a caller can attempt to provide compile-time initialization
10602 of a variable and, if that fails, *then* choose to start a new block
10603 and resort to using temporaries, as appropriate. */
10606 ffecom_const_expr (ffebld expr
)
10609 return integer_zero_node
;
10611 if (ffebld_op (expr
) == FFEBLD_opANY
)
10612 return error_mark_node
;
10614 if (ffebld_arity (expr
) == 0
10615 && (ffebld_op (expr
) != FFEBLD_opSYMTER
10617 /* ~~Enable once common/equivalence is handled properly? */
10618 || ffebld_where (expr
) == FFEINFO_whereCOMMON
10620 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
10621 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
10625 t
= ffecom_expr (expr
);
10626 assert (TREE_CONSTANT (t
));
10633 /* Handy way to make a field in a struct/union. */
10636 ffecom_decl_field (tree context
, tree prevfield
,
10637 const char *name
, tree type
)
10641 field
= build_decl (FIELD_DECL
, get_identifier (name
), type
);
10642 DECL_CONTEXT (field
) = context
;
10643 DECL_ALIGN (field
) = 0;
10644 DECL_USER_ALIGN (field
) = 0;
10645 if (prevfield
!= NULL_TREE
)
10646 TREE_CHAIN (prevfield
) = field
;
10652 ffecom_close_include (FILE *f
)
10654 ffecom_close_include_ (f
);
10658 ffecom_decode_include_option (char *spec
)
10660 return ffecom_decode_include_option_ (spec
);
10663 /* End a compound statement (block). */
10666 ffecom_end_compstmt (void)
10668 return bison_rule_compstmt_ ();
10671 /* ffecom_end_transition -- Perform end transition on all symbols
10673 ffecom_end_transition();
10675 Calls ffecom_sym_end_transition for each global and local symbol. */
10678 ffecom_end_transition ()
10682 if (ffe_is_ffedebug ())
10683 fprintf (dmpout
, "; end_stmt_transition\n");
10685 ffecom_list_blockdata_
= NULL
;
10686 ffecom_list_common_
= NULL
;
10688 ffesymbol_drive (ffecom_sym_end_transition
);
10689 if (ffe_is_ffedebug ())
10691 ffestorag_report ();
10694 ffecom_start_progunit_ ();
10696 for (item
= ffecom_list_blockdata_
;
10698 item
= ffebld_trail (item
))
10705 static int number
= 0;
10707 callee
= ffebld_head (item
);
10708 s
= ffebld_symter (callee
);
10709 t
= ffesymbol_hook (s
).decl_tree
;
10710 if (t
== NULL_TREE
)
10712 s
= ffecom_sym_transform_ (s
);
10713 t
= ffesymbol_hook (s
).decl_tree
;
10716 dt
= build_pointer_type (TREE_TYPE (t
));
10718 var
= build_decl (VAR_DECL
,
10719 ffecom_get_invented_identifier ("__g77_forceload_%d",
10722 DECL_EXTERNAL (var
) = 0;
10723 TREE_STATIC (var
) = 1;
10724 TREE_PUBLIC (var
) = 0;
10725 DECL_INITIAL (var
) = error_mark_node
;
10726 TREE_USED (var
) = 1;
10728 var
= start_decl (var
, FALSE
);
10730 t
= ffecom_1 (ADDR_EXPR
, dt
, t
);
10732 finish_decl (var
, t
, FALSE
);
10735 /* This handles any COMMON areas that weren't referenced but have, for
10736 example, important initial data. */
10738 for (item
= ffecom_list_common_
;
10740 item
= ffebld_trail (item
))
10741 ffecom_transform_common_ (ffebld_symter (ffebld_head (item
)));
10743 ffecom_list_common_
= NULL
;
10746 /* ffecom_exec_transition -- Perform exec transition on all symbols
10748 ffecom_exec_transition();
10750 Calls ffecom_sym_exec_transition for each global and local symbol.
10751 Make sure error updating not inhibited. */
10754 ffecom_exec_transition ()
10758 if (ffe_is_ffedebug ())
10759 fprintf (dmpout
, "; exec_stmt_transition\n");
10761 inhibited
= ffebad_inhibit ();
10762 ffebad_set_inhibit (FALSE
);
10764 ffesymbol_drive (ffecom_sym_exec_transition
); /* Don't retract! */
10765 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
10766 if (ffe_is_ffedebug ())
10768 ffestorag_report ();
10772 ffebad_set_inhibit (TRUE
);
10775 /* Handle assignment statement.
10777 Convert dest and source using ffecom_expr, then join them
10778 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
10781 ffecom_expand_let_stmt (ffebld dest
, ffebld source
)
10788 if (ffeinfo_basictype (ffebld_info (dest
)) != FFEINFO_basictypeCHARACTER
)
10793 /* This attempts to replicate the test below, but must not be
10794 true when the test below is false. (Always err on the side
10795 of creating unused temporaries, to avoid ICEs.) */
10796 if (ffebld_op (dest
) != FFEBLD_opSYMTER
10797 || ((dest_tree
= ffesymbol_hook (ffebld_symter (dest
)).decl_tree
)
10798 && (TREE_CODE (dest_tree
) != VAR_DECL
10799 || TREE_ADDRESSABLE (dest_tree
))))
10801 ffecom_prepare_expr_ (source
, dest
);
10806 ffecom_prepare_expr_ (source
, NULL
);
10810 ffecom_prepare_expr_w (NULL_TREE
, dest
);
10812 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10813 create a temporary through which the assignment is to take place,
10814 since MODIFY_EXPR doesn't handle partial overlap properly. */
10815 if (ffebld_basictype (dest
) == FFEINFO_basictypeCOMPLEX
10816 && ffecom_possible_partial_overlap_ (dest
, source
))
10818 assign_temp
= ffecom_make_tempvar ("complex_let",
10820 [ffebld_basictype (dest
)]
10821 [ffebld_kindtype (dest
)],
10822 FFETARGET_charactersizeNONE
,
10826 assign_temp
= NULL_TREE
;
10828 ffecom_prepare_end ();
10830 dest_tree
= ffecom_expr_w (NULL_TREE
, dest
);
10831 if (dest_tree
== error_mark_node
)
10834 if ((TREE_CODE (dest_tree
) != VAR_DECL
)
10835 || TREE_ADDRESSABLE (dest_tree
))
10836 source_tree
= ffecom_expr_ (source
, dest_tree
, dest
, &dest_used
,
10840 assert (! dest_used
);
10842 source_tree
= ffecom_expr (source
);
10844 if (source_tree
== error_mark_node
)
10848 expr_tree
= source_tree
;
10849 else if (assign_temp
)
10852 /* The back end understands a conceptual move (evaluate source;
10853 store into dest), so use that, in case it can determine
10854 that it is going to use, say, two registers as temporaries
10855 anyway. So don't use the temp (and someday avoid generating
10856 it, once this code starts triggering regularly). */
10857 expr_tree
= ffecom_2s (MOVE_EXPR
, void_type_node
,
10861 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
10864 expand_expr_stmt (expr_tree
);
10865 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
10871 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
10875 expand_expr_stmt (expr_tree
);
10879 ffecom_prepare_let_char_ (ffebld_size_known (dest
), source
);
10880 ffecom_prepare_expr_w (NULL_TREE
, dest
);
10882 ffecom_prepare_end ();
10884 ffecom_char_args_ (&dest_tree
, &dest_length
, dest
);
10885 ffecom_let_char_ (dest_tree
, dest_length
, ffebld_size_known (dest
),
10889 /* ffecom_expr -- Transform expr into gcc tree
10892 ffebld expr; // FFE expression.
10893 tree = ffecom_expr(expr);
10895 Recursive descent on expr while making corresponding tree nodes and
10896 attaching type info and such. */
10899 ffecom_expr (ffebld expr
)
10901 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, FALSE
, FALSE
);
10904 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
10907 ffecom_expr_assign (ffebld expr
)
10909 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
10912 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
10915 ffecom_expr_assign_w (ffebld expr
)
10917 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
10920 /* Transform expr for use as into read/write tree and stabilize the
10921 reference. Not for use on CHARACTER expressions.
10923 Recursive descent on expr while making corresponding tree nodes and
10924 attaching type info and such. */
10927 ffecom_expr_rw (tree type
, ffebld expr
)
10929 assert (expr
!= NULL
);
10930 /* Different target types not yet supported. */
10931 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
10933 return stabilize_reference (ffecom_expr (expr
));
10936 /* Transform expr for use as into write tree and stabilize the
10937 reference. Not for use on CHARACTER expressions.
10939 Recursive descent on expr while making corresponding tree nodes and
10940 attaching type info and such. */
10943 ffecom_expr_w (tree type
, ffebld expr
)
10945 assert (expr
!= NULL
);
10946 /* Different target types not yet supported. */
10947 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
10949 return stabilize_reference (ffecom_expr (expr
));
10952 /* Do global stuff. */
10955 ffecom_finish_compile ()
10957 assert (ffecom_outer_function_decl_
== NULL_TREE
);
10958 assert (current_function_decl
== NULL_TREE
);
10960 ffeglobal_drive (ffecom_finish_global_
);
10963 /* Public entry point for front end to access finish_decl. */
10966 ffecom_finish_decl (tree decl
, tree init
, bool is_top_level
)
10968 assert (!is_top_level
);
10969 finish_decl (decl
, init
, FALSE
);
10972 /* Finish a program unit. */
10975 ffecom_finish_progunit ()
10977 ffecom_end_compstmt ();
10979 ffecom_previous_function_decl_
= current_function_decl
;
10980 ffecom_which_entrypoint_decl_
= NULL_TREE
;
10982 finish_function (0);
10985 /* Wrapper for get_identifier. pattern is sprintf-like. */
10988 ffecom_get_invented_identifier (const char *pattern
, ...)
10994 va_start (ap
, pattern
);
10995 if (vasprintf (&nam
, pattern
, ap
) == 0)
10998 decl
= get_identifier (nam
);
11000 IDENTIFIER_INVENTED (decl
) = 1;
11005 ffecom_gfrt_basictype (ffecomGfrt gfrt
)
11007 assert (gfrt
< FFECOM_gfrt
);
11009 switch (ffecom_gfrt_type_
[gfrt
])
11011 case FFECOM_rttypeVOID_
:
11012 case FFECOM_rttypeVOIDSTAR_
:
11013 return FFEINFO_basictypeNONE
;
11015 case FFECOM_rttypeFTNINT_
:
11016 return FFEINFO_basictypeINTEGER
;
11018 case FFECOM_rttypeINTEGER_
:
11019 return FFEINFO_basictypeINTEGER
;
11021 case FFECOM_rttypeLONGINT_
:
11022 return FFEINFO_basictypeINTEGER
;
11024 case FFECOM_rttypeLOGICAL_
:
11025 return FFEINFO_basictypeLOGICAL
;
11027 case FFECOM_rttypeREAL_F2C_
:
11028 case FFECOM_rttypeREAL_GNU_
:
11029 return FFEINFO_basictypeREAL
;
11031 case FFECOM_rttypeCOMPLEX_F2C_
:
11032 case FFECOM_rttypeCOMPLEX_GNU_
:
11033 return FFEINFO_basictypeCOMPLEX
;
11035 case FFECOM_rttypeDOUBLE_
:
11036 case FFECOM_rttypeDOUBLEREAL_
:
11037 return FFEINFO_basictypeREAL
;
11039 case FFECOM_rttypeDBLCMPLX_F2C_
:
11040 case FFECOM_rttypeDBLCMPLX_GNU_
:
11041 return FFEINFO_basictypeCOMPLEX
;
11043 case FFECOM_rttypeCHARACTER_
:
11044 return FFEINFO_basictypeCHARACTER
;
11047 return FFEINFO_basictypeANY
;
11052 ffecom_gfrt_kindtype (ffecomGfrt gfrt
)
11054 assert (gfrt
< FFECOM_gfrt
);
11056 switch (ffecom_gfrt_type_
[gfrt
])
11058 case FFECOM_rttypeVOID_
:
11059 case FFECOM_rttypeVOIDSTAR_
:
11060 return FFEINFO_kindtypeNONE
;
11062 case FFECOM_rttypeFTNINT_
:
11063 return FFEINFO_kindtypeINTEGER1
;
11065 case FFECOM_rttypeINTEGER_
:
11066 return FFEINFO_kindtypeINTEGER1
;
11068 case FFECOM_rttypeLONGINT_
:
11069 return FFEINFO_kindtypeINTEGER4
;
11071 case FFECOM_rttypeLOGICAL_
:
11072 return FFEINFO_kindtypeLOGICAL1
;
11074 case FFECOM_rttypeREAL_F2C_
:
11075 case FFECOM_rttypeREAL_GNU_
:
11076 return FFEINFO_kindtypeREAL1
;
11078 case FFECOM_rttypeCOMPLEX_F2C_
:
11079 case FFECOM_rttypeCOMPLEX_GNU_
:
11080 return FFEINFO_kindtypeREAL1
;
11082 case FFECOM_rttypeDOUBLE_
:
11083 case FFECOM_rttypeDOUBLEREAL_
:
11084 return FFEINFO_kindtypeREAL2
;
11086 case FFECOM_rttypeDBLCMPLX_F2C_
:
11087 case FFECOM_rttypeDBLCMPLX_GNU_
:
11088 return FFEINFO_kindtypeREAL2
;
11090 case FFECOM_rttypeCHARACTER_
:
11091 return FFEINFO_kindtypeCHARACTER1
;
11094 return FFEINFO_kindtypeANY
;
11108 tree double_ftype_double
;
11109 tree float_ftype_float
;
11110 tree ldouble_ftype_ldouble
;
11111 tree ffecom_tree_ptr_to_fun_type_void
;
11113 /* This block of code comes from the now-obsolete cktyps.c. It checks
11114 whether the compiler environment is buggy in known ways, some of which
11115 would, if not explicitly checked here, result in subtle bugs in g77. */
11117 if (ffe_is_do_internal_checks ())
11119 static const char names
[][12]
11121 {"bar", "bletch", "foo", "foobar"};
11126 name
= bsearch ("foo", &names
[0], ARRAY_SIZE (names
), sizeof (names
[0]),
11127 (int (*)(const void *, const void *)) strcmp
);
11128 if (name
!= &names
[2][0])
11130 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11135 ul
= strtoul ("123456789", NULL
, 10);
11136 if (ul
!= 123456789L)
11138 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11139 in proj.h" == NULL
);
11143 fl
= atof ("56.789");
11144 if ((fl
< 56.788) || (fl
> 56.79))
11146 assert ("atof not type double, fix your #include <stdio.h>"
11152 ffecom_outer_function_decl_
= NULL_TREE
;
11153 current_function_decl
= NULL_TREE
;
11154 named_labels
= NULL_TREE
;
11155 current_binding_level
= NULL_BINDING_LEVEL
;
11156 free_binding_level
= NULL_BINDING_LEVEL
;
11157 /* Make the binding_level structure for global names. */
11159 global_binding_level
= current_binding_level
;
11160 current_binding_level
->prep_state
= 2;
11162 build_common_tree_nodes (1);
11164 /* Define `int' and `char' first so that dbx will output them first. */
11165 pushdecl (build_decl (TYPE_DECL
, get_identifier ("int"),
11166 integer_type_node
));
11167 /* CHARACTER*1 is unsigned in ICHAR contexts. */
11168 char_type_node
= make_unsigned_type (CHAR_TYPE_SIZE
);
11169 pushdecl (build_decl (TYPE_DECL
, get_identifier ("char"),
11171 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long int"),
11172 long_integer_type_node
));
11173 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned int"),
11174 unsigned_type_node
));
11175 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long unsigned int"),
11176 long_unsigned_type_node
));
11177 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long int"),
11178 long_long_integer_type_node
));
11179 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long unsigned int"),
11180 long_long_unsigned_type_node
));
11181 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short int"),
11182 short_integer_type_node
));
11183 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short unsigned int"),
11184 short_unsigned_type_node
));
11186 /* Set the sizetype before we make other types. This *should* be the
11187 first type we create. */
11190 (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE
))));
11191 ffecom_typesize_pointer_
11192 = TREE_INT_CST_LOW (TYPE_SIZE (sizetype
)) / BITS_PER_UNIT
;
11194 build_common_tree_nodes_2 (0);
11196 /* Define both `signed char' and `unsigned char'. */
11197 pushdecl (build_decl (TYPE_DECL
, get_identifier ("signed char"),
11198 signed_char_type_node
));
11200 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned char"),
11201 unsigned_char_type_node
));
11203 pushdecl (build_decl (TYPE_DECL
, get_identifier ("float"),
11205 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double"),
11206 double_type_node
));
11207 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long double"),
11208 long_double_type_node
));
11210 /* For now, override what build_common_tree_nodes has done. */
11211 complex_integer_type_node
= ffecom_make_complex_type_ (integer_type_node
);
11212 complex_float_type_node
= ffecom_make_complex_type_ (float_type_node
);
11213 complex_double_type_node
= ffecom_make_complex_type_ (double_type_node
);
11214 complex_long_double_type_node
11215 = ffecom_make_complex_type_ (long_double_type_node
);
11217 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex int"),
11218 complex_integer_type_node
));
11219 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex float"),
11220 complex_float_type_node
));
11221 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex double"),
11222 complex_double_type_node
));
11223 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex long double"),
11224 complex_long_double_type_node
));
11226 pushdecl (build_decl (TYPE_DECL
, get_identifier ("void"),
11228 /* We are not going to have real types in C with less than byte alignment,
11229 so we might as well not have any types that claim to have it. */
11230 TYPE_ALIGN (void_type_node
) = BITS_PER_UNIT
;
11231 TYPE_USER_ALIGN (void_type_node
) = 0;
11233 string_type_node
= build_pointer_type (char_type_node
);
11235 ffecom_tree_fun_type_void
11236 = build_function_type (void_type_node
, NULL_TREE
);
11238 ffecom_tree_ptr_to_fun_type_void
11239 = build_pointer_type (ffecom_tree_fun_type_void
);
11241 endlink
= tree_cons (NULL_TREE
, void_type_node
, NULL_TREE
);
11244 = build_function_type (float_type_node
,
11245 tree_cons (NULL_TREE
, float_type_node
, endlink
));
11247 double_ftype_double
11248 = build_function_type (double_type_node
,
11249 tree_cons (NULL_TREE
, double_type_node
, endlink
));
11251 ldouble_ftype_ldouble
11252 = build_function_type (long_double_type_node
,
11253 tree_cons (NULL_TREE
, long_double_type_node
,
11256 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11257 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11259 ffecom_tree_type
[i
][j
] = NULL_TREE
;
11260 ffecom_tree_fun_type
[i
][j
] = NULL_TREE
;
11261 ffecom_tree_ptr_to_fun_type
[i
][j
] = NULL_TREE
;
11262 ffecom_f2c_typecode_
[i
][j
] = -1;
11265 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11266 to size FLOAT_TYPE_SIZE because they have to be the same size as
11267 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11268 Compiler options and other such stuff that change the ways these
11269 types are set should not affect this particular setup. */
11271 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
]
11272 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
11273 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer"),
11275 type
= ffetype_new ();
11277 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER1
,
11279 ffetype_set_ams (type
,
11280 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11281 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11282 ffetype_set_star (base_type
,
11283 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11285 ffetype_set_kind (base_type
, 1, type
);
11286 ffecom_typesize_integer1_
= ffetype_size (type
);
11287 assert (ffetype_size (type
) == sizeof (ffetargetInteger1
));
11289 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER1
]
11290 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
); /* HOLLERITH means unsigned. */
11291 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned"),
11294 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER2
]
11295 = t
= make_signed_type (CHAR_TYPE_SIZE
);
11296 pushdecl (build_decl (TYPE_DECL
, get_identifier ("byte"),
11298 type
= ffetype_new ();
11299 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER2
,
11301 ffetype_set_ams (type
,
11302 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11303 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11304 ffetype_set_star (base_type
,
11305 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11307 ffetype_set_kind (base_type
, 3, type
);
11308 assert (ffetype_size (type
) == sizeof (ffetargetInteger2
));
11310 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER2
]
11311 = t
= make_unsigned_type (CHAR_TYPE_SIZE
);
11312 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned byte"),
11315 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER3
]
11316 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
11317 pushdecl (build_decl (TYPE_DECL
, get_identifier ("word"),
11319 type
= ffetype_new ();
11320 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER3
,
11322 ffetype_set_ams (type
,
11323 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11324 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11325 ffetype_set_star (base_type
,
11326 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11328 ffetype_set_kind (base_type
, 6, type
);
11329 assert (ffetype_size (type
) == sizeof (ffetargetInteger3
));
11331 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER3
]
11332 = t
= make_unsigned_type (CHAR_TYPE_SIZE
* 2);
11333 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned word"),
11336 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER4
]
11337 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
11338 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer4"),
11340 type
= ffetype_new ();
11341 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER4
,
11343 ffetype_set_ams (type
,
11344 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11345 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11346 ffetype_set_star (base_type
,
11347 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11349 ffetype_set_kind (base_type
, 2, type
);
11350 assert (ffetype_size (type
) == sizeof (ffetargetInteger4
));
11352 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER4
]
11353 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
* 2);
11354 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned4"),
11358 if (ffe_is_do_internal_checks ()
11359 && LONG_TYPE_SIZE
!= FLOAT_TYPE_SIZE
11360 && LONG_TYPE_SIZE
!= CHAR_TYPE_SIZE
11361 && LONG_TYPE_SIZE
!= SHORT_TYPE_SIZE
11362 && LONG_TYPE_SIZE
!= LONG_LONG_TYPE_SIZE
)
11364 fprintf (stderr
, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11369 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL1
]
11370 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
11371 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical"),
11373 type
= ffetype_new ();
11375 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL1
,
11377 ffetype_set_ams (type
,
11378 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11379 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11380 ffetype_set_star (base_type
,
11381 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11383 ffetype_set_kind (base_type
, 1, type
);
11384 assert (ffetype_size (type
) == sizeof (ffetargetLogical1
));
11386 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL2
]
11387 = t
= make_signed_type (CHAR_TYPE_SIZE
);
11388 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical2"),
11390 type
= ffetype_new ();
11391 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL2
,
11393 ffetype_set_ams (type
,
11394 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11395 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11396 ffetype_set_star (base_type
,
11397 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11399 ffetype_set_kind (base_type
, 3, type
);
11400 assert (ffetype_size (type
) == sizeof (ffetargetLogical2
));
11402 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL3
]
11403 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
11404 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical3"),
11406 type
= ffetype_new ();
11407 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL3
,
11409 ffetype_set_ams (type
,
11410 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11411 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11412 ffetype_set_star (base_type
,
11413 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11415 ffetype_set_kind (base_type
, 6, type
);
11416 assert (ffetype_size (type
) == sizeof (ffetargetLogical3
));
11418 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL4
]
11419 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
11420 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical4"),
11422 type
= ffetype_new ();
11423 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL4
,
11425 ffetype_set_ams (type
,
11426 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11427 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11428 ffetype_set_star (base_type
,
11429 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11431 ffetype_set_kind (base_type
, 2, type
);
11432 assert (ffetype_size (type
) == sizeof (ffetargetLogical4
));
11434 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
11435 = t
= make_node (REAL_TYPE
);
11436 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
;
11437 pushdecl (build_decl (TYPE_DECL
, get_identifier ("real"),
11440 type
= ffetype_new ();
11442 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREAL1
,
11444 ffetype_set_ams (type
,
11445 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11446 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11447 ffetype_set_star (base_type
,
11448 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11450 ffetype_set_kind (base_type
, 1, type
);
11451 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
11452 = FFETARGET_f2cTYREAL
;
11453 assert (ffetype_size (type
) == sizeof (ffetargetReal1
));
11455 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREALDOUBLE
]
11456 = t
= make_node (REAL_TYPE
);
11457 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
* 2; /* Always twice REAL. */
11458 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double precision"),
11461 type
= ffetype_new ();
11462 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREALDOUBLE
,
11464 ffetype_set_ams (type
,
11465 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11466 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11467 ffetype_set_star (base_type
,
11468 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11470 ffetype_set_kind (base_type
, 2, type
);
11471 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]
11472 = FFETARGET_f2cTYDREAL
;
11473 assert (ffetype_size (type
) == sizeof (ffetargetReal2
));
11475 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
11476 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]);
11477 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex"),
11479 type
= ffetype_new ();
11481 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREAL1
,
11483 ffetype_set_ams (type
,
11484 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11485 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11486 ffetype_set_star (base_type
,
11487 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11489 ffetype_set_kind (base_type
, 1, type
);
11490 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
11491 = FFETARGET_f2cTYCOMPLEX
;
11492 assert (ffetype_size (type
) == sizeof (ffetargetComplex1
));
11494 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREALDOUBLE
]
11495 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]);
11496 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double complex"),
11498 type
= ffetype_new ();
11499 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREALDOUBLE
,
11501 ffetype_set_ams (type
,
11502 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11503 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11504 ffetype_set_star (base_type
,
11505 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11507 ffetype_set_kind (base_type
, 2,
11509 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL2
]
11510 = FFETARGET_f2cTYDCOMPLEX
;
11511 assert (ffetype_size (type
) == sizeof (ffetargetComplex2
));
11513 /* Make function and ptr-to-function types for non-CHARACTER types. */
11515 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11516 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11518 if ((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
11520 if (i
== FFEINFO_basictypeINTEGER
)
11522 /* Figure out the smallest INTEGER type that can hold
11523 a pointer on this machine. */
11524 if (GET_MODE_SIZE (TYPE_MODE (t
))
11525 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
11527 if ((ffecom_pointer_kind_
== FFEINFO_kindtypeNONE
)
11528 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type
[i
][ffecom_pointer_kind_
]))
11529 > GET_MODE_SIZE (TYPE_MODE (t
))))
11530 ffecom_pointer_kind_
= j
;
11533 else if (i
== FFEINFO_basictypeCOMPLEX
)
11534 t
= void_type_node
;
11535 /* For f2c compatibility, REAL functions are really
11536 implemented as DOUBLE PRECISION. */
11537 else if ((i
== FFEINFO_basictypeREAL
)
11538 && (j
== FFEINFO_kindtypeREAL1
))
11539 t
= ffecom_tree_type
11540 [FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
];
11542 t
= ffecom_tree_fun_type
[i
][j
] = build_function_type (t
,
11544 ffecom_tree_ptr_to_fun_type
[i
][j
] = build_pointer_type (t
);
11548 /* Set up pointer types. */
11550 if (ffecom_pointer_kind_
== FFEINFO_basictypeNONE
)
11551 fatal_error ("no INTEGER type can hold a pointer on this configuration");
11552 else if (0 && ffe_is_do_internal_checks ())
11553 fprintf (stderr
, "Pointer type kt=%d\n", ffecom_pointer_kind_
);
11554 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER
,
11555 FFEINFO_kindtypeINTEGERDEFAULT
),
11557 ffeinfo_type (FFEINFO_basictypeINTEGER
,
11558 ffecom_pointer_kind_
));
11560 if (ffe_is_ugly_assign ())
11561 ffecom_label_kind_
= ffecom_pointer_kind_
; /* Require ASSIGN etc to this. */
11563 ffecom_label_kind_
= FFEINFO_kindtypeINTEGERDEFAULT
;
11564 if (0 && ffe_is_do_internal_checks ())
11565 fprintf (stderr
, "Label type kt=%d\n", ffecom_label_kind_
);
11567 ffecom_integer_type_node
11568 = ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
];
11569 ffecom_integer_zero_node
= convert (ffecom_integer_type_node
,
11570 integer_zero_node
);
11571 ffecom_integer_one_node
= convert (ffecom_integer_type_node
,
11574 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11575 Turns out that by TYLONG, runtime/libI77/lio.h really means
11576 "whatever size an ftnint is". For consistency and sanity,
11577 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11578 all are INTEGER, which we also make out of whatever back-end
11579 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11580 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11581 accommodate machines like the Alpha. Note that this suggests
11582 f2c and libf2c are missing a distinction perhaps needed on
11583 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11585 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, FLOAT_TYPE_SIZE
,
11586 FFETARGET_f2cTYLONG
);
11587 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, SHORT_TYPE_SIZE
,
11588 FFETARGET_f2cTYSHORT
);
11589 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, CHAR_TYPE_SIZE
,
11590 FFETARGET_f2cTYINT1
);
11591 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, LONG_LONG_TYPE_SIZE
,
11592 FFETARGET_f2cTYQUAD
);
11593 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, FLOAT_TYPE_SIZE
,
11594 FFETARGET_f2cTYLOGICAL
);
11595 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, SHORT_TYPE_SIZE
,
11596 FFETARGET_f2cTYLOGICAL2
);
11597 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, CHAR_TYPE_SIZE
,
11598 FFETARGET_f2cTYLOGICAL1
);
11599 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11600 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, LONG_LONG_TYPE_SIZE
,
11601 FFETARGET_f2cTYQUAD
);
11603 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11604 loop. CHARACTER items are built as arrays of unsigned char. */
11606 ffecom_tree_type
[FFEINFO_basictypeCHARACTER
]
11607 [FFEINFO_kindtypeCHARACTER1
] = t
= char_type_node
;
11608 type
= ffetype_new ();
11610 ffeinfo_set_type (FFEINFO_basictypeCHARACTER
,
11611 FFEINFO_kindtypeCHARACTER1
,
11613 ffetype_set_ams (type
,
11614 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11615 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11616 ffetype_set_kind (base_type
, 1, type
);
11617 assert (ffetype_size (type
)
11618 == sizeof (((ffetargetCharacter1
) { 0, NULL
}).text
[0]));
11620 ffecom_tree_fun_type
[FFEINFO_basictypeCHARACTER
]
11621 [FFEINFO_kindtypeCHARACTER1
] = ffecom_tree_fun_type_void
;
11622 ffecom_tree_ptr_to_fun_type
[FFEINFO_basictypeCHARACTER
]
11623 [FFEINFO_kindtypeCHARACTER1
]
11624 = ffecom_tree_ptr_to_fun_type_void
;
11625 ffecom_f2c_typecode_
[FFEINFO_basictypeCHARACTER
][FFEINFO_kindtypeCHARACTER1
]
11626 = FFETARGET_f2cTYCHAR
;
11628 ffecom_f2c_typecode_
[FFEINFO_basictypeANY
][FFEINFO_kindtypeANY
]
11631 /* Make multi-return-value type and fields. */
11633 ffecom_multi_type_node_
= make_node (UNION_TYPE
);
11637 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11638 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11642 if (ffecom_tree_type
[i
][j
] == NULL_TREE
)
11643 continue; /* Not supported. */
11644 sprintf (&name
[0], "bt_%s_kt_%s",
11645 ffeinfo_basictype_string ((ffeinfoBasictype
) i
),
11646 ffeinfo_kindtype_string ((ffeinfoKindtype
) j
));
11647 ffecom_multi_fields_
[i
][j
] = build_decl (FIELD_DECL
,
11648 get_identifier (name
),
11649 ffecom_tree_type
[i
][j
]);
11650 DECL_CONTEXT (ffecom_multi_fields_
[i
][j
])
11651 = ffecom_multi_type_node_
;
11652 DECL_ALIGN (ffecom_multi_fields_
[i
][j
]) = 0;
11653 DECL_USER_ALIGN (ffecom_multi_fields_
[i
][j
]) = 0;
11654 TREE_CHAIN (ffecom_multi_fields_
[i
][j
]) = field
;
11655 field
= ffecom_multi_fields_
[i
][j
];
11658 TYPE_FIELDS (ffecom_multi_type_node_
) = field
;
11659 layout_type (ffecom_multi_type_node_
);
11661 /* Subroutines usually return integer because they might have alternate
11664 ffecom_tree_subr_type
11665 = build_function_type (integer_type_node
, NULL_TREE
);
11666 ffecom_tree_ptr_to_subr_type
11667 = build_pointer_type (ffecom_tree_subr_type
);
11668 ffecom_tree_blockdata_type
11669 = build_function_type (void_type_node
, NULL_TREE
);
11671 builtin_function ("__builtin_sqrtf", float_ftype_float
,
11672 BUILT_IN_SQRTF
, BUILT_IN_NORMAL
, "sqrtf", NULL_TREE
);
11673 builtin_function ("__builtin_sqrt", double_ftype_double
,
11674 BUILT_IN_SQRT
, BUILT_IN_NORMAL
, "sqrt", NULL_TREE
);
11675 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble
,
11676 BUILT_IN_SQRTL
, BUILT_IN_NORMAL
, "sqrtl", NULL_TREE
);
11677 builtin_function ("__builtin_sinf", float_ftype_float
,
11678 BUILT_IN_SINF
, BUILT_IN_NORMAL
, "sinf", NULL_TREE
);
11679 builtin_function ("__builtin_sin", double_ftype_double
,
11680 BUILT_IN_SIN
, BUILT_IN_NORMAL
, "sin", NULL_TREE
);
11681 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble
,
11682 BUILT_IN_SINL
, BUILT_IN_NORMAL
, "sinl", NULL_TREE
);
11683 builtin_function ("__builtin_cosf", float_ftype_float
,
11684 BUILT_IN_COSF
, BUILT_IN_NORMAL
, "cosf", NULL_TREE
);
11685 builtin_function ("__builtin_cos", double_ftype_double
,
11686 BUILT_IN_COS
, BUILT_IN_NORMAL
, "cos", NULL_TREE
);
11687 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble
,
11688 BUILT_IN_COSL
, BUILT_IN_NORMAL
, "cosl", NULL_TREE
);
11690 pedantic_lvalues
= FALSE
;
11692 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node
,
11695 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node
,
11698 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node
,
11701 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node
,
11702 FFECOM_f2cDOUBLEREAL
,
11704 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node
,
11707 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node
,
11708 FFECOM_f2cDOUBLECOMPLEX
,
11710 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node
,
11713 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node
,
11716 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node
,
11719 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node
,
11722 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node
,
11726 ffecom_f2c_ftnlen_zero_node
11727 = convert (ffecom_f2c_ftnlen_type_node
, integer_zero_node
);
11729 ffecom_f2c_ftnlen_one_node
11730 = convert (ffecom_f2c_ftnlen_type_node
, integer_one_node
);
11732 ffecom_f2c_ftnlen_two_node
= build_int_2 (2, 0);
11733 TREE_TYPE (ffecom_f2c_ftnlen_two_node
) = ffecom_integer_type_node
;
11735 ffecom_f2c_ptr_to_ftnlen_type_node
11736 = build_pointer_type (ffecom_f2c_ftnlen_type_node
);
11738 ffecom_f2c_ptr_to_ftnint_type_node
11739 = build_pointer_type (ffecom_f2c_ftnint_type_node
);
11741 ffecom_f2c_ptr_to_integer_type_node
11742 = build_pointer_type (ffecom_f2c_integer_type_node
);
11744 ffecom_f2c_ptr_to_real_type_node
11745 = build_pointer_type (ffecom_f2c_real_type_node
);
11747 ffecom_float_zero_
= build_real (float_type_node
, dconst0
);
11748 ffecom_double_zero_
= build_real (double_type_node
, dconst0
);
11750 REAL_VALUE_TYPE point_5
;
11752 REAL_ARITHMETIC (point_5
, RDIV_EXPR
, dconst1
, dconst2
);
11753 ffecom_float_half_
= build_real (float_type_node
, point_5
);
11754 ffecom_double_half_
= build_real (double_type_node
, point_5
);
11757 /* Do "extern int xargc;". */
11759 ffecom_tree_xargc_
= build_decl (VAR_DECL
,
11760 get_identifier ("f__xargc"),
11761 integer_type_node
);
11762 DECL_EXTERNAL (ffecom_tree_xargc_
) = 1;
11763 TREE_STATIC (ffecom_tree_xargc_
) = 1;
11764 TREE_PUBLIC (ffecom_tree_xargc_
) = 1;
11765 ffecom_tree_xargc_
= start_decl (ffecom_tree_xargc_
, FALSE
);
11766 finish_decl (ffecom_tree_xargc_
, NULL_TREE
, FALSE
);
11768 #if 0 /* This is being fixed, and seems to be working now. */
11769 if ((FLOAT_TYPE_SIZE
!= 32)
11770 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))) != 32))
11772 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11773 (int) FLOAT_TYPE_SIZE
);
11774 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11775 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))));
11776 warning ("properly unless they all are 32 bits wide");
11777 warning ("Please keep this in mind before you report bugs.");
11781 #if 0 /* Code in ste.c that would crash has been commented out. */
11782 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
11783 < TYPE_PRECISION (string_type_node
))
11784 /* I/O will probably crash. */
11785 warning ("configuration: char * holds %d bits, but ftnlen only %d",
11786 TYPE_PRECISION (string_type_node
),
11787 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
));
11790 #if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
11791 if (TYPE_PRECISION (ffecom_integer_type_node
)
11792 < TYPE_PRECISION (string_type_node
))
11793 /* ASSIGN 10 TO I will crash. */
11794 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11795 ASSIGN statement might fail",
11796 TYPE_PRECISION (string_type_node
),
11797 TYPE_PRECISION (ffecom_integer_type_node
));
11801 /* ffecom_init_2 -- Initialize
11803 ffecom_init_2(); */
11808 assert (ffecom_outer_function_decl_
== NULL_TREE
);
11809 assert (current_function_decl
== NULL_TREE
);
11810 assert (ffecom_which_entrypoint_decl_
== NULL_TREE
);
11812 ffecom_master_arglist_
= NULL
;
11814 ffecom_primary_entry_
= NULL
;
11815 ffecom_is_altreturning_
= FALSE
;
11816 ffecom_func_result_
= NULL_TREE
;
11817 ffecom_multi_retval_
= NULL_TREE
;
11820 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11823 ffebld expr; // FFE opITEM list.
11824 tree = ffecom_list_expr(expr);
11826 List of actual args is transformed into corresponding gcc backend list. */
11829 ffecom_list_expr (ffebld expr
)
11832 tree
*plist
= &list
;
11833 tree trail
= NULL_TREE
; /* Append char length args here. */
11834 tree
*ptrail
= &trail
;
11837 while (expr
!= NULL
)
11839 tree texpr
= ffecom_arg_expr (ffebld_head (expr
), &length
);
11841 if (texpr
== error_mark_node
)
11842 return error_mark_node
;
11844 *plist
= build_tree_list (NULL_TREE
, texpr
);
11845 plist
= &TREE_CHAIN (*plist
);
11846 expr
= ffebld_trail (expr
);
11847 if (length
!= NULL_TREE
)
11849 *ptrail
= build_tree_list (NULL_TREE
, length
);
11850 ptrail
= &TREE_CHAIN (*ptrail
);
11859 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11862 ffebld expr; // FFE opITEM list.
11863 tree = ffecom_list_ptr_to_expr(expr);
11865 List of actual args is transformed into corresponding gcc backend list for
11866 use in calling an external procedure (vs. a statement function). */
11869 ffecom_list_ptr_to_expr (ffebld expr
)
11872 tree
*plist
= &list
;
11873 tree trail
= NULL_TREE
; /* Append char length args here. */
11874 tree
*ptrail
= &trail
;
11877 while (expr
!= NULL
)
11879 tree texpr
= ffecom_arg_ptr_to_expr (ffebld_head (expr
), &length
);
11881 if (texpr
== error_mark_node
)
11882 return error_mark_node
;
11884 *plist
= build_tree_list (NULL_TREE
, texpr
);
11885 plist
= &TREE_CHAIN (*plist
);
11886 expr
= ffebld_trail (expr
);
11887 if (length
!= NULL_TREE
)
11889 *ptrail
= build_tree_list (NULL_TREE
, length
);
11890 ptrail
= &TREE_CHAIN (*ptrail
);
11899 /* Obtain gcc's LABEL_DECL tree for label. */
11902 ffecom_lookup_label (ffelab label
)
11906 if (ffelab_hook (label
) == NULL_TREE
)
11908 char labelname
[16];
11910 switch (ffelab_type (label
))
11912 case FFELAB_typeLOOPEND
:
11913 case FFELAB_typeNOTLOOP
:
11914 case FFELAB_typeENDIF
:
11915 sprintf (labelname
, "%" ffelabValue_f
"u", ffelab_value (label
));
11916 glabel
= build_decl (LABEL_DECL
, get_identifier (labelname
),
11918 DECL_CONTEXT (glabel
) = current_function_decl
;
11919 DECL_MODE (glabel
) = VOIDmode
;
11922 case FFELAB_typeFORMAT
:
11923 glabel
= build_decl (VAR_DECL
,
11924 ffecom_get_invented_identifier
11925 ("__g77_format_%d", (int) ffelab_value (label
)),
11926 build_type_variant (build_array_type
11930 TREE_CONSTANT (glabel
) = 1;
11931 TREE_STATIC (glabel
) = 1;
11932 DECL_CONTEXT (glabel
) = current_function_decl
;
11933 DECL_INITIAL (glabel
) = NULL
;
11934 make_decl_rtl (glabel
, NULL
);
11935 expand_decl (glabel
);
11937 ffecom_save_tree_forever (glabel
);
11941 case FFELAB_typeANY
:
11942 glabel
= error_mark_node
;
11946 assert ("bad label type" == NULL
);
11950 ffelab_set_hook (label
, glabel
);
11954 glabel
= ffelab_hook (label
);
11960 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
11961 a single source specification (as in the fourth argument of MVBITS).
11962 If the type is NULL_TREE, the type of lhs is used to make the type of
11963 the MODIFY_EXPR. */
11966 ffecom_modify (tree newtype
, tree lhs
,
11969 if (lhs
== error_mark_node
|| rhs
== error_mark_node
)
11970 return error_mark_node
;
11972 if (newtype
== NULL_TREE
)
11973 newtype
= TREE_TYPE (lhs
);
11975 if (TREE_SIDE_EFFECTS (lhs
))
11976 lhs
= stabilize_reference (lhs
);
11978 return ffecom_2s (MODIFY_EXPR
, newtype
, lhs
, rhs
);
11981 /* Register source file name. */
11984 ffecom_file (const char *name
)
11986 ffecom_file_ (name
);
11989 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
11992 ffecom_notify_init_storage(st);
11994 Gets called when all possible units in an aggregate storage area (a LOCAL
11995 with equivalences or a COMMON) have been initialized. The initialization
11996 info either is in ffestorag_init or, if that is NULL,
11997 ffestorag_accretion:
11999 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
12000 even for an array if the array is one element in length!
12002 ffestorag_accretion will contain an opACCTER. It is much like an
12003 opARRTER except it has an ffebit object in it instead of just a size.
12004 The back end can use the info in the ffebit object, if it wants, to
12005 reduce the amount of actual initialization, but in any case it should
12006 kill the ffebit object when done. Also, set accretion to NULL but
12007 init to a non-NULL value.
12009 After performing initialization, DO NOT set init to NULL, because that'll
12010 tell the front end it is ok for more initialization to happen. Instead,
12011 set init to an opANY expression or some such thing that you can use to
12012 tell that you've already initialized the object.
12015 Support two-pass FFE. */
12018 ffecom_notify_init_storage (ffestorag st
)
12020 ffebld init
; /* The initialization expression. */
12022 if (ffestorag_init (st
) == NULL
)
12024 init
= ffestorag_accretion (st
);
12025 assert (init
!= NULL
);
12026 ffestorag_set_accretion (st
, NULL
);
12027 ffestorag_set_accretes (st
, 0);
12028 ffestorag_set_init (st
, init
);
12032 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12035 ffecom_notify_init_symbol(s);
12037 Gets called when all possible units in a symbol (not placed in COMMON
12038 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12039 have been initialized. The initialization info either is in
12040 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12042 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12043 even for an array if the array is one element in length!
12045 ffesymbol_accretion will contain an opACCTER. It is much like an
12046 opARRTER except it has an ffebit object in it instead of just a size.
12047 The back end can use the info in the ffebit object, if it wants, to
12048 reduce the amount of actual initialization, but in any case it should
12049 kill the ffebit object when done. Also, set accretion to NULL but
12050 init to a non-NULL value.
12052 After performing initialization, DO NOT set init to NULL, because that'll
12053 tell the front end it is ok for more initialization to happen. Instead,
12054 set init to an opANY expression or some such thing that you can use to
12055 tell that you've already initialized the object.
12058 Support two-pass FFE. */
12061 ffecom_notify_init_symbol (ffesymbol s
)
12063 ffebld init
; /* The initialization expression. */
12065 if (ffesymbol_storage (s
) == NULL
)
12066 return; /* Do nothing until COMMON/EQUIVALENCE
12067 possibilities checked. */
12069 if ((ffesymbol_init (s
) == NULL
)
12070 && ((init
= ffesymbol_accretion (s
)) != NULL
))
12072 ffesymbol_set_accretion (s
, NULL
);
12073 ffesymbol_set_accretes (s
, 0);
12074 ffesymbol_set_init (s
, init
);
12078 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12081 ffecom_notify_primary_entry(s);
12083 Gets called when implicit or explicit PROGRAM statement seen or when
12084 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12085 global symbol that serves as the entry point. */
12088 ffecom_notify_primary_entry (ffesymbol s
)
12090 ffecom_primary_entry_
= s
;
12091 ffecom_primary_entry_kind_
= ffesymbol_kind (s
);
12093 if ((ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
12094 || (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
))
12095 ffecom_primary_entry_is_proc_
= TRUE
;
12097 ffecom_primary_entry_is_proc_
= FALSE
;
12099 if (!ffe_is_silent ())
12101 if (ffecom_primary_entry_kind_
== FFEINFO_kindPROGRAM
)
12102 fprintf (stderr
, "%s:\n", ffesymbol_text (s
));
12104 fprintf (stderr
, " %s:\n", ffesymbol_text (s
));
12107 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
12112 for (list
= ffesymbol_dummyargs (s
);
12114 list
= ffebld_trail (list
))
12116 arg
= ffebld_head (list
);
12117 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
12119 ffecom_is_altreturning_
= TRUE
;
12127 ffecom_open_include (char *name
, ffewhereLine l
, ffewhereColumn c
)
12129 return ffecom_open_include_ (name
, l
, c
);
12132 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12135 ffebld expr; // FFE expression.
12136 tree = ffecom_ptr_to_expr(expr);
12138 Like ffecom_expr, but sticks address-of in front of most things. */
12141 ffecom_ptr_to_expr (ffebld expr
)
12144 ffeinfoBasictype bt
;
12145 ffeinfoKindtype kt
;
12148 assert (expr
!= NULL
);
12150 switch (ffebld_op (expr
))
12152 case FFEBLD_opSYMTER
:
12153 s
= ffebld_symter (expr
);
12154 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
12158 ix
= ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr
));
12159 assert (ix
!= FFECOM_gfrt
);
12160 if ((item
= ffecom_gfrt_
[ix
]) == NULL_TREE
)
12162 ffecom_make_gfrt_ (ix
);
12163 item
= ffecom_gfrt_
[ix
];
12168 item
= ffesymbol_hook (s
).decl_tree
;
12169 if (item
== NULL_TREE
)
12171 s
= ffecom_sym_transform_ (s
);
12172 item
= ffesymbol_hook (s
).decl_tree
;
12175 assert (item
!= NULL
);
12176 if (item
== error_mark_node
)
12178 if (!ffesymbol_hook (s
).addr
)
12179 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12183 case FFEBLD_opARRAYREF
:
12184 return ffecom_arrayref_ (NULL_TREE
, expr
, 1);
12186 case FFEBLD_opCONTER
:
12188 bt
= ffeinfo_basictype (ffebld_info (expr
));
12189 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12191 item
= ffecom_constantunion (&ffebld_constant_union
12192 (ffebld_conter (expr
)), bt
, kt
,
12193 ffecom_tree_type
[bt
][kt
]);
12194 if (item
== error_mark_node
)
12195 return error_mark_node
;
12196 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12201 return error_mark_node
;
12204 bt
= ffeinfo_basictype (ffebld_info (expr
));
12205 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12207 item
= ffecom_expr (expr
);
12208 if (item
== error_mark_node
)
12209 return error_mark_node
;
12211 /* The back end currently optimizes a bit too zealously for us, in that
12212 we fail JCB001 if the following block of code is omitted. It checks
12213 to see if the transformed expression is a symbol or array reference,
12214 and encloses it in a SAVE_EXPR if that is the case. */
12217 if ((TREE_CODE (item
) == VAR_DECL
)
12218 || (TREE_CODE (item
) == PARM_DECL
)
12219 || (TREE_CODE (item
) == RESULT_DECL
)
12220 || (TREE_CODE (item
) == INDIRECT_REF
)
12221 || (TREE_CODE (item
) == ARRAY_REF
)
12222 || (TREE_CODE (item
) == COMPONENT_REF
)
12224 || (TREE_CODE (item
) == OFFSET_REF
)
12226 || (TREE_CODE (item
) == BUFFER_REF
)
12227 || (TREE_CODE (item
) == REALPART_EXPR
)
12228 || (TREE_CODE (item
) == IMAGPART_EXPR
))
12230 item
= ffecom_save_tree (item
);
12233 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12238 assert ("fall-through error" == NULL
);
12239 return error_mark_node
;
12242 /* Obtain a temp var with given data type.
12244 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12245 or >= 0 for a CHARACTER type.
12247 elements is -1 for a scalar or > 0 for an array of type. */
12250 ffecom_make_tempvar (const char *commentary
, tree type
,
12251 ffetargetCharacterSize size
, int elements
)
12254 static int mynumber
;
12256 assert (current_binding_level
->prep_state
< 2);
12258 if (type
== error_mark_node
)
12259 return error_mark_node
;
12261 if (size
!= FFETARGET_charactersizeNONE
)
12262 type
= build_array_type (type
,
12263 build_range_type (ffecom_f2c_ftnlen_type_node
,
12264 ffecom_f2c_ftnlen_one_node
,
12265 build_int_2 (size
, 0)));
12266 if (elements
!= -1)
12267 type
= build_array_type (type
,
12268 build_range_type (integer_type_node
,
12270 build_int_2 (elements
- 1,
12272 t
= build_decl (VAR_DECL
,
12273 ffecom_get_invented_identifier ("__g77_%s_%d",
12278 t
= start_decl (t
, FALSE
);
12279 finish_decl (t
, NULL_TREE
, FALSE
);
12284 /* Prepare argument pointer to expression.
12286 Like ffecom_prepare_expr, except for expressions to be evaluated
12287 via ffecom_arg_ptr_to_expr. */
12290 ffecom_prepare_arg_ptr_to_expr (ffebld expr
)
12292 /* ~~For now, it seems to be the same thing. */
12293 ffecom_prepare_expr (expr
);
12297 /* End of preparations. */
12300 ffecom_prepare_end (void)
12302 int prep_state
= current_binding_level
->prep_state
;
12304 assert (prep_state
< 2);
12305 current_binding_level
->prep_state
= 2;
12307 return (prep_state
== 1) ? TRUE
: FALSE
;
12310 /* Prepare expression.
12312 This is called before any code is generated for the current block.
12313 It scans the expression, declares any temporaries that might be needed
12314 during evaluation of the expression, and stores those temporaries in
12315 the appropriate "hook" fields of the expression. `dest', if not NULL,
12316 specifies the destination that ffecom_expr_ will see, in case that
12317 helps avoid generating unused temporaries.
12319 ~~Improve to avoid allocating unused temporaries by taking `dest'
12320 into account vis-a-vis aliasing requirements of complex/character
12324 ffecom_prepare_expr_ (ffebld expr
, ffebld dest UNUSED
)
12326 ffeinfoBasictype bt
;
12327 ffeinfoKindtype kt
;
12328 ffetargetCharacterSize sz
;
12329 tree tempvar
= NULL_TREE
;
12331 assert (current_binding_level
->prep_state
< 2);
12336 bt
= ffeinfo_basictype (ffebld_info (expr
));
12337 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12338 sz
= ffeinfo_size (ffebld_info (expr
));
12340 /* Generate whatever temporaries are needed to represent the result
12341 of the expression. */
12343 if (bt
== FFEINFO_basictypeCHARACTER
)
12345 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
12346 expr
= ffebld_left (expr
);
12349 switch (ffebld_op (expr
))
12352 /* Don't make temps for SYMTER, CONTER, etc. */
12353 if (ffebld_arity (expr
) == 0)
12358 case FFEINFO_basictypeCOMPLEX
:
12359 if (ffebld_op (expr
) == FFEBLD_opFUNCREF
)
12363 if (ffebld_op (ffebld_left (expr
)) != FFEBLD_opSYMTER
)
12366 s
= ffebld_symter (ffebld_left (expr
));
12367 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
12368 || (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
12369 && ! ffesymbol_is_f2c (s
))
12370 || (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
12371 && ! ffe_is_f2c_library ()))
12374 else if (ffebld_op (expr
) == FFEBLD_opPOWER
)
12376 /* Requires special treatment. There's no POW_CC function
12377 in libg2c, so POW_ZZ is used, which means we always
12378 need a double-complex temp, not a single-complex. */
12379 kt
= FFEINFO_kindtypeREAL2
;
12381 else if (ffebld_op (expr
) != FFEBLD_opDIVIDE
)
12382 /* The other ops don't need temps for complex operands. */
12385 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12386 REAL(C). See 19990325-0.f, routine `check', for cases. */
12387 tempvar
= ffecom_make_tempvar ("complex",
12389 [FFEINFO_basictypeCOMPLEX
][kt
],
12390 FFETARGET_charactersizeNONE
,
12394 case FFEINFO_basictypeCHARACTER
:
12395 if (ffebld_op (expr
) != FFEBLD_opFUNCREF
)
12398 if (sz
== FFETARGET_charactersizeNONE
)
12399 /* ~~Kludge alert! This should someday be fixed. */
12402 tempvar
= ffecom_make_tempvar ("char", char_type_node
, sz
, -1);
12410 case FFEBLD_opCONCATENATE
:
12412 /* This gets special handling, because only one set of temps
12413 is needed for a tree of these -- the tree is treated as
12414 a flattened list of concatenations when generating code. */
12416 ffecomConcatList_ catlist
;
12417 tree ltmp
, itmp
, result
;
12421 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
12422 count
= ffecom_concat_list_count_ (catlist
);
12427 = ffecom_make_tempvar ("concat_len",
12428 ffecom_f2c_ftnlen_type_node
,
12429 FFETARGET_charactersizeNONE
, count
);
12431 = ffecom_make_tempvar ("concat_item",
12432 ffecom_f2c_address_type_node
,
12433 FFETARGET_charactersizeNONE
, count
);
12435 = ffecom_make_tempvar ("concat_res",
12437 ffecom_concat_list_maxlen_ (catlist
),
12440 tempvar
= make_tree_vec (3);
12441 TREE_VEC_ELT (tempvar
, 0) = ltmp
;
12442 TREE_VEC_ELT (tempvar
, 1) = itmp
;
12443 TREE_VEC_ELT (tempvar
, 2) = result
;
12446 for (i
= 0; i
< count
; ++i
)
12447 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist
,
12450 ffecom_concat_list_kill_ (catlist
);
12454 ffebld_nonter_set_hook (expr
, tempvar
);
12455 current_binding_level
->prep_state
= 1;
12460 case FFEBLD_opCONVERT
:
12461 if (bt
== FFEINFO_basictypeCHARACTER
12462 && ((ffebld_size_known (ffebld_left (expr
))
12463 == FFETARGET_charactersizeNONE
)
12464 || (ffebld_size_known (ffebld_left (expr
)) >= sz
)))
12465 tempvar
= ffecom_make_tempvar ("convert", char_type_node
, sz
, -1);
12471 ffebld_nonter_set_hook (expr
, tempvar
);
12472 current_binding_level
->prep_state
= 1;
12475 /* Prepare subexpressions for this expr. */
12477 switch (ffebld_op (expr
))
12479 case FFEBLD_opPERCENT_LOC
:
12480 ffecom_prepare_ptr_to_expr (ffebld_left (expr
));
12483 case FFEBLD_opPERCENT_VAL
:
12484 case FFEBLD_opPERCENT_REF
:
12485 ffecom_prepare_expr (ffebld_left (expr
));
12488 case FFEBLD_opPERCENT_DESCR
:
12489 ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr
));
12492 case FFEBLD_opITEM
:
12498 item
= ffebld_trail (item
))
12499 if (ffebld_head (item
) != NULL
)
12500 ffecom_prepare_expr (ffebld_head (item
));
12505 /* Need to handle character conversion specially. */
12506 switch (ffebld_arity (expr
))
12509 ffecom_prepare_expr (ffebld_left (expr
));
12510 ffecom_prepare_expr (ffebld_right (expr
));
12514 ffecom_prepare_expr (ffebld_left (expr
));
12525 /* Prepare expression for reading and writing.
12527 Like ffecom_prepare_expr, except for expressions to be evaluated
12528 via ffecom_expr_rw. */
12531 ffecom_prepare_expr_rw (tree type
, ffebld expr
)
12533 /* This is all we support for now. */
12534 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
12536 /* ~~For now, it seems to be the same thing. */
12537 ffecom_prepare_expr (expr
);
12541 /* Prepare expression for writing.
12543 Like ffecom_prepare_expr, except for expressions to be evaluated
12544 via ffecom_expr_w. */
12547 ffecom_prepare_expr_w (tree type
, ffebld expr
)
12549 /* This is all we support for now. */
12550 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
12552 /* ~~For now, it seems to be the same thing. */
12553 ffecom_prepare_expr (expr
);
12557 /* Prepare expression for returning.
12559 Like ffecom_prepare_expr, except for expressions to be evaluated
12560 via ffecom_return_expr. */
12563 ffecom_prepare_return_expr (ffebld expr
)
12565 assert (current_binding_level
->prep_state
< 2);
12567 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
12568 && ffecom_is_altreturning_
12570 ffecom_prepare_expr (expr
);
12573 /* Prepare pointer to expression.
12575 Like ffecom_prepare_expr, except for expressions to be evaluated
12576 via ffecom_ptr_to_expr. */
12579 ffecom_prepare_ptr_to_expr (ffebld expr
)
12581 /* ~~For now, it seems to be the same thing. */
12582 ffecom_prepare_expr (expr
);
12586 /* Transform expression into constant pointer-to-expression tree.
12588 If the expression can be transformed into a pointer-to-expression tree
12589 that is constant, that is done, and the tree returned. Else NULL_TREE
12592 That way, a caller can attempt to provide compile-time initialization
12593 of a variable and, if that fails, *then* choose to start a new block
12594 and resort to using temporaries, as appropriate. */
12597 ffecom_ptr_to_const_expr (ffebld expr
)
12600 return integer_zero_node
;
12602 if (ffebld_op (expr
) == FFEBLD_opANY
)
12603 return error_mark_node
;
12605 if (ffebld_arity (expr
) == 0
12606 && (ffebld_op (expr
) != FFEBLD_opSYMTER
12607 || ffebld_where (expr
) == FFEINFO_whereCOMMON
12608 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
12609 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
12613 t
= ffecom_ptr_to_expr (expr
);
12614 assert (TREE_CONSTANT (t
));
12621 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12623 tree rtn; // NULL_TREE means use expand_null_return()
12624 ffebld expr; // NULL if no alt return expr to RETURN stmt
12625 rtn = ffecom_return_expr(expr);
12627 Based on the program unit type and other info (like return function
12628 type, return master function type when alternate ENTRY points,
12629 whether subroutine has any alternate RETURN points, etc), returns the
12630 appropriate expression to be returned to the caller, or NULL_TREE
12631 meaning no return value or the caller expects it to be returned somewhere
12632 else (which is handled by other parts of this module). */
12635 ffecom_return_expr (ffebld expr
)
12639 switch (ffecom_primary_entry_kind_
)
12641 case FFEINFO_kindPROGRAM
:
12642 case FFEINFO_kindBLOCKDATA
:
12646 case FFEINFO_kindSUBROUTINE
:
12647 if (!ffecom_is_altreturning_
)
12648 rtn
= NULL_TREE
; /* No alt returns, never an expr. */
12649 else if (expr
== NULL
)
12650 rtn
= integer_zero_node
;
12652 rtn
= ffecom_expr (expr
);
12655 case FFEINFO_kindFUNCTION
:
12656 if ((ffecom_multi_retval_
!= NULL_TREE
)
12657 || (ffesymbol_basictype (ffecom_primary_entry_
)
12658 == FFEINFO_basictypeCHARACTER
)
12659 || ((ffesymbol_basictype (ffecom_primary_entry_
)
12660 == FFEINFO_basictypeCOMPLEX
)
12661 && (ffecom_num_entrypoints_
== 0)
12662 && ffesymbol_is_f2c (ffecom_primary_entry_
)))
12663 { /* Value is returned by direct assignment
12664 into (implicit) dummy. */
12668 rtn
= ffecom_func_result_
;
12670 /* Spurious error if RETURN happens before first reference! So elide
12671 this code. In particular, for debugging registry, rtn should always
12672 be non-null after all, but TREE_USED won't be set until we encounter
12673 a reference in the code. Perfectly okay (but weird) code that,
12674 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12675 this diagnostic for no reason. Have people use -O -Wuninitialized
12676 and leave it to the back end to find obviously weird cases. */
12678 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12679 situation; if the return value has never been referenced, it won't
12680 have a tree under 2pass mode. */
12681 if ((rtn
== NULL_TREE
)
12682 || !TREE_USED (rtn
))
12684 ffebad_start (FFEBAD_RETURN_VALUE_UNSET
);
12685 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_
),
12686 ffesymbol_where_column (ffecom_primary_entry_
));
12687 ffebad_string (ffesymbol_text (ffesymbol_funcresult
12688 (ffecom_primary_entry_
)));
12695 assert ("bad unit kind" == NULL
);
12696 case FFEINFO_kindANY
:
12697 rtn
= error_mark_node
;
12704 /* Do save_expr only if tree is not error_mark_node. */
12707 ffecom_save_tree (tree t
)
12709 return save_expr (t
);
12712 /* Start a compound statement (block). */
12715 ffecom_start_compstmt (void)
12717 bison_rule_pushlevel_ ();
12720 /* Public entry point for front end to access start_decl. */
12723 ffecom_start_decl (tree decl
, bool is_initialized
)
12725 DECL_INITIAL (decl
) = is_initialized
? error_mark_node
: NULL_TREE
;
12726 return start_decl (decl
, FALSE
);
12729 /* ffecom_sym_commit -- Symbol's state being committed to reality
12732 ffecom_sym_commit(s);
12734 Does whatever the backend needs when a symbol is committed after having
12735 been backtrackable for a period of time. */
12738 ffecom_sym_commit (ffesymbol s UNUSED
)
12740 assert (!ffesymbol_retractable ());
12743 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12745 ffecom_sym_end_transition();
12747 Does backend-specific stuff and also calls ffest_sym_end_transition
12748 to do the necessary FFE stuff.
12750 Backtracking is never enabled when this fn is called, so don't worry
12754 ffecom_sym_end_transition (ffesymbol s
)
12758 assert (!ffesymbol_retractable ());
12760 s
= ffest_sym_end_transition (s
);
12762 if ((ffesymbol_kind (s
) == FFEINFO_kindBLOCKDATA
)
12763 && (ffesymbol_where (s
) == FFEINFO_whereGLOBAL
))
12765 ffecom_list_blockdata_
12766 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
12767 FFEINTRIN_specNONE
,
12768 FFEINTRIN_impNONE
),
12769 ffecom_list_blockdata_
);
12772 /* This is where we finally notice that a symbol has partial initialization
12773 and finalize it. */
12775 if (ffesymbol_accretion (s
) != NULL
)
12777 assert (ffesymbol_init (s
) == NULL
);
12778 ffecom_notify_init_symbol (s
);
12780 else if (((st
= ffesymbol_storage (s
)) != NULL
)
12781 && ((st
= ffestorag_parent (st
)) != NULL
)
12782 && (ffestorag_accretion (st
) != NULL
))
12784 assert (ffestorag_init (st
) == NULL
);
12785 ffecom_notify_init_storage (st
);
12788 if ((ffesymbol_kind (s
) == FFEINFO_kindCOMMON
)
12789 && (ffesymbol_where (s
) == FFEINFO_whereLOCAL
)
12790 && (ffesymbol_storage (s
) != NULL
))
12792 ffecom_list_common_
12793 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
12794 FFEINTRIN_specNONE
,
12795 FFEINTRIN_impNONE
),
12796 ffecom_list_common_
);
12802 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12804 ffecom_sym_exec_transition();
12806 Does backend-specific stuff and also calls ffest_sym_exec_transition
12807 to do the necessary FFE stuff.
12809 See the long-winded description in ffecom_sym_learned for info
12810 on handling the situation where backtracking is inhibited. */
12813 ffecom_sym_exec_transition (ffesymbol s
)
12815 s
= ffest_sym_exec_transition (s
);
12820 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12823 s = ffecom_sym_learned(s);
12825 Called when a new symbol is seen after the exec transition or when more
12826 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
12827 it arrives here is that all its latest info is updated already, so its
12828 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12829 field filled in if its gone through here or exec_transition first, and
12832 The backend probably wants to check ffesymbol_retractable() to see if
12833 backtracking is in effect. If so, the FFE's changes to the symbol may
12834 be retracted (undone) or committed (ratified), at which time the
12835 appropriate ffecom_sym_retract or _commit function will be called
12838 If the backend has its own backtracking mechanism, great, use it so that
12839 committal is a simple operation. Though it doesn't make much difference,
12840 I suppose: the reason for tentative symbol evolution in the FFE is to
12841 enable error detection in weird incorrect statements early and to disable
12842 incorrect error detection on a correct statement. The backend is not
12843 likely to introduce any information that'll get involved in these
12844 considerations, so it is probably just fine that the implementation
12845 model for this fn and for _exec_transition is to not do anything
12846 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12847 and instead wait until ffecom_sym_commit is called (which it never
12848 will be as long as we're using ambiguity-detecting statement analysis in
12849 the FFE, which we are initially to shake out the code, but don't depend
12850 on this), otherwise go ahead and do whatever is needed.
12852 In essence, then, when this fn and _exec_transition get called while
12853 backtracking is enabled, a general mechanism would be to flag which (or
12854 both) of these were called (and in what order? neat question as to what
12855 might happen that I'm too lame to think through right now) and then when
12856 _commit is called reproduce the original calling sequence, if any, for
12857 the two fns (at which point backtracking will, of course, be disabled). */
12860 ffecom_sym_learned (ffesymbol s
)
12862 ffestorag_exec_layout (s
);
12867 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12870 ffecom_sym_retract(s);
12872 Does whatever the backend needs when a symbol is retracted after having
12873 been backtrackable for a period of time. */
12876 ffecom_sym_retract (ffesymbol s UNUSED
)
12878 assert (!ffesymbol_retractable ());
12880 #if 0 /* GCC doesn't commit any backtrackable sins,
12881 so nothing needed here. */
12882 switch (ffesymbol_hook (s
).state
)
12884 case 0: /* nothing happened yet. */
12887 case 1: /* exec transition happened. */
12890 case 2: /* learned happened. */
12893 case 3: /* learned then exec. */
12896 case 4: /* exec then learned. */
12900 assert ("bad hook state" == NULL
);
12906 /* Create temporary gcc label. */
12909 ffecom_temp_label ()
12912 static int mynumber
= 0;
12914 glabel
= build_decl (LABEL_DECL
,
12915 ffecom_get_invented_identifier ("__g77_label_%d",
12918 DECL_CONTEXT (glabel
) = current_function_decl
;
12919 DECL_MODE (glabel
) = VOIDmode
;
12924 /* Return an expression that is usable as an arg in a conditional context
12925 (IF, DO WHILE, .NOT., and so on).
12927 Use the one provided for the back end as of >2.6.0. */
12930 ffecom_truth_value (tree expr
)
12932 return ffe_truthvalue_conversion (expr
);
12935 /* Return the inversion of a truth value (the inversion of what
12936 ffecom_truth_value builds).
12938 Apparently invert_truthvalue, which is properly in the back end, is
12939 enough for now, so just use it. */
12942 ffecom_truth_value_invert (tree expr
)
12944 return invert_truthvalue (ffecom_truth_value (expr
));
12947 /* Return the tree that is the type of the expression, as would be
12948 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
12949 transforming the expression, generating temporaries, etc. */
12952 ffecom_type_expr (ffebld expr
)
12954 ffeinfoBasictype bt
;
12955 ffeinfoKindtype kt
;
12958 assert (expr
!= NULL
);
12960 bt
= ffeinfo_basictype (ffebld_info (expr
));
12961 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12962 tree_type
= ffecom_tree_type
[bt
][kt
];
12964 switch (ffebld_op (expr
))
12966 case FFEBLD_opCONTER
:
12967 case FFEBLD_opSYMTER
:
12968 case FFEBLD_opARRAYREF
:
12969 case FFEBLD_opUPLUS
:
12970 case FFEBLD_opPAREN
:
12971 case FFEBLD_opUMINUS
:
12973 case FFEBLD_opSUBTRACT
:
12974 case FFEBLD_opMULTIPLY
:
12975 case FFEBLD_opDIVIDE
:
12976 case FFEBLD_opPOWER
:
12978 case FFEBLD_opFUNCREF
:
12979 case FFEBLD_opSUBRREF
:
12983 case FFEBLD_opNEQV
:
12985 case FFEBLD_opCONVERT
:
12992 case FFEBLD_opPERCENT_LOC
:
12995 case FFEBLD_opACCTER
:
12996 case FFEBLD_opARRTER
:
12997 case FFEBLD_opITEM
:
12998 case FFEBLD_opSTAR
:
12999 case FFEBLD_opBOUNDS
:
13000 case FFEBLD_opREPEAT
:
13001 case FFEBLD_opLABTER
:
13002 case FFEBLD_opLABTOK
:
13003 case FFEBLD_opIMPDO
:
13004 case FFEBLD_opCONCATENATE
:
13005 case FFEBLD_opSUBSTR
:
13007 assert ("bad op for ffecom_type_expr" == NULL
);
13008 /* Fall through. */
13010 return error_mark_node
;
13014 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13016 If the PARM_DECL already exists, return it, else create it. It's an
13017 integer_type_node argument for the master function that implements a
13018 subroutine or function with more than one entrypoint and is bound at
13019 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13020 first ENTRY statement, and so on). */
13023 ffecom_which_entrypoint_decl ()
13025 assert (ffecom_which_entrypoint_decl_
!= NULL_TREE
);
13027 return ffecom_which_entrypoint_decl_
;
13030 /* The following sections consists of private and public functions
13031 that have the same names and perform roughly the same functions
13032 as counterparts in the C front end. Changes in the C front end
13033 might affect how things should be done here. Only functions
13034 needed by the back end should be public here; the rest should
13035 be private (static in the C sense). Functions needed by other
13036 g77 front-end modules should be accessed by them via public
13037 ffecom_* names, which should themselves call private versions
13038 in this section so the private versions are easy to recognize
13039 when upgrading to a new gcc and finding interesting changes
13042 Functions named after rule "foo:" in c-parse.y are named
13043 "bison_rule_foo_" so they are easy to find. */
13046 bison_rule_pushlevel_ ()
13048 emit_line_note (input_filename
, lineno
);
13050 clear_last_expr ();
13051 expand_start_bindings (0);
13055 bison_rule_compstmt_ ()
13058 int keep
= kept_level_p ();
13060 /* Make the temps go away. */
13062 current_binding_level
->names
= NULL_TREE
;
13064 emit_line_note (input_filename
, lineno
);
13065 expand_end_bindings (getdecls (), keep
, 0);
13066 t
= poplevel (keep
, 1, 0);
13071 /* Return a definition for a builtin function named NAME and whose data type
13072 is TYPE. TYPE should be a function type with argument types.
13073 FUNCTION_CODE tells later passes how to compile calls to this function.
13074 See tree.h for its possible values.
13076 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13077 the name to be called if we can't opencode the function. If
13078 ATTRS is nonzero, use that for the function's attribute list. */
13081 builtin_function (const char *name
, tree type
, int function_code
,
13082 enum built_in_class
class,
13083 const char *library_name
,
13084 tree attrs ATTRIBUTE_UNUSED
)
13086 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
13087 DECL_EXTERNAL (decl
) = 1;
13088 TREE_PUBLIC (decl
) = 1;
13090 SET_DECL_ASSEMBLER_NAME (decl
, get_identifier (library_name
));
13091 make_decl_rtl (decl
, NULL
);
13093 DECL_BUILT_IN_CLASS (decl
) = class;
13094 DECL_FUNCTION_CODE (decl
) = function_code
;
13099 /* Handle when a new declaration NEWDECL
13100 has the same name as an old one OLDDECL
13101 in the same binding contour.
13102 Prints an error message if appropriate.
13104 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13105 Otherwise, return 0. */
13108 duplicate_decls (tree newdecl
, tree olddecl
)
13110 int types_match
= 1;
13111 int new_is_definition
= (TREE_CODE (newdecl
) == FUNCTION_DECL
13112 && DECL_INITIAL (newdecl
) != 0);
13113 tree oldtype
= TREE_TYPE (olddecl
);
13114 tree newtype
= TREE_TYPE (newdecl
);
13116 if (olddecl
== newdecl
)
13119 if (TREE_CODE (newtype
) == ERROR_MARK
13120 || TREE_CODE (oldtype
) == ERROR_MARK
)
13123 /* New decl is completely inconsistent with the old one =>
13124 tell caller to replace the old one.
13125 This is always an error except in the case of shadowing a builtin. */
13126 if (TREE_CODE (olddecl
) != TREE_CODE (newdecl
))
13129 /* For real parm decl following a forward decl,
13130 return 1 so old decl will be reused. */
13131 if (types_match
&& TREE_CODE (newdecl
) == PARM_DECL
13132 && TREE_ASM_WRITTEN (olddecl
) && ! TREE_ASM_WRITTEN (newdecl
))
13135 /* The new declaration is the same kind of object as the old one.
13136 The declarations may partially match. Print warnings if they don't
13137 match enough. Ultimately, copy most of the information from the new
13138 decl to the old one, and keep using the old one. */
13140 if (TREE_CODE (olddecl
) == FUNCTION_DECL
13141 && DECL_BUILT_IN (olddecl
))
13143 /* A function declaration for a built-in function. */
13144 if (!TREE_PUBLIC (newdecl
))
13146 else if (!types_match
)
13148 /* Accept the return type of the new declaration if same modes. */
13149 tree oldreturntype
= TREE_TYPE (TREE_TYPE (olddecl
));
13150 tree newreturntype
= TREE_TYPE (TREE_TYPE (newdecl
));
13152 if (TYPE_MODE (oldreturntype
) == TYPE_MODE (newreturntype
))
13154 /* Function types may be shared, so we can't just modify
13155 the return type of olddecl's function type. */
13157 = build_function_type (newreturntype
,
13158 TYPE_ARG_TYPES (TREE_TYPE (olddecl
)));
13162 TREE_TYPE (olddecl
) = newtype
;
13168 else if (TREE_CODE (olddecl
) == FUNCTION_DECL
13169 && DECL_SOURCE_LINE (olddecl
) == 0)
13171 /* A function declaration for a predeclared function
13172 that isn't actually built in. */
13173 if (!TREE_PUBLIC (newdecl
))
13175 else if (!types_match
)
13177 /* If the types don't match, preserve volatility indication.
13178 Later on, we will discard everything else about the
13179 default declaration. */
13180 TREE_THIS_VOLATILE (newdecl
) |= TREE_THIS_VOLATILE (olddecl
);
13184 /* Copy all the DECL_... slots specified in the new decl
13185 except for any that we copy here from the old type.
13187 Past this point, we don't change OLDTYPE and NEWTYPE
13188 even if we change the types of NEWDECL and OLDDECL. */
13192 /* Merge the data types specified in the two decls. */
13193 if (TREE_CODE (newdecl
) != FUNCTION_DECL
|| !DECL_BUILT_IN (olddecl
))
13194 TREE_TYPE (newdecl
)
13195 = TREE_TYPE (olddecl
)
13196 = TREE_TYPE (newdecl
);
13198 /* Lay the type out, unless already done. */
13199 if (oldtype
!= TREE_TYPE (newdecl
))
13201 if (TREE_TYPE (newdecl
) != error_mark_node
)
13202 layout_type (TREE_TYPE (newdecl
));
13203 if (TREE_CODE (newdecl
) != FUNCTION_DECL
13204 && TREE_CODE (newdecl
) != TYPE_DECL
13205 && TREE_CODE (newdecl
) != CONST_DECL
)
13206 layout_decl (newdecl
, 0);
13210 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13211 DECL_SIZE (newdecl
) = DECL_SIZE (olddecl
);
13212 DECL_SIZE_UNIT (newdecl
) = DECL_SIZE_UNIT (olddecl
);
13213 if (TREE_CODE (olddecl
) != FUNCTION_DECL
)
13214 if (DECL_ALIGN (olddecl
) > DECL_ALIGN (newdecl
))
13216 DECL_ALIGN (newdecl
) = DECL_ALIGN (olddecl
);
13217 DECL_USER_ALIGN (newdecl
) |= DECL_USER_ALIGN (olddecl
);
13221 /* Keep the old rtl since we can safely use it. */
13222 COPY_DECL_RTL (olddecl
, newdecl
);
13224 /* Merge the type qualifiers. */
13225 if (DECL_BUILT_IN_NONANSI (olddecl
) && TREE_THIS_VOLATILE (olddecl
)
13226 && !TREE_THIS_VOLATILE (newdecl
))
13227 TREE_THIS_VOLATILE (olddecl
) = 0;
13228 if (TREE_READONLY (newdecl
))
13229 TREE_READONLY (olddecl
) = 1;
13230 if (TREE_THIS_VOLATILE (newdecl
))
13232 TREE_THIS_VOLATILE (olddecl
) = 1;
13233 if (TREE_CODE (newdecl
) == VAR_DECL
)
13234 make_var_volatile (newdecl
);
13237 /* Keep source location of definition rather than declaration.
13238 Likewise, keep decl at outer scope. */
13239 if ((DECL_INITIAL (newdecl
) == 0 && DECL_INITIAL (olddecl
) != 0)
13240 || (DECL_CONTEXT (newdecl
) != 0 && DECL_CONTEXT (olddecl
) == 0))
13242 DECL_SOURCE_LINE (newdecl
) = DECL_SOURCE_LINE (olddecl
);
13243 DECL_SOURCE_FILE (newdecl
) = DECL_SOURCE_FILE (olddecl
);
13245 if (DECL_CONTEXT (olddecl
) == 0
13246 && TREE_CODE (newdecl
) != FUNCTION_DECL
)
13247 DECL_CONTEXT (newdecl
) = 0;
13250 /* Merge the unused-warning information. */
13251 if (DECL_IN_SYSTEM_HEADER (olddecl
))
13252 DECL_IN_SYSTEM_HEADER (newdecl
) = 1;
13253 else if (DECL_IN_SYSTEM_HEADER (newdecl
))
13254 DECL_IN_SYSTEM_HEADER (olddecl
) = 1;
13256 /* Merge the initialization information. */
13257 if (DECL_INITIAL (newdecl
) == 0)
13258 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13260 /* Merge the section attribute.
13261 We want to issue an error if the sections conflict but that must be
13262 done later in decl_attributes since we are called before attributes
13264 if (DECL_SECTION_NAME (newdecl
) == NULL_TREE
)
13265 DECL_SECTION_NAME (newdecl
) = DECL_SECTION_NAME (olddecl
);
13267 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13269 DECL_STATIC_CONSTRUCTOR(newdecl
) |= DECL_STATIC_CONSTRUCTOR(olddecl
);
13270 DECL_STATIC_DESTRUCTOR (newdecl
) |= DECL_STATIC_DESTRUCTOR (olddecl
);
13273 /* If cannot merge, then use the new type and qualifiers,
13274 and don't preserve the old rtl. */
13277 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13278 TREE_READONLY (olddecl
) = TREE_READONLY (newdecl
);
13279 TREE_THIS_VOLATILE (olddecl
) = TREE_THIS_VOLATILE (newdecl
);
13280 TREE_SIDE_EFFECTS (olddecl
) = TREE_SIDE_EFFECTS (newdecl
);
13283 /* Merge the storage class information. */
13284 /* For functions, static overrides non-static. */
13285 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13287 TREE_PUBLIC (newdecl
) &= TREE_PUBLIC (olddecl
);
13288 /* This is since we don't automatically
13289 copy the attributes of NEWDECL into OLDDECL. */
13290 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13291 /* If this clears `static', clear it in the identifier too. */
13292 if (! TREE_PUBLIC (olddecl
))
13293 TREE_PUBLIC (DECL_NAME (olddecl
)) = 0;
13295 if (DECL_EXTERNAL (newdecl
))
13297 TREE_STATIC (newdecl
) = TREE_STATIC (olddecl
);
13298 DECL_EXTERNAL (newdecl
) = DECL_EXTERNAL (olddecl
);
13299 /* An extern decl does not override previous storage class. */
13300 TREE_PUBLIC (newdecl
) = TREE_PUBLIC (olddecl
);
13304 TREE_STATIC (olddecl
) = TREE_STATIC (newdecl
);
13305 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13308 /* If either decl says `inline', this fn is inline,
13309 unless its definition was passed already. */
13310 if (DECL_INLINE (newdecl
) && DECL_INITIAL (olddecl
) == 0)
13311 DECL_INLINE (olddecl
) = 1;
13312 DECL_INLINE (newdecl
) = DECL_INLINE (olddecl
);
13314 /* Get rid of any built-in function if new arg types don't match it
13315 or if we have a function definition. */
13316 if (TREE_CODE (newdecl
) == FUNCTION_DECL
13317 && DECL_BUILT_IN (olddecl
)
13318 && (!types_match
|| new_is_definition
))
13320 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13321 DECL_BUILT_IN_CLASS (olddecl
) = NOT_BUILT_IN
;
13324 /* If redeclaring a builtin function, and not a definition,
13326 Also preserve various other info from the definition. */
13327 if (TREE_CODE (newdecl
) == FUNCTION_DECL
&& !new_is_definition
)
13329 if (DECL_BUILT_IN (olddecl
))
13331 DECL_BUILT_IN_CLASS (newdecl
) = DECL_BUILT_IN_CLASS (olddecl
);
13332 DECL_FUNCTION_CODE (newdecl
) = DECL_FUNCTION_CODE (olddecl
);
13335 DECL_RESULT (newdecl
) = DECL_RESULT (olddecl
);
13336 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13337 DECL_SAVED_INSNS (newdecl
) = DECL_SAVED_INSNS (olddecl
);
13338 DECL_ARGUMENTS (newdecl
) = DECL_ARGUMENTS (olddecl
);
13341 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13342 But preserve olddecl's DECL_UID. */
13344 register unsigned olddecl_uid
= DECL_UID (olddecl
);
13346 memcpy ((char *) olddecl
+ sizeof (struct tree_common
),
13347 (char *) newdecl
+ sizeof (struct tree_common
),
13348 sizeof (struct tree_decl
) - sizeof (struct tree_common
));
13349 DECL_UID (olddecl
) = olddecl_uid
;
13355 /* Finish processing of a declaration;
13356 install its initial value.
13357 If the length of an array type is not known before,
13358 it must be determined now, from the initial value, or it is an error. */
13361 finish_decl (tree decl
, tree init
, bool is_top_level
)
13363 register tree type
= TREE_TYPE (decl
);
13364 int was_incomplete
= (DECL_SIZE (decl
) == 0);
13365 bool at_top_level
= (current_binding_level
== global_binding_level
);
13366 bool top_level
= is_top_level
|| at_top_level
;
13368 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13370 assert (!is_top_level
|| !at_top_level
);
13372 if (TREE_CODE (decl
) == PARM_DECL
)
13373 assert (init
== NULL_TREE
);
13374 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13375 overlaps DECL_ARG_TYPE. */
13376 else if (init
== NULL_TREE
)
13377 assert (DECL_INITIAL (decl
) == NULL_TREE
);
13379 assert (DECL_INITIAL (decl
) == error_mark_node
);
13381 if (init
!= NULL_TREE
)
13383 if (TREE_CODE (decl
) != TYPE_DECL
)
13384 DECL_INITIAL (decl
) = init
;
13387 /* typedef foo = bar; store the type of bar as the type of foo. */
13388 TREE_TYPE (decl
) = TREE_TYPE (init
);
13389 DECL_INITIAL (decl
) = init
= 0;
13393 /* Deduce size of array from initialization, if not already known */
13395 if (TREE_CODE (type
) == ARRAY_TYPE
13396 && TYPE_DOMAIN (type
) == 0
13397 && TREE_CODE (decl
) != TYPE_DECL
)
13399 assert (top_level
);
13400 assert (was_incomplete
);
13402 layout_decl (decl
, 0);
13405 if (TREE_CODE (decl
) == VAR_DECL
)
13407 if (DECL_SIZE (decl
) == NULL_TREE
13408 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
13409 layout_decl (decl
, 0);
13411 if (DECL_SIZE (decl
) == NULL_TREE
13412 && (TREE_STATIC (decl
)
13414 /* A static variable with an incomplete type is an error if it is
13415 initialized. Also if it is not file scope. Otherwise, let it
13416 through, but if it is not `extern' then it may cause an error
13418 (DECL_INITIAL (decl
) != 0 || DECL_CONTEXT (decl
) != 0)
13420 /* An automatic variable with an incomplete type is an error. */
13421 !DECL_EXTERNAL (decl
)))
13423 assert ("storage size not known" == NULL
);
13427 if ((DECL_EXTERNAL (decl
) || TREE_STATIC (decl
))
13428 && (DECL_SIZE (decl
) != 0)
13429 && (TREE_CODE (DECL_SIZE (decl
)) != INTEGER_CST
))
13431 assert ("storage size not constant" == NULL
);
13436 /* Output the assembler code and/or RTL code for variables and functions,
13437 unless the type is an undefined structure or union. If not, it will get
13438 done when the type is completed. */
13440 if (TREE_CODE (decl
) == VAR_DECL
|| TREE_CODE (decl
) == FUNCTION_DECL
)
13442 rest_of_decl_compilation (decl
, NULL
,
13443 DECL_CONTEXT (decl
) == 0,
13446 if (DECL_CONTEXT (decl
) != 0)
13448 /* Recompute the RTL of a local array now if it used to be an
13449 incomplete type. */
13451 && !TREE_STATIC (decl
) && !DECL_EXTERNAL (decl
))
13453 /* If we used it already as memory, it must stay in memory. */
13454 TREE_ADDRESSABLE (decl
) = TREE_USED (decl
);
13455 /* If it's still incomplete now, no init will save it. */
13456 if (DECL_SIZE (decl
) == 0)
13457 DECL_INITIAL (decl
) = 0;
13458 expand_decl (decl
);
13460 /* Compute and store the initial value. */
13461 if (TREE_CODE (decl
) != FUNCTION_DECL
)
13462 expand_decl_init (decl
);
13465 else if (TREE_CODE (decl
) == TYPE_DECL
)
13467 rest_of_decl_compilation (decl
, NULL
,
13468 DECL_CONTEXT (decl
) == 0,
13472 /* At the end of a declaration, throw away any variable type sizes of types
13473 defined inside that declaration. There is no use computing them in the
13474 following function definition. */
13475 if (current_binding_level
== global_binding_level
)
13476 get_pending_sizes ();
13479 /* Finish up a function declaration and compile that function
13480 all the way to assembler language output. The free the storage
13481 for the function definition.
13483 This is called after parsing the body of the function definition.
13485 NESTED is nonzero if the function being finished is nested in another. */
13488 finish_function (int nested
)
13490 register tree fndecl
= current_function_decl
;
13492 assert (fndecl
!= NULL_TREE
);
13493 if (TREE_CODE (fndecl
) != ERROR_MARK
)
13496 assert (DECL_CONTEXT (fndecl
) != NULL_TREE
);
13498 assert (DECL_CONTEXT (fndecl
) == NULL_TREE
);
13501 /* TREE_READONLY (fndecl) = 1;
13502 This caused &foo to be of type ptr-to-const-function
13503 which then got a warning when stored in a ptr-to-function variable. */
13505 poplevel (1, 0, 1);
13507 if (TREE_CODE (fndecl
) != ERROR_MARK
)
13509 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
13511 /* Must mark the RESULT_DECL as being in this function. */
13513 DECL_CONTEXT (DECL_RESULT (fndecl
)) = fndecl
;
13515 /* Obey `register' declarations if `setjmp' is called in this fn. */
13516 /* Generate rtl for function exit. */
13517 expand_function_end (input_filename
, lineno
, 0);
13519 /* If this is a nested function, protect the local variables in the stack
13520 above us from being collected while we're compiling this function. */
13522 ggc_push_context ();
13524 /* Run the optimizers and output the assembler code for this function. */
13525 rest_of_compilation (fndecl
);
13527 /* Undo the GC context switch. */
13529 ggc_pop_context ();
13532 if (TREE_CODE (fndecl
) != ERROR_MARK
13534 && DECL_SAVED_INSNS (fndecl
) == 0)
13536 /* Stop pointing to the local nodes about to be freed. */
13537 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13538 function definition. */
13539 /* For a nested function, this is done in pop_f_function_context. */
13540 /* If rest_of_compilation set this to 0, leave it 0. */
13541 if (DECL_INITIAL (fndecl
) != 0)
13542 DECL_INITIAL (fndecl
) = error_mark_node
;
13543 DECL_ARGUMENTS (fndecl
) = 0;
13548 /* Let the error reporting routines know that we're outside a function.
13549 For a nested function, this value is used in pop_c_function_context
13550 and then reset via pop_function_context. */
13551 ffecom_outer_function_decl_
= current_function_decl
= NULL
;
13555 /* Plug-in replacement for identifying the name of a decl and, for a
13556 function, what we call it in diagnostics. For now, "program unit"
13557 should suffice, since it's a bit of a hassle to figure out which
13558 of several kinds of things it is. Note that it could conceivably
13559 be a statement function, which probably isn't really a program unit
13560 per se, but if that comes up, it should be easy to check (being a
13561 nested function and all). */
13563 static const char *
13564 ffe_printable_name (tree decl
, int v
)
13566 /* Just to keep GCC quiet about the unused variable.
13567 In theory, differing values of V should produce different
13572 if (TREE_CODE (decl
) == ERROR_MARK
)
13573 return "erroneous code";
13574 return IDENTIFIER_POINTER (DECL_NAME (decl
));
13578 /* g77's function to print out name of current function that caused
13582 ffe_print_error_function (diagnostic_context
*context
__attribute__((unused
)),
13585 static ffeglobal last_g
= NULL
;
13586 static ffesymbol last_s
= NULL
;
13591 if ((ffecom_primary_entry_
== NULL
)
13592 || (ffesymbol_global (ffecom_primary_entry_
) == NULL
))
13600 g
= ffesymbol_global (ffecom_primary_entry_
);
13601 if (ffecom_nested_entry_
== NULL
)
13603 s
= ffecom_primary_entry_
;
13604 kind
= _(ffeinfo_kind_message (ffesymbol_kind (s
)));
13608 s
= ffecom_nested_entry_
;
13609 kind
= _("In statement function");
13613 if ((last_g
!= g
) || (last_s
!= s
))
13616 fprintf (stderr
, "%s: ", file
);
13619 fprintf (stderr
, _("Outside of any program unit:\n"));
13622 const char *name
= ffesymbol_text (s
);
13624 fprintf (stderr
, "%s `%s':\n", kind
, name
);
13632 /* Similar to `lookup_name' but look only at current binding level. */
13635 lookup_name_current_level (tree name
)
13639 if (current_binding_level
== global_binding_level
)
13640 return IDENTIFIER_GLOBAL_VALUE (name
);
13642 if (IDENTIFIER_LOCAL_VALUE (name
) == 0)
13645 for (t
= current_binding_level
->names
; t
; t
= TREE_CHAIN (t
))
13646 if (DECL_NAME (t
) == name
)
13652 /* Create a new `struct f_binding_level'. */
13654 static struct f_binding_level
*
13655 make_binding_level ()
13658 return ggc_alloc (sizeof (struct f_binding_level
));
13661 /* Save and restore the variables in this file and elsewhere
13662 that keep track of the progress of compilation of the current function.
13663 Used for nested functions. */
13667 struct f_function
*next
;
13669 tree shadowed_labels
;
13670 struct f_binding_level
*binding_level
;
13673 struct f_function
*f_function_chain
;
13675 /* Restore the variables used during compilation of a C function. */
13678 pop_f_function_context ()
13680 struct f_function
*p
= f_function_chain
;
13683 /* Bring back all the labels that were shadowed. */
13684 for (link
= shadowed_labels
; link
; link
= TREE_CHAIN (link
))
13685 if (DECL_NAME (TREE_VALUE (link
)) != 0)
13686 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link
)))
13687 = TREE_VALUE (link
);
13689 if (current_function_decl
!= error_mark_node
13690 && DECL_SAVED_INSNS (current_function_decl
) == 0)
13692 /* Stop pointing to the local nodes about to be freed. */
13693 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13694 function definition. */
13695 DECL_INITIAL (current_function_decl
) = error_mark_node
;
13696 DECL_ARGUMENTS (current_function_decl
) = 0;
13699 pop_function_context ();
13701 f_function_chain
= p
->next
;
13703 named_labels
= p
->named_labels
;
13704 shadowed_labels
= p
->shadowed_labels
;
13705 current_binding_level
= p
->binding_level
;
13710 /* Save and reinitialize the variables
13711 used during compilation of a C function. */
13714 push_f_function_context ()
13716 struct f_function
*p
13717 = (struct f_function
*) xmalloc (sizeof (struct f_function
));
13719 push_function_context ();
13721 p
->next
= f_function_chain
;
13722 f_function_chain
= p
;
13724 p
->named_labels
= named_labels
;
13725 p
->shadowed_labels
= shadowed_labels
;
13726 p
->binding_level
= current_binding_level
;
13730 push_parm_decl (tree parm
)
13732 int old_immediate_size_expand
= immediate_size_expand
;
13734 /* Don't try computing parm sizes now -- wait till fn is called. */
13736 immediate_size_expand
= 0;
13738 /* Fill in arg stuff. */
13740 DECL_ARG_TYPE (parm
) = TREE_TYPE (parm
);
13741 DECL_ARG_TYPE_AS_WRITTEN (parm
) = TREE_TYPE (parm
);
13742 TREE_READONLY (parm
) = 1; /* All implementation args are read-only. */
13744 parm
= pushdecl (parm
);
13746 immediate_size_expand
= old_immediate_size_expand
;
13748 finish_decl (parm
, NULL_TREE
, FALSE
);
13751 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
13754 pushdecl_top_level (x
)
13758 register struct f_binding_level
*b
= current_binding_level
;
13759 register tree f
= current_function_decl
;
13761 current_binding_level
= global_binding_level
;
13762 current_function_decl
= NULL_TREE
;
13764 current_binding_level
= b
;
13765 current_function_decl
= f
;
13769 /* Store the list of declarations of the current level.
13770 This is done for the parameter declarations of a function being defined,
13771 after they are modified in the light of any missing parameters. */
13777 return current_binding_level
->names
= decls
;
13780 /* Store the parameter declarations into the current function declaration.
13781 This is called after parsing the parameter declarations, before
13782 digesting the body of the function.
13784 For an old-style definition, modify the function's type
13785 to specify at least the number of arguments. */
13788 store_parm_decls (int is_main_program UNUSED
)
13790 register tree fndecl
= current_function_decl
;
13792 if (fndecl
== error_mark_node
)
13795 /* This is a chain of PARM_DECLs from old-style parm declarations. */
13796 DECL_ARGUMENTS (fndecl
) = storedecls (nreverse (getdecls ()));
13798 /* Initialize the RTL code for the function. */
13800 init_function_start (fndecl
, input_filename
, lineno
);
13802 /* Set up parameters and prepare for return, for the function. */
13804 expand_function_start (fndecl
, 0);
13808 start_decl (tree decl
, bool is_top_level
)
13811 bool at_top_level
= (current_binding_level
== global_binding_level
);
13812 bool top_level
= is_top_level
|| at_top_level
;
13814 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13816 assert (!is_top_level
|| !at_top_level
);
13818 if (DECL_INITIAL (decl
) != NULL_TREE
)
13820 assert (DECL_INITIAL (decl
) == error_mark_node
);
13821 assert (!DECL_EXTERNAL (decl
));
13823 else if (top_level
)
13824 assert ((TREE_STATIC (decl
) == 1) || DECL_EXTERNAL (decl
) == 1);
13826 /* For Fortran, we by default put things in .common when possible. */
13827 DECL_COMMON (decl
) = 1;
13829 /* Add this decl to the current binding level. TEM may equal DECL or it may
13830 be a previous decl of the same name. */
13832 tem
= pushdecl_top_level (decl
);
13834 tem
= pushdecl (decl
);
13836 /* For a local variable, define the RTL now. */
13838 /* But not if this is a duplicate decl and we preserved the rtl from the
13839 previous one (which may or may not happen). */
13840 && !DECL_RTL_SET_P (tem
))
13842 if (TYPE_SIZE (TREE_TYPE (tem
)) != 0)
13844 else if (TREE_CODE (TREE_TYPE (tem
)) == ARRAY_TYPE
13845 && DECL_INITIAL (tem
) != 0)
13852 /* Create the FUNCTION_DECL for a function definition.
13853 DECLSPECS and DECLARATOR are the parts of the declaration;
13854 they describe the function's name and the type it returns,
13855 but twisted together in a fashion that parallels the syntax of C.
13857 This function creates a binding context for the function body
13858 as well as setting up the FUNCTION_DECL in current_function_decl.
13860 Returns 1 on success. If the DECLARATOR is not suitable for a function
13861 (it defines a datum instead), we return 0, which tells
13862 ffe_parse_file to report a parse error.
13864 NESTED is nonzero for a function nested within another function. */
13867 start_function (tree name
, tree type
, int nested
, int public)
13871 int old_immediate_size_expand
= immediate_size_expand
;
13874 shadowed_labels
= 0;
13876 /* Don't expand any sizes in the return type of the function. */
13877 immediate_size_expand
= 0;
13882 assert (current_function_decl
!= NULL_TREE
);
13883 assert (DECL_CONTEXT (current_function_decl
) == NULL_TREE
);
13887 assert (current_function_decl
== NULL_TREE
);
13890 if (TREE_CODE (type
) == ERROR_MARK
)
13891 decl1
= current_function_decl
= error_mark_node
;
13894 decl1
= build_decl (FUNCTION_DECL
,
13897 TREE_PUBLIC (decl1
) = public ? 1 : 0;
13899 DECL_INLINE (decl1
) = 1;
13900 TREE_STATIC (decl1
) = 1;
13901 DECL_EXTERNAL (decl1
) = 0;
13903 announce_function (decl1
);
13905 /* Make the init_value nonzero so pushdecl knows this is not tentative.
13906 error_mark_node is replaced below (in poplevel) with the BLOCK. */
13907 DECL_INITIAL (decl1
) = error_mark_node
;
13909 /* Record the decl so that the function name is defined. If we already have
13910 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
13912 current_function_decl
= pushdecl (decl1
);
13916 ffecom_outer_function_decl_
= current_function_decl
;
13919 current_binding_level
->prep_state
= 2;
13921 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
13923 make_decl_rtl (current_function_decl
, NULL
);
13925 restype
= TREE_TYPE (TREE_TYPE (current_function_decl
));
13926 DECL_RESULT (current_function_decl
)
13927 = build_decl (RESULT_DECL
, NULL_TREE
, restype
);
13930 if (!nested
&& (TREE_CODE (current_function_decl
) != ERROR_MARK
))
13931 TREE_ADDRESSABLE (current_function_decl
) = 1;
13933 immediate_size_expand
= old_immediate_size_expand
;
13936 /* Here are the public functions the GNU back end needs. */
13939 convert (type
, expr
)
13942 register tree e
= expr
;
13943 register enum tree_code code
= TREE_CODE (type
);
13945 if (type
== TREE_TYPE (e
)
13946 || TREE_CODE (e
) == ERROR_MARK
)
13948 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
13949 return fold (build1 (NOP_EXPR
, type
, e
));
13950 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
13951 || code
== ERROR_MARK
)
13952 return error_mark_node
;
13953 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
13955 assert ("void value not ignored as it ought to be" == NULL
);
13956 return error_mark_node
;
13958 if (code
== VOID_TYPE
)
13959 return build1 (CONVERT_EXPR
, type
, e
);
13960 if ((code
!= RECORD_TYPE
)
13961 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
13962 e
= ffecom_1 (REALPART_EXPR
, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
))),
13964 if (code
== INTEGER_TYPE
|| code
== ENUMERAL_TYPE
)
13965 return fold (convert_to_integer (type
, e
));
13966 if (code
== POINTER_TYPE
)
13967 return fold (convert_to_pointer (type
, e
));
13968 if (code
== REAL_TYPE
)
13969 return fold (convert_to_real (type
, e
));
13970 if (code
== COMPLEX_TYPE
)
13971 return fold (convert_to_complex (type
, e
));
13972 if (code
== RECORD_TYPE
)
13973 return fold (ffecom_convert_to_complex_ (type
, e
));
13975 assert ("conversion to non-scalar type requested" == NULL
);
13976 return error_mark_node
;
13979 /* Return the list of declarations of the current level.
13980 Note that this list is in reverse order unless/until
13981 you nreverse it; and when you do nreverse it, you must
13982 store the result back using `storedecls' or you will lose. */
13987 return current_binding_level
->names
;
13990 /* Nonzero if we are currently in the global binding level. */
13993 global_bindings_p ()
13995 return current_binding_level
== global_binding_level
;
13999 ffecom_init_decl_processing ()
14006 /* Delete the node BLOCK from the current binding level.
14007 This is used for the block inside a stmt expr ({...})
14008 so that the block can be reinserted where appropriate. */
14011 delete_block (block
)
14015 if (current_binding_level
->blocks
== block
)
14016 current_binding_level
->blocks
= TREE_CHAIN (block
);
14017 for (t
= current_binding_level
->blocks
; t
;)
14019 if (TREE_CHAIN (t
) == block
)
14020 TREE_CHAIN (t
) = TREE_CHAIN (block
);
14022 t
= TREE_CHAIN (t
);
14024 TREE_CHAIN (block
) = NULL
;
14025 /* Clear TREE_USED which is always set by poplevel.
14026 The flag is set again if insert_block is called. */
14027 TREE_USED (block
) = 0;
14031 insert_block (block
)
14034 TREE_USED (block
) = 1;
14035 current_binding_level
->blocks
14036 = chainon (current_binding_level
->blocks
, block
);
14039 /* Each front end provides its own. */
14040 static const char *ffe_init
PARAMS ((const char *));
14041 static void ffe_finish
PARAMS ((void));
14042 static void ffe_init_options
PARAMS ((void));
14043 static void ffe_print_identifier
PARAMS ((FILE *, tree
, int));
14045 struct language_function
GTY(())
14050 #undef LANG_HOOKS_NAME
14051 #define LANG_HOOKS_NAME "GNU F77"
14052 #undef LANG_HOOKS_INIT
14053 #define LANG_HOOKS_INIT ffe_init
14054 #undef LANG_HOOKS_FINISH
14055 #define LANG_HOOKS_FINISH ffe_finish
14056 #undef LANG_HOOKS_INIT_OPTIONS
14057 #define LANG_HOOKS_INIT_OPTIONS ffe_init_options
14058 #undef LANG_HOOKS_DECODE_OPTION
14059 #define LANG_HOOKS_DECODE_OPTION ffe_decode_option
14060 #undef LANG_HOOKS_PARSE_FILE
14061 #define LANG_HOOKS_PARSE_FILE ffe_parse_file
14062 #undef LANG_HOOKS_MARK_ADDRESSABLE
14063 #define LANG_HOOKS_MARK_ADDRESSABLE ffe_mark_addressable
14064 #undef LANG_HOOKS_PRINT_IDENTIFIER
14065 #define LANG_HOOKS_PRINT_IDENTIFIER ffe_print_identifier
14066 #undef LANG_HOOKS_DECL_PRINTABLE_NAME
14067 #define LANG_HOOKS_DECL_PRINTABLE_NAME ffe_printable_name
14068 #undef LANG_HOOKS_PRINT_ERROR_FUNCTION
14069 #define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
14070 #undef LANG_HOOKS_TRUTHVALUE_CONVERSION
14071 #define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
14073 #undef LANG_HOOKS_TYPE_FOR_MODE
14074 #define LANG_HOOKS_TYPE_FOR_MODE ffe_type_for_mode
14075 #undef LANG_HOOKS_TYPE_FOR_SIZE
14076 #define LANG_HOOKS_TYPE_FOR_SIZE ffe_type_for_size
14077 #undef LANG_HOOKS_SIGNED_TYPE
14078 #define LANG_HOOKS_SIGNED_TYPE ffe_signed_type
14079 #undef LANG_HOOKS_UNSIGNED_TYPE
14080 #define LANG_HOOKS_UNSIGNED_TYPE ffe_unsigned_type
14081 #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
14082 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
14084 /* We do not wish to use alias-set based aliasing at all. Used in the
14085 extreme (every object with its own set, with equivalences recorded) it
14086 might be helpful, but there are problems when it comes to inlining. We
14087 get on ok with flag_argument_noalias, and alias-set aliasing does
14088 currently limit how stack slots can be reused, which is a lose. */
14089 #undef LANG_HOOKS_GET_ALIAS_SET
14090 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14092 const struct lang_hooks lang_hooks
= LANG_HOOKS_INITIALIZER
;
14094 /* Table indexed by tree code giving a string containing a character
14095 classifying the tree code. Possibilities are
14096 t, d, s, c, r, <, 1, 2 and e. See tree.def for details. */
14098 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14100 const char tree_code_type
[] = {
14101 #include "tree.def"
14105 /* Table indexed by tree code giving number of expression
14106 operands beyond the fixed part of the node structure.
14107 Not used for types or decls. */
14109 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14111 const unsigned char tree_code_length
[] = {
14112 #include "tree.def"
14116 /* Names of tree components.
14117 Used for printing out the tree and error messages. */
14118 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14120 const char *const tree_code_name
[] = {
14121 #include "tree.def"
14125 static const char *
14126 ffe_init (filename
)
14127 const char *filename
;
14129 /* Open input file. */
14130 if (filename
== 0 || !strcmp (filename
, "-"))
14133 filename
= "stdin";
14136 finput
= fopen (filename
, "r");
14138 fatal_io_error ("can't open %s", filename
);
14140 #ifdef IO_BUFFER_SIZE
14141 setvbuf (finput
, (char *) xmalloc (IO_BUFFER_SIZE
), _IOFBF
, IO_BUFFER_SIZE
);
14144 ffecom_init_decl_processing ();
14146 /* If the file is output from cpp, it should contain a first line
14147 `# 1 "real-filename"', and the current design of gcc (toplev.c
14148 in particular and the way it sets up information relied on by
14149 INCLUDE) requires that we read this now, and store the
14150 "real-filename" info in master_input_filename. Ask the lexer
14151 to try doing this. */
14152 ffelex_hash_kludge (finput
);
14154 /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14155 return the new file name. */
14156 if (main_input_filename
)
14157 filename
= main_input_filename
;
14165 ffe_terminate_0 ();
14167 if (ffe_is_ffedebug ())
14168 malloc_pool_display (malloc_pool_image ());
14174 ffe_init_options ()
14176 /* Set default options for Fortran. */
14177 flag_move_all_movables
= 1;
14178 flag_reduce_all_givs
= 1;
14179 flag_argument_noalias
= 2;
14180 flag_merge_constants
= 2;
14181 flag_errno_math
= 0;
14182 flag_complex_divide_method
= 1;
14186 ffe_mark_addressable (exp
)
14189 register tree x
= exp
;
14191 switch (TREE_CODE (x
))
14194 case COMPONENT_REF
:
14196 x
= TREE_OPERAND (x
, 0);
14200 TREE_ADDRESSABLE (x
) = 1;
14207 if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
)
14208 && DECL_NONLOCAL (x
))
14210 if (TREE_PUBLIC (x
))
14212 assert ("address of global register var requested" == NULL
);
14215 assert ("address of register variable requested" == NULL
);
14217 else if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
))
14219 if (TREE_PUBLIC (x
))
14221 assert ("address of global register var requested" == NULL
);
14224 assert ("address of register var requested" == NULL
);
14226 put_var_into_stack (x
);
14229 case FUNCTION_DECL
:
14230 TREE_ADDRESSABLE (x
) = 1;
14231 #if 0 /* poplevel deals with this now. */
14232 if (DECL_CONTEXT (x
) == 0)
14233 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x
)) = 1;
14241 /* Exit a binding level.
14242 Pop the level off, and restore the state of the identifier-decl mappings
14243 that were in effect when this level was entered.
14245 If KEEP is nonzero, this level had explicit declarations, so
14246 and create a "block" (a BLOCK node) for the level
14247 to record its declarations and subblocks for symbol table output.
14249 If FUNCTIONBODY is nonzero, this level is the body of a function,
14250 so create a block as if KEEP were set and also clear out all
14253 If REVERSE is nonzero, reverse the order of decls before putting
14254 them into the BLOCK. */
14257 poplevel (keep
, reverse
, functionbody
)
14262 register tree link
;
14263 /* The chain of decls was accumulated in reverse order.
14264 Put it into forward order, just for cleanliness. */
14266 tree subblocks
= current_binding_level
->blocks
;
14269 int block_previously_created
;
14271 /* Get the decls in the order they were written.
14272 Usually current_binding_level->names is in reverse order.
14273 But parameter decls were previously put in forward order. */
14276 current_binding_level
->names
14277 = decls
= nreverse (current_binding_level
->names
);
14279 decls
= current_binding_level
->names
;
14281 /* Output any nested inline functions within this block
14282 if they weren't already output. */
14284 for (decl
= decls
; decl
; decl
= TREE_CHAIN (decl
))
14285 if (TREE_CODE (decl
) == FUNCTION_DECL
14286 && ! TREE_ASM_WRITTEN (decl
)
14287 && DECL_INITIAL (decl
) != 0
14288 && TREE_ADDRESSABLE (decl
))
14290 /* If this decl was copied from a file-scope decl
14291 on account of a block-scope extern decl,
14292 propagate TREE_ADDRESSABLE to the file-scope decl.
14294 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14295 true, since then the decl goes through save_for_inline_copying. */
14296 if (DECL_ABSTRACT_ORIGIN (decl
) != 0
14297 && DECL_ABSTRACT_ORIGIN (decl
) != decl
)
14298 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl
)) = 1;
14299 else if (DECL_SAVED_INSNS (decl
) != 0)
14301 push_function_context ();
14302 output_inline_function (decl
);
14303 pop_function_context ();
14307 /* If there were any declarations or structure tags in that level,
14308 or if this level is a function body,
14309 create a BLOCK to record them for the life of this function. */
14312 block_previously_created
= (current_binding_level
->this_block
!= 0);
14313 if (block_previously_created
)
14314 block
= current_binding_level
->this_block
;
14315 else if (keep
|| functionbody
)
14316 block
= make_node (BLOCK
);
14319 BLOCK_VARS (block
) = decls
;
14320 BLOCK_SUBBLOCKS (block
) = subblocks
;
14323 /* In each subblock, record that this is its superior. */
14325 for (link
= subblocks
; link
; link
= TREE_CHAIN (link
))
14326 BLOCK_SUPERCONTEXT (link
) = block
;
14328 /* Clear out the meanings of the local variables of this level. */
14330 for (link
= decls
; link
; link
= TREE_CHAIN (link
))
14332 if (DECL_NAME (link
) != 0)
14334 /* If the ident. was used or addressed via a local extern decl,
14335 don't forget that fact. */
14336 if (DECL_EXTERNAL (link
))
14338 if (TREE_USED (link
))
14339 TREE_USED (DECL_NAME (link
)) = 1;
14340 if (TREE_ADDRESSABLE (link
))
14341 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link
)) = 1;
14343 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link
)) = 0;
14347 /* If the level being exited is the top level of a function,
14348 check over all the labels, and clear out the current
14349 (function local) meanings of their names. */
14353 /* If this is the top level block of a function,
14354 the vars are the function's parameters.
14355 Don't leave them in the BLOCK because they are
14356 found in the FUNCTION_DECL instead. */
14358 BLOCK_VARS (block
) = 0;
14361 /* Pop the current level, and free the structure for reuse. */
14364 register struct f_binding_level
*level
= current_binding_level
;
14365 current_binding_level
= current_binding_level
->level_chain
;
14367 level
->level_chain
= free_binding_level
;
14368 free_binding_level
= level
;
14371 /* Dispose of the block that we just made inside some higher level. */
14373 && current_function_decl
!= error_mark_node
)
14374 DECL_INITIAL (current_function_decl
) = block
;
14377 if (!block_previously_created
)
14378 current_binding_level
->blocks
14379 = chainon (current_binding_level
->blocks
, block
);
14381 /* If we did not make a block for the level just exited,
14382 any blocks made for inner levels
14383 (since they cannot be recorded as subblocks in that level)
14384 must be carried forward so they will later become subblocks
14385 of something else. */
14386 else if (subblocks
)
14387 current_binding_level
->blocks
14388 = chainon (current_binding_level
->blocks
, subblocks
);
14391 TREE_USED (block
) = 1;
14396 ffe_print_identifier (file
, node
, indent
)
14401 print_node (file
, "global", IDENTIFIER_GLOBAL_VALUE (node
), indent
+ 4);
14402 print_node (file
, "local", IDENTIFIER_LOCAL_VALUE (node
), indent
+ 4);
14405 /* Record a decl-node X as belonging to the current lexical scope.
14406 Check for errors (such as an incompatible declaration for the same
14407 name already seen in the same scope).
14409 Returns either X or an old decl for the same name.
14410 If an old decl is returned, it may have been smashed
14411 to agree with what X says. */
14418 register tree name
= DECL_NAME (x
);
14419 register struct f_binding_level
*b
= current_binding_level
;
14421 if ((TREE_CODE (x
) == FUNCTION_DECL
)
14422 && (DECL_INITIAL (x
) == 0)
14423 && DECL_EXTERNAL (x
))
14424 DECL_CONTEXT (x
) = NULL_TREE
;
14426 DECL_CONTEXT (x
) = current_function_decl
;
14430 if (IDENTIFIER_INVENTED (name
))
14432 DECL_ARTIFICIAL (x
) = 1;
14433 DECL_IN_SYSTEM_HEADER (x
) = 1;
14436 t
= lookup_name_current_level (name
);
14438 assert ((t
== NULL_TREE
) || (DECL_CONTEXT (x
) == NULL_TREE
));
14440 /* Don't push non-parms onto list for parms until we understand
14441 why we're doing this and whether it works. */
14443 assert ((b
== global_binding_level
)
14444 || !ffecom_transform_only_dummies_
14445 || TREE_CODE (x
) == PARM_DECL
);
14447 if ((t
!= NULL_TREE
) && duplicate_decls (x
, t
))
14450 /* If we are processing a typedef statement, generate a whole new
14451 ..._TYPE node (which will be just an variant of the existing
14452 ..._TYPE node with identical properties) and then install the
14453 TYPE_DECL node generated to represent the typedef name as the
14454 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14456 The whole point here is to end up with a situation where each and every
14457 ..._TYPE node the compiler creates will be uniquely associated with
14458 AT MOST one node representing a typedef name. This way, even though
14459 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14460 (i.e. "typedef name") nodes very early on, later parts of the
14461 compiler can always do the reverse translation and get back the
14462 corresponding typedef name. For example, given:
14464 typedef struct S MY_TYPE; MY_TYPE object;
14466 Later parts of the compiler might only know that `object' was of type
14467 `struct S' if it were not for code just below. With this code
14468 however, later parts of the compiler see something like:
14470 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14472 And they can then deduce (from the node for type struct S') that the
14473 original object declaration was:
14477 Being able to do this is important for proper support of protoize, and
14478 also for generating precise symbolic debugging information which
14479 takes full account of the programmer's (typedef) vocabulary.
14481 Obviously, we don't want to generate a duplicate ..._TYPE node if the
14482 TYPE_DECL node that we are now processing really represents a
14483 standard built-in type.
14485 Since all standard types are effectively declared at line zero in the
14486 source file, we can easily check to see if we are working on a
14487 standard type by checking the current value of lineno. */
14489 if (TREE_CODE (x
) == TYPE_DECL
)
14491 if (DECL_SOURCE_LINE (x
) == 0)
14493 if (TYPE_NAME (TREE_TYPE (x
)) == 0)
14494 TYPE_NAME (TREE_TYPE (x
)) = x
;
14496 else if (TREE_TYPE (x
) != error_mark_node
)
14498 tree tt
= TREE_TYPE (x
);
14500 tt
= build_type_copy (tt
);
14501 TYPE_NAME (tt
) = x
;
14502 TREE_TYPE (x
) = tt
;
14506 /* This name is new in its binding level. Install the new declaration
14508 if (b
== global_binding_level
)
14509 IDENTIFIER_GLOBAL_VALUE (name
) = x
;
14511 IDENTIFIER_LOCAL_VALUE (name
) = x
;
14514 /* Put decls on list in reverse order. We will reverse them later if
14516 TREE_CHAIN (x
) = b
->names
;
14522 /* Nonzero if the current level needs to have a BLOCK made. */
14529 for (decl
= current_binding_level
->names
;
14531 decl
= TREE_CHAIN (decl
))
14533 if (TREE_USED (decl
) || TREE_CODE (decl
) != VAR_DECL
14534 || (DECL_NAME (decl
) && ! DECL_ARTIFICIAL (decl
)))
14535 /* Currently, there aren't supposed to be non-artificial names
14536 at other than the top block for a function -- they're
14537 believed to always be temps. But it's wise to check anyway. */
14543 /* Enter a new binding level.
14544 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14545 not for that of tags. */
14548 pushlevel (tag_transparent
)
14549 int tag_transparent
;
14551 register struct f_binding_level
*newlevel
= NULL_BINDING_LEVEL
;
14553 assert (! tag_transparent
);
14555 if (current_binding_level
== global_binding_level
)
14560 /* Reuse or create a struct for this binding level. */
14562 if (free_binding_level
)
14564 newlevel
= free_binding_level
;
14565 free_binding_level
= free_binding_level
->level_chain
;
14569 newlevel
= make_binding_level ();
14572 /* Add this level to the front of the chain (stack) of levels that
14575 *newlevel
= clear_binding_level
;
14576 newlevel
->level_chain
= current_binding_level
;
14577 current_binding_level
= newlevel
;
14580 /* Set the BLOCK node for the innermost scope
14581 (the one we are currently in). */
14585 register tree block
;
14587 current_binding_level
->this_block
= block
;
14588 current_binding_level
->names
= chainon (current_binding_level
->names
,
14589 BLOCK_VARS (block
));
14590 current_binding_level
->blocks
= chainon (current_binding_level
->blocks
,
14591 BLOCK_SUBBLOCKS (block
));
14595 ffe_signed_or_unsigned_type (unsignedp
, type
)
14601 if (! INTEGRAL_TYPE_P (type
))
14603 if (TYPE_PRECISION (type
) == TYPE_PRECISION (signed_char_type_node
))
14604 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
14605 if (TYPE_PRECISION (type
) == TYPE_PRECISION (integer_type_node
))
14606 return unsignedp
? unsigned_type_node
: integer_type_node
;
14607 if (TYPE_PRECISION (type
) == TYPE_PRECISION (short_integer_type_node
))
14608 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
14609 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_integer_type_node
))
14610 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
14611 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_long_integer_type_node
))
14612 return (unsignedp
? long_long_unsigned_type_node
14613 : long_long_integer_type_node
);
14615 type2
= ffe_type_for_size (TYPE_PRECISION (type
), unsignedp
);
14616 if (type2
== NULL_TREE
)
14623 ffe_signed_type (type
)
14626 tree type1
= TYPE_MAIN_VARIANT (type
);
14627 ffeinfoKindtype kt
;
14630 if (type1
== unsigned_char_type_node
|| type1
== char_type_node
)
14631 return signed_char_type_node
;
14632 if (type1
== unsigned_type_node
)
14633 return integer_type_node
;
14634 if (type1
== short_unsigned_type_node
)
14635 return short_integer_type_node
;
14636 if (type1
== long_unsigned_type_node
)
14637 return long_integer_type_node
;
14638 if (type1
== long_long_unsigned_type_node
)
14639 return long_long_integer_type_node
;
14640 #if 0 /* gcc/c-* files only */
14641 if (type1
== unsigned_intDI_type_node
)
14642 return intDI_type_node
;
14643 if (type1
== unsigned_intSI_type_node
)
14644 return intSI_type_node
;
14645 if (type1
== unsigned_intHI_type_node
)
14646 return intHI_type_node
;
14647 if (type1
== unsigned_intQI_type_node
)
14648 return intQI_type_node
;
14651 type2
= ffe_type_for_size (TYPE_PRECISION (type1
), 0);
14652 if (type2
!= NULL_TREE
)
14655 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
14657 type2
= ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
14659 if (type1
== type2
)
14660 return ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
14666 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14667 or validate its data type for an `if' or `while' statement or ?..: exp.
14669 This preparation consists of taking the ordinary
14670 representation of an expression expr and producing a valid tree
14671 boolean expression describing whether expr is nonzero. We could
14672 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14673 but we optimize comparisons, &&, ||, and !.
14675 The resulting type should always be `integer_type_node'. */
14678 ffe_truthvalue_conversion (expr
)
14681 if (TREE_CODE (expr
) == ERROR_MARK
)
14684 #if 0 /* This appears to be wrong for C++. */
14685 /* These really should return error_mark_node after 2.4 is stable.
14686 But not all callers handle ERROR_MARK properly. */
14687 switch (TREE_CODE (TREE_TYPE (expr
)))
14690 error ("struct type value used where scalar is required");
14691 return integer_zero_node
;
14694 error ("union type value used where scalar is required");
14695 return integer_zero_node
;
14698 error ("array type value used where scalar is required");
14699 return integer_zero_node
;
14706 switch (TREE_CODE (expr
))
14708 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14709 or comparison expressions as truth values at this level. */
14711 case COMPONENT_REF
:
14712 /* A one-bit unsigned bit-field is already acceptable. */
14713 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr
, 1)))
14714 && TREE_UNSIGNED (TREE_OPERAND (expr
, 1)))
14720 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14721 or comparison expressions as truth values at this level. */
14723 if (integer_zerop (TREE_OPERAND (expr
, 1)))
14724 return build_unary_op (TRUTH_NOT_EXPR
, TREE_OPERAND (expr
, 0), 0);
14726 case NE_EXPR
: case LE_EXPR
: case GE_EXPR
: case LT_EXPR
: case GT_EXPR
:
14727 case TRUTH_ANDIF_EXPR
:
14728 case TRUTH_ORIF_EXPR
:
14729 case TRUTH_AND_EXPR
:
14730 case TRUTH_OR_EXPR
:
14731 case TRUTH_XOR_EXPR
:
14732 TREE_TYPE (expr
) = integer_type_node
;
14739 return integer_zerop (expr
) ? integer_zero_node
: integer_one_node
;
14742 return real_zerop (expr
) ? integer_zero_node
: integer_one_node
;
14745 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 0)))
14746 return build (COMPOUND_EXPR
, integer_type_node
,
14747 TREE_OPERAND (expr
, 0), integer_one_node
);
14749 return integer_one_node
;
14752 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1))
14753 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
14755 ffe_truthvalue_conversion (TREE_OPERAND (expr
, 0)),
14756 ffe_truthvalue_conversion (TREE_OPERAND (expr
, 1)));
14762 /* These don't change whether an object is nonzero or zero. */
14763 return ffe_truthvalue_conversion (TREE_OPERAND (expr
, 0));
14767 /* These don't change whether an object is zero or nonzero, but
14768 we can't ignore them if their second arg has side-effects. */
14769 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1)))
14770 return build (COMPOUND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 1),
14771 ffe_truthvalue_conversion (TREE_OPERAND (expr
, 0)));
14773 return ffe_truthvalue_conversion (TREE_OPERAND (expr
, 0));
14777 /* Distribute the conversion into the arms of a COND_EXPR. */
14778 tree arg1
= TREE_OPERAND (expr
, 1);
14779 tree arg2
= TREE_OPERAND (expr
, 2);
14780 if (! VOID_TYPE_P (TREE_TYPE (arg1
)))
14781 arg1
= ffe_truthvalue_conversion (arg1
);
14782 if (! VOID_TYPE_P (TREE_TYPE (arg2
)))
14783 arg2
= ffe_truthvalue_conversion (arg2
);
14784 return fold (build (COND_EXPR
, integer_type_node
,
14785 TREE_OPERAND (expr
, 0), arg1
, arg2
));
14789 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14790 since that affects how `default_conversion' will behave. */
14791 if (TREE_CODE (TREE_TYPE (expr
)) == REFERENCE_TYPE
14792 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == REFERENCE_TYPE
)
14794 /* fall through... */
14796 /* If this is widening the argument, we can ignore it. */
14797 if (TYPE_PRECISION (TREE_TYPE (expr
))
14798 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr
, 0))))
14799 return ffe_truthvalue_conversion (TREE_OPERAND (expr
, 0));
14803 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14805 if (TARGET_FLOAT_FORMAT
== IEEE_FLOAT_FORMAT
14806 && TREE_CODE (TREE_TYPE (expr
)) == REAL_TYPE
)
14808 /* fall through... */
14810 /* This and MINUS_EXPR can be changed into a comparison of the
14812 if (TREE_TYPE (TREE_OPERAND (expr
, 0))
14813 == TREE_TYPE (TREE_OPERAND (expr
, 1)))
14814 return ffecom_2 (NE_EXPR
, integer_type_node
,
14815 TREE_OPERAND (expr
, 0),
14816 TREE_OPERAND (expr
, 1));
14817 return ffecom_2 (NE_EXPR
, integer_type_node
,
14818 TREE_OPERAND (expr
, 0),
14819 fold (build1 (NOP_EXPR
,
14820 TREE_TYPE (TREE_OPERAND (expr
, 0)),
14821 TREE_OPERAND (expr
, 1))));
14824 if (integer_onep (TREE_OPERAND (expr
, 1)))
14829 #if 0 /* No such thing in Fortran. */
14830 if (warn_parentheses
&& C_EXP_ORIGINAL_CODE (expr
) == MODIFY_EXPR
)
14831 warning ("suggest parentheses around assignment used as truth value");
14839 if (TREE_CODE (TREE_TYPE (expr
)) == COMPLEX_TYPE
)
14841 ((TREE_SIDE_EFFECTS (expr
)
14842 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
14844 ffe_truthvalue_conversion (ffecom_1 (REALPART_EXPR
,
14845 TREE_TYPE (TREE_TYPE (expr
)),
14847 ffe_truthvalue_conversion (ffecom_1 (IMAGPART_EXPR
,
14848 TREE_TYPE (TREE_TYPE (expr
)),
14851 return ffecom_2 (NE_EXPR
, integer_type_node
,
14853 convert (TREE_TYPE (expr
), integer_zero_node
));
14857 ffe_type_for_mode (mode
, unsignedp
)
14858 enum machine_mode mode
;
14865 if (mode
== TYPE_MODE (integer_type_node
))
14866 return unsignedp
? unsigned_type_node
: integer_type_node
;
14868 if (mode
== TYPE_MODE (signed_char_type_node
))
14869 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
14871 if (mode
== TYPE_MODE (short_integer_type_node
))
14872 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
14874 if (mode
== TYPE_MODE (long_integer_type_node
))
14875 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
14877 if (mode
== TYPE_MODE (long_long_integer_type_node
))
14878 return unsignedp
? long_long_unsigned_type_node
: long_long_integer_type_node
;
14880 #if HOST_BITS_PER_WIDE_INT >= 64
14881 if (mode
== TYPE_MODE (intTI_type_node
))
14882 return unsignedp
? unsigned_intTI_type_node
: intTI_type_node
;
14885 if (mode
== TYPE_MODE (float_type_node
))
14886 return float_type_node
;
14888 if (mode
== TYPE_MODE (double_type_node
))
14889 return double_type_node
;
14891 if (mode
== TYPE_MODE (long_double_type_node
))
14892 return long_double_type_node
;
14894 if (mode
== TYPE_MODE (build_pointer_type (char_type_node
)))
14895 return build_pointer_type (char_type_node
);
14897 if (mode
== TYPE_MODE (build_pointer_type (integer_type_node
)))
14898 return build_pointer_type (integer_type_node
);
14900 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
14901 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
14903 if (((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
14904 && (mode
== TYPE_MODE (t
)))
14906 if ((i
== FFEINFO_basictypeINTEGER
) && unsignedp
)
14907 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][j
];
14917 ffe_type_for_size (bits
, unsignedp
)
14921 ffeinfoKindtype kt
;
14924 if (bits
== TYPE_PRECISION (integer_type_node
))
14925 return unsignedp
? unsigned_type_node
: integer_type_node
;
14927 if (bits
== TYPE_PRECISION (signed_char_type_node
))
14928 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
14930 if (bits
== TYPE_PRECISION (short_integer_type_node
))
14931 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
14933 if (bits
== TYPE_PRECISION (long_integer_type_node
))
14934 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
14936 if (bits
== TYPE_PRECISION (long_long_integer_type_node
))
14937 return (unsignedp
? long_long_unsigned_type_node
14938 : long_long_integer_type_node
);
14940 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
14942 type_node
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
14944 if ((type_node
!= NULL_TREE
) && (bits
== TYPE_PRECISION (type_node
)))
14945 return unsignedp
? ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
]
14953 ffe_unsigned_type (type
)
14956 tree type1
= TYPE_MAIN_VARIANT (type
);
14957 ffeinfoKindtype kt
;
14960 if (type1
== signed_char_type_node
|| type1
== char_type_node
)
14961 return unsigned_char_type_node
;
14962 if (type1
== integer_type_node
)
14963 return unsigned_type_node
;
14964 if (type1
== short_integer_type_node
)
14965 return short_unsigned_type_node
;
14966 if (type1
== long_integer_type_node
)
14967 return long_unsigned_type_node
;
14968 if (type1
== long_long_integer_type_node
)
14969 return long_long_unsigned_type_node
;
14970 #if 0 /* gcc/c-* files only */
14971 if (type1
== intDI_type_node
)
14972 return unsigned_intDI_type_node
;
14973 if (type1
== intSI_type_node
)
14974 return unsigned_intSI_type_node
;
14975 if (type1
== intHI_type_node
)
14976 return unsigned_intHI_type_node
;
14977 if (type1
== intQI_type_node
)
14978 return unsigned_intQI_type_node
;
14981 type2
= ffe_type_for_size (TYPE_PRECISION (type1
), 1);
14982 if (type2
!= NULL_TREE
)
14985 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
14987 type2
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
14989 if (type1
== type2
)
14990 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
14996 /* From gcc/cccp.c, the code to handle -I. */
14998 /* Skip leading "./" from a directory name.
14999 This may yield the empty string, which represents the current directory. */
15001 static const char *
15002 skip_redundant_dir_prefix (const char *dir
)
15004 while (dir
[0] == '.' && dir
[1] == '/')
15005 for (dir
+= 2; *dir
== '/'; dir
++)
15007 if (dir
[0] == '.' && !dir
[1])
15012 /* The file_name_map structure holds a mapping of file names for a
15013 particular directory. This mapping is read from the file named
15014 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
15015 map filenames on a file system with severe filename restrictions,
15016 such as DOS. The format of the file name map file is just a series
15017 of lines with two tokens on each line. The first token is the name
15018 to map, and the second token is the actual name to use. */
15020 struct file_name_map
15022 struct file_name_map
*map_next
;
15027 #define FILE_NAME_MAP_FILE "header.gcc"
15029 /* Current maximum length of directory names in the search path
15030 for include files. (Altered as we get more of them.) */
15032 static int max_include_len
= 0;
15034 struct file_name_list
15036 struct file_name_list
*next
;
15038 /* Mapping of file names for this directory. */
15039 struct file_name_map
*name_map
;
15040 /* Nonzero if name_map is valid. */
15044 static struct file_name_list
*include
= NULL
; /* First dir to search */
15045 static struct file_name_list
*last_include
= NULL
; /* Last in chain */
15047 /* I/O buffer structure.
15048 The `fname' field is nonzero for source files and #include files
15049 and for the dummy text used for -D and -U.
15050 It is zero for rescanning results of macro expansion
15051 and for expanding macro arguments. */
15052 #define INPUT_STACK_MAX 400
15053 static struct file_buf
{
15055 /* Filename specified with #line command. */
15056 const char *nominal_fname
;
15057 /* Record where in the search path this file was found.
15058 For #include_next. */
15059 struct file_name_list
*dir
;
15061 ffewhereColumn column
;
15062 } instack
[INPUT_STACK_MAX
];
15064 static int last_error_tick
= 0; /* Incremented each time we print it. */
15065 static int input_file_stack_tick
= 0; /* Incremented when status changes. */
15067 /* Current nesting level of input sources.
15068 `instack[indepth]' is the level currently being read. */
15069 static int indepth
= -1;
15071 typedef struct file_buf FILE_BUF
;
15073 /* Nonzero means -I- has been seen,
15074 so don't look for #include "foo" the source-file directory. */
15075 static int ignore_srcdir
;
15077 #ifndef INCLUDE_LEN_FUDGE
15078 #define INCLUDE_LEN_FUDGE 0
15081 static void append_include_chain (struct file_name_list
*first
,
15082 struct file_name_list
*last
);
15083 static FILE *open_include_file (char *filename
,
15084 struct file_name_list
*searchptr
);
15085 static void print_containing_files (ffebadSeverity sev
);
15086 static char *read_filename_string (int ch
, FILE *f
);
15087 static struct file_name_map
*read_name_map (const char *dirname
);
15089 /* Append a chain of `struct file_name_list's
15090 to the end of the main include chain.
15091 FIRST is the beginning of the chain to append, and LAST is the end. */
15094 append_include_chain (first
, last
)
15095 struct file_name_list
*first
, *last
;
15097 struct file_name_list
*dir
;
15099 if (!first
|| !last
)
15105 last_include
->next
= first
;
15107 for (dir
= first
; ; dir
= dir
->next
) {
15108 int len
= strlen (dir
->fname
) + INCLUDE_LEN_FUDGE
;
15109 if (len
> max_include_len
)
15110 max_include_len
= len
;
15116 last_include
= last
;
15119 /* Try to open include file FILENAME. SEARCHPTR is the directory
15120 being tried from the include file search path. This function maps
15121 filenames on file systems based on information read by
15125 open_include_file (filename
, searchptr
)
15127 struct file_name_list
*searchptr
;
15129 register struct file_name_map
*map
;
15130 register char *from
;
15133 if (searchptr
&& ! searchptr
->got_name_map
)
15135 searchptr
->name_map
= read_name_map (searchptr
->fname
15136 ? searchptr
->fname
: ".");
15137 searchptr
->got_name_map
= 1;
15140 /* First check the mapping for the directory we are using. */
15141 if (searchptr
&& searchptr
->name_map
)
15144 if (searchptr
->fname
)
15145 from
+= strlen (searchptr
->fname
) + 1;
15146 for (map
= searchptr
->name_map
; map
; map
= map
->map_next
)
15148 if (! strcmp (map
->map_from
, from
))
15150 /* Found a match. */
15151 return fopen (map
->map_to
, "r");
15156 /* Try to find a mapping file for the particular directory we are
15157 looking in. Thus #include <sys/types.h> will look up sys/types.h
15158 in /usr/include/header.gcc and look up types.h in
15159 /usr/include/sys/header.gcc. */
15160 p
= strrchr (filename
, '/');
15161 #ifdef DIR_SEPARATOR
15162 if (! p
) p
= strrchr (filename
, DIR_SEPARATOR
);
15164 char *tmp
= strrchr (filename
, DIR_SEPARATOR
);
15165 if (tmp
!= NULL
&& tmp
> p
) p
= tmp
;
15171 && searchptr
->fname
15172 && strlen (searchptr
->fname
) == (size_t) (p
- filename
)
15173 && ! strncmp (searchptr
->fname
, filename
, (int) (p
- filename
)))
15175 /* FILENAME is in SEARCHPTR, which we've already checked. */
15176 return fopen (filename
, "r");
15182 map
= read_name_map (".");
15186 dir
= (char *) xmalloc (p
- filename
+ 1);
15187 memcpy (dir
, filename
, p
- filename
);
15188 dir
[p
- filename
] = '\0';
15190 map
= read_name_map (dir
);
15193 for (; map
; map
= map
->map_next
)
15194 if (! strcmp (map
->map_from
, from
))
15195 return fopen (map
->map_to
, "r");
15197 return fopen (filename
, "r");
15200 /* Print the file names and line numbers of the #include
15201 commands which led to the current file. */
15204 print_containing_files (ffebadSeverity sev
)
15206 FILE_BUF
*ip
= NULL
;
15212 /* If stack of files hasn't changed since we last printed
15213 this info, don't repeat it. */
15214 if (last_error_tick
== input_file_stack_tick
)
15217 for (i
= indepth
; i
>= 0; i
--)
15218 if (instack
[i
].fname
!= NULL
) {
15223 /* Give up if we don't find a source file. */
15227 /* Find the other, outer source files. */
15228 for (i
--; i
>= 0; i
--)
15229 if (instack
[i
].fname
!= NULL
)
15235 str1
= "In file included";
15247 /* xgettext:no-c-format */
15248 ffebad_start_msg ("%A from %B at %0%C", sev
);
15249 ffebad_here (0, ip
->line
, ip
->column
);
15250 ffebad_string (str1
);
15251 ffebad_string (ip
->nominal_fname
);
15252 ffebad_string (str2
);
15256 /* Record we have printed the status as of this time. */
15257 last_error_tick
= input_file_stack_tick
;
15260 /* Read a space delimited string of unlimited length from a stdio
15264 read_filename_string (ch
, f
)
15272 set
= alloc
= xmalloc (len
+ 1);
15273 if (! ISSPACE (ch
))
15276 while ((ch
= getc (f
)) != EOF
&& ! ISSPACE (ch
))
15278 if (set
- alloc
== len
)
15281 alloc
= xrealloc (alloc
, len
+ 1);
15282 set
= alloc
+ len
/ 2;
15292 /* Read the file name map file for DIRNAME. */
15294 static struct file_name_map
*
15295 read_name_map (dirname
)
15296 const char *dirname
;
15298 /* This structure holds a linked list of file name maps, one per
15300 struct file_name_map_list
15302 struct file_name_map_list
*map_list_next
;
15303 char *map_list_name
;
15304 struct file_name_map
*map_list_map
;
15306 static struct file_name_map_list
*map_list
;
15307 register struct file_name_map_list
*map_list_ptr
;
15311 int separator_needed
;
15313 dirname
= skip_redundant_dir_prefix (dirname
);
15315 for (map_list_ptr
= map_list
; map_list_ptr
;
15316 map_list_ptr
= map_list_ptr
->map_list_next
)
15317 if (! strcmp (map_list_ptr
->map_list_name
, dirname
))
15318 return map_list_ptr
->map_list_map
;
15320 map_list_ptr
= ((struct file_name_map_list
*)
15321 xmalloc (sizeof (struct file_name_map_list
)));
15322 map_list_ptr
->map_list_name
= xstrdup (dirname
);
15323 map_list_ptr
->map_list_map
= NULL
;
15325 dirlen
= strlen (dirname
);
15326 separator_needed
= dirlen
!= 0 && dirname
[dirlen
- 1] != '/';
15327 if (separator_needed
)
15328 name
= concat (dirname
, "/", FILE_NAME_MAP_FILE
, NULL
);
15330 name
= concat (dirname
, FILE_NAME_MAP_FILE
, NULL
);
15331 f
= fopen (name
, "r");
15334 map_list_ptr
->map_list_map
= NULL
;
15339 while ((ch
= getc (f
)) != EOF
)
15342 struct file_name_map
*ptr
;
15346 from
= read_filename_string (ch
, f
);
15347 while ((ch
= getc (f
)) != EOF
&& ISSPACE (ch
) && ch
!= '\n')
15349 to
= read_filename_string (ch
, f
);
15351 ptr
= ((struct file_name_map
*)
15352 xmalloc (sizeof (struct file_name_map
)));
15353 ptr
->map_from
= from
;
15355 /* Make the real filename absolute. */
15360 if (separator_needed
)
15361 ptr
->map_to
= concat (dirname
, "/", to
, NULL
);
15363 ptr
->map_to
= concat (dirname
, to
, NULL
);
15367 ptr
->map_next
= map_list_ptr
->map_list_map
;
15368 map_list_ptr
->map_list_map
= ptr
;
15370 while ((ch
= getc (f
)) != '\n')
15377 map_list_ptr
->map_list_next
= map_list
;
15378 map_list
= map_list_ptr
;
15380 return map_list_ptr
->map_list_map
;
15384 ffecom_file_ (const char *name
)
15388 /* Do partial setup of input buffer for the sake of generating
15389 early #line directives (when -g is in effect). */
15391 fp
= &instack
[++indepth
];
15392 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
15395 fp
->nominal_fname
= fp
->fname
= name
;
15399 ffecom_close_include_ (FILE *f
)
15404 input_file_stack_tick
++;
15406 ffewhere_line_kill (instack
[indepth
].line
);
15407 ffewhere_column_kill (instack
[indepth
].column
);
15411 ffecom_decode_include_option_ (char *spec
)
15413 struct file_name_list
*dirtmp
;
15415 if (! ignore_srcdir
&& !strcmp (spec
, "-"))
15419 dirtmp
= (struct file_name_list
*)
15420 xmalloc (sizeof (struct file_name_list
));
15421 dirtmp
->next
= 0; /* New one goes on the end */
15422 dirtmp
->fname
= spec
;
15423 dirtmp
->got_name_map
= 0;
15425 error ("directory name must immediately follow -I");
15427 append_include_chain (dirtmp
, dirtmp
);
15432 /* Open INCLUDEd file. */
15435 ffecom_open_include_ (char *name
, ffewhereLine l
, ffewhereColumn c
)
15438 size_t flen
= strlen (fbeg
);
15439 struct file_name_list
*search_start
= include
; /* Chain of dirs to search */
15440 struct file_name_list dsp
[1]; /* First in chain, if #include "..." */
15441 struct file_name_list
*searchptr
= 0;
15442 char *fname
; /* Dynamically allocated fname buffer */
15449 dsp
[0].fname
= NULL
;
15451 /* If -I- was specified, don't search current dir, only spec'd ones. */
15452 if (!ignore_srcdir
)
15454 for (fp
= &instack
[indepth
]; fp
>= instack
; fp
--)
15460 if ((nam
= fp
->nominal_fname
) != NULL
)
15462 /* Found a named file. Figure out dir of the file,
15463 and put it in front of the search list. */
15464 dsp
[0].next
= search_start
;
15465 search_start
= dsp
;
15467 ep
= strrchr (nam
, '/');
15468 #ifdef DIR_SEPARATOR
15469 if (ep
== NULL
) ep
= strrchr (nam
, DIR_SEPARATOR
);
15471 char *tmp
= strrchr (nam
, DIR_SEPARATOR
);
15472 if (tmp
!= NULL
&& tmp
> ep
) ep
= tmp
;
15476 ep
= strrchr (nam
, ']');
15477 if (ep
== NULL
) ep
= strrchr (nam
, '>');
15478 if (ep
== NULL
) ep
= strrchr (nam
, ':');
15479 if (ep
!= NULL
) ep
++;
15484 dsp
[0].fname
= (char *) xmalloc (n
+ 1);
15485 strncpy (dsp
[0].fname
, nam
, n
);
15486 dsp
[0].fname
[n
] = '\0';
15487 if (n
+ INCLUDE_LEN_FUDGE
> max_include_len
)
15488 max_include_len
= n
+ INCLUDE_LEN_FUDGE
;
15491 dsp
[0].fname
= NULL
; /* Current directory */
15492 dsp
[0].got_name_map
= 0;
15498 /* Allocate this permanently, because it gets stored in the definitions
15500 fname
= xmalloc (max_include_len
+ flen
+ 4);
15501 /* + 2 above for slash and terminating null. */
15502 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15505 /* If specified file name is absolute, just open it. */
15508 #ifdef DIR_SEPARATOR
15509 || *fbeg
== DIR_SEPARATOR
15513 strncpy (fname
, (char *) fbeg
, flen
);
15515 f
= open_include_file (fname
, NULL
);
15521 /* Search directory path, trying to open the file.
15522 Copy each filename tried into FNAME. */
15524 for (searchptr
= search_start
; searchptr
; searchptr
= searchptr
->next
)
15526 if (searchptr
->fname
)
15528 /* The empty string in a search path is ignored.
15529 This makes it possible to turn off entirely
15530 a standard piece of the list. */
15531 if (searchptr
->fname
[0] == 0)
15533 strcpy (fname
, skip_redundant_dir_prefix (searchptr
->fname
));
15534 if (fname
[0] && fname
[strlen (fname
) - 1] != '/')
15535 strcat (fname
, "/");
15536 fname
[strlen (fname
) + flen
] = 0;
15541 strncat (fname
, fbeg
, flen
);
15543 /* Change this 1/2 Unix 1/2 VMS file specification into a
15544 full VMS file specification */
15545 if (searchptr
->fname
&& (searchptr
->fname
[0] != 0))
15547 /* Fix up the filename */
15548 hack_vms_include_specification (fname
);
15552 /* This is a normal VMS filespec, so use it unchanged. */
15553 strncpy (fname
, (char *) fbeg
, flen
);
15555 #if 0 /* Not for g77. */
15556 /* if it's '#include filename', add the missing .h */
15557 if (strchr (fname
, '.') == NULL
)
15558 strcat (fname
, ".h");
15562 f
= open_include_file (fname
, searchptr
);
15564 if (f
== NULL
&& errno
== EACCES
)
15566 print_containing_files (FFEBAD_severityWARNING
);
15567 /* xgettext:no-c-format */
15568 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15569 FFEBAD_severityWARNING
);
15570 ffebad_string (fname
);
15571 ffebad_here (0, l
, c
);
15582 /* A file that was not found. */
15584 strncpy (fname
, (char *) fbeg
, flen
);
15586 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE
));
15587 ffebad_start (FFEBAD_OPEN_INCLUDE
);
15588 ffebad_here (0, l
, c
);
15589 ffebad_string (fname
);
15593 if (dsp
[0].fname
!= NULL
)
15594 free (dsp
[0].fname
);
15599 if (indepth
>= (INPUT_STACK_MAX
- 1))
15601 print_containing_files (FFEBAD_severityFATAL
);
15602 /* xgettext:no-c-format */
15603 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15604 FFEBAD_severityFATAL
);
15605 ffebad_string (fname
);
15606 ffebad_here (0, l
, c
);
15611 instack
[indepth
].line
= ffewhere_line_use (l
);
15612 instack
[indepth
].column
= ffewhere_column_use (c
);
15614 fp
= &instack
[indepth
+ 1];
15615 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
15616 fp
->nominal_fname
= fp
->fname
= fname
;
15617 fp
->dir
= searchptr
;
15620 input_file_stack_tick
++;
15625 /**INDENT* (Do not reformat this comment even with -fca option.)
15626 Data-gathering files: Given the source file listed below, compiled with
15627 f2c I obtained the output file listed after that, and from the output
15628 file I derived the above code.
15630 -------- (begin input file to f2c)
15636 double precision D1,D2
15638 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15665 c FFEINTRIN_impACOS
15666 call fooR(ACOS(R1))
15667 c FFEINTRIN_impAIMAG
15668 call fooR(AIMAG(C1))
15669 c FFEINTRIN_impAINT
15670 call fooR(AINT(R1))
15671 c FFEINTRIN_impALOG
15672 call fooR(ALOG(R1))
15673 c FFEINTRIN_impALOG10
15674 call fooR(ALOG10(R1))
15675 c FFEINTRIN_impAMAX0
15676 call fooR(AMAX0(I1,I2))
15677 c FFEINTRIN_impAMAX1
15678 call fooR(AMAX1(R1,R2))
15679 c FFEINTRIN_impAMIN0
15680 call fooR(AMIN0(I1,I2))
15681 c FFEINTRIN_impAMIN1
15682 call fooR(AMIN1(R1,R2))
15683 c FFEINTRIN_impAMOD
15684 call fooR(AMOD(R1,R2))
15685 c FFEINTRIN_impANINT
15686 call fooR(ANINT(R1))
15687 c FFEINTRIN_impASIN
15688 call fooR(ASIN(R1))
15689 c FFEINTRIN_impATAN
15690 call fooR(ATAN(R1))
15691 c FFEINTRIN_impATAN2
15692 call fooR(ATAN2(R1,R2))
15693 c FFEINTRIN_impCABS
15694 call fooR(CABS(C1))
15695 c FFEINTRIN_impCCOS
15696 call fooC(CCOS(C1))
15697 c FFEINTRIN_impCEXP
15698 call fooC(CEXP(C1))
15699 c FFEINTRIN_impCHAR
15700 call fooA(CHAR(I1))
15701 c FFEINTRIN_impCLOG
15702 call fooC(CLOG(C1))
15703 c FFEINTRIN_impCONJG
15704 call fooC(CONJG(C1))
15707 c FFEINTRIN_impCOSH
15708 call fooR(COSH(R1))
15709 c FFEINTRIN_impCSIN
15710 call fooC(CSIN(C1))
15711 c FFEINTRIN_impCSQRT
15712 call fooC(CSQRT(C1))
15713 c FFEINTRIN_impDABS
15714 call fooD(DABS(D1))
15715 c FFEINTRIN_impDACOS
15716 call fooD(DACOS(D1))
15717 c FFEINTRIN_impDASIN
15718 call fooD(DASIN(D1))
15719 c FFEINTRIN_impDATAN
15720 call fooD(DATAN(D1))
15721 c FFEINTRIN_impDATAN2
15722 call fooD(DATAN2(D1,D2))
15723 c FFEINTRIN_impDCOS
15724 call fooD(DCOS(D1))
15725 c FFEINTRIN_impDCOSH
15726 call fooD(DCOSH(D1))
15727 c FFEINTRIN_impDDIM
15728 call fooD(DDIM(D1,D2))
15729 c FFEINTRIN_impDEXP
15730 call fooD(DEXP(D1))
15732 call fooR(DIM(R1,R2))
15733 c FFEINTRIN_impDINT
15734 call fooD(DINT(D1))
15735 c FFEINTRIN_impDLOG
15736 call fooD(DLOG(D1))
15737 c FFEINTRIN_impDLOG10
15738 call fooD(DLOG10(D1))
15739 c FFEINTRIN_impDMAX1
15740 call fooD(DMAX1(D1,D2))
15741 c FFEINTRIN_impDMIN1
15742 call fooD(DMIN1(D1,D2))
15743 c FFEINTRIN_impDMOD
15744 call fooD(DMOD(D1,D2))
15745 c FFEINTRIN_impDNINT
15746 call fooD(DNINT(D1))
15747 c FFEINTRIN_impDPROD
15748 call fooD(DPROD(R1,R2))
15749 c FFEINTRIN_impDSIGN
15750 call fooD(DSIGN(D1,D2))
15751 c FFEINTRIN_impDSIN
15752 call fooD(DSIN(D1))
15753 c FFEINTRIN_impDSINH
15754 call fooD(DSINH(D1))
15755 c FFEINTRIN_impDSQRT
15756 call fooD(DSQRT(D1))
15757 c FFEINTRIN_impDTAN
15758 call fooD(DTAN(D1))
15759 c FFEINTRIN_impDTANH
15760 call fooD(DTANH(D1))
15763 c FFEINTRIN_impIABS
15764 call fooI(IABS(I1))
15765 c FFEINTRIN_impICHAR
15766 call fooI(ICHAR(A1))
15767 c FFEINTRIN_impIDIM
15768 call fooI(IDIM(I1,I2))
15769 c FFEINTRIN_impIDNINT
15770 call fooI(IDNINT(D1))
15771 c FFEINTRIN_impINDEX
15772 call fooI(INDEX(A1,A2))
15773 c FFEINTRIN_impISIGN
15774 call fooI(ISIGN(I1,I2))
15778 call fooL(LGE(A1,A2))
15780 call fooL(LGT(A1,A2))
15782 call fooL(LLE(A1,A2))
15784 call fooL(LLT(A1,A2))
15785 c FFEINTRIN_impMAX0
15786 call fooI(MAX0(I1,I2))
15787 c FFEINTRIN_impMAX1
15788 call fooI(MAX1(R1,R2))
15789 c FFEINTRIN_impMIN0
15790 call fooI(MIN0(I1,I2))
15791 c FFEINTRIN_impMIN1
15792 call fooI(MIN1(R1,R2))
15794 call fooI(MOD(I1,I2))
15795 c FFEINTRIN_impNINT
15796 call fooI(NINT(R1))
15797 c FFEINTRIN_impSIGN
15798 call fooR(SIGN(R1,R2))
15801 c FFEINTRIN_impSINH
15802 call fooR(SINH(R1))
15803 c FFEINTRIN_impSQRT
15804 call fooR(SQRT(R1))
15807 c FFEINTRIN_impTANH
15808 call fooR(TANH(R1))
15809 c FFEINTRIN_imp_CMPLX_C
15810 call fooC(cmplx(C1,C2))
15811 c FFEINTRIN_imp_CMPLX_D
15812 call fooZ(cmplx(D1,D2))
15813 c FFEINTRIN_imp_CMPLX_I
15814 call fooC(cmplx(I1,I2))
15815 c FFEINTRIN_imp_CMPLX_R
15816 call fooC(cmplx(R1,R2))
15817 c FFEINTRIN_imp_DBLE_C
15818 call fooD(dble(C1))
15819 c FFEINTRIN_imp_DBLE_D
15820 call fooD(dble(D1))
15821 c FFEINTRIN_imp_DBLE_I
15822 call fooD(dble(I1))
15823 c FFEINTRIN_imp_DBLE_R
15824 call fooD(dble(R1))
15825 c FFEINTRIN_imp_INT_C
15827 c FFEINTRIN_imp_INT_D
15829 c FFEINTRIN_imp_INT_I
15831 c FFEINTRIN_imp_INT_R
15833 c FFEINTRIN_imp_REAL_C
15834 call fooR(real(C1))
15835 c FFEINTRIN_imp_REAL_D
15836 call fooR(real(D1))
15837 c FFEINTRIN_imp_REAL_I
15838 call fooR(real(I1))
15839 c FFEINTRIN_imp_REAL_R
15840 call fooR(real(R1))
15842 c FFEINTRIN_imp_INT_D:
15844 c FFEINTRIN_specIDINT
15845 call fooI(IDINT(D1))
15847 c FFEINTRIN_imp_INT_R:
15849 c FFEINTRIN_specIFIX
15850 call fooI(IFIX(R1))
15851 c FFEINTRIN_specINT
15854 c FFEINTRIN_imp_REAL_D:
15856 c FFEINTRIN_specSNGL
15857 call fooR(SNGL(D1))
15859 c FFEINTRIN_imp_REAL_I:
15861 c FFEINTRIN_specFLOAT
15862 call fooR(FLOAT(I1))
15863 c FFEINTRIN_specREAL
15864 call fooR(REAL(I1))
15867 -------- (end input file to f2c)
15869 -------- (begin output from providing above input file as input to:
15870 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
15871 -------- -e "s:^#.*$::g"')
15873 // -- translated by f2c (version 19950223).
15874 You must link the resulting object file with the libraries:
15875 -lf2c -lm (in that order)
15879 // f2c.h -- Standard Fortran to C header file //
15881 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
15883 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
15888 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
15889 // we assume short, float are OK //
15890 typedef long int // long int // integer;
15891 typedef char *address;
15892 typedef short int shortint;
15893 typedef float real;
15894 typedef double doublereal;
15895 typedef struct { real r, i; } complex;
15896 typedef struct { doublereal r, i; } doublecomplex;
15897 typedef long int // long int // logical;
15898 typedef short int shortlogical;
15899 typedef char logical1;
15900 typedef char integer1;
15901 // typedef long long longint; // // system-dependent //
15906 // Extern is for use with -E //
15920 typedef long int // int or long int // flag;
15921 typedef long int // int or long int // ftnlen;
15922 typedef long int // int or long int // ftnint;
15925 //external read, write//
15934 //internal read, write//
15964 //rewind, backspace, endfile//
15976 ftnint *inex; //parameters in standard's order//
16002 union Multitype { // for multiple entry points //
16013 typedef union Multitype Multitype;
16015 typedef long Long; // No longer used; formerly in Namelist //
16017 struct Vardesc { // for Namelist //
16023 typedef struct Vardesc Vardesc;
16030 typedef struct Namelist Namelist;
16039 // procedure parameter types for -A and -C++ //
16044 typedef int // Unknown procedure type // (*U_fp)();
16045 typedef shortint (*J_fp)();
16046 typedef integer (*I_fp)();
16047 typedef real (*R_fp)();
16048 typedef doublereal (*D_fp)(), (*E_fp)();
16049 typedef // Complex // void (*C_fp)();
16050 typedef // Double Complex // void (*Z_fp)();
16051 typedef logical (*L_fp)();
16052 typedef shortlogical (*K_fp)();
16053 typedef // Character // void (*H_fp)();
16054 typedef // Subroutine // int (*S_fp)();
16056 // E_fp is for real functions when -R is not specified //
16057 typedef void C_f; // complex function //
16058 typedef void H_f; // character function //
16059 typedef void Z_f; // double complex function //
16060 typedef doublereal E_f; // real function with -R not specified //
16062 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16065 // (No such symbols should be defined in a strict ANSI C compiler.
16066 We can avoid trouble with f2c-translated code by using
16091 // Main program // MAIN__()
16093 // System generated locals //
16096 doublereal d__1, d__2;
16098 doublecomplex z__1, z__2, z__3;
16102 // Builtin functions //
16105 double pow_ri(), pow_di();
16109 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16110 asin(), atan(), atan2(), c_abs();
16111 void c_cos(), c_exp(), c_log(), r_cnjg();
16112 double cos(), cosh();
16113 void c_sin(), c_sqrt();
16114 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16115 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16116 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16117 logical l_ge(), l_gt(), l_le(), l_lt();
16121 // Local variables //
16122 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16123 fool_(), fooz_(), getem_();
16124 static char a1[10], a2[10];
16125 static complex c1, c2;
16126 static doublereal d1, d2;
16127 static integer i1, i2;
16128 static real r1, r2;
16131 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16139 d__1 = (doublereal) i1;
16140 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16150 c_div(&q__1, &c1, &c2);
16152 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16154 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16157 i__1 = pow_ii(&i1, &i2);
16159 r__1 = pow_ri(&r1, &i1);
16161 d__1 = pow_di(&d1, &i1);
16163 pow_ci(&q__1, &c1, &i1);
16165 d__1 = (doublereal) r1;
16166 d__2 = (doublereal) r2;
16167 r__1 = pow_dd(&d__1, &d__2);
16169 d__2 = (doublereal) r1;
16170 d__1 = pow_dd(&d__2, &d1);
16172 d__1 = pow_dd(&d1, &d2);
16174 d__2 = (doublereal) r1;
16175 d__1 = pow_dd(&d1, &d__2);
16177 z__2.r = c1.r, z__2.i = c1.i;
16178 z__3.r = c2.r, z__3.i = c2.i;
16179 pow_zz(&z__1, &z__2, &z__3);
16180 q__1.r = z__1.r, q__1.i = z__1.i;
16182 z__2.r = c1.r, z__2.i = c1.i;
16183 z__3.r = r1, z__3.i = 0.;
16184 pow_zz(&z__1, &z__2, &z__3);
16185 q__1.r = z__1.r, q__1.i = z__1.i;
16187 z__2.r = c1.r, z__2.i = c1.i;
16188 z__3.r = d1, z__3.i = 0.;
16189 pow_zz(&z__1, &z__2, &z__3);
16191 // FFEINTRIN_impABS //
16192 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16194 // FFEINTRIN_impACOS //
16197 // FFEINTRIN_impAIMAG //
16198 r__1 = r_imag(&c1);
16200 // FFEINTRIN_impAINT //
16203 // FFEINTRIN_impALOG //
16206 // FFEINTRIN_impALOG10 //
16207 r__1 = r_lg10(&r1);
16209 // FFEINTRIN_impAMAX0 //
16210 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16212 // FFEINTRIN_impAMAX1 //
16213 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16215 // FFEINTRIN_impAMIN0 //
16216 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16218 // FFEINTRIN_impAMIN1 //
16219 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16221 // FFEINTRIN_impAMOD //
16222 r__1 = r_mod(&r1, &r2);
16224 // FFEINTRIN_impANINT //
16225 r__1 = r_nint(&r1);
16227 // FFEINTRIN_impASIN //
16230 // FFEINTRIN_impATAN //
16233 // FFEINTRIN_impATAN2 //
16234 r__1 = atan2(r1, r2);
16236 // FFEINTRIN_impCABS //
16239 // FFEINTRIN_impCCOS //
16242 // FFEINTRIN_impCEXP //
16245 // FFEINTRIN_impCHAR //
16246 *(unsigned char *)&ch__1[0] = i1;
16248 // FFEINTRIN_impCLOG //
16251 // FFEINTRIN_impCONJG //
16252 r_cnjg(&q__1, &c1);
16254 // FFEINTRIN_impCOS //
16257 // FFEINTRIN_impCOSH //
16260 // FFEINTRIN_impCSIN //
16263 // FFEINTRIN_impCSQRT //
16264 c_sqrt(&q__1, &c1);
16266 // FFEINTRIN_impDABS //
16267 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16269 // FFEINTRIN_impDACOS //
16272 // FFEINTRIN_impDASIN //
16275 // FFEINTRIN_impDATAN //
16278 // FFEINTRIN_impDATAN2 //
16279 d__1 = atan2(d1, d2);
16281 // FFEINTRIN_impDCOS //
16284 // FFEINTRIN_impDCOSH //
16287 // FFEINTRIN_impDDIM //
16288 d__1 = d_dim(&d1, &d2);
16290 // FFEINTRIN_impDEXP //
16293 // FFEINTRIN_impDIM //
16294 r__1 = r_dim(&r1, &r2);
16296 // FFEINTRIN_impDINT //
16299 // FFEINTRIN_impDLOG //
16302 // FFEINTRIN_impDLOG10 //
16303 d__1 = d_lg10(&d1);
16305 // FFEINTRIN_impDMAX1 //
16306 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16308 // FFEINTRIN_impDMIN1 //
16309 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16311 // FFEINTRIN_impDMOD //
16312 d__1 = d_mod(&d1, &d2);
16314 // FFEINTRIN_impDNINT //
16315 d__1 = d_nint(&d1);
16317 // FFEINTRIN_impDPROD //
16318 d__1 = (doublereal) r1 * r2;
16320 // FFEINTRIN_impDSIGN //
16321 d__1 = d_sign(&d1, &d2);
16323 // FFEINTRIN_impDSIN //
16326 // FFEINTRIN_impDSINH //
16329 // FFEINTRIN_impDSQRT //
16332 // FFEINTRIN_impDTAN //
16335 // FFEINTRIN_impDTANH //
16338 // FFEINTRIN_impEXP //
16341 // FFEINTRIN_impIABS //
16342 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16344 // FFEINTRIN_impICHAR //
16345 i__1 = *(unsigned char *)a1;
16347 // FFEINTRIN_impIDIM //
16348 i__1 = i_dim(&i1, &i2);
16350 // FFEINTRIN_impIDNINT //
16351 i__1 = i_dnnt(&d1);
16353 // FFEINTRIN_impINDEX //
16354 i__1 = i_indx(a1, a2, 10L, 10L);
16356 // FFEINTRIN_impISIGN //
16357 i__1 = i_sign(&i1, &i2);
16359 // FFEINTRIN_impLEN //
16360 i__1 = i_len(a1, 10L);
16362 // FFEINTRIN_impLGE //
16363 L__1 = l_ge(a1, a2, 10L, 10L);
16365 // FFEINTRIN_impLGT //
16366 L__1 = l_gt(a1, a2, 10L, 10L);
16368 // FFEINTRIN_impLLE //
16369 L__1 = l_le(a1, a2, 10L, 10L);
16371 // FFEINTRIN_impLLT //
16372 L__1 = l_lt(a1, a2, 10L, 10L);
16374 // FFEINTRIN_impMAX0 //
16375 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16377 // FFEINTRIN_impMAX1 //
16378 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16380 // FFEINTRIN_impMIN0 //
16381 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16383 // FFEINTRIN_impMIN1 //
16384 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16386 // FFEINTRIN_impMOD //
16389 // FFEINTRIN_impNINT //
16390 i__1 = i_nint(&r1);
16392 // FFEINTRIN_impSIGN //
16393 r__1 = r_sign(&r1, &r2);
16395 // FFEINTRIN_impSIN //
16398 // FFEINTRIN_impSINH //
16401 // FFEINTRIN_impSQRT //
16404 // FFEINTRIN_impTAN //
16407 // FFEINTRIN_impTANH //
16410 // FFEINTRIN_imp_CMPLX_C //
16413 q__1.r = r__1, q__1.i = r__2;
16415 // FFEINTRIN_imp_CMPLX_D //
16416 z__1.r = d1, z__1.i = d2;
16418 // FFEINTRIN_imp_CMPLX_I //
16421 q__1.r = r__1, q__1.i = r__2;
16423 // FFEINTRIN_imp_CMPLX_R //
16424 q__1.r = r1, q__1.i = r2;
16426 // FFEINTRIN_imp_DBLE_C //
16427 d__1 = (doublereal) c1.r;
16429 // FFEINTRIN_imp_DBLE_D //
16432 // FFEINTRIN_imp_DBLE_I //
16433 d__1 = (doublereal) i1;
16435 // FFEINTRIN_imp_DBLE_R //
16436 d__1 = (doublereal) r1;
16438 // FFEINTRIN_imp_INT_C //
16439 i__1 = (integer) c1.r;
16441 // FFEINTRIN_imp_INT_D //
16442 i__1 = (integer) d1;
16444 // FFEINTRIN_imp_INT_I //
16447 // FFEINTRIN_imp_INT_R //
16448 i__1 = (integer) r1;
16450 // FFEINTRIN_imp_REAL_C //
16453 // FFEINTRIN_imp_REAL_D //
16456 // FFEINTRIN_imp_REAL_I //
16459 // FFEINTRIN_imp_REAL_R //
16463 // FFEINTRIN_imp_INT_D: //
16465 // FFEINTRIN_specIDINT //
16466 i__1 = (integer) d1;
16469 // FFEINTRIN_imp_INT_R: //
16471 // FFEINTRIN_specIFIX //
16472 i__1 = (integer) r1;
16474 // FFEINTRIN_specINT //
16475 i__1 = (integer) r1;
16478 // FFEINTRIN_imp_REAL_D: //
16480 // FFEINTRIN_specSNGL //
16484 // FFEINTRIN_imp_REAL_I: //
16486 // FFEINTRIN_specFLOAT //
16489 // FFEINTRIN_specREAL //
16495 -------- (end output file from f2c)
16499 #include "gt-f-com.h"
16500 #include "gtype-f.h"