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_ (tree type
, tree expr
)
1114 register tree e
= expr
;
1115 register enum tree_code code
= TREE_CODE (type
);
1117 if (type
== TREE_TYPE (e
)
1118 || TREE_CODE (e
) == ERROR_MARK
)
1120 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
1121 return fold (build1 (NOP_EXPR
, type
, e
));
1122 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
1123 || code
== ERROR_MARK
)
1124 return error_mark_node
;
1125 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
1127 assert ("void value not ignored as it ought to be" == NULL
);
1128 return error_mark_node
;
1130 assert (code
!= VOID_TYPE
);
1131 if ((code
!= RECORD_TYPE
)
1132 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
1133 assert ("converting COMPLEX to REAL" == NULL
);
1134 assert (code
!= ENUMERAL_TYPE
);
1135 if (code
== INTEGER_TYPE
)
1137 assert ((TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
1138 && TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)))
1139 || (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
1140 && (TYPE_PRECISION (type
)
1141 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e
))))));
1142 return fold (convert_to_integer (type
, e
));
1144 if (code
== POINTER_TYPE
)
1146 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1147 return fold (convert_to_pointer (type
, e
));
1149 if (code
== REAL_TYPE
)
1151 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1152 assert (TYPE_PRECISION (type
) <= TYPE_PRECISION (TREE_TYPE (e
)));
1153 return fold (convert_to_real (type
, e
));
1155 if (code
== COMPLEX_TYPE
)
1157 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1158 assert (TYPE_PRECISION (TREE_TYPE (type
)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1159 return fold (convert_to_complex (type
, e
));
1161 if (code
== RECORD_TYPE
)
1163 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1164 /* Check that at least the first field name agrees. */
1165 assert (DECL_NAME (TYPE_FIELDS (type
))
1166 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e
))));
1167 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1168 <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1169 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1170 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))))
1172 return fold (ffecom_convert_to_complex_ (type
, e
));
1175 assert ("conversion to non-scalar type requested" == NULL
);
1176 return error_mark_node
;
1179 /* Like gcc's convert(), but crashes if narrowing might happen. */
1182 ffecom_convert_widen_ (tree type
, tree expr
)
1184 register tree e
= expr
;
1185 register enum tree_code code
= TREE_CODE (type
);
1187 if (type
== TREE_TYPE (e
)
1188 || TREE_CODE (e
) == ERROR_MARK
)
1190 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
1191 return fold (build1 (NOP_EXPR
, type
, e
));
1192 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
1193 || code
== ERROR_MARK
)
1194 return error_mark_node
;
1195 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
1197 assert ("void value not ignored as it ought to be" == NULL
);
1198 return error_mark_node
;
1200 assert (code
!= VOID_TYPE
);
1201 if ((code
!= RECORD_TYPE
)
1202 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
1203 assert ("narrowing COMPLEX to REAL" == NULL
);
1204 assert (code
!= ENUMERAL_TYPE
);
1205 if (code
== INTEGER_TYPE
)
1207 assert ((TREE_CODE (TREE_TYPE (e
)) == INTEGER_TYPE
1208 && TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)))
1209 || (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
1210 && (TYPE_PRECISION (type
)
1211 == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e
))))));
1212 return fold (convert_to_integer (type
, e
));
1214 if (code
== POINTER_TYPE
)
1216 assert (TREE_CODE (TREE_TYPE (e
)) == POINTER_TYPE
);
1217 return fold (convert_to_pointer (type
, e
));
1219 if (code
== REAL_TYPE
)
1221 assert (TREE_CODE (TREE_TYPE (e
)) == REAL_TYPE
);
1222 assert (TYPE_PRECISION (type
) >= TYPE_PRECISION (TREE_TYPE (e
)));
1223 return fold (convert_to_real (type
, e
));
1225 if (code
== COMPLEX_TYPE
)
1227 assert (TREE_CODE (TREE_TYPE (e
)) == COMPLEX_TYPE
);
1228 assert (TYPE_PRECISION (TREE_TYPE (type
)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e
))));
1229 return fold (convert_to_complex (type
, e
));
1231 if (code
== RECORD_TYPE
)
1233 assert (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
);
1234 /* Check that at least the first field name agrees. */
1235 assert (DECL_NAME (TYPE_FIELDS (type
))
1236 == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e
))));
1237 assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1238 >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))));
1239 if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type
)))
1240 == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
)))))
1242 return fold (ffecom_convert_to_complex_ (type
, e
));
1245 assert ("conversion to non-scalar type requested" == NULL
);
1246 return error_mark_node
;
1249 /* Handles making a COMPLEX type, either the standard
1250 (but buggy?) gbe way, or the safer (but less elegant?)
1254 ffecom_make_complex_type_ (tree subtype
)
1260 if (ffe_is_emulate_complex ())
1262 type
= make_node (RECORD_TYPE
);
1263 realfield
= ffecom_decl_field (type
, NULL_TREE
, "r", subtype
);
1264 imagfield
= ffecom_decl_field (type
, realfield
, "i", subtype
);
1265 TYPE_FIELDS (type
) = realfield
;
1270 type
= make_node (COMPLEX_TYPE
);
1271 TREE_TYPE (type
) = subtype
;
1278 /* Chooses either the gbe or the f2c way to build a
1279 complex constant. */
1282 ffecom_build_complex_constant_ (tree type
, tree realpart
, tree imagpart
)
1286 if (ffe_is_emulate_complex ())
1288 bothparts
= build_tree_list (TYPE_FIELDS (type
), realpart
);
1289 TREE_CHAIN (bothparts
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), imagpart
);
1290 bothparts
= build (CONSTRUCTOR
, type
, NULL_TREE
, bothparts
);
1294 bothparts
= build_complex (type
, realpart
, imagpart
);
1301 ffecom_arglist_expr_ (const char *c
, ffebld expr
)
1304 tree
*plist
= &list
;
1305 tree trail
= NULL_TREE
; /* Append char length args here. */
1306 tree
*ptrail
= &trail
;
1311 tree wanted
= NULL_TREE
;
1312 static const char zed
[] = "0";
1317 while (expr
!= NULL
)
1340 wanted
= ffecom_f2c_complex_type_node
;
1344 wanted
= ffecom_f2c_doublereal_type_node
;
1348 wanted
= ffecom_f2c_doublecomplex_type_node
;
1352 wanted
= ffecom_f2c_real_type_node
;
1356 wanted
= ffecom_f2c_integer_type_node
;
1360 wanted
= ffecom_f2c_longint_type_node
;
1364 assert ("bad argstring code" == NULL
);
1370 exprh
= ffebld_head (expr
);
1374 if ((wanted
== NULL_TREE
)
1377 (ffecom_tree_type
[ffeinfo_basictype (ffebld_info (exprh
))]
1378 [ffeinfo_kindtype (ffebld_info (exprh
))])
1379 == TYPE_MODE (wanted
))))
1381 = build_tree_list (NULL_TREE
,
1382 ffecom_arg_ptr_to_expr (exprh
,
1386 item
= ffecom_arg_expr (exprh
, &length
);
1387 item
= ffecom_convert_widen_ (wanted
, item
);
1390 item
= ffecom_1 (ADDR_EXPR
,
1391 build_pointer_type (TREE_TYPE (item
)),
1395 = build_tree_list (NULL_TREE
,
1399 plist
= &TREE_CHAIN (*plist
);
1400 expr
= ffebld_trail (expr
);
1401 if (length
!= NULL_TREE
)
1403 *ptrail
= build_tree_list (NULL_TREE
, length
);
1404 ptrail
= &TREE_CHAIN (*ptrail
);
1408 /* We've run out of args in the call; if the implementation expects
1409 more, supply null pointers for them, which the implementation can
1410 check to see if an arg was omitted. */
1412 while (*c
!= '\0' && *c
!= '0')
1417 assert ("missing arg to run-time routine!" == NULL
);
1432 assert ("bad arg string code" == NULL
);
1436 = build_tree_list (NULL_TREE
,
1438 plist
= &TREE_CHAIN (*plist
);
1447 ffecom_widest_expr_type_ (ffebld list
)
1450 ffebld widest
= NULL
;
1452 ffetype widest_type
= NULL
;
1455 for (; list
!= NULL
; list
= ffebld_trail (list
))
1457 item
= ffebld_head (list
);
1460 if ((widest
!= NULL
)
1461 && (ffeinfo_basictype (ffebld_info (item
))
1462 != ffeinfo_basictype (ffebld_info (widest
))))
1464 type
= ffeinfo_type (ffeinfo_basictype (ffebld_info (item
)),
1465 ffeinfo_kindtype (ffebld_info (item
)));
1466 if ((widest
== FFEINFO_kindtypeNONE
)
1467 || (ffetype_size (type
)
1468 > ffetype_size (widest_type
)))
1475 assert (widest
!= NULL
);
1476 t
= ffecom_tree_type
[ffeinfo_basictype (ffebld_info (widest
))]
1477 [ffeinfo_kindtype (ffebld_info (widest
))];
1478 assert (t
!= NULL_TREE
);
1482 /* Check whether a partial overlap between two expressions is possible.
1484 Can *starting* to write a portion of expr1 change the value
1485 computed (perhaps already, *partially*) by expr2?
1487 Currently, this is a concern only for a COMPLEX expr1. But if it
1488 isn't in COMMON or local EQUIVALENCE, since we don't support
1489 aliasing of arguments, it isn't a concern. */
1492 ffecom_possible_partial_overlap_ (ffebld expr1
, ffebld expr2 ATTRIBUTE_UNUSED
)
1497 switch (ffebld_op (expr1
))
1499 case FFEBLD_opSYMTER
:
1500 sym
= ffebld_symter (expr1
);
1503 case FFEBLD_opARRAYREF
:
1504 if (ffebld_op (ffebld_left (expr1
)) != FFEBLD_opSYMTER
)
1506 sym
= ffebld_symter (ffebld_left (expr1
));
1513 if (ffesymbol_where (sym
) != FFEINFO_whereCOMMON
1514 && (ffesymbol_where (sym
) != FFEINFO_whereLOCAL
1515 || ! (st
= ffesymbol_storage (sym
))
1516 || ! ffestorag_parent (st
)))
1519 /* It's in COMMON or local EQUIVALENCE. */
1524 /* Check whether dest and source might overlap. ffebld versions of these
1525 might or might not be passed, will be NULL if not.
1527 The test is really whether source_tree is modifiable and, if modified,
1528 might overlap destination such that the value(s) in the destination might
1529 change before it is finally modified. dest_* are the canonized
1530 destination itself. */
1533 ffecom_overlap_ (tree dest_decl
, tree dest_offset
, tree dest_size
,
1534 tree source_tree
, ffebld source UNUSED
,
1542 if (source_tree
== NULL_TREE
)
1545 switch (TREE_CODE (source_tree
))
1548 case IDENTIFIER_NODE
:
1559 case TRUNC_DIV_EXPR
:
1561 case FLOOR_DIV_EXPR
:
1562 case ROUND_DIV_EXPR
:
1563 case TRUNC_MOD_EXPR
:
1565 case FLOOR_MOD_EXPR
:
1566 case ROUND_MOD_EXPR
:
1568 case EXACT_DIV_EXPR
:
1569 case FIX_TRUNC_EXPR
:
1571 case FIX_FLOOR_EXPR
:
1572 case FIX_ROUND_EXPR
:
1586 case BIT_ANDTC_EXPR
:
1588 case TRUTH_ANDIF_EXPR
:
1589 case TRUTH_ORIF_EXPR
:
1590 case TRUTH_AND_EXPR
:
1592 case TRUTH_XOR_EXPR
:
1593 case TRUTH_NOT_EXPR
:
1609 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1610 TREE_OPERAND (source_tree
, 1), NULL
,
1614 return ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1615 TREE_OPERAND (source_tree
, 0), NULL
,
1620 case NON_LVALUE_EXPR
:
1622 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1625 ffecom_tree_canonize_ptr_ (&source_decl
, &source_offset
,
1627 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1632 ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1633 TREE_OPERAND (source_tree
, 1), NULL
,
1635 || ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1636 TREE_OPERAND (source_tree
, 2), NULL
,
1641 ffecom_tree_canonize_ref_ (&source_decl
, &source_offset
,
1643 TREE_OPERAND (source_tree
, 0));
1647 if (TREE_CODE (TREE_TYPE (source_tree
)) != POINTER_TYPE
)
1650 source_decl
= source_tree
;
1651 source_offset
= bitsize_zero_node
;
1652 source_size
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree
)));
1656 case REFERENCE_EXPR
:
1657 case PREDECREMENT_EXPR
:
1658 case PREINCREMENT_EXPR
:
1659 case POSTDECREMENT_EXPR
:
1660 case POSTINCREMENT_EXPR
:
1668 /* Come here when source_decl, source_offset, and source_size filled
1669 in appropriately. */
1671 if (source_decl
== NULL_TREE
)
1672 return FALSE
; /* No decl involved, so no overlap. */
1674 if (source_decl
!= dest_decl
)
1675 return FALSE
; /* Different decl, no overlap. */
1677 if (TREE_CODE (dest_size
) == ERROR_MARK
)
1678 return TRUE
; /* Assignment into entire assumed-size
1679 array? Shouldn't happen.... */
1681 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1682 ffecom_2 (PLUS_EXPR
, TREE_TYPE (dest_offset
),
1684 convert (TREE_TYPE (dest_offset
),
1686 convert (TREE_TYPE (dest_offset
),
1689 if (integer_onep (t
))
1690 return FALSE
; /* Destination precedes source. */
1693 || (source_size
== NULL_TREE
)
1694 || (TREE_CODE (source_size
) == ERROR_MARK
)
1695 || integer_zerop (source_size
))
1696 return TRUE
; /* No way to tell if dest follows source. */
1698 t
= ffecom_2 (LE_EXPR
, integer_type_node
,
1699 ffecom_2 (PLUS_EXPR
, TREE_TYPE (source_offset
),
1701 convert (TREE_TYPE (source_offset
),
1703 convert (TREE_TYPE (source_offset
),
1706 if (integer_onep (t
))
1707 return FALSE
; /* Destination follows source. */
1709 return TRUE
; /* Destination and source overlap. */
1712 /* Check whether dest might overlap any of a list of arguments or is
1713 in a COMMON area the callee might know about (and thus modify). */
1716 ffecom_args_overlapping_ (tree dest_tree
, ffebld dest UNUSED
,
1717 tree args
, tree callee_commons
,
1725 ffecom_tree_canonize_ref_ (&dest_decl
, &dest_offset
, &dest_size
,
1728 if (dest_decl
== NULL_TREE
)
1729 return FALSE
; /* Seems unlikely! */
1731 /* If the decl cannot be determined reliably, or if its in COMMON
1732 and the callee isn't known to not futz with COMMON via other
1733 means, overlap might happen. */
1735 if ((TREE_CODE (dest_decl
) == ERROR_MARK
)
1736 || ((callee_commons
!= NULL_TREE
)
1737 && TREE_PUBLIC (dest_decl
)))
1740 for (; args
!= NULL_TREE
; args
= TREE_CHAIN (args
))
1742 if (((arg
= TREE_VALUE (args
)) != NULL_TREE
)
1743 && ffecom_overlap_ (dest_decl
, dest_offset
, dest_size
,
1744 arg
, NULL
, scalar_args
))
1751 /* Build a string for a variable name as used by NAMELIST. This means that
1752 if we're using the f2c library, we build an uppercase string, since
1756 ffecom_build_f2c_string_ (int i
, const char *s
)
1758 if (!ffe_is_f2c_library ())
1759 return build_string (i
, s
);
1768 if (((size_t) i
) > ARRAY_SIZE (space
))
1769 tmp
= malloc_new_ks (malloc_pool_image (), "f2c_string", i
);
1773 for (p
= s
, q
= tmp
; *p
!= '\0'; ++p
, ++q
)
1777 t
= build_string (i
, tmp
);
1779 if (((size_t) i
) > ARRAY_SIZE (space
))
1780 malloc_kill_ks (malloc_pool_image (), tmp
, i
);
1786 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1787 type to just get whatever the function returns), handling the
1788 f2c value-returning convention, if required, by prepending
1789 to the arglist a pointer to a temporary to receive the return value. */
1792 ffecom_call_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1793 tree type
, tree args
, tree dest_tree
,
1794 ffebld dest
, bool *dest_used
, tree callee_commons
,
1795 bool scalar_args
, tree hook
)
1800 if (dest_used
!= NULL
)
1805 if ((dest_used
== NULL
)
1807 || (ffeinfo_basictype (ffebld_info (dest
))
1808 != FFEINFO_basictypeCOMPLEX
)
1809 || (ffeinfo_kindtype (ffebld_info (dest
)) != kt
)
1810 || ((type
!= NULL_TREE
) && (TREE_TYPE (dest_tree
) != type
))
1811 || ffecom_args_overlapping_ (dest_tree
, dest
, args
,
1821 tempvar
= dest_tree
;
1826 = build_tree_list (NULL_TREE
,
1827 ffecom_1 (ADDR_EXPR
,
1828 build_pointer_type (TREE_TYPE (tempvar
)),
1830 TREE_CHAIN (item
) = args
;
1832 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1835 if (tempvar
!= dest_tree
)
1836 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
, tempvar
);
1839 item
= ffecom_3s (CALL_EXPR
, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn
))), fn
,
1842 if ((type
!= NULL_TREE
) && (TREE_TYPE (item
) != type
))
1843 item
= ffecom_convert_narrow_ (type
, item
);
1848 /* Given two arguments, transform them and make a call to the given
1849 function via ffecom_call_. */
1852 ffecom_call_binop_ (tree fn
, ffeinfoKindtype kt
, bool is_f2c_complex
,
1853 tree type
, ffebld left
, ffebld right
,
1854 tree dest_tree
, ffebld dest
, bool *dest_used
,
1855 tree callee_commons
, bool scalar_args
, bool ref
, tree hook
)
1864 /* Pass arguments by reference. */
1865 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
1866 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
1870 /* Pass arguments by value. */
1871 left_tree
= ffecom_arg_expr (left
, &left_length
);
1872 right_tree
= ffecom_arg_expr (right
, &right_length
);
1876 left_tree
= build_tree_list (NULL_TREE
, left_tree
);
1877 right_tree
= build_tree_list (NULL_TREE
, right_tree
);
1878 TREE_CHAIN (left_tree
) = right_tree
;
1880 if (left_length
!= NULL_TREE
)
1882 left_length
= build_tree_list (NULL_TREE
, left_length
);
1883 TREE_CHAIN (right_tree
) = left_length
;
1886 if (right_length
!= NULL_TREE
)
1888 right_length
= build_tree_list (NULL_TREE
, right_length
);
1889 if (left_length
!= NULL_TREE
)
1890 TREE_CHAIN (left_length
) = right_length
;
1892 TREE_CHAIN (right_tree
) = right_length
;
1895 return ffecom_call_ (fn
, kt
, is_f2c_complex
, type
, left_tree
,
1896 dest_tree
, dest
, dest_used
, callee_commons
,
1900 /* Return ptr/length args for char subexpression
1902 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1903 subexpressions by constructing the appropriate trees for the ptr-to-
1904 character-text and length-of-character-text arguments in a calling
1907 Note that if with_null is TRUE, and the expression is an opCONTER,
1908 a null byte is appended to the string. */
1911 ffecom_char_args_x_ (tree
*xitem
, tree
*length
, ffebld expr
, bool with_null
)
1915 ffetargetCharacter1 val
;
1916 ffetargetCharacterSize newlen
;
1918 switch (ffebld_op (expr
))
1920 case FFEBLD_opCONTER
:
1921 val
= ffebld_constant_character1 (ffebld_conter (expr
));
1922 newlen
= ffetarget_length_character1 (val
);
1925 /* Begin FFETARGET-NULL-KLUDGE. */
1929 *length
= build_int_2 (newlen
, 0);
1930 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1931 high
= build_int_2 (newlen
, 0);
1932 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
1933 item
= build_string (newlen
,
1934 ffetarget_text_character1 (val
));
1935 /* End FFETARGET-NULL-KLUDGE. */
1937 = build_type_variant
1941 (ffecom_f2c_ftnlen_type_node
,
1942 ffecom_f2c_ftnlen_one_node
,
1945 TREE_CONSTANT (item
) = 1;
1946 TREE_STATIC (item
) = 1;
1947 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
1951 case FFEBLD_opSYMTER
:
1953 ffesymbol s
= ffebld_symter (expr
);
1955 item
= ffesymbol_hook (s
).decl_tree
;
1956 if (item
== NULL_TREE
)
1958 s
= ffecom_sym_transform_ (s
);
1959 item
= ffesymbol_hook (s
).decl_tree
;
1961 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
1963 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
1964 *length
= ffesymbol_hook (s
).length_tree
;
1967 *length
= build_int_2 (ffesymbol_size (s
), 0);
1968 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
1971 else if (item
== error_mark_node
)
1972 *length
= error_mark_node
;
1974 /* FFEINFO_kindFUNCTION. */
1975 *length
= NULL_TREE
;
1976 if (!ffesymbol_hook (s
).addr
1977 && (item
!= error_mark_node
))
1978 item
= ffecom_1 (ADDR_EXPR
,
1979 build_pointer_type (TREE_TYPE (item
)),
1984 case FFEBLD_opARRAYREF
:
1986 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
1988 if (item
== error_mark_node
|| *length
== error_mark_node
)
1990 item
= *length
= error_mark_node
;
1994 item
= ffecom_arrayref_ (item
, expr
, 1);
1998 case FFEBLD_opSUBSTR
:
2002 ffebld thing
= ffebld_right (expr
);
2005 const char *char_name
;
2009 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
2010 start
= ffebld_head (thing
);
2011 thing
= ffebld_trail (thing
);
2012 assert (ffebld_trail (thing
) == NULL
);
2013 end
= ffebld_head (thing
);
2015 /* Determine name for pretty-printing range-check errors. */
2016 for (left_symter
= ffebld_left (expr
);
2017 left_symter
&& ffebld_op (left_symter
) == FFEBLD_opARRAYREF
;
2018 left_symter
= ffebld_left (left_symter
))
2020 if (ffebld_op (left_symter
) == FFEBLD_opSYMTER
)
2021 char_name
= ffesymbol_text (ffebld_symter (left_symter
));
2023 char_name
= "[expr?]";
2025 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
2027 if (item
== error_mark_node
|| *length
== error_mark_node
)
2029 item
= *length
= error_mark_node
;
2033 array
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item
)));
2035 /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF. */
2043 end_tree
= ffecom_expr (end
);
2044 if (flag_bounds_check
)
2045 end_tree
= ffecom_subscript_check_ (array
, end_tree
, 1, 0,
2047 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2050 if (end_tree
== error_mark_node
)
2052 item
= *length
= error_mark_node
;
2061 start_tree
= ffecom_expr (start
);
2062 if (flag_bounds_check
)
2063 start_tree
= ffecom_subscript_check_ (array
, start_tree
, 0, 0,
2065 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2068 if (start_tree
== error_mark_node
)
2070 item
= *length
= error_mark_node
;
2074 start_tree
= ffecom_save_tree (start_tree
);
2076 item
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (item
),
2078 ffecom_2 (MINUS_EXPR
,
2079 TREE_TYPE (start_tree
),
2081 ffecom_f2c_ftnlen_one_node
));
2085 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
2086 ffecom_f2c_ftnlen_one_node
,
2087 ffecom_2 (MINUS_EXPR
,
2088 ffecom_f2c_ftnlen_type_node
,
2094 end_tree
= ffecom_expr (end
);
2095 if (flag_bounds_check
)
2096 end_tree
= ffecom_subscript_check_ (array
, end_tree
, 1, 0,
2098 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
2101 if (end_tree
== error_mark_node
)
2103 item
= *length
= error_mark_node
;
2107 *length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
2108 ffecom_f2c_ftnlen_one_node
,
2109 ffecom_2 (MINUS_EXPR
,
2110 ffecom_f2c_ftnlen_type_node
,
2111 end_tree
, start_tree
));
2117 case FFEBLD_opFUNCREF
:
2119 ffesymbol s
= ffebld_symter (ffebld_left (expr
));
2122 ffetargetCharacterSize size
= ffeinfo_size (ffebld_info (expr
));
2125 if (size
== FFETARGET_charactersizeNONE
)
2126 /* ~~Kludge alert! This should someday be fixed. */
2129 *length
= build_int_2 (size
, 0);
2130 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2132 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
2133 == FFEINFO_whereINTRINSIC
)
2137 /* Invocation of an intrinsic returning CHARACTER*1. */
2138 item
= ffecom_expr_intrinsic_ (expr
, NULL_TREE
,
2142 ix
= ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr
)));
2143 assert (ix
!= FFECOM_gfrt
);
2144 item
= ffecom_gfrt_tree_ (ix
);
2149 item
= ffesymbol_hook (s
).decl_tree
;
2150 if (item
== NULL_TREE
)
2152 s
= ffecom_sym_transform_ (s
);
2153 item
= ffesymbol_hook (s
).decl_tree
;
2155 if (item
== error_mark_node
)
2157 item
= *length
= error_mark_node
;
2161 if (!ffesymbol_hook (s
).addr
)
2162 item
= ffecom_1_fn (item
);
2164 tempvar
= ffebld_nonter_hook (expr
);
2166 tempvar
= ffecom_1 (ADDR_EXPR
,
2167 build_pointer_type (TREE_TYPE (tempvar
)),
2170 args
= build_tree_list (NULL_TREE
, tempvar
);
2172 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
) /* Sfunc args by value. */
2173 TREE_CHAIN (args
) = ffecom_list_expr (ffebld_right (expr
));
2176 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, *length
);
2177 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
2179 TREE_CHAIN (TREE_CHAIN (args
))
2180 = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix
),
2181 ffebld_right (expr
));
2185 TREE_CHAIN (TREE_CHAIN (args
))
2186 = ffecom_list_ptr_to_expr (ffebld_right (expr
));
2190 item
= ffecom_3s (CALL_EXPR
,
2191 TREE_TYPE (TREE_TYPE (TREE_TYPE (item
))),
2192 item
, args
, NULL_TREE
);
2193 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), item
,
2198 case FFEBLD_opCONVERT
:
2200 ffecom_char_args_ (&item
, length
, ffebld_left (expr
));
2202 if (item
== error_mark_node
|| *length
== error_mark_node
)
2204 item
= *length
= error_mark_node
;
2208 if ((ffebld_size_known (ffebld_left (expr
))
2209 == FFETARGET_charactersizeNONE
)
2210 || (ffebld_size_known (ffebld_left (expr
)) < (ffebld_size (expr
))))
2211 { /* Possible blank-padding needed, copy into
2217 tempvar
= ffebld_nonter_hook (expr
);
2219 tempvar
= ffecom_1 (ADDR_EXPR
,
2220 build_pointer_type (TREE_TYPE (tempvar
)),
2223 newlen
= build_int_2 (ffebld_size (expr
), 0);
2224 TREE_TYPE (newlen
) = ffecom_f2c_ftnlen_type_node
;
2226 args
= build_tree_list (NULL_TREE
, tempvar
);
2227 TREE_CHAIN (args
) = build_tree_list (NULL_TREE
, item
);
2228 TREE_CHAIN (TREE_CHAIN (args
)) = build_tree_list (NULL_TREE
, newlen
);
2229 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args
)))
2230 = build_tree_list (NULL_TREE
, *length
);
2232 item
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, args
, NULL_TREE
);
2233 TREE_SIDE_EFFECTS (item
) = 1;
2234 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
), fold (item
),
2239 { /* Just truncate the length. */
2240 *length
= build_int_2 (ffebld_size (expr
), 0);
2241 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
2246 assert ("bad op for single char arg expr" == NULL
);
2254 /* Check the size of the type to be sure it doesn't overflow the
2255 "portable" capacities of the compiler back end. `dummy' types
2256 can generally overflow the normal sizes as long as the computations
2257 themselves don't overflow. A particular target of the back end
2258 must still enforce its size requirements, though, and the back
2259 end takes care of this in stor-layout.c. */
2262 ffecom_check_size_overflow_ (ffesymbol s
, tree type
, bool dummy
)
2264 if (TREE_CODE (type
) == ERROR_MARK
)
2267 if (TYPE_SIZE (type
) == NULL_TREE
)
2270 if (TREE_CODE (TYPE_SIZE (type
)) != INTEGER_CST
)
2273 /* An array is too large if size is negative or the type_size overflows
2274 or its "upper half" is larger than 3 (which would make the signed
2275 byte size and offset computations overflow). */
2277 if ((tree_int_cst_sgn (TYPE_SIZE (type
)) < 0)
2278 || (!dummy
&& (TREE_INT_CST_HIGH (TYPE_SIZE (type
)) > 3
2279 || TREE_OVERFLOW (TYPE_SIZE (type
)))))
2281 ffebad_start (FFEBAD_ARRAY_LARGE
);
2282 ffebad_string (ffesymbol_text (s
));
2283 ffebad_here (0, ffesymbol_where_line (s
), ffesymbol_where_column (s
));
2286 return error_mark_node
;
2292 /* Builds a length argument (PARM_DECL). Also wraps type in an array type
2293 where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2294 known, length_arg if not known (FFETARGET_charactersizeNONE). */
2297 ffecom_char_enhance_arg_ (tree
*xtype
, ffesymbol s
)
2299 ffetargetCharacterSize sz
= ffesymbol_size (s
);
2304 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
2305 tlen
= NULL_TREE
; /* A statement function, no length passed. */
2308 if (ffesymbol_where (s
) == FFEINFO_whereDUMMY
)
2309 tlen
= ffecom_get_invented_identifier ("__g77_length_%s",
2310 ffesymbol_text (s
));
2312 tlen
= ffecom_get_invented_identifier ("__g77_%s", "length");
2313 tlen
= build_decl (PARM_DECL
, tlen
, ffecom_f2c_ftnlen_type_node
);
2314 DECL_ARTIFICIAL (tlen
) = 1;
2317 if (sz
== FFETARGET_charactersizeNONE
)
2319 assert (tlen
!= NULL_TREE
);
2320 highval
= variable_size (tlen
);
2324 highval
= build_int_2 (sz
, 0);
2325 TREE_TYPE (highval
) = ffecom_f2c_ftnlen_type_node
;
2328 type
= build_array_type (type
,
2329 build_range_type (ffecom_f2c_ftnlen_type_node
,
2330 ffecom_f2c_ftnlen_one_node
,
2337 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2339 ffecomConcatList_ catlist;
2340 ffebld expr; // expr of CHARACTER basictype.
2341 ffetargetCharacterSize max; // max chars to gather or _...NONE if no max
2342 catlist = ffecom_concat_list_gather_(catlist,expr,max);
2344 Scans expr for character subexpressions, updates and returns catlist
2347 static ffecomConcatList_
2348 ffecom_concat_list_gather_ (ffecomConcatList_ catlist
, ffebld expr
,
2349 ffetargetCharacterSize max
)
2351 ffetargetCharacterSize sz
;
2358 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
>= max
))
2359 return catlist
; /* Don't append any more items. */
2361 switch (ffebld_op (expr
))
2363 case FFEBLD_opCONTER
:
2364 case FFEBLD_opSYMTER
:
2365 case FFEBLD_opARRAYREF
:
2366 case FFEBLD_opFUNCREF
:
2367 case FFEBLD_opSUBSTR
:
2368 case FFEBLD_opCONVERT
: /* Callers should strip this off beforehand
2369 if they don't need to preserve it. */
2370 if (catlist
.count
== catlist
.max
)
2371 { /* Make a (larger) list. */
2375 newmax
= (catlist
.max
== 0) ? 8 : catlist
.max
* 2;
2376 newx
= malloc_new_ks (malloc_pool_image (), "catlist",
2377 newmax
* sizeof (newx
[0]));
2378 if (catlist
.max
!= 0)
2380 memcpy (newx
, catlist
.exprs
, catlist
.max
* sizeof (newx
[0]));
2381 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2382 catlist
.max
* sizeof (newx
[0]));
2384 catlist
.max
= newmax
;
2385 catlist
.exprs
= newx
;
2387 if ((sz
= ffebld_size_known (expr
)) != FFETARGET_charactersizeNONE
)
2388 catlist
.minlen
+= sz
;
2390 ++catlist
.minlen
; /* Not true for F90; can be 0 length. */
2391 if ((sz
= ffebld_size_max (expr
)) == FFETARGET_charactersizeNONE
)
2392 catlist
.maxlen
= sz
;
2394 catlist
.maxlen
+= sz
;
2395 if ((max
!= FFETARGET_charactersizeNONE
) && (catlist
.minlen
> max
))
2396 { /* This item overlaps (or is beyond) the end
2397 of the destination. */
2398 switch (ffebld_op (expr
))
2400 case FFEBLD_opCONTER
:
2401 case FFEBLD_opSYMTER
:
2402 case FFEBLD_opARRAYREF
:
2403 case FFEBLD_opFUNCREF
:
2404 case FFEBLD_opSUBSTR
:
2405 /* ~~Do useful truncations here. */
2409 assert ("op changed or inconsistent switches!" == NULL
);
2413 catlist
.exprs
[catlist
.count
++] = expr
;
2416 case FFEBLD_opPAREN
:
2417 expr
= ffebld_left (expr
);
2418 goto recurse
; /* :::::::::::::::::::: */
2420 case FFEBLD_opCONCATENATE
:
2421 catlist
= ffecom_concat_list_gather_ (catlist
, ffebld_left (expr
), max
);
2422 expr
= ffebld_right (expr
);
2423 goto recurse
; /* :::::::::::::::::::: */
2425 #if 0 /* Breaks passing small actual arg to larger
2426 dummy arg of sfunc */
2427 case FFEBLD_opCONVERT
:
2428 expr
= ffebld_left (expr
);
2430 ffetargetCharacterSize cmax
;
2432 cmax
= catlist
.len
+ ffebld_size_known (expr
);
2434 if ((max
== FFETARGET_charactersizeNONE
) || (max
> cmax
))
2437 goto recurse
; /* :::::::::::::::::::: */
2444 assert ("bad op in _gather_" == NULL
);
2449 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2451 ffecomConcatList_ catlist;
2452 ffecom_concat_list_kill_(catlist);
2454 Anything allocated within the list info is deallocated. */
2457 ffecom_concat_list_kill_ (ffecomConcatList_ catlist
)
2459 if (catlist
.max
!= 0)
2460 malloc_kill_ks (malloc_pool_image (), catlist
.exprs
,
2461 catlist
.max
* sizeof (catlist
.exprs
[0]));
2464 /* Make list of concatenated string exprs.
2466 Returns a flattened list of concatenated subexpressions given a
2467 tree of such expressions. */
2469 static ffecomConcatList_
2470 ffecom_concat_list_new_ (ffebld expr
, ffetargetCharacterSize max
)
2472 ffecomConcatList_ catlist
;
2474 catlist
.maxlen
= catlist
.minlen
= catlist
.max
= catlist
.count
= 0;
2475 return ffecom_concat_list_gather_ (catlist
, expr
, max
);
2478 /* Provide some kind of useful info on member of aggregate area,
2479 since current g77/gcc technology does not provide debug info
2480 on these members. */
2483 ffecom_debug_kludge_ (tree aggr
, const char *aggr_type
, ffesymbol member
,
2484 tree member_type UNUSED
, ffetargetOffset offset
)
2494 for (type_id
= member_type
;
2495 TREE_CODE (type_id
) != IDENTIFIER_NODE
;
2498 switch (TREE_CODE (type_id
))
2502 type_id
= TYPE_NAME (type_id
);
2507 type_id
= TREE_TYPE (type_id
);
2511 assert ("no IDENTIFIER_NODE for type!" == NULL
);
2512 type_id
= error_mark_node
;
2518 if (ffecom_transform_only_dummies_
2519 || !ffe_is_debug_kludge ())
2520 return; /* Can't do this yet, maybe later. */
2523 + strlen (aggr_type
)
2524 + IDENTIFIER_LENGTH (DECL_NAME (aggr
));
2526 + IDENTIFIER_LENGTH (type_id
);
2529 if (((size_t) len
) >= ARRAY_SIZE (space
))
2530 buff
= malloc_new_ks (malloc_pool_image (), "debug_kludge", len
+ 1);
2534 sprintf (&buff
[0], "At (%s) `%s' plus %ld bytes",
2536 IDENTIFIER_POINTER (DECL_NAME (aggr
)),
2539 value
= build_string (len
, buff
);
2541 = build_type_variant (build_array_type (char_type_node
,
2545 build_int_2 (strlen (buff
), 0))),
2547 decl
= build_decl (VAR_DECL
,
2548 ffecom_get_identifier_ (ffesymbol_text (member
)),
2550 TREE_CONSTANT (decl
) = 1;
2551 TREE_STATIC (decl
) = 1;
2552 DECL_INITIAL (decl
) = error_mark_node
;
2553 DECL_IN_SYSTEM_HEADER (decl
) = 1; /* Don't let -Wunused complain. */
2554 decl
= start_decl (decl
, FALSE
);
2555 finish_decl (decl
, value
, FALSE
);
2557 if (buff
!= &space
[0])
2558 malloc_kill_ks (malloc_pool_image (), buff
, len
+ 1);
2561 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2563 ffesymbol fn; // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2564 int i; // entry# for this entrypoint (used by master fn)
2565 ffecom_do_entrypoint_(s,i);
2567 Makes a public entry point that calls our private master fn (already
2571 ffecom_do_entry_ (ffesymbol fn
, int entrynum
)
2574 tree type
; /* Type of function. */
2575 tree multi_retval
; /* Var holding return value (union). */
2576 tree result
; /* Var holding result. */
2577 ffeinfoBasictype bt
;
2581 bool charfunc
; /* All entry points return same type
2583 bool cmplxfunc
; /* Use f2c way of returning COMPLEX. */
2584 bool multi
; /* Master fn has multiple return types. */
2585 bool altreturning
= FALSE
; /* This entry point has alternate returns. */
2586 int old_lineno
= lineno
;
2587 const char *old_input_filename
= input_filename
;
2589 input_filename
= ffesymbol_where_filename (fn
);
2590 lineno
= ffesymbol_where_filelinenum (fn
);
2592 ffecom_doing_entry_
= TRUE
; /* Don't bother with array dimensions. */
2594 switch (ffecom_primary_entry_kind_
)
2596 case FFEINFO_kindFUNCTION
:
2598 /* Determine actual return type for function. */
2600 gt
= FFEGLOBAL_typeFUNC
;
2601 bt
= ffesymbol_basictype (fn
);
2602 kt
= ffesymbol_kindtype (fn
);
2603 if (bt
== FFEINFO_basictypeNONE
)
2605 ffeimplic_establish_symbol (fn
);
2606 if (ffesymbol_funcresult (fn
) != NULL
)
2607 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
2608 bt
= ffesymbol_basictype (fn
);
2609 kt
= ffesymbol_kindtype (fn
);
2612 if (bt
== FFEINFO_basictypeCHARACTER
)
2613 charfunc
= TRUE
, cmplxfunc
= FALSE
;
2614 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
2615 && ffesymbol_is_f2c (fn
))
2616 charfunc
= FALSE
, cmplxfunc
= TRUE
;
2618 charfunc
= cmplxfunc
= FALSE
;
2621 type
= ffecom_tree_fun_type_void
;
2622 else if (ffesymbol_is_f2c (fn
))
2623 type
= ffecom_tree_fun_type
[bt
][kt
];
2625 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
2627 if ((type
== NULL_TREE
)
2628 || (TREE_TYPE (type
) == NULL_TREE
))
2629 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
2631 multi
= (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
2634 case FFEINFO_kindSUBROUTINE
:
2635 gt
= FFEGLOBAL_typeSUBR
;
2636 bt
= FFEINFO_basictypeNONE
;
2637 kt
= FFEINFO_kindtypeNONE
;
2638 if (ffecom_is_altreturning_
)
2639 { /* Am _I_ altreturning? */
2640 for (item
= ffesymbol_dummyargs (fn
);
2642 item
= ffebld_trail (item
))
2644 if (ffebld_op (ffebld_head (item
)) == FFEBLD_opSTAR
)
2646 altreturning
= TRUE
;
2651 type
= ffecom_tree_subr_type
;
2653 type
= ffecom_tree_fun_type_void
;
2656 type
= ffecom_tree_fun_type_void
;
2663 assert ("say what??" == NULL
);
2665 case FFEINFO_kindANY
:
2666 gt
= FFEGLOBAL_typeANY
;
2667 bt
= FFEINFO_basictypeNONE
;
2668 kt
= FFEINFO_kindtypeNONE
;
2669 type
= error_mark_node
;
2676 /* build_decl uses the current lineno and input_filename to set the decl
2677 source info. So, I've putzed with ffestd and ffeste code to update that
2678 source info to point to the appropriate statement just before calling
2679 ffecom_do_entrypoint (which calls this fn). */
2681 start_function (ffecom_get_external_identifier_ (fn
),
2683 0, /* nested/inline */
2684 1); /* TREE_PUBLIC */
2686 if (((g
= ffesymbol_global (fn
)) != NULL
)
2687 && ((ffeglobal_type (g
) == gt
)
2688 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
2690 ffeglobal_set_hook (g
, current_function_decl
);
2693 /* Reset args in master arg list so they get retransitioned. */
2695 for (item
= ffecom_master_arglist_
;
2697 item
= ffebld_trail (item
))
2702 arg
= ffebld_head (item
);
2703 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2704 continue; /* Alternate return or some such thing. */
2705 s
= ffebld_symter (arg
);
2706 ffesymbol_hook (s
).decl_tree
= NULL_TREE
;
2707 ffesymbol_hook (s
).length_tree
= NULL_TREE
;
2710 /* Build dummy arg list for this entry point. */
2712 if (charfunc
|| cmplxfunc
)
2713 { /* Prepend arg for where result goes. */
2718 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
2720 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
2722 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
2724 /* Make length arg _and_ enhance type info for CHAR arg itself. */
2727 length
= ffecom_char_enhance_arg_ (&type
, fn
);
2729 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
2731 type
= build_pointer_type (type
);
2732 result
= build_decl (PARM_DECL
, result
, type
);
2734 push_parm_decl (result
);
2735 ffecom_func_result_
= result
;
2739 push_parm_decl (length
);
2740 ffecom_func_length_
= length
;
2744 result
= DECL_RESULT (current_function_decl
);
2746 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn
), FALSE
);
2748 store_parm_decls (0);
2750 ffecom_start_compstmt ();
2751 /* Disallow temp vars at this level. */
2752 current_binding_level
->prep_state
= 2;
2754 /* Make local var to hold return type for multi-type master fn. */
2758 multi_retval
= ffecom_get_invented_identifier ("__g77_%s",
2760 multi_retval
= build_decl (VAR_DECL
, multi_retval
,
2761 ffecom_multi_type_node_
);
2762 multi_retval
= start_decl (multi_retval
, FALSE
);
2763 finish_decl (multi_retval
, NULL_TREE
, FALSE
);
2766 multi_retval
= NULL_TREE
; /* Not actually ref'd if !multi. */
2768 /* Here we emit the actual code for the entry point. */
2774 tree arglist
= NULL_TREE
;
2775 tree
*plist
= &arglist
;
2781 /* Prepare actual arg list based on master arg list. */
2783 for (list
= ffecom_master_arglist_
;
2785 list
= ffebld_trail (list
))
2787 arg
= ffebld_head (list
);
2788 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2790 s
= ffebld_symter (arg
);
2791 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
2792 || ffesymbol_hook (s
).decl_tree
== error_mark_node
)
2793 actarg
= null_pointer_node
; /* We don't have this arg. */
2795 actarg
= ffesymbol_hook (s
).decl_tree
;
2796 *plist
= build_tree_list (NULL_TREE
, actarg
);
2797 plist
= &TREE_CHAIN (*plist
);
2800 /* This code appends the length arguments for character
2801 variables/arrays. */
2803 for (list
= ffecom_master_arglist_
;
2805 list
= ffebld_trail (list
))
2807 arg
= ffebld_head (list
);
2808 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
2810 s
= ffebld_symter (arg
);
2811 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
2812 continue; /* Only looking for CHARACTER arguments. */
2813 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
2814 continue; /* Only looking for variables and arrays. */
2815 if (ffesymbol_hook (s
).length_tree
== NULL_TREE
2816 || ffesymbol_hook (s
).length_tree
== error_mark_node
)
2817 actarg
= ffecom_f2c_ftnlen_zero_node
; /* We don't have this arg. */
2819 actarg
= ffesymbol_hook (s
).length_tree
;
2820 *plist
= build_tree_list (NULL_TREE
, actarg
);
2821 plist
= &TREE_CHAIN (*plist
);
2824 /* Prepend character-value return info to actual arg list. */
2828 prepend
= build_tree_list (NULL_TREE
, ffecom_func_result_
);
2829 TREE_CHAIN (prepend
)
2830 = build_tree_list (NULL_TREE
, ffecom_func_length_
);
2831 TREE_CHAIN (TREE_CHAIN (prepend
)) = arglist
;
2835 /* Prepend multi-type return value to actual arg list. */
2840 = build_tree_list (NULL_TREE
,
2841 ffecom_1 (ADDR_EXPR
,
2842 build_pointer_type (TREE_TYPE (multi_retval
)),
2844 TREE_CHAIN (prepend
) = arglist
;
2848 /* Prepend my entry-point number to the actual arg list. */
2850 prepend
= build_tree_list (NULL_TREE
, build_int_2 (entrynum
, 0));
2851 TREE_CHAIN (prepend
) = arglist
;
2854 /* Build the call to the master function. */
2856 master_fn
= ffecom_1_fn (ffecom_previous_function_decl_
);
2857 call
= ffecom_3s (CALL_EXPR
,
2858 TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn
))),
2859 master_fn
, arglist
, NULL_TREE
);
2861 /* Decide whether the master function is a function or subroutine, and
2862 handle the return value for my entry point. */
2864 if (charfunc
|| ((ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
2867 expand_expr_stmt (call
);
2868 expand_null_return ();
2870 else if (multi
&& cmplxfunc
)
2872 expand_expr_stmt (call
);
2874 = ffecom_1 (INDIRECT_REF
,
2875 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2877 result
= ffecom_modify (NULL_TREE
, result
,
2878 ffecom_2 (COMPONENT_REF
, TREE_TYPE (result
),
2880 ffecom_multi_fields_
[bt
][kt
]));
2881 expand_expr_stmt (result
);
2882 expand_null_return ();
2886 expand_expr_stmt (call
);
2888 = ffecom_modify (NULL_TREE
, result
,
2889 convert (TREE_TYPE (result
),
2890 ffecom_2 (COMPONENT_REF
,
2891 ffecom_tree_type
[bt
][kt
],
2893 ffecom_multi_fields_
[bt
][kt
])));
2894 expand_return (result
);
2899 = ffecom_1 (INDIRECT_REF
,
2900 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result
))),
2902 result
= ffecom_modify (NULL_TREE
, result
, call
);
2903 expand_expr_stmt (result
);
2904 expand_null_return ();
2908 result
= ffecom_modify (NULL_TREE
,
2910 convert (TREE_TYPE (result
),
2912 expand_return (result
);
2916 ffecom_end_compstmt ();
2918 finish_function (0);
2920 lineno
= old_lineno
;
2921 input_filename
= old_input_filename
;
2923 ffecom_doing_entry_
= FALSE
;
2926 /* Transform expr into gcc tree with possible destination
2928 Recursive descent on expr while making corresponding tree nodes and
2929 attaching type info and such. If destination supplied and compatible
2930 with temporary that would be made in certain cases, temporary isn't
2931 made, destination used instead, and dest_used flag set TRUE. */
2934 ffecom_expr_ (ffebld expr
, tree dest_tree
, ffebld dest
,
2935 bool *dest_used
, bool assignp
, bool widenp
)
2940 ffeinfoBasictype bt
;
2943 tree dt
; /* decl_tree for an ffesymbol. */
2944 tree tree_type
, tree_type_x
;
2947 enum tree_code code
;
2949 assert (expr
!= NULL
);
2951 if (dest_used
!= NULL
)
2954 bt
= ffeinfo_basictype (ffebld_info (expr
));
2955 kt
= ffeinfo_kindtype (ffebld_info (expr
));
2956 tree_type
= ffecom_tree_type
[bt
][kt
];
2958 /* Widen integral arithmetic as desired while preserving signedness. */
2959 tree_type_x
= NULL_TREE
;
2960 if (widenp
&& tree_type
2961 && GET_MODE_CLASS (TYPE_MODE (tree_type
)) == MODE_INT
2962 && TYPE_PRECISION (tree_type
) < TYPE_PRECISION (sizetype
))
2963 tree_type_x
= (TREE_UNSIGNED (tree_type
) ? usizetype
: ssizetype
);
2965 switch (ffebld_op (expr
))
2967 case FFEBLD_opACCTER
:
2970 ffebit bits
= ffebld_accter_bits (expr
);
2971 ffetargetOffset source_offset
= 0;
2972 ffetargetOffset dest_offset
= ffebld_accter_pad (expr
);
2975 assert (dest_offset
== 0
2976 || (bt
== FFEINFO_basictypeCHARACTER
2977 && kt
== FFEINFO_kindtypeCHARACTER1
));
2982 ffebldConstantUnion cu
;
2985 ffebldConstantArray ca
= ffebld_accter (expr
);
2987 ffebit_test (bits
, source_offset
, &value
, &length
);
2993 for (i
= 0; i
< length
; ++i
)
2995 cu
= ffebld_constantarray_get (ca
, bt
, kt
,
2998 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
3001 && dest_offset
!= 0)
3002 purpose
= build_int_2 (dest_offset
, 0);
3004 purpose
= NULL_TREE
;
3006 if (list
== NULL_TREE
)
3007 list
= item
= build_tree_list (purpose
, t
);
3010 TREE_CHAIN (item
) = build_tree_list (purpose
, t
);
3011 item
= TREE_CHAIN (item
);
3015 source_offset
+= length
;
3016 dest_offset
+= length
;
3020 item
= build_int_2 ((ffebld_accter_size (expr
)
3021 + ffebld_accter_pad (expr
)) - 1, 0);
3022 ffebit_kill (ffebld_accter_bits (expr
));
3023 TREE_TYPE (item
) = ffecom_integer_type_node
;
3027 build_range_type (ffecom_integer_type_node
,
3028 ffecom_integer_zero_node
,
3030 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
3031 TREE_CONSTANT (list
) = 1;
3032 TREE_STATIC (list
) = 1;
3035 case FFEBLD_opARRTER
:
3040 if (ffebld_arrter_pad (expr
) == 0)
3044 assert (bt
== FFEINFO_basictypeCHARACTER
3045 && kt
== FFEINFO_kindtypeCHARACTER1
);
3047 /* Becomes PURPOSE first time through loop. */
3048 item
= build_int_2 (ffebld_arrter_pad (expr
), 0);
3051 for (i
= 0; i
< ffebld_arrter_size (expr
); ++i
)
3053 ffebldConstantUnion cu
3054 = ffebld_constantarray_get (ffebld_arrter (expr
), bt
, kt
, i
);
3056 t
= ffecom_constantunion (&cu
, bt
, kt
, tree_type
);
3058 if (list
== NULL_TREE
)
3059 /* Assume item is PURPOSE first time through loop. */
3060 list
= item
= build_tree_list (item
, t
);
3063 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
3064 item
= TREE_CHAIN (item
);
3069 item
= build_int_2 ((ffebld_arrter_size (expr
)
3070 + ffebld_arrter_pad (expr
)) - 1, 0);
3071 TREE_TYPE (item
) = ffecom_integer_type_node
;
3075 build_range_type (ffecom_integer_type_node
,
3076 ffecom_integer_zero_node
,
3078 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
3079 TREE_CONSTANT (list
) = 1;
3080 TREE_STATIC (list
) = 1;
3083 case FFEBLD_opCONTER
:
3084 assert (ffebld_conter_pad (expr
) == 0);
3086 = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr
)),
3090 case FFEBLD_opSYMTER
:
3091 if ((ffebld_symter_generic (expr
) != FFEINTRIN_genNONE
)
3092 || (ffebld_symter_specific (expr
) != FFEINTRIN_specNONE
))
3093 return ffecom_ptr_to_expr (expr
); /* Same as %REF(intrinsic). */
3094 s
= ffebld_symter (expr
);
3095 t
= ffesymbol_hook (s
).decl_tree
;
3098 { /* ASSIGN'ed-label expr. */
3099 if (ffe_is_ugly_assign ())
3101 /* User explicitly wants ASSIGN'ed variables to be at the same
3102 memory address as the variables when used in non-ASSIGN
3103 contexts. That can make old, arcane, non-standard code
3104 work, but don't try to do it when a pointer wouldn't fit
3105 in the normal variable (take other approach, and warn,
3110 s
= ffecom_sym_transform_ (s
);
3111 t
= ffesymbol_hook (s
).decl_tree
;
3112 assert (t
!= NULL_TREE
);
3115 if (t
== error_mark_node
)
3118 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t
)))
3119 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
3121 if (ffesymbol_hook (s
).addr
)
3122 t
= ffecom_1 (INDIRECT_REF
,
3123 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
3127 if (ffesymbol_hook (s
).assign_tree
== NULL_TREE
)
3129 /* xgettext:no-c-format */
3130 ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3131 FFEBAD_severityWARNING
);
3132 ffebad_string (ffesymbol_text (s
));
3133 ffebad_here (0, ffesymbol_where_line (s
),
3134 ffesymbol_where_column (s
));
3139 /* Don't use the normal variable's tree for ASSIGN, though mark
3140 it as in the system header (housekeeping). Use an explicit,
3141 specially created sibling that is known to be wide enough
3142 to hold pointers to labels. */
3145 && TREE_CODE (t
) == VAR_DECL
)
3146 DECL_IN_SYSTEM_HEADER (t
) = 1; /* Don't let -Wunused complain. */
3148 t
= ffesymbol_hook (s
).assign_tree
;
3151 s
= ffecom_sym_transform_assign_ (s
);
3152 t
= ffesymbol_hook (s
).assign_tree
;
3153 assert (t
!= NULL_TREE
);
3160 s
= ffecom_sym_transform_ (s
);
3161 t
= ffesymbol_hook (s
).decl_tree
;
3162 assert (t
!= NULL_TREE
);
3164 if (ffesymbol_hook (s
).addr
)
3165 t
= ffecom_1 (INDIRECT_REF
,
3166 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t
))), t
);
3170 case FFEBLD_opARRAYREF
:
3171 return ffecom_arrayref_ (NULL_TREE
, expr
, 0);
3173 case FFEBLD_opUPLUS
:
3174 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3175 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3177 case FFEBLD_opPAREN
:
3178 /* ~~~Make sure Fortran rules respected here */
3179 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3180 return ffecom_1 (NOP_EXPR
, tree_type
, left
);
3182 case FFEBLD_opUMINUS
:
3183 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3186 tree_type
= tree_type_x
;
3187 left
= convert (tree_type
, left
);
3189 return ffecom_1 (NEGATE_EXPR
, tree_type
, left
);
3192 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3193 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3196 tree_type
= tree_type_x
;
3197 left
= convert (tree_type
, left
);
3198 right
= convert (tree_type
, right
);
3200 return ffecom_2 (PLUS_EXPR
, tree_type
, left
, right
);
3202 case FFEBLD_opSUBTRACT
:
3203 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3204 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3207 tree_type
= tree_type_x
;
3208 left
= convert (tree_type
, left
);
3209 right
= convert (tree_type
, right
);
3211 return ffecom_2 (MINUS_EXPR
, tree_type
, left
, right
);
3213 case FFEBLD_opMULTIPLY
:
3214 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3215 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3218 tree_type
= tree_type_x
;
3219 left
= convert (tree_type
, left
);
3220 right
= convert (tree_type
, right
);
3222 return ffecom_2 (MULT_EXPR
, tree_type
, left
, right
);
3224 case FFEBLD_opDIVIDE
:
3225 left
= ffecom_expr_ (ffebld_left (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3226 right
= ffecom_expr_ (ffebld_right (expr
), NULL
, NULL
, NULL
, FALSE
, widenp
);
3229 tree_type
= tree_type_x
;
3230 left
= convert (tree_type
, left
);
3231 right
= convert (tree_type
, right
);
3233 return ffecom_tree_divide_ (tree_type
, left
, right
,
3234 dest_tree
, dest
, dest_used
,
3235 ffebld_nonter_hook (expr
));
3237 case FFEBLD_opPOWER
:
3239 ffebld left
= ffebld_left (expr
);
3240 ffebld right
= ffebld_right (expr
);
3242 ffeinfoKindtype rtkt
;
3243 ffeinfoKindtype ltkt
;
3246 switch (ffeinfo_basictype (ffebld_info (right
)))
3249 case FFEINFO_basictypeINTEGER
:
3252 item
= ffecom_expr_power_integer_ (expr
);
3253 if (item
!= NULL_TREE
)
3257 rtkt
= FFEINFO_kindtypeINTEGER1
;
3258 switch (ffeinfo_basictype (ffebld_info (left
)))
3260 case FFEINFO_basictypeINTEGER
:
3261 if ((ffeinfo_kindtype (ffebld_info (left
))
3262 == FFEINFO_kindtypeINTEGER4
)
3263 || (ffeinfo_kindtype (ffebld_info (right
))
3264 == FFEINFO_kindtypeINTEGER4
))
3266 code
= FFECOM_gfrtPOW_QQ
;
3267 ltkt
= FFEINFO_kindtypeINTEGER4
;
3268 rtkt
= FFEINFO_kindtypeINTEGER4
;
3272 code
= FFECOM_gfrtPOW_II
;
3273 ltkt
= FFEINFO_kindtypeINTEGER1
;
3277 case FFEINFO_basictypeREAL
:
3278 if (ffeinfo_kindtype (ffebld_info (left
))
3279 == FFEINFO_kindtypeREAL1
)
3281 code
= FFECOM_gfrtPOW_RI
;
3282 ltkt
= FFEINFO_kindtypeREAL1
;
3286 code
= FFECOM_gfrtPOW_DI
;
3287 ltkt
= FFEINFO_kindtypeREAL2
;
3291 case FFEINFO_basictypeCOMPLEX
:
3292 if (ffeinfo_kindtype (ffebld_info (left
))
3293 == FFEINFO_kindtypeREAL1
)
3295 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3296 ltkt
= FFEINFO_kindtypeREAL1
;
3300 code
= FFECOM_gfrtPOW_ZI
; /* Overlapping result okay. */
3301 ltkt
= FFEINFO_kindtypeREAL2
;
3306 assert ("bad pow_*i" == NULL
);
3307 code
= FFECOM_gfrtPOW_CI
; /* Overlapping result okay. */
3308 ltkt
= FFEINFO_kindtypeREAL1
;
3311 if (ffeinfo_kindtype (ffebld_info (left
)) != ltkt
)
3312 left
= ffeexpr_convert (left
, NULL
, NULL
,
3313 ffeinfo_basictype (ffebld_info (left
)),
3315 FFETARGET_charactersizeNONE
,
3316 FFEEXPR_contextLET
);
3317 if (ffeinfo_kindtype (ffebld_info (right
)) != rtkt
)
3318 right
= ffeexpr_convert (right
, NULL
, NULL
,
3319 FFEINFO_basictypeINTEGER
,
3321 FFETARGET_charactersizeNONE
,
3322 FFEEXPR_contextLET
);
3325 case FFEINFO_basictypeREAL
:
3326 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3327 left
= ffeexpr_convert (left
, NULL
, NULL
, FFEINFO_basictypeREAL
,
3328 FFEINFO_kindtypeREALDOUBLE
, 0,
3329 FFETARGET_charactersizeNONE
,
3330 FFEEXPR_contextLET
);
3331 if (ffeinfo_kindtype (ffebld_info (right
))
3332 == FFEINFO_kindtypeREAL1
)
3333 right
= ffeexpr_convert (right
, NULL
, NULL
,
3334 FFEINFO_basictypeREAL
,
3335 FFEINFO_kindtypeREALDOUBLE
, 0,
3336 FFETARGET_charactersizeNONE
,
3337 FFEEXPR_contextLET
);
3338 /* We used to call FFECOM_gfrtPOW_DD here,
3339 which passes arguments by reference. */
3340 code
= FFECOM_gfrtL_POW
;
3341 /* Pass arguments by value. */
3345 case FFEINFO_basictypeCOMPLEX
:
3346 if (ffeinfo_kindtype (ffebld_info (left
)) == FFEINFO_kindtypeREAL1
)
3347 left
= ffeexpr_convert (left
, NULL
, NULL
,
3348 FFEINFO_basictypeCOMPLEX
,
3349 FFEINFO_kindtypeREALDOUBLE
, 0,
3350 FFETARGET_charactersizeNONE
,
3351 FFEEXPR_contextLET
);
3352 if (ffeinfo_kindtype (ffebld_info (right
))
3353 == FFEINFO_kindtypeREAL1
)
3354 right
= ffeexpr_convert (right
, NULL
, NULL
,
3355 FFEINFO_basictypeCOMPLEX
,
3356 FFEINFO_kindtypeREALDOUBLE
, 0,
3357 FFETARGET_charactersizeNONE
,
3358 FFEEXPR_contextLET
);
3359 code
= FFECOM_gfrtPOW_ZZ
; /* Overlapping result okay. */
3360 ref
= TRUE
; /* Pass arguments by reference. */
3364 assert ("bad pow_x*" == NULL
);
3365 code
= FFECOM_gfrtPOW_II
;
3368 return ffecom_call_binop_ (ffecom_gfrt_tree_ (code
),
3369 ffecom_gfrt_kindtype (code
),
3370 (ffe_is_f2c_library ()
3371 && ffecom_gfrt_complex_
[code
]),
3372 tree_type
, left
, right
,
3373 dest_tree
, dest
, dest_used
,
3374 NULL_TREE
, FALSE
, ref
,
3375 ffebld_nonter_hook (expr
));
3381 case FFEINFO_basictypeLOGICAL
:
3382 item
= ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr
)));
3383 return convert (tree_type
, item
);
3385 case FFEINFO_basictypeINTEGER
:
3386 return ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3387 ffecom_expr (ffebld_left (expr
)));
3390 assert ("NOT bad basictype" == NULL
);
3392 case FFEINFO_basictypeANY
:
3393 return error_mark_node
;
3397 case FFEBLD_opFUNCREF
:
3398 assert (ffeinfo_basictype (ffebld_info (expr
))
3399 != FFEINFO_basictypeCHARACTER
);
3401 case FFEBLD_opSUBRREF
:
3402 if (ffeinfo_where (ffebld_info (ffebld_left (expr
)))
3403 == FFEINFO_whereINTRINSIC
)
3404 { /* Invocation of an intrinsic. */
3405 item
= ffecom_expr_intrinsic_ (expr
, dest_tree
, dest
,
3409 s
= ffebld_symter (ffebld_left (expr
));
3410 dt
= ffesymbol_hook (s
).decl_tree
;
3411 if (dt
== NULL_TREE
)
3413 s
= ffecom_sym_transform_ (s
);
3414 dt
= ffesymbol_hook (s
).decl_tree
;
3416 if (dt
== error_mark_node
)
3419 if (ffesymbol_hook (s
).addr
)
3422 item
= ffecom_1_fn (dt
);
3424 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
3425 args
= ffecom_list_expr (ffebld_right (expr
));
3427 args
= ffecom_list_ptr_to_expr (ffebld_right (expr
));
3429 if (args
== error_mark_node
)
3430 return error_mark_node
;
3432 item
= ffecom_call_ (item
, kt
,
3433 ffesymbol_is_f2c (s
)
3434 && (bt
== FFEINFO_basictypeCOMPLEX
)
3435 && (ffesymbol_where (s
)
3436 != FFEINFO_whereCONSTANT
),
3439 dest_tree
, dest
, dest_used
,
3440 error_mark_node
, FALSE
,
3441 ffebld_nonter_hook (expr
));
3442 TREE_SIDE_EFFECTS (item
) = 1;
3448 case FFEINFO_basictypeLOGICAL
:
3450 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3451 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3452 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3453 return convert (tree_type
, item
);
3455 case FFEINFO_basictypeINTEGER
:
3456 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
3457 ffecom_expr (ffebld_left (expr
)),
3458 ffecom_expr (ffebld_right (expr
)));
3461 assert ("AND bad basictype" == NULL
);
3463 case FFEINFO_basictypeANY
:
3464 return error_mark_node
;
3471 case FFEINFO_basictypeLOGICAL
:
3473 = ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
3474 ffecom_truth_value (ffecom_expr (ffebld_left (expr
))),
3475 ffecom_truth_value (ffecom_expr (ffebld_right (expr
))));
3476 return convert (tree_type
, item
);
3478 case FFEINFO_basictypeINTEGER
:
3479 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
3480 ffecom_expr (ffebld_left (expr
)),
3481 ffecom_expr (ffebld_right (expr
)));
3484 assert ("OR bad basictype" == NULL
);
3486 case FFEINFO_basictypeANY
:
3487 return error_mark_node
;
3495 case FFEINFO_basictypeLOGICAL
:
3497 = ffecom_2 (NE_EXPR
, integer_type_node
,
3498 ffecom_expr (ffebld_left (expr
)),
3499 ffecom_expr (ffebld_right (expr
)));
3500 return convert (tree_type
, ffecom_truth_value (item
));
3502 case FFEINFO_basictypeINTEGER
:
3503 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3504 ffecom_expr (ffebld_left (expr
)),
3505 ffecom_expr (ffebld_right (expr
)));
3508 assert ("XOR/NEQV bad basictype" == NULL
);
3510 case FFEINFO_basictypeANY
:
3511 return error_mark_node
;
3518 case FFEINFO_basictypeLOGICAL
:
3520 = ffecom_2 (EQ_EXPR
, integer_type_node
,
3521 ffecom_expr (ffebld_left (expr
)),
3522 ffecom_expr (ffebld_right (expr
)));
3523 return convert (tree_type
, ffecom_truth_value (item
));
3525 case FFEINFO_basictypeINTEGER
:
3527 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
3528 ffecom_2 (BIT_XOR_EXPR
, tree_type
,
3529 ffecom_expr (ffebld_left (expr
)),
3530 ffecom_expr (ffebld_right (expr
))));
3533 assert ("EQV bad basictype" == NULL
);
3535 case FFEINFO_basictypeANY
:
3536 return error_mark_node
;
3540 case FFEBLD_opCONVERT
:
3541 if (ffebld_op (ffebld_left (expr
)) == FFEBLD_opANY
)
3542 return error_mark_node
;
3546 case FFEINFO_basictypeLOGICAL
:
3547 case FFEINFO_basictypeINTEGER
:
3548 case FFEINFO_basictypeREAL
:
3549 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3551 case FFEINFO_basictypeCOMPLEX
:
3552 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3554 case FFEINFO_basictypeINTEGER
:
3555 case FFEINFO_basictypeLOGICAL
:
3556 case FFEINFO_basictypeREAL
:
3557 item
= ffecom_expr (ffebld_left (expr
));
3558 if (item
== error_mark_node
)
3559 return error_mark_node
;
3560 /* convert() takes care of converting to the subtype first,
3561 at least in gcc-2.7.2. */
3562 item
= convert (tree_type
, item
);
3565 case FFEINFO_basictypeCOMPLEX
:
3566 return convert (tree_type
, ffecom_expr (ffebld_left (expr
)));
3569 assert ("CONVERT COMPLEX bad basictype" == NULL
);
3571 case FFEINFO_basictypeANY
:
3572 return error_mark_node
;
3577 assert ("CONVERT bad basictype" == NULL
);
3579 case FFEINFO_basictypeANY
:
3580 return error_mark_node
;
3586 goto relational
; /* :::::::::::::::::::: */
3590 goto relational
; /* :::::::::::::::::::: */
3594 goto relational
; /* :::::::::::::::::::: */
3598 goto relational
; /* :::::::::::::::::::: */
3602 goto relational
; /* :::::::::::::::::::: */
3607 relational
: /* :::::::::::::::::::: */
3608 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
3610 case FFEINFO_basictypeLOGICAL
:
3611 case FFEINFO_basictypeINTEGER
:
3612 case FFEINFO_basictypeREAL
:
3613 item
= ffecom_2 (code
, integer_type_node
,
3614 ffecom_expr (ffebld_left (expr
)),
3615 ffecom_expr (ffebld_right (expr
)));
3616 return convert (tree_type
, item
);
3618 case FFEINFO_basictypeCOMPLEX
:
3619 assert (code
== EQ_EXPR
|| code
== NE_EXPR
);
3622 tree arg1
= ffecom_expr (ffebld_left (expr
));
3623 tree arg2
= ffecom_expr (ffebld_right (expr
));
3625 if (arg1
== error_mark_node
|| arg2
== error_mark_node
)
3626 return error_mark_node
;
3628 arg1
= ffecom_save_tree (arg1
);
3629 arg2
= ffecom_save_tree (arg2
);
3631 if (TREE_CODE (TREE_TYPE (arg1
)) == COMPLEX_TYPE
)
3633 real_type
= TREE_TYPE (TREE_TYPE (arg1
));
3634 assert (real_type
== TREE_TYPE (TREE_TYPE (arg2
)));
3638 real_type
= TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1
)));
3639 assert (real_type
== TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2
))));
3643 = ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
3644 ffecom_2 (EQ_EXPR
, integer_type_node
,
3645 ffecom_1 (REALPART_EXPR
, real_type
, arg1
),
3646 ffecom_1 (REALPART_EXPR
, real_type
, arg2
)),
3647 ffecom_2 (EQ_EXPR
, integer_type_node
,
3648 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1
),
3649 ffecom_1 (IMAGPART_EXPR
, real_type
,
3651 if (code
== EQ_EXPR
)
3652 item
= ffecom_truth_value (item
);
3654 item
= ffecom_truth_value_invert (item
);
3655 return convert (tree_type
, item
);
3658 case FFEINFO_basictypeCHARACTER
:
3660 ffebld left
= ffebld_left (expr
);
3661 ffebld right
= ffebld_right (expr
);
3667 /* f2c run-time functions do the implicit blank-padding for us,
3668 so we don't usually have to implement blank-padding ourselves.
3669 (The exception is when we pass an argument to a separately
3670 compiled statement function -- if we know the arg is not the
3671 same length as the dummy, we must truncate or extend it. If
3672 we "inline" statement functions, that necessity goes away as
3675 Strip off the CONVERT operators that blank-pad. (Truncation by
3676 CONVERT shouldn't happen here, but it can happen in
3679 while (ffebld_op (left
) == FFEBLD_opCONVERT
)
3680 left
= ffebld_left (left
);
3681 while (ffebld_op (right
) == FFEBLD_opCONVERT
)
3682 right
= ffebld_left (right
);
3684 left_tree
= ffecom_arg_ptr_to_expr (left
, &left_length
);
3685 right_tree
= ffecom_arg_ptr_to_expr (right
, &right_length
);
3687 if (left_tree
== error_mark_node
|| left_length
== error_mark_node
3688 || right_tree
== error_mark_node
3689 || right_length
== error_mark_node
)
3690 return error_mark_node
;
3692 if ((ffebld_size_known (left
) == 1)
3693 && (ffebld_size_known (right
) == 1))
3696 = ffecom_1 (INDIRECT_REF
,
3697 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3700 = ffecom_1 (INDIRECT_REF
,
3701 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3705 = ffecom_2 (code
, integer_type_node
,
3706 ffecom_2 (ARRAY_REF
,
3707 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree
))),
3710 ffecom_2 (ARRAY_REF
,
3711 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree
))),
3717 item
= build_tree_list (NULL_TREE
, left_tree
);
3718 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, right_tree
);
3719 TREE_CHAIN (TREE_CHAIN (item
)) = build_tree_list (NULL_TREE
,
3721 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
3722 = build_tree_list (NULL_TREE
, right_length
);
3723 item
= ffecom_call_gfrt (FFECOM_gfrtCMP
, item
, NULL_TREE
);
3724 item
= ffecom_2 (code
, integer_type_node
,
3726 convert (TREE_TYPE (item
),
3727 integer_zero_node
));
3729 item
= convert (tree_type
, item
);
3735 assert ("relational bad basictype" == NULL
);
3737 case FFEINFO_basictypeANY
:
3738 return error_mark_node
;
3742 case FFEBLD_opPERCENT_LOC
:
3743 item
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &list
);
3744 return convert (tree_type
, item
);
3746 case FFEBLD_opPERCENT_VAL
:
3747 item
= ffecom_arg_expr (ffebld_left (expr
), &list
);
3748 return convert (tree_type
, item
);
3752 case FFEBLD_opBOUNDS
:
3753 case FFEBLD_opREPEAT
:
3754 case FFEBLD_opLABTER
:
3755 case FFEBLD_opLABTOK
:
3756 case FFEBLD_opIMPDO
:
3757 case FFEBLD_opCONCATENATE
:
3758 case FFEBLD_opSUBSTR
:
3760 assert ("bad op" == NULL
);
3763 return error_mark_node
;
3767 assert ("didn't think anything got here anymore!!" == NULL
);
3769 switch (ffebld_arity (expr
))
3772 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3773 TREE_OPERAND (item
, 1) = ffecom_expr (ffebld_right (expr
));
3774 if (TREE_OPERAND (item
, 0) == error_mark_node
3775 || TREE_OPERAND (item
, 1) == error_mark_node
)
3776 return error_mark_node
;
3780 TREE_OPERAND (item
, 0) = ffecom_expr (ffebld_left (expr
));
3781 if (TREE_OPERAND (item
, 0) == error_mark_node
)
3782 return error_mark_node
;
3793 /* Returns the tree that does the intrinsic invocation.
3795 Note: this function applies only to intrinsics returning
3796 CHARACTER*1 or non-CHARACTER results, and to intrinsic
3800 ffecom_expr_intrinsic_ (ffebld expr
, tree dest_tree
,
3801 ffebld dest
, bool *dest_used
)
3804 tree saved_expr1
; /* For those who need it. */
3805 tree saved_expr2
; /* For those who need it. */
3806 ffeinfoBasictype bt
;
3810 tree real_type
; /* REAL type corresponding to COMPLEX. */
3812 ffebld list
= ffebld_right (expr
); /* List of (some) args. */
3813 ffebld arg1
; /* For handy reference. */
3816 ffeintrinImp codegen_imp
;
3819 assert (ffebld_op (ffebld_left (expr
)) == FFEBLD_opSYMTER
);
3821 if (dest_used
!= NULL
)
3824 bt
= ffeinfo_basictype (ffebld_info (expr
));
3825 kt
= ffeinfo_kindtype (ffebld_info (expr
));
3826 tree_type
= ffecom_tree_type
[bt
][kt
];
3830 arg1
= ffebld_head (list
);
3831 if (arg1
!= NULL
&& ffebld_op (arg1
) == FFEBLD_opANY
)
3832 return error_mark_node
;
3833 if ((list
= ffebld_trail (list
)) != NULL
)
3835 arg2
= ffebld_head (list
);
3836 if (arg2
!= NULL
&& ffebld_op (arg2
) == FFEBLD_opANY
)
3837 return error_mark_node
;
3838 if ((list
= ffebld_trail (list
)) != NULL
)
3840 arg3
= ffebld_head (list
);
3841 if (arg3
!= NULL
&& ffebld_op (arg3
) == FFEBLD_opANY
)
3842 return error_mark_node
;
3851 arg1
= arg2
= arg3
= NULL
;
3853 /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3854 args. This is used by the MAX/MIN expansions. */
3857 arg1_type
= ffecom_tree_type
3858 [ffeinfo_basictype (ffebld_info (arg1
))]
3859 [ffeinfo_kindtype (ffebld_info (arg1
))];
3861 arg1_type
= NULL_TREE
; /* Really not needed, but might catch bugs
3864 /* There are several ways for each of the cases in the following switch
3865 statements to exit (from simplest to use to most complicated):
3867 break; (when expr_tree == NULL)
3869 A standard call is made to the specific intrinsic just as if it had been
3870 passed in as a dummy procedure and called as any old procedure. This
3871 method can produce slower code but in some cases it's the easiest way for
3872 now. However, if a (presumably faster) direct call is available,
3873 that is used, so this is the easiest way in many more cases now.
3875 gfrt = FFECOM_gfrtWHATEVER;
3878 gfrt contains the gfrt index of a library function to call, passing the
3879 argument(s) by value rather than by reference. Used when a more
3880 careful choice of library function is needed than that provided
3881 by the vanilla `break;'.
3885 The expr_tree has been completely set up and is ready to be returned
3886 as is. No further actions are taken. Use this when the tree is not
3887 in the simple form for one of the arity_n labels. */
3889 /* For info on how the switch statement cases were written, see the files
3890 enclosed in comments below the switch statement. */
3892 codegen_imp
= ffebld_symter_implementation (ffebld_left (expr
));
3893 gfrt
= ffeintrin_gfrt_direct (codegen_imp
);
3894 if (gfrt
== FFECOM_gfrt
)
3895 gfrt
= ffeintrin_gfrt_indirect (codegen_imp
);
3897 switch (codegen_imp
)
3899 case FFEINTRIN_impABS
:
3900 case FFEINTRIN_impCABS
:
3901 case FFEINTRIN_impCDABS
:
3902 case FFEINTRIN_impDABS
:
3903 case FFEINTRIN_impIABS
:
3904 if (ffeinfo_basictype (ffebld_info (arg1
))
3905 == FFEINFO_basictypeCOMPLEX
)
3907 if (kt
== FFEINFO_kindtypeREAL1
)
3908 gfrt
= FFECOM_gfrtCABS
;
3909 else if (kt
== FFEINFO_kindtypeREAL2
)
3910 gfrt
= FFECOM_gfrtCDABS
;
3913 return ffecom_1 (ABS_EXPR
, tree_type
,
3914 convert (tree_type
, ffecom_expr (arg1
)));
3916 case FFEINTRIN_impACOS
:
3917 case FFEINTRIN_impDACOS
:
3920 case FFEINTRIN_impAIMAG
:
3921 case FFEINTRIN_impDIMAG
:
3922 case FFEINTRIN_impIMAGPART
:
3923 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
3924 arg1_type
= TREE_TYPE (arg1_type
);
3926 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
3930 ffecom_1 (IMAGPART_EXPR
, arg1_type
,
3931 ffecom_expr (arg1
)));
3933 case FFEINTRIN_impAINT
:
3934 case FFEINTRIN_impDINT
:
3936 /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg. */
3937 return ffecom_1 (FIX_TRUNC_EXPR
, tree_type
, ffecom_expr (arg1
));
3938 #else /* in the meantime, must use floor to avoid range problems with ints */
3939 /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
3940 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3943 ffecom_3 (COND_EXPR
, double_type_node
,
3945 (ffecom_2 (GE_EXPR
, integer_type_node
,
3948 ffecom_float_zero_
))),
3949 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3950 build_tree_list (NULL_TREE
,
3951 convert (double_type_node
,
3954 ffecom_1 (NEGATE_EXPR
, double_type_node
,
3955 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
3956 build_tree_list (NULL_TREE
,
3957 convert (double_type_node
,
3958 ffecom_1 (NEGATE_EXPR
,
3966 case FFEINTRIN_impANINT
:
3967 case FFEINTRIN_impDNINT
:
3968 #if 0 /* This way of doing it won't handle real
3969 numbers of large magnitudes. */
3970 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3971 expr_tree
= convert (tree_type
,
3972 convert (integer_type_node
,
3973 ffecom_3 (COND_EXPR
, tree_type
,
3978 ffecom_float_zero_
)),
3979 ffecom_2 (PLUS_EXPR
,
3982 ffecom_float_half_
),
3983 ffecom_2 (MINUS_EXPR
,
3986 ffecom_float_half_
))));
3988 #else /* So we instead call floor. */
3989 /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
3990 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
3993 ffecom_3 (COND_EXPR
, double_type_node
,
3995 (ffecom_2 (GE_EXPR
, integer_type_node
,
3998 ffecom_float_zero_
))),
3999 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
4000 build_tree_list (NULL_TREE
,
4001 convert (double_type_node
,
4002 ffecom_2 (PLUS_EXPR
,
4006 ffecom_float_half_
)))),
4008 ffecom_1 (NEGATE_EXPR
, double_type_node
,
4009 ffecom_call_gfrt (FFECOM_gfrtL_FLOOR
,
4010 build_tree_list (NULL_TREE
,
4011 convert (double_type_node
,
4012 ffecom_2 (MINUS_EXPR
,
4015 ffecom_float_half_
),
4022 case FFEINTRIN_impASIN
:
4023 case FFEINTRIN_impDASIN
:
4024 case FFEINTRIN_impATAN
:
4025 case FFEINTRIN_impDATAN
:
4026 case FFEINTRIN_impATAN2
:
4027 case FFEINTRIN_impDATAN2
:
4030 case FFEINTRIN_impCHAR
:
4031 case FFEINTRIN_impACHAR
:
4032 tempvar
= ffebld_nonter_hook (expr
);
4035 tree tmv
= TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar
)));
4037 expr_tree
= ffecom_modify (tmv
,
4038 ffecom_2 (ARRAY_REF
, tmv
, tempvar
,
4040 convert (tmv
, ffecom_expr (arg1
)));
4042 expr_tree
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (tempvar
),
4045 expr_tree
= ffecom_1 (ADDR_EXPR
,
4046 build_pointer_type (TREE_TYPE (expr_tree
)),
4050 case FFEINTRIN_impCMPLX
:
4051 case FFEINTRIN_impDCMPLX
:
4054 convert (tree_type
, ffecom_expr (arg1
));
4056 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
4058 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4059 convert (real_type
, ffecom_expr (arg1
)),
4061 ffecom_expr (arg2
)));
4063 case FFEINTRIN_impCOMPLEX
:
4065 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4067 ffecom_expr (arg2
));
4069 case FFEINTRIN_impCONJG
:
4070 case FFEINTRIN_impDCONJG
:
4074 real_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
4075 arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4077 ffecom_2 (COMPLEX_EXPR
, tree_type
,
4078 ffecom_1 (REALPART_EXPR
, real_type
, arg1_tree
),
4079 ffecom_1 (NEGATE_EXPR
, real_type
,
4080 ffecom_1 (IMAGPART_EXPR
, real_type
, arg1_tree
)));
4083 case FFEINTRIN_impCOS
:
4084 case FFEINTRIN_impCCOS
:
4085 case FFEINTRIN_impCDCOS
:
4086 case FFEINTRIN_impDCOS
:
4087 if (bt
== FFEINFO_basictypeCOMPLEX
)
4089 if (kt
== FFEINFO_kindtypeREAL1
)
4090 gfrt
= FFECOM_gfrtCCOS
; /* Overlapping result okay. */
4091 else if (kt
== FFEINFO_kindtypeREAL2
)
4092 gfrt
= FFECOM_gfrtCDCOS
; /* Overlapping result okay. */
4096 case FFEINTRIN_impCOSH
:
4097 case FFEINTRIN_impDCOSH
:
4100 case FFEINTRIN_impDBLE
:
4101 case FFEINTRIN_impDFLOAT
:
4102 case FFEINTRIN_impDREAL
:
4103 case FFEINTRIN_impFLOAT
:
4104 case FFEINTRIN_impIDINT
:
4105 case FFEINTRIN_impIFIX
:
4106 case FFEINTRIN_impINT2
:
4107 case FFEINTRIN_impINT8
:
4108 case FFEINTRIN_impINT
:
4109 case FFEINTRIN_impLONG
:
4110 case FFEINTRIN_impREAL
:
4111 case FFEINTRIN_impSHORT
:
4112 case FFEINTRIN_impSNGL
:
4113 return convert (tree_type
, ffecom_expr (arg1
));
4115 case FFEINTRIN_impDIM
:
4116 case FFEINTRIN_impDDIM
:
4117 case FFEINTRIN_impIDIM
:
4118 saved_expr1
= ffecom_save_tree (convert (tree_type
,
4119 ffecom_expr (arg1
)));
4120 saved_expr2
= ffecom_save_tree (convert (tree_type
,
4121 ffecom_expr (arg2
)));
4123 ffecom_3 (COND_EXPR
, tree_type
,
4125 (ffecom_2 (GT_EXPR
, integer_type_node
,
4128 ffecom_2 (MINUS_EXPR
, tree_type
,
4131 convert (tree_type
, ffecom_float_zero_
));
4133 case FFEINTRIN_impDPROD
:
4135 ffecom_2 (MULT_EXPR
, tree_type
,
4136 convert (tree_type
, ffecom_expr (arg1
)),
4137 convert (tree_type
, ffecom_expr (arg2
)));
4139 case FFEINTRIN_impEXP
:
4140 case FFEINTRIN_impCDEXP
:
4141 case FFEINTRIN_impCEXP
:
4142 case FFEINTRIN_impDEXP
:
4143 if (bt
== FFEINFO_basictypeCOMPLEX
)
4145 if (kt
== FFEINFO_kindtypeREAL1
)
4146 gfrt
= FFECOM_gfrtCEXP
; /* Overlapping result okay. */
4147 else if (kt
== FFEINFO_kindtypeREAL2
)
4148 gfrt
= FFECOM_gfrtCDEXP
; /* Overlapping result okay. */
4152 case FFEINTRIN_impICHAR
:
4153 case FFEINTRIN_impIACHAR
:
4154 #if 0 /* The simple approach. */
4155 ffecom_char_args_ (&expr_tree
, &saved_expr1
/* Ignored */ , arg1
);
4157 = ffecom_1 (INDIRECT_REF
,
4158 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
4161 = ffecom_2 (ARRAY_REF
,
4162 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
4165 return convert (tree_type
, expr_tree
);
4166 #else /* The more interesting (and more optimal) approach. */
4167 expr_tree
= ffecom_intrinsic_ichar_ (tree_type
, arg1
, &saved_expr1
);
4168 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
4171 convert (tree_type
, integer_zero_node
));
4175 case FFEINTRIN_impINDEX
:
4178 case FFEINTRIN_impLEN
:
4180 break; /* The simple approach. */
4182 return ffecom_intrinsic_len_ (arg1
); /* The more optimal approach. */
4185 case FFEINTRIN_impLGE
:
4186 case FFEINTRIN_impLGT
:
4187 case FFEINTRIN_impLLE
:
4188 case FFEINTRIN_impLLT
:
4191 case FFEINTRIN_impLOG
:
4192 case FFEINTRIN_impALOG
:
4193 case FFEINTRIN_impCDLOG
:
4194 case FFEINTRIN_impCLOG
:
4195 case FFEINTRIN_impDLOG
:
4196 if (bt
== FFEINFO_basictypeCOMPLEX
)
4198 if (kt
== FFEINFO_kindtypeREAL1
)
4199 gfrt
= FFECOM_gfrtCLOG
; /* Overlapping result okay. */
4200 else if (kt
== FFEINFO_kindtypeREAL2
)
4201 gfrt
= FFECOM_gfrtCDLOG
; /* Overlapping result okay. */
4205 case FFEINTRIN_impLOG10
:
4206 case FFEINTRIN_impALOG10
:
4207 case FFEINTRIN_impDLOG10
:
4208 if (gfrt
!= FFECOM_gfrt
)
4209 break; /* Already picked one, stick with it. */
4211 if (kt
== FFEINFO_kindtypeREAL1
)
4212 /* We used to call FFECOM_gfrtALOG10 here. */
4213 gfrt
= FFECOM_gfrtL_LOG10
;
4214 else if (kt
== FFEINFO_kindtypeREAL2
)
4215 /* We used to call FFECOM_gfrtDLOG10 here. */
4216 gfrt
= FFECOM_gfrtL_LOG10
;
4219 case FFEINTRIN_impMAX
:
4220 case FFEINTRIN_impAMAX0
:
4221 case FFEINTRIN_impAMAX1
:
4222 case FFEINTRIN_impDMAX1
:
4223 case FFEINTRIN_impMAX0
:
4224 case FFEINTRIN_impMAX1
:
4225 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4226 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4228 arg1_type
= tree_type
;
4229 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4230 convert (arg1_type
, ffecom_expr (arg1
)),
4231 convert (arg1_type
, ffecom_expr (arg2
)));
4232 for (; list
!= NULL
; list
= ffebld_trail (list
))
4234 if ((ffebld_head (list
) == NULL
)
4235 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4237 expr_tree
= ffecom_2 (MAX_EXPR
, arg1_type
,
4240 ffecom_expr (ffebld_head (list
))));
4242 return convert (tree_type
, expr_tree
);
4244 case FFEINTRIN_impMIN
:
4245 case FFEINTRIN_impAMIN0
:
4246 case FFEINTRIN_impAMIN1
:
4247 case FFEINTRIN_impDMIN1
:
4248 case FFEINTRIN_impMIN0
:
4249 case FFEINTRIN_impMIN1
:
4250 if (bt
!= ffeinfo_basictype (ffebld_info (arg1
)))
4251 arg1_type
= ffecom_widest_expr_type_ (ffebld_right (expr
));
4253 arg1_type
= tree_type
;
4254 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4255 convert (arg1_type
, ffecom_expr (arg1
)),
4256 convert (arg1_type
, ffecom_expr (arg2
)));
4257 for (; list
!= NULL
; list
= ffebld_trail (list
))
4259 if ((ffebld_head (list
) == NULL
)
4260 || (ffebld_op (ffebld_head (list
)) == FFEBLD_opANY
))
4262 expr_tree
= ffecom_2 (MIN_EXPR
, arg1_type
,
4265 ffecom_expr (ffebld_head (list
))));
4267 return convert (tree_type
, expr_tree
);
4269 case FFEINTRIN_impMOD
:
4270 case FFEINTRIN_impAMOD
:
4271 case FFEINTRIN_impDMOD
:
4272 if (bt
!= FFEINFO_basictypeREAL
)
4273 return ffecom_2 (TRUNC_MOD_EXPR
, tree_type
,
4274 convert (tree_type
, ffecom_expr (arg1
)),
4275 convert (tree_type
, ffecom_expr (arg2
)));
4277 if (kt
== FFEINFO_kindtypeREAL1
)
4278 /* We used to call FFECOM_gfrtAMOD here. */
4279 gfrt
= FFECOM_gfrtL_FMOD
;
4280 else if (kt
== FFEINFO_kindtypeREAL2
)
4281 /* We used to call FFECOM_gfrtDMOD here. */
4282 gfrt
= FFECOM_gfrtL_FMOD
;
4285 case FFEINTRIN_impNINT
:
4286 case FFEINTRIN_impIDNINT
:
4288 /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet. */
4289 return ffecom_1 (FIX_ROUND_EXPR
, tree_type
, ffecom_expr (arg1
));
4291 /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4292 saved_expr1
= ffecom_save_tree (ffecom_expr (arg1
));
4294 convert (ffecom_integer_type_node
,
4295 ffecom_3 (COND_EXPR
, arg1_type
,
4297 (ffecom_2 (GE_EXPR
, integer_type_node
,
4300 ffecom_float_zero_
))),
4301 ffecom_2 (PLUS_EXPR
, arg1_type
,
4304 ffecom_float_half_
)),
4305 ffecom_2 (MINUS_EXPR
, arg1_type
,
4308 ffecom_float_half_
))));
4311 case FFEINTRIN_impSIGN
:
4312 case FFEINTRIN_impDSIGN
:
4313 case FFEINTRIN_impISIGN
:
4315 tree arg2_tree
= ffecom_expr (arg2
);
4319 (ffecom_1 (ABS_EXPR
, tree_type
,
4321 ffecom_expr (arg1
))));
4323 = ffecom_3 (COND_EXPR
, tree_type
,
4325 (ffecom_2 (GE_EXPR
, integer_type_node
,
4327 convert (TREE_TYPE (arg2_tree
),
4328 integer_zero_node
))),
4330 ffecom_1 (NEGATE_EXPR
, tree_type
, saved_expr1
));
4331 /* Make sure SAVE_EXPRs get referenced early enough. */
4333 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4334 convert (void_type_node
, saved_expr1
),
4339 case FFEINTRIN_impSIN
:
4340 case FFEINTRIN_impCDSIN
:
4341 case FFEINTRIN_impCSIN
:
4342 case FFEINTRIN_impDSIN
:
4343 if (bt
== FFEINFO_basictypeCOMPLEX
)
4345 if (kt
== FFEINFO_kindtypeREAL1
)
4346 gfrt
= FFECOM_gfrtCSIN
; /* Overlapping result okay. */
4347 else if (kt
== FFEINFO_kindtypeREAL2
)
4348 gfrt
= FFECOM_gfrtCDSIN
; /* Overlapping result okay. */
4352 case FFEINTRIN_impSINH
:
4353 case FFEINTRIN_impDSINH
:
4356 case FFEINTRIN_impSQRT
:
4357 case FFEINTRIN_impCDSQRT
:
4358 case FFEINTRIN_impCSQRT
:
4359 case FFEINTRIN_impDSQRT
:
4360 if (bt
== FFEINFO_basictypeCOMPLEX
)
4362 if (kt
== FFEINFO_kindtypeREAL1
)
4363 gfrt
= FFECOM_gfrtCSQRT
; /* Overlapping result okay. */
4364 else if (kt
== FFEINFO_kindtypeREAL2
)
4365 gfrt
= FFECOM_gfrtCDSQRT
; /* Overlapping result okay. */
4369 case FFEINTRIN_impTAN
:
4370 case FFEINTRIN_impDTAN
:
4371 case FFEINTRIN_impTANH
:
4372 case FFEINTRIN_impDTANH
:
4375 case FFEINTRIN_impREALPART
:
4376 if (TREE_CODE (arg1_type
) == COMPLEX_TYPE
)
4377 arg1_type
= TREE_TYPE (arg1_type
);
4379 arg1_type
= TREE_TYPE (TYPE_FIELDS (arg1_type
));
4383 ffecom_1 (REALPART_EXPR
, arg1_type
,
4384 ffecom_expr (arg1
)));
4386 case FFEINTRIN_impIAND
:
4387 case FFEINTRIN_impAND
:
4388 return ffecom_2 (BIT_AND_EXPR
, tree_type
,
4390 ffecom_expr (arg1
)),
4392 ffecom_expr (arg2
)));
4394 case FFEINTRIN_impIOR
:
4395 case FFEINTRIN_impOR
:
4396 return ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4398 ffecom_expr (arg1
)),
4400 ffecom_expr (arg2
)));
4402 case FFEINTRIN_impIEOR
:
4403 case FFEINTRIN_impXOR
:
4404 return ffecom_2 (BIT_XOR_EXPR
, tree_type
,
4406 ffecom_expr (arg1
)),
4408 ffecom_expr (arg2
)));
4410 case FFEINTRIN_impLSHIFT
:
4411 return ffecom_2 (LSHIFT_EXPR
, tree_type
,
4413 convert (integer_type_node
,
4414 ffecom_expr (arg2
)));
4416 case FFEINTRIN_impRSHIFT
:
4417 return ffecom_2 (RSHIFT_EXPR
, tree_type
,
4419 convert (integer_type_node
,
4420 ffecom_expr (arg2
)));
4422 case FFEINTRIN_impNOT
:
4423 return ffecom_1 (BIT_NOT_EXPR
, tree_type
, ffecom_expr (arg1
));
4425 case FFEINTRIN_impBIT_SIZE
:
4426 return convert (tree_type
, TYPE_SIZE (arg1_type
));
4428 case FFEINTRIN_impBTEST
:
4430 ffetargetLogical1 target_true
;
4431 ffetargetLogical1 target_false
;
4435 ffetarget_logical1 (&target_true
, TRUE
);
4436 ffetarget_logical1 (&target_false
, FALSE
);
4437 if (target_true
== 1)
4438 true_tree
= convert (tree_type
, integer_one_node
);
4440 true_tree
= convert (tree_type
, build_int_2 (target_true
, 0));
4441 if (target_false
== 0)
4442 false_tree
= convert (tree_type
, integer_zero_node
);
4444 false_tree
= convert (tree_type
, build_int_2 (target_false
, 0));
4447 ffecom_3 (COND_EXPR
, tree_type
,
4449 (ffecom_2 (EQ_EXPR
, integer_type_node
,
4450 ffecom_2 (BIT_AND_EXPR
, arg1_type
,
4452 ffecom_2 (LSHIFT_EXPR
, arg1_type
,
4455 convert (integer_type_node
,
4456 ffecom_expr (arg2
)))),
4458 integer_zero_node
))),
4463 case FFEINTRIN_impIBCLR
:
4465 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4467 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4468 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4471 convert (integer_type_node
,
4472 ffecom_expr (arg2
)))));
4474 case FFEINTRIN_impIBITS
:
4476 tree arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4477 ffecom_expr (arg3
)));
4479 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4482 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4483 ffecom_2 (RSHIFT_EXPR
, tree_type
,
4485 convert (integer_type_node
,
4486 ffecom_expr (arg2
))),
4488 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4489 ffecom_1 (BIT_NOT_EXPR
,
4492 integer_zero_node
)),
4493 ffecom_2 (MINUS_EXPR
,
4495 TYPE_SIZE (uns_type
),
4497 /* Fix up, because the RSHIFT_EXPR above can't shift over TYPE_SIZE. */
4499 = ffecom_3 (COND_EXPR
, tree_type
,
4501 (ffecom_2 (NE_EXPR
, integer_type_node
,
4503 integer_zero_node
)),
4505 convert (tree_type
, integer_zero_node
));
4509 case FFEINTRIN_impIBSET
:
4511 ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4513 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4514 convert (tree_type
, integer_one_node
),
4515 convert (integer_type_node
,
4516 ffecom_expr (arg2
))));
4518 case FFEINTRIN_impISHFT
:
4520 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4521 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4522 ffecom_expr (arg2
)));
4524 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4527 = ffecom_3 (COND_EXPR
, tree_type
,
4529 (ffecom_2 (GE_EXPR
, integer_type_node
,
4531 integer_zero_node
)),
4532 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4536 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4537 convert (uns_type
, arg1_tree
),
4538 ffecom_1 (NEGATE_EXPR
,
4541 /* Fix up, because {L|R}SHIFT_EXPR don't go over TYPE_SIZE bounds. */
4543 = ffecom_3 (COND_EXPR
, tree_type
,
4545 (ffecom_2 (NE_EXPR
, integer_type_node
,
4549 TYPE_SIZE (uns_type
))),
4551 convert (tree_type
, integer_zero_node
));
4552 /* Make sure SAVE_EXPRs get referenced early enough. */
4554 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4555 convert (void_type_node
, arg1_tree
),
4556 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4557 convert (void_type_node
, arg2_tree
),
4562 case FFEINTRIN_impISHFTC
:
4564 tree arg1_tree
= ffecom_save_tree (ffecom_expr (arg1
));
4565 tree arg2_tree
= ffecom_save_tree (convert (integer_type_node
,
4566 ffecom_expr (arg2
)));
4567 tree arg3_tree
= (arg3
== NULL
) ? TYPE_SIZE (tree_type
)
4568 : ffecom_save_tree (convert (integer_type_node
, ffecom_expr (arg3
)));
4574 = ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
4577 = ffecom_2 (LSHIFT_EXPR
, tree_type
,
4578 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4579 convert (tree_type
, integer_zero_node
)),
4581 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4583 = ffecom_3 (COND_EXPR
, tree_type
,
4585 (ffecom_2 (NE_EXPR
, integer_type_node
,
4587 TYPE_SIZE (uns_type
))),
4589 convert (tree_type
, integer_zero_node
));
4590 mask_arg1
= ffecom_save_tree (mask_arg1
);
4592 = ffecom_2 (BIT_AND_EXPR
, tree_type
,
4594 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4596 masked_arg1
= ffecom_save_tree (masked_arg1
);
4598 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4600 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4601 convert (uns_type
, masked_arg1
),
4602 ffecom_1 (NEGATE_EXPR
,
4605 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4607 ffecom_2 (PLUS_EXPR
, integer_type_node
,
4611 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4612 ffecom_2 (LSHIFT_EXPR
, tree_type
,
4616 ffecom_2 (RSHIFT_EXPR
, uns_type
,
4617 convert (uns_type
, masked_arg1
),
4618 ffecom_2 (MINUS_EXPR
,
4623 = ffecom_3 (COND_EXPR
, tree_type
,
4625 (ffecom_2 (LT_EXPR
, integer_type_node
,
4627 integer_zero_node
)),
4631 = ffecom_2 (BIT_IOR_EXPR
, tree_type
,
4632 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4635 ffecom_2 (BIT_AND_EXPR
, tree_type
,
4636 ffecom_1 (BIT_NOT_EXPR
, tree_type
,
4640 = ffecom_3 (COND_EXPR
, tree_type
,
4642 (ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
4643 ffecom_2 (EQ_EXPR
, integer_type_node
,
4648 ffecom_2 (EQ_EXPR
, integer_type_node
,
4650 integer_zero_node
))),
4653 /* Make sure SAVE_EXPRs get referenced early enough. */
4655 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4656 convert (void_type_node
, arg1_tree
),
4657 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4658 convert (void_type_node
, arg2_tree
),
4659 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4660 convert (void_type_node
,
4662 ffecom_2 (COMPOUND_EXPR
, tree_type
,
4663 convert (void_type_node
,
4667 = ffecom_2 (COMPOUND_EXPR
, tree_type
,
4668 convert (void_type_node
,
4674 case FFEINTRIN_impLOC
:
4676 tree arg1_tree
= ffecom_expr (arg1
);
4679 = convert (tree_type
,
4680 ffecom_1 (ADDR_EXPR
,
4681 build_pointer_type (TREE_TYPE (arg1_tree
)),
4686 case FFEINTRIN_impMVBITS
:
4691 ffebld arg4
= ffebld_head (ffebld_trail (list
));
4694 ffebld arg5
= ffebld_head (ffebld_trail (ffebld_trail (list
)));
4698 tree arg5_plus_arg3
;
4700 arg2_tree
= convert (integer_type_node
,
4701 ffecom_expr (arg2
));
4702 arg3_tree
= ffecom_save_tree (convert (integer_type_node
,
4703 ffecom_expr (arg3
)));
4704 arg4_tree
= ffecom_expr_rw (NULL_TREE
, arg4
);
4705 arg4_type
= TREE_TYPE (arg4_tree
);
4707 arg1_tree
= ffecom_save_tree (convert (arg4_type
,
4708 ffecom_expr (arg1
)));
4710 arg5_tree
= ffecom_save_tree (convert (integer_type_node
,
4711 ffecom_expr (arg5
)));
4714 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4715 ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4716 ffecom_2 (RSHIFT_EXPR
, arg4_type
,
4719 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4720 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4721 ffecom_1 (BIT_NOT_EXPR
,
4725 integer_zero_node
)),
4729 = ffecom_save_tree (ffecom_2 (PLUS_EXPR
, arg4_type
,
4733 = ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4734 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4736 integer_zero_node
)),
4738 /* Fix up, because LSHIFT_EXPR above can't shift over TYPE_SIZE. */
4740 = ffecom_3 (COND_EXPR
, arg4_type
,
4742 (ffecom_2 (NE_EXPR
, integer_type_node
,
4744 convert (TREE_TYPE (arg5_plus_arg3
),
4745 TYPE_SIZE (arg4_type
)))),
4747 convert (arg4_type
, integer_zero_node
));
4749 = ffecom_2 (BIT_AND_EXPR
, arg4_type
,
4751 ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4753 ffecom_1 (BIT_NOT_EXPR
, arg4_type
,
4754 ffecom_2 (LSHIFT_EXPR
, arg4_type
,
4755 ffecom_1 (BIT_NOT_EXPR
,
4759 integer_zero_node
)),
4762 = ffecom_2 (BIT_IOR_EXPR
, arg4_type
,
4765 /* Fix up (twice), because LSHIFT_EXPR above
4766 can't shift over TYPE_SIZE. */
4768 = ffecom_3 (COND_EXPR
, arg4_type
,
4770 (ffecom_2 (NE_EXPR
, integer_type_node
,
4772 convert (TREE_TYPE (arg3_tree
),
4773 integer_zero_node
))),
4777 = ffecom_3 (COND_EXPR
, arg4_type
,
4779 (ffecom_2 (NE_EXPR
, integer_type_node
,
4781 convert (TREE_TYPE (arg3_tree
),
4782 TYPE_SIZE (arg4_type
)))),
4786 = ffecom_2s (MODIFY_EXPR
, void_type_node
,
4789 /* Make sure SAVE_EXPRs get referenced early enough. */
4791 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4793 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4795 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4797 ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4801 = ffecom_2 (COMPOUND_EXPR
, void_type_node
,
4808 case FFEINTRIN_impDERF
:
4809 case FFEINTRIN_impERF
:
4810 case FFEINTRIN_impDERFC
:
4811 case FFEINTRIN_impERFC
:
4814 case FFEINTRIN_impIARGC
:
4815 /* extern int xargc; i__1 = xargc - 1; */
4816 expr_tree
= ffecom_2 (MINUS_EXPR
, TREE_TYPE (ffecom_tree_xargc_
),
4818 convert (TREE_TYPE (ffecom_tree_xargc_
),
4822 case FFEINTRIN_impSIGNAL_func
:
4823 case FFEINTRIN_impSIGNAL_subr
:
4829 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4830 ffecom_expr (arg1
));
4831 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4832 build_pointer_type (TREE_TYPE (arg1_tree
)),
4835 /* Pass procedure as a pointer to it, anything else by value. */
4836 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4837 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4839 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4840 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4844 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
4846 arg3_tree
= NULL_TREE
;
4848 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4849 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4850 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4853 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4854 ffecom_gfrt_kindtype (gfrt
),
4856 ((codegen_imp
== FFEINTRIN_impSIGNAL_subr
) ?
4860 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4861 ffebld_nonter_hook (expr
));
4863 if (arg3_tree
!= NULL_TREE
)
4865 = ffecom_modify (NULL_TREE
, arg3_tree
,
4866 convert (TREE_TYPE (arg3_tree
),
4871 case FFEINTRIN_impALARM
:
4877 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
4878 ffecom_expr (arg1
));
4879 arg1_tree
= ffecom_1 (ADDR_EXPR
,
4880 build_pointer_type (TREE_TYPE (arg1_tree
)),
4883 /* Pass procedure as a pointer to it, anything else by value. */
4884 if (ffeinfo_kind (ffebld_info (arg2
)) == FFEINFO_kindENTITY
)
4885 arg2_tree
= convert (integer_type_node
, ffecom_expr (arg2
));
4887 arg2_tree
= ffecom_ptr_to_expr (arg2
);
4888 arg2_tree
= convert (TREE_TYPE (null_pointer_node
),
4892 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
4894 arg3_tree
= NULL_TREE
;
4896 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4897 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
4898 TREE_CHAIN (arg1_tree
) = arg2_tree
;
4901 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4902 ffecom_gfrt_kindtype (gfrt
),
4906 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4907 ffebld_nonter_hook (expr
));
4909 if (arg3_tree
!= NULL_TREE
)
4911 = ffecom_modify (NULL_TREE
, arg3_tree
,
4912 convert (TREE_TYPE (arg3_tree
),
4917 case FFEINTRIN_impCHDIR_subr
:
4918 case FFEINTRIN_impFDATE_subr
:
4919 case FFEINTRIN_impFGET_subr
:
4920 case FFEINTRIN_impFPUT_subr
:
4921 case FFEINTRIN_impGETCWD_subr
:
4922 case FFEINTRIN_impHOSTNM_subr
:
4923 case FFEINTRIN_impSYSTEM_subr
:
4924 case FFEINTRIN_impUNLINK_subr
:
4926 tree arg1_len
= integer_zero_node
;
4930 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4933 arg2_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
4935 arg2_tree
= NULL_TREE
;
4937 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
4938 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
4939 TREE_CHAIN (arg1_tree
) = arg1_len
;
4942 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4943 ffecom_gfrt_kindtype (gfrt
),
4947 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4948 ffebld_nonter_hook (expr
));
4950 if (arg2_tree
!= NULL_TREE
)
4952 = ffecom_modify (NULL_TREE
, arg2_tree
,
4953 convert (TREE_TYPE (arg2_tree
),
4958 case FFEINTRIN_impEXIT
:
4962 expr_tree
= build_tree_list (NULL_TREE
,
4963 ffecom_1 (ADDR_EXPR
,
4965 (ffecom_integer_type_node
),
4966 integer_zero_node
));
4969 ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
4970 ffecom_gfrt_kindtype (gfrt
),
4974 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
4975 ffebld_nonter_hook (expr
));
4977 case FFEINTRIN_impFLUSH
:
4979 gfrt
= FFECOM_gfrtFLUSH
;
4981 gfrt
= FFECOM_gfrtFLUSH1
;
4984 case FFEINTRIN_impCHMOD_subr
:
4985 case FFEINTRIN_impLINK_subr
:
4986 case FFEINTRIN_impRENAME_subr
:
4987 case FFEINTRIN_impSYMLNK_subr
:
4989 tree arg1_len
= integer_zero_node
;
4991 tree arg2_len
= integer_zero_node
;
4995 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
4996 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
4998 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5000 arg3_tree
= NULL_TREE
;
5002 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5003 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5004 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5005 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
5006 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5007 TREE_CHAIN (arg2_tree
) = arg1_len
;
5008 TREE_CHAIN (arg1_len
) = arg2_len
;
5009 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5010 ffecom_gfrt_kindtype (gfrt
),
5014 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5015 ffebld_nonter_hook (expr
));
5016 if (arg3_tree
!= NULL_TREE
)
5017 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5018 convert (TREE_TYPE (arg3_tree
),
5023 case FFEINTRIN_impLSTAT_subr
:
5024 case FFEINTRIN_impSTAT_subr
:
5026 tree arg1_len
= integer_zero_node
;
5031 arg1_tree
= ffecom_arg_ptr_to_expr (arg1
, &arg1_len
);
5033 arg2_tree
= ffecom_ptr_to_expr (arg2
);
5036 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5038 arg3_tree
= NULL_TREE
;
5040 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5041 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5042 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5043 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5044 TREE_CHAIN (arg2_tree
) = arg1_len
;
5045 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5046 ffecom_gfrt_kindtype (gfrt
),
5050 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5051 ffebld_nonter_hook (expr
));
5052 if (arg3_tree
!= NULL_TREE
)
5053 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5054 convert (TREE_TYPE (arg3_tree
),
5059 case FFEINTRIN_impFGETC_subr
:
5060 case FFEINTRIN_impFPUTC_subr
:
5064 tree arg2_len
= integer_zero_node
;
5067 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5068 ffecom_expr (arg1
));
5069 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5070 build_pointer_type (TREE_TYPE (arg1_tree
)),
5073 arg2_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg2_len
);
5075 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5077 arg3_tree
= NULL_TREE
;
5079 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5080 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5081 arg2_len
= build_tree_list (NULL_TREE
, arg2_len
);
5082 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5083 TREE_CHAIN (arg2_tree
) = arg2_len
;
5085 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5086 ffecom_gfrt_kindtype (gfrt
),
5090 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5091 ffebld_nonter_hook (expr
));
5092 if (arg3_tree
!= NULL_TREE
)
5093 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5094 convert (TREE_TYPE (arg3_tree
),
5099 case FFEINTRIN_impFSTAT_subr
:
5105 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5106 ffecom_expr (arg1
));
5107 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5108 build_pointer_type (TREE_TYPE (arg1_tree
)),
5111 arg2_tree
= convert (ffecom_f2c_ptr_to_integer_type_node
,
5112 ffecom_ptr_to_expr (arg2
));
5115 arg3_tree
= NULL_TREE
;
5117 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5119 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5120 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5121 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5122 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5123 ffecom_gfrt_kindtype (gfrt
),
5127 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5128 ffebld_nonter_hook (expr
));
5129 if (arg3_tree
!= NULL_TREE
) {
5130 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5131 convert (TREE_TYPE (arg3_tree
),
5137 case FFEINTRIN_impKILL_subr
:
5143 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5144 ffecom_expr (arg1
));
5145 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5146 build_pointer_type (TREE_TYPE (arg1_tree
)),
5149 arg2_tree
= convert (ffecom_f2c_integer_type_node
,
5150 ffecom_expr (arg2
));
5151 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5152 build_pointer_type (TREE_TYPE (arg2_tree
)),
5156 arg3_tree
= NULL_TREE
;
5158 arg3_tree
= ffecom_expr_w (NULL_TREE
, arg3
);
5160 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5161 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5162 TREE_CHAIN (arg1_tree
) = arg2_tree
;
5163 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5164 ffecom_gfrt_kindtype (gfrt
),
5168 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5169 ffebld_nonter_hook (expr
));
5170 if (arg3_tree
!= NULL_TREE
) {
5171 expr_tree
= ffecom_modify (NULL_TREE
, arg3_tree
,
5172 convert (TREE_TYPE (arg3_tree
),
5178 case FFEINTRIN_impCTIME_subr
:
5179 case FFEINTRIN_impTTYNAM_subr
:
5181 tree arg1_len
= integer_zero_node
;
5185 arg1_tree
= ffecom_arg_ptr_to_expr (arg2
, &arg1_len
);
5187 arg2_tree
= convert (((codegen_imp
== FFEINTRIN_impCTIME_subr
) ?
5188 ffecom_f2c_longint_type_node
:
5189 ffecom_f2c_integer_type_node
),
5190 ffecom_expr (arg1
));
5191 arg2_tree
= ffecom_1 (ADDR_EXPR
,
5192 build_pointer_type (TREE_TYPE (arg2_tree
)),
5195 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5196 arg1_len
= build_tree_list (NULL_TREE
, arg1_len
);
5197 arg2_tree
= build_tree_list (NULL_TREE
, arg2_tree
);
5198 TREE_CHAIN (arg1_len
) = arg2_tree
;
5199 TREE_CHAIN (arg1_tree
) = arg1_len
;
5202 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5203 ffecom_gfrt_kindtype (gfrt
),
5207 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5208 ffebld_nonter_hook (expr
));
5209 TREE_SIDE_EFFECTS (expr_tree
) = 1;
5213 case FFEINTRIN_impIRAND
:
5214 case FFEINTRIN_impRAND
:
5215 /* Arg defaults to 0 (normal random case) */
5220 arg1_tree
= ffecom_integer_zero_node
;
5222 arg1_tree
= ffecom_expr (arg1
);
5223 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5225 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5226 build_pointer_type (TREE_TYPE (arg1_tree
)),
5228 arg1_tree
= build_tree_list (NULL_TREE
, arg1_tree
);
5230 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5231 ffecom_gfrt_kindtype (gfrt
),
5233 ((codegen_imp
== FFEINTRIN_impIRAND
) ?
5234 ffecom_f2c_integer_type_node
:
5235 ffecom_f2c_real_type_node
),
5237 dest_tree
, dest
, dest_used
,
5239 ffebld_nonter_hook (expr
));
5243 case FFEINTRIN_impFTELL_subr
:
5244 case FFEINTRIN_impUMASK_subr
:
5249 arg1_tree
= convert (ffecom_f2c_integer_type_node
,
5250 ffecom_expr (arg1
));
5251 arg1_tree
= ffecom_1 (ADDR_EXPR
,
5252 build_pointer_type (TREE_TYPE (arg1_tree
)),
5256 arg2_tree
= NULL_TREE
;
5258 arg2_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
5260 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5261 ffecom_gfrt_kindtype (gfrt
),
5264 build_tree_list (NULL_TREE
, arg1_tree
),
5265 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5267 ffebld_nonter_hook (expr
));
5268 if (arg2_tree
!= NULL_TREE
) {
5269 expr_tree
= ffecom_modify (NULL_TREE
, arg2_tree
,
5270 convert (TREE_TYPE (arg2_tree
),
5276 case FFEINTRIN_impCPU_TIME
:
5277 case FFEINTRIN_impSECOND_subr
:
5281 arg1_tree
= ffecom_expr_w (NULL_TREE
, arg1
);
5284 = ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5285 ffecom_gfrt_kindtype (gfrt
),
5289 NULL_TREE
, NULL
, NULL
, NULL_TREE
, TRUE
,
5290 ffebld_nonter_hook (expr
));
5293 = ffecom_modify (NULL_TREE
, arg1_tree
,
5294 convert (TREE_TYPE (arg1_tree
),
5299 case FFEINTRIN_impDTIME_subr
:
5300 case FFEINTRIN_impETIME_subr
:
5305 result_tree
= ffecom_expr_w (NULL_TREE
, arg2
);
5307 arg1_tree
= ffecom_ptr_to_expr (arg1
);
5309 expr_tree
= ffecom_call_ (ffecom_gfrt_tree_ (gfrt
),
5310 ffecom_gfrt_kindtype (gfrt
),
5313 build_tree_list (NULL_TREE
, arg1_tree
),
5314 NULL_TREE
, NULL
, NULL
, NULL_TREE
,
5316 ffebld_nonter_hook (expr
));
5317 expr_tree
= ffecom_modify (NULL_TREE
, result_tree
,
5318 convert (TREE_TYPE (result_tree
),
5323 /* Straightforward calls of libf2c routines: */
5324 case FFEINTRIN_impABORT
:
5325 case FFEINTRIN_impACCESS
:
5326 case FFEINTRIN_impBESJ0
:
5327 case FFEINTRIN_impBESJ1
:
5328 case FFEINTRIN_impBESJN
:
5329 case FFEINTRIN_impBESY0
:
5330 case FFEINTRIN_impBESY1
:
5331 case FFEINTRIN_impBESYN
:
5332 case FFEINTRIN_impCHDIR_func
:
5333 case FFEINTRIN_impCHMOD_func
:
5334 case FFEINTRIN_impDATE
:
5335 case FFEINTRIN_impDATE_AND_TIME
:
5336 case FFEINTRIN_impDBESJ0
:
5337 case FFEINTRIN_impDBESJ1
:
5338 case FFEINTRIN_impDBESJN
:
5339 case FFEINTRIN_impDBESY0
:
5340 case FFEINTRIN_impDBESY1
:
5341 case FFEINTRIN_impDBESYN
:
5342 case FFEINTRIN_impDTIME_func
:
5343 case FFEINTRIN_impETIME_func
:
5344 case FFEINTRIN_impFGETC_func
:
5345 case FFEINTRIN_impFGET_func
:
5346 case FFEINTRIN_impFNUM
:
5347 case FFEINTRIN_impFPUTC_func
:
5348 case FFEINTRIN_impFPUT_func
:
5349 case FFEINTRIN_impFSEEK
:
5350 case FFEINTRIN_impFSTAT_func
:
5351 case FFEINTRIN_impFTELL_func
:
5352 case FFEINTRIN_impGERROR
:
5353 case FFEINTRIN_impGETARG
:
5354 case FFEINTRIN_impGETCWD_func
:
5355 case FFEINTRIN_impGETENV
:
5356 case FFEINTRIN_impGETGID
:
5357 case FFEINTRIN_impGETLOG
:
5358 case FFEINTRIN_impGETPID
:
5359 case FFEINTRIN_impGETUID
:
5360 case FFEINTRIN_impGMTIME
:
5361 case FFEINTRIN_impHOSTNM_func
:
5362 case FFEINTRIN_impIDATE_unix
:
5363 case FFEINTRIN_impIDATE_vxt
:
5364 case FFEINTRIN_impIERRNO
:
5365 case FFEINTRIN_impISATTY
:
5366 case FFEINTRIN_impITIME
:
5367 case FFEINTRIN_impKILL_func
:
5368 case FFEINTRIN_impLINK_func
:
5369 case FFEINTRIN_impLNBLNK
:
5370 case FFEINTRIN_impLSTAT_func
:
5371 case FFEINTRIN_impLTIME
:
5372 case FFEINTRIN_impMCLOCK8
:
5373 case FFEINTRIN_impMCLOCK
:
5374 case FFEINTRIN_impPERROR
:
5375 case FFEINTRIN_impRENAME_func
:
5376 case FFEINTRIN_impSECNDS
:
5377 case FFEINTRIN_impSECOND_func
:
5378 case FFEINTRIN_impSLEEP
:
5379 case FFEINTRIN_impSRAND
:
5380 case FFEINTRIN_impSTAT_func
:
5381 case FFEINTRIN_impSYMLNK_func
:
5382 case FFEINTRIN_impSYSTEM_CLOCK
:
5383 case FFEINTRIN_impSYSTEM_func
:
5384 case FFEINTRIN_impTIME8
:
5385 case FFEINTRIN_impTIME_unix
:
5386 case FFEINTRIN_impTIME_vxt
:
5387 case FFEINTRIN_impUMASK_func
:
5388 case FFEINTRIN_impUNLINK_func
:
5391 case FFEINTRIN_impCTIME_func
: /* CHARACTER functions not handled here. */
5392 case FFEINTRIN_impFDATE_func
: /* CHARACTER functions not handled here. */
5393 case FFEINTRIN_impTTYNAM_func
: /* CHARACTER functions not handled here. */
5394 case FFEINTRIN_impNONE
:
5395 case FFEINTRIN_imp
: /* Hush up gcc warning. */
5396 fprintf (stderr
, "No %s implementation.\n",
5397 ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr
))));
5398 assert ("unimplemented intrinsic" == NULL
);
5399 return error_mark_node
;
5402 assert (gfrt
!= FFECOM_gfrt
); /* Must have an implementation! */
5404 expr_tree
= ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt
),
5405 ffebld_right (expr
));
5407 return ffecom_call_ (ffecom_gfrt_tree_ (gfrt
), ffecom_gfrt_kindtype (gfrt
),
5408 (ffe_is_f2c_library () && ffecom_gfrt_complex_
[gfrt
]),
5410 expr_tree
, dest_tree
, dest
, dest_used
,
5412 ffebld_nonter_hook (expr
));
5414 /* See bottom of this file for f2c transforms used to determine
5415 many of the above implementations. The info seems to confuse
5416 Emacs's C mode indentation, which is why it's been moved to
5417 the bottom of this source file. */
5420 /* For power (exponentiation) where right-hand operand is type INTEGER,
5421 generate in-line code to do it the fast way (which, if the operand
5422 is a constant, might just mean a series of multiplies). */
5425 ffecom_expr_power_integer_ (ffebld expr
)
5427 tree l
= ffecom_expr (ffebld_left (expr
));
5428 tree r
= ffecom_expr (ffebld_right (expr
));
5429 tree ltype
= TREE_TYPE (l
);
5430 tree rtype
= TREE_TYPE (r
);
5431 tree result
= NULL_TREE
;
5433 if (l
== error_mark_node
5434 || r
== error_mark_node
)
5435 return error_mark_node
;
5437 if (TREE_CODE (r
) == INTEGER_CST
)
5439 int sgn
= tree_int_cst_sgn (r
);
5442 return convert (ltype
, integer_one_node
);
5444 if ((TREE_CODE (ltype
) == INTEGER_TYPE
)
5447 /* Reciprocal of integer is either 0, -1, or 1, so after
5448 calculating that (which we leave to the back end to do
5449 or not do optimally), don't bother with any multiplying. */
5451 result
= ffecom_tree_divide_ (ltype
,
5452 convert (ltype
, integer_one_node
),
5454 NULL_TREE
, NULL
, NULL
, NULL_TREE
);
5455 r
= ffecom_1 (NEGATE_EXPR
,
5458 if ((TREE_INT_CST_LOW (r
) & 1) == 0)
5459 result
= ffecom_1 (ABS_EXPR
, rtype
,
5463 /* Generate appropriate series of multiplies, preceded
5464 by divide if the exponent is negative. */
5470 l
= ffecom_tree_divide_ (ltype
,
5471 convert (ltype
, integer_one_node
),
5473 NULL_TREE
, NULL
, NULL
,
5474 ffebld_nonter_hook (expr
));
5475 r
= ffecom_1 (NEGATE_EXPR
, rtype
, r
);
5476 assert (TREE_CODE (r
) == INTEGER_CST
);
5478 if (tree_int_cst_sgn (r
) < 0)
5479 { /* The "most negative" number. */
5480 r
= ffecom_1 (NEGATE_EXPR
, rtype
,
5481 ffecom_2 (RSHIFT_EXPR
, rtype
,
5485 l
= ffecom_2 (MULT_EXPR
, ltype
,
5493 if (TREE_INT_CST_LOW (r
) & 1)
5495 if (result
== NULL_TREE
)
5498 result
= ffecom_2 (MULT_EXPR
, ltype
,
5503 r
= ffecom_2 (RSHIFT_EXPR
, rtype
,
5506 if (integer_zerop (r
))
5508 assert (TREE_CODE (r
) == INTEGER_CST
);
5511 l
= ffecom_2 (MULT_EXPR
, ltype
,
5518 /* Though rhs isn't a constant, in-line code cannot be expanded
5519 while transforming dummies
5520 because the back end cannot be easily convinced to generate
5521 stores (MODIFY_EXPR), handle temporaries, and so on before
5522 all the appropriate rtx's have been generated for things like
5523 dummy args referenced in rhs -- which doesn't happen until
5524 store_parm_decls() is called (expand_function_start, I believe,
5525 does the actual rtx-stuffing of PARM_DECLs).
5527 So, in this case, let the caller generate the call to the
5528 run-time-library function to evaluate the power for us. */
5530 if (ffecom_transform_only_dummies_
)
5533 /* Right-hand operand not a constant, expand in-line code to figure
5534 out how to do the multiplies, &c.
5536 The returned expression is expressed this way in GNU C, where l and
5539 ({ typeof (r) rtmp = r;
5540 typeof (l) ltmp = l;
5547 if ((basetypeof (l) == basetypeof (int))
5550 result = ((typeof (l)) 1) / ltmp;
5551 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5557 if ((basetypeof (l) != basetypeof (int))
5560 ltmp = ((typeof (l)) 1) / ltmp;
5564 rtmp = -(rtmp >> 1);
5572 if ((rtmp >>= 1) == 0)
5581 Note that some of the above is compile-time collapsable, such as
5582 the first part of the if statements that checks the base type of
5583 l against int. The if statements are phrased that way to suggest
5584 an easy way to generate the if/else constructs here, knowing that
5585 the back end should (and probably does) eliminate the resulting
5586 dead code (either the int case or the non-int case), something
5587 it couldn't do without the redundant phrasing, requiring explicit
5588 dead-code elimination here, which would be kind of difficult to
5595 tree basetypeof_l_is_int
;
5600 = build_int_2 ((TREE_CODE (ltype
) == INTEGER_TYPE
), 0);
5602 se
= expand_start_stmt_expr (/*has_scope=*/1);
5604 ffecom_start_compstmt ();
5606 rtmp
= ffecom_make_tempvar ("power_r", rtype
,
5607 FFETARGET_charactersizeNONE
, -1);
5608 ltmp
= ffecom_make_tempvar ("power_l", ltype
,
5609 FFETARGET_charactersizeNONE
, -1);
5610 result
= ffecom_make_tempvar ("power_res", ltype
,
5611 FFETARGET_charactersizeNONE
, -1);
5612 if (TREE_CODE (ltype
) == COMPLEX_TYPE
5613 || TREE_CODE (ltype
) == RECORD_TYPE
)
5614 divide
= ffecom_make_tempvar ("power_div", ltype
,
5615 FFETARGET_charactersizeNONE
, -1);
5619 expand_expr_stmt (ffecom_modify (void_type_node
,
5622 expand_expr_stmt (ffecom_modify (void_type_node
,
5625 expand_start_cond (ffecom_truth_value
5626 (ffecom_2 (EQ_EXPR
, integer_type_node
,
5628 convert (rtype
, integer_zero_node
))),
5630 expand_expr_stmt (ffecom_modify (void_type_node
,
5632 convert (ltype
, integer_one_node
)));
5633 expand_start_else ();
5634 if (! integer_zerop (basetypeof_l_is_int
))
5636 expand_start_cond (ffecom_2 (LT_EXPR
, integer_type_node
,
5639 integer_zero_node
)),
5641 expand_expr_stmt (ffecom_modify (void_type_node
,
5645 convert (ltype
, integer_one_node
),
5647 NULL_TREE
, NULL
, NULL
,
5649 expand_start_cond (ffecom_truth_value
5650 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
5651 ffecom_2 (LT_EXPR
, integer_type_node
,
5654 integer_zero_node
)),
5655 ffecom_2 (EQ_EXPR
, integer_type_node
,
5656 ffecom_2 (BIT_AND_EXPR
,
5658 ffecom_1 (NEGATE_EXPR
,
5664 integer_zero_node
)))),
5666 expand_expr_stmt (ffecom_modify (void_type_node
,
5668 ffecom_1 (NEGATE_EXPR
,
5672 expand_start_else ();
5674 expand_expr_stmt (ffecom_modify (void_type_node
,
5676 convert (ltype
, integer_one_node
)));
5677 expand_start_cond (ffecom_truth_value
5678 (ffecom_2 (TRUTH_ANDIF_EXPR
, integer_type_node
,
5679 ffecom_truth_value_invert
5680 (basetypeof_l_is_int
),
5681 ffecom_2 (LT_EXPR
, integer_type_node
,
5684 integer_zero_node
)))),
5686 expand_expr_stmt (ffecom_modify (void_type_node
,
5690 convert (ltype
, integer_one_node
),
5692 NULL_TREE
, NULL
, NULL
,
5694 expand_expr_stmt (ffecom_modify (void_type_node
,
5696 ffecom_1 (NEGATE_EXPR
, rtype
,
5698 expand_start_cond (ffecom_truth_value
5699 (ffecom_2 (LT_EXPR
, integer_type_node
,
5701 convert (rtype
, integer_zero_node
))),
5703 expand_expr_stmt (ffecom_modify (void_type_node
,
5705 ffecom_1 (NEGATE_EXPR
, rtype
,
5706 ffecom_2 (RSHIFT_EXPR
,
5709 integer_one_node
))));
5710 expand_expr_stmt (ffecom_modify (void_type_node
,
5712 ffecom_2 (MULT_EXPR
, ltype
,
5717 expand_start_loop (1);
5718 expand_start_cond (ffecom_truth_value
5719 (ffecom_2 (BIT_AND_EXPR
, rtype
,
5721 convert (rtype
, integer_one_node
))),
5723 expand_expr_stmt (ffecom_modify (void_type_node
,
5725 ffecom_2 (MULT_EXPR
, ltype
,
5729 expand_exit_loop_if_false (NULL
,
5731 (ffecom_modify (rtype
,
5733 ffecom_2 (RSHIFT_EXPR
,
5736 integer_one_node
))));
5737 expand_expr_stmt (ffecom_modify (void_type_node
,
5739 ffecom_2 (MULT_EXPR
, ltype
,
5744 if (!integer_zerop (basetypeof_l_is_int
))
5746 expand_expr_stmt (result
);
5748 t
= ffecom_end_compstmt ();
5750 result
= expand_end_stmt_expr (se
);
5752 /* This code comes from c-parse.in, after its expand_end_stmt_expr. */
5754 if (TREE_CODE (t
) == BLOCK
)
5756 /* Make a BIND_EXPR for the BLOCK already made. */
5757 result
= build (BIND_EXPR
, TREE_TYPE (result
),
5758 NULL_TREE
, result
, t
);
5759 /* Remove the block from the tree at this point.
5760 It gets put back at the proper place
5761 when the BIND_EXPR is expanded. */
5771 /* ffecom_expr_transform_ -- Transform symbols in expr
5773 ffebld expr; // FFE expression.
5774 ffecom_expr_transform_ (expr);
5776 Recursive descent on expr while transforming any untransformed SYMTERs. */
5779 ffecom_expr_transform_ (ffebld expr
)
5789 switch (ffebld_op (expr
))
5791 case FFEBLD_opSYMTER
:
5792 s
= ffebld_symter (expr
);
5793 t
= ffesymbol_hook (s
).decl_tree
;
5794 if ((t
== NULL_TREE
)
5795 && ((ffesymbol_kind (s
) != FFEINFO_kindNONE
)
5796 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
5797 && (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
))))
5799 s
= ffecom_sym_transform_ (s
);
5800 t
= ffesymbol_hook (s
).decl_tree
; /* Sfunc expr non-dummy,
5803 break; /* Ok if (t == NULL) here. */
5806 ffecom_expr_transform_ (ffebld_head (expr
));
5807 expr
= ffebld_trail (expr
);
5808 goto tail_recurse
; /* :::::::::::::::::::: */
5814 switch (ffebld_arity (expr
))
5817 ffecom_expr_transform_ (ffebld_left (expr
));
5818 expr
= ffebld_right (expr
);
5819 goto tail_recurse
; /* :::::::::::::::::::: */
5822 expr
= ffebld_left (expr
);
5823 goto tail_recurse
; /* :::::::::::::::::::: */
5832 /* Make a type based on info in live f2c.h file. */
5835 ffecom_f2c_make_type_ (tree
*type
, int tcode
, const char *name
)
5839 case FFECOM_f2ccodeCHAR
:
5840 *type
= make_signed_type (CHAR_TYPE_SIZE
);
5843 case FFECOM_f2ccodeSHORT
:
5844 *type
= make_signed_type (SHORT_TYPE_SIZE
);
5847 case FFECOM_f2ccodeINT
:
5848 *type
= make_signed_type (INT_TYPE_SIZE
);
5851 case FFECOM_f2ccodeLONG
:
5852 *type
= make_signed_type (LONG_TYPE_SIZE
);
5855 case FFECOM_f2ccodeLONGLONG
:
5856 *type
= make_signed_type (LONG_LONG_TYPE_SIZE
);
5859 case FFECOM_f2ccodeCHARPTR
:
5860 *type
= build_pointer_type (DEFAULT_SIGNED_CHAR
5861 ? signed_char_type_node
5862 : unsigned_char_type_node
);
5865 case FFECOM_f2ccodeFLOAT
:
5866 *type
= make_node (REAL_TYPE
);
5867 TYPE_PRECISION (*type
) = FLOAT_TYPE_SIZE
;
5868 layout_type (*type
);
5871 case FFECOM_f2ccodeDOUBLE
:
5872 *type
= make_node (REAL_TYPE
);
5873 TYPE_PRECISION (*type
) = DOUBLE_TYPE_SIZE
;
5874 layout_type (*type
);
5877 case FFECOM_f2ccodeLONGDOUBLE
:
5878 *type
= make_node (REAL_TYPE
);
5879 TYPE_PRECISION (*type
) = LONG_DOUBLE_TYPE_SIZE
;
5880 layout_type (*type
);
5883 case FFECOM_f2ccodeTWOREALS
:
5884 *type
= ffecom_make_complex_type_ (ffecom_f2c_real_type_node
);
5887 case FFECOM_f2ccodeTWODOUBLEREALS
:
5888 *type
= ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node
);
5892 assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL
);
5893 *type
= error_mark_node
;
5897 pushdecl (build_decl (TYPE_DECL
,
5898 ffecom_get_invented_identifier ("__g77_f2c_%s", name
),
5902 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
5906 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt
, int size
,
5912 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
5913 if ((t
= ffecom_tree_type
[bt
][j
]) != NULL_TREE
5914 && compare_tree_int (TYPE_SIZE (t
), size
) == 0)
5916 assert (code
!= -1);
5917 ffecom_f2c_typecode_
[bt
][j
] = code
;
5922 /* Finish up globals after doing all program units in file
5924 Need to handle only uninitialized COMMON areas. */
5927 ffecom_finish_global_ (ffeglobal global
)
5933 if (ffeglobal_type (global
) != FFEGLOBAL_typeCOMMON
)
5936 if (ffeglobal_common_init (global
))
5939 cbt
= ffeglobal_hook (global
);
5940 if ((cbt
== NULL_TREE
)
5941 || !ffeglobal_common_have_size (global
))
5942 return global
; /* No need to make common, never ref'd. */
5944 DECL_EXTERNAL (cbt
) = 0;
5946 /* Give the array a size now. */
5948 size
= build_int_2 ((ffeglobal_common_size (global
)
5949 + ffeglobal_common_pad (global
)) - 1,
5952 cbtype
= TREE_TYPE (cbt
);
5953 TYPE_DOMAIN (cbtype
) = build_range_type (integer_type_node
,
5956 if (!TREE_TYPE (size
))
5957 TREE_TYPE (size
) = TYPE_DOMAIN (cbtype
);
5958 layout_type (cbtype
);
5960 cbt
= start_decl (cbt
, FALSE
);
5961 assert (cbt
== ffeglobal_hook (global
));
5963 finish_decl (cbt
, NULL_TREE
, FALSE
);
5968 /* Finish up any untransformed symbols. */
5971 ffecom_finish_symbol_transform_ (ffesymbol s
)
5973 if ((s
== NULL
) || (TREE_CODE (current_function_decl
) == ERROR_MARK
))
5976 /* It's easy to know to transform an untransformed symbol, to make sure
5977 we put out debugging info for it. But COMMON variables, unlike
5978 EQUIVALENCE ones, aren't given declarations in addition to the
5979 tree expressions that specify offsets, because COMMON variables
5980 can be referenced in the outer scope where only dummy arguments
5981 (PARM_DECLs) should really be seen. To be safe, just don't do any
5982 VAR_DECLs for COMMON variables when we transform them for real
5983 use, and therefore we do all the VAR_DECL creating here. */
5985 if (ffesymbol_hook (s
).decl_tree
== NULL_TREE
)
5987 if (ffesymbol_kind (s
) != FFEINFO_kindNONE
5988 || (ffesymbol_where (s
) != FFEINFO_whereNONE
5989 && ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
5990 && ffesymbol_where (s
) != FFEINFO_whereDUMMY
))
5991 /* Not transformed, and not CHARACTER*(*), and not a dummy
5992 argument, which can happen only if the entry point names
5993 it "rides in on" are all invalidated for other reasons. */
5994 s
= ffecom_sym_transform_ (s
);
5997 if ((ffesymbol_where (s
) == FFEINFO_whereCOMMON
)
5998 && (ffesymbol_hook (s
).decl_tree
!= error_mark_node
))
6000 /* This isn't working, at least for dbxout. The .s file looks
6001 okay to me (burley), but in gdb 4.9 at least, the variables
6002 appear to reside somewhere outside of the common area, so
6003 it doesn't make sense to mislead anyone by generating the info
6004 on those variables until this is fixed. NOTE: Same problem
6005 with EQUIVALENCE, sadly...see similar #if later. */
6006 ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s
)),
6007 ffesymbol_storage (s
));
6013 /* Append underscore(s) to name before calling get_identifier. "us"
6014 is nonzero if the name already contains an underscore and thus
6015 needs two underscores appended. */
6018 ffecom_get_appended_identifier_ (char us
, const char *name
)
6024 newname
= xmalloc ((i
= strlen (name
)) + 1
6025 + ffe_is_underscoring ()
6027 memcpy (newname
, name
, i
);
6029 newname
[i
+ us
] = '_';
6030 newname
[i
+ 1 + us
] = '\0';
6031 id
= get_identifier (newname
);
6038 /* Decide whether to append underscore to name before calling
6042 ffecom_get_external_identifier_ (ffesymbol s
)
6045 const char *name
= ffesymbol_text (s
);
6047 /* If name is a built-in name, just return it as is. */
6049 if (!ffe_is_underscoring ()
6050 || (strcmp (name
, FFETARGET_nameBLANK_COMMON
) == 0)
6051 #if FFETARGET_isENFORCED_MAIN_NAME
6052 || (strcmp (name
, FFETARGET_nameENFORCED_NAME
) == 0)
6054 || (strcmp (name
, FFETARGET_nameUNNAMED_MAIN
) == 0)
6056 || (strcmp (name
, FFETARGET_nameUNNAMED_BLOCK_DATA
) == 0))
6057 return get_identifier (name
);
6059 us
= ffe_is_second_underscore ()
6060 ? (strchr (name
, '_') != NULL
)
6063 return ffecom_get_appended_identifier_ (us
, name
);
6066 /* Decide whether to append underscore to internal name before calling
6069 This is for non-external, top-function-context names only. Transform
6070 identifier so it doesn't conflict with the transformed result
6071 of using a _different_ external name. E.g. if "CALL FOO" is
6072 transformed into "FOO_();", then the variable in "FOO_ = 3"
6073 must be transformed into something that does not conflict, since
6074 these two things should be independent.
6076 The transformation is as follows. If the name does not contain
6077 an underscore, there is no possible conflict, so just return.
6078 If the name does contain an underscore, then transform it just
6079 like we transform an external identifier. */
6082 ffecom_get_identifier_ (const char *name
)
6084 /* If name does not contain an underscore, just return it as is. */
6086 if (!ffe_is_underscoring ()
6087 || (strchr (name
, '_') == NULL
))
6088 return get_identifier (name
);
6090 return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6094 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6097 ffesymbol s; // kindFUNCTION, whereIMMEDIATE.
6098 t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6099 ffesymbol_kindtype(s));
6101 Call after setting up containing function and getting trees for all
6105 ffecom_gen_sfuncdef_ (ffesymbol s
, ffeinfoBasictype bt
, ffeinfoKindtype kt
)
6107 ffebld expr
= ffesymbol_sfexpr (s
);
6111 bool charfunc
= (bt
== FFEINFO_basictypeCHARACTER
);
6112 static bool recurse
= FALSE
;
6113 int old_lineno
= lineno
;
6114 const char *old_input_filename
= input_filename
;
6116 ffecom_nested_entry_
= s
;
6118 /* For now, we don't have a handy pointer to where the sfunc is actually
6119 defined, though that should be easy to add to an ffesymbol. (The
6120 token/where info available might well point to the place where the type
6121 of the sfunc is declared, especially if that precedes the place where
6122 the sfunc itself is defined, which is typically the case.) We should
6123 put out a null pointer rather than point somewhere wrong, but I want to
6124 see how it works at this point. */
6126 input_filename
= ffesymbol_where_filename (s
);
6127 lineno
= ffesymbol_where_filelinenum (s
);
6129 /* Pretransform the expression so any newly discovered things belong to the
6130 outer program unit, not to the statement function. */
6132 ffecom_expr_transform_ (expr
);
6134 /* Make sure no recursive invocation of this fn (a specific case of failing
6135 to pretransform an sfunc's expression, i.e. where its expression
6136 references another untransformed sfunc) happens. */
6141 push_f_function_context ();
6144 type
= void_type_node
;
6147 type
= ffecom_tree_type
[bt
][kt
];
6148 if (type
== NULL_TREE
)
6149 type
= integer_type_node
; /* _sym_exec_transition reports
6153 start_function (ffecom_get_identifier_ (ffesymbol_text (s
)),
6154 build_function_type (type
, NULL_TREE
),
6155 1, /* nested/inline */
6156 0); /* TREE_PUBLIC */
6158 /* We don't worry about COMPLEX return values here, because this is
6159 entirely internal to our code, and gcc has the ability to return COMPLEX
6160 directly as a value. */
6163 { /* Prepend arg for where result goes. */
6166 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
6168 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
6170 ffecom_char_enhance_arg_ (&type
, s
); /* Ignore returned length. */
6172 type
= build_pointer_type (type
);
6173 result
= build_decl (PARM_DECL
, result
, type
);
6175 push_parm_decl (result
);
6178 result
= NULL_TREE
; /* Not ref'd if !charfunc. */
6180 ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s
), TRUE
);
6182 store_parm_decls (0);
6184 ffecom_start_compstmt ();
6190 ffetargetCharacterSize sz
= ffesymbol_size (s
);
6193 result_length
= build_int_2 (sz
, 0);
6194 TREE_TYPE (result_length
) = ffecom_f2c_ftnlen_type_node
;
6196 ffecom_prepare_let_char_ (sz
, expr
);
6198 ffecom_prepare_end ();
6200 ffecom_let_char_ (result
, result_length
, sz
, expr
);
6201 expand_null_return ();
6205 ffecom_prepare_expr (expr
);
6207 ffecom_prepare_end ();
6209 expand_return (ffecom_modify (NULL_TREE
,
6210 DECL_RESULT (current_function_decl
),
6211 ffecom_expr (expr
)));
6215 ffecom_end_compstmt ();
6217 func
= current_function_decl
;
6218 finish_function (1);
6220 pop_f_function_context ();
6224 lineno
= old_lineno
;
6225 input_filename
= old_input_filename
;
6227 ffecom_nested_entry_
= NULL
;
6233 ffecom_gfrt_args_ (ffecomGfrt ix
)
6235 return ffecom_gfrt_argstring_
[ix
];
6239 ffecom_gfrt_tree_ (ffecomGfrt ix
)
6241 if (ffecom_gfrt_
[ix
] == NULL_TREE
)
6242 ffecom_make_gfrt_ (ix
);
6244 return ffecom_1 (ADDR_EXPR
,
6245 build_pointer_type (TREE_TYPE (ffecom_gfrt_
[ix
])),
6249 /* Return initialize-to-zero expression for this VAR_DECL. */
6251 /* A somewhat evil way to prevent the garbage collector
6252 from collecting 'tree' structures. */
6253 #define NUM_TRACKED_CHUNK 63
6254 struct tree_ggc_tracker
GTY(())
6256 struct tree_ggc_tracker
*next
;
6257 tree trees
[NUM_TRACKED_CHUNK
];
6259 static GTY(()) struct tree_ggc_tracker
*tracker_head
;
6262 ffecom_save_tree_forever (tree t
)
6265 if (tracker_head
!= NULL
)
6266 for (i
= 0; i
< NUM_TRACKED_CHUNK
; i
++)
6267 if (tracker_head
->trees
[i
] == NULL
)
6269 tracker_head
->trees
[i
] = t
;
6274 /* Need to allocate a new block. */
6275 struct tree_ggc_tracker
*old_head
= tracker_head
;
6277 tracker_head
= ggc_alloc (sizeof (*tracker_head
));
6278 tracker_head
->next
= old_head
;
6279 tracker_head
->trees
[0] = t
;
6280 for (i
= 1; i
< NUM_TRACKED_CHUNK
; i
++)
6281 tracker_head
->trees
[i
] = NULL
;
6286 ffecom_init_zero_ (tree decl
)
6289 int incremental
= TREE_STATIC (decl
);
6290 tree type
= TREE_TYPE (decl
);
6294 make_decl_rtl (decl
, NULL
);
6295 assemble_variable (decl
, TREE_PUBLIC (decl
) ? 1 : 0, 0, 1);
6298 if ((TREE_CODE (type
) != ARRAY_TYPE
)
6299 && (TREE_CODE (type
) != RECORD_TYPE
)
6300 && (TREE_CODE (type
) != UNION_TYPE
)
6302 init
= convert (type
, integer_zero_node
);
6303 else if (!incremental
)
6305 init
= build (CONSTRUCTOR
, type
, NULL_TREE
, NULL_TREE
);
6306 TREE_CONSTANT (init
) = 1;
6307 TREE_STATIC (init
) = 1;
6311 assemble_zeros (int_size_in_bytes (type
));
6312 init
= error_mark_node
;
6319 ffecom_intrinsic_ichar_ (tree tree_type
, ffebld arg
,
6325 switch (ffebld_op (arg
))
6327 case FFEBLD_opCONTER
: /* For F90, check 0-length. */
6328 if (ffetarget_length_character1
6329 (ffebld_constant_character1
6330 (ffebld_conter (arg
))) == 0)
6332 *maybe_tree
= integer_zero_node
;
6333 return convert (tree_type
, integer_zero_node
);
6336 *maybe_tree
= integer_one_node
;
6337 expr_tree
= build_int_2 (*ffetarget_text_character1
6338 (ffebld_constant_character1
6339 (ffebld_conter (arg
))),
6341 TREE_TYPE (expr_tree
) = tree_type
;
6344 case FFEBLD_opSYMTER
:
6345 case FFEBLD_opARRAYREF
:
6346 case FFEBLD_opFUNCREF
:
6347 case FFEBLD_opSUBSTR
:
6348 ffecom_char_args_ (&expr_tree
, &length_tree
, arg
);
6350 if ((expr_tree
== error_mark_node
)
6351 || (length_tree
== error_mark_node
))
6353 *maybe_tree
= error_mark_node
;
6354 return error_mark_node
;
6357 if (integer_zerop (length_tree
))
6359 *maybe_tree
= integer_zero_node
;
6360 return convert (tree_type
, integer_zero_node
);
6364 = ffecom_1 (INDIRECT_REF
,
6365 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
6368 = ffecom_2 (ARRAY_REF
,
6369 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree
))),
6372 expr_tree
= convert (tree_type
, expr_tree
);
6374 if (TREE_CODE (length_tree
) == INTEGER_CST
)
6375 *maybe_tree
= integer_one_node
;
6376 else /* Must check length at run time. */
6378 = ffecom_truth_value
6379 (ffecom_2 (GT_EXPR
, integer_type_node
,
6381 ffecom_f2c_ftnlen_zero_node
));
6384 case FFEBLD_opPAREN
:
6385 case FFEBLD_opCONVERT
:
6386 if (ffeinfo_size (ffebld_info (arg
)) == 0)
6388 *maybe_tree
= integer_zero_node
;
6389 return convert (tree_type
, integer_zero_node
);
6391 return ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
6394 case FFEBLD_opCONCATENATE
:
6401 expr_left
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_left (arg
),
6403 expr_right
= ffecom_intrinsic_ichar_ (tree_type
, ffebld_right (arg
),
6405 *maybe_tree
= ffecom_2 (TRUTH_ORIF_EXPR
, integer_type_node
,
6408 expr_tree
= ffecom_3 (COND_EXPR
, tree_type
,
6416 assert ("bad op in ICHAR" == NULL
);
6417 return error_mark_node
;
6421 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6425 length_arg = ffecom_intrinsic_len_ (expr);
6427 Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6428 subexpressions by constructing the appropriate tree for the
6429 length-of-character-text argument in a calling sequence. */
6432 ffecom_intrinsic_len_ (ffebld expr
)
6434 ffetargetCharacter1 val
;
6437 switch (ffebld_op (expr
))
6439 case FFEBLD_opCONTER
:
6440 val
= ffebld_constant_character1 (ffebld_conter (expr
));
6441 length
= build_int_2 (ffetarget_length_character1 (val
), 0);
6442 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6445 case FFEBLD_opSYMTER
:
6447 ffesymbol s
= ffebld_symter (expr
);
6450 item
= ffesymbol_hook (s
).decl_tree
;
6451 if (item
== NULL_TREE
)
6453 s
= ffecom_sym_transform_ (s
);
6454 item
= ffesymbol_hook (s
).decl_tree
;
6456 if (ffesymbol_kind (s
) == FFEINFO_kindENTITY
)
6458 if (ffesymbol_size (s
) == FFETARGET_charactersizeNONE
)
6459 length
= ffesymbol_hook (s
).length_tree
;
6462 length
= build_int_2 (ffesymbol_size (s
), 0);
6463 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6466 else if (item
== error_mark_node
)
6467 length
= error_mark_node
;
6468 else /* FFEINFO_kindFUNCTION: */
6473 case FFEBLD_opARRAYREF
:
6474 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
6477 case FFEBLD_opSUBSTR
:
6481 ffebld thing
= ffebld_right (expr
);
6485 assert (ffebld_op (thing
) == FFEBLD_opITEM
);
6486 start
= ffebld_head (thing
);
6487 thing
= ffebld_trail (thing
);
6488 assert (ffebld_trail (thing
) == NULL
);
6489 end
= ffebld_head (thing
);
6491 length
= ffecom_intrinsic_len_ (ffebld_left (expr
));
6493 if (length
== error_mark_node
)
6502 length
= convert (ffecom_f2c_ftnlen_type_node
,
6508 start_tree
= convert (ffecom_f2c_ftnlen_type_node
,
6509 ffecom_expr (start
));
6511 if (start_tree
== error_mark_node
)
6513 length
= error_mark_node
;
6519 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6520 ffecom_f2c_ftnlen_one_node
,
6521 ffecom_2 (MINUS_EXPR
,
6522 ffecom_f2c_ftnlen_type_node
,
6528 end_tree
= convert (ffecom_f2c_ftnlen_type_node
,
6531 if (end_tree
== error_mark_node
)
6533 length
= error_mark_node
;
6537 length
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6538 ffecom_f2c_ftnlen_one_node
,
6539 ffecom_2 (MINUS_EXPR
,
6540 ffecom_f2c_ftnlen_type_node
,
6541 end_tree
, start_tree
));
6547 case FFEBLD_opCONCATENATE
:
6549 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
6550 ffecom_intrinsic_len_ (ffebld_left (expr
)),
6551 ffecom_intrinsic_len_ (ffebld_right (expr
)));
6554 case FFEBLD_opFUNCREF
:
6555 case FFEBLD_opCONVERT
:
6556 length
= build_int_2 (ffebld_size (expr
), 0);
6557 TREE_TYPE (length
) = ffecom_f2c_ftnlen_type_node
;
6561 assert ("bad op for single char arg expr" == NULL
);
6562 length
= ffecom_f2c_ftnlen_zero_node
;
6566 assert (length
!= NULL_TREE
);
6571 /* Handle CHARACTER assignments.
6573 Generates code to do the assignment. Used by ordinary assignment
6574 statement handler ffecom_let_stmt and by statement-function
6575 handler to generate code for a statement function. */
6578 ffecom_let_char_ (tree dest_tree
, tree dest_length
,
6579 ffetargetCharacterSize dest_size
, ffebld source
)
6581 ffecomConcatList_ catlist
;
6586 if ((dest_tree
== error_mark_node
)
6587 || (dest_length
== error_mark_node
))
6590 assert (dest_tree
!= NULL_TREE
);
6591 assert (dest_length
!= NULL_TREE
);
6593 /* Source might be an opCONVERT, which just means it is a different size
6594 than the destination. Since the underlying implementation here handles
6595 that (directly or via the s_copy or s_cat run-time-library functions),
6596 we don't need the "convenience" of an opCONVERT that tells us to
6597 truncate or blank-pad, particularly since the resulting implementation
6598 would probably be slower than otherwise. */
6600 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
6601 source
= ffebld_left (source
);
6603 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
6604 switch (ffecom_concat_list_count_ (catlist
))
6606 case 0: /* Shouldn't happen, but in case it does... */
6607 ffecom_concat_list_kill_ (catlist
);
6608 source_tree
= null_pointer_node
;
6609 source_length
= ffecom_f2c_ftnlen_zero_node
;
6610 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6611 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
6612 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6613 = build_tree_list (NULL_TREE
, dest_length
);
6614 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6615 = build_tree_list (NULL_TREE
, source_length
);
6617 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
, NULL_TREE
);
6618 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6620 expand_expr_stmt (expr_tree
);
6624 case 1: /* The (fairly) easy case. */
6625 ffecom_char_args_ (&source_tree
, &source_length
,
6626 ffecom_concat_list_expr_ (catlist
, 0));
6627 ffecom_concat_list_kill_ (catlist
);
6628 assert (source_tree
!= NULL_TREE
);
6629 assert (source_length
!= NULL_TREE
);
6631 if ((source_tree
== error_mark_node
)
6632 || (source_length
== error_mark_node
))
6638 = ffecom_1 (INDIRECT_REF
,
6639 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6643 = ffecom_2 (ARRAY_REF
,
6644 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6649 = ffecom_1 (INDIRECT_REF
,
6650 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6654 = ffecom_2 (ARRAY_REF
,
6655 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6660 expr_tree
= ffecom_modify (void_type_node
, dest_tree
, source_tree
);
6662 expand_expr_stmt (expr_tree
);
6667 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6668 TREE_CHAIN (expr_tree
) = build_tree_list (NULL_TREE
, source_tree
);
6669 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6670 = build_tree_list (NULL_TREE
, dest_length
);
6671 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6672 = build_tree_list (NULL_TREE
, source_length
);
6674 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCOPY
, expr_tree
, NULL_TREE
);
6675 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6677 expand_expr_stmt (expr_tree
);
6681 default: /* Must actually concatenate things. */
6685 /* Heavy-duty concatenation. */
6688 int count
= ffecom_concat_list_count_ (catlist
);
6700 hook
= ffebld_nonter_hook (source
);
6702 assert (TREE_CODE (hook
) == TREE_VEC
);
6703 assert (TREE_VEC_LENGTH (hook
) == 2);
6704 length_array
= lengths
= TREE_VEC_ELT (hook
, 0);
6705 item_array
= items
= TREE_VEC_ELT (hook
, 1);
6708 for (i
= 0; i
< count
; ++i
)
6710 ffecom_char_args_ (&citem
, &clength
,
6711 ffecom_concat_list_expr_ (catlist
, i
));
6712 if ((citem
== error_mark_node
)
6713 || (clength
== error_mark_node
))
6715 ffecom_concat_list_kill_ (catlist
);
6720 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
6721 ffecom_modify (void_type_node
,
6722 ffecom_2 (ARRAY_REF
,
6723 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
6725 build_int_2 (i
, 0)),
6729 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
6730 ffecom_modify (void_type_node
,
6731 ffecom_2 (ARRAY_REF
,
6732 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
6734 build_int_2 (i
, 0)),
6739 expr_tree
= build_tree_list (NULL_TREE
, dest_tree
);
6740 TREE_CHAIN (expr_tree
)
6741 = build_tree_list (NULL_TREE
,
6742 ffecom_1 (ADDR_EXPR
,
6743 build_pointer_type (TREE_TYPE (items
)),
6745 TREE_CHAIN (TREE_CHAIN (expr_tree
))
6746 = build_tree_list (NULL_TREE
,
6747 ffecom_1 (ADDR_EXPR
,
6748 build_pointer_type (TREE_TYPE (lengths
)),
6750 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
)))
6753 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
6754 convert (ffecom_f2c_ftnlen_type_node
,
6755 build_int_2 (count
, 0))));
6756 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree
))))
6757 = build_tree_list (NULL_TREE
, dest_length
);
6759 expr_tree
= ffecom_call_gfrt (FFECOM_gfrtCAT
, expr_tree
, NULL_TREE
);
6760 TREE_SIDE_EFFECTS (expr_tree
) = 1;
6762 expand_expr_stmt (expr_tree
);
6765 ffecom_concat_list_kill_ (catlist
);
6768 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6771 ffecom_make_gfrt_(ix);
6773 Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6774 for the indicated run-time routine (ix). */
6777 ffecom_make_gfrt_ (ffecomGfrt ix
)
6782 switch (ffecom_gfrt_type_
[ix
])
6784 case FFECOM_rttypeVOID_
:
6785 ttype
= void_type_node
;
6788 case FFECOM_rttypeVOIDSTAR_
:
6789 ttype
= TREE_TYPE (null_pointer_node
); /* `void *'. */
6792 case FFECOM_rttypeFTNINT_
:
6793 ttype
= ffecom_f2c_ftnint_type_node
;
6796 case FFECOM_rttypeINTEGER_
:
6797 ttype
= ffecom_f2c_integer_type_node
;
6800 case FFECOM_rttypeLONGINT_
:
6801 ttype
= ffecom_f2c_longint_type_node
;
6804 case FFECOM_rttypeLOGICAL_
:
6805 ttype
= ffecom_f2c_logical_type_node
;
6808 case FFECOM_rttypeREAL_F2C_
:
6809 ttype
= double_type_node
;
6812 case FFECOM_rttypeREAL_GNU_
:
6813 ttype
= float_type_node
;
6816 case FFECOM_rttypeCOMPLEX_F2C_
:
6817 ttype
= void_type_node
;
6820 case FFECOM_rttypeCOMPLEX_GNU_
:
6821 ttype
= ffecom_f2c_complex_type_node
;
6824 case FFECOM_rttypeDOUBLE_
:
6825 ttype
= double_type_node
;
6828 case FFECOM_rttypeDOUBLEREAL_
:
6829 ttype
= ffecom_f2c_doublereal_type_node
;
6832 case FFECOM_rttypeDBLCMPLX_F2C_
:
6833 ttype
= void_type_node
;
6836 case FFECOM_rttypeDBLCMPLX_GNU_
:
6837 ttype
= ffecom_f2c_doublecomplex_type_node
;
6840 case FFECOM_rttypeCHARACTER_
:
6841 ttype
= void_type_node
;
6846 assert ("bad rttype" == NULL
);
6850 ttype
= build_function_type (ttype
, NULL_TREE
);
6851 t
= build_decl (FUNCTION_DECL
,
6852 get_identifier (ffecom_gfrt_name_
[ix
]),
6854 DECL_EXTERNAL (t
) = 1;
6855 TREE_READONLY (t
) = ffecom_gfrt_const_
[ix
] ? 1 : 0;
6856 TREE_PUBLIC (t
) = 1;
6857 TREE_THIS_VOLATILE (t
) = ffecom_gfrt_volatile_
[ix
] ? 1 : 0;
6859 /* Sanity check: A function that's const cannot be volatile. */
6861 assert (ffecom_gfrt_const_
[ix
] ? !ffecom_gfrt_volatile_
[ix
] : 1);
6863 /* Sanity check: A function that's const cannot return complex. */
6865 assert (ffecom_gfrt_const_
[ix
] ? !ffecom_gfrt_complex_
[ix
] : 1);
6867 t
= start_decl (t
, TRUE
);
6869 finish_decl (t
, NULL_TREE
, TRUE
);
6871 ffecom_gfrt_
[ix
] = t
;
6874 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
6877 ffecom_member_phase1_ (ffestorag mst UNUSED
, ffestorag st
)
6879 ffesymbol s
= ffestorag_symbol (st
);
6881 if (ffesymbol_namelisted (s
))
6882 ffecom_member_namelisted_
= TRUE
;
6885 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
6886 the member so debugger will see it. Otherwise nobody should be
6887 referencing the member. */
6890 ffecom_member_phase2_ (ffestorag mst
, ffestorag st
)
6898 || ((mt
= ffestorag_hook (mst
)) == NULL
)
6899 || (mt
== error_mark_node
))
6903 || ((s
= ffestorag_symbol (st
)) == NULL
))
6906 type
= ffecom_type_localvar_ (s
,
6907 ffesymbol_basictype (s
),
6908 ffesymbol_kindtype (s
));
6909 if (type
== error_mark_node
)
6912 t
= build_decl (VAR_DECL
,
6913 ffecom_get_identifier_ (ffesymbol_text (s
)),
6916 TREE_STATIC (t
) = TREE_STATIC (mt
);
6917 DECL_INITIAL (t
) = NULL_TREE
;
6918 TREE_ASM_WRITTEN (t
) = 1;
6922 gen_rtx (MEM
, TYPE_MODE (type
),
6923 plus_constant (XEXP (DECL_RTL (mt
), 0),
6924 ffestorag_modulo (mst
)
6925 + ffestorag_offset (st
)
6926 - ffestorag_offset (mst
))));
6928 t
= start_decl (t
, FALSE
);
6930 finish_decl (t
, NULL_TREE
, FALSE
);
6933 /* Prepare source expression for assignment into a destination perhaps known
6934 to be of a specific size. */
6937 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size
, ffebld source
)
6939 ffecomConcatList_ catlist
;
6944 tree tempvar
= NULL_TREE
;
6946 while (ffebld_op (source
) == FFEBLD_opCONVERT
)
6947 source
= ffebld_left (source
);
6949 catlist
= ffecom_concat_list_new_ (source
, dest_size
);
6950 count
= ffecom_concat_list_count_ (catlist
);
6955 = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node
,
6956 FFETARGET_charactersizeNONE
, count
);
6958 = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node
,
6959 FFETARGET_charactersizeNONE
, count
);
6961 tempvar
= make_tree_vec (2);
6962 TREE_VEC_ELT (tempvar
, 0) = ltmp
;
6963 TREE_VEC_ELT (tempvar
, 1) = itmp
;
6966 for (i
= 0; i
< count
; ++i
)
6967 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist
, i
));
6969 ffecom_concat_list_kill_ (catlist
);
6973 ffebld_nonter_set_hook (source
, tempvar
);
6974 current_binding_level
->prep_state
= 1;
6978 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
6980 Ignores STAR (alternate-return) dummies. All other get exec-transitioned
6981 (which generates their trees) and then their trees get push_parm_decl'd.
6983 The second arg is TRUE if the dummies are for a statement function, in
6984 which case lengths are not pushed for character arguments (since they are
6985 always known by both the caller and the callee, though the code allows
6986 for someday permitting CHAR*(*) stmtfunc dummies). */
6989 ffecom_push_dummy_decls_ (ffebld dummy_list
, bool stmtfunc
)
6996 ffecom_transform_only_dummies_
= TRUE
;
6998 /* First push the parms corresponding to actual dummy "contents". */
7000 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7002 dummy
= ffebld_head (dumlist
);
7003 switch (ffebld_op (dummy
))
7007 continue; /* Forget alternate returns. */
7012 assert (ffebld_op (dummy
) == FFEBLD_opSYMTER
);
7013 s
= ffebld_symter (dummy
);
7014 parm
= ffesymbol_hook (s
).decl_tree
;
7015 if (parm
== NULL_TREE
)
7017 s
= ffecom_sym_transform_ (s
);
7018 parm
= ffesymbol_hook (s
).decl_tree
;
7019 assert (parm
!= NULL_TREE
);
7021 if (parm
!= error_mark_node
)
7022 push_parm_decl (parm
);
7025 /* Then, for CHARACTER dummies, push the parms giving their lengths. */
7027 for (dumlist
= dummy_list
; dumlist
!= NULL
; dumlist
= ffebld_trail (dumlist
))
7029 dummy
= ffebld_head (dumlist
);
7030 switch (ffebld_op (dummy
))
7034 continue; /* Forget alternate returns, they mean
7040 s
= ffebld_symter (dummy
);
7041 if (ffesymbol_basictype (s
) != FFEINFO_basictypeCHARACTER
)
7042 continue; /* Only looking for CHARACTER arguments. */
7043 if (stmtfunc
&& (ffesymbol_size (s
) != FFETARGET_charactersizeNONE
))
7044 continue; /* Stmtfunc arg with known size needs no
7046 if (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
7047 continue; /* Only looking for variables and arrays. */
7048 parm
= ffesymbol_hook (s
).length_tree
;
7049 assert (parm
!= NULL_TREE
);
7050 if (parm
!= error_mark_node
)
7051 push_parm_decl (parm
);
7054 ffecom_transform_only_dummies_
= FALSE
;
7057 /* ffecom_start_progunit_ -- Beginning of program unit
7059 Does GNU back end stuff necessary to teach it about the start of its
7060 equivalent of a Fortran program unit. */
7063 ffecom_start_progunit_ ()
7065 ffesymbol fn
= ffecom_primary_entry_
;
7067 tree id
; /* Identifier (name) of function. */
7068 tree type
; /* Type of function. */
7069 tree result
; /* Result of function. */
7070 ffeinfoBasictype bt
;
7074 ffeglobalType egt
= FFEGLOBAL_type
;
7077 bool altentries
= (ffecom_num_entrypoints_
!= 0);
7080 && (ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
7081 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
);
7082 bool main_program
= FALSE
;
7083 int old_lineno
= lineno
;
7084 const char *old_input_filename
= input_filename
;
7086 assert (fn
!= NULL
);
7087 assert (ffesymbol_hook (fn
).decl_tree
== NULL_TREE
);
7089 input_filename
= ffesymbol_where_filename (fn
);
7090 lineno
= ffesymbol_where_filelinenum (fn
);
7092 switch (ffecom_primary_entry_kind_
)
7094 case FFEINFO_kindPROGRAM
:
7095 main_program
= TRUE
;
7096 gt
= FFEGLOBAL_typeMAIN
;
7097 bt
= FFEINFO_basictypeNONE
;
7098 kt
= FFEINFO_kindtypeNONE
;
7099 type
= ffecom_tree_fun_type_void
;
7104 case FFEINFO_kindBLOCKDATA
:
7105 gt
= FFEGLOBAL_typeBDATA
;
7106 bt
= FFEINFO_basictypeNONE
;
7107 kt
= FFEINFO_kindtypeNONE
;
7108 type
= ffecom_tree_fun_type_void
;
7113 case FFEINFO_kindFUNCTION
:
7114 gt
= FFEGLOBAL_typeFUNC
;
7115 egt
= FFEGLOBAL_typeEXT
;
7116 bt
= ffesymbol_basictype (fn
);
7117 kt
= ffesymbol_kindtype (fn
);
7118 if (bt
== FFEINFO_basictypeNONE
)
7120 ffeimplic_establish_symbol (fn
);
7121 if (ffesymbol_funcresult (fn
) != NULL
)
7122 ffeimplic_establish_symbol (ffesymbol_funcresult (fn
));
7123 bt
= ffesymbol_basictype (fn
);
7124 kt
= ffesymbol_kindtype (fn
);
7128 charfunc
= cmplxfunc
= FALSE
;
7129 else if (bt
== FFEINFO_basictypeCHARACTER
)
7130 charfunc
= TRUE
, cmplxfunc
= FALSE
;
7131 else if ((bt
== FFEINFO_basictypeCOMPLEX
)
7132 && ffesymbol_is_f2c (fn
)
7134 charfunc
= FALSE
, cmplxfunc
= TRUE
;
7136 charfunc
= cmplxfunc
= FALSE
;
7138 if (multi
|| charfunc
)
7139 type
= ffecom_tree_fun_type_void
;
7140 else if (ffesymbol_is_f2c (fn
) && !altentries
)
7141 type
= ffecom_tree_fun_type
[bt
][kt
];
7143 type
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
7145 if ((type
== NULL_TREE
)
7146 || (TREE_TYPE (type
) == NULL_TREE
))
7147 type
= ffecom_tree_fun_type_void
; /* _sym_exec_transition. */
7150 case FFEINFO_kindSUBROUTINE
:
7151 gt
= FFEGLOBAL_typeSUBR
;
7152 egt
= FFEGLOBAL_typeEXT
;
7153 bt
= FFEINFO_basictypeNONE
;
7154 kt
= FFEINFO_kindtypeNONE
;
7155 if (ffecom_is_altreturning_
)
7156 type
= ffecom_tree_subr_type
;
7158 type
= ffecom_tree_fun_type_void
;
7164 assert ("say what??" == NULL
);
7166 case FFEINFO_kindANY
:
7167 gt
= FFEGLOBAL_typeANY
;
7168 bt
= FFEINFO_basictypeNONE
;
7169 kt
= FFEINFO_kindtypeNONE
;
7170 type
= error_mark_node
;
7178 id
= ffecom_get_invented_identifier ("__g77_masterfun_%s",
7179 ffesymbol_text (fn
));
7181 #if FFETARGET_isENFORCED_MAIN
7182 else if (main_program
)
7183 id
= get_identifier (FFETARGET_nameENFORCED_MAIN_NAME
);
7186 id
= ffecom_get_external_identifier_ (fn
);
7190 0, /* nested/inline */
7191 !altentries
); /* TREE_PUBLIC */
7193 TREE_USED (current_function_decl
) = 1; /* Avoid spurious warning if altentries. */
7196 && ((g
= ffesymbol_global (fn
)) != NULL
)
7197 && ((ffeglobal_type (g
) == gt
)
7198 || (ffeglobal_type (g
) == egt
)))
7200 ffeglobal_set_hook (g
, current_function_decl
);
7203 /* Arg handling needs exec-transitioned ffesymbols to work with. But
7204 exec-transitioning needs current_function_decl to be filled in. So we
7205 do these things in two phases. */
7208 { /* 1st arg identifies which entrypoint. */
7209 ffecom_which_entrypoint_decl_
7210 = build_decl (PARM_DECL
,
7211 ffecom_get_invented_identifier ("__g77_%s",
7212 "which_entrypoint"),
7214 push_parm_decl (ffecom_which_entrypoint_decl_
);
7220 { /* Arg for result (return value). */
7225 type
= ffecom_tree_type
[FFEINFO_basictypeCHARACTER
][kt
];
7227 type
= ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][kt
];
7229 type
= ffecom_multi_type_node_
;
7231 result
= ffecom_get_invented_identifier ("__g77_%s", "result");
7233 /* Make length arg _and_ enhance type info for CHAR arg itself. */
7236 length
= ffecom_char_enhance_arg_ (&type
, fn
);
7238 length
= NULL_TREE
; /* Not ref'd if !charfunc. */
7240 type
= build_pointer_type (type
);
7241 result
= build_decl (PARM_DECL
, result
, type
);
7243 push_parm_decl (result
);
7245 ffecom_multi_retval_
= result
;
7247 ffecom_func_result_
= result
;
7251 push_parm_decl (length
);
7252 ffecom_func_length_
= length
;
7256 if (ffecom_primary_entry_is_proc_
)
7259 arglist
= ffecom_master_arglist_
;
7261 arglist
= ffesymbol_dummyargs (fn
);
7262 ffecom_push_dummy_decls_ (arglist
, FALSE
);
7265 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
7266 store_parm_decls (main_program
? 1 : 0);
7268 ffecom_start_compstmt ();
7269 /* Disallow temp vars at this level. */
7270 current_binding_level
->prep_state
= 2;
7272 lineno
= old_lineno
;
7273 input_filename
= old_input_filename
;
7275 /* This handles any symbols still untransformed, in case -g specified.
7276 This used to be done in ffecom_finish_progunit, but it turns out to
7277 be necessary to do it here so that statement functions are
7278 expanded before code. But don't bother for BLOCK DATA. */
7280 if (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
7281 ffesymbol_drive (ffecom_finish_symbol_transform_
);
7284 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7287 ffecom_sym_transform_(s);
7289 The ffesymbol_hook info for s is updated with appropriate backend info
7293 ffecom_sym_transform_ (ffesymbol s
)
7295 tree t
; /* Transformed thingy. */
7296 tree tlen
; /* Length if CHAR*(*). */
7297 bool addr
; /* Is t the address of the thingy? */
7298 ffeinfoBasictype bt
;
7301 int old_lineno
= lineno
;
7302 const char *old_input_filename
= input_filename
;
7304 /* Must ensure special ASSIGN variables are declared at top of outermost
7305 block, else they'll end up in the innermost block when their first
7306 ASSIGN is seen, which leaves them out of scope when they're the
7307 subject of a GOTO or I/O statement.
7309 We make this variable even if -fugly-assign. Just let it go unused,
7310 in case it turns out there are cases where we really want to use this
7311 variable anyway (e.g. ASSIGN to INTEGER*2 variable). */
7313 if (! ffecom_transform_only_dummies_
7314 && ffesymbol_assigned (s
)
7315 && ! ffesymbol_hook (s
).assign_tree
)
7316 s
= ffecom_sym_transform_assign_ (s
);
7318 if (ffesymbol_sfdummyparent (s
) == NULL
)
7320 input_filename
= ffesymbol_where_filename (s
);
7321 lineno
= ffesymbol_where_filelinenum (s
);
7325 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
7327 input_filename
= ffesymbol_where_filename (sf
);
7328 lineno
= ffesymbol_where_filelinenum (sf
);
7331 bt
= ffeinfo_basictype (ffebld_info (s
));
7332 kt
= ffeinfo_kindtype (ffebld_info (s
));
7338 switch (ffesymbol_kind (s
))
7340 case FFEINFO_kindNONE
:
7341 switch (ffesymbol_where (s
))
7343 case FFEINFO_whereDUMMY
: /* Subroutine or function. */
7344 assert (ffecom_transform_only_dummies_
);
7346 /* Before 0.4, this could be ENTITY/DUMMY, but see
7347 ffestu_sym_end_transition -- no longer true (in particular, if
7348 it could be an ENTITY, it _will_ be made one, so that
7349 possibility won't come through here). So we never make length
7350 arg for CHARACTER type. */
7352 t
= build_decl (PARM_DECL
,
7353 ffecom_get_identifier_ (ffesymbol_text (s
)),
7354 ffecom_tree_ptr_to_subr_type
);
7355 DECL_ARTIFICIAL (t
) = 1;
7359 case FFEINFO_whereGLOBAL
: /* Subroutine or function. */
7360 assert (!ffecom_transform_only_dummies_
);
7362 if (((g
= ffesymbol_global (s
)) != NULL
)
7363 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
7364 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7365 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
7366 && (ffeglobal_hook (g
) != NULL_TREE
)
7367 && ffe_is_globals ())
7369 t
= ffeglobal_hook (g
);
7373 t
= build_decl (FUNCTION_DECL
,
7374 ffecom_get_external_identifier_ (s
),
7375 ffecom_tree_subr_type
); /* Assume subr. */
7376 DECL_EXTERNAL (t
) = 1;
7377 TREE_PUBLIC (t
) = 1;
7379 t
= start_decl (t
, FALSE
);
7380 finish_decl (t
, NULL_TREE
, FALSE
);
7383 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
7384 || (ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7385 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
7386 ffeglobal_set_hook (g
, t
);
7388 ffecom_save_tree_forever (t
);
7393 assert ("NONE where unexpected" == NULL
);
7395 case FFEINFO_whereANY
:
7400 case FFEINFO_kindENTITY
:
7401 switch (ffeinfo_where (ffesymbol_info (s
)))
7404 case FFEINFO_whereCONSTANT
:
7405 /* ~~Debugging info needed? */
7406 assert (!ffecom_transform_only_dummies_
);
7407 t
= error_mark_node
; /* Shouldn't ever see this in expr. */
7410 case FFEINFO_whereLOCAL
:
7411 assert (!ffecom_transform_only_dummies_
);
7414 ffestorag st
= ffesymbol_storage (s
);
7418 && (ffestorag_size (st
) == 0))
7420 t
= error_mark_node
;
7424 type
= ffecom_type_localvar_ (s
, bt
, kt
);
7426 if (type
== error_mark_node
)
7428 t
= error_mark_node
;
7433 && (ffestorag_parent (st
) != NULL
))
7434 { /* Child of EQUIVALENCE parent. */
7437 ffetargetOffset offset
;
7439 est
= ffestorag_parent (st
);
7440 ffecom_transform_equiv_ (est
);
7442 et
= ffestorag_hook (est
);
7443 assert (et
!= NULL_TREE
);
7445 if (! TREE_STATIC (et
))
7446 put_var_into_stack (et
);
7448 offset
= ffestorag_modulo (est
)
7449 + ffestorag_offset (ffesymbol_storage (s
))
7450 - ffestorag_offset (est
);
7452 ffecom_debug_kludge_ (et
, "EQUIVALENCE", s
, type
, offset
);
7454 /* (t_type *) (((char *) &et) + offset) */
7456 t
= convert (string_type_node
, /* (char *) */
7457 ffecom_1 (ADDR_EXPR
,
7458 build_pointer_type (TREE_TYPE (et
)),
7460 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
7462 build_int_2 (offset
, 0));
7463 t
= convert (build_pointer_type (type
),
7465 TREE_CONSTANT (t
) = staticp (et
);
7472 bool init
= ffesymbol_is_init (s
);
7474 t
= build_decl (VAR_DECL
,
7475 ffecom_get_identifier_ (ffesymbol_text (s
)),
7479 || ffesymbol_namelisted (s
)
7480 #ifdef FFECOM_sizeMAXSTACKITEM
7482 && (ffestorag_size (st
) > FFECOM_sizeMAXSTACKITEM
))
7484 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
7485 && (ffecom_primary_entry_kind_
7486 != FFEINFO_kindBLOCKDATA
)
7487 && (ffesymbol_is_save (s
) || ffe_is_saveall ())))
7488 TREE_STATIC (t
) = !ffesymbol_attr (s
, FFESYMBOL_attrADJUSTABLE
);
7490 TREE_STATIC (t
) = 0; /* No need to make static. */
7492 if (init
|| ffe_is_init_local_zero ())
7493 DECL_INITIAL (t
) = error_mark_node
;
7495 /* Keep -Wunused from complaining about var if it
7496 is used as sfunc arg or DATA implied-DO. */
7497 if (ffesymbol_attrs (s
) & FFESYMBOL_attrsSFARG
)
7498 DECL_IN_SYSTEM_HEADER (t
) = 1;
7500 t
= start_decl (t
, FALSE
);
7504 if (ffesymbol_init (s
) != NULL
)
7505 initexpr
= ffecom_expr (ffesymbol_init (s
));
7507 initexpr
= ffecom_init_zero_ (t
);
7509 else if (ffe_is_init_local_zero ())
7510 initexpr
= ffecom_init_zero_ (t
);
7512 initexpr
= NULL_TREE
; /* Not ref'd if !init. */
7514 finish_decl (t
, initexpr
, FALSE
);
7516 if (st
!= NULL
&& DECL_SIZE (t
) != error_mark_node
)
7518 assert (TREE_CODE (DECL_SIZE_UNIT (t
)) == INTEGER_CST
);
7519 assert (0 == compare_tree_int (DECL_SIZE_UNIT (t
),
7520 ffestorag_size (st
)));
7526 case FFEINFO_whereRESULT
:
7527 assert (!ffecom_transform_only_dummies_
);
7529 if (bt
== FFEINFO_basictypeCHARACTER
)
7530 { /* Result is already in list of dummies, use
7532 t
= ffecom_func_result_
;
7533 tlen
= ffecom_func_length_
;
7537 if ((ffecom_num_entrypoints_
== 0)
7538 && (bt
== FFEINFO_basictypeCOMPLEX
)
7539 && (ffesymbol_is_f2c (ffecom_primary_entry_
)))
7540 { /* Result is already in list of dummies, use
7542 t
= ffecom_func_result_
;
7546 if (ffecom_func_result_
!= NULL_TREE
)
7548 t
= ffecom_func_result_
;
7551 if ((ffecom_num_entrypoints_
!= 0)
7552 && (ffecom_master_bt_
== FFEINFO_basictypeNONE
))
7554 assert (ffecom_multi_retval_
!= NULL_TREE
);
7555 t
= ffecom_1 (INDIRECT_REF
, ffecom_multi_type_node_
,
7556 ffecom_multi_retval_
);
7557 t
= ffecom_2 (COMPONENT_REF
, ffecom_tree_type
[bt
][kt
],
7558 t
, ffecom_multi_fields_
[bt
][kt
]);
7563 t
= build_decl (VAR_DECL
,
7564 ffecom_get_identifier_ (ffesymbol_text (s
)),
7565 ffecom_tree_type
[bt
][kt
]);
7566 TREE_STATIC (t
) = 0; /* Put result on stack. */
7567 t
= start_decl (t
, FALSE
);
7568 finish_decl (t
, NULL_TREE
, FALSE
);
7570 ffecom_func_result_
= t
;
7574 case FFEINFO_whereDUMMY
:
7582 bool adjustable
= FALSE
; /* Conditionally adjustable? */
7584 type
= ffecom_tree_type
[bt
][kt
];
7585 if (ffesymbol_sfdummyparent (s
) != NULL
)
7587 if (current_function_decl
== ffecom_outer_function_decl_
)
7588 { /* Exec transition before sfunc
7589 context; get it later. */
7592 t
= ffecom_get_identifier_ (ffesymbol_text
7593 (ffesymbol_sfdummyparent (s
)));
7596 t
= ffecom_get_identifier_ (ffesymbol_text (s
));
7598 assert (ffecom_transform_only_dummies_
);
7600 old_sizes
= get_pending_sizes ();
7601 put_pending_sizes (old_sizes
);
7603 if (bt
== FFEINFO_basictypeCHARACTER
)
7604 tlen
= ffecom_char_enhance_arg_ (&type
, s
);
7605 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
7607 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
7609 if (type
== error_mark_node
)
7612 dim
= ffebld_head (dl
);
7613 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
7614 if ((ffebld_left (dim
) == NULL
) || ffecom_doing_entry_
)
7615 low
= ffecom_integer_one_node
;
7617 low
= ffecom_expr (ffebld_left (dim
));
7618 assert (ffebld_right (dim
) != NULL
);
7619 if ((ffebld_op (ffebld_right (dim
)) == FFEBLD_opSTAR
)
7620 || ffecom_doing_entry_
)
7622 /* Used to just do high=low. But for ffecom_tree_
7623 canonize_ref_, it probably is important to correctly
7624 assess the size. E.g. given COMPLEX C(*),CFUNC and
7625 C(2)=CFUNC(C), overlap can happen, while it can't
7626 for, say, C(1)=CFUNC(C(2)). */
7627 /* Even more recently used to set to INT_MAX, but that
7628 broke when some overflow checking went into the back
7629 end. Now we just leave the upper bound unspecified. */
7633 high
= ffecom_expr (ffebld_right (dim
));
7635 /* Determine whether array is conditionally adjustable,
7636 to decide whether back-end magic is needed.
7638 Normally the front end uses the back-end function
7639 variable_size to wrap SAVE_EXPR's around expressions
7640 affecting the size/shape of an array so that the
7641 size/shape info doesn't change during execution
7642 of the compiled code even though variables and
7643 functions referenced in those expressions might.
7645 variable_size also makes sure those saved expressions
7646 get evaluated immediately upon entry to the
7647 compiled procedure -- the front end normally doesn't
7648 have to worry about that.
7650 However, there is a problem with this that affects
7651 g77's implementation of entry points, and that is
7652 that it is _not_ true that each invocation of the
7653 compiled procedure is permitted to evaluate
7654 array size/shape info -- because it is possible
7655 that, for some invocations, that info is invalid (in
7656 which case it is "promised" -- i.e. a violation of
7657 the Fortran standard -- that the compiled code
7658 won't reference the array or its size/shape
7659 during that particular invocation).
7661 To phrase this in C terms, consider this gcc function:
7663 void foo (int *n, float (*a)[*n])
7665 // a is "pointer to array ...", fyi.
7668 Suppose that, for some invocations, it is permitted
7669 for a caller of foo to do this:
7673 Now the _written_ code for foo can take such a call
7674 into account by either testing explicitly for whether
7675 (a == NULL) || (n == NULL) -- presumably it is
7676 not permitted to reference *a in various fashions
7677 if (n == NULL) I suppose -- or it can avoid it by
7678 looking at other info (other arguments, static/global
7681 However, this won't work in gcc 2.5.8 because it'll
7682 automatically emit the code to save the "*n"
7683 expression, which'll yield a NULL dereference for
7684 the "foo (NULL, NULL)" call, something the code
7685 for foo cannot prevent.
7687 g77 definitely needs to avoid executing such
7688 code anytime the pointer to the adjustable array
7689 is NULL, because even if its bounds expressions
7690 don't have any references to possible "absent"
7691 variables like "*n" -- say all variable references
7692 are to COMMON variables, i.e. global (though in C,
7693 local static could actually make sense) -- the
7694 expressions could yield other run-time problems
7695 for allowably "dead" values in those variables.
7697 For example, let's consider a more complicated
7703 void foo (float (*a)[i/j])
7708 The above is (essentially) quite valid for Fortran
7709 but, again, for a call like "foo (NULL);", it is
7710 permitted for i and j to be undefined when the
7711 call is made. If j happened to be zero, for
7712 example, emitting the code to evaluate "i/j"
7713 could result in a run-time error.
7715 Offhand, though I don't have my F77 or F90
7716 standards handy, it might even be valid for a
7717 bounds expression to contain a function reference,
7718 in which case I doubt it is permitted for an
7719 implementation to invoke that function in the
7720 Fortran case involved here (invocation of an
7721 alternate ENTRY point that doesn't have the adjustable
7722 array as one of its arguments).
7724 So, the code that the compiler would normally emit
7725 to preevaluate the size/shape info for an
7726 adjustable array _must not_ be executed at run time
7727 in certain cases. Specifically, for Fortran,
7728 the case is when the pointer to the adjustable
7729 array == NULL. (For gnu-ish C, it might be nice
7730 for the source code itself to specify an expression
7731 that, if TRUE, inhibits execution of the code. Or
7732 reverse the sense for elegance.)
7734 (Note that g77 could use a different test than NULL,
7735 actually, since it happens to always pass an
7736 integer to the called function that specifies which
7737 entry point is being invoked. Hmm, this might
7738 solve the next problem.)
7740 One way a user could, I suppose, write "foo" so
7741 it works is to insert COND_EXPR's for the
7742 size/shape info so the dangerous stuff isn't
7743 actually done, as in:
7745 void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7750 The next problem is that the front end needs to
7751 be able to tell the back end about the array's
7752 decl _before_ it tells it about the conditional
7753 expression to inhibit evaluation of size/shape info,
7756 To solve this, the front end needs to be able
7757 to give the back end the expression to inhibit
7758 generation of the preevaluation code _after_
7759 it makes the decl for the adjustable array.
7761 Until then, the above example using the COND_EXPR
7762 doesn't pass muster with gcc because the "(a == NULL)"
7763 part has a reference to "a", which is still
7764 undefined at that point.
7766 g77 will therefore use a different mechanism in the
7770 && ((TREE_CODE (low
) != INTEGER_CST
)
7771 || (high
&& TREE_CODE (high
) != INTEGER_CST
)))
7774 #if 0 /* Old approach -- see below. */
7775 if (TREE_CODE (low
) != INTEGER_CST
)
7776 low
= ffecom_3 (COND_EXPR
, integer_type_node
,
7777 ffecom_adjarray_passed_ (s
),
7779 ffecom_integer_zero_node
);
7781 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
7782 high
= ffecom_3 (COND_EXPR
, integer_type_node
,
7783 ffecom_adjarray_passed_ (s
),
7785 ffecom_integer_zero_node
);
7788 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7789 probably. Fixes 950302-1.f. */
7791 if (TREE_CODE (low
) != INTEGER_CST
)
7792 low
= variable_size (low
);
7794 /* ~~~Similarly, this fixes dumb0.f. The C front end
7795 does this, which is why dumb0.c would work. */
7797 if (high
&& TREE_CODE (high
) != INTEGER_CST
)
7798 high
= variable_size (high
);
7803 build_range_type (ffecom_integer_type_node
,
7805 type
= ffecom_check_size_overflow_ (s
, type
, TRUE
);
7808 if (type
== error_mark_node
)
7810 t
= error_mark_node
;
7814 if ((ffesymbol_sfdummyparent (s
) == NULL
)
7815 || (ffesymbol_basictype (s
) == FFEINFO_basictypeCHARACTER
))
7817 type
= build_pointer_type (type
);
7821 t
= build_decl (PARM_DECL
, t
, type
);
7822 DECL_ARTIFICIAL (t
) = 1;
7824 /* If this arg is present in every entry point's list of
7825 dummy args, then we're done. */
7827 if (ffesymbol_numentries (s
)
7828 == (ffecom_num_entrypoints_
+ 1))
7833 /* If variable_size in stor-layout has been called during
7834 the above, then get_pending_sizes should have the
7835 yet-to-be-evaluated saved expressions pending.
7836 Make the whole lot of them get emitted, conditionally
7837 on whether the array decl ("t" above) is not NULL. */
7840 tree sizes
= get_pending_sizes ();
7845 tem
= TREE_CHAIN (tem
))
7847 tree temv
= TREE_VALUE (tem
);
7853 = ffecom_2 (COMPOUND_EXPR
,
7862 = ffecom_3 (COND_EXPR
,
7869 convert (TREE_TYPE (sizes
),
7870 integer_zero_node
));
7871 sizes
= ffecom_save_tree (sizes
);
7874 = tree_cons (NULL_TREE
, sizes
, tem
);
7878 put_pending_sizes (sizes
);
7884 && (ffesymbol_numentries (s
)
7885 != ffecom_num_entrypoints_
+ 1))
7887 = ffecom_2 (NE_EXPR
, integer_type_node
,
7893 && (ffesymbol_numentries (s
)
7894 != ffecom_num_entrypoints_
+ 1))
7896 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED
);
7897 ffebad_here (0, ffesymbol_where_line (s
),
7898 ffesymbol_where_column (s
));
7899 ffebad_string (ffesymbol_text (s
));
7908 case FFEINFO_whereCOMMON
:
7913 ffestorag st
= ffesymbol_storage (s
);
7916 cs
= ffesymbol_common (s
); /* The COMMON area itself. */
7917 if (st
!= NULL
) /* Else not laid out. */
7919 ffecom_transform_common_ (cs
);
7920 st
= ffesymbol_storage (s
);
7923 type
= ffecom_type_localvar_ (s
, bt
, kt
);
7925 cg
= ffesymbol_global (cs
); /* The global COMMON info. */
7927 || (ffeglobal_type (cg
) != FFEGLOBAL_typeCOMMON
))
7930 ct
= ffeglobal_hook (cg
); /* The common area's tree. */
7932 if ((ct
== NULL_TREE
)
7934 || (type
== error_mark_node
))
7935 t
= error_mark_node
;
7938 ffetargetOffset offset
;
7941 cst
= ffestorag_parent (st
);
7942 assert (cst
== ffesymbol_storage (cs
));
7944 offset
= ffestorag_modulo (cst
)
7945 + ffestorag_offset (st
)
7946 - ffestorag_offset (cst
);
7948 ffecom_debug_kludge_ (ct
, "COMMON", s
, type
, offset
);
7950 /* (t_type *) (((char *) &ct) + offset) */
7952 t
= convert (string_type_node
, /* (char *) */
7953 ffecom_1 (ADDR_EXPR
,
7954 build_pointer_type (TREE_TYPE (ct
)),
7956 t
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (t
),
7958 build_int_2 (offset
, 0));
7959 t
= convert (build_pointer_type (type
),
7961 TREE_CONSTANT (t
) = 1;
7968 case FFEINFO_whereIMMEDIATE
:
7969 case FFEINFO_whereGLOBAL
:
7970 case FFEINFO_whereFLEETING
:
7971 case FFEINFO_whereFLEETING_CADDR
:
7972 case FFEINFO_whereFLEETING_IADDR
:
7973 case FFEINFO_whereINTRINSIC
:
7974 case FFEINFO_whereCONSTANT_SUBOBJECT
:
7976 assert ("ENTITY where unheard of" == NULL
);
7978 case FFEINFO_whereANY
:
7979 t
= error_mark_node
;
7984 case FFEINFO_kindFUNCTION
:
7985 switch (ffeinfo_where (ffesymbol_info (s
)))
7987 case FFEINFO_whereLOCAL
: /* Me. */
7988 assert (!ffecom_transform_only_dummies_
);
7989 t
= current_function_decl
;
7992 case FFEINFO_whereGLOBAL
:
7993 assert (!ffecom_transform_only_dummies_
);
7995 if (((g
= ffesymbol_global (s
)) != NULL
)
7996 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
7997 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
7998 && (ffeglobal_hook (g
) != NULL_TREE
)
7999 && ffe_is_globals ())
8001 t
= ffeglobal_hook (g
);
8005 if (ffesymbol_is_f2c (s
)
8006 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8007 t
= ffecom_tree_fun_type
[bt
][kt
];
8009 t
= build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
);
8011 t
= build_decl (FUNCTION_DECL
,
8012 ffecom_get_external_identifier_ (s
),
8014 DECL_EXTERNAL (t
) = 1;
8015 TREE_PUBLIC (t
) = 1;
8017 t
= start_decl (t
, FALSE
);
8018 finish_decl (t
, NULL_TREE
, FALSE
);
8021 && ((ffeglobal_type (g
) == FFEGLOBAL_typeFUNC
)
8022 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8023 ffeglobal_set_hook (g
, t
);
8025 ffecom_save_tree_forever (t
);
8029 case FFEINFO_whereDUMMY
:
8030 assert (ffecom_transform_only_dummies_
);
8032 if (ffesymbol_is_f2c (s
)
8033 && (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
))
8034 t
= ffecom_tree_ptr_to_fun_type
[bt
][kt
];
8036 t
= build_pointer_type
8037 (build_function_type (ffecom_tree_type
[bt
][kt
], NULL_TREE
));
8039 t
= build_decl (PARM_DECL
,
8040 ffecom_get_identifier_ (ffesymbol_text (s
)),
8042 DECL_ARTIFICIAL (t
) = 1;
8046 case FFEINFO_whereCONSTANT
: /* Statement function. */
8047 assert (!ffecom_transform_only_dummies_
);
8048 t
= ffecom_gen_sfuncdef_ (s
, bt
, kt
);
8051 case FFEINFO_whereINTRINSIC
:
8052 assert (!ffecom_transform_only_dummies_
);
8053 break; /* Let actual references generate their
8057 assert ("FUNCTION where unheard of" == NULL
);
8059 case FFEINFO_whereANY
:
8060 t
= error_mark_node
;
8065 case FFEINFO_kindSUBROUTINE
:
8066 switch (ffeinfo_where (ffesymbol_info (s
)))
8068 case FFEINFO_whereLOCAL
: /* Me. */
8069 assert (!ffecom_transform_only_dummies_
);
8070 t
= current_function_decl
;
8073 case FFEINFO_whereGLOBAL
:
8074 assert (!ffecom_transform_only_dummies_
);
8076 if (((g
= ffesymbol_global (s
)) != NULL
)
8077 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8078 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
))
8079 && (ffeglobal_hook (g
) != NULL_TREE
)
8080 && ffe_is_globals ())
8082 t
= ffeglobal_hook (g
);
8086 t
= build_decl (FUNCTION_DECL
,
8087 ffecom_get_external_identifier_ (s
),
8088 ffecom_tree_subr_type
);
8089 DECL_EXTERNAL (t
) = 1;
8090 TREE_PUBLIC (t
) = 1;
8092 t
= start_decl (t
, FALSE
);
8093 finish_decl (t
, NULL_TREE
, FALSE
);
8096 && ((ffeglobal_type (g
) == FFEGLOBAL_typeSUBR
)
8097 || (ffeglobal_type (g
) == FFEGLOBAL_typeEXT
)))
8098 ffeglobal_set_hook (g
, t
);
8100 ffecom_save_tree_forever (t
);
8104 case FFEINFO_whereDUMMY
:
8105 assert (ffecom_transform_only_dummies_
);
8107 t
= build_decl (PARM_DECL
,
8108 ffecom_get_identifier_ (ffesymbol_text (s
)),
8109 ffecom_tree_ptr_to_subr_type
);
8110 DECL_ARTIFICIAL (t
) = 1;
8114 case FFEINFO_whereINTRINSIC
:
8115 assert (!ffecom_transform_only_dummies_
);
8116 break; /* Let actual references generate their
8120 assert ("SUBROUTINE where unheard of" == NULL
);
8122 case FFEINFO_whereANY
:
8123 t
= error_mark_node
;
8128 case FFEINFO_kindPROGRAM
:
8129 switch (ffeinfo_where (ffesymbol_info (s
)))
8131 case FFEINFO_whereLOCAL
: /* Me. */
8132 assert (!ffecom_transform_only_dummies_
);
8133 t
= current_function_decl
;
8136 case FFEINFO_whereCOMMON
:
8137 case FFEINFO_whereDUMMY
:
8138 case FFEINFO_whereGLOBAL
:
8139 case FFEINFO_whereRESULT
:
8140 case FFEINFO_whereFLEETING
:
8141 case FFEINFO_whereFLEETING_CADDR
:
8142 case FFEINFO_whereFLEETING_IADDR
:
8143 case FFEINFO_whereIMMEDIATE
:
8144 case FFEINFO_whereINTRINSIC
:
8145 case FFEINFO_whereCONSTANT
:
8146 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8148 assert ("PROGRAM where unheard of" == NULL
);
8150 case FFEINFO_whereANY
:
8151 t
= error_mark_node
;
8156 case FFEINFO_kindBLOCKDATA
:
8157 switch (ffeinfo_where (ffesymbol_info (s
)))
8159 case FFEINFO_whereLOCAL
: /* Me. */
8160 assert (!ffecom_transform_only_dummies_
);
8161 t
= current_function_decl
;
8164 case FFEINFO_whereGLOBAL
:
8165 assert (!ffecom_transform_only_dummies_
);
8167 t
= build_decl (FUNCTION_DECL
,
8168 ffecom_get_external_identifier_ (s
),
8169 ffecom_tree_blockdata_type
);
8170 DECL_EXTERNAL (t
) = 1;
8171 TREE_PUBLIC (t
) = 1;
8173 t
= start_decl (t
, FALSE
);
8174 finish_decl (t
, NULL_TREE
, FALSE
);
8176 ffecom_save_tree_forever (t
);
8180 case FFEINFO_whereCOMMON
:
8181 case FFEINFO_whereDUMMY
:
8182 case FFEINFO_whereRESULT
:
8183 case FFEINFO_whereFLEETING
:
8184 case FFEINFO_whereFLEETING_CADDR
:
8185 case FFEINFO_whereFLEETING_IADDR
:
8186 case FFEINFO_whereIMMEDIATE
:
8187 case FFEINFO_whereINTRINSIC
:
8188 case FFEINFO_whereCONSTANT
:
8189 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8191 assert ("BLOCKDATA where unheard of" == NULL
);
8193 case FFEINFO_whereANY
:
8194 t
= error_mark_node
;
8199 case FFEINFO_kindCOMMON
:
8200 switch (ffeinfo_where (ffesymbol_info (s
)))
8202 case FFEINFO_whereLOCAL
:
8203 assert (!ffecom_transform_only_dummies_
);
8204 ffecom_transform_common_ (s
);
8207 case FFEINFO_whereNONE
:
8208 case FFEINFO_whereCOMMON
:
8209 case FFEINFO_whereDUMMY
:
8210 case FFEINFO_whereGLOBAL
:
8211 case FFEINFO_whereRESULT
:
8212 case FFEINFO_whereFLEETING
:
8213 case FFEINFO_whereFLEETING_CADDR
:
8214 case FFEINFO_whereFLEETING_IADDR
:
8215 case FFEINFO_whereIMMEDIATE
:
8216 case FFEINFO_whereINTRINSIC
:
8217 case FFEINFO_whereCONSTANT
:
8218 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8220 assert ("COMMON where unheard of" == NULL
);
8222 case FFEINFO_whereANY
:
8223 t
= error_mark_node
;
8228 case FFEINFO_kindCONSTRUCT
:
8229 switch (ffeinfo_where (ffesymbol_info (s
)))
8231 case FFEINFO_whereLOCAL
:
8232 assert (!ffecom_transform_only_dummies_
);
8235 case FFEINFO_whereNONE
:
8236 case FFEINFO_whereCOMMON
:
8237 case FFEINFO_whereDUMMY
:
8238 case FFEINFO_whereGLOBAL
:
8239 case FFEINFO_whereRESULT
:
8240 case FFEINFO_whereFLEETING
:
8241 case FFEINFO_whereFLEETING_CADDR
:
8242 case FFEINFO_whereFLEETING_IADDR
:
8243 case FFEINFO_whereIMMEDIATE
:
8244 case FFEINFO_whereINTRINSIC
:
8245 case FFEINFO_whereCONSTANT
:
8246 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8248 assert ("CONSTRUCT where unheard of" == NULL
);
8250 case FFEINFO_whereANY
:
8251 t
= error_mark_node
;
8256 case FFEINFO_kindNAMELIST
:
8257 switch (ffeinfo_where (ffesymbol_info (s
)))
8259 case FFEINFO_whereLOCAL
:
8260 assert (!ffecom_transform_only_dummies_
);
8261 t
= ffecom_transform_namelist_ (s
);
8264 case FFEINFO_whereNONE
:
8265 case FFEINFO_whereCOMMON
:
8266 case FFEINFO_whereDUMMY
:
8267 case FFEINFO_whereGLOBAL
:
8268 case FFEINFO_whereRESULT
:
8269 case FFEINFO_whereFLEETING
:
8270 case FFEINFO_whereFLEETING_CADDR
:
8271 case FFEINFO_whereFLEETING_IADDR
:
8272 case FFEINFO_whereIMMEDIATE
:
8273 case FFEINFO_whereINTRINSIC
:
8274 case FFEINFO_whereCONSTANT
:
8275 case FFEINFO_whereCONSTANT_SUBOBJECT
:
8277 assert ("NAMELIST where unheard of" == NULL
);
8279 case FFEINFO_whereANY
:
8280 t
= error_mark_node
;
8286 assert ("kind unheard of" == NULL
);
8288 case FFEINFO_kindANY
:
8289 t
= error_mark_node
;
8293 ffesymbol_hook (s
).decl_tree
= t
;
8294 ffesymbol_hook (s
).length_tree
= tlen
;
8295 ffesymbol_hook (s
).addr
= addr
;
8297 lineno
= old_lineno
;
8298 input_filename
= old_input_filename
;
8303 /* Transform into ASSIGNable symbol.
8305 Symbol has already been transformed, but for whatever reason, the
8306 resulting decl_tree has been deemed not usable for an ASSIGN target.
8307 (E.g. it isn't wide enough to hold a pointer.) So, here we invent
8308 another local symbol of type void * and stuff that in the assign_tree
8309 argument. The F77/F90 standards allow this implementation. */
8312 ffecom_sym_transform_assign_ (ffesymbol s
)
8314 tree t
; /* Transformed thingy. */
8315 int old_lineno
= lineno
;
8316 const char *old_input_filename
= input_filename
;
8318 if (ffesymbol_sfdummyparent (s
) == NULL
)
8320 input_filename
= ffesymbol_where_filename (s
);
8321 lineno
= ffesymbol_where_filelinenum (s
);
8325 ffesymbol sf
= ffesymbol_sfdummyparent (s
);
8327 input_filename
= ffesymbol_where_filename (sf
);
8328 lineno
= ffesymbol_where_filelinenum (sf
);
8331 assert (!ffecom_transform_only_dummies_
);
8333 t
= build_decl (VAR_DECL
,
8334 ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8335 ffesymbol_text (s
)),
8336 TREE_TYPE (null_pointer_node
));
8338 switch (ffesymbol_where (s
))
8340 case FFEINFO_whereLOCAL
:
8341 /* Unlike for regular vars, SAVE status is easy to determine for
8342 ASSIGNed vars, since there's no initialization, there's no
8343 effective storage association (so "SAVE J" does not apply to
8344 K even given "EQUIVALENCE (J,K)"), there's no size issue
8345 to worry about, etc. */
8346 if ((ffesymbol_is_save (s
) || ffe_is_saveall ())
8347 && (ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8348 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
))
8349 TREE_STATIC (t
) = 1; /* SAVEd in proc, make static. */
8351 TREE_STATIC (t
) = 0; /* No need to make static. */
8354 case FFEINFO_whereCOMMON
:
8355 TREE_STATIC (t
) = 1; /* Assume COMMONs always SAVEd. */
8358 case FFEINFO_whereDUMMY
:
8359 /* Note that twinning a DUMMY means the caller won't see
8360 the ASSIGNed value. But both F77 and F90 allow implementations
8361 to do this, i.e. disallow Fortran code that would try and
8362 take advantage of actually putting a label into a variable
8363 via a dummy argument (or any other storage association, for
8365 TREE_STATIC (t
) = 0;
8369 TREE_STATIC (t
) = 0;
8373 t
= start_decl (t
, FALSE
);
8374 finish_decl (t
, NULL_TREE
, FALSE
);
8376 ffesymbol_hook (s
).assign_tree
= t
;
8378 lineno
= old_lineno
;
8379 input_filename
= old_input_filename
;
8384 /* Implement COMMON area in back end.
8386 Because COMMON-based variables can be referenced in the dimension
8387 expressions of dummy (adjustable) arrays, and because dummies
8388 (in the gcc back end) need to be put in the outer binding level
8389 of a function (which has two binding levels, the outer holding
8390 the dummies and the inner holding the other vars), special care
8391 must be taken to handle COMMON areas.
8393 The current strategy is basically to always tell the back end about
8394 the COMMON area as a top-level external reference to just a block
8395 of storage of the master type of that area (e.g. integer, real,
8396 character, whatever -- not a structure). As a distinct action,
8397 if initial values are provided, tell the back end about the area
8398 as a top-level non-external (initialized) area and remember not to
8399 allow further initialization or expansion of the area. Meanwhile,
8400 if no initialization happens at all, tell the back end about
8401 the largest size we've seen declared so the space does get reserved.
8402 (This function doesn't handle all that stuff, but it does some
8403 of the important things.)
8405 Meanwhile, for COMMON variables themselves, just keep creating
8406 references like *((float *) (&common_area + offset)) each time
8407 we reference the variable. In other words, don't make a VAR_DECL
8408 or any kind of component reference (like we used to do before 0.4),
8409 though we might do that as well just for debugging purposes (and
8410 stuff the rtl with the appropriate offset expression). */
8413 ffecom_transform_common_ (ffesymbol s
)
8415 ffestorag st
= ffesymbol_storage (s
);
8416 ffeglobal g
= ffesymbol_global (s
);
8421 bool is_init
= ffestorag_is_init (st
);
8423 assert (st
!= NULL
);
8426 || (ffeglobal_type (g
) != FFEGLOBAL_typeCOMMON
))
8429 /* First update the size of the area in global terms. */
8431 ffeglobal_size_common (s
, ffestorag_size (st
));
8433 if (!ffeglobal_common_init (g
))
8434 is_init
= FALSE
; /* No explicit init, don't let erroneous joins init. */
8436 cbt
= ffeglobal_hook (g
);
8438 /* If we already have declared this common block for a previous program
8439 unit, and either we already initialized it or we don't have new
8440 initialization for it, just return what we have without changing it. */
8442 if ((cbt
!= NULL_TREE
)
8444 || !DECL_EXTERNAL (cbt
)))
8446 if (st
->hook
== NULL
) ffestorag_set_hook (st
, cbt
);
8450 /* Process inits. */
8454 if (ffestorag_init (st
) != NULL
)
8458 /* Set the padding for the expression, so ffecom_expr
8459 knows to insert that many zeros. */
8460 switch (ffebld_op (sexp
= ffestorag_init (st
)))
8462 case FFEBLD_opCONTER
:
8463 ffebld_conter_set_pad (sexp
, ffestorag_modulo (st
));
8466 case FFEBLD_opARRTER
:
8467 ffebld_arrter_set_pad (sexp
, ffestorag_modulo (st
));
8470 case FFEBLD_opACCTER
:
8471 ffebld_accter_set_pad (sexp
, ffestorag_modulo (st
));
8475 assert ("bad op for cmn init (pad)" == NULL
);
8479 init
= ffecom_expr (sexp
);
8480 if (init
== error_mark_node
)
8481 { /* Hopefully the back end complained! */
8483 if (cbt
!= NULL_TREE
)
8488 init
= error_mark_node
;
8493 /* cbtype must be permanently allocated! */
8495 /* Allocate the MAX of the areas so far, seen filewide. */
8496 high
= build_int_2 ((ffeglobal_common_size (g
)
8497 + ffeglobal_common_pad (g
)) - 1, 0);
8498 TREE_TYPE (high
) = ffecom_integer_type_node
;
8501 cbtype
= build_array_type (char_type_node
,
8502 build_range_type (integer_type_node
,
8506 cbtype
= build_array_type (char_type_node
, NULL_TREE
);
8508 if (cbt
== NULL_TREE
)
8511 = build_decl (VAR_DECL
,
8512 ffecom_get_external_identifier_ (s
),
8514 TREE_STATIC (cbt
) = 1;
8515 TREE_PUBLIC (cbt
) = 1;
8520 TREE_TYPE (cbt
) = cbtype
;
8522 DECL_EXTERNAL (cbt
) = init
? 0 : 1;
8523 DECL_INITIAL (cbt
) = init
? error_mark_node
: NULL_TREE
;
8525 cbt
= start_decl (cbt
, TRUE
);
8526 if (ffeglobal_hook (g
) != NULL
)
8527 assert (cbt
== ffeglobal_hook (g
));
8529 assert (!init
|| !DECL_EXTERNAL (cbt
));
8531 /* Make sure that any type can live in COMMON and be referenced
8532 without getting a bus error. We could pick the most restrictive
8533 alignment of all entities actually placed in the COMMON, but
8534 this seems easy enough. */
8536 DECL_ALIGN (cbt
) = BIGGEST_ALIGNMENT
;
8537 DECL_USER_ALIGN (cbt
) = 0;
8539 if (is_init
&& (ffestorag_init (st
) == NULL
))
8540 init
= ffecom_init_zero_ (cbt
);
8542 finish_decl (cbt
, init
, TRUE
);
8545 ffestorag_set_init (st
, ffebld_new_any ());
8549 assert (DECL_SIZE_UNIT (cbt
) != NULL_TREE
);
8550 assert (TREE_CODE (DECL_SIZE_UNIT (cbt
)) == INTEGER_CST
);
8551 assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt
),
8552 (ffeglobal_common_size (g
)
8553 + ffeglobal_common_pad (g
))));
8556 ffeglobal_set_hook (g
, cbt
);
8558 ffestorag_set_hook (st
, cbt
);
8560 ffecom_save_tree_forever (cbt
);
8563 /* Make master area for local EQUIVALENCE. */
8566 ffecom_transform_equiv_ (ffestorag eqst
)
8572 bool is_init
= ffestorag_is_init (eqst
);
8574 assert (eqst
!= NULL
);
8576 eqt
= ffestorag_hook (eqst
);
8578 if (eqt
!= NULL_TREE
)
8581 /* Process inits. */
8585 if (ffestorag_init (eqst
) != NULL
)
8589 /* Set the padding for the expression, so ffecom_expr
8590 knows to insert that many zeros. */
8591 switch (ffebld_op (sexp
= ffestorag_init (eqst
)))
8593 case FFEBLD_opCONTER
:
8594 ffebld_conter_set_pad (sexp
, ffestorag_modulo (eqst
));
8597 case FFEBLD_opARRTER
:
8598 ffebld_arrter_set_pad (sexp
, ffestorag_modulo (eqst
));
8601 case FFEBLD_opACCTER
:
8602 ffebld_accter_set_pad (sexp
, ffestorag_modulo (eqst
));
8606 assert ("bad op for eqv init (pad)" == NULL
);
8610 init
= ffecom_expr (sexp
);
8611 if (init
== error_mark_node
)
8612 init
= NULL_TREE
; /* Hopefully the back end complained! */
8615 init
= error_mark_node
;
8617 else if (ffe_is_init_local_zero ())
8618 init
= error_mark_node
;
8622 ffecom_member_namelisted_
= FALSE
;
8623 ffestorag_drive (ffestorag_list_equivs (eqst
),
8624 &ffecom_member_phase1_
,
8627 high
= build_int_2 ((ffestorag_size (eqst
)
8628 + ffestorag_modulo (eqst
)) - 1, 0);
8629 TREE_TYPE (high
) = ffecom_integer_type_node
;
8631 eqtype
= build_array_type (char_type_node
,
8632 build_range_type (ffecom_integer_type_node
,
8633 ffecom_integer_zero_node
,
8636 eqt
= build_decl (VAR_DECL
,
8637 ffecom_get_invented_identifier ("__g77_equiv_%s",
8639 (ffestorag_symbol (eqst
))),
8641 DECL_EXTERNAL (eqt
) = 0;
8643 || ffecom_member_namelisted_
8644 #ifdef FFECOM_sizeMAXSTACKITEM
8645 || (ffestorag_size (eqst
) > FFECOM_sizeMAXSTACKITEM
)
8647 || ((ffecom_primary_entry_kind_
!= FFEINFO_kindPROGRAM
)
8648 && (ffecom_primary_entry_kind_
!= FFEINFO_kindBLOCKDATA
)
8649 && (ffestorag_is_save (eqst
) || ffe_is_saveall ())))
8650 TREE_STATIC (eqt
) = 1;
8652 TREE_STATIC (eqt
) = 0;
8653 TREE_PUBLIC (eqt
) = 0;
8654 TREE_ADDRESSABLE (eqt
) = 1; /* Ensure non-register allocation */
8655 DECL_CONTEXT (eqt
) = current_function_decl
;
8657 DECL_INITIAL (eqt
) = error_mark_node
;
8659 DECL_INITIAL (eqt
) = NULL_TREE
;
8661 eqt
= start_decl (eqt
, FALSE
);
8663 /* Make sure that any type can live in EQUIVALENCE and be referenced
8664 without getting a bus error. We could pick the most restrictive
8665 alignment of all entities actually placed in the EQUIVALENCE, but
8666 this seems easy enough. */
8668 DECL_ALIGN (eqt
) = BIGGEST_ALIGNMENT
;
8669 DECL_USER_ALIGN (eqt
) = 0;
8671 if ((!is_init
&& ffe_is_init_local_zero ())
8672 || (is_init
&& (ffestorag_init (eqst
) == NULL
)))
8673 init
= ffecom_init_zero_ (eqt
);
8675 finish_decl (eqt
, init
, FALSE
);
8678 ffestorag_set_init (eqst
, ffebld_new_any ());
8681 assert (TREE_CODE (DECL_SIZE_UNIT (eqt
)) == INTEGER_CST
);
8682 assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt
),
8683 (ffestorag_size (eqst
)
8684 + ffestorag_modulo (eqst
))));
8687 ffestorag_set_hook (eqst
, eqt
);
8689 ffestorag_drive (ffestorag_list_equivs (eqst
),
8690 &ffecom_member_phase2_
,
8694 /* Implement NAMELIST in back end. See f2c/format.c for more info. */
8697 ffecom_transform_namelist_ (ffesymbol s
)
8700 tree nmltype
= ffecom_type_namelist_ ();
8708 static int mynumber
= 0;
8710 nmlt
= build_decl (VAR_DECL
,
8711 ffecom_get_invented_identifier ("__g77_namelist_%d",
8714 TREE_STATIC (nmlt
) = 1;
8715 DECL_INITIAL (nmlt
) = error_mark_node
;
8717 nmlt
= start_decl (nmlt
, FALSE
);
8719 /* Process inits. */
8721 i
= strlen (ffesymbol_text (s
));
8723 high
= build_int_2 (i
, 0);
8724 TREE_TYPE (high
) = ffecom_f2c_ftnlen_type_node
;
8726 nameinit
= ffecom_build_f2c_string_ (i
+ 1,
8727 ffesymbol_text (s
));
8728 TREE_TYPE (nameinit
)
8729 = build_type_variant
8732 build_range_type (ffecom_f2c_ftnlen_type_node
,
8733 ffecom_f2c_ftnlen_one_node
,
8736 TREE_CONSTANT (nameinit
) = 1;
8737 TREE_STATIC (nameinit
) = 1;
8738 nameinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (nameinit
)),
8741 varsinit
= ffecom_vardesc_array_ (s
);
8742 varsinit
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (varsinit
)),
8744 TREE_CONSTANT (varsinit
) = 1;
8745 TREE_STATIC (varsinit
) = 1;
8750 for (i
= 0, b
= ffesymbol_namelist (s
); b
!= NULL
; b
= ffebld_trail (b
))
8753 nvarsinit
= build_int_2 (i
, 0);
8754 TREE_TYPE (nvarsinit
) = integer_type_node
;
8755 TREE_CONSTANT (nvarsinit
) = 1;
8756 TREE_STATIC (nvarsinit
) = 1;
8758 nmlinits
= build_tree_list ((field
= TYPE_FIELDS (nmltype
)), nameinit
);
8759 TREE_CHAIN (nmlinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
8761 TREE_CHAIN (TREE_CHAIN (nmlinits
))
8762 = build_tree_list ((field
= TREE_CHAIN (field
)), nvarsinit
);
8764 nmlinits
= build (CONSTRUCTOR
, nmltype
, NULL_TREE
, nmlinits
);
8765 TREE_CONSTANT (nmlinits
) = 1;
8766 TREE_STATIC (nmlinits
) = 1;
8768 finish_decl (nmlt
, nmlinits
, FALSE
);
8770 nmlt
= ffecom_1 (ADDR_EXPR
, build_pointer_type (nmltype
), nmlt
);
8775 /* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
8776 analyzed on the assumption it is calculating a pointer to be
8777 indirected through. It must return the proper decl and offset,
8778 taking into account different units of measurements for offsets. */
8781 ffecom_tree_canonize_ptr_ (tree
*decl
, tree
*offset
,
8784 switch (TREE_CODE (t
))
8788 case NON_LVALUE_EXPR
:
8789 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
8793 ffecom_tree_canonize_ptr_ (decl
, offset
, TREE_OPERAND (t
, 0));
8794 if ((*decl
== NULL_TREE
)
8795 || (*decl
== error_mark_node
))
8798 if (TREE_CODE (TREE_OPERAND (t
, 1)) == INTEGER_CST
)
8800 /* An offset into COMMON. */
8801 *offset
= fold (build (PLUS_EXPR
, TREE_TYPE (*offset
),
8802 *offset
, TREE_OPERAND (t
, 1)));
8803 /* Convert offset (presumably in bytes) into canonical units
8804 (presumably bits). */
8805 *offset
= size_binop (MULT_EXPR
,
8806 convert (bitsizetype
, *offset
),
8807 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t
))));
8810 /* Not a COMMON reference, so an unrecognized pattern. */
8811 *decl
= error_mark_node
;
8816 *offset
= bitsize_zero_node
;
8820 if (TREE_CODE (TREE_OPERAND (t
, 0)) == VAR_DECL
)
8822 /* A reference to COMMON. */
8823 *decl
= TREE_OPERAND (t
, 0);
8824 *offset
= bitsize_zero_node
;
8829 /* Not a COMMON reference, so an unrecognized pattern. */
8830 *decl
= error_mark_node
;
8835 /* Given a tree that is possibly intended for use as an lvalue, return
8836 information representing a canonical view of that tree as a decl, an
8837 offset into that decl, and a size for the lvalue.
8839 If there's no applicable decl, NULL_TREE is returned for the decl,
8840 and the other fields are left undefined.
8842 If the tree doesn't fit the recognizable forms, an ERROR_MARK node
8843 is returned for the decl, and the other fields are left undefined.
8845 Otherwise, the decl returned currently is either a VAR_DECL or a
8848 The offset returned is always valid, but of course not necessarily
8849 a constant, and not necessarily converted into the appropriate
8850 type, leaving that up to the caller (so as to avoid that overhead
8851 if the decls being looked at are different anyway).
8853 If the size cannot be determined (e.g. an adjustable array),
8854 an ERROR_MARK node is returned for the size. Otherwise, the
8855 size returned is valid, not necessarily a constant, and not
8856 necessarily converted into the appropriate type as with the
8859 Note that the offset and size expressions are expressed in the
8860 base storage units (usually bits) rather than in the units of
8861 the type of the decl, because two decls with different types
8862 might overlap but with apparently non-overlapping array offsets,
8863 whereas converting the array offsets to consistant offsets will
8864 reveal the overlap. */
8867 ffecom_tree_canonize_ref_ (tree
*decl
, tree
*offset
,
8870 /* The default path is to report a nonexistant decl. */
8876 switch (TREE_CODE (t
))
8879 case IDENTIFIER_NODE
:
8888 case TRUNC_DIV_EXPR
:
8890 case FLOOR_DIV_EXPR
:
8891 case ROUND_DIV_EXPR
:
8892 case TRUNC_MOD_EXPR
:
8894 case FLOOR_MOD_EXPR
:
8895 case ROUND_MOD_EXPR
:
8897 case EXACT_DIV_EXPR
:
8898 case FIX_TRUNC_EXPR
:
8900 case FIX_FLOOR_EXPR
:
8901 case FIX_ROUND_EXPR
:
8915 case BIT_ANDTC_EXPR
:
8917 case TRUTH_ANDIF_EXPR
:
8918 case TRUTH_ORIF_EXPR
:
8919 case TRUTH_AND_EXPR
:
8921 case TRUTH_XOR_EXPR
:
8922 case TRUTH_NOT_EXPR
:
8942 *offset
= bitsize_zero_node
;
8943 *size
= TYPE_SIZE (TREE_TYPE (t
));
8948 tree array
= TREE_OPERAND (t
, 0);
8949 tree element
= TREE_OPERAND (t
, 1);
8952 if ((array
== NULL_TREE
)
8953 || (element
== NULL_TREE
))
8955 *decl
= error_mark_node
;
8959 ffecom_tree_canonize_ref_ (decl
, &init_offset
, size
,
8961 if ((*decl
== NULL_TREE
)
8962 || (*decl
== error_mark_node
))
8965 /* Calculate ((element - base) * NBBY) + init_offset. */
8966 *offset
= fold (build (MINUS_EXPR
, TREE_TYPE (element
),
8968 TYPE_MIN_VALUE (TYPE_DOMAIN
8969 (TREE_TYPE (array
)))));
8971 *offset
= size_binop (MULT_EXPR
,
8972 convert (bitsizetype
, *offset
),
8973 TYPE_SIZE (TREE_TYPE (TREE_TYPE (array
))));
8975 *offset
= size_binop (PLUS_EXPR
, init_offset
, *offset
);
8977 *size
= TYPE_SIZE (TREE_TYPE (t
));
8983 /* Most of this code is to handle references to COMMON. And so
8984 far that is useful only for calling library functions, since
8985 external (user) functions might reference common areas. But
8986 even calling an external function, it's worthwhile to decode
8987 COMMON references because if not storing into COMMON, we don't
8988 want COMMON-based arguments to gratuitously force use of a
8991 *size
= TYPE_SIZE (TREE_TYPE (t
));
8993 ffecom_tree_canonize_ptr_ (decl
, offset
,
8994 TREE_OPERAND (t
, 0));
9001 case NON_LVALUE_EXPR
:
9004 case COND_EXPR
: /* More cases than we can handle. */
9006 case REFERENCE_EXPR
:
9007 case PREDECREMENT_EXPR
:
9008 case PREINCREMENT_EXPR
:
9009 case POSTDECREMENT_EXPR
:
9010 case POSTINCREMENT_EXPR
:
9013 *decl
= error_mark_node
;
9018 /* Do divide operation appropriate to type of operands. */
9021 ffecom_tree_divide_ (tree tree_type
, tree left
, tree right
,
9022 tree dest_tree
, ffebld dest
, bool *dest_used
,
9025 if ((left
== error_mark_node
)
9026 || (right
== error_mark_node
))
9027 return error_mark_node
;
9029 switch (TREE_CODE (tree_type
))
9032 return ffecom_2 (TRUNC_DIV_EXPR
, tree_type
,
9037 if (! optimize_size
)
9038 return ffecom_2 (RDIV_EXPR
, tree_type
,
9044 if (TREE_TYPE (tree_type
)
9045 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9046 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9048 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9050 left
= ffecom_1 (ADDR_EXPR
,
9051 build_pointer_type (TREE_TYPE (left
)),
9053 left
= build_tree_list (NULL_TREE
, left
);
9054 right
= ffecom_1 (ADDR_EXPR
,
9055 build_pointer_type (TREE_TYPE (right
)),
9057 right
= build_tree_list (NULL_TREE
, right
);
9058 TREE_CHAIN (left
) = right
;
9060 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9061 ffecom_gfrt_kindtype (ix
),
9062 ffe_is_f2c_library (),
9065 dest_tree
, dest
, dest_used
,
9066 NULL_TREE
, TRUE
, hook
);
9074 if (TREE_TYPE (TYPE_FIELDS (tree_type
))
9075 == ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
])
9076 ix
= FFECOM_gfrtDIV_CC
; /* Overlapping result okay. */
9078 ix
= FFECOM_gfrtDIV_ZZ
; /* Overlapping result okay. */
9080 left
= ffecom_1 (ADDR_EXPR
,
9081 build_pointer_type (TREE_TYPE (left
)),
9083 left
= build_tree_list (NULL_TREE
, left
);
9084 right
= ffecom_1 (ADDR_EXPR
,
9085 build_pointer_type (TREE_TYPE (right
)),
9087 right
= build_tree_list (NULL_TREE
, right
);
9088 TREE_CHAIN (left
) = right
;
9090 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
9091 ffecom_gfrt_kindtype (ix
),
9092 ffe_is_f2c_library (),
9095 dest_tree
, dest
, dest_used
,
9096 NULL_TREE
, TRUE
, hook
);
9101 return ffecom_2 (RDIV_EXPR
, tree_type
,
9107 /* Build type info for non-dummy variable. */
9110 ffecom_type_localvar_ (ffesymbol s
, ffeinfoBasictype bt
,
9119 type
= ffecom_tree_type
[bt
][kt
];
9120 if (bt
== FFEINFO_basictypeCHARACTER
)
9122 hight
= build_int_2 (ffesymbol_size (s
), 0);
9123 TREE_TYPE (hight
) = ffecom_f2c_ftnlen_type_node
;
9128 build_range_type (ffecom_f2c_ftnlen_type_node
,
9129 ffecom_f2c_ftnlen_one_node
,
9131 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9134 for (dl
= ffesymbol_dims (s
); dl
!= NULL
; dl
= ffebld_trail (dl
))
9136 if (type
== error_mark_node
)
9139 dim
= ffebld_head (dl
);
9140 assert (ffebld_op (dim
) == FFEBLD_opBOUNDS
);
9142 if (ffebld_left (dim
) == NULL
)
9143 lowt
= integer_one_node
;
9145 lowt
= ffecom_expr (ffebld_left (dim
));
9147 if (TREE_CODE (lowt
) != INTEGER_CST
)
9148 lowt
= variable_size (lowt
);
9150 assert (ffebld_right (dim
) != NULL
);
9151 hight
= ffecom_expr (ffebld_right (dim
));
9153 if (TREE_CODE (hight
) != INTEGER_CST
)
9154 hight
= variable_size (hight
);
9156 type
= build_array_type (type
,
9157 build_range_type (ffecom_integer_type_node
,
9159 type
= ffecom_check_size_overflow_ (s
, type
, FALSE
);
9165 /* Build Namelist type. */
9167 static GTY(()) tree ffecom_type_namelist_var
;
9169 ffecom_type_namelist_ ()
9171 if (ffecom_type_namelist_var
== NULL_TREE
)
9173 tree namefield
, varsfield
, nvarsfield
, vardesctype
, type
;
9175 vardesctype
= ffecom_type_vardesc_ ();
9177 type
= make_node (RECORD_TYPE
);
9179 vardesctype
= build_pointer_type (build_pointer_type (vardesctype
));
9181 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9183 varsfield
= ffecom_decl_field (type
, namefield
, "vars", vardesctype
);
9184 nvarsfield
= ffecom_decl_field (type
, varsfield
, "nvars",
9187 TYPE_FIELDS (type
) = namefield
;
9190 ffecom_type_namelist_var
= type
;
9193 return ffecom_type_namelist_var
;
9196 /* Build Vardesc type. */
9198 static GTY(()) tree ffecom_type_vardesc_var
;
9200 ffecom_type_vardesc_ ()
9202 if (ffecom_type_vardesc_var
== NULL_TREE
)
9204 tree namefield
, addrfield
, dimsfield
, typefield
, type
;
9205 type
= make_node (RECORD_TYPE
);
9207 namefield
= ffecom_decl_field (type
, NULL_TREE
, "name",
9209 addrfield
= ffecom_decl_field (type
, namefield
, "addr",
9211 dimsfield
= ffecom_decl_field (type
, addrfield
, "dims",
9212 ffecom_f2c_ptr_to_ftnlen_type_node
);
9213 typefield
= ffecom_decl_field (type
, dimsfield
, "type",
9216 TYPE_FIELDS (type
) = namefield
;
9219 ffecom_type_vardesc_var
= type
;
9222 return ffecom_type_vardesc_var
;
9226 ffecom_vardesc_ (ffebld expr
)
9230 assert (ffebld_op (expr
) == FFEBLD_opSYMTER
);
9231 s
= ffebld_symter (expr
);
9233 if (ffesymbol_hook (s
).vardesc_tree
== NULL_TREE
)
9236 tree vardesctype
= ffecom_type_vardesc_ ();
9244 static int mynumber
= 0;
9246 var
= build_decl (VAR_DECL
,
9247 ffecom_get_invented_identifier ("__g77_vardesc_%d",
9250 TREE_STATIC (var
) = 1;
9251 DECL_INITIAL (var
) = error_mark_node
;
9253 var
= start_decl (var
, FALSE
);
9255 /* Process inits. */
9257 nameinit
= ffecom_build_f2c_string_ ((i
= strlen (ffesymbol_text (s
)))
9259 ffesymbol_text (s
));
9260 TREE_TYPE (nameinit
)
9261 = build_type_variant
9264 build_range_type (integer_type_node
,
9266 build_int_2 (i
, 0))),
9268 TREE_CONSTANT (nameinit
) = 1;
9269 TREE_STATIC (nameinit
) = 1;
9270 nameinit
= ffecom_1 (ADDR_EXPR
,
9271 build_pointer_type (TREE_TYPE (nameinit
)),
9274 addrinit
= ffecom_arg_ptr_to_expr (expr
, &typeinit
);
9276 dimsinit
= ffecom_vardesc_dims_ (s
);
9278 if (typeinit
== NULL_TREE
)
9280 ffeinfoBasictype bt
= ffesymbol_basictype (s
);
9281 ffeinfoKindtype kt
= ffesymbol_kindtype (s
);
9282 int tc
= ffecom_f2c_typecode (bt
, kt
);
9285 typeinit
= build_int_2 (tc
, (tc
< 0) ? -1 : 0);
9288 typeinit
= ffecom_1 (NEGATE_EXPR
, TREE_TYPE (typeinit
), typeinit
);
9290 varinits
= build_tree_list ((field
= TYPE_FIELDS (vardesctype
)),
9292 TREE_CHAIN (varinits
) = build_tree_list ((field
= TREE_CHAIN (field
)),
9294 TREE_CHAIN (TREE_CHAIN (varinits
))
9295 = build_tree_list ((field
= TREE_CHAIN (field
)), dimsinit
);
9296 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits
)))
9297 = build_tree_list ((field
= TREE_CHAIN (field
)), typeinit
);
9299 varinits
= build (CONSTRUCTOR
, vardesctype
, NULL_TREE
, varinits
);
9300 TREE_CONSTANT (varinits
) = 1;
9301 TREE_STATIC (varinits
) = 1;
9303 finish_decl (var
, varinits
, FALSE
);
9305 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (vardesctype
), var
);
9307 ffesymbol_hook (s
).vardesc_tree
= var
;
9310 return ffesymbol_hook (s
).vardesc_tree
;
9314 ffecom_vardesc_array_ (ffesymbol s
)
9318 tree item
= NULL_TREE
;
9321 static int mynumber
= 0;
9323 for (i
= 0, list
= NULL_TREE
, b
= ffesymbol_namelist (s
);
9325 b
= ffebld_trail (b
), ++i
)
9329 t
= ffecom_vardesc_ (ffebld_head (b
));
9331 if (list
== NULL_TREE
)
9332 list
= item
= build_tree_list (NULL_TREE
, t
);
9335 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
9336 item
= TREE_CHAIN (item
);
9340 item
= build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9341 build_range_type (integer_type_node
,
9343 build_int_2 (i
, 0)));
9344 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, list
);
9345 TREE_CONSTANT (list
) = 1;
9346 TREE_STATIC (list
) = 1;
9348 var
= ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber
++);
9349 var
= build_decl (VAR_DECL
, var
, item
);
9350 TREE_STATIC (var
) = 1;
9351 DECL_INITIAL (var
) = error_mark_node
;
9352 var
= start_decl (var
, FALSE
);
9353 finish_decl (var
, list
, FALSE
);
9359 ffecom_vardesc_dims_ (ffesymbol s
)
9361 if (ffesymbol_dims (s
) == NULL
)
9362 return convert (ffecom_f2c_ptr_to_ftnlen_type_node
,
9370 tree item
= NULL_TREE
;
9374 tree baseoff
= NULL_TREE
;
9375 static int mynumber
= 0;
9377 numdim
= build_int_2 ((int) ffesymbol_rank (s
), 0);
9378 TREE_TYPE (numdim
) = ffecom_f2c_ftnlen_type_node
;
9380 numelem
= ffecom_expr (ffesymbol_arraysize (s
));
9381 TREE_TYPE (numelem
) = ffecom_f2c_ftnlen_type_node
;
9384 backlist
= NULL_TREE
;
9385 for (b
= ffesymbol_dims (s
), e
= ffesymbol_extents (s
);
9387 b
= ffebld_trail (b
), e
= ffebld_trail (e
))
9393 if (ffebld_trail (b
) == NULL
)
9397 t
= convert (ffecom_f2c_ftnlen_type_node
,
9398 ffecom_expr (ffebld_head (e
)));
9400 if (list
== NULL_TREE
)
9401 list
= item
= build_tree_list (NULL_TREE
, t
);
9404 TREE_CHAIN (item
) = build_tree_list (NULL_TREE
, t
);
9405 item
= TREE_CHAIN (item
);
9409 if (ffebld_left (ffebld_head (b
)) == NULL
)
9410 low
= ffecom_integer_one_node
;
9412 low
= ffecom_expr (ffebld_left (ffebld_head (b
)));
9413 low
= convert (ffecom_f2c_ftnlen_type_node
, low
);
9415 back
= build_tree_list (low
, t
);
9416 TREE_CHAIN (back
) = backlist
;
9420 for (item
= backlist
; item
!= NULL_TREE
; item
= TREE_CHAIN (item
))
9422 if (TREE_VALUE (item
) == NULL_TREE
)
9423 baseoff
= TREE_PURPOSE (item
);
9425 baseoff
= ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
9426 TREE_PURPOSE (item
),
9427 ffecom_2 (MULT_EXPR
,
9428 ffecom_f2c_ftnlen_type_node
,
9433 /* backlist now dead, along with all TREE_PURPOSEs on it. */
9435 baseoff
= build_tree_list (NULL_TREE
, baseoff
);
9436 TREE_CHAIN (baseoff
) = list
;
9438 numelem
= build_tree_list (NULL_TREE
, numelem
);
9439 TREE_CHAIN (numelem
) = baseoff
;
9441 numdim
= build_tree_list (NULL_TREE
, numdim
);
9442 TREE_CHAIN (numdim
) = numelem
;
9444 item
= build_array_type (ffecom_f2c_ftnlen_type_node
,
9445 build_range_type (integer_type_node
,
9448 ((int) ffesymbol_rank (s
)
9450 list
= build (CONSTRUCTOR
, item
, NULL_TREE
, numdim
);
9451 TREE_CONSTANT (list
) = 1;
9452 TREE_STATIC (list
) = 1;
9454 var
= ffecom_get_invented_identifier ("__g77_dims_%d", mynumber
++);
9455 var
= build_decl (VAR_DECL
, var
, item
);
9456 TREE_STATIC (var
) = 1;
9457 DECL_INITIAL (var
) = error_mark_node
;
9458 var
= start_decl (var
, FALSE
);
9459 finish_decl (var
, list
, FALSE
);
9461 var
= ffecom_1 (ADDR_EXPR
, build_pointer_type (item
), var
);
9467 /* Essentially does a "fold (build1 (code, type, node))" while checking
9468 for certain housekeeping things.
9470 NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9471 ffecom_1_fn instead. */
9474 ffecom_1 (enum tree_code code
, tree type
, tree node
)
9478 if ((node
== error_mark_node
)
9479 || (type
== error_mark_node
))
9480 return error_mark_node
;
9482 if (code
== ADDR_EXPR
)
9484 if (!ffe_mark_addressable (node
))
9485 assert ("can't mark_addressable this node!" == NULL
);
9488 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
9493 item
= build (COMPONENT_REF
, type
, node
, TYPE_FIELDS (TREE_TYPE (node
)));
9497 item
= build (COMPONENT_REF
, type
, node
, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node
))));
9502 if (TREE_CODE (type
) != RECORD_TYPE
)
9504 item
= build1 (code
, type
, node
);
9507 node
= ffecom_stabilize_aggregate_ (node
);
9508 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9510 ffecom_2 (COMPLEX_EXPR
, type
,
9511 ffecom_1 (NEGATE_EXPR
, realtype
,
9512 ffecom_1 (REALPART_EXPR
, realtype
,
9514 ffecom_1 (NEGATE_EXPR
, realtype
,
9515 ffecom_1 (IMAGPART_EXPR
, realtype
,
9520 item
= build1 (code
, type
, node
);
9524 if (TREE_SIDE_EFFECTS (node
))
9525 TREE_SIDE_EFFECTS (item
) = 1;
9526 if (code
== ADDR_EXPR
&& staticp (node
))
9527 TREE_CONSTANT (item
) = 1;
9528 else if (code
== INDIRECT_REF
)
9529 TREE_READONLY (item
) = TYPE_READONLY (type
);
9533 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9534 handles TREE_CODE (node) == FUNCTION_DECL. In particular,
9535 does not set TREE_ADDRESSABLE (because calling an inline
9536 function does not mean the function needs to be separately
9540 ffecom_1_fn (tree node
)
9545 if (node
== error_mark_node
)
9546 return error_mark_node
;
9548 type
= build_type_variant (TREE_TYPE (node
),
9549 TREE_READONLY (node
),
9550 TREE_THIS_VOLATILE (node
));
9551 item
= build1 (ADDR_EXPR
,
9552 build_pointer_type (type
), node
);
9553 if (TREE_SIDE_EFFECTS (node
))
9554 TREE_SIDE_EFFECTS (item
) = 1;
9556 TREE_CONSTANT (item
) = 1;
9560 /* Essentially does a "fold (build (code, type, node1, node2))" while
9561 checking for certain housekeeping things. */
9564 ffecom_2 (enum tree_code code
, tree type
, tree node1
,
9569 if ((node1
== error_mark_node
)
9570 || (node2
== error_mark_node
)
9571 || (type
== error_mark_node
))
9572 return error_mark_node
;
9574 switch (ffe_is_emulate_complex () ? code
: NOP_EXPR
)
9576 tree a
, b
, c
, d
, realtype
;
9579 assert ("no CONJ_EXPR support yet" == NULL
);
9580 return error_mark_node
;
9583 item
= build_tree_list (TYPE_FIELDS (type
), node1
);
9584 TREE_CHAIN (item
) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type
)), node2
);
9585 item
= build (CONSTRUCTOR
, type
, NULL_TREE
, item
);
9589 if (TREE_CODE (type
) != RECORD_TYPE
)
9591 item
= build (code
, type
, node1
, node2
);
9594 node1
= ffecom_stabilize_aggregate_ (node1
);
9595 node2
= ffecom_stabilize_aggregate_ (node2
);
9596 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9598 ffecom_2 (COMPLEX_EXPR
, type
,
9599 ffecom_2 (PLUS_EXPR
, realtype
,
9600 ffecom_1 (REALPART_EXPR
, realtype
,
9602 ffecom_1 (REALPART_EXPR
, realtype
,
9604 ffecom_2 (PLUS_EXPR
, realtype
,
9605 ffecom_1 (IMAGPART_EXPR
, realtype
,
9607 ffecom_1 (IMAGPART_EXPR
, realtype
,
9612 if (TREE_CODE (type
) != RECORD_TYPE
)
9614 item
= build (code
, type
, node1
, node2
);
9617 node1
= ffecom_stabilize_aggregate_ (node1
);
9618 node2
= ffecom_stabilize_aggregate_ (node2
);
9619 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9621 ffecom_2 (COMPLEX_EXPR
, type
,
9622 ffecom_2 (MINUS_EXPR
, realtype
,
9623 ffecom_1 (REALPART_EXPR
, realtype
,
9625 ffecom_1 (REALPART_EXPR
, realtype
,
9627 ffecom_2 (MINUS_EXPR
, realtype
,
9628 ffecom_1 (IMAGPART_EXPR
, realtype
,
9630 ffecom_1 (IMAGPART_EXPR
, realtype
,
9635 if (TREE_CODE (type
) != RECORD_TYPE
)
9637 item
= build (code
, type
, node1
, node2
);
9640 node1
= ffecom_stabilize_aggregate_ (node1
);
9641 node2
= ffecom_stabilize_aggregate_ (node2
);
9642 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9643 a
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
9645 b
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
9647 c
= save_expr (ffecom_1 (REALPART_EXPR
, realtype
,
9649 d
= save_expr (ffecom_1 (IMAGPART_EXPR
, realtype
,
9652 ffecom_2 (COMPLEX_EXPR
, type
,
9653 ffecom_2 (MINUS_EXPR
, realtype
,
9654 ffecom_2 (MULT_EXPR
, realtype
,
9657 ffecom_2 (MULT_EXPR
, realtype
,
9660 ffecom_2 (PLUS_EXPR
, realtype
,
9661 ffecom_2 (MULT_EXPR
, realtype
,
9664 ffecom_2 (MULT_EXPR
, realtype
,
9670 if ((TREE_CODE (node1
) != RECORD_TYPE
)
9671 && (TREE_CODE (node2
) != RECORD_TYPE
))
9673 item
= build (code
, type
, node1
, node2
);
9676 assert (TREE_CODE (node1
) == RECORD_TYPE
);
9677 assert (TREE_CODE (node2
) == RECORD_TYPE
);
9678 node1
= ffecom_stabilize_aggregate_ (node1
);
9679 node2
= ffecom_stabilize_aggregate_ (node2
);
9680 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9682 ffecom_2 (TRUTH_ANDIF_EXPR
, type
,
9683 ffecom_2 (code
, type
,
9684 ffecom_1 (REALPART_EXPR
, realtype
,
9686 ffecom_1 (REALPART_EXPR
, realtype
,
9688 ffecom_2 (code
, type
,
9689 ffecom_1 (IMAGPART_EXPR
, realtype
,
9691 ffecom_1 (IMAGPART_EXPR
, realtype
,
9696 if ((TREE_CODE (node1
) != RECORD_TYPE
)
9697 && (TREE_CODE (node2
) != RECORD_TYPE
))
9699 item
= build (code
, type
, node1
, node2
);
9702 assert (TREE_CODE (node1
) == RECORD_TYPE
);
9703 assert (TREE_CODE (node2
) == RECORD_TYPE
);
9704 node1
= ffecom_stabilize_aggregate_ (node1
);
9705 node2
= ffecom_stabilize_aggregate_ (node2
);
9706 realtype
= TREE_TYPE (TYPE_FIELDS (type
));
9708 ffecom_2 (TRUTH_ORIF_EXPR
, type
,
9709 ffecom_2 (code
, type
,
9710 ffecom_1 (REALPART_EXPR
, realtype
,
9712 ffecom_1 (REALPART_EXPR
, realtype
,
9714 ffecom_2 (code
, type
,
9715 ffecom_1 (IMAGPART_EXPR
, realtype
,
9717 ffecom_1 (IMAGPART_EXPR
, realtype
,
9722 item
= build (code
, type
, node1
, node2
);
9726 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
))
9727 TREE_SIDE_EFFECTS (item
) = 1;
9731 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9733 ffesymbol s; // the ENTRY point itself
9734 if (ffecom_2pass_advise_entrypoint(s))
9735 // the ENTRY point has been accepted
9737 Does whatever compiler needs to do when it learns about the entrypoint,
9738 like determine the return type of the master function, count the
9739 number of entrypoints, etc. Returns FALSE if the return type is
9740 not compatible with the return type(s) of other entrypoint(s).
9742 NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9743 later (after _finish_progunit) be called with the same entrypoint(s)
9744 as passed to this fn for which TRUE was returned.
9747 Return FALSE if the return type conflicts with previous entrypoints. */
9750 ffecom_2pass_advise_entrypoint (ffesymbol entry
)
9752 ffebld list
; /* opITEM. */
9753 ffebld mlist
; /* opITEM. */
9754 ffebld plist
; /* opITEM. */
9755 ffebld arg
; /* ffebld_head(opITEM). */
9756 ffebld item
; /* opITEM. */
9757 ffesymbol s
; /* ffebld_symter(arg). */
9758 ffeinfoBasictype bt
= ffesymbol_basictype (entry
);
9759 ffeinfoKindtype kt
= ffesymbol_kindtype (entry
);
9760 ffetargetCharacterSize size
= ffesymbol_size (entry
);
9763 if (ffecom_num_entrypoints_
== 0)
9764 { /* First entrypoint, make list of main
9765 arglist's dummies. */
9766 assert (ffecom_primary_entry_
!= NULL
);
9768 ffecom_master_bt_
= ffesymbol_basictype (ffecom_primary_entry_
);
9769 ffecom_master_kt_
= ffesymbol_kindtype (ffecom_primary_entry_
);
9770 ffecom_master_size_
= ffesymbol_size (ffecom_primary_entry_
);
9772 for (plist
= NULL
, list
= ffesymbol_dummyargs (ffecom_primary_entry_
);
9774 list
= ffebld_trail (list
))
9776 arg
= ffebld_head (list
);
9777 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
9778 continue; /* Alternate return or some such thing. */
9779 item
= ffebld_new_item (arg
, NULL
);
9781 ffecom_master_arglist_
= item
;
9783 ffebld_set_trail (plist
, item
);
9788 /* If necessary, scan entry arglist for alternate returns. Do this scan
9789 apparently redundantly (it's done below to UNIONize the arglists) so
9790 that we don't complain about RETURN 1 if an offending ENTRY is the only
9791 one with an alternate return. */
9793 if (!ffecom_is_altreturning_
)
9795 for (list
= ffesymbol_dummyargs (entry
);
9797 list
= ffebld_trail (list
))
9799 arg
= ffebld_head (list
);
9800 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
9802 ffecom_is_altreturning_
= TRUE
;
9808 /* Now check type compatibility. */
9810 switch (ffecom_master_bt_
)
9812 case FFEINFO_basictypeNONE
:
9813 ok
= (bt
!= FFEINFO_basictypeCHARACTER
);
9816 case FFEINFO_basictypeCHARACTER
:
9818 = (bt
== FFEINFO_basictypeCHARACTER
)
9819 && (kt
== ffecom_master_kt_
)
9820 && (size
== ffecom_master_size_
);
9823 case FFEINFO_basictypeANY
:
9824 return FALSE
; /* Just don't bother. */
9827 if (bt
== FFEINFO_basictypeCHARACTER
)
9833 if ((bt
!= ffecom_master_bt_
) || (kt
!= ffecom_master_kt_
))
9835 ffecom_master_bt_
= FFEINFO_basictypeNONE
;
9836 ffecom_master_kt_
= FFEINFO_kindtypeNONE
;
9843 ffebad_start (FFEBAD_ENTRY_CONFLICTS
);
9844 ffest_ffebad_here_current_stmt (0);
9846 return FALSE
; /* Can't handle entrypoint. */
9849 /* Entrypoint type compatible with previous types. */
9851 ++ffecom_num_entrypoints_
;
9853 /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
9855 for (list
= ffesymbol_dummyargs (entry
);
9857 list
= ffebld_trail (list
))
9859 arg
= ffebld_head (list
);
9860 if (ffebld_op (arg
) != FFEBLD_opSYMTER
)
9861 continue; /* Alternate return or some such thing. */
9862 s
= ffebld_symter (arg
);
9863 for (plist
= NULL
, mlist
= ffecom_master_arglist_
;
9865 plist
= mlist
, mlist
= ffebld_trail (mlist
))
9866 { /* plist points to previous item for easy
9867 appending of arg. */
9868 if (ffebld_symter (ffebld_head (mlist
)) == s
)
9869 break; /* Already have this arg in the master list. */
9872 continue; /* Already have this arg in the master list. */
9874 /* Append this arg to the master list. */
9876 item
= ffebld_new_item (arg
, NULL
);
9878 ffecom_master_arglist_
= item
;
9880 ffebld_set_trail (plist
, item
);
9886 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
9888 ffesymbol s; // the ENTRY point itself
9889 ffecom_2pass_do_entrypoint(s);
9891 Does whatever compiler needs to do to make the entrypoint actually
9892 happen. Must be called for each entrypoint after
9893 ffecom_finish_progunit is called. */
9896 ffecom_2pass_do_entrypoint (ffesymbol entry
)
9898 static int mfn_num
= 0;
9901 if (mfn_num
!= ffecom_num_fns_
)
9902 { /* First entrypoint for this program unit. */
9904 mfn_num
= ffecom_num_fns_
;
9905 ffecom_do_entry_ (ffecom_primary_entry_
, 0);
9910 --ffecom_num_entrypoints_
;
9912 ffecom_do_entry_ (entry
, ent_num
);
9915 /* Essentially does a "fold (build (code, type, node1, node2))" while
9916 checking for certain housekeeping things. Always sets
9917 TREE_SIDE_EFFECTS. */
9920 ffecom_2s (enum tree_code code
, tree type
, tree node1
,
9925 if ((node1
== error_mark_node
)
9926 || (node2
== error_mark_node
)
9927 || (type
== error_mark_node
))
9928 return error_mark_node
;
9930 item
= build (code
, type
, node1
, node2
);
9931 TREE_SIDE_EFFECTS (item
) = 1;
9935 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9936 checking for certain housekeeping things. */
9939 ffecom_3 (enum tree_code code
, tree type
, tree node1
,
9940 tree node2
, tree node3
)
9944 if ((node1
== error_mark_node
)
9945 || (node2
== error_mark_node
)
9946 || (node3
== error_mark_node
)
9947 || (type
== error_mark_node
))
9948 return error_mark_node
;
9950 item
= build (code
, type
, node1
, node2
, node3
);
9951 if (TREE_SIDE_EFFECTS (node1
) || TREE_SIDE_EFFECTS (node2
)
9952 || (node3
!= NULL_TREE
&& TREE_SIDE_EFFECTS (node3
)))
9953 TREE_SIDE_EFFECTS (item
) = 1;
9957 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
9958 checking for certain housekeeping things. Always sets
9959 TREE_SIDE_EFFECTS. */
9962 ffecom_3s (enum tree_code code
, tree type
, tree node1
,
9963 tree node2
, tree node3
)
9967 if ((node1
== error_mark_node
)
9968 || (node2
== error_mark_node
)
9969 || (node3
== error_mark_node
)
9970 || (type
== error_mark_node
))
9971 return error_mark_node
;
9973 item
= build (code
, type
, node1
, node2
, node3
);
9974 TREE_SIDE_EFFECTS (item
) = 1;
9978 /* ffecom_arg_expr -- Transform argument expr into gcc tree
9980 See use by ffecom_list_expr.
9982 If expression is NULL, returns an integer zero tree. If it is not
9983 a CHARACTER expression, returns whatever ffecom_expr
9984 returns and sets the length return value to NULL_TREE. Otherwise
9985 generates code to evaluate the character expression, returns the proper
9986 pointer to the result, but does NOT set the length return value to a tree
9987 that specifies the length of the result. (In other words, the length
9988 variable is always set to NULL_TREE, because a length is never passed.)
9991 Don't set returned length, since nobody needs it (yet; someday if
9992 we allow CHARACTER*(*) dummies to statement functions, we'll need
9996 ffecom_arg_expr (ffebld expr
, tree
*length
)
10000 *length
= NULL_TREE
;
10003 return integer_zero_node
;
10005 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10006 return ffecom_expr (expr
);
10008 return ffecom_arg_ptr_to_expr (expr
, &ign
);
10011 /* Transform expression into constant argument-pointer-to-expression tree.
10013 If the expression can be transformed into a argument-pointer-to-expression
10014 tree that is constant, that is done, and the tree returned. Else
10015 NULL_TREE is returned.
10017 That way, a caller can attempt to provide compile-time initialization
10018 of a variable and, if that fails, *then* choose to start a new block
10019 and resort to using temporaries, as appropriate. */
10022 ffecom_arg_ptr_to_const_expr (ffebld expr
, tree
*length
)
10025 return integer_zero_node
;
10027 if (ffebld_op (expr
) == FFEBLD_opANY
)
10030 *length
= error_mark_node
;
10031 return error_mark_node
;
10034 if (ffebld_arity (expr
) == 0
10035 && (ffebld_op (expr
) != FFEBLD_opSYMTER
10036 || ffebld_where (expr
) == FFEINFO_whereCOMMON
10037 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
10038 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
10042 t
= ffecom_arg_ptr_to_expr (expr
, length
);
10043 assert (TREE_CONSTANT (t
));
10044 assert (! length
|| TREE_CONSTANT (*length
));
10049 && ffebld_size (expr
) != FFETARGET_charactersizeNONE
)
10050 *length
= build_int_2 (ffebld_size (expr
), 0);
10052 *length
= NULL_TREE
;
10056 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10058 See use by ffecom_list_ptr_to_expr.
10060 If expression is NULL, returns an integer zero tree. If it is not
10061 a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10062 returns and sets the length return value to NULL_TREE. Otherwise
10063 generates code to evaluate the character expression, returns the proper
10064 pointer to the result, AND sets the length return value to a tree that
10065 specifies the length of the result.
10067 If the length argument is NULL, this is a slightly special
10068 case of building a FORMAT expression, that is, an expression that
10069 will be used at run time without regard to length. For the current
10070 implementation, which uses the libf2c library, this means it is nice
10071 to append a null byte to the end of the expression, where feasible,
10072 to make sure any diagnostic about the FORMAT string terminates at
10075 For now, treat %REF(char-expr) as the same as char-expr with a NULL
10076 length argument. This might even be seen as a feature, if a null
10077 byte can always be appended. */
10080 ffecom_arg_ptr_to_expr (ffebld expr
, tree
*length
)
10084 ffecomConcatList_ catlist
;
10086 if (length
!= NULL
)
10087 *length
= NULL_TREE
;
10090 return integer_zero_node
;
10092 switch (ffebld_op (expr
))
10094 case FFEBLD_opPERCENT_VAL
:
10095 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10096 return ffecom_expr (ffebld_left (expr
));
10101 temp_exp
= ffecom_arg_ptr_to_expr (ffebld_left (expr
), &temp_length
);
10102 if (temp_exp
== error_mark_node
)
10103 return error_mark_node
;
10105 return ffecom_1 (INDIRECT_REF
, TREE_TYPE (TREE_TYPE (temp_exp
)),
10109 case FFEBLD_opPERCENT_REF
:
10110 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10111 return ffecom_ptr_to_expr (ffebld_left (expr
));
10112 if (length
!= NULL
)
10114 ign_length
= NULL_TREE
;
10115 length
= &ign_length
;
10117 expr
= ffebld_left (expr
);
10120 case FFEBLD_opPERCENT_DESCR
:
10121 switch (ffeinfo_basictype (ffebld_info (expr
)))
10123 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10124 case FFEINFO_basictypeHOLLERITH
:
10126 case FFEINFO_basictypeCHARACTER
:
10127 break; /* Passed by descriptor anyway. */
10130 item
= ffecom_ptr_to_expr (expr
);
10131 if (item
!= error_mark_node
)
10132 *length
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (item
)));
10141 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10142 if ((ffeinfo_basictype (ffebld_info (expr
)) == FFEINFO_basictypeHOLLERITH
)
10143 && (length
!= NULL
))
10144 { /* Pass Hollerith by descriptor. */
10145 ffetargetHollerith h
;
10147 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
10148 h
= ffebld_cu_val_hollerith (ffebld_constant_union
10149 (ffebld_conter (expr
)));
10151 = build_int_2 (h
.length
, 0);
10152 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10156 if (ffeinfo_basictype (ffebld_info (expr
)) != FFEINFO_basictypeCHARACTER
)
10157 return ffecom_ptr_to_expr (expr
);
10159 assert (ffeinfo_kindtype (ffebld_info (expr
))
10160 == FFEINFO_kindtypeCHARACTER1
);
10162 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
10163 expr
= ffebld_left (expr
);
10165 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
10166 switch (ffecom_concat_list_count_ (catlist
))
10168 case 0: /* Shouldn't happen, but in case it does... */
10169 if (length
!= NULL
)
10171 *length
= ffecom_f2c_ftnlen_zero_node
;
10172 TREE_TYPE (*length
) = ffecom_f2c_ftnlen_type_node
;
10174 ffecom_concat_list_kill_ (catlist
);
10175 return null_pointer_node
;
10177 case 1: /* The (fairly) easy case. */
10178 if (length
== NULL
)
10179 ffecom_char_args_with_null_ (&item
, &ign_length
,
10180 ffecom_concat_list_expr_ (catlist
, 0));
10182 ffecom_char_args_ (&item
, length
,
10183 ffecom_concat_list_expr_ (catlist
, 0));
10184 ffecom_concat_list_kill_ (catlist
);
10185 assert (item
!= NULL_TREE
);
10188 default: /* Must actually concatenate things. */
10193 int count
= ffecom_concat_list_count_ (catlist
);
10204 ffetargetCharacterSize sz
;
10206 sz
= ffecom_concat_list_maxlen_ (catlist
);
10208 assert (sz
!= FFETARGET_charactersizeNONE
);
10213 hook
= ffebld_nonter_hook (expr
);
10215 assert (TREE_CODE (hook
) == TREE_VEC
);
10216 assert (TREE_VEC_LENGTH (hook
) == 3);
10217 length_array
= lengths
= TREE_VEC_ELT (hook
, 0);
10218 item_array
= items
= TREE_VEC_ELT (hook
, 1);
10219 temporary
= TREE_VEC_ELT (hook
, 2);
10222 known_length
= ffecom_f2c_ftnlen_zero_node
;
10224 for (i
= 0; i
< count
; ++i
)
10227 && (length
== NULL
))
10228 ffecom_char_args_with_null_ (&citem
, &clength
,
10229 ffecom_concat_list_expr_ (catlist
, i
));
10231 ffecom_char_args_ (&citem
, &clength
,
10232 ffecom_concat_list_expr_ (catlist
, i
));
10233 if ((citem
== error_mark_node
)
10234 || (clength
== error_mark_node
))
10236 ffecom_concat_list_kill_ (catlist
);
10237 *length
= error_mark_node
;
10238 return error_mark_node
;
10242 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (items
),
10243 ffecom_modify (void_type_node
,
10244 ffecom_2 (ARRAY_REF
,
10245 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array
))),
10247 build_int_2 (i
, 0)),
10250 clength
= ffecom_save_tree (clength
);
10251 if (length
!= NULL
)
10253 = ffecom_2 (PLUS_EXPR
, ffecom_f2c_ftnlen_type_node
,
10257 = ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (lengths
),
10258 ffecom_modify (void_type_node
,
10259 ffecom_2 (ARRAY_REF
,
10260 TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array
))),
10262 build_int_2 (i
, 0)),
10267 temporary
= ffecom_1 (ADDR_EXPR
,
10268 build_pointer_type (TREE_TYPE (temporary
)),
10271 item
= build_tree_list (NULL_TREE
, temporary
);
10273 = build_tree_list (NULL_TREE
,
10274 ffecom_1 (ADDR_EXPR
,
10275 build_pointer_type (TREE_TYPE (items
)),
10277 TREE_CHAIN (TREE_CHAIN (item
))
10278 = build_tree_list (NULL_TREE
,
10279 ffecom_1 (ADDR_EXPR
,
10280 build_pointer_type (TREE_TYPE (lengths
)),
10282 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
)))
10285 ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
10286 convert (ffecom_f2c_ftnlen_type_node
,
10287 build_int_2 (count
, 0))));
10288 num
= build_int_2 (sz
, 0);
10289 TREE_TYPE (num
) = ffecom_f2c_ftnlen_type_node
;
10290 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item
))))
10291 = build_tree_list (NULL_TREE
, num
);
10293 item
= ffecom_call_gfrt (FFECOM_gfrtCAT
, item
, NULL_TREE
);
10294 TREE_SIDE_EFFECTS (item
) = 1;
10295 item
= ffecom_2 (COMPOUND_EXPR
, TREE_TYPE (temporary
),
10299 if (length
!= NULL
)
10300 *length
= known_length
;
10303 ffecom_concat_list_kill_ (catlist
);
10304 assert (item
!= NULL_TREE
);
10308 /* Generate call to run-time function.
10310 The first arg is the GNU Fortran Run-Time function index, the second
10311 arg is the list of arguments to pass to it. Returned is the expression
10312 (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10313 result (which may be void). */
10316 ffecom_call_gfrt (ffecomGfrt ix
, tree args
, tree hook
)
10318 return ffecom_call_ (ffecom_gfrt_tree_ (ix
),
10319 ffecom_gfrt_kindtype (ix
),
10320 ffe_is_f2c_library () && ffecom_gfrt_complex_
[ix
],
10321 NULL_TREE
, args
, NULL_TREE
, NULL
,
10322 NULL
, NULL_TREE
, TRUE
, hook
);
10325 /* Transform constant-union to tree. */
10328 ffecom_constantunion (ffebldConstantUnion
*cu
, ffeinfoBasictype bt
,
10329 ffeinfoKindtype kt
, tree tree_type
)
10335 case FFEINFO_basictypeINTEGER
:
10341 #if FFETARGET_okINTEGER1
10342 case FFEINFO_kindtypeINTEGER1
:
10343 val
= ffebld_cu_val_integer1 (*cu
);
10347 #if FFETARGET_okINTEGER2
10348 case FFEINFO_kindtypeINTEGER2
:
10349 val
= ffebld_cu_val_integer2 (*cu
);
10353 #if FFETARGET_okINTEGER3
10354 case FFEINFO_kindtypeINTEGER3
:
10355 val
= ffebld_cu_val_integer3 (*cu
);
10359 #if FFETARGET_okINTEGER4
10360 case FFEINFO_kindtypeINTEGER4
:
10361 val
= ffebld_cu_val_integer4 (*cu
);
10366 assert ("bad INTEGER constant kind type" == NULL
);
10367 /* Fall through. */
10368 case FFEINFO_kindtypeANY
:
10369 return error_mark_node
;
10371 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
10372 TREE_TYPE (item
) = tree_type
;
10376 case FFEINFO_basictypeLOGICAL
:
10382 #if FFETARGET_okLOGICAL1
10383 case FFEINFO_kindtypeLOGICAL1
:
10384 val
= ffebld_cu_val_logical1 (*cu
);
10388 #if FFETARGET_okLOGICAL2
10389 case FFEINFO_kindtypeLOGICAL2
:
10390 val
= ffebld_cu_val_logical2 (*cu
);
10394 #if FFETARGET_okLOGICAL3
10395 case FFEINFO_kindtypeLOGICAL3
:
10396 val
= ffebld_cu_val_logical3 (*cu
);
10400 #if FFETARGET_okLOGICAL4
10401 case FFEINFO_kindtypeLOGICAL4
:
10402 val
= ffebld_cu_val_logical4 (*cu
);
10407 assert ("bad LOGICAL constant kind type" == NULL
);
10408 /* Fall through. */
10409 case FFEINFO_kindtypeANY
:
10410 return error_mark_node
;
10412 item
= build_int_2 (val
, (val
< 0) ? -1 : 0);
10413 TREE_TYPE (item
) = tree_type
;
10417 case FFEINFO_basictypeREAL
:
10419 REAL_VALUE_TYPE val
;
10423 #if FFETARGET_okREAL1
10424 case FFEINFO_kindtypeREAL1
:
10425 val
= ffetarget_value_real1 (ffebld_cu_val_real1 (*cu
));
10429 #if FFETARGET_okREAL2
10430 case FFEINFO_kindtypeREAL2
:
10431 val
= ffetarget_value_real2 (ffebld_cu_val_real2 (*cu
));
10435 #if FFETARGET_okREAL3
10436 case FFEINFO_kindtypeREAL3
:
10437 val
= ffetarget_value_real3 (ffebld_cu_val_real3 (*cu
));
10441 #if FFETARGET_okREAL4
10442 case FFEINFO_kindtypeREAL4
:
10443 val
= ffetarget_value_real4 (ffebld_cu_val_real4 (*cu
));
10448 assert ("bad REAL constant kind type" == NULL
);
10449 /* Fall through. */
10450 case FFEINFO_kindtypeANY
:
10451 return error_mark_node
;
10453 item
= build_real (tree_type
, val
);
10457 case FFEINFO_basictypeCOMPLEX
:
10459 REAL_VALUE_TYPE real
;
10460 REAL_VALUE_TYPE imag
;
10461 tree el_type
= ffecom_tree_type
[FFEINFO_basictypeREAL
][kt
];
10465 #if FFETARGET_okCOMPLEX1
10466 case FFEINFO_kindtypeREAL1
:
10467 real
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).real
);
10468 imag
= ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu
).imaginary
);
10472 #if FFETARGET_okCOMPLEX2
10473 case FFEINFO_kindtypeREAL2
:
10474 real
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).real
);
10475 imag
= ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu
).imaginary
);
10479 #if FFETARGET_okCOMPLEX3
10480 case FFEINFO_kindtypeREAL3
:
10481 real
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).real
);
10482 imag
= ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu
).imaginary
);
10486 #if FFETARGET_okCOMPLEX4
10487 case FFEINFO_kindtypeREAL4
:
10488 real
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).real
);
10489 imag
= ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu
).imaginary
);
10494 assert ("bad REAL constant kind type" == NULL
);
10495 /* Fall through. */
10496 case FFEINFO_kindtypeANY
:
10497 return error_mark_node
;
10499 item
= ffecom_build_complex_constant_ (tree_type
,
10500 build_real (el_type
, real
),
10501 build_real (el_type
, imag
));
10505 case FFEINFO_basictypeCHARACTER
:
10506 { /* Happens only in DATA and similar contexts. */
10507 ffetargetCharacter1 val
;
10511 #if FFETARGET_okCHARACTER1
10512 case FFEINFO_kindtypeLOGICAL1
:
10513 val
= ffebld_cu_val_character1 (*cu
);
10518 assert ("bad CHARACTER constant kind type" == NULL
);
10519 /* Fall through. */
10520 case FFEINFO_kindtypeANY
:
10521 return error_mark_node
;
10523 item
= build_string (ffetarget_length_character1 (val
),
10524 ffetarget_text_character1 (val
));
10526 = build_type_variant (build_array_type (char_type_node
,
10528 (integer_type_node
,
10531 (ffetarget_length_character1
10537 case FFEINFO_basictypeHOLLERITH
:
10539 ffetargetHollerith h
;
10541 h
= ffebld_cu_val_hollerith (*cu
);
10543 /* If not at least as wide as default INTEGER, widen it. */
10544 if (h
.length
>= FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
)
10545 item
= build_string (h
.length
, h
.text
);
10548 char str
[FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
];
10550 memcpy (str
, h
.text
, h
.length
);
10551 memset (&str
[h
.length
], ' ',
10552 FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
10554 item
= build_string (FLOAT_TYPE_SIZE
/ CHAR_TYPE_SIZE
,
10558 = build_type_variant (build_array_type (char_type_node
,
10560 (integer_type_node
,
10568 case FFEINFO_basictypeTYPELESS
:
10570 ffetargetInteger1 ival
;
10571 ffetargetTypeless tless
;
10574 tless
= ffebld_cu_val_typeless (*cu
);
10575 error
= ffetarget_convert_integer1_typeless (&ival
, tless
);
10576 assert (error
== FFEBAD
);
10578 item
= build_int_2 ((int) ival
, 0);
10583 assert ("not yet on constant type" == NULL
);
10584 /* Fall through. */
10585 case FFEINFO_basictypeANY
:
10586 return error_mark_node
;
10589 TREE_CONSTANT (item
) = 1;
10594 /* Transform expression into constant tree.
10596 If the expression can be transformed into a tree that is constant,
10597 that is done, and the tree returned. Else NULL_TREE is returned.
10599 That way, a caller can attempt to provide compile-time initialization
10600 of a variable and, if that fails, *then* choose to start a new block
10601 and resort to using temporaries, as appropriate. */
10604 ffecom_const_expr (ffebld expr
)
10607 return integer_zero_node
;
10609 if (ffebld_op (expr
) == FFEBLD_opANY
)
10610 return error_mark_node
;
10612 if (ffebld_arity (expr
) == 0
10613 && (ffebld_op (expr
) != FFEBLD_opSYMTER
10615 /* ~~Enable once common/equivalence is handled properly? */
10616 || ffebld_where (expr
) == FFEINFO_whereCOMMON
10618 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
10619 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
10623 t
= ffecom_expr (expr
);
10624 assert (TREE_CONSTANT (t
));
10631 /* Handy way to make a field in a struct/union. */
10634 ffecom_decl_field (tree context
, tree prevfield
,
10635 const char *name
, tree type
)
10639 field
= build_decl (FIELD_DECL
, get_identifier (name
), type
);
10640 DECL_CONTEXT (field
) = context
;
10641 DECL_ALIGN (field
) = 0;
10642 DECL_USER_ALIGN (field
) = 0;
10643 if (prevfield
!= NULL_TREE
)
10644 TREE_CHAIN (prevfield
) = field
;
10650 ffecom_close_include (FILE *f
)
10652 ffecom_close_include_ (f
);
10656 ffecom_decode_include_option (char *spec
)
10658 return ffecom_decode_include_option_ (spec
);
10661 /* End a compound statement (block). */
10664 ffecom_end_compstmt (void)
10666 return bison_rule_compstmt_ ();
10669 /* ffecom_end_transition -- Perform end transition on all symbols
10671 ffecom_end_transition();
10673 Calls ffecom_sym_end_transition for each global and local symbol. */
10676 ffecom_end_transition ()
10680 if (ffe_is_ffedebug ())
10681 fprintf (dmpout
, "; end_stmt_transition\n");
10683 ffecom_list_blockdata_
= NULL
;
10684 ffecom_list_common_
= NULL
;
10686 ffesymbol_drive (ffecom_sym_end_transition
);
10687 if (ffe_is_ffedebug ())
10689 ffestorag_report ();
10692 ffecom_start_progunit_ ();
10694 for (item
= ffecom_list_blockdata_
;
10696 item
= ffebld_trail (item
))
10703 static int number
= 0;
10705 callee
= ffebld_head (item
);
10706 s
= ffebld_symter (callee
);
10707 t
= ffesymbol_hook (s
).decl_tree
;
10708 if (t
== NULL_TREE
)
10710 s
= ffecom_sym_transform_ (s
);
10711 t
= ffesymbol_hook (s
).decl_tree
;
10714 dt
= build_pointer_type (TREE_TYPE (t
));
10716 var
= build_decl (VAR_DECL
,
10717 ffecom_get_invented_identifier ("__g77_forceload_%d",
10720 DECL_EXTERNAL (var
) = 0;
10721 TREE_STATIC (var
) = 1;
10722 TREE_PUBLIC (var
) = 0;
10723 DECL_INITIAL (var
) = error_mark_node
;
10724 TREE_USED (var
) = 1;
10726 var
= start_decl (var
, FALSE
);
10728 t
= ffecom_1 (ADDR_EXPR
, dt
, t
);
10730 finish_decl (var
, t
, FALSE
);
10733 /* This handles any COMMON areas that weren't referenced but have, for
10734 example, important initial data. */
10736 for (item
= ffecom_list_common_
;
10738 item
= ffebld_trail (item
))
10739 ffecom_transform_common_ (ffebld_symter (ffebld_head (item
)));
10741 ffecom_list_common_
= NULL
;
10744 /* ffecom_exec_transition -- Perform exec transition on all symbols
10746 ffecom_exec_transition();
10748 Calls ffecom_sym_exec_transition for each global and local symbol.
10749 Make sure error updating not inhibited. */
10752 ffecom_exec_transition ()
10756 if (ffe_is_ffedebug ())
10757 fprintf (dmpout
, "; exec_stmt_transition\n");
10759 inhibited
= ffebad_inhibit ();
10760 ffebad_set_inhibit (FALSE
);
10762 ffesymbol_drive (ffecom_sym_exec_transition
); /* Don't retract! */
10763 ffeequiv_exec_transition (); /* Handle all pending EQUIVALENCEs. */
10764 if (ffe_is_ffedebug ())
10766 ffestorag_report ();
10770 ffebad_set_inhibit (TRUE
);
10773 /* Handle assignment statement.
10775 Convert dest and source using ffecom_expr, then join them
10776 with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
10779 ffecom_expand_let_stmt (ffebld dest
, ffebld source
)
10786 if (ffeinfo_basictype (ffebld_info (dest
)) != FFEINFO_basictypeCHARACTER
)
10791 /* This attempts to replicate the test below, but must not be
10792 true when the test below is false. (Always err on the side
10793 of creating unused temporaries, to avoid ICEs.) */
10794 if (ffebld_op (dest
) != FFEBLD_opSYMTER
10795 || ((dest_tree
= ffesymbol_hook (ffebld_symter (dest
)).decl_tree
)
10796 && (TREE_CODE (dest_tree
) != VAR_DECL
10797 || TREE_ADDRESSABLE (dest_tree
))))
10799 ffecom_prepare_expr_ (source
, dest
);
10804 ffecom_prepare_expr_ (source
, NULL
);
10808 ffecom_prepare_expr_w (NULL_TREE
, dest
);
10810 /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
10811 create a temporary through which the assignment is to take place,
10812 since MODIFY_EXPR doesn't handle partial overlap properly. */
10813 if (ffebld_basictype (dest
) == FFEINFO_basictypeCOMPLEX
10814 && ffecom_possible_partial_overlap_ (dest
, source
))
10816 assign_temp
= ffecom_make_tempvar ("complex_let",
10818 [ffebld_basictype (dest
)]
10819 [ffebld_kindtype (dest
)],
10820 FFETARGET_charactersizeNONE
,
10824 assign_temp
= NULL_TREE
;
10826 ffecom_prepare_end ();
10828 dest_tree
= ffecom_expr_w (NULL_TREE
, dest
);
10829 if (dest_tree
== error_mark_node
)
10832 if ((TREE_CODE (dest_tree
) != VAR_DECL
)
10833 || TREE_ADDRESSABLE (dest_tree
))
10834 source_tree
= ffecom_expr_ (source
, dest_tree
, dest
, &dest_used
,
10838 assert (! dest_used
);
10840 source_tree
= ffecom_expr (source
);
10842 if (source_tree
== error_mark_node
)
10846 expr_tree
= source_tree
;
10847 else if (assign_temp
)
10850 /* The back end understands a conceptual move (evaluate source;
10851 store into dest), so use that, in case it can determine
10852 that it is going to use, say, two registers as temporaries
10853 anyway. So don't use the temp (and someday avoid generating
10854 it, once this code starts triggering regularly). */
10855 expr_tree
= ffecom_2s (MOVE_EXPR
, void_type_node
,
10859 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
10862 expand_expr_stmt (expr_tree
);
10863 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
10869 expr_tree
= ffecom_2s (MODIFY_EXPR
, void_type_node
,
10873 expand_expr_stmt (expr_tree
);
10877 ffecom_prepare_let_char_ (ffebld_size_known (dest
), source
);
10878 ffecom_prepare_expr_w (NULL_TREE
, dest
);
10880 ffecom_prepare_end ();
10882 ffecom_char_args_ (&dest_tree
, &dest_length
, dest
);
10883 ffecom_let_char_ (dest_tree
, dest_length
, ffebld_size_known (dest
),
10887 /* ffecom_expr -- Transform expr into gcc tree
10890 ffebld expr; // FFE expression.
10891 tree = ffecom_expr(expr);
10893 Recursive descent on expr while making corresponding tree nodes and
10894 attaching type info and such. */
10897 ffecom_expr (ffebld expr
)
10899 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, FALSE
, FALSE
);
10902 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
10905 ffecom_expr_assign (ffebld expr
)
10907 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
10910 /* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
10913 ffecom_expr_assign_w (ffebld expr
)
10915 return ffecom_expr_ (expr
, NULL_TREE
, NULL
, NULL
, TRUE
, FALSE
);
10918 /* Transform expr for use as into read/write tree and stabilize the
10919 reference. Not for use on CHARACTER expressions.
10921 Recursive descent on expr while making corresponding tree nodes and
10922 attaching type info and such. */
10925 ffecom_expr_rw (tree type
, ffebld expr
)
10927 assert (expr
!= NULL
);
10928 /* Different target types not yet supported. */
10929 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
10931 return stabilize_reference (ffecom_expr (expr
));
10934 /* Transform expr for use as into write tree and stabilize the
10935 reference. Not for use on CHARACTER expressions.
10937 Recursive descent on expr while making corresponding tree nodes and
10938 attaching type info and such. */
10941 ffecom_expr_w (tree type
, ffebld expr
)
10943 assert (expr
!= NULL
);
10944 /* Different target types not yet supported. */
10945 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
10947 return stabilize_reference (ffecom_expr (expr
));
10950 /* Do global stuff. */
10953 ffecom_finish_compile ()
10955 assert (ffecom_outer_function_decl_
== NULL_TREE
);
10956 assert (current_function_decl
== NULL_TREE
);
10958 ffeglobal_drive (ffecom_finish_global_
);
10961 /* Public entry point for front end to access finish_decl. */
10964 ffecom_finish_decl (tree decl
, tree init
, bool is_top_level
)
10966 assert (!is_top_level
);
10967 finish_decl (decl
, init
, FALSE
);
10970 /* Finish a program unit. */
10973 ffecom_finish_progunit ()
10975 ffecom_end_compstmt ();
10977 ffecom_previous_function_decl_
= current_function_decl
;
10978 ffecom_which_entrypoint_decl_
= NULL_TREE
;
10980 finish_function (0);
10983 /* Wrapper for get_identifier. pattern is sprintf-like. */
10986 ffecom_get_invented_identifier (const char *pattern
, ...)
10992 va_start (ap
, pattern
);
10993 if (vasprintf (&nam
, pattern
, ap
) == 0)
10996 decl
= get_identifier (nam
);
10998 IDENTIFIER_INVENTED (decl
) = 1;
11003 ffecom_gfrt_basictype (ffecomGfrt gfrt
)
11005 assert (gfrt
< FFECOM_gfrt
);
11007 switch (ffecom_gfrt_type_
[gfrt
])
11009 case FFECOM_rttypeVOID_
:
11010 case FFECOM_rttypeVOIDSTAR_
:
11011 return FFEINFO_basictypeNONE
;
11013 case FFECOM_rttypeFTNINT_
:
11014 return FFEINFO_basictypeINTEGER
;
11016 case FFECOM_rttypeINTEGER_
:
11017 return FFEINFO_basictypeINTEGER
;
11019 case FFECOM_rttypeLONGINT_
:
11020 return FFEINFO_basictypeINTEGER
;
11022 case FFECOM_rttypeLOGICAL_
:
11023 return FFEINFO_basictypeLOGICAL
;
11025 case FFECOM_rttypeREAL_F2C_
:
11026 case FFECOM_rttypeREAL_GNU_
:
11027 return FFEINFO_basictypeREAL
;
11029 case FFECOM_rttypeCOMPLEX_F2C_
:
11030 case FFECOM_rttypeCOMPLEX_GNU_
:
11031 return FFEINFO_basictypeCOMPLEX
;
11033 case FFECOM_rttypeDOUBLE_
:
11034 case FFECOM_rttypeDOUBLEREAL_
:
11035 return FFEINFO_basictypeREAL
;
11037 case FFECOM_rttypeDBLCMPLX_F2C_
:
11038 case FFECOM_rttypeDBLCMPLX_GNU_
:
11039 return FFEINFO_basictypeCOMPLEX
;
11041 case FFECOM_rttypeCHARACTER_
:
11042 return FFEINFO_basictypeCHARACTER
;
11045 return FFEINFO_basictypeANY
;
11050 ffecom_gfrt_kindtype (ffecomGfrt gfrt
)
11052 assert (gfrt
< FFECOM_gfrt
);
11054 switch (ffecom_gfrt_type_
[gfrt
])
11056 case FFECOM_rttypeVOID_
:
11057 case FFECOM_rttypeVOIDSTAR_
:
11058 return FFEINFO_kindtypeNONE
;
11060 case FFECOM_rttypeFTNINT_
:
11061 return FFEINFO_kindtypeINTEGER1
;
11063 case FFECOM_rttypeINTEGER_
:
11064 return FFEINFO_kindtypeINTEGER1
;
11066 case FFECOM_rttypeLONGINT_
:
11067 return FFEINFO_kindtypeINTEGER4
;
11069 case FFECOM_rttypeLOGICAL_
:
11070 return FFEINFO_kindtypeLOGICAL1
;
11072 case FFECOM_rttypeREAL_F2C_
:
11073 case FFECOM_rttypeREAL_GNU_
:
11074 return FFEINFO_kindtypeREAL1
;
11076 case FFECOM_rttypeCOMPLEX_F2C_
:
11077 case FFECOM_rttypeCOMPLEX_GNU_
:
11078 return FFEINFO_kindtypeREAL1
;
11080 case FFECOM_rttypeDOUBLE_
:
11081 case FFECOM_rttypeDOUBLEREAL_
:
11082 return FFEINFO_kindtypeREAL2
;
11084 case FFECOM_rttypeDBLCMPLX_F2C_
:
11085 case FFECOM_rttypeDBLCMPLX_GNU_
:
11086 return FFEINFO_kindtypeREAL2
;
11088 case FFECOM_rttypeCHARACTER_
:
11089 return FFEINFO_kindtypeCHARACTER1
;
11092 return FFEINFO_kindtypeANY
;
11106 tree double_ftype_double
;
11107 tree float_ftype_float
;
11108 tree ldouble_ftype_ldouble
;
11109 tree ffecom_tree_ptr_to_fun_type_void
;
11111 /* This block of code comes from the now-obsolete cktyps.c. It checks
11112 whether the compiler environment is buggy in known ways, some of which
11113 would, if not explicitly checked here, result in subtle bugs in g77. */
11115 if (ffe_is_do_internal_checks ())
11117 static const char names
[][12]
11119 {"bar", "bletch", "foo", "foobar"};
11124 name
= bsearch ("foo", &names
[0], ARRAY_SIZE (names
), sizeof (names
[0]),
11125 (int (*)(const void *, const void *)) strcmp
);
11126 if (name
!= &names
[2][0])
11128 assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11133 ul
= strtoul ("123456789", NULL
, 10);
11134 if (ul
!= 123456789L)
11136 assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11137 in proj.h" == NULL
);
11141 fl
= atof ("56.789");
11142 if ((fl
< 56.788) || (fl
> 56.79))
11144 assert ("atof not type double, fix your #include <stdio.h>"
11150 ffecom_outer_function_decl_
= NULL_TREE
;
11151 current_function_decl
= NULL_TREE
;
11152 named_labels
= NULL_TREE
;
11153 current_binding_level
= NULL_BINDING_LEVEL
;
11154 free_binding_level
= NULL_BINDING_LEVEL
;
11155 /* Make the binding_level structure for global names. */
11157 global_binding_level
= current_binding_level
;
11158 current_binding_level
->prep_state
= 2;
11160 build_common_tree_nodes (1);
11162 /* Define `int' and `char' first so that dbx will output them first. */
11163 pushdecl (build_decl (TYPE_DECL
, get_identifier ("int"),
11164 integer_type_node
));
11165 /* CHARACTER*1 is unsigned in ICHAR contexts. */
11166 char_type_node
= make_unsigned_type (CHAR_TYPE_SIZE
);
11167 pushdecl (build_decl (TYPE_DECL
, get_identifier ("char"),
11169 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long int"),
11170 long_integer_type_node
));
11171 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned int"),
11172 unsigned_type_node
));
11173 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long unsigned int"),
11174 long_unsigned_type_node
));
11175 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long int"),
11176 long_long_integer_type_node
));
11177 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long long unsigned int"),
11178 long_long_unsigned_type_node
));
11179 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short int"),
11180 short_integer_type_node
));
11181 pushdecl (build_decl (TYPE_DECL
, get_identifier ("short unsigned int"),
11182 short_unsigned_type_node
));
11184 /* Set the sizetype before we make other types. This *should* be the
11185 first type we create. */
11188 (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE
))));
11189 ffecom_typesize_pointer_
11190 = TREE_INT_CST_LOW (TYPE_SIZE (sizetype
)) / BITS_PER_UNIT
;
11192 build_common_tree_nodes_2 (0);
11194 /* Define both `signed char' and `unsigned char'. */
11195 pushdecl (build_decl (TYPE_DECL
, get_identifier ("signed char"),
11196 signed_char_type_node
));
11198 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned char"),
11199 unsigned_char_type_node
));
11201 pushdecl (build_decl (TYPE_DECL
, get_identifier ("float"),
11203 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double"),
11204 double_type_node
));
11205 pushdecl (build_decl (TYPE_DECL
, get_identifier ("long double"),
11206 long_double_type_node
));
11208 /* For now, override what build_common_tree_nodes has done. */
11209 complex_integer_type_node
= ffecom_make_complex_type_ (integer_type_node
);
11210 complex_float_type_node
= ffecom_make_complex_type_ (float_type_node
);
11211 complex_double_type_node
= ffecom_make_complex_type_ (double_type_node
);
11212 complex_long_double_type_node
11213 = ffecom_make_complex_type_ (long_double_type_node
);
11215 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex int"),
11216 complex_integer_type_node
));
11217 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex float"),
11218 complex_float_type_node
));
11219 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex double"),
11220 complex_double_type_node
));
11221 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex long double"),
11222 complex_long_double_type_node
));
11224 pushdecl (build_decl (TYPE_DECL
, get_identifier ("void"),
11226 /* We are not going to have real types in C with less than byte alignment,
11227 so we might as well not have any types that claim to have it. */
11228 TYPE_ALIGN (void_type_node
) = BITS_PER_UNIT
;
11229 TYPE_USER_ALIGN (void_type_node
) = 0;
11231 string_type_node
= build_pointer_type (char_type_node
);
11233 ffecom_tree_fun_type_void
11234 = build_function_type (void_type_node
, NULL_TREE
);
11236 ffecom_tree_ptr_to_fun_type_void
11237 = build_pointer_type (ffecom_tree_fun_type_void
);
11239 endlink
= tree_cons (NULL_TREE
, void_type_node
, NULL_TREE
);
11242 = build_function_type (float_type_node
,
11243 tree_cons (NULL_TREE
, float_type_node
, endlink
));
11245 double_ftype_double
11246 = build_function_type (double_type_node
,
11247 tree_cons (NULL_TREE
, double_type_node
, endlink
));
11249 ldouble_ftype_ldouble
11250 = build_function_type (long_double_type_node
,
11251 tree_cons (NULL_TREE
, long_double_type_node
,
11254 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11255 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11257 ffecom_tree_type
[i
][j
] = NULL_TREE
;
11258 ffecom_tree_fun_type
[i
][j
] = NULL_TREE
;
11259 ffecom_tree_ptr_to_fun_type
[i
][j
] = NULL_TREE
;
11260 ffecom_f2c_typecode_
[i
][j
] = -1;
11263 /* Set up standard g77 types. Note that INTEGER and LOGICAL are set
11264 to size FLOAT_TYPE_SIZE because they have to be the same size as
11265 REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11266 Compiler options and other such stuff that change the ways these
11267 types are set should not affect this particular setup. */
11269 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
]
11270 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
11271 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer"),
11273 type
= ffetype_new ();
11275 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER1
,
11277 ffetype_set_ams (type
,
11278 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11279 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11280 ffetype_set_star (base_type
,
11281 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11283 ffetype_set_kind (base_type
, 1, type
);
11284 ffecom_typesize_integer1_
= ffetype_size (type
);
11285 assert (ffetype_size (type
) == sizeof (ffetargetInteger1
));
11287 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER1
]
11288 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
); /* HOLLERITH means unsigned. */
11289 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned"),
11292 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER2
]
11293 = t
= make_signed_type (CHAR_TYPE_SIZE
);
11294 pushdecl (build_decl (TYPE_DECL
, get_identifier ("byte"),
11296 type
= ffetype_new ();
11297 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER2
,
11299 ffetype_set_ams (type
,
11300 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11301 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11302 ffetype_set_star (base_type
,
11303 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11305 ffetype_set_kind (base_type
, 3, type
);
11306 assert (ffetype_size (type
) == sizeof (ffetargetInteger2
));
11308 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER2
]
11309 = t
= make_unsigned_type (CHAR_TYPE_SIZE
);
11310 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned byte"),
11313 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER3
]
11314 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
11315 pushdecl (build_decl (TYPE_DECL
, get_identifier ("word"),
11317 type
= ffetype_new ();
11318 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER3
,
11320 ffetype_set_ams (type
,
11321 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11322 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11323 ffetype_set_star (base_type
,
11324 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11326 ffetype_set_kind (base_type
, 6, type
);
11327 assert (ffetype_size (type
) == sizeof (ffetargetInteger3
));
11329 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER3
]
11330 = t
= make_unsigned_type (CHAR_TYPE_SIZE
* 2);
11331 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned word"),
11334 ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER4
]
11335 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
11336 pushdecl (build_decl (TYPE_DECL
, get_identifier ("integer4"),
11338 type
= ffetype_new ();
11339 ffeinfo_set_type (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGER4
,
11341 ffetype_set_ams (type
,
11342 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11343 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11344 ffetype_set_star (base_type
,
11345 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11347 ffetype_set_kind (base_type
, 2, type
);
11348 assert (ffetype_size (type
) == sizeof (ffetargetInteger4
));
11350 ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][FFEINFO_kindtypeINTEGER4
]
11351 = t
= make_unsigned_type (FLOAT_TYPE_SIZE
* 2);
11352 pushdecl (build_decl (TYPE_DECL
, get_identifier ("unsigned4"),
11356 if (ffe_is_do_internal_checks ()
11357 && LONG_TYPE_SIZE
!= FLOAT_TYPE_SIZE
11358 && LONG_TYPE_SIZE
!= CHAR_TYPE_SIZE
11359 && LONG_TYPE_SIZE
!= SHORT_TYPE_SIZE
11360 && LONG_TYPE_SIZE
!= LONG_LONG_TYPE_SIZE
)
11362 fprintf (stderr
, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11367 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL1
]
11368 = t
= make_signed_type (FLOAT_TYPE_SIZE
);
11369 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical"),
11371 type
= ffetype_new ();
11373 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL1
,
11375 ffetype_set_ams (type
,
11376 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11377 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11378 ffetype_set_star (base_type
,
11379 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11381 ffetype_set_kind (base_type
, 1, type
);
11382 assert (ffetype_size (type
) == sizeof (ffetargetLogical1
));
11384 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL2
]
11385 = t
= make_signed_type (CHAR_TYPE_SIZE
);
11386 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical2"),
11388 type
= ffetype_new ();
11389 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL2
,
11391 ffetype_set_ams (type
,
11392 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11393 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11394 ffetype_set_star (base_type
,
11395 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11397 ffetype_set_kind (base_type
, 3, type
);
11398 assert (ffetype_size (type
) == sizeof (ffetargetLogical2
));
11400 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL3
]
11401 = t
= make_signed_type (CHAR_TYPE_SIZE
* 2);
11402 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical3"),
11404 type
= ffetype_new ();
11405 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL3
,
11407 ffetype_set_ams (type
,
11408 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11409 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11410 ffetype_set_star (base_type
,
11411 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11413 ffetype_set_kind (base_type
, 6, type
);
11414 assert (ffetype_size (type
) == sizeof (ffetargetLogical3
));
11416 ffecom_tree_type
[FFEINFO_basictypeLOGICAL
][FFEINFO_kindtypeLOGICAL4
]
11417 = t
= make_signed_type (FLOAT_TYPE_SIZE
* 2);
11418 pushdecl (build_decl (TYPE_DECL
, get_identifier ("logical4"),
11420 type
= ffetype_new ();
11421 ffeinfo_set_type (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICAL4
,
11423 ffetype_set_ams (type
,
11424 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11425 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11426 ffetype_set_star (base_type
,
11427 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11429 ffetype_set_kind (base_type
, 2, type
);
11430 assert (ffetype_size (type
) == sizeof (ffetargetLogical4
));
11432 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
11433 = t
= make_node (REAL_TYPE
);
11434 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
;
11435 pushdecl (build_decl (TYPE_DECL
, get_identifier ("real"),
11438 type
= ffetype_new ();
11440 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREAL1
,
11442 ffetype_set_ams (type
,
11443 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11444 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11445 ffetype_set_star (base_type
,
11446 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11448 ffetype_set_kind (base_type
, 1, type
);
11449 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]
11450 = FFETARGET_f2cTYREAL
;
11451 assert (ffetype_size (type
) == sizeof (ffetargetReal1
));
11453 ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREALDOUBLE
]
11454 = t
= make_node (REAL_TYPE
);
11455 TYPE_PRECISION (t
) = FLOAT_TYPE_SIZE
* 2; /* Always twice REAL. */
11456 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double precision"),
11459 type
= ffetype_new ();
11460 ffeinfo_set_type (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREALDOUBLE
,
11462 ffetype_set_ams (type
,
11463 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11464 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11465 ffetype_set_star (base_type
,
11466 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11468 ffetype_set_kind (base_type
, 2, type
);
11469 ffecom_f2c_typecode_
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]
11470 = FFETARGET_f2cTYDREAL
;
11471 assert (ffetype_size (type
) == sizeof (ffetargetReal2
));
11473 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
11474 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL1
]);
11475 pushdecl (build_decl (TYPE_DECL
, get_identifier ("complex"),
11477 type
= ffetype_new ();
11479 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREAL1
,
11481 ffetype_set_ams (type
,
11482 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11483 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11484 ffetype_set_star (base_type
,
11485 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11487 ffetype_set_kind (base_type
, 1, type
);
11488 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL1
]
11489 = FFETARGET_f2cTYCOMPLEX
;
11490 assert (ffetype_size (type
) == sizeof (ffetargetComplex1
));
11492 ffecom_tree_type
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREALDOUBLE
]
11493 = t
= ffecom_make_complex_type_ (ffecom_tree_type
[FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
]);
11494 pushdecl (build_decl (TYPE_DECL
, get_identifier ("double complex"),
11496 type
= ffetype_new ();
11497 ffeinfo_set_type (FFEINFO_basictypeCOMPLEX
, FFEINFO_kindtypeREALDOUBLE
,
11499 ffetype_set_ams (type
,
11500 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11501 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11502 ffetype_set_star (base_type
,
11503 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / CHAR_TYPE_SIZE
,
11505 ffetype_set_kind (base_type
, 2,
11507 ffecom_f2c_typecode_
[FFEINFO_basictypeCOMPLEX
][FFEINFO_kindtypeREAL2
]
11508 = FFETARGET_f2cTYDCOMPLEX
;
11509 assert (ffetype_size (type
) == sizeof (ffetargetComplex2
));
11511 /* Make function and ptr-to-function types for non-CHARACTER types. */
11513 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11514 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11516 if ((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
11518 if (i
== FFEINFO_basictypeINTEGER
)
11520 /* Figure out the smallest INTEGER type that can hold
11521 a pointer on this machine. */
11522 if (GET_MODE_SIZE (TYPE_MODE (t
))
11523 >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
11525 if ((ffecom_pointer_kind_
== FFEINFO_kindtypeNONE
)
11526 || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type
[i
][ffecom_pointer_kind_
]))
11527 > GET_MODE_SIZE (TYPE_MODE (t
))))
11528 ffecom_pointer_kind_
= j
;
11531 else if (i
== FFEINFO_basictypeCOMPLEX
)
11532 t
= void_type_node
;
11533 /* For f2c compatibility, REAL functions are really
11534 implemented as DOUBLE PRECISION. */
11535 else if ((i
== FFEINFO_basictypeREAL
)
11536 && (j
== FFEINFO_kindtypeREAL1
))
11537 t
= ffecom_tree_type
11538 [FFEINFO_basictypeREAL
][FFEINFO_kindtypeREAL2
];
11540 t
= ffecom_tree_fun_type
[i
][j
] = build_function_type (t
,
11542 ffecom_tree_ptr_to_fun_type
[i
][j
] = build_pointer_type (t
);
11546 /* Set up pointer types. */
11548 if (ffecom_pointer_kind_
== FFEINFO_basictypeNONE
)
11549 fatal_error ("no INTEGER type can hold a pointer on this configuration");
11550 else if (0 && ffe_is_do_internal_checks ())
11551 fprintf (stderr
, "Pointer type kt=%d\n", ffecom_pointer_kind_
);
11552 ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER
,
11553 FFEINFO_kindtypeINTEGERDEFAULT
),
11555 ffeinfo_type (FFEINFO_basictypeINTEGER
,
11556 ffecom_pointer_kind_
));
11558 if (ffe_is_ugly_assign ())
11559 ffecom_label_kind_
= ffecom_pointer_kind_
; /* Require ASSIGN etc to this. */
11561 ffecom_label_kind_
= FFEINFO_kindtypeINTEGERDEFAULT
;
11562 if (0 && ffe_is_do_internal_checks ())
11563 fprintf (stderr
, "Label type kt=%d\n", ffecom_label_kind_
);
11565 ffecom_integer_type_node
11566 = ffecom_tree_type
[FFEINFO_basictypeINTEGER
][FFEINFO_kindtypeINTEGER1
];
11567 ffecom_integer_zero_node
= convert (ffecom_integer_type_node
,
11568 integer_zero_node
);
11569 ffecom_integer_one_node
= convert (ffecom_integer_type_node
,
11572 /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11573 Turns out that by TYLONG, runtime/libI77/lio.h really means
11574 "whatever size an ftnint is". For consistency and sanity,
11575 com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11576 all are INTEGER, which we also make out of whatever back-end
11577 integer type is FLOAT_TYPE_SIZE bits wide. This change, from
11578 LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11579 accommodate machines like the Alpha. Note that this suggests
11580 f2c and libf2c are missing a distinction perhaps needed on
11581 some machines between "int" and "long int". -- burley 0.5.5 950215 */
11583 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, FLOAT_TYPE_SIZE
,
11584 FFETARGET_f2cTYLONG
);
11585 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, SHORT_TYPE_SIZE
,
11586 FFETARGET_f2cTYSHORT
);
11587 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, CHAR_TYPE_SIZE
,
11588 FFETARGET_f2cTYINT1
);
11589 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER
, LONG_LONG_TYPE_SIZE
,
11590 FFETARGET_f2cTYQUAD
);
11591 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, FLOAT_TYPE_SIZE
,
11592 FFETARGET_f2cTYLOGICAL
);
11593 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, SHORT_TYPE_SIZE
,
11594 FFETARGET_f2cTYLOGICAL2
);
11595 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, CHAR_TYPE_SIZE
,
11596 FFETARGET_f2cTYLOGICAL1
);
11597 /* ~~~Not really such a type in libf2c, e.g. I/O support? */
11598 ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL
, LONG_LONG_TYPE_SIZE
,
11599 FFETARGET_f2cTYQUAD
);
11601 /* CHARACTER stuff is all special-cased, so it is not handled in the above
11602 loop. CHARACTER items are built as arrays of unsigned char. */
11604 ffecom_tree_type
[FFEINFO_basictypeCHARACTER
]
11605 [FFEINFO_kindtypeCHARACTER1
] = t
= char_type_node
;
11606 type
= ffetype_new ();
11608 ffeinfo_set_type (FFEINFO_basictypeCHARACTER
,
11609 FFEINFO_kindtypeCHARACTER1
,
11611 ffetype_set_ams (type
,
11612 TYPE_ALIGN (t
) / BITS_PER_UNIT
, 0,
11613 TREE_INT_CST_LOW (TYPE_SIZE (t
)) / BITS_PER_UNIT
);
11614 ffetype_set_kind (base_type
, 1, type
);
11615 assert (ffetype_size (type
)
11616 == sizeof (((ffetargetCharacter1
) { 0, NULL
}).text
[0]));
11618 ffecom_tree_fun_type
[FFEINFO_basictypeCHARACTER
]
11619 [FFEINFO_kindtypeCHARACTER1
] = ffecom_tree_fun_type_void
;
11620 ffecom_tree_ptr_to_fun_type
[FFEINFO_basictypeCHARACTER
]
11621 [FFEINFO_kindtypeCHARACTER1
]
11622 = ffecom_tree_ptr_to_fun_type_void
;
11623 ffecom_f2c_typecode_
[FFEINFO_basictypeCHARACTER
][FFEINFO_kindtypeCHARACTER1
]
11624 = FFETARGET_f2cTYCHAR
;
11626 ffecom_f2c_typecode_
[FFEINFO_basictypeANY
][FFEINFO_kindtypeANY
]
11629 /* Make multi-return-value type and fields. */
11631 ffecom_multi_type_node_
= make_node (UNION_TYPE
);
11635 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
11636 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
11640 if (ffecom_tree_type
[i
][j
] == NULL_TREE
)
11641 continue; /* Not supported. */
11642 sprintf (&name
[0], "bt_%s_kt_%s",
11643 ffeinfo_basictype_string ((ffeinfoBasictype
) i
),
11644 ffeinfo_kindtype_string ((ffeinfoKindtype
) j
));
11645 ffecom_multi_fields_
[i
][j
] = build_decl (FIELD_DECL
,
11646 get_identifier (name
),
11647 ffecom_tree_type
[i
][j
]);
11648 DECL_CONTEXT (ffecom_multi_fields_
[i
][j
])
11649 = ffecom_multi_type_node_
;
11650 DECL_ALIGN (ffecom_multi_fields_
[i
][j
]) = 0;
11651 DECL_USER_ALIGN (ffecom_multi_fields_
[i
][j
]) = 0;
11652 TREE_CHAIN (ffecom_multi_fields_
[i
][j
]) = field
;
11653 field
= ffecom_multi_fields_
[i
][j
];
11656 TYPE_FIELDS (ffecom_multi_type_node_
) = field
;
11657 layout_type (ffecom_multi_type_node_
);
11659 /* Subroutines usually return integer because they might have alternate
11662 ffecom_tree_subr_type
11663 = build_function_type (integer_type_node
, NULL_TREE
);
11664 ffecom_tree_ptr_to_subr_type
11665 = build_pointer_type (ffecom_tree_subr_type
);
11666 ffecom_tree_blockdata_type
11667 = build_function_type (void_type_node
, NULL_TREE
);
11669 builtin_function ("__builtin_sqrtf", float_ftype_float
,
11670 BUILT_IN_SQRTF
, BUILT_IN_NORMAL
, "sqrtf", NULL_TREE
);
11671 builtin_function ("__builtin_sqrt", double_ftype_double
,
11672 BUILT_IN_SQRT
, BUILT_IN_NORMAL
, "sqrt", NULL_TREE
);
11673 builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble
,
11674 BUILT_IN_SQRTL
, BUILT_IN_NORMAL
, "sqrtl", NULL_TREE
);
11675 builtin_function ("__builtin_sinf", float_ftype_float
,
11676 BUILT_IN_SINF
, BUILT_IN_NORMAL
, "sinf", NULL_TREE
);
11677 builtin_function ("__builtin_sin", double_ftype_double
,
11678 BUILT_IN_SIN
, BUILT_IN_NORMAL
, "sin", NULL_TREE
);
11679 builtin_function ("__builtin_sinl", ldouble_ftype_ldouble
,
11680 BUILT_IN_SINL
, BUILT_IN_NORMAL
, "sinl", NULL_TREE
);
11681 builtin_function ("__builtin_cosf", float_ftype_float
,
11682 BUILT_IN_COSF
, BUILT_IN_NORMAL
, "cosf", NULL_TREE
);
11683 builtin_function ("__builtin_cos", double_ftype_double
,
11684 BUILT_IN_COS
, BUILT_IN_NORMAL
, "cos", NULL_TREE
);
11685 builtin_function ("__builtin_cosl", ldouble_ftype_ldouble
,
11686 BUILT_IN_COSL
, BUILT_IN_NORMAL
, "cosl", NULL_TREE
);
11688 pedantic_lvalues
= FALSE
;
11690 ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node
,
11693 ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node
,
11696 ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node
,
11699 ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node
,
11700 FFECOM_f2cDOUBLEREAL
,
11702 ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node
,
11705 ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node
,
11706 FFECOM_f2cDOUBLECOMPLEX
,
11708 ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node
,
11711 ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node
,
11714 ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node
,
11717 ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node
,
11720 ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node
,
11724 ffecom_f2c_ftnlen_zero_node
11725 = convert (ffecom_f2c_ftnlen_type_node
, integer_zero_node
);
11727 ffecom_f2c_ftnlen_one_node
11728 = convert (ffecom_f2c_ftnlen_type_node
, integer_one_node
);
11730 ffecom_f2c_ftnlen_two_node
= build_int_2 (2, 0);
11731 TREE_TYPE (ffecom_f2c_ftnlen_two_node
) = ffecom_integer_type_node
;
11733 ffecom_f2c_ptr_to_ftnlen_type_node
11734 = build_pointer_type (ffecom_f2c_ftnlen_type_node
);
11736 ffecom_f2c_ptr_to_ftnint_type_node
11737 = build_pointer_type (ffecom_f2c_ftnint_type_node
);
11739 ffecom_f2c_ptr_to_integer_type_node
11740 = build_pointer_type (ffecom_f2c_integer_type_node
);
11742 ffecom_f2c_ptr_to_real_type_node
11743 = build_pointer_type (ffecom_f2c_real_type_node
);
11745 ffecom_float_zero_
= build_real (float_type_node
, dconst0
);
11746 ffecom_double_zero_
= build_real (double_type_node
, dconst0
);
11748 REAL_VALUE_TYPE point_5
;
11750 REAL_ARITHMETIC (point_5
, RDIV_EXPR
, dconst1
, dconst2
);
11751 ffecom_float_half_
= build_real (float_type_node
, point_5
);
11752 ffecom_double_half_
= build_real (double_type_node
, point_5
);
11755 /* Do "extern int xargc;". */
11757 ffecom_tree_xargc_
= build_decl (VAR_DECL
,
11758 get_identifier ("f__xargc"),
11759 integer_type_node
);
11760 DECL_EXTERNAL (ffecom_tree_xargc_
) = 1;
11761 TREE_STATIC (ffecom_tree_xargc_
) = 1;
11762 TREE_PUBLIC (ffecom_tree_xargc_
) = 1;
11763 ffecom_tree_xargc_
= start_decl (ffecom_tree_xargc_
, FALSE
);
11764 finish_decl (ffecom_tree_xargc_
, NULL_TREE
, FALSE
);
11766 #if 0 /* This is being fixed, and seems to be working now. */
11767 if ((FLOAT_TYPE_SIZE
!= 32)
11768 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))) != 32))
11770 warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
11771 (int) FLOAT_TYPE_SIZE
);
11772 warning ("and pointers are %d bits wide, but g77 doesn't yet work",
11773 (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node
))));
11774 warning ("properly unless they all are 32 bits wide");
11775 warning ("Please keep this in mind before you report bugs.");
11779 #if 0 /* Code in ste.c that would crash has been commented out. */
11780 if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
11781 < TYPE_PRECISION (string_type_node
))
11782 /* I/O will probably crash. */
11783 warning ("configuration: char * holds %d bits, but ftnlen only %d",
11784 TYPE_PRECISION (string_type_node
),
11785 TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
));
11788 #if 0 /* ASSIGN-related stuff has been changed to accommodate this. */
11789 if (TYPE_PRECISION (ffecom_integer_type_node
)
11790 < TYPE_PRECISION (string_type_node
))
11791 /* ASSIGN 10 TO I will crash. */
11792 warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
11793 ASSIGN statement might fail",
11794 TYPE_PRECISION (string_type_node
),
11795 TYPE_PRECISION (ffecom_integer_type_node
));
11799 /* ffecom_init_2 -- Initialize
11801 ffecom_init_2(); */
11806 assert (ffecom_outer_function_decl_
== NULL_TREE
);
11807 assert (current_function_decl
== NULL_TREE
);
11808 assert (ffecom_which_entrypoint_decl_
== NULL_TREE
);
11810 ffecom_master_arglist_
= NULL
;
11812 ffecom_primary_entry_
= NULL
;
11813 ffecom_is_altreturning_
= FALSE
;
11814 ffecom_func_result_
= NULL_TREE
;
11815 ffecom_multi_retval_
= NULL_TREE
;
11818 /* ffecom_list_expr -- Transform list of exprs into gcc tree
11821 ffebld expr; // FFE opITEM list.
11822 tree = ffecom_list_expr(expr);
11824 List of actual args is transformed into corresponding gcc backend list. */
11827 ffecom_list_expr (ffebld expr
)
11830 tree
*plist
= &list
;
11831 tree trail
= NULL_TREE
; /* Append char length args here. */
11832 tree
*ptrail
= &trail
;
11835 while (expr
!= NULL
)
11837 tree texpr
= ffecom_arg_expr (ffebld_head (expr
), &length
);
11839 if (texpr
== error_mark_node
)
11840 return error_mark_node
;
11842 *plist
= build_tree_list (NULL_TREE
, texpr
);
11843 plist
= &TREE_CHAIN (*plist
);
11844 expr
= ffebld_trail (expr
);
11845 if (length
!= NULL_TREE
)
11847 *ptrail
= build_tree_list (NULL_TREE
, length
);
11848 ptrail
= &TREE_CHAIN (*ptrail
);
11857 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
11860 ffebld expr; // FFE opITEM list.
11861 tree = ffecom_list_ptr_to_expr(expr);
11863 List of actual args is transformed into corresponding gcc backend list for
11864 use in calling an external procedure (vs. a statement function). */
11867 ffecom_list_ptr_to_expr (ffebld expr
)
11870 tree
*plist
= &list
;
11871 tree trail
= NULL_TREE
; /* Append char length args here. */
11872 tree
*ptrail
= &trail
;
11875 while (expr
!= NULL
)
11877 tree texpr
= ffecom_arg_ptr_to_expr (ffebld_head (expr
), &length
);
11879 if (texpr
== error_mark_node
)
11880 return error_mark_node
;
11882 *plist
= build_tree_list (NULL_TREE
, texpr
);
11883 plist
= &TREE_CHAIN (*plist
);
11884 expr
= ffebld_trail (expr
);
11885 if (length
!= NULL_TREE
)
11887 *ptrail
= build_tree_list (NULL_TREE
, length
);
11888 ptrail
= &TREE_CHAIN (*ptrail
);
11897 /* Obtain gcc's LABEL_DECL tree for label. */
11900 ffecom_lookup_label (ffelab label
)
11904 if (ffelab_hook (label
) == NULL_TREE
)
11906 char labelname
[16];
11908 switch (ffelab_type (label
))
11910 case FFELAB_typeLOOPEND
:
11911 case FFELAB_typeNOTLOOP
:
11912 case FFELAB_typeENDIF
:
11913 sprintf (labelname
, "%" ffelabValue_f
"u", ffelab_value (label
));
11914 glabel
= build_decl (LABEL_DECL
, get_identifier (labelname
),
11916 DECL_CONTEXT (glabel
) = current_function_decl
;
11917 DECL_MODE (glabel
) = VOIDmode
;
11920 case FFELAB_typeFORMAT
:
11921 glabel
= build_decl (VAR_DECL
,
11922 ffecom_get_invented_identifier
11923 ("__g77_format_%d", (int) ffelab_value (label
)),
11924 build_type_variant (build_array_type
11928 TREE_CONSTANT (glabel
) = 1;
11929 TREE_STATIC (glabel
) = 1;
11930 DECL_CONTEXT (glabel
) = current_function_decl
;
11931 DECL_INITIAL (glabel
) = NULL
;
11932 make_decl_rtl (glabel
, NULL
);
11933 expand_decl (glabel
);
11935 ffecom_save_tree_forever (glabel
);
11939 case FFELAB_typeANY
:
11940 glabel
= error_mark_node
;
11944 assert ("bad label type" == NULL
);
11948 ffelab_set_hook (label
, glabel
);
11952 glabel
= ffelab_hook (label
);
11958 /* Stabilizes the arguments. Don't use this if the lhs and rhs come from
11959 a single source specification (as in the fourth argument of MVBITS).
11960 If the type is NULL_TREE, the type of lhs is used to make the type of
11961 the MODIFY_EXPR. */
11964 ffecom_modify (tree newtype
, tree lhs
,
11967 if (lhs
== error_mark_node
|| rhs
== error_mark_node
)
11968 return error_mark_node
;
11970 if (newtype
== NULL_TREE
)
11971 newtype
= TREE_TYPE (lhs
);
11973 if (TREE_SIDE_EFFECTS (lhs
))
11974 lhs
= stabilize_reference (lhs
);
11976 return ffecom_2s (MODIFY_EXPR
, newtype
, lhs
, rhs
);
11979 /* Register source file name. */
11982 ffecom_file (const char *name
)
11984 ffecom_file_ (name
);
11987 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
11990 ffecom_notify_init_storage(st);
11992 Gets called when all possible units in an aggregate storage area (a LOCAL
11993 with equivalences or a COMMON) have been initialized. The initialization
11994 info either is in ffestorag_init or, if that is NULL,
11995 ffestorag_accretion:
11997 ffestorag_init may contain an opCONTER or opARRTER. opCONTER may occur
11998 even for an array if the array is one element in length!
12000 ffestorag_accretion will contain an opACCTER. It is much like an
12001 opARRTER except it has an ffebit object in it instead of just a size.
12002 The back end can use the info in the ffebit object, if it wants, to
12003 reduce the amount of actual initialization, but in any case it should
12004 kill the ffebit object when done. Also, set accretion to NULL but
12005 init to a non-NULL value.
12007 After performing initialization, DO NOT set init to NULL, because that'll
12008 tell the front end it is ok for more initialization to happen. Instead,
12009 set init to an opANY expression or some such thing that you can use to
12010 tell that you've already initialized the object.
12013 Support two-pass FFE. */
12016 ffecom_notify_init_storage (ffestorag st
)
12018 ffebld init
; /* The initialization expression. */
12020 if (ffestorag_init (st
) == NULL
)
12022 init
= ffestorag_accretion (st
);
12023 assert (init
!= NULL
);
12024 ffestorag_set_accretion (st
, NULL
);
12025 ffestorag_set_accretes (st
, 0);
12026 ffestorag_set_init (st
, init
);
12030 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12033 ffecom_notify_init_symbol(s);
12035 Gets called when all possible units in a symbol (not placed in COMMON
12036 or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12037 have been initialized. The initialization info either is in
12038 ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12040 ffesymbol_init may contain an opCONTER or opARRTER. opCONTER may occur
12041 even for an array if the array is one element in length!
12043 ffesymbol_accretion will contain an opACCTER. It is much like an
12044 opARRTER except it has an ffebit object in it instead of just a size.
12045 The back end can use the info in the ffebit object, if it wants, to
12046 reduce the amount of actual initialization, but in any case it should
12047 kill the ffebit object when done. Also, set accretion to NULL but
12048 init to a non-NULL value.
12050 After performing initialization, DO NOT set init to NULL, because that'll
12051 tell the front end it is ok for more initialization to happen. Instead,
12052 set init to an opANY expression or some such thing that you can use to
12053 tell that you've already initialized the object.
12056 Support two-pass FFE. */
12059 ffecom_notify_init_symbol (ffesymbol s
)
12061 ffebld init
; /* The initialization expression. */
12063 if (ffesymbol_storage (s
) == NULL
)
12064 return; /* Do nothing until COMMON/EQUIVALENCE
12065 possibilities checked. */
12067 if ((ffesymbol_init (s
) == NULL
)
12068 && ((init
= ffesymbol_accretion (s
)) != NULL
))
12070 ffesymbol_set_accretion (s
, NULL
);
12071 ffesymbol_set_accretes (s
, 0);
12072 ffesymbol_set_init (s
, init
);
12076 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12079 ffecom_notify_primary_entry(s);
12081 Gets called when implicit or explicit PROGRAM statement seen or when
12082 FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12083 global symbol that serves as the entry point. */
12086 ffecom_notify_primary_entry (ffesymbol s
)
12088 ffecom_primary_entry_
= s
;
12089 ffecom_primary_entry_kind_
= ffesymbol_kind (s
);
12091 if ((ffecom_primary_entry_kind_
== FFEINFO_kindFUNCTION
)
12092 || (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
))
12093 ffecom_primary_entry_is_proc_
= TRUE
;
12095 ffecom_primary_entry_is_proc_
= FALSE
;
12097 if (!ffe_is_silent ())
12099 if (ffecom_primary_entry_kind_
== FFEINFO_kindPROGRAM
)
12100 fprintf (stderr
, "%s:\n", ffesymbol_text (s
));
12102 fprintf (stderr
, " %s:\n", ffesymbol_text (s
));
12105 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
)
12110 for (list
= ffesymbol_dummyargs (s
);
12112 list
= ffebld_trail (list
))
12114 arg
= ffebld_head (list
);
12115 if (ffebld_op (arg
) == FFEBLD_opSTAR
)
12117 ffecom_is_altreturning_
= TRUE
;
12125 ffecom_open_include (char *name
, ffewhereLine l
, ffewhereColumn c
)
12127 return ffecom_open_include_ (name
, l
, c
);
12130 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12133 ffebld expr; // FFE expression.
12134 tree = ffecom_ptr_to_expr(expr);
12136 Like ffecom_expr, but sticks address-of in front of most things. */
12139 ffecom_ptr_to_expr (ffebld expr
)
12142 ffeinfoBasictype bt
;
12143 ffeinfoKindtype kt
;
12146 assert (expr
!= NULL
);
12148 switch (ffebld_op (expr
))
12150 case FFEBLD_opSYMTER
:
12151 s
= ffebld_symter (expr
);
12152 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
12156 ix
= ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr
));
12157 assert (ix
!= FFECOM_gfrt
);
12158 if ((item
= ffecom_gfrt_
[ix
]) == NULL_TREE
)
12160 ffecom_make_gfrt_ (ix
);
12161 item
= ffecom_gfrt_
[ix
];
12166 item
= ffesymbol_hook (s
).decl_tree
;
12167 if (item
== NULL_TREE
)
12169 s
= ffecom_sym_transform_ (s
);
12170 item
= ffesymbol_hook (s
).decl_tree
;
12173 assert (item
!= NULL
);
12174 if (item
== error_mark_node
)
12176 if (!ffesymbol_hook (s
).addr
)
12177 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12181 case FFEBLD_opARRAYREF
:
12182 return ffecom_arrayref_ (NULL_TREE
, expr
, 1);
12184 case FFEBLD_opCONTER
:
12186 bt
= ffeinfo_basictype (ffebld_info (expr
));
12187 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12189 item
= ffecom_constantunion (&ffebld_constant_union
12190 (ffebld_conter (expr
)), bt
, kt
,
12191 ffecom_tree_type
[bt
][kt
]);
12192 if (item
== error_mark_node
)
12193 return error_mark_node
;
12194 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12199 return error_mark_node
;
12202 bt
= ffeinfo_basictype (ffebld_info (expr
));
12203 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12205 item
= ffecom_expr (expr
);
12206 if (item
== error_mark_node
)
12207 return error_mark_node
;
12209 /* The back end currently optimizes a bit too zealously for us, in that
12210 we fail JCB001 if the following block of code is omitted. It checks
12211 to see if the transformed expression is a symbol or array reference,
12212 and encloses it in a SAVE_EXPR if that is the case. */
12215 if ((TREE_CODE (item
) == VAR_DECL
)
12216 || (TREE_CODE (item
) == PARM_DECL
)
12217 || (TREE_CODE (item
) == RESULT_DECL
)
12218 || (TREE_CODE (item
) == INDIRECT_REF
)
12219 || (TREE_CODE (item
) == ARRAY_REF
)
12220 || (TREE_CODE (item
) == COMPONENT_REF
)
12222 || (TREE_CODE (item
) == OFFSET_REF
)
12224 || (TREE_CODE (item
) == BUFFER_REF
)
12225 || (TREE_CODE (item
) == REALPART_EXPR
)
12226 || (TREE_CODE (item
) == IMAGPART_EXPR
))
12228 item
= ffecom_save_tree (item
);
12231 item
= ffecom_1 (ADDR_EXPR
, build_pointer_type (TREE_TYPE (item
)),
12236 assert ("fall-through error" == NULL
);
12237 return error_mark_node
;
12240 /* Obtain a temp var with given data type.
12242 size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12243 or >= 0 for a CHARACTER type.
12245 elements is -1 for a scalar or > 0 for an array of type. */
12248 ffecom_make_tempvar (const char *commentary
, tree type
,
12249 ffetargetCharacterSize size
, int elements
)
12252 static int mynumber
;
12254 assert (current_binding_level
->prep_state
< 2);
12256 if (type
== error_mark_node
)
12257 return error_mark_node
;
12259 if (size
!= FFETARGET_charactersizeNONE
)
12260 type
= build_array_type (type
,
12261 build_range_type (ffecom_f2c_ftnlen_type_node
,
12262 ffecom_f2c_ftnlen_one_node
,
12263 build_int_2 (size
, 0)));
12264 if (elements
!= -1)
12265 type
= build_array_type (type
,
12266 build_range_type (integer_type_node
,
12268 build_int_2 (elements
- 1,
12270 t
= build_decl (VAR_DECL
,
12271 ffecom_get_invented_identifier ("__g77_%s_%d",
12276 t
= start_decl (t
, FALSE
);
12277 finish_decl (t
, NULL_TREE
, FALSE
);
12282 /* Prepare argument pointer to expression.
12284 Like ffecom_prepare_expr, except for expressions to be evaluated
12285 via ffecom_arg_ptr_to_expr. */
12288 ffecom_prepare_arg_ptr_to_expr (ffebld expr
)
12290 /* ~~For now, it seems to be the same thing. */
12291 ffecom_prepare_expr (expr
);
12295 /* End of preparations. */
12298 ffecom_prepare_end (void)
12300 int prep_state
= current_binding_level
->prep_state
;
12302 assert (prep_state
< 2);
12303 current_binding_level
->prep_state
= 2;
12305 return (prep_state
== 1) ? TRUE
: FALSE
;
12308 /* Prepare expression.
12310 This is called before any code is generated for the current block.
12311 It scans the expression, declares any temporaries that might be needed
12312 during evaluation of the expression, and stores those temporaries in
12313 the appropriate "hook" fields of the expression. `dest', if not NULL,
12314 specifies the destination that ffecom_expr_ will see, in case that
12315 helps avoid generating unused temporaries.
12317 ~~Improve to avoid allocating unused temporaries by taking `dest'
12318 into account vis-a-vis aliasing requirements of complex/character
12322 ffecom_prepare_expr_ (ffebld expr
, ffebld dest UNUSED
)
12324 ffeinfoBasictype bt
;
12325 ffeinfoKindtype kt
;
12326 ffetargetCharacterSize sz
;
12327 tree tempvar
= NULL_TREE
;
12329 assert (current_binding_level
->prep_state
< 2);
12334 bt
= ffeinfo_basictype (ffebld_info (expr
));
12335 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12336 sz
= ffeinfo_size (ffebld_info (expr
));
12338 /* Generate whatever temporaries are needed to represent the result
12339 of the expression. */
12341 if (bt
== FFEINFO_basictypeCHARACTER
)
12343 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
12344 expr
= ffebld_left (expr
);
12347 switch (ffebld_op (expr
))
12350 /* Don't make temps for SYMTER, CONTER, etc. */
12351 if (ffebld_arity (expr
) == 0)
12356 case FFEINFO_basictypeCOMPLEX
:
12357 if (ffebld_op (expr
) == FFEBLD_opFUNCREF
)
12361 if (ffebld_op (ffebld_left (expr
)) != FFEBLD_opSYMTER
)
12364 s
= ffebld_symter (ffebld_left (expr
));
12365 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
12366 || (ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
12367 && ! ffesymbol_is_f2c (s
))
12368 || (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
12369 && ! ffe_is_f2c_library ()))
12372 else if (ffebld_op (expr
) == FFEBLD_opPOWER
)
12374 /* Requires special treatment. There's no POW_CC function
12375 in libg2c, so POW_ZZ is used, which means we always
12376 need a double-complex temp, not a single-complex. */
12377 kt
= FFEINFO_kindtypeREAL2
;
12379 else if (ffebld_op (expr
) != FFEBLD_opDIVIDE
)
12380 /* The other ops don't need temps for complex operands. */
12383 /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12384 REAL(C). See 19990325-0.f, routine `check', for cases. */
12385 tempvar
= ffecom_make_tempvar ("complex",
12387 [FFEINFO_basictypeCOMPLEX
][kt
],
12388 FFETARGET_charactersizeNONE
,
12392 case FFEINFO_basictypeCHARACTER
:
12393 if (ffebld_op (expr
) != FFEBLD_opFUNCREF
)
12396 if (sz
== FFETARGET_charactersizeNONE
)
12397 /* ~~Kludge alert! This should someday be fixed. */
12400 tempvar
= ffecom_make_tempvar ("char", char_type_node
, sz
, -1);
12408 case FFEBLD_opCONCATENATE
:
12410 /* This gets special handling, because only one set of temps
12411 is needed for a tree of these -- the tree is treated as
12412 a flattened list of concatenations when generating code. */
12414 ffecomConcatList_ catlist
;
12415 tree ltmp
, itmp
, result
;
12419 catlist
= ffecom_concat_list_new_ (expr
, FFETARGET_charactersizeNONE
);
12420 count
= ffecom_concat_list_count_ (catlist
);
12425 = ffecom_make_tempvar ("concat_len",
12426 ffecom_f2c_ftnlen_type_node
,
12427 FFETARGET_charactersizeNONE
, count
);
12429 = ffecom_make_tempvar ("concat_item",
12430 ffecom_f2c_address_type_node
,
12431 FFETARGET_charactersizeNONE
, count
);
12433 = ffecom_make_tempvar ("concat_res",
12435 ffecom_concat_list_maxlen_ (catlist
),
12438 tempvar
= make_tree_vec (3);
12439 TREE_VEC_ELT (tempvar
, 0) = ltmp
;
12440 TREE_VEC_ELT (tempvar
, 1) = itmp
;
12441 TREE_VEC_ELT (tempvar
, 2) = result
;
12444 for (i
= 0; i
< count
; ++i
)
12445 ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist
,
12448 ffecom_concat_list_kill_ (catlist
);
12452 ffebld_nonter_set_hook (expr
, tempvar
);
12453 current_binding_level
->prep_state
= 1;
12458 case FFEBLD_opCONVERT
:
12459 if (bt
== FFEINFO_basictypeCHARACTER
12460 && ((ffebld_size_known (ffebld_left (expr
))
12461 == FFETARGET_charactersizeNONE
)
12462 || (ffebld_size_known (ffebld_left (expr
)) >= sz
)))
12463 tempvar
= ffecom_make_tempvar ("convert", char_type_node
, sz
, -1);
12469 ffebld_nonter_set_hook (expr
, tempvar
);
12470 current_binding_level
->prep_state
= 1;
12473 /* Prepare subexpressions for this expr. */
12475 switch (ffebld_op (expr
))
12477 case FFEBLD_opPERCENT_LOC
:
12478 ffecom_prepare_ptr_to_expr (ffebld_left (expr
));
12481 case FFEBLD_opPERCENT_VAL
:
12482 case FFEBLD_opPERCENT_REF
:
12483 ffecom_prepare_expr (ffebld_left (expr
));
12486 case FFEBLD_opPERCENT_DESCR
:
12487 ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr
));
12490 case FFEBLD_opITEM
:
12496 item
= ffebld_trail (item
))
12497 if (ffebld_head (item
) != NULL
)
12498 ffecom_prepare_expr (ffebld_head (item
));
12503 /* Need to handle character conversion specially. */
12504 switch (ffebld_arity (expr
))
12507 ffecom_prepare_expr (ffebld_left (expr
));
12508 ffecom_prepare_expr (ffebld_right (expr
));
12512 ffecom_prepare_expr (ffebld_left (expr
));
12523 /* Prepare expression for reading and writing.
12525 Like ffecom_prepare_expr, except for expressions to be evaluated
12526 via ffecom_expr_rw. */
12529 ffecom_prepare_expr_rw (tree type
, ffebld expr
)
12531 /* This is all we support for now. */
12532 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
12534 /* ~~For now, it seems to be the same thing. */
12535 ffecom_prepare_expr (expr
);
12539 /* Prepare expression for writing.
12541 Like ffecom_prepare_expr, except for expressions to be evaluated
12542 via ffecom_expr_w. */
12545 ffecom_prepare_expr_w (tree type
, ffebld expr
)
12547 /* This is all we support for now. */
12548 assert (type
== NULL_TREE
|| type
== ffecom_type_expr (expr
));
12550 /* ~~For now, it seems to be the same thing. */
12551 ffecom_prepare_expr (expr
);
12555 /* Prepare expression for returning.
12557 Like ffecom_prepare_expr, except for expressions to be evaluated
12558 via ffecom_return_expr. */
12561 ffecom_prepare_return_expr (ffebld expr
)
12563 assert (current_binding_level
->prep_state
< 2);
12565 if (ffecom_primary_entry_kind_
== FFEINFO_kindSUBROUTINE
12566 && ffecom_is_altreturning_
12568 ffecom_prepare_expr (expr
);
12571 /* Prepare pointer to expression.
12573 Like ffecom_prepare_expr, except for expressions to be evaluated
12574 via ffecom_ptr_to_expr. */
12577 ffecom_prepare_ptr_to_expr (ffebld expr
)
12579 /* ~~For now, it seems to be the same thing. */
12580 ffecom_prepare_expr (expr
);
12584 /* Transform expression into constant pointer-to-expression tree.
12586 If the expression can be transformed into a pointer-to-expression tree
12587 that is constant, that is done, and the tree returned. Else NULL_TREE
12590 That way, a caller can attempt to provide compile-time initialization
12591 of a variable and, if that fails, *then* choose to start a new block
12592 and resort to using temporaries, as appropriate. */
12595 ffecom_ptr_to_const_expr (ffebld expr
)
12598 return integer_zero_node
;
12600 if (ffebld_op (expr
) == FFEBLD_opANY
)
12601 return error_mark_node
;
12603 if (ffebld_arity (expr
) == 0
12604 && (ffebld_op (expr
) != FFEBLD_opSYMTER
12605 || ffebld_where (expr
) == FFEINFO_whereCOMMON
12606 || ffebld_where (expr
) == FFEINFO_whereGLOBAL
12607 || ffebld_where (expr
) == FFEINFO_whereINTRINSIC
))
12611 t
= ffecom_ptr_to_expr (expr
);
12612 assert (TREE_CONSTANT (t
));
12619 /* ffecom_return_expr -- Returns return-value expr given alt return expr
12621 tree rtn; // NULL_TREE means use expand_null_return()
12622 ffebld expr; // NULL if no alt return expr to RETURN stmt
12623 rtn = ffecom_return_expr(expr);
12625 Based on the program unit type and other info (like return function
12626 type, return master function type when alternate ENTRY points,
12627 whether subroutine has any alternate RETURN points, etc), returns the
12628 appropriate expression to be returned to the caller, or NULL_TREE
12629 meaning no return value or the caller expects it to be returned somewhere
12630 else (which is handled by other parts of this module). */
12633 ffecom_return_expr (ffebld expr
)
12637 switch (ffecom_primary_entry_kind_
)
12639 case FFEINFO_kindPROGRAM
:
12640 case FFEINFO_kindBLOCKDATA
:
12644 case FFEINFO_kindSUBROUTINE
:
12645 if (!ffecom_is_altreturning_
)
12646 rtn
= NULL_TREE
; /* No alt returns, never an expr. */
12647 else if (expr
== NULL
)
12648 rtn
= integer_zero_node
;
12650 rtn
= ffecom_expr (expr
);
12653 case FFEINFO_kindFUNCTION
:
12654 if ((ffecom_multi_retval_
!= NULL_TREE
)
12655 || (ffesymbol_basictype (ffecom_primary_entry_
)
12656 == FFEINFO_basictypeCHARACTER
)
12657 || ((ffesymbol_basictype (ffecom_primary_entry_
)
12658 == FFEINFO_basictypeCOMPLEX
)
12659 && (ffecom_num_entrypoints_
== 0)
12660 && ffesymbol_is_f2c (ffecom_primary_entry_
)))
12661 { /* Value is returned by direct assignment
12662 into (implicit) dummy. */
12666 rtn
= ffecom_func_result_
;
12668 /* Spurious error if RETURN happens before first reference! So elide
12669 this code. In particular, for debugging registry, rtn should always
12670 be non-null after all, but TREE_USED won't be set until we encounter
12671 a reference in the code. Perfectly okay (but weird) code that,
12672 e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
12673 this diagnostic for no reason. Have people use -O -Wuninitialized
12674 and leave it to the back end to find obviously weird cases. */
12676 /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
12677 situation; if the return value has never been referenced, it won't
12678 have a tree under 2pass mode. */
12679 if ((rtn
== NULL_TREE
)
12680 || !TREE_USED (rtn
))
12682 ffebad_start (FFEBAD_RETURN_VALUE_UNSET
);
12683 ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_
),
12684 ffesymbol_where_column (ffecom_primary_entry_
));
12685 ffebad_string (ffesymbol_text (ffesymbol_funcresult
12686 (ffecom_primary_entry_
)));
12693 assert ("bad unit kind" == NULL
);
12694 case FFEINFO_kindANY
:
12695 rtn
= error_mark_node
;
12702 /* Do save_expr only if tree is not error_mark_node. */
12705 ffecom_save_tree (tree t
)
12707 return save_expr (t
);
12710 /* Start a compound statement (block). */
12713 ffecom_start_compstmt (void)
12715 bison_rule_pushlevel_ ();
12718 /* Public entry point for front end to access start_decl. */
12721 ffecom_start_decl (tree decl
, bool is_initialized
)
12723 DECL_INITIAL (decl
) = is_initialized
? error_mark_node
: NULL_TREE
;
12724 return start_decl (decl
, FALSE
);
12727 /* ffecom_sym_commit -- Symbol's state being committed to reality
12730 ffecom_sym_commit(s);
12732 Does whatever the backend needs when a symbol is committed after having
12733 been backtrackable for a period of time. */
12736 ffecom_sym_commit (ffesymbol s UNUSED
)
12738 assert (!ffesymbol_retractable ());
12741 /* ffecom_sym_end_transition -- Perform end transition on all symbols
12743 ffecom_sym_end_transition();
12745 Does backend-specific stuff and also calls ffest_sym_end_transition
12746 to do the necessary FFE stuff.
12748 Backtracking is never enabled when this fn is called, so don't worry
12752 ffecom_sym_end_transition (ffesymbol s
)
12756 assert (!ffesymbol_retractable ());
12758 s
= ffest_sym_end_transition (s
);
12760 if ((ffesymbol_kind (s
) == FFEINFO_kindBLOCKDATA
)
12761 && (ffesymbol_where (s
) == FFEINFO_whereGLOBAL
))
12763 ffecom_list_blockdata_
12764 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
12765 FFEINTRIN_specNONE
,
12766 FFEINTRIN_impNONE
),
12767 ffecom_list_blockdata_
);
12770 /* This is where we finally notice that a symbol has partial initialization
12771 and finalize it. */
12773 if (ffesymbol_accretion (s
) != NULL
)
12775 assert (ffesymbol_init (s
) == NULL
);
12776 ffecom_notify_init_symbol (s
);
12778 else if (((st
= ffesymbol_storage (s
)) != NULL
)
12779 && ((st
= ffestorag_parent (st
)) != NULL
)
12780 && (ffestorag_accretion (st
) != NULL
))
12782 assert (ffestorag_init (st
) == NULL
);
12783 ffecom_notify_init_storage (st
);
12786 if ((ffesymbol_kind (s
) == FFEINFO_kindCOMMON
)
12787 && (ffesymbol_where (s
) == FFEINFO_whereLOCAL
)
12788 && (ffesymbol_storage (s
) != NULL
))
12790 ffecom_list_common_
12791 = ffebld_new_item (ffebld_new_symter (s
, FFEINTRIN_genNONE
,
12792 FFEINTRIN_specNONE
,
12793 FFEINTRIN_impNONE
),
12794 ffecom_list_common_
);
12800 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
12802 ffecom_sym_exec_transition();
12804 Does backend-specific stuff and also calls ffest_sym_exec_transition
12805 to do the necessary FFE stuff.
12807 See the long-winded description in ffecom_sym_learned for info
12808 on handling the situation where backtracking is inhibited. */
12811 ffecom_sym_exec_transition (ffesymbol s
)
12813 s
= ffest_sym_exec_transition (s
);
12818 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
12821 s = ffecom_sym_learned(s);
12823 Called when a new symbol is seen after the exec transition or when more
12824 info (perhaps) is gained for an UNCERTAIN symbol. The symbol state when
12825 it arrives here is that all its latest info is updated already, so its
12826 state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
12827 field filled in if its gone through here or exec_transition first, and
12830 The backend probably wants to check ffesymbol_retractable() to see if
12831 backtracking is in effect. If so, the FFE's changes to the symbol may
12832 be retracted (undone) or committed (ratified), at which time the
12833 appropriate ffecom_sym_retract or _commit function will be called
12836 If the backend has its own backtracking mechanism, great, use it so that
12837 committal is a simple operation. Though it doesn't make much difference,
12838 I suppose: the reason for tentative symbol evolution in the FFE is to
12839 enable error detection in weird incorrect statements early and to disable
12840 incorrect error detection on a correct statement. The backend is not
12841 likely to introduce any information that'll get involved in these
12842 considerations, so it is probably just fine that the implementation
12843 model for this fn and for _exec_transition is to not do anything
12844 (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
12845 and instead wait until ffecom_sym_commit is called (which it never
12846 will be as long as we're using ambiguity-detecting statement analysis in
12847 the FFE, which we are initially to shake out the code, but don't depend
12848 on this), otherwise go ahead and do whatever is needed.
12850 In essence, then, when this fn and _exec_transition get called while
12851 backtracking is enabled, a general mechanism would be to flag which (or
12852 both) of these were called (and in what order? neat question as to what
12853 might happen that I'm too lame to think through right now) and then when
12854 _commit is called reproduce the original calling sequence, if any, for
12855 the two fns (at which point backtracking will, of course, be disabled). */
12858 ffecom_sym_learned (ffesymbol s
)
12860 ffestorag_exec_layout (s
);
12865 /* ffecom_sym_retract -- Symbol's state being retracted from reality
12868 ffecom_sym_retract(s);
12870 Does whatever the backend needs when a symbol is retracted after having
12871 been backtrackable for a period of time. */
12874 ffecom_sym_retract (ffesymbol s UNUSED
)
12876 assert (!ffesymbol_retractable ());
12878 #if 0 /* GCC doesn't commit any backtrackable sins,
12879 so nothing needed here. */
12880 switch (ffesymbol_hook (s
).state
)
12882 case 0: /* nothing happened yet. */
12885 case 1: /* exec transition happened. */
12888 case 2: /* learned happened. */
12891 case 3: /* learned then exec. */
12894 case 4: /* exec then learned. */
12898 assert ("bad hook state" == NULL
);
12904 /* Create temporary gcc label. */
12907 ffecom_temp_label ()
12910 static int mynumber
= 0;
12912 glabel
= build_decl (LABEL_DECL
,
12913 ffecom_get_invented_identifier ("__g77_label_%d",
12916 DECL_CONTEXT (glabel
) = current_function_decl
;
12917 DECL_MODE (glabel
) = VOIDmode
;
12922 /* Return an expression that is usable as an arg in a conditional context
12923 (IF, DO WHILE, .NOT., and so on).
12925 Use the one provided for the back end as of >2.6.0. */
12928 ffecom_truth_value (tree expr
)
12930 return ffe_truthvalue_conversion (expr
);
12933 /* Return the inversion of a truth value (the inversion of what
12934 ffecom_truth_value builds).
12936 Apparently invert_truthvalue, which is properly in the back end, is
12937 enough for now, so just use it. */
12940 ffecom_truth_value_invert (tree expr
)
12942 return invert_truthvalue (ffecom_truth_value (expr
));
12945 /* Return the tree that is the type of the expression, as would be
12946 returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
12947 transforming the expression, generating temporaries, etc. */
12950 ffecom_type_expr (ffebld expr
)
12952 ffeinfoBasictype bt
;
12953 ffeinfoKindtype kt
;
12956 assert (expr
!= NULL
);
12958 bt
= ffeinfo_basictype (ffebld_info (expr
));
12959 kt
= ffeinfo_kindtype (ffebld_info (expr
));
12960 tree_type
= ffecom_tree_type
[bt
][kt
];
12962 switch (ffebld_op (expr
))
12964 case FFEBLD_opCONTER
:
12965 case FFEBLD_opSYMTER
:
12966 case FFEBLD_opARRAYREF
:
12967 case FFEBLD_opUPLUS
:
12968 case FFEBLD_opPAREN
:
12969 case FFEBLD_opUMINUS
:
12971 case FFEBLD_opSUBTRACT
:
12972 case FFEBLD_opMULTIPLY
:
12973 case FFEBLD_opDIVIDE
:
12974 case FFEBLD_opPOWER
:
12976 case FFEBLD_opFUNCREF
:
12977 case FFEBLD_opSUBRREF
:
12981 case FFEBLD_opNEQV
:
12983 case FFEBLD_opCONVERT
:
12990 case FFEBLD_opPERCENT_LOC
:
12993 case FFEBLD_opACCTER
:
12994 case FFEBLD_opARRTER
:
12995 case FFEBLD_opITEM
:
12996 case FFEBLD_opSTAR
:
12997 case FFEBLD_opBOUNDS
:
12998 case FFEBLD_opREPEAT
:
12999 case FFEBLD_opLABTER
:
13000 case FFEBLD_opLABTOK
:
13001 case FFEBLD_opIMPDO
:
13002 case FFEBLD_opCONCATENATE
:
13003 case FFEBLD_opSUBSTR
:
13005 assert ("bad op for ffecom_type_expr" == NULL
);
13006 /* Fall through. */
13008 return error_mark_node
;
13012 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13014 If the PARM_DECL already exists, return it, else create it. It's an
13015 integer_type_node argument for the master function that implements a
13016 subroutine or function with more than one entrypoint and is bound at
13017 run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13018 first ENTRY statement, and so on). */
13021 ffecom_which_entrypoint_decl ()
13023 assert (ffecom_which_entrypoint_decl_
!= NULL_TREE
);
13025 return ffecom_which_entrypoint_decl_
;
13028 /* The following sections consists of private and public functions
13029 that have the same names and perform roughly the same functions
13030 as counterparts in the C front end. Changes in the C front end
13031 might affect how things should be done here. Only functions
13032 needed by the back end should be public here; the rest should
13033 be private (static in the C sense). Functions needed by other
13034 g77 front-end modules should be accessed by them via public
13035 ffecom_* names, which should themselves call private versions
13036 in this section so the private versions are easy to recognize
13037 when upgrading to a new gcc and finding interesting changes
13040 Functions named after rule "foo:" in c-parse.y are named
13041 "bison_rule_foo_" so they are easy to find. */
13044 bison_rule_pushlevel_ ()
13046 emit_line_note (input_filename
, lineno
);
13048 clear_last_expr ();
13049 expand_start_bindings (0);
13053 bison_rule_compstmt_ ()
13056 int keep
= kept_level_p ();
13058 /* Make the temps go away. */
13060 current_binding_level
->names
= NULL_TREE
;
13062 emit_line_note (input_filename
, lineno
);
13063 expand_end_bindings (getdecls (), keep
, 0);
13064 t
= poplevel (keep
, 1, 0);
13069 /* Return a definition for a builtin function named NAME and whose data type
13070 is TYPE. TYPE should be a function type with argument types.
13071 FUNCTION_CODE tells later passes how to compile calls to this function.
13072 See tree.h for its possible values.
13074 If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13075 the name to be called if we can't opencode the function. If
13076 ATTRS is nonzero, use that for the function's attribute list. */
13079 builtin_function (const char *name
, tree type
, int function_code
,
13080 enum built_in_class
class,
13081 const char *library_name
,
13082 tree attrs ATTRIBUTE_UNUSED
)
13084 tree decl
= build_decl (FUNCTION_DECL
, get_identifier (name
), type
);
13085 DECL_EXTERNAL (decl
) = 1;
13086 TREE_PUBLIC (decl
) = 1;
13088 SET_DECL_ASSEMBLER_NAME (decl
, get_identifier (library_name
));
13089 make_decl_rtl (decl
, NULL
);
13091 DECL_BUILT_IN_CLASS (decl
) = class;
13092 DECL_FUNCTION_CODE (decl
) = function_code
;
13097 /* Handle when a new declaration NEWDECL
13098 has the same name as an old one OLDDECL
13099 in the same binding contour.
13100 Prints an error message if appropriate.
13102 If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13103 Otherwise, return 0. */
13106 duplicate_decls (tree newdecl
, tree olddecl
)
13108 int types_match
= 1;
13109 int new_is_definition
= (TREE_CODE (newdecl
) == FUNCTION_DECL
13110 && DECL_INITIAL (newdecl
) != 0);
13111 tree oldtype
= TREE_TYPE (olddecl
);
13112 tree newtype
= TREE_TYPE (newdecl
);
13114 if (olddecl
== newdecl
)
13117 if (TREE_CODE (newtype
) == ERROR_MARK
13118 || TREE_CODE (oldtype
) == ERROR_MARK
)
13121 /* New decl is completely inconsistent with the old one =>
13122 tell caller to replace the old one.
13123 This is always an error except in the case of shadowing a builtin. */
13124 if (TREE_CODE (olddecl
) != TREE_CODE (newdecl
))
13127 /* For real parm decl following a forward decl,
13128 return 1 so old decl will be reused. */
13129 if (types_match
&& TREE_CODE (newdecl
) == PARM_DECL
13130 && TREE_ASM_WRITTEN (olddecl
) && ! TREE_ASM_WRITTEN (newdecl
))
13133 /* The new declaration is the same kind of object as the old one.
13134 The declarations may partially match. Print warnings if they don't
13135 match enough. Ultimately, copy most of the information from the new
13136 decl to the old one, and keep using the old one. */
13138 if (TREE_CODE (olddecl
) == FUNCTION_DECL
13139 && DECL_BUILT_IN (olddecl
))
13141 /* A function declaration for a built-in function. */
13142 if (!TREE_PUBLIC (newdecl
))
13144 else if (!types_match
)
13146 /* Accept the return type of the new declaration if same modes. */
13147 tree oldreturntype
= TREE_TYPE (TREE_TYPE (olddecl
));
13148 tree newreturntype
= TREE_TYPE (TREE_TYPE (newdecl
));
13150 if (TYPE_MODE (oldreturntype
) == TYPE_MODE (newreturntype
))
13152 /* Function types may be shared, so we can't just modify
13153 the return type of olddecl's function type. */
13155 = build_function_type (newreturntype
,
13156 TYPE_ARG_TYPES (TREE_TYPE (olddecl
)));
13160 TREE_TYPE (olddecl
) = newtype
;
13166 else if (TREE_CODE (olddecl
) == FUNCTION_DECL
13167 && DECL_SOURCE_LINE (olddecl
) == 0)
13169 /* A function declaration for a predeclared function
13170 that isn't actually built in. */
13171 if (!TREE_PUBLIC (newdecl
))
13173 else if (!types_match
)
13175 /* If the types don't match, preserve volatility indication.
13176 Later on, we will discard everything else about the
13177 default declaration. */
13178 TREE_THIS_VOLATILE (newdecl
) |= TREE_THIS_VOLATILE (olddecl
);
13182 /* Copy all the DECL_... slots specified in the new decl
13183 except for any that we copy here from the old type.
13185 Past this point, we don't change OLDTYPE and NEWTYPE
13186 even if we change the types of NEWDECL and OLDDECL. */
13190 /* Merge the data types specified in the two decls. */
13191 if (TREE_CODE (newdecl
) != FUNCTION_DECL
|| !DECL_BUILT_IN (olddecl
))
13192 TREE_TYPE (newdecl
)
13193 = TREE_TYPE (olddecl
)
13194 = TREE_TYPE (newdecl
);
13196 /* Lay the type out, unless already done. */
13197 if (oldtype
!= TREE_TYPE (newdecl
))
13199 if (TREE_TYPE (newdecl
) != error_mark_node
)
13200 layout_type (TREE_TYPE (newdecl
));
13201 if (TREE_CODE (newdecl
) != FUNCTION_DECL
13202 && TREE_CODE (newdecl
) != TYPE_DECL
13203 && TREE_CODE (newdecl
) != CONST_DECL
)
13204 layout_decl (newdecl
, 0);
13208 /* Since the type is OLDDECL's, make OLDDECL's size go with. */
13209 DECL_SIZE (newdecl
) = DECL_SIZE (olddecl
);
13210 DECL_SIZE_UNIT (newdecl
) = DECL_SIZE_UNIT (olddecl
);
13211 if (TREE_CODE (olddecl
) != FUNCTION_DECL
)
13212 if (DECL_ALIGN (olddecl
) > DECL_ALIGN (newdecl
))
13214 DECL_ALIGN (newdecl
) = DECL_ALIGN (olddecl
);
13215 DECL_USER_ALIGN (newdecl
) |= DECL_USER_ALIGN (olddecl
);
13219 /* Keep the old rtl since we can safely use it. */
13220 COPY_DECL_RTL (olddecl
, newdecl
);
13222 /* Merge the type qualifiers. */
13223 if (DECL_BUILT_IN_NONANSI (olddecl
) && TREE_THIS_VOLATILE (olddecl
)
13224 && !TREE_THIS_VOLATILE (newdecl
))
13225 TREE_THIS_VOLATILE (olddecl
) = 0;
13226 if (TREE_READONLY (newdecl
))
13227 TREE_READONLY (olddecl
) = 1;
13228 if (TREE_THIS_VOLATILE (newdecl
))
13230 TREE_THIS_VOLATILE (olddecl
) = 1;
13231 if (TREE_CODE (newdecl
) == VAR_DECL
)
13232 make_var_volatile (newdecl
);
13235 /* Keep source location of definition rather than declaration.
13236 Likewise, keep decl at outer scope. */
13237 if ((DECL_INITIAL (newdecl
) == 0 && DECL_INITIAL (olddecl
) != 0)
13238 || (DECL_CONTEXT (newdecl
) != 0 && DECL_CONTEXT (olddecl
) == 0))
13240 DECL_SOURCE_LINE (newdecl
) = DECL_SOURCE_LINE (olddecl
);
13241 DECL_SOURCE_FILE (newdecl
) = DECL_SOURCE_FILE (olddecl
);
13243 if (DECL_CONTEXT (olddecl
) == 0
13244 && TREE_CODE (newdecl
) != FUNCTION_DECL
)
13245 DECL_CONTEXT (newdecl
) = 0;
13248 /* Merge the unused-warning information. */
13249 if (DECL_IN_SYSTEM_HEADER (olddecl
))
13250 DECL_IN_SYSTEM_HEADER (newdecl
) = 1;
13251 else if (DECL_IN_SYSTEM_HEADER (newdecl
))
13252 DECL_IN_SYSTEM_HEADER (olddecl
) = 1;
13254 /* Merge the initialization information. */
13255 if (DECL_INITIAL (newdecl
) == 0)
13256 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13258 /* Merge the section attribute.
13259 We want to issue an error if the sections conflict but that must be
13260 done later in decl_attributes since we are called before attributes
13262 if (DECL_SECTION_NAME (newdecl
) == NULL_TREE
)
13263 DECL_SECTION_NAME (newdecl
) = DECL_SECTION_NAME (olddecl
);
13265 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13267 DECL_STATIC_CONSTRUCTOR(newdecl
) |= DECL_STATIC_CONSTRUCTOR(olddecl
);
13268 DECL_STATIC_DESTRUCTOR (newdecl
) |= DECL_STATIC_DESTRUCTOR (olddecl
);
13271 /* If cannot merge, then use the new type and qualifiers,
13272 and don't preserve the old rtl. */
13275 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13276 TREE_READONLY (olddecl
) = TREE_READONLY (newdecl
);
13277 TREE_THIS_VOLATILE (olddecl
) = TREE_THIS_VOLATILE (newdecl
);
13278 TREE_SIDE_EFFECTS (olddecl
) = TREE_SIDE_EFFECTS (newdecl
);
13281 /* Merge the storage class information. */
13282 /* For functions, static overrides non-static. */
13283 if (TREE_CODE (newdecl
) == FUNCTION_DECL
)
13285 TREE_PUBLIC (newdecl
) &= TREE_PUBLIC (olddecl
);
13286 /* This is since we don't automatically
13287 copy the attributes of NEWDECL into OLDDECL. */
13288 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13289 /* If this clears `static', clear it in the identifier too. */
13290 if (! TREE_PUBLIC (olddecl
))
13291 TREE_PUBLIC (DECL_NAME (olddecl
)) = 0;
13293 if (DECL_EXTERNAL (newdecl
))
13295 TREE_STATIC (newdecl
) = TREE_STATIC (olddecl
);
13296 DECL_EXTERNAL (newdecl
) = DECL_EXTERNAL (olddecl
);
13297 /* An extern decl does not override previous storage class. */
13298 TREE_PUBLIC (newdecl
) = TREE_PUBLIC (olddecl
);
13302 TREE_STATIC (olddecl
) = TREE_STATIC (newdecl
);
13303 TREE_PUBLIC (olddecl
) = TREE_PUBLIC (newdecl
);
13306 /* If either decl says `inline', this fn is inline,
13307 unless its definition was passed already. */
13308 if (DECL_INLINE (newdecl
) && DECL_INITIAL (olddecl
) == 0)
13309 DECL_INLINE (olddecl
) = 1;
13310 DECL_INLINE (newdecl
) = DECL_INLINE (olddecl
);
13312 /* Get rid of any built-in function if new arg types don't match it
13313 or if we have a function definition. */
13314 if (TREE_CODE (newdecl
) == FUNCTION_DECL
13315 && DECL_BUILT_IN (olddecl
)
13316 && (!types_match
|| new_is_definition
))
13318 TREE_TYPE (olddecl
) = TREE_TYPE (newdecl
);
13319 DECL_BUILT_IN_CLASS (olddecl
) = NOT_BUILT_IN
;
13322 /* If redeclaring a builtin function, and not a definition,
13324 Also preserve various other info from the definition. */
13325 if (TREE_CODE (newdecl
) == FUNCTION_DECL
&& !new_is_definition
)
13327 if (DECL_BUILT_IN (olddecl
))
13329 DECL_BUILT_IN_CLASS (newdecl
) = DECL_BUILT_IN_CLASS (olddecl
);
13330 DECL_FUNCTION_CODE (newdecl
) = DECL_FUNCTION_CODE (olddecl
);
13333 DECL_RESULT (newdecl
) = DECL_RESULT (olddecl
);
13334 DECL_INITIAL (newdecl
) = DECL_INITIAL (olddecl
);
13335 DECL_SAVED_INSNS (newdecl
) = DECL_SAVED_INSNS (olddecl
);
13336 DECL_ARGUMENTS (newdecl
) = DECL_ARGUMENTS (olddecl
);
13339 /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13340 But preserve olddecl's DECL_UID. */
13342 register unsigned olddecl_uid
= DECL_UID (olddecl
);
13344 memcpy ((char *) olddecl
+ sizeof (struct tree_common
),
13345 (char *) newdecl
+ sizeof (struct tree_common
),
13346 sizeof (struct tree_decl
) - sizeof (struct tree_common
));
13347 DECL_UID (olddecl
) = olddecl_uid
;
13353 /* Finish processing of a declaration;
13354 install its initial value.
13355 If the length of an array type is not known before,
13356 it must be determined now, from the initial value, or it is an error. */
13359 finish_decl (tree decl
, tree init
, bool is_top_level
)
13361 register tree type
= TREE_TYPE (decl
);
13362 int was_incomplete
= (DECL_SIZE (decl
) == 0);
13363 bool at_top_level
= (current_binding_level
== global_binding_level
);
13364 bool top_level
= is_top_level
|| at_top_level
;
13366 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13368 assert (!is_top_level
|| !at_top_level
);
13370 if (TREE_CODE (decl
) == PARM_DECL
)
13371 assert (init
== NULL_TREE
);
13372 /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13373 overlaps DECL_ARG_TYPE. */
13374 else if (init
== NULL_TREE
)
13375 assert (DECL_INITIAL (decl
) == NULL_TREE
);
13377 assert (DECL_INITIAL (decl
) == error_mark_node
);
13379 if (init
!= NULL_TREE
)
13381 if (TREE_CODE (decl
) != TYPE_DECL
)
13382 DECL_INITIAL (decl
) = init
;
13385 /* typedef foo = bar; store the type of bar as the type of foo. */
13386 TREE_TYPE (decl
) = TREE_TYPE (init
);
13387 DECL_INITIAL (decl
) = init
= 0;
13391 /* Deduce size of array from initialization, if not already known */
13393 if (TREE_CODE (type
) == ARRAY_TYPE
13394 && TYPE_DOMAIN (type
) == 0
13395 && TREE_CODE (decl
) != TYPE_DECL
)
13397 assert (top_level
);
13398 assert (was_incomplete
);
13400 layout_decl (decl
, 0);
13403 if (TREE_CODE (decl
) == VAR_DECL
)
13405 if (DECL_SIZE (decl
) == NULL_TREE
13406 && TYPE_SIZE (TREE_TYPE (decl
)) != NULL_TREE
)
13407 layout_decl (decl
, 0);
13409 if (DECL_SIZE (decl
) == NULL_TREE
13410 && (TREE_STATIC (decl
)
13412 /* A static variable with an incomplete type is an error if it is
13413 initialized. Also if it is not file scope. Otherwise, let it
13414 through, but if it is not `extern' then it may cause an error
13416 (DECL_INITIAL (decl
) != 0 || DECL_CONTEXT (decl
) != 0)
13418 /* An automatic variable with an incomplete type is an error. */
13419 !DECL_EXTERNAL (decl
)))
13421 assert ("storage size not known" == NULL
);
13425 if ((DECL_EXTERNAL (decl
) || TREE_STATIC (decl
))
13426 && (DECL_SIZE (decl
) != 0)
13427 && (TREE_CODE (DECL_SIZE (decl
)) != INTEGER_CST
))
13429 assert ("storage size not constant" == NULL
);
13434 /* Output the assembler code and/or RTL code for variables and functions,
13435 unless the type is an undefined structure or union. If not, it will get
13436 done when the type is completed. */
13438 if (TREE_CODE (decl
) == VAR_DECL
|| TREE_CODE (decl
) == FUNCTION_DECL
)
13440 rest_of_decl_compilation (decl
, NULL
,
13441 DECL_CONTEXT (decl
) == 0,
13444 if (DECL_CONTEXT (decl
) != 0)
13446 /* Recompute the RTL of a local array now if it used to be an
13447 incomplete type. */
13449 && !TREE_STATIC (decl
) && !DECL_EXTERNAL (decl
))
13451 /* If we used it already as memory, it must stay in memory. */
13452 TREE_ADDRESSABLE (decl
) = TREE_USED (decl
);
13453 /* If it's still incomplete now, no init will save it. */
13454 if (DECL_SIZE (decl
) == 0)
13455 DECL_INITIAL (decl
) = 0;
13456 expand_decl (decl
);
13458 /* Compute and store the initial value. */
13459 if (TREE_CODE (decl
) != FUNCTION_DECL
)
13460 expand_decl_init (decl
);
13463 else if (TREE_CODE (decl
) == TYPE_DECL
)
13465 rest_of_decl_compilation (decl
, NULL
,
13466 DECL_CONTEXT (decl
) == 0,
13470 /* At the end of a declaration, throw away any variable type sizes of types
13471 defined inside that declaration. There is no use computing them in the
13472 following function definition. */
13473 if (current_binding_level
== global_binding_level
)
13474 get_pending_sizes ();
13477 /* Finish up a function declaration and compile that function
13478 all the way to assembler language output. The free the storage
13479 for the function definition.
13481 This is called after parsing the body of the function definition.
13483 NESTED is nonzero if the function being finished is nested in another. */
13486 finish_function (int nested
)
13488 register tree fndecl
= current_function_decl
;
13490 assert (fndecl
!= NULL_TREE
);
13491 if (TREE_CODE (fndecl
) != ERROR_MARK
)
13494 assert (DECL_CONTEXT (fndecl
) != NULL_TREE
);
13496 assert (DECL_CONTEXT (fndecl
) == NULL_TREE
);
13499 /* TREE_READONLY (fndecl) = 1;
13500 This caused &foo to be of type ptr-to-const-function
13501 which then got a warning when stored in a ptr-to-function variable. */
13503 poplevel (1, 0, 1);
13505 if (TREE_CODE (fndecl
) != ERROR_MARK
)
13507 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl
)) = fndecl
;
13509 /* Must mark the RESULT_DECL as being in this function. */
13511 DECL_CONTEXT (DECL_RESULT (fndecl
)) = fndecl
;
13513 /* Obey `register' declarations if `setjmp' is called in this fn. */
13514 /* Generate rtl for function exit. */
13515 expand_function_end (input_filename
, lineno
, 0);
13517 /* If this is a nested function, protect the local variables in the stack
13518 above us from being collected while we're compiling this function. */
13520 ggc_push_context ();
13522 /* Run the optimizers and output the assembler code for this function. */
13523 rest_of_compilation (fndecl
);
13525 /* Undo the GC context switch. */
13527 ggc_pop_context ();
13530 if (TREE_CODE (fndecl
) != ERROR_MARK
13532 && DECL_SAVED_INSNS (fndecl
) == 0)
13534 /* Stop pointing to the local nodes about to be freed. */
13535 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13536 function definition. */
13537 /* For a nested function, this is done in pop_f_function_context. */
13538 /* If rest_of_compilation set this to 0, leave it 0. */
13539 if (DECL_INITIAL (fndecl
) != 0)
13540 DECL_INITIAL (fndecl
) = error_mark_node
;
13541 DECL_ARGUMENTS (fndecl
) = 0;
13546 /* Let the error reporting routines know that we're outside a function.
13547 For a nested function, this value is used in pop_c_function_context
13548 and then reset via pop_function_context. */
13549 ffecom_outer_function_decl_
= current_function_decl
= NULL
;
13553 /* Plug-in replacement for identifying the name of a decl and, for a
13554 function, what we call it in diagnostics. For now, "program unit"
13555 should suffice, since it's a bit of a hassle to figure out which
13556 of several kinds of things it is. Note that it could conceivably
13557 be a statement function, which probably isn't really a program unit
13558 per se, but if that comes up, it should be easy to check (being a
13559 nested function and all). */
13561 static const char *
13562 ffe_printable_name (tree decl
, int v
)
13564 /* Just to keep GCC quiet about the unused variable.
13565 In theory, differing values of V should produce different
13570 if (TREE_CODE (decl
) == ERROR_MARK
)
13571 return "erroneous code";
13572 return IDENTIFIER_POINTER (DECL_NAME (decl
));
13576 /* g77's function to print out name of current function that caused
13580 ffe_print_error_function (diagnostic_context
*context
__attribute__((unused
)),
13583 static ffeglobal last_g
= NULL
;
13584 static ffesymbol last_s
= NULL
;
13589 if ((ffecom_primary_entry_
== NULL
)
13590 || (ffesymbol_global (ffecom_primary_entry_
) == NULL
))
13598 g
= ffesymbol_global (ffecom_primary_entry_
);
13599 if (ffecom_nested_entry_
== NULL
)
13601 s
= ffecom_primary_entry_
;
13602 kind
= _(ffeinfo_kind_message (ffesymbol_kind (s
)));
13606 s
= ffecom_nested_entry_
;
13607 kind
= _("In statement function");
13611 if ((last_g
!= g
) || (last_s
!= s
))
13614 fprintf (stderr
, "%s: ", file
);
13617 fprintf (stderr
, _("Outside of any program unit:\n"));
13620 const char *name
= ffesymbol_text (s
);
13622 fprintf (stderr
, "%s `%s':\n", kind
, name
);
13630 /* Similar to `lookup_name' but look only at current binding level. */
13633 lookup_name_current_level (tree name
)
13637 if (current_binding_level
== global_binding_level
)
13638 return IDENTIFIER_GLOBAL_VALUE (name
);
13640 if (IDENTIFIER_LOCAL_VALUE (name
) == 0)
13643 for (t
= current_binding_level
->names
; t
; t
= TREE_CHAIN (t
))
13644 if (DECL_NAME (t
) == name
)
13650 /* Create a new `struct f_binding_level'. */
13652 static struct f_binding_level
*
13653 make_binding_level ()
13656 return ggc_alloc (sizeof (struct f_binding_level
));
13659 /* Save and restore the variables in this file and elsewhere
13660 that keep track of the progress of compilation of the current function.
13661 Used for nested functions. */
13665 struct f_function
*next
;
13667 tree shadowed_labels
;
13668 struct f_binding_level
*binding_level
;
13671 struct f_function
*f_function_chain
;
13673 /* Restore the variables used during compilation of a C function. */
13676 pop_f_function_context ()
13678 struct f_function
*p
= f_function_chain
;
13681 /* Bring back all the labels that were shadowed. */
13682 for (link
= shadowed_labels
; link
; link
= TREE_CHAIN (link
))
13683 if (DECL_NAME (TREE_VALUE (link
)) != 0)
13684 IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link
)))
13685 = TREE_VALUE (link
);
13687 if (current_function_decl
!= error_mark_node
13688 && DECL_SAVED_INSNS (current_function_decl
) == 0)
13690 /* Stop pointing to the local nodes about to be freed. */
13691 /* But DECL_INITIAL must remain nonzero so we know this was an actual
13692 function definition. */
13693 DECL_INITIAL (current_function_decl
) = error_mark_node
;
13694 DECL_ARGUMENTS (current_function_decl
) = 0;
13697 pop_function_context ();
13699 f_function_chain
= p
->next
;
13701 named_labels
= p
->named_labels
;
13702 shadowed_labels
= p
->shadowed_labels
;
13703 current_binding_level
= p
->binding_level
;
13708 /* Save and reinitialize the variables
13709 used during compilation of a C function. */
13712 push_f_function_context ()
13714 struct f_function
*p
13715 = (struct f_function
*) xmalloc (sizeof (struct f_function
));
13717 push_function_context ();
13719 p
->next
= f_function_chain
;
13720 f_function_chain
= p
;
13722 p
->named_labels
= named_labels
;
13723 p
->shadowed_labels
= shadowed_labels
;
13724 p
->binding_level
= current_binding_level
;
13728 push_parm_decl (tree parm
)
13730 int old_immediate_size_expand
= immediate_size_expand
;
13732 /* Don't try computing parm sizes now -- wait till fn is called. */
13734 immediate_size_expand
= 0;
13736 /* Fill in arg stuff. */
13738 DECL_ARG_TYPE (parm
) = TREE_TYPE (parm
);
13739 DECL_ARG_TYPE_AS_WRITTEN (parm
) = TREE_TYPE (parm
);
13740 TREE_READONLY (parm
) = 1; /* All implementation args are read-only. */
13742 parm
= pushdecl (parm
);
13744 immediate_size_expand
= old_immediate_size_expand
;
13746 finish_decl (parm
, NULL_TREE
, FALSE
);
13749 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate. */
13752 pushdecl_top_level (tree x
)
13755 register struct f_binding_level
*b
= current_binding_level
;
13756 register tree f
= current_function_decl
;
13758 current_binding_level
= global_binding_level
;
13759 current_function_decl
= NULL_TREE
;
13761 current_binding_level
= b
;
13762 current_function_decl
= f
;
13766 /* Store the list of declarations of the current level.
13767 This is done for the parameter declarations of a function being defined,
13768 after they are modified in the light of any missing parameters. */
13771 storedecls (tree decls
)
13773 return current_binding_level
->names
= decls
;
13776 /* Store the parameter declarations into the current function declaration.
13777 This is called after parsing the parameter declarations, before
13778 digesting the body of the function.
13780 For an old-style definition, modify the function's type
13781 to specify at least the number of arguments. */
13784 store_parm_decls (int is_main_program UNUSED
)
13786 register tree fndecl
= current_function_decl
;
13788 if (fndecl
== error_mark_node
)
13791 /* This is a chain of PARM_DECLs from old-style parm declarations. */
13792 DECL_ARGUMENTS (fndecl
) = storedecls (nreverse (getdecls ()));
13794 /* Initialize the RTL code for the function. */
13796 init_function_start (fndecl
, input_filename
, lineno
);
13798 /* Set up parameters and prepare for return, for the function. */
13800 expand_function_start (fndecl
, 0);
13804 start_decl (tree decl
, bool is_top_level
)
13807 bool at_top_level
= (current_binding_level
== global_binding_level
);
13808 bool top_level
= is_top_level
|| at_top_level
;
13810 /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13812 assert (!is_top_level
|| !at_top_level
);
13814 if (DECL_INITIAL (decl
) != NULL_TREE
)
13816 assert (DECL_INITIAL (decl
) == error_mark_node
);
13817 assert (!DECL_EXTERNAL (decl
));
13819 else if (top_level
)
13820 assert ((TREE_STATIC (decl
) == 1) || DECL_EXTERNAL (decl
) == 1);
13822 /* For Fortran, we by default put things in .common when possible. */
13823 DECL_COMMON (decl
) = 1;
13825 /* Add this decl to the current binding level. TEM may equal DECL or it may
13826 be a previous decl of the same name. */
13828 tem
= pushdecl_top_level (decl
);
13830 tem
= pushdecl (decl
);
13832 /* For a local variable, define the RTL now. */
13834 /* But not if this is a duplicate decl and we preserved the rtl from the
13835 previous one (which may or may not happen). */
13836 && !DECL_RTL_SET_P (tem
))
13838 if (TYPE_SIZE (TREE_TYPE (tem
)) != 0)
13840 else if (TREE_CODE (TREE_TYPE (tem
)) == ARRAY_TYPE
13841 && DECL_INITIAL (tem
) != 0)
13848 /* Create the FUNCTION_DECL for a function definition.
13849 DECLSPECS and DECLARATOR are the parts of the declaration;
13850 they describe the function's name and the type it returns,
13851 but twisted together in a fashion that parallels the syntax of C.
13853 This function creates a binding context for the function body
13854 as well as setting up the FUNCTION_DECL in current_function_decl.
13856 Returns 1 on success. If the DECLARATOR is not suitable for a function
13857 (it defines a datum instead), we return 0, which tells
13858 ffe_parse_file to report a parse error.
13860 NESTED is nonzero for a function nested within another function. */
13863 start_function (tree name
, tree type
, int nested
, int public)
13867 int old_immediate_size_expand
= immediate_size_expand
;
13870 shadowed_labels
= 0;
13872 /* Don't expand any sizes in the return type of the function. */
13873 immediate_size_expand
= 0;
13878 assert (current_function_decl
!= NULL_TREE
);
13879 assert (DECL_CONTEXT (current_function_decl
) == NULL_TREE
);
13883 assert (current_function_decl
== NULL_TREE
);
13886 if (TREE_CODE (type
) == ERROR_MARK
)
13887 decl1
= current_function_decl
= error_mark_node
;
13890 decl1
= build_decl (FUNCTION_DECL
,
13893 TREE_PUBLIC (decl1
) = public ? 1 : 0;
13895 DECL_INLINE (decl1
) = 1;
13896 TREE_STATIC (decl1
) = 1;
13897 DECL_EXTERNAL (decl1
) = 0;
13899 announce_function (decl1
);
13901 /* Make the init_value nonzero so pushdecl knows this is not tentative.
13902 error_mark_node is replaced below (in poplevel) with the BLOCK. */
13903 DECL_INITIAL (decl1
) = error_mark_node
;
13905 /* Record the decl so that the function name is defined. If we already have
13906 a decl for this name, and it is a FUNCTION_DECL, use the old decl. */
13908 current_function_decl
= pushdecl (decl1
);
13912 ffecom_outer_function_decl_
= current_function_decl
;
13915 current_binding_level
->prep_state
= 2;
13917 if (TREE_CODE (current_function_decl
) != ERROR_MARK
)
13919 make_decl_rtl (current_function_decl
, NULL
);
13921 restype
= TREE_TYPE (TREE_TYPE (current_function_decl
));
13922 DECL_RESULT (current_function_decl
)
13923 = build_decl (RESULT_DECL
, NULL_TREE
, restype
);
13926 if (!nested
&& (TREE_CODE (current_function_decl
) != ERROR_MARK
))
13927 TREE_ADDRESSABLE (current_function_decl
) = 1;
13929 immediate_size_expand
= old_immediate_size_expand
;
13932 /* Here are the public functions the GNU back end needs. */
13935 convert (tree type
, tree expr
)
13937 register tree e
= expr
;
13938 register enum tree_code code
= TREE_CODE (type
);
13940 if (type
== TREE_TYPE (e
)
13941 || TREE_CODE (e
) == ERROR_MARK
)
13943 if (TYPE_MAIN_VARIANT (type
) == TYPE_MAIN_VARIANT (TREE_TYPE (e
)))
13944 return fold (build1 (NOP_EXPR
, type
, e
));
13945 if (TREE_CODE (TREE_TYPE (e
)) == ERROR_MARK
13946 || code
== ERROR_MARK
)
13947 return error_mark_node
;
13948 if (TREE_CODE (TREE_TYPE (e
)) == VOID_TYPE
)
13950 assert ("void value not ignored as it ought to be" == NULL
);
13951 return error_mark_node
;
13953 if (code
== VOID_TYPE
)
13954 return build1 (CONVERT_EXPR
, type
, e
);
13955 if ((code
!= RECORD_TYPE
)
13956 && (TREE_CODE (TREE_TYPE (e
)) == RECORD_TYPE
))
13957 e
= ffecom_1 (REALPART_EXPR
, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e
))),
13959 if (code
== INTEGER_TYPE
|| code
== ENUMERAL_TYPE
)
13960 return fold (convert_to_integer (type
, e
));
13961 if (code
== POINTER_TYPE
)
13962 return fold (convert_to_pointer (type
, e
));
13963 if (code
== REAL_TYPE
)
13964 return fold (convert_to_real (type
, e
));
13965 if (code
== COMPLEX_TYPE
)
13966 return fold (convert_to_complex (type
, e
));
13967 if (code
== RECORD_TYPE
)
13968 return fold (ffecom_convert_to_complex_ (type
, e
));
13970 assert ("conversion to non-scalar type requested" == NULL
);
13971 return error_mark_node
;
13974 /* Return the list of declarations of the current level.
13975 Note that this list is in reverse order unless/until
13976 you nreverse it; and when you do nreverse it, you must
13977 store the result back using `storedecls' or you will lose. */
13982 return current_binding_level
->names
;
13985 /* Nonzero if we are currently in the global binding level. */
13988 global_bindings_p ()
13990 return current_binding_level
== global_binding_level
;
13994 ffecom_init_decl_processing ()
14001 /* Delete the node BLOCK from the current binding level.
14002 This is used for the block inside a stmt expr ({...})
14003 so that the block can be reinserted where appropriate. */
14006 delete_block (tree block
)
14009 if (current_binding_level
->blocks
== block
)
14010 current_binding_level
->blocks
= TREE_CHAIN (block
);
14011 for (t
= current_binding_level
->blocks
; t
;)
14013 if (TREE_CHAIN (t
) == block
)
14014 TREE_CHAIN (t
) = TREE_CHAIN (block
);
14016 t
= TREE_CHAIN (t
);
14018 TREE_CHAIN (block
) = NULL
;
14019 /* Clear TREE_USED which is always set by poplevel.
14020 The flag is set again if insert_block is called. */
14021 TREE_USED (block
) = 0;
14025 insert_block (tree block
)
14027 TREE_USED (block
) = 1;
14028 current_binding_level
->blocks
14029 = chainon (current_binding_level
->blocks
, block
);
14032 /* Each front end provides its own. */
14033 static const char *ffe_init
PARAMS ((const char *));
14034 static void ffe_finish
PARAMS ((void));
14035 static void ffe_init_options
PARAMS ((void));
14036 static void ffe_print_identifier
PARAMS ((FILE *, tree
, int));
14038 struct language_function
GTY(())
14043 #undef LANG_HOOKS_NAME
14044 #define LANG_HOOKS_NAME "GNU F77"
14045 #undef LANG_HOOKS_INIT
14046 #define LANG_HOOKS_INIT ffe_init
14047 #undef LANG_HOOKS_FINISH
14048 #define LANG_HOOKS_FINISH ffe_finish
14049 #undef LANG_HOOKS_INIT_OPTIONS
14050 #define LANG_HOOKS_INIT_OPTIONS ffe_init_options
14051 #undef LANG_HOOKS_DECODE_OPTION
14052 #define LANG_HOOKS_DECODE_OPTION ffe_decode_option
14053 #undef LANG_HOOKS_PARSE_FILE
14054 #define LANG_HOOKS_PARSE_FILE ffe_parse_file
14055 #undef LANG_HOOKS_MARK_ADDRESSABLE
14056 #define LANG_HOOKS_MARK_ADDRESSABLE ffe_mark_addressable
14057 #undef LANG_HOOKS_PRINT_IDENTIFIER
14058 #define LANG_HOOKS_PRINT_IDENTIFIER ffe_print_identifier
14059 #undef LANG_HOOKS_DECL_PRINTABLE_NAME
14060 #define LANG_HOOKS_DECL_PRINTABLE_NAME ffe_printable_name
14061 #undef LANG_HOOKS_PRINT_ERROR_FUNCTION
14062 #define LANG_HOOKS_PRINT_ERROR_FUNCTION ffe_print_error_function
14063 #undef LANG_HOOKS_TRUTHVALUE_CONVERSION
14064 #define LANG_HOOKS_TRUTHVALUE_CONVERSION ffe_truthvalue_conversion
14066 #undef LANG_HOOKS_TYPE_FOR_MODE
14067 #define LANG_HOOKS_TYPE_FOR_MODE ffe_type_for_mode
14068 #undef LANG_HOOKS_TYPE_FOR_SIZE
14069 #define LANG_HOOKS_TYPE_FOR_SIZE ffe_type_for_size
14070 #undef LANG_HOOKS_SIGNED_TYPE
14071 #define LANG_HOOKS_SIGNED_TYPE ffe_signed_type
14072 #undef LANG_HOOKS_UNSIGNED_TYPE
14073 #define LANG_HOOKS_UNSIGNED_TYPE ffe_unsigned_type
14074 #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
14075 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE ffe_signed_or_unsigned_type
14077 /* We do not wish to use alias-set based aliasing at all. Used in the
14078 extreme (every object with its own set, with equivalences recorded) it
14079 might be helpful, but there are problems when it comes to inlining. We
14080 get on ok with flag_argument_noalias, and alias-set aliasing does
14081 currently limit how stack slots can be reused, which is a lose. */
14082 #undef LANG_HOOKS_GET_ALIAS_SET
14083 #define LANG_HOOKS_GET_ALIAS_SET hook_get_alias_set_0
14085 const struct lang_hooks lang_hooks
= LANG_HOOKS_INITIALIZER
;
14087 /* Table indexed by tree code giving a string containing a character
14088 classifying the tree code. Possibilities are
14089 t, d, s, c, r, <, 1, 2 and e. See tree.def for details. */
14091 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
14093 const char tree_code_type
[] = {
14094 #include "tree.def"
14098 /* Table indexed by tree code giving number of expression
14099 operands beyond the fixed part of the node structure.
14100 Not used for types or decls. */
14102 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
14104 const unsigned char tree_code_length
[] = {
14105 #include "tree.def"
14109 /* Names of tree components.
14110 Used for printing out the tree and error messages. */
14111 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
14113 const char *const tree_code_name
[] = {
14114 #include "tree.def"
14118 static const char *
14119 ffe_init (const char *filename
)
14121 /* Open input file. */
14122 if (filename
== 0 || !strcmp (filename
, "-"))
14125 filename
= "stdin";
14128 finput
= fopen (filename
, "r");
14130 fatal_io_error ("can't open %s", filename
);
14132 #ifdef IO_BUFFER_SIZE
14133 setvbuf (finput
, (char *) xmalloc (IO_BUFFER_SIZE
), _IOFBF
, IO_BUFFER_SIZE
);
14136 ffecom_init_decl_processing ();
14138 /* If the file is output from cpp, it should contain a first line
14139 `# 1 "real-filename"', and the current design of gcc (toplev.c
14140 in particular and the way it sets up information relied on by
14141 INCLUDE) requires that we read this now, and store the
14142 "real-filename" info in master_input_filename. Ask the lexer
14143 to try doing this. */
14144 ffelex_hash_kludge (finput
);
14146 /* FIXME: The ffelex_hash_kludge code needs to be cleaned up to
14147 return the new file name. */
14148 if (main_input_filename
)
14149 filename
= main_input_filename
;
14157 ffe_terminate_0 ();
14159 if (ffe_is_ffedebug ())
14160 malloc_pool_display (malloc_pool_image ());
14166 ffe_init_options ()
14168 /* Set default options for Fortran. */
14169 flag_move_all_movables
= 1;
14170 flag_reduce_all_givs
= 1;
14171 flag_argument_noalias
= 2;
14172 flag_merge_constants
= 2;
14173 flag_errno_math
= 0;
14174 flag_complex_divide_method
= 1;
14178 ffe_mark_addressable (tree exp
)
14180 register tree x
= exp
;
14182 switch (TREE_CODE (x
))
14185 case COMPONENT_REF
:
14187 x
= TREE_OPERAND (x
, 0);
14191 TREE_ADDRESSABLE (x
) = 1;
14198 if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
)
14199 && DECL_NONLOCAL (x
))
14201 if (TREE_PUBLIC (x
))
14203 assert ("address of global register var requested" == NULL
);
14206 assert ("address of register variable requested" == NULL
);
14208 else if (DECL_REGISTER (x
) && !TREE_ADDRESSABLE (x
))
14210 if (TREE_PUBLIC (x
))
14212 assert ("address of global register var requested" == NULL
);
14215 assert ("address of register var requested" == NULL
);
14217 put_var_into_stack (x
);
14220 case FUNCTION_DECL
:
14221 TREE_ADDRESSABLE (x
) = 1;
14222 #if 0 /* poplevel deals with this now. */
14223 if (DECL_CONTEXT (x
) == 0)
14224 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x
)) = 1;
14232 /* Exit a binding level.
14233 Pop the level off, and restore the state of the identifier-decl mappings
14234 that were in effect when this level was entered.
14236 If KEEP is nonzero, this level had explicit declarations, so
14237 and create a "block" (a BLOCK node) for the level
14238 to record its declarations and subblocks for symbol table output.
14240 If FUNCTIONBODY is nonzero, this level is the body of a function,
14241 so create a block as if KEEP were set and also clear out all
14244 If REVERSE is nonzero, reverse the order of decls before putting
14245 them into the BLOCK. */
14248 poplevel (int keep
, int reverse
, int functionbody
)
14250 register tree link
;
14251 /* The chain of decls was accumulated in reverse order.
14252 Put it into forward order, just for cleanliness. */
14254 tree subblocks
= current_binding_level
->blocks
;
14257 int block_previously_created
;
14259 /* Get the decls in the order they were written.
14260 Usually current_binding_level->names is in reverse order.
14261 But parameter decls were previously put in forward order. */
14264 current_binding_level
->names
14265 = decls
= nreverse (current_binding_level
->names
);
14267 decls
= current_binding_level
->names
;
14269 /* Output any nested inline functions within this block
14270 if they weren't already output. */
14272 for (decl
= decls
; decl
; decl
= TREE_CHAIN (decl
))
14273 if (TREE_CODE (decl
) == FUNCTION_DECL
14274 && ! TREE_ASM_WRITTEN (decl
)
14275 && DECL_INITIAL (decl
) != 0
14276 && TREE_ADDRESSABLE (decl
))
14278 /* If this decl was copied from a file-scope decl
14279 on account of a block-scope extern decl,
14280 propagate TREE_ADDRESSABLE to the file-scope decl.
14282 DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14283 true, since then the decl goes through save_for_inline_copying. */
14284 if (DECL_ABSTRACT_ORIGIN (decl
) != 0
14285 && DECL_ABSTRACT_ORIGIN (decl
) != decl
)
14286 TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl
)) = 1;
14287 else if (DECL_SAVED_INSNS (decl
) != 0)
14289 push_function_context ();
14290 output_inline_function (decl
);
14291 pop_function_context ();
14295 /* If there were any declarations or structure tags in that level,
14296 or if this level is a function body,
14297 create a BLOCK to record them for the life of this function. */
14300 block_previously_created
= (current_binding_level
->this_block
!= 0);
14301 if (block_previously_created
)
14302 block
= current_binding_level
->this_block
;
14303 else if (keep
|| functionbody
)
14304 block
= make_node (BLOCK
);
14307 BLOCK_VARS (block
) = decls
;
14308 BLOCK_SUBBLOCKS (block
) = subblocks
;
14311 /* In each subblock, record that this is its superior. */
14313 for (link
= subblocks
; link
; link
= TREE_CHAIN (link
))
14314 BLOCK_SUPERCONTEXT (link
) = block
;
14316 /* Clear out the meanings of the local variables of this level. */
14318 for (link
= decls
; link
; link
= TREE_CHAIN (link
))
14320 if (DECL_NAME (link
) != 0)
14322 /* If the ident. was used or addressed via a local extern decl,
14323 don't forget that fact. */
14324 if (DECL_EXTERNAL (link
))
14326 if (TREE_USED (link
))
14327 TREE_USED (DECL_NAME (link
)) = 1;
14328 if (TREE_ADDRESSABLE (link
))
14329 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link
)) = 1;
14331 IDENTIFIER_LOCAL_VALUE (DECL_NAME (link
)) = 0;
14335 /* If the level being exited is the top level of a function,
14336 check over all the labels, and clear out the current
14337 (function local) meanings of their names. */
14341 /* If this is the top level block of a function,
14342 the vars are the function's parameters.
14343 Don't leave them in the BLOCK because they are
14344 found in the FUNCTION_DECL instead. */
14346 BLOCK_VARS (block
) = 0;
14349 /* Pop the current level, and free the structure for reuse. */
14352 register struct f_binding_level
*level
= current_binding_level
;
14353 current_binding_level
= current_binding_level
->level_chain
;
14355 level
->level_chain
= free_binding_level
;
14356 free_binding_level
= level
;
14359 /* Dispose of the block that we just made inside some higher level. */
14361 && current_function_decl
!= error_mark_node
)
14362 DECL_INITIAL (current_function_decl
) = block
;
14365 if (!block_previously_created
)
14366 current_binding_level
->blocks
14367 = chainon (current_binding_level
->blocks
, block
);
14369 /* If we did not make a block for the level just exited,
14370 any blocks made for inner levels
14371 (since they cannot be recorded as subblocks in that level)
14372 must be carried forward so they will later become subblocks
14373 of something else. */
14374 else if (subblocks
)
14375 current_binding_level
->blocks
14376 = chainon (current_binding_level
->blocks
, subblocks
);
14379 TREE_USED (block
) = 1;
14384 ffe_print_identifier (FILE *file
, tree node
, int indent
)
14386 print_node (file
, "global", IDENTIFIER_GLOBAL_VALUE (node
), indent
+ 4);
14387 print_node (file
, "local", IDENTIFIER_LOCAL_VALUE (node
), indent
+ 4);
14390 /* Record a decl-node X as belonging to the current lexical scope.
14391 Check for errors (such as an incompatible declaration for the same
14392 name already seen in the same scope).
14394 Returns either X or an old decl for the same name.
14395 If an old decl is returned, it may have been smashed
14396 to agree with what X says. */
14402 register tree name
= DECL_NAME (x
);
14403 register struct f_binding_level
*b
= current_binding_level
;
14405 if ((TREE_CODE (x
) == FUNCTION_DECL
)
14406 && (DECL_INITIAL (x
) == 0)
14407 && DECL_EXTERNAL (x
))
14408 DECL_CONTEXT (x
) = NULL_TREE
;
14410 DECL_CONTEXT (x
) = current_function_decl
;
14414 if (IDENTIFIER_INVENTED (name
))
14416 DECL_ARTIFICIAL (x
) = 1;
14417 DECL_IN_SYSTEM_HEADER (x
) = 1;
14420 t
= lookup_name_current_level (name
);
14422 assert ((t
== NULL_TREE
) || (DECL_CONTEXT (x
) == NULL_TREE
));
14424 /* Don't push non-parms onto list for parms until we understand
14425 why we're doing this and whether it works. */
14427 assert ((b
== global_binding_level
)
14428 || !ffecom_transform_only_dummies_
14429 || TREE_CODE (x
) == PARM_DECL
);
14431 if ((t
!= NULL_TREE
) && duplicate_decls (x
, t
))
14434 /* If we are processing a typedef statement, generate a whole new
14435 ..._TYPE node (which will be just an variant of the existing
14436 ..._TYPE node with identical properties) and then install the
14437 TYPE_DECL node generated to represent the typedef name as the
14438 TYPE_NAME of this brand new (duplicate) ..._TYPE node.
14440 The whole point here is to end up with a situation where each and every
14441 ..._TYPE node the compiler creates will be uniquely associated with
14442 AT MOST one node representing a typedef name. This way, even though
14443 the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
14444 (i.e. "typedef name") nodes very early on, later parts of the
14445 compiler can always do the reverse translation and get back the
14446 corresponding typedef name. For example, given:
14448 typedef struct S MY_TYPE; MY_TYPE object;
14450 Later parts of the compiler might only know that `object' was of type
14451 `struct S' if it were not for code just below. With this code
14452 however, later parts of the compiler see something like:
14454 struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
14456 And they can then deduce (from the node for type struct S') that the
14457 original object declaration was:
14461 Being able to do this is important for proper support of protoize, and
14462 also for generating precise symbolic debugging information which
14463 takes full account of the programmer's (typedef) vocabulary.
14465 Obviously, we don't want to generate a duplicate ..._TYPE node if the
14466 TYPE_DECL node that we are now processing really represents a
14467 standard built-in type.
14469 Since all standard types are effectively declared at line zero in the
14470 source file, we can easily check to see if we are working on a
14471 standard type by checking the current value of lineno. */
14473 if (TREE_CODE (x
) == TYPE_DECL
)
14475 if (DECL_SOURCE_LINE (x
) == 0)
14477 if (TYPE_NAME (TREE_TYPE (x
)) == 0)
14478 TYPE_NAME (TREE_TYPE (x
)) = x
;
14480 else if (TREE_TYPE (x
) != error_mark_node
)
14482 tree tt
= TREE_TYPE (x
);
14484 tt
= build_type_copy (tt
);
14485 TYPE_NAME (tt
) = x
;
14486 TREE_TYPE (x
) = tt
;
14490 /* This name is new in its binding level. Install the new declaration
14492 if (b
== global_binding_level
)
14493 IDENTIFIER_GLOBAL_VALUE (name
) = x
;
14495 IDENTIFIER_LOCAL_VALUE (name
) = x
;
14498 /* Put decls on list in reverse order. We will reverse them later if
14500 TREE_CHAIN (x
) = b
->names
;
14506 /* Nonzero if the current level needs to have a BLOCK made. */
14513 for (decl
= current_binding_level
->names
;
14515 decl
= TREE_CHAIN (decl
))
14517 if (TREE_USED (decl
) || TREE_CODE (decl
) != VAR_DECL
14518 || (DECL_NAME (decl
) && ! DECL_ARTIFICIAL (decl
)))
14519 /* Currently, there aren't supposed to be non-artificial names
14520 at other than the top block for a function -- they're
14521 believed to always be temps. But it's wise to check anyway. */
14527 /* Enter a new binding level.
14528 If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
14529 not for that of tags. */
14532 pushlevel (int tag_transparent
)
14534 register struct f_binding_level
*newlevel
= NULL_BINDING_LEVEL
;
14536 assert (! tag_transparent
);
14538 if (current_binding_level
== global_binding_level
)
14543 /* Reuse or create a struct for this binding level. */
14545 if (free_binding_level
)
14547 newlevel
= free_binding_level
;
14548 free_binding_level
= free_binding_level
->level_chain
;
14552 newlevel
= make_binding_level ();
14555 /* Add this level to the front of the chain (stack) of levels that
14558 *newlevel
= clear_binding_level
;
14559 newlevel
->level_chain
= current_binding_level
;
14560 current_binding_level
= newlevel
;
14563 /* Set the BLOCK node for the innermost scope
14564 (the one we are currently in). */
14567 set_block (tree block
)
14569 current_binding_level
->this_block
= block
;
14570 current_binding_level
->names
= chainon (current_binding_level
->names
,
14571 BLOCK_VARS (block
));
14572 current_binding_level
->blocks
= chainon (current_binding_level
->blocks
,
14573 BLOCK_SUBBLOCKS (block
));
14577 ffe_signed_or_unsigned_type (int unsignedp
, tree type
)
14581 if (! INTEGRAL_TYPE_P (type
))
14583 if (TYPE_PRECISION (type
) == TYPE_PRECISION (signed_char_type_node
))
14584 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
14585 if (TYPE_PRECISION (type
) == TYPE_PRECISION (integer_type_node
))
14586 return unsignedp
? unsigned_type_node
: integer_type_node
;
14587 if (TYPE_PRECISION (type
) == TYPE_PRECISION (short_integer_type_node
))
14588 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
14589 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_integer_type_node
))
14590 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
14591 if (TYPE_PRECISION (type
) == TYPE_PRECISION (long_long_integer_type_node
))
14592 return (unsignedp
? long_long_unsigned_type_node
14593 : long_long_integer_type_node
);
14595 type2
= ffe_type_for_size (TYPE_PRECISION (type
), unsignedp
);
14596 if (type2
== NULL_TREE
)
14603 ffe_signed_type (tree type
)
14605 tree type1
= TYPE_MAIN_VARIANT (type
);
14606 ffeinfoKindtype kt
;
14609 if (type1
== unsigned_char_type_node
|| type1
== char_type_node
)
14610 return signed_char_type_node
;
14611 if (type1
== unsigned_type_node
)
14612 return integer_type_node
;
14613 if (type1
== short_unsigned_type_node
)
14614 return short_integer_type_node
;
14615 if (type1
== long_unsigned_type_node
)
14616 return long_integer_type_node
;
14617 if (type1
== long_long_unsigned_type_node
)
14618 return long_long_integer_type_node
;
14619 #if 0 /* gcc/c-* files only */
14620 if (type1
== unsigned_intDI_type_node
)
14621 return intDI_type_node
;
14622 if (type1
== unsigned_intSI_type_node
)
14623 return intSI_type_node
;
14624 if (type1
== unsigned_intHI_type_node
)
14625 return intHI_type_node
;
14626 if (type1
== unsigned_intQI_type_node
)
14627 return intQI_type_node
;
14630 type2
= ffe_type_for_size (TYPE_PRECISION (type1
), 0);
14631 if (type2
!= NULL_TREE
)
14634 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
14636 type2
= ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
14638 if (type1
== type2
)
14639 return ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
14645 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
14646 or validate its data type for an `if' or `while' statement or ?..: exp.
14648 This preparation consists of taking the ordinary
14649 representation of an expression expr and producing a valid tree
14650 boolean expression describing whether expr is nonzero. We could
14651 simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
14652 but we optimize comparisons, &&, ||, and !.
14654 The resulting type should always be `integer_type_node'. */
14657 ffe_truthvalue_conversion (tree expr
)
14659 if (TREE_CODE (expr
) == ERROR_MARK
)
14662 #if 0 /* This appears to be wrong for C++. */
14663 /* These really should return error_mark_node after 2.4 is stable.
14664 But not all callers handle ERROR_MARK properly. */
14665 switch (TREE_CODE (TREE_TYPE (expr
)))
14668 error ("struct type value used where scalar is required");
14669 return integer_zero_node
;
14672 error ("union type value used where scalar is required");
14673 return integer_zero_node
;
14676 error ("array type value used where scalar is required");
14677 return integer_zero_node
;
14684 switch (TREE_CODE (expr
))
14686 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14687 or comparison expressions as truth values at this level. */
14689 case COMPONENT_REF
:
14690 /* A one-bit unsigned bit-field is already acceptable. */
14691 if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr
, 1)))
14692 && TREE_UNSIGNED (TREE_OPERAND (expr
, 1)))
14698 /* It is simpler and generates better code to have only TRUTH_*_EXPR
14699 or comparison expressions as truth values at this level. */
14701 if (integer_zerop (TREE_OPERAND (expr
, 1)))
14702 return build_unary_op (TRUTH_NOT_EXPR
, TREE_OPERAND (expr
, 0), 0);
14704 case NE_EXPR
: case LE_EXPR
: case GE_EXPR
: case LT_EXPR
: case GT_EXPR
:
14705 case TRUTH_ANDIF_EXPR
:
14706 case TRUTH_ORIF_EXPR
:
14707 case TRUTH_AND_EXPR
:
14708 case TRUTH_OR_EXPR
:
14709 case TRUTH_XOR_EXPR
:
14710 TREE_TYPE (expr
) = integer_type_node
;
14717 return integer_zerop (expr
) ? integer_zero_node
: integer_one_node
;
14720 return real_zerop (expr
) ? integer_zero_node
: integer_one_node
;
14723 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 0)))
14724 return build (COMPOUND_EXPR
, integer_type_node
,
14725 TREE_OPERAND (expr
, 0), integer_one_node
);
14727 return integer_one_node
;
14730 return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1))
14731 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
14733 ffe_truthvalue_conversion (TREE_OPERAND (expr
, 0)),
14734 ffe_truthvalue_conversion (TREE_OPERAND (expr
, 1)));
14740 /* These don't change whether an object is nonzero or zero. */
14741 return ffe_truthvalue_conversion (TREE_OPERAND (expr
, 0));
14745 /* These don't change whether an object is zero or nonzero, but
14746 we can't ignore them if their second arg has side-effects. */
14747 if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr
, 1)))
14748 return build (COMPOUND_EXPR
, integer_type_node
, TREE_OPERAND (expr
, 1),
14749 ffe_truthvalue_conversion (TREE_OPERAND (expr
, 0)));
14751 return ffe_truthvalue_conversion (TREE_OPERAND (expr
, 0));
14755 /* Distribute the conversion into the arms of a COND_EXPR. */
14756 tree arg1
= TREE_OPERAND (expr
, 1);
14757 tree arg2
= TREE_OPERAND (expr
, 2);
14758 if (! VOID_TYPE_P (TREE_TYPE (arg1
)))
14759 arg1
= ffe_truthvalue_conversion (arg1
);
14760 if (! VOID_TYPE_P (TREE_TYPE (arg2
)))
14761 arg2
= ffe_truthvalue_conversion (arg2
);
14762 return fold (build (COND_EXPR
, integer_type_node
,
14763 TREE_OPERAND (expr
, 0), arg1
, arg2
));
14767 /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
14768 since that affects how `default_conversion' will behave. */
14769 if (TREE_CODE (TREE_TYPE (expr
)) == REFERENCE_TYPE
14770 || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr
, 0))) == REFERENCE_TYPE
)
14772 /* fall through... */
14774 /* If this is widening the argument, we can ignore it. */
14775 if (TYPE_PRECISION (TREE_TYPE (expr
))
14776 >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr
, 0))))
14777 return ffe_truthvalue_conversion (TREE_OPERAND (expr
, 0));
14781 /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
14783 if (TARGET_FLOAT_FORMAT
== IEEE_FLOAT_FORMAT
14784 && TREE_CODE (TREE_TYPE (expr
)) == REAL_TYPE
)
14786 /* fall through... */
14788 /* This and MINUS_EXPR can be changed into a comparison of the
14790 if (TREE_TYPE (TREE_OPERAND (expr
, 0))
14791 == TREE_TYPE (TREE_OPERAND (expr
, 1)))
14792 return ffecom_2 (NE_EXPR
, integer_type_node
,
14793 TREE_OPERAND (expr
, 0),
14794 TREE_OPERAND (expr
, 1));
14795 return ffecom_2 (NE_EXPR
, integer_type_node
,
14796 TREE_OPERAND (expr
, 0),
14797 fold (build1 (NOP_EXPR
,
14798 TREE_TYPE (TREE_OPERAND (expr
, 0)),
14799 TREE_OPERAND (expr
, 1))));
14802 if (integer_onep (TREE_OPERAND (expr
, 1)))
14807 #if 0 /* No such thing in Fortran. */
14808 if (warn_parentheses
&& C_EXP_ORIGINAL_CODE (expr
) == MODIFY_EXPR
)
14809 warning ("suggest parentheses around assignment used as truth value");
14817 if (TREE_CODE (TREE_TYPE (expr
)) == COMPLEX_TYPE
)
14819 ((TREE_SIDE_EFFECTS (expr
)
14820 ? TRUTH_OR_EXPR
: TRUTH_ORIF_EXPR
),
14822 ffe_truthvalue_conversion (ffecom_1 (REALPART_EXPR
,
14823 TREE_TYPE (TREE_TYPE (expr
)),
14825 ffe_truthvalue_conversion (ffecom_1 (IMAGPART_EXPR
,
14826 TREE_TYPE (TREE_TYPE (expr
)),
14829 return ffecom_2 (NE_EXPR
, integer_type_node
,
14831 convert (TREE_TYPE (expr
), integer_zero_node
));
14835 ffe_type_for_mode (enum machine_mode mode
, int unsignedp
)
14841 if (mode
== TYPE_MODE (integer_type_node
))
14842 return unsignedp
? unsigned_type_node
: integer_type_node
;
14844 if (mode
== TYPE_MODE (signed_char_type_node
))
14845 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
14847 if (mode
== TYPE_MODE (short_integer_type_node
))
14848 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
14850 if (mode
== TYPE_MODE (long_integer_type_node
))
14851 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
14853 if (mode
== TYPE_MODE (long_long_integer_type_node
))
14854 return unsignedp
? long_long_unsigned_type_node
: long_long_integer_type_node
;
14856 #if HOST_BITS_PER_WIDE_INT >= 64
14857 if (mode
== TYPE_MODE (intTI_type_node
))
14858 return unsignedp
? unsigned_intTI_type_node
: intTI_type_node
;
14861 if (mode
== TYPE_MODE (float_type_node
))
14862 return float_type_node
;
14864 if (mode
== TYPE_MODE (double_type_node
))
14865 return double_type_node
;
14867 if (mode
== TYPE_MODE (long_double_type_node
))
14868 return long_double_type_node
;
14870 if (mode
== TYPE_MODE (build_pointer_type (char_type_node
)))
14871 return build_pointer_type (char_type_node
);
14873 if (mode
== TYPE_MODE (build_pointer_type (integer_type_node
)))
14874 return build_pointer_type (integer_type_node
);
14876 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffecom_tree_type
); ++i
)
14877 for (j
= 0; ((size_t) j
) < ARRAY_SIZE (ffecom_tree_type
[0]); ++j
)
14879 if (((t
= ffecom_tree_type
[i
][j
]) != NULL_TREE
)
14880 && (mode
== TYPE_MODE (t
)))
14882 if ((i
== FFEINFO_basictypeINTEGER
) && unsignedp
)
14883 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][j
];
14893 ffe_type_for_size (unsigned bits
, int unsignedp
)
14895 ffeinfoKindtype kt
;
14898 if (bits
== TYPE_PRECISION (integer_type_node
))
14899 return unsignedp
? unsigned_type_node
: integer_type_node
;
14901 if (bits
== TYPE_PRECISION (signed_char_type_node
))
14902 return unsignedp
? unsigned_char_type_node
: signed_char_type_node
;
14904 if (bits
== TYPE_PRECISION (short_integer_type_node
))
14905 return unsignedp
? short_unsigned_type_node
: short_integer_type_node
;
14907 if (bits
== TYPE_PRECISION (long_integer_type_node
))
14908 return unsignedp
? long_unsigned_type_node
: long_integer_type_node
;
14910 if (bits
== TYPE_PRECISION (long_long_integer_type_node
))
14911 return (unsignedp
? long_long_unsigned_type_node
14912 : long_long_integer_type_node
);
14914 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
14916 type_node
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
14918 if ((type_node
!= NULL_TREE
) && (bits
== TYPE_PRECISION (type_node
)))
14919 return unsignedp
? ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
]
14927 ffe_unsigned_type (tree type
)
14929 tree type1
= TYPE_MAIN_VARIANT (type
);
14930 ffeinfoKindtype kt
;
14933 if (type1
== signed_char_type_node
|| type1
== char_type_node
)
14934 return unsigned_char_type_node
;
14935 if (type1
== integer_type_node
)
14936 return unsigned_type_node
;
14937 if (type1
== short_integer_type_node
)
14938 return short_unsigned_type_node
;
14939 if (type1
== long_integer_type_node
)
14940 return long_unsigned_type_node
;
14941 if (type1
== long_long_integer_type_node
)
14942 return long_long_unsigned_type_node
;
14943 #if 0 /* gcc/c-* files only */
14944 if (type1
== intDI_type_node
)
14945 return unsigned_intDI_type_node
;
14946 if (type1
== intSI_type_node
)
14947 return unsigned_intSI_type_node
;
14948 if (type1
== intHI_type_node
)
14949 return unsigned_intHI_type_node
;
14950 if (type1
== intQI_type_node
)
14951 return unsigned_intQI_type_node
;
14954 type2
= ffe_type_for_size (TYPE_PRECISION (type1
), 1);
14955 if (type2
!= NULL_TREE
)
14958 for (kt
= 0; kt
< ARRAY_SIZE (ffecom_tree_type
[0]); ++kt
)
14960 type2
= ffecom_tree_type
[FFEINFO_basictypeINTEGER
][kt
];
14962 if (type1
== type2
)
14963 return ffecom_tree_type
[FFEINFO_basictypeHOLLERITH
][kt
];
14969 /* From gcc/cccp.c, the code to handle -I. */
14971 /* Skip leading "./" from a directory name.
14972 This may yield the empty string, which represents the current directory. */
14974 static const char *
14975 skip_redundant_dir_prefix (const char *dir
)
14977 while (dir
[0] == '.' && dir
[1] == '/')
14978 for (dir
+= 2; *dir
== '/'; dir
++)
14980 if (dir
[0] == '.' && !dir
[1])
14985 /* The file_name_map structure holds a mapping of file names for a
14986 particular directory. This mapping is read from the file named
14987 FILE_NAME_MAP_FILE in that directory. Such a file can be used to
14988 map filenames on a file system with severe filename restrictions,
14989 such as DOS. The format of the file name map file is just a series
14990 of lines with two tokens on each line. The first token is the name
14991 to map, and the second token is the actual name to use. */
14993 struct file_name_map
14995 struct file_name_map
*map_next
;
15000 #define FILE_NAME_MAP_FILE "header.gcc"
15002 /* Current maximum length of directory names in the search path
15003 for include files. (Altered as we get more of them.) */
15005 static int max_include_len
= 0;
15007 struct file_name_list
15009 struct file_name_list
*next
;
15011 /* Mapping of file names for this directory. */
15012 struct file_name_map
*name_map
;
15013 /* Nonzero if name_map is valid. */
15017 static struct file_name_list
*include
= NULL
; /* First dir to search */
15018 static struct file_name_list
*last_include
= NULL
; /* Last in chain */
15020 /* I/O buffer structure.
15021 The `fname' field is nonzero for source files and #include files
15022 and for the dummy text used for -D and -U.
15023 It is zero for rescanning results of macro expansion
15024 and for expanding macro arguments. */
15025 #define INPUT_STACK_MAX 400
15026 static struct file_buf
{
15028 /* Filename specified with #line command. */
15029 const char *nominal_fname
;
15030 /* Record where in the search path this file was found.
15031 For #include_next. */
15032 struct file_name_list
*dir
;
15034 ffewhereColumn column
;
15035 } instack
[INPUT_STACK_MAX
];
15037 static int last_error_tick
= 0; /* Incremented each time we print it. */
15038 static int input_file_stack_tick
= 0; /* Incremented when status changes. */
15040 /* Current nesting level of input sources.
15041 `instack[indepth]' is the level currently being read. */
15042 static int indepth
= -1;
15044 typedef struct file_buf FILE_BUF
;
15046 /* Nonzero means -I- has been seen,
15047 so don't look for #include "foo" the source-file directory. */
15048 static int ignore_srcdir
;
15050 #ifndef INCLUDE_LEN_FUDGE
15051 #define INCLUDE_LEN_FUDGE 0
15054 static void append_include_chain (struct file_name_list
*first
,
15055 struct file_name_list
*last
);
15056 static FILE *open_include_file (char *filename
,
15057 struct file_name_list
*searchptr
);
15058 static void print_containing_files (ffebadSeverity sev
);
15059 static char *read_filename_string (int ch
, FILE *f
);
15060 static struct file_name_map
*read_name_map (const char *dirname
);
15062 /* Append a chain of `struct file_name_list's
15063 to the end of the main include chain.
15064 FIRST is the beginning of the chain to append, and LAST is the end. */
15067 append_include_chain (struct file_name_list
*first
, struct file_name_list
*last
)
15069 struct file_name_list
*dir
;
15071 if (!first
|| !last
)
15077 last_include
->next
= first
;
15079 for (dir
= first
; ; dir
= dir
->next
) {
15080 int len
= strlen (dir
->fname
) + INCLUDE_LEN_FUDGE
;
15081 if (len
> max_include_len
)
15082 max_include_len
= len
;
15088 last_include
= last
;
15091 /* Try to open include file FILENAME. SEARCHPTR is the directory
15092 being tried from the include file search path. This function maps
15093 filenames on file systems based on information read by
15097 open_include_file (char *filename
, struct file_name_list
*searchptr
)
15099 register struct file_name_map
*map
;
15100 register char *from
;
15103 if (searchptr
&& ! searchptr
->got_name_map
)
15105 searchptr
->name_map
= read_name_map (searchptr
->fname
15106 ? searchptr
->fname
: ".");
15107 searchptr
->got_name_map
= 1;
15110 /* First check the mapping for the directory we are using. */
15111 if (searchptr
&& searchptr
->name_map
)
15114 if (searchptr
->fname
)
15115 from
+= strlen (searchptr
->fname
) + 1;
15116 for (map
= searchptr
->name_map
; map
; map
= map
->map_next
)
15118 if (! strcmp (map
->map_from
, from
))
15120 /* Found a match. */
15121 return fopen (map
->map_to
, "r");
15126 /* Try to find a mapping file for the particular directory we are
15127 looking in. Thus #include <sys/types.h> will look up sys/types.h
15128 in /usr/include/header.gcc and look up types.h in
15129 /usr/include/sys/header.gcc. */
15130 p
= strrchr (filename
, '/');
15131 #ifdef DIR_SEPARATOR
15132 if (! p
) p
= strrchr (filename
, DIR_SEPARATOR
);
15134 char *tmp
= strrchr (filename
, DIR_SEPARATOR
);
15135 if (tmp
!= NULL
&& tmp
> p
) p
= tmp
;
15141 && searchptr
->fname
15142 && strlen (searchptr
->fname
) == (size_t) (p
- filename
)
15143 && ! strncmp (searchptr
->fname
, filename
, (int) (p
- filename
)))
15145 /* FILENAME is in SEARCHPTR, which we've already checked. */
15146 return fopen (filename
, "r");
15152 map
= read_name_map (".");
15156 dir
= (char *) xmalloc (p
- filename
+ 1);
15157 memcpy (dir
, filename
, p
- filename
);
15158 dir
[p
- filename
] = '\0';
15160 map
= read_name_map (dir
);
15163 for (; map
; map
= map
->map_next
)
15164 if (! strcmp (map
->map_from
, from
))
15165 return fopen (map
->map_to
, "r");
15167 return fopen (filename
, "r");
15170 /* Print the file names and line numbers of the #include
15171 commands which led to the current file. */
15174 print_containing_files (ffebadSeverity sev
)
15176 FILE_BUF
*ip
= NULL
;
15182 /* If stack of files hasn't changed since we last printed
15183 this info, don't repeat it. */
15184 if (last_error_tick
== input_file_stack_tick
)
15187 for (i
= indepth
; i
>= 0; i
--)
15188 if (instack
[i
].fname
!= NULL
) {
15193 /* Give up if we don't find a source file. */
15197 /* Find the other, outer source files. */
15198 for (i
--; i
>= 0; i
--)
15199 if (instack
[i
].fname
!= NULL
)
15205 str1
= "In file included";
15217 /* xgettext:no-c-format */
15218 ffebad_start_msg ("%A from %B at %0%C", sev
);
15219 ffebad_here (0, ip
->line
, ip
->column
);
15220 ffebad_string (str1
);
15221 ffebad_string (ip
->nominal_fname
);
15222 ffebad_string (str2
);
15226 /* Record we have printed the status as of this time. */
15227 last_error_tick
= input_file_stack_tick
;
15230 /* Read a space delimited string of unlimited length from a stdio
15234 read_filename_string (int ch
, FILE *f
)
15240 set
= alloc
= xmalloc (len
+ 1);
15241 if (! ISSPACE (ch
))
15244 while ((ch
= getc (f
)) != EOF
&& ! ISSPACE (ch
))
15246 if (set
- alloc
== len
)
15249 alloc
= xrealloc (alloc
, len
+ 1);
15250 set
= alloc
+ len
/ 2;
15260 /* Read the file name map file for DIRNAME. */
15262 static struct file_name_map
*
15263 read_name_map (const char *dirname
)
15265 /* This structure holds a linked list of file name maps, one per
15267 struct file_name_map_list
15269 struct file_name_map_list
*map_list_next
;
15270 char *map_list_name
;
15271 struct file_name_map
*map_list_map
;
15273 static struct file_name_map_list
*map_list
;
15274 register struct file_name_map_list
*map_list_ptr
;
15278 int separator_needed
;
15280 dirname
= skip_redundant_dir_prefix (dirname
);
15282 for (map_list_ptr
= map_list
; map_list_ptr
;
15283 map_list_ptr
= map_list_ptr
->map_list_next
)
15284 if (! strcmp (map_list_ptr
->map_list_name
, dirname
))
15285 return map_list_ptr
->map_list_map
;
15287 map_list_ptr
= ((struct file_name_map_list
*)
15288 xmalloc (sizeof (struct file_name_map_list
)));
15289 map_list_ptr
->map_list_name
= xstrdup (dirname
);
15290 map_list_ptr
->map_list_map
= NULL
;
15292 dirlen
= strlen (dirname
);
15293 separator_needed
= dirlen
!= 0 && dirname
[dirlen
- 1] != '/';
15294 if (separator_needed
)
15295 name
= concat (dirname
, "/", FILE_NAME_MAP_FILE
, NULL
);
15297 name
= concat (dirname
, FILE_NAME_MAP_FILE
, NULL
);
15298 f
= fopen (name
, "r");
15301 map_list_ptr
->map_list_map
= NULL
;
15306 while ((ch
= getc (f
)) != EOF
)
15309 struct file_name_map
*ptr
;
15313 from
= read_filename_string (ch
, f
);
15314 while ((ch
= getc (f
)) != EOF
&& ISSPACE (ch
) && ch
!= '\n')
15316 to
= read_filename_string (ch
, f
);
15318 ptr
= ((struct file_name_map
*)
15319 xmalloc (sizeof (struct file_name_map
)));
15320 ptr
->map_from
= from
;
15322 /* Make the real filename absolute. */
15327 if (separator_needed
)
15328 ptr
->map_to
= concat (dirname
, "/", to
, NULL
);
15330 ptr
->map_to
= concat (dirname
, to
, NULL
);
15334 ptr
->map_next
= map_list_ptr
->map_list_map
;
15335 map_list_ptr
->map_list_map
= ptr
;
15337 while ((ch
= getc (f
)) != '\n')
15344 map_list_ptr
->map_list_next
= map_list
;
15345 map_list
= map_list_ptr
;
15347 return map_list_ptr
->map_list_map
;
15351 ffecom_file_ (const char *name
)
15355 /* Do partial setup of input buffer for the sake of generating
15356 early #line directives (when -g is in effect). */
15358 fp
= &instack
[++indepth
];
15359 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
15362 fp
->nominal_fname
= fp
->fname
= name
;
15366 ffecom_close_include_ (FILE *f
)
15371 input_file_stack_tick
++;
15373 ffewhere_line_kill (instack
[indepth
].line
);
15374 ffewhere_column_kill (instack
[indepth
].column
);
15378 ffecom_decode_include_option_ (char *spec
)
15380 struct file_name_list
*dirtmp
;
15382 if (! ignore_srcdir
&& !strcmp (spec
, "-"))
15386 dirtmp
= (struct file_name_list
*)
15387 xmalloc (sizeof (struct file_name_list
));
15388 dirtmp
->next
= 0; /* New one goes on the end */
15389 dirtmp
->fname
= spec
;
15390 dirtmp
->got_name_map
= 0;
15392 error ("directory name must immediately follow -I");
15394 append_include_chain (dirtmp
, dirtmp
);
15399 /* Open INCLUDEd file. */
15402 ffecom_open_include_ (char *name
, ffewhereLine l
, ffewhereColumn c
)
15405 size_t flen
= strlen (fbeg
);
15406 struct file_name_list
*search_start
= include
; /* Chain of dirs to search */
15407 struct file_name_list dsp
[1]; /* First in chain, if #include "..." */
15408 struct file_name_list
*searchptr
= 0;
15409 char *fname
; /* Dynamically allocated fname buffer */
15416 dsp
[0].fname
= NULL
;
15418 /* If -I- was specified, don't search current dir, only spec'd ones. */
15419 if (!ignore_srcdir
)
15421 for (fp
= &instack
[indepth
]; fp
>= instack
; fp
--)
15427 if ((nam
= fp
->nominal_fname
) != NULL
)
15429 /* Found a named file. Figure out dir of the file,
15430 and put it in front of the search list. */
15431 dsp
[0].next
= search_start
;
15432 search_start
= dsp
;
15434 ep
= strrchr (nam
, '/');
15435 #ifdef DIR_SEPARATOR
15436 if (ep
== NULL
) ep
= strrchr (nam
, DIR_SEPARATOR
);
15438 char *tmp
= strrchr (nam
, DIR_SEPARATOR
);
15439 if (tmp
!= NULL
&& tmp
> ep
) ep
= tmp
;
15443 ep
= strrchr (nam
, ']');
15444 if (ep
== NULL
) ep
= strrchr (nam
, '>');
15445 if (ep
== NULL
) ep
= strrchr (nam
, ':');
15446 if (ep
!= NULL
) ep
++;
15451 dsp
[0].fname
= (char *) xmalloc (n
+ 1);
15452 strncpy (dsp
[0].fname
, nam
, n
);
15453 dsp
[0].fname
[n
] = '\0';
15454 if (n
+ INCLUDE_LEN_FUDGE
> max_include_len
)
15455 max_include_len
= n
+ INCLUDE_LEN_FUDGE
;
15458 dsp
[0].fname
= NULL
; /* Current directory */
15459 dsp
[0].got_name_map
= 0;
15465 /* Allocate this permanently, because it gets stored in the definitions
15467 fname
= xmalloc (max_include_len
+ flen
+ 4);
15468 /* + 2 above for slash and terminating null. */
15469 /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
15472 /* If specified file name is absolute, just open it. */
15475 #ifdef DIR_SEPARATOR
15476 || *fbeg
== DIR_SEPARATOR
15480 strncpy (fname
, (char *) fbeg
, flen
);
15482 f
= open_include_file (fname
, NULL
);
15488 /* Search directory path, trying to open the file.
15489 Copy each filename tried into FNAME. */
15491 for (searchptr
= search_start
; searchptr
; searchptr
= searchptr
->next
)
15493 if (searchptr
->fname
)
15495 /* The empty string in a search path is ignored.
15496 This makes it possible to turn off entirely
15497 a standard piece of the list. */
15498 if (searchptr
->fname
[0] == 0)
15500 strcpy (fname
, skip_redundant_dir_prefix (searchptr
->fname
));
15501 if (fname
[0] && fname
[strlen (fname
) - 1] != '/')
15502 strcat (fname
, "/");
15503 fname
[strlen (fname
) + flen
] = 0;
15508 strncat (fname
, fbeg
, flen
);
15510 /* Change this 1/2 Unix 1/2 VMS file specification into a
15511 full VMS file specification */
15512 if (searchptr
->fname
&& (searchptr
->fname
[0] != 0))
15514 /* Fix up the filename */
15515 hack_vms_include_specification (fname
);
15519 /* This is a normal VMS filespec, so use it unchanged. */
15520 strncpy (fname
, (char *) fbeg
, flen
);
15522 #if 0 /* Not for g77. */
15523 /* if it's '#include filename', add the missing .h */
15524 if (strchr (fname
, '.') == NULL
)
15525 strcat (fname
, ".h");
15529 f
= open_include_file (fname
, searchptr
);
15531 if (f
== NULL
&& errno
== EACCES
)
15533 print_containing_files (FFEBAD_severityWARNING
);
15534 /* xgettext:no-c-format */
15535 ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
15536 FFEBAD_severityWARNING
);
15537 ffebad_string (fname
);
15538 ffebad_here (0, l
, c
);
15549 /* A file that was not found. */
15551 strncpy (fname
, (char *) fbeg
, flen
);
15553 print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE
));
15554 ffebad_start (FFEBAD_OPEN_INCLUDE
);
15555 ffebad_here (0, l
, c
);
15556 ffebad_string (fname
);
15560 if (dsp
[0].fname
!= NULL
)
15561 free (dsp
[0].fname
);
15566 if (indepth
>= (INPUT_STACK_MAX
- 1))
15568 print_containing_files (FFEBAD_severityFATAL
);
15569 /* xgettext:no-c-format */
15570 ffebad_start_msg ("At %0, INCLUDE nesting too deep",
15571 FFEBAD_severityFATAL
);
15572 ffebad_string (fname
);
15573 ffebad_here (0, l
, c
);
15578 instack
[indepth
].line
= ffewhere_line_use (l
);
15579 instack
[indepth
].column
= ffewhere_column_use (c
);
15581 fp
= &instack
[indepth
+ 1];
15582 memset ((char *) fp
, 0, sizeof (FILE_BUF
));
15583 fp
->nominal_fname
= fp
->fname
= fname
;
15584 fp
->dir
= searchptr
;
15587 input_file_stack_tick
++;
15592 /**INDENT* (Do not reformat this comment even with -fca option.)
15593 Data-gathering files: Given the source file listed below, compiled with
15594 f2c I obtained the output file listed after that, and from the output
15595 file I derived the above code.
15597 -------- (begin input file to f2c)
15603 double precision D1,D2
15605 call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
15632 c FFEINTRIN_impACOS
15633 call fooR(ACOS(R1))
15634 c FFEINTRIN_impAIMAG
15635 call fooR(AIMAG(C1))
15636 c FFEINTRIN_impAINT
15637 call fooR(AINT(R1))
15638 c FFEINTRIN_impALOG
15639 call fooR(ALOG(R1))
15640 c FFEINTRIN_impALOG10
15641 call fooR(ALOG10(R1))
15642 c FFEINTRIN_impAMAX0
15643 call fooR(AMAX0(I1,I2))
15644 c FFEINTRIN_impAMAX1
15645 call fooR(AMAX1(R1,R2))
15646 c FFEINTRIN_impAMIN0
15647 call fooR(AMIN0(I1,I2))
15648 c FFEINTRIN_impAMIN1
15649 call fooR(AMIN1(R1,R2))
15650 c FFEINTRIN_impAMOD
15651 call fooR(AMOD(R1,R2))
15652 c FFEINTRIN_impANINT
15653 call fooR(ANINT(R1))
15654 c FFEINTRIN_impASIN
15655 call fooR(ASIN(R1))
15656 c FFEINTRIN_impATAN
15657 call fooR(ATAN(R1))
15658 c FFEINTRIN_impATAN2
15659 call fooR(ATAN2(R1,R2))
15660 c FFEINTRIN_impCABS
15661 call fooR(CABS(C1))
15662 c FFEINTRIN_impCCOS
15663 call fooC(CCOS(C1))
15664 c FFEINTRIN_impCEXP
15665 call fooC(CEXP(C1))
15666 c FFEINTRIN_impCHAR
15667 call fooA(CHAR(I1))
15668 c FFEINTRIN_impCLOG
15669 call fooC(CLOG(C1))
15670 c FFEINTRIN_impCONJG
15671 call fooC(CONJG(C1))
15674 c FFEINTRIN_impCOSH
15675 call fooR(COSH(R1))
15676 c FFEINTRIN_impCSIN
15677 call fooC(CSIN(C1))
15678 c FFEINTRIN_impCSQRT
15679 call fooC(CSQRT(C1))
15680 c FFEINTRIN_impDABS
15681 call fooD(DABS(D1))
15682 c FFEINTRIN_impDACOS
15683 call fooD(DACOS(D1))
15684 c FFEINTRIN_impDASIN
15685 call fooD(DASIN(D1))
15686 c FFEINTRIN_impDATAN
15687 call fooD(DATAN(D1))
15688 c FFEINTRIN_impDATAN2
15689 call fooD(DATAN2(D1,D2))
15690 c FFEINTRIN_impDCOS
15691 call fooD(DCOS(D1))
15692 c FFEINTRIN_impDCOSH
15693 call fooD(DCOSH(D1))
15694 c FFEINTRIN_impDDIM
15695 call fooD(DDIM(D1,D2))
15696 c FFEINTRIN_impDEXP
15697 call fooD(DEXP(D1))
15699 call fooR(DIM(R1,R2))
15700 c FFEINTRIN_impDINT
15701 call fooD(DINT(D1))
15702 c FFEINTRIN_impDLOG
15703 call fooD(DLOG(D1))
15704 c FFEINTRIN_impDLOG10
15705 call fooD(DLOG10(D1))
15706 c FFEINTRIN_impDMAX1
15707 call fooD(DMAX1(D1,D2))
15708 c FFEINTRIN_impDMIN1
15709 call fooD(DMIN1(D1,D2))
15710 c FFEINTRIN_impDMOD
15711 call fooD(DMOD(D1,D2))
15712 c FFEINTRIN_impDNINT
15713 call fooD(DNINT(D1))
15714 c FFEINTRIN_impDPROD
15715 call fooD(DPROD(R1,R2))
15716 c FFEINTRIN_impDSIGN
15717 call fooD(DSIGN(D1,D2))
15718 c FFEINTRIN_impDSIN
15719 call fooD(DSIN(D1))
15720 c FFEINTRIN_impDSINH
15721 call fooD(DSINH(D1))
15722 c FFEINTRIN_impDSQRT
15723 call fooD(DSQRT(D1))
15724 c FFEINTRIN_impDTAN
15725 call fooD(DTAN(D1))
15726 c FFEINTRIN_impDTANH
15727 call fooD(DTANH(D1))
15730 c FFEINTRIN_impIABS
15731 call fooI(IABS(I1))
15732 c FFEINTRIN_impICHAR
15733 call fooI(ICHAR(A1))
15734 c FFEINTRIN_impIDIM
15735 call fooI(IDIM(I1,I2))
15736 c FFEINTRIN_impIDNINT
15737 call fooI(IDNINT(D1))
15738 c FFEINTRIN_impINDEX
15739 call fooI(INDEX(A1,A2))
15740 c FFEINTRIN_impISIGN
15741 call fooI(ISIGN(I1,I2))
15745 call fooL(LGE(A1,A2))
15747 call fooL(LGT(A1,A2))
15749 call fooL(LLE(A1,A2))
15751 call fooL(LLT(A1,A2))
15752 c FFEINTRIN_impMAX0
15753 call fooI(MAX0(I1,I2))
15754 c FFEINTRIN_impMAX1
15755 call fooI(MAX1(R1,R2))
15756 c FFEINTRIN_impMIN0
15757 call fooI(MIN0(I1,I2))
15758 c FFEINTRIN_impMIN1
15759 call fooI(MIN1(R1,R2))
15761 call fooI(MOD(I1,I2))
15762 c FFEINTRIN_impNINT
15763 call fooI(NINT(R1))
15764 c FFEINTRIN_impSIGN
15765 call fooR(SIGN(R1,R2))
15768 c FFEINTRIN_impSINH
15769 call fooR(SINH(R1))
15770 c FFEINTRIN_impSQRT
15771 call fooR(SQRT(R1))
15774 c FFEINTRIN_impTANH
15775 call fooR(TANH(R1))
15776 c FFEINTRIN_imp_CMPLX_C
15777 call fooC(cmplx(C1,C2))
15778 c FFEINTRIN_imp_CMPLX_D
15779 call fooZ(cmplx(D1,D2))
15780 c FFEINTRIN_imp_CMPLX_I
15781 call fooC(cmplx(I1,I2))
15782 c FFEINTRIN_imp_CMPLX_R
15783 call fooC(cmplx(R1,R2))
15784 c FFEINTRIN_imp_DBLE_C
15785 call fooD(dble(C1))
15786 c FFEINTRIN_imp_DBLE_D
15787 call fooD(dble(D1))
15788 c FFEINTRIN_imp_DBLE_I
15789 call fooD(dble(I1))
15790 c FFEINTRIN_imp_DBLE_R
15791 call fooD(dble(R1))
15792 c FFEINTRIN_imp_INT_C
15794 c FFEINTRIN_imp_INT_D
15796 c FFEINTRIN_imp_INT_I
15798 c FFEINTRIN_imp_INT_R
15800 c FFEINTRIN_imp_REAL_C
15801 call fooR(real(C1))
15802 c FFEINTRIN_imp_REAL_D
15803 call fooR(real(D1))
15804 c FFEINTRIN_imp_REAL_I
15805 call fooR(real(I1))
15806 c FFEINTRIN_imp_REAL_R
15807 call fooR(real(R1))
15809 c FFEINTRIN_imp_INT_D:
15811 c FFEINTRIN_specIDINT
15812 call fooI(IDINT(D1))
15814 c FFEINTRIN_imp_INT_R:
15816 c FFEINTRIN_specIFIX
15817 call fooI(IFIX(R1))
15818 c FFEINTRIN_specINT
15821 c FFEINTRIN_imp_REAL_D:
15823 c FFEINTRIN_specSNGL
15824 call fooR(SNGL(D1))
15826 c FFEINTRIN_imp_REAL_I:
15828 c FFEINTRIN_specFLOAT
15829 call fooR(FLOAT(I1))
15830 c FFEINTRIN_specREAL
15831 call fooR(REAL(I1))
15834 -------- (end input file to f2c)
15836 -------- (begin output from providing above input file as input to:
15837 -------- `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
15838 -------- -e "s:^#.*$::g"')
15840 // -- translated by f2c (version 19950223).
15841 You must link the resulting object file with the libraries:
15842 -lf2c -lm (in that order)
15846 // f2c.h -- Standard Fortran to C header file //
15848 /// barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
15850 - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
15855 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
15856 // we assume short, float are OK //
15857 typedef long int // long int // integer;
15858 typedef char *address;
15859 typedef short int shortint;
15860 typedef float real;
15861 typedef double doublereal;
15862 typedef struct { real r, i; } complex;
15863 typedef struct { doublereal r, i; } doublecomplex;
15864 typedef long int // long int // logical;
15865 typedef short int shortlogical;
15866 typedef char logical1;
15867 typedef char integer1;
15868 // typedef long long longint; // // system-dependent //
15873 // Extern is for use with -E //
15887 typedef long int // int or long int // flag;
15888 typedef long int // int or long int // ftnlen;
15889 typedef long int // int or long int // ftnint;
15892 //external read, write//
15901 //internal read, write//
15931 //rewind, backspace, endfile//
15943 ftnint *inex; //parameters in standard's order//
15969 union Multitype { // for multiple entry points //
15980 typedef union Multitype Multitype;
15982 typedef long Long; // No longer used; formerly in Namelist //
15984 struct Vardesc { // for Namelist //
15990 typedef struct Vardesc Vardesc;
15997 typedef struct Namelist Namelist;
16006 // procedure parameter types for -A and -C++ //
16011 typedef int // Unknown procedure type // (*U_fp)();
16012 typedef shortint (*J_fp)();
16013 typedef integer (*I_fp)();
16014 typedef real (*R_fp)();
16015 typedef doublereal (*D_fp)(), (*E_fp)();
16016 typedef // Complex // void (*C_fp)();
16017 typedef // Double Complex // void (*Z_fp)();
16018 typedef logical (*L_fp)();
16019 typedef shortlogical (*K_fp)();
16020 typedef // Character // void (*H_fp)();
16021 typedef // Subroutine // int (*S_fp)();
16023 // E_fp is for real functions when -R is not specified //
16024 typedef void C_f; // complex function //
16025 typedef void H_f; // character function //
16026 typedef void Z_f; // double complex function //
16027 typedef doublereal E_f; // real function with -R not specified //
16029 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16032 // (No such symbols should be defined in a strict ANSI C compiler.
16033 We can avoid trouble with f2c-translated code by using
16058 // Main program // MAIN__()
16060 // System generated locals //
16063 doublereal d__1, d__2;
16065 doublecomplex z__1, z__2, z__3;
16069 // Builtin functions //
16072 double pow_ri(), pow_di();
16076 double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16077 asin(), atan(), atan2(), c_abs();
16078 void c_cos(), c_exp(), c_log(), r_cnjg();
16079 double cos(), cosh();
16080 void c_sin(), c_sqrt();
16081 double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16082 d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16083 integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16084 logical l_ge(), l_gt(), l_le(), l_lt();
16088 // Local variables //
16089 extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16090 fool_(), fooz_(), getem_();
16091 static char a1[10], a2[10];
16092 static complex c1, c2;
16093 static doublereal d1, d2;
16094 static integer i1, i2;
16095 static real r1, r2;
16098 getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16106 d__1 = (doublereal) i1;
16107 q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16117 c_div(&q__1, &c1, &c2);
16119 q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16121 z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16124 i__1 = pow_ii(&i1, &i2);
16126 r__1 = pow_ri(&r1, &i1);
16128 d__1 = pow_di(&d1, &i1);
16130 pow_ci(&q__1, &c1, &i1);
16132 d__1 = (doublereal) r1;
16133 d__2 = (doublereal) r2;
16134 r__1 = pow_dd(&d__1, &d__2);
16136 d__2 = (doublereal) r1;
16137 d__1 = pow_dd(&d__2, &d1);
16139 d__1 = pow_dd(&d1, &d2);
16141 d__2 = (doublereal) r1;
16142 d__1 = pow_dd(&d1, &d__2);
16144 z__2.r = c1.r, z__2.i = c1.i;
16145 z__3.r = c2.r, z__3.i = c2.i;
16146 pow_zz(&z__1, &z__2, &z__3);
16147 q__1.r = z__1.r, q__1.i = z__1.i;
16149 z__2.r = c1.r, z__2.i = c1.i;
16150 z__3.r = r1, z__3.i = 0.;
16151 pow_zz(&z__1, &z__2, &z__3);
16152 q__1.r = z__1.r, q__1.i = z__1.i;
16154 z__2.r = c1.r, z__2.i = c1.i;
16155 z__3.r = d1, z__3.i = 0.;
16156 pow_zz(&z__1, &z__2, &z__3);
16158 // FFEINTRIN_impABS //
16159 r__1 = (doublereal)(( r1 ) >= 0 ? ( r1 ) : -( r1 )) ;
16161 // FFEINTRIN_impACOS //
16164 // FFEINTRIN_impAIMAG //
16165 r__1 = r_imag(&c1);
16167 // FFEINTRIN_impAINT //
16170 // FFEINTRIN_impALOG //
16173 // FFEINTRIN_impALOG10 //
16174 r__1 = r_lg10(&r1);
16176 // FFEINTRIN_impAMAX0 //
16177 r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16179 // FFEINTRIN_impAMAX1 //
16180 r__1 = (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16182 // FFEINTRIN_impAMIN0 //
16183 r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16185 // FFEINTRIN_impAMIN1 //
16186 r__1 = (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16188 // FFEINTRIN_impAMOD //
16189 r__1 = r_mod(&r1, &r2);
16191 // FFEINTRIN_impANINT //
16192 r__1 = r_nint(&r1);
16194 // FFEINTRIN_impASIN //
16197 // FFEINTRIN_impATAN //
16200 // FFEINTRIN_impATAN2 //
16201 r__1 = atan2(r1, r2);
16203 // FFEINTRIN_impCABS //
16206 // FFEINTRIN_impCCOS //
16209 // FFEINTRIN_impCEXP //
16212 // FFEINTRIN_impCHAR //
16213 *(unsigned char *)&ch__1[0] = i1;
16215 // FFEINTRIN_impCLOG //
16218 // FFEINTRIN_impCONJG //
16219 r_cnjg(&q__1, &c1);
16221 // FFEINTRIN_impCOS //
16224 // FFEINTRIN_impCOSH //
16227 // FFEINTRIN_impCSIN //
16230 // FFEINTRIN_impCSQRT //
16231 c_sqrt(&q__1, &c1);
16233 // FFEINTRIN_impDABS //
16234 d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16236 // FFEINTRIN_impDACOS //
16239 // FFEINTRIN_impDASIN //
16242 // FFEINTRIN_impDATAN //
16245 // FFEINTRIN_impDATAN2 //
16246 d__1 = atan2(d1, d2);
16248 // FFEINTRIN_impDCOS //
16251 // FFEINTRIN_impDCOSH //
16254 // FFEINTRIN_impDDIM //
16255 d__1 = d_dim(&d1, &d2);
16257 // FFEINTRIN_impDEXP //
16260 // FFEINTRIN_impDIM //
16261 r__1 = r_dim(&r1, &r2);
16263 // FFEINTRIN_impDINT //
16266 // FFEINTRIN_impDLOG //
16269 // FFEINTRIN_impDLOG10 //
16270 d__1 = d_lg10(&d1);
16272 // FFEINTRIN_impDMAX1 //
16273 d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16275 // FFEINTRIN_impDMIN1 //
16276 d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16278 // FFEINTRIN_impDMOD //
16279 d__1 = d_mod(&d1, &d2);
16281 // FFEINTRIN_impDNINT //
16282 d__1 = d_nint(&d1);
16284 // FFEINTRIN_impDPROD //
16285 d__1 = (doublereal) r1 * r2;
16287 // FFEINTRIN_impDSIGN //
16288 d__1 = d_sign(&d1, &d2);
16290 // FFEINTRIN_impDSIN //
16293 // FFEINTRIN_impDSINH //
16296 // FFEINTRIN_impDSQRT //
16299 // FFEINTRIN_impDTAN //
16302 // FFEINTRIN_impDTANH //
16305 // FFEINTRIN_impEXP //
16308 // FFEINTRIN_impIABS //
16309 i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
16311 // FFEINTRIN_impICHAR //
16312 i__1 = *(unsigned char *)a1;
16314 // FFEINTRIN_impIDIM //
16315 i__1 = i_dim(&i1, &i2);
16317 // FFEINTRIN_impIDNINT //
16318 i__1 = i_dnnt(&d1);
16320 // FFEINTRIN_impINDEX //
16321 i__1 = i_indx(a1, a2, 10L, 10L);
16323 // FFEINTRIN_impISIGN //
16324 i__1 = i_sign(&i1, &i2);
16326 // FFEINTRIN_impLEN //
16327 i__1 = i_len(a1, 10L);
16329 // FFEINTRIN_impLGE //
16330 L__1 = l_ge(a1, a2, 10L, 10L);
16332 // FFEINTRIN_impLGT //
16333 L__1 = l_gt(a1, a2, 10L, 10L);
16335 // FFEINTRIN_impLLE //
16336 L__1 = l_le(a1, a2, 10L, 10L);
16338 // FFEINTRIN_impLLT //
16339 L__1 = l_lt(a1, a2, 10L, 10L);
16341 // FFEINTRIN_impMAX0 //
16342 i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16344 // FFEINTRIN_impMAX1 //
16345 i__1 = (integer) (doublereal)(( r1 ) >= ( r2 ) ? ( r1 ) : ( r2 )) ;
16347 // FFEINTRIN_impMIN0 //
16348 i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16350 // FFEINTRIN_impMIN1 //
16351 i__1 = (integer) (doublereal)(( r1 ) <= ( r2 ) ? ( r1 ) : ( r2 )) ;
16353 // FFEINTRIN_impMOD //
16356 // FFEINTRIN_impNINT //
16357 i__1 = i_nint(&r1);
16359 // FFEINTRIN_impSIGN //
16360 r__1 = r_sign(&r1, &r2);
16362 // FFEINTRIN_impSIN //
16365 // FFEINTRIN_impSINH //
16368 // FFEINTRIN_impSQRT //
16371 // FFEINTRIN_impTAN //
16374 // FFEINTRIN_impTANH //
16377 // FFEINTRIN_imp_CMPLX_C //
16380 q__1.r = r__1, q__1.i = r__2;
16382 // FFEINTRIN_imp_CMPLX_D //
16383 z__1.r = d1, z__1.i = d2;
16385 // FFEINTRIN_imp_CMPLX_I //
16388 q__1.r = r__1, q__1.i = r__2;
16390 // FFEINTRIN_imp_CMPLX_R //
16391 q__1.r = r1, q__1.i = r2;
16393 // FFEINTRIN_imp_DBLE_C //
16394 d__1 = (doublereal) c1.r;
16396 // FFEINTRIN_imp_DBLE_D //
16399 // FFEINTRIN_imp_DBLE_I //
16400 d__1 = (doublereal) i1;
16402 // FFEINTRIN_imp_DBLE_R //
16403 d__1 = (doublereal) r1;
16405 // FFEINTRIN_imp_INT_C //
16406 i__1 = (integer) c1.r;
16408 // FFEINTRIN_imp_INT_D //
16409 i__1 = (integer) d1;
16411 // FFEINTRIN_imp_INT_I //
16414 // FFEINTRIN_imp_INT_R //
16415 i__1 = (integer) r1;
16417 // FFEINTRIN_imp_REAL_C //
16420 // FFEINTRIN_imp_REAL_D //
16423 // FFEINTRIN_imp_REAL_I //
16426 // FFEINTRIN_imp_REAL_R //
16430 // FFEINTRIN_imp_INT_D: //
16432 // FFEINTRIN_specIDINT //
16433 i__1 = (integer) d1;
16436 // FFEINTRIN_imp_INT_R: //
16438 // FFEINTRIN_specIFIX //
16439 i__1 = (integer) r1;
16441 // FFEINTRIN_specINT //
16442 i__1 = (integer) r1;
16445 // FFEINTRIN_imp_REAL_D: //
16447 // FFEINTRIN_specSNGL //
16451 // FFEINTRIN_imp_REAL_I: //
16453 // FFEINTRIN_specFLOAT //
16456 // FFEINTRIN_specREAL //
16462 -------- (end output file from f2c)
16466 #include "gt-f-com.h"
16467 #include "gtype-f.h"